(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*<*)
theory Chapter3_HoareHeap
imports "../../AutoCorres"
begin
(*>*)

subsection {* \texttt{swap} *}

text {*

  Here, we use AutoCorres to verify a C program that reads and writes to the heap.
  Our C function, \texttt{swap}, swaps two words in memory:

\lstinputlisting[language=C, firstline=5]{../../swap.c}

  Again, we translate the program using the C parser and AutoCorres.
*}

install_C_file "swap.c"
autocorres [heap_abs_syntax, ts_rules = nondet] "swap.c"
(*<*)
context swap begin
(*>*)

text {*
  Most heap operations in C programs consist of accessing a pointer.
  AutoCorres abstracts the global C heap by creating one heap for
  each type. (In our simple \texttt{swap} example, it creates only
  a @{typ word32} heap.) This makes verification easier as long as
  the program does not access the same memory as two different types.

  There are other operations that are relevant to program verification,
  such as changing the type that occupies a given region of memory.
  AutoCorres will not abstract any functions that use these operations,
  so verifying them will be more complicated (but still possible).
*}

text {*
  The C parser expresses \texttt{swap} like this:
*}

thm swap_body_def
text {* @{thm [display] swap_body_def} *}

text {*
  AutoCorres abstracts the function to this:
*}

thm swap'_def
text {* @{thm [display] swap'_def } *}

text {*
  There are some things to note:

  The function contains guards (assertions) that the pointers
  \texttt{a} and \texttt{b} are valid. We need to prove that
  these guards never fail when verifying \texttt{swap}.
  Conversely, when verifying any function that calls
  \texttt{swap}, we need to show that the arguments are
  valid pointers.

  We saw a monadic program in the previous section, but here
  the monad is actually being used to carry the program heap.

  \emph{(Something about heap syntax here.)}
*}

text {*
  Now we prove that \texttt{swap} is correct. We use @{term x}
  and @{term y} to ``remember'' the initial values so that we can
  talk about them in the postcondition.
*}
lemma "\<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply clarsimp
  txt {*
    The C parser and AutoCorres both model the C heap using functions,
    which takes a pointer to some object in memory. Heap updates are
    modelled using the functional update @{term fun_upd}:

      @{thm [display] fun_upd_def}

    To reason about functional updates, we use the rule fun\_upd\_apply.
  *}
  apply (simp add: fun_upd_apply)
  done

text {*
  Note that we have ``only'' proved that the function swaps its
  arguments. We have not proved that it does \emph{not} change
  any other state. This is a typical \emph{frame problem} with
  pointer reasoning. We can prove a more complete specification
  of \texttt{swap}:
*}
lemma "(\<And>x y s. P (s[a := x][b := y]) = P s) \<Longrightarrow>
       \<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<and> P s \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<and> P s \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

text {*
  In other words, if predicate @{term P} does not depend on the
  inputs to \texttt{swap}, it will continue to hold.

  \emph{Separation logic} provides a more structured approach
  to this problem.
*}

(*<*)
end
end
(*>*)


(*  Title:      HOL/HOLCF/Cfun.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of continuous functions\<close>

theory Cfun
imports Cpodef Fun_Cpo Product_Cpo
begin

default_sort cpo

subsection \<open>Definition of continuous function type\<close>

definition "cfun = {f::'a => 'b. cont f}"

cpodef ('a, 'b) cfun ("(_ \<rightarrow>/ _)" [1, 0] 0) = "cfun :: ('a => 'b) set"
  unfolding cfun_def by (auto intro: cont_const adm_cont)

type_notation (ASCII)
  cfun  (infixr "->" 0)

notation (ASCII)
  Rep_cfun  ("(_$/_)" [999,1000] 999)

notation
  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)

subsection \<open>Syntax for continuous lambda abstraction\<close>

syntax "_cabs" :: "[logic, logic] \<Rightarrow> logic"

parse_translation \<open>
(* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
  [Syntax_Trans.mk_binder_tr (@{syntax_const "_cabs"}, @{const_syntax Abs_cfun})];
\<close>

print_translation \<open>
  [(@{const_syntax Abs_cfun}, fn _ => fn [Abs abs] =>
      let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
      in Syntax.const @{syntax_const "_cabs"} $ x $ t end)]
\<close>  \<comment> \<open>To avoid eta-contraction of body\<close>

text \<open>Syntax for nested abstractions\<close>

syntax (ASCII)
  "_Lambda" :: "[cargs, logic] \<Rightarrow> logic"  ("(3LAM _./ _)" [1000, 10] 10)

syntax
  "_Lambda" :: "[cargs, logic] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)

parse_ast_translation \<open>
(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
  let
    fun Lambda_ast_tr [pats, body] =
          Ast.fold_ast_p @{syntax_const "_cabs"}
            (Ast.unfold_ast @{syntax_const "_cargs"} (Ast.strip_positions pats), body)
      | Lambda_ast_tr asts = raise Ast.AST ("Lambda_ast_tr", asts);
  in [(@{syntax_const "_Lambda"}, K Lambda_ast_tr)] end;
\<close>

print_ast_translation \<open>
(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
  let
    fun cabs_ast_tr' asts =
      (case Ast.unfold_ast_p @{syntax_const "_cabs"}
          (Ast.Appl (Ast.Constant @{syntax_const "_cabs"} :: asts)) of
        ([], _) => raise Ast.AST ("cabs_ast_tr'", asts)
      | (xs, body) => Ast.Appl
          [Ast.Constant @{syntax_const "_Lambda"},
           Ast.fold_ast @{syntax_const "_cargs"} xs, body]);
  in [(@{syntax_const "_cabs"}, K cabs_ast_tr')] end
\<close>

text \<open>Dummy patterns for continuous abstraction\<close>
translations
  "\<Lambda> _. t" => "CONST Abs_cfun (\<lambda> _. t)"

subsection \<open>Continuous function space is pointed\<close>

lemma bottom_cfun: "\<bottom> \<in> cfun"
by (simp add: cfun_def inst_fun_pcpo)

instance cfun :: (cpo, discrete_cpo) discrete_cpo
by intro_classes (simp add: below_cfun_def Rep_cfun_inject)

instance cfun :: (cpo, pcpo) pcpo
by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def bottom_cfun])

lemmas Rep_cfun_strict =
  typedef_Rep_strict [OF type_definition_cfun below_cfun_def bottom_cfun]

lemmas Abs_cfun_strict =
  typedef_Abs_strict [OF type_definition_cfun below_cfun_def bottom_cfun]

text \<open>function application is strict in its first argument\<close>

lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
by (simp add: Rep_cfun_strict)

lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)

text \<open>for compatibility with old HOLCF-Version\<close>
lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
by simp

subsection \<open>Basic properties of continuous functions\<close>

text \<open>Beta-equality for continuous functions\<close>

lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
by (simp add: Abs_cfun_inverse cfun_def)

lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
by (simp add: Abs_cfun_inverse2)

text \<open>Beta-reduction simproc\<close>

text \<open>
  Given the term @{term "(\<Lambda> x. f x)\<cdot>y"}, the procedure tries to
  construct the theorem @{term "(\<Lambda> x. f x)\<cdot>y == f y"}.  If this
  theorem cannot be completely solved by the cont2cont rules, then
  the procedure returns the ordinary conditional \<open>beta_cfun\<close>
  rule.

  The simproc does not solve any more goals that would be solved by
  using \<open>beta_cfun\<close> as a simp rule.  The advantage of the
  simproc is that it can avoid deeply-nested calls to the simplifier
  that would otherwise be caused by large continuity side conditions.

  Update: The simproc now uses rule \<open>Abs_cfun_inverse2\<close> instead
  of \<open>beta_cfun\<close>, to avoid problems with eta-contraction.
\<close>

simproc_setup beta_cfun_proc ("Rep_cfun (Abs_cfun f)") = \<open>
  fn phi => fn ctxt => fn ct =>
    let
      val dest = Thm.dest_comb;
      val f = (snd o dest o snd o dest) ct;
      val [T, U] = Thm.dest_ctyp (Thm.ctyp_of_cterm f);
      val tr = Thm.instantiate' [SOME T, SOME U] [SOME f]
          (mk_meta_eq @{thm Abs_cfun_inverse2});
      val rules = Named_Theorems.get ctxt @{named_theorems cont2cont};
      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac ctxt (rev rules)));
    in SOME (perhaps (SINGLE (tac 1)) tr) end
\<close>

text \<open>Eta-equality for continuous functions\<close>

lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
by (rule Rep_cfun_inverse)

text \<open>Extensionality for continuous functions\<close>

lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)

lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
by (simp add: cfun_eq_iff)

text \<open>Extensionality wrt. ordering for continuous functions\<close>

lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
by (simp add: below_cfun_def fun_below_iff)

lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
by (simp add: cfun_below_iff)

text \<open>Congruence for continuous function application\<close>

lemma cfun_cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f\<cdot>x = g\<cdot>y"
by simp

lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
by simp

lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
by simp

subsection \<open>Continuity of application\<close>

lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
by (rule cont_Rep_cfun [OF cont_id, THEN cont2cont_fun])

lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
apply (cut_tac x=f in Rep_cfun)
apply (simp add: cfun_def)
done

lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]

lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono]
lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono]

text \<open>contlub, cont properties of @{term Rep_cfun} in each argument\<close>

lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
by (rule cont_Rep_cfun2 [THEN cont2contlubE])

lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
by (rule cont_Rep_cfun1 [THEN cont2contlubE])

text \<open>monotonicity of application\<close>

lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
by (simp add: cfun_below_iff)

lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
by (rule monofun_Rep_cfun2 [THEN monofunE])

lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])

text \<open>ch2ch - rules for the type @{typ "'a -> 'b"}\<close>

lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfun [simp]:
  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
by (simp add: chain_def monofun_cfun)

lemma ch2ch_LAM [simp]:
  "\<lbrakk>\<And>x. chain (\<lambda>i. S i x); \<And>i. cont (\<lambda>x. S i x)\<rbrakk> \<Longrightarrow> chain (\<lambda>i. \<Lambda> x. S i x)"
by (simp add: chain_def cfun_below_iff)

text \<open>contlub, cont properties of @{term Rep_cfun} in both arguments\<close>

lemma lub_APP:
  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> (\<Squnion>i. F i\<cdot>(Y i)) = (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i)"
by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)

lemma lub_LAM:
  "\<lbrakk>\<And>x. chain (\<lambda>i. F i x); \<And>i. cont (\<lambda>x. F i x)\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. \<Lambda> x. F i x) = (\<Lambda> x. \<Squnion>i. F i x)"
by (simp add: lub_cfun lub_fun ch2ch_lambda)

lemmas lub_distribs = lub_APP lub_LAM

text \<open>strictness\<close>

lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
apply (rule bottomI)
apply (erule subst)
apply (rule minimal [THEN monofun_cfun_arg])
done

text \<open>type @{typ "'a -> 'b"} is chain complete\<close>

lemma lub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
by (simp add: lub_cfun lub_fun ch2ch_lambda)

subsection \<open>Continuity simplification procedure\<close>

text \<open>cont2cont lemma for @{term Rep_cfun}\<close>

lemma cont2cont_APP [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes t: "cont (\<lambda>x. t x)"
  shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
proof -
  have 1: "\<And>y. cont (\<lambda>x. (f x)\<cdot>y)"
    using cont_Rep_cfun1 f by (rule cont_compose)
  show "cont (\<lambda>x. (f x)\<cdot>(t x))"
    using t cont_Rep_cfun2 1 by (rule cont_apply)
qed

text \<open>
  Two specific lemmas for the combination of LCF and HOL terms.
  These lemmas are needed in theories that use types like @{typ "'a \<rightarrow> 'b \<Rightarrow> 'c"}.
\<close>

lemma cont_APP_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
by (rule cont2cont_APP [THEN cont2cont_fun])

lemma cont_APP_app_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
by (rule cont_APP_app [THEN cont2cont_fun])

text \<open>cont2mono Lemma for @{term "%x. LAM y. c1(x)(y)"}\<close>

lemma cont2mono_LAM:
  "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
    \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
  unfolding monofun_def cfun_below_iff by simp

text \<open>cont2cont Lemma for @{term "%x. LAM y. f x y"}\<close>

text \<open>
  Not suitable as a cont2cont rule, because on nested lambdas
  it causes exponential blow-up in the number of subgoals.
\<close>

lemma cont2cont_LAM:
  assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
  assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
proof (rule cont_Abs_cfun)
  fix x
  from f1 show "f x \<in> cfun" by (simp add: cfun_def)
  from f2 show "cont f" by (rule cont2cont_lambda)
qed

text \<open>
  This version does work as a cont2cont rule, since it
  has only a single subgoal.
\<close>

lemma cont2cont_LAM' [simp, cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
using assms by (simp add: cont2cont_LAM prod_cont_iff)

lemma cont2cont_LAM_discrete [simp, cont2cont]:
  "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
by (simp add: cont2cont_LAM)

subsection \<open>Miscellaneous\<close>

text \<open>Monotonicity of @{term Abs_cfun}\<close>

lemma monofun_LAM:
  "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
by (simp add: cfun_below_iff)

text \<open>some lemmata for functions with flat/chfin domain/range types\<close>

lemma chfin_Rep_cfunR: "chain (Y::nat => 'a::cpo->'b::chfin)
      ==> !s. ? n. (LUB i. Y i)\<cdot>s = Y n\<cdot>s"
apply (rule allI)
apply (subst contlub_cfun_fun)
apply assumption
apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
done

lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
by (rule adm_subst, simp, rule adm_chfin)

subsection \<open>Continuous injection-retraction pairs\<close>

text \<open>Continuous retractions are strict.\<close>

lemma retraction_strict:
  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
apply (rule bottomI)
apply (drule_tac x="\<bottom>" in spec)
apply (erule subst)
apply (rule monofun_cfun_arg)
apply (rule minimal)
done

lemma injection_eq:
  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
apply (rule iffI)
apply (drule_tac f=f in cfun_arg_cong)
apply simp
apply simp
done

lemma injection_below:
  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
apply (rule iffI)
apply (drule_tac f=f in monofun_cfun_arg)
apply simp
apply (erule monofun_cfun_arg)
done

lemma injection_defined_rev:
  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; g\<cdot>z = \<bottom>\<rbrakk> \<Longrightarrow> z = \<bottom>"
apply (drule_tac f=f in cfun_arg_cong)
apply (simp add: retraction_strict)
done

lemma injection_defined:
  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; z \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
by (erule contrapos_nn, rule injection_defined_rev)

text \<open>a result about functions with flat codomain\<close>

lemma flat_eqI: "\<lbrakk>(x::'a::flat) \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> x = y"
by (drule ax_flat, simp)

lemma flat_codom:
  "f\<cdot>x = (c::'b::flat) \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
apply (case_tac "f\<cdot>x = \<bottom>")
apply (rule disjI1)
apply (rule bottomI)
apply (erule_tac t="\<bottom>" in subst)
apply (rule minimal [THEN monofun_cfun_arg])
apply clarify
apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
done

subsection \<open>Identity and composition\<close>

definition
  ID :: "'a \<rightarrow> 'a" where
  "ID = (\<Lambda> x. x)"

definition
  cfcomp  :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c" where
  oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"

abbreviation
  cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "oo" 100)  where
  "f oo g == cfcomp\<cdot>f\<cdot>g"

lemma ID1 [simp]: "ID\<cdot>x = x"
by (simp add: ID_def)

lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
by (simp add: oo_def)

lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
by (simp add: cfcomp1)

lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
by (simp add: cfcomp1)

lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
by (simp add: cfun_eq_iff)

text \<open>
  Show that interpretation of (pcpo,\<open>_->_\<close>) is a category.
  The class of objects is interpretation of syntactical class pcpo.
  The class of arrows  between objects @{typ 'a} and @{typ 'b} is interpret. of @{typ "'a -> 'b"}.
  The identity arrow is interpretation of @{term ID}.
  The composition of f and g is interpretation of \<open>oo\<close>.
\<close>

lemma ID2 [simp]: "f oo ID = f"
by (rule cfun_eqI, simp)

lemma ID3 [simp]: "ID oo f = f"
by (rule cfun_eqI, simp)

lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
by (rule cfun_eqI, simp)

subsection \<open>Strictified functions\<close>

default_sort pcpo

definition
  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b" where
  "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"

lemma cont2cont_if_bottom [cont2cont, simp]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. if f x = \<bottom> then \<bottom> else g x)"
proof (rule cont_apply [OF f])
  show "\<And>x. cont (\<lambda>y. if y = \<bottom> then \<bottom> else g x)"
    unfolding cont_def is_lub_def is_ub_def ball_simps
    by (simp add: lub_eq_bottom_iff)
  show "\<And>y. cont (\<lambda>x. if y = \<bottom> then \<bottom> else g x)"
    by (simp add: g)
qed

lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
unfolding seq_def by simp

lemma seq_simps [simp]:
  "seq\<cdot>\<bottom> = \<bottom>"
  "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
  "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
by (simp_all add: seq_conv_if)

definition
  strictify  :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b" where
  "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"

lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
unfolding strictify_def by simp

lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (simp add: strictify_conv_if)

lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
by (simp add: strictify_conv_if)

subsection \<open>Continuity of let-bindings\<close>

lemma cont2cont_Let:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
  assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
  shows "cont (\<lambda>x. let y = f x in g x y)"
unfolding Let_def using f g2 g1 by (rule cont_apply)

lemma cont2cont_Let' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
  shows "cont (\<lambda>x. let y = f x in g x y)"
using f
proof (rule cont2cont_Let)
  fix x show "cont (\<lambda>y. g x y)"
    using g by (simp add: prod_cont_iff)
next
  fix y show "cont (\<lambda>x. g x y)"
    using g by (simp add: prod_cont_iff)
qed

text \<open>The simple version (suggested by Joachim Breitner) is needed if
  the type of the defined term is not a cpo.\<close>

lemma cont2cont_Let_simple [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. g x y)"
  shows "cont (\<lambda>x. let y = t in g x y)"
unfolding Let_def using assms .

end


(*  Title:       Ground Ordered Resolution Calculus with Selection
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2016, 2017
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Ground Ordered Resolution Calculus with Selection\<close>

theory Ordered_Ground_Resolution
  imports Inference_System Ground_Resolution_Model
begin

text \<open>
Ordered ground resolution with selection is the second inference system studied in Section~3
(``Standard Resolution'') of Bachmair and Ganzinger's chapter.
\<close>

subsection \<open>Inference Rule\<close>

text \<open>
Ordered ground resolution consists of a single rule, called \<open>ord_resolve\<close> below. Like
\<open>unord_resolve\<close>, the rule is sound and counterexample-reducing. In addition, it is reductive.
\<close>

context ground_resolution_with_selection
begin

text \<open>
The following inductive definition corresponds to Figure 2.
\<close>

definition maximal_wrt :: "'a \<Rightarrow> 'a literal multiset \<Rightarrow> bool" where
  "maximal_wrt A DA \<longleftrightarrow> DA = {#} \<or> A = Max (atms_of DA)"

definition strictly_maximal_wrt :: "'a \<Rightarrow> 'a literal multiset \<Rightarrow> bool" where
  "strictly_maximal_wrt A CA \<longleftrightarrow> (\<forall>B \<in> atms_of CA. B < A)"

inductive eligible :: "'a list \<Rightarrow> 'a clause \<Rightarrow> bool" where
  eligible: "(S DA = negs (mset As)) \<or> (S DA = {#} \<and> length As = 1 \<and> maximal_wrt (As ! 0) DA) \<Longrightarrow>
    eligible As DA"

lemma "(S DA = negs (mset As) \<or> S DA = {#} \<and> length As = 1 \<and> maximal_wrt (As ! 0) DA) \<longleftrightarrow>
    eligible As DA"
  using eligible.intros ground_resolution_with_selection.eligible.cases ground_resolution_with_selection_axioms by blast

inductive
  ord_resolve :: "'a clause list \<Rightarrow> 'a clause \<Rightarrow> 'a multiset list \<Rightarrow> 'a list \<Rightarrow> 'a clause \<Rightarrow> bool"
where
  ord_resolve:
    "length CAs = n \<Longrightarrow>
     length Cs = n \<Longrightarrow>
     length AAs = n \<Longrightarrow>
     length As = n \<Longrightarrow>
     n \<noteq> 0 \<Longrightarrow>
     (\<forall>i < n. CAs ! i = Cs ! i + poss (AAs ! i)) \<Longrightarrow>
     (\<forall>i < n. AAs ! i \<noteq> {#}) \<Longrightarrow>
     (\<forall>i < n. \<forall>A \<in># AAs ! i. A = As ! i) \<Longrightarrow>
     eligible As (D + negs (mset As)) \<Longrightarrow>
     (\<forall>i < n. strictly_maximal_wrt (As ! i) (Cs ! i)) \<Longrightarrow>
     (\<forall>i < n. S (CAs ! i) = {#}) \<Longrightarrow>
     ord_resolve CAs (D + negs (mset As)) AAs As (\<Sum>\<^sub># (mset Cs) + D)"

lemma ord_resolve_sound:
  assumes
    res_e: "ord_resolve CAs DA AAs As E" and
    cc_true: "I \<Turnstile>m mset CAs" and
    d_true: "I \<Turnstile> DA"
  shows "I \<Turnstile> E"
  using res_e
proof (cases rule: ord_resolve.cases)
  case (ord_resolve n Cs D)
  note DA = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4) and
    as_len = this(6) and cas = this(8) and aas_ne = this(9) and a_eq = this(10)

  show ?thesis
  proof (cases "\<forall>A \<in> set As. A \<in> I")
    case True
    then have "\<not> I \<Turnstile> negs (mset As)"
      unfolding true_cls_def by fastforce
    then have "I \<Turnstile> D"
      using d_true DA by fast
    then show ?thesis
      unfolding e by blast
  next
    case False
    then obtain i where
      a_in_aa: "i < n" and
      a_false: "As ! i \<notin> I"
      using cas_len as_len by (metis in_set_conv_nth)
    have "\<not> I \<Turnstile> poss (AAs ! i)"
      using a_false a_eq aas_ne a_in_aa unfolding true_cls_def by auto
    moreover have "I \<Turnstile> CAs ! i"
      using a_in_aa cc_true unfolding true_cls_mset_def using cas_len by auto
    ultimately have "I \<Turnstile> Cs ! i"
      using cas a_in_aa by auto
    then show ?thesis
      using a_in_aa cs_len unfolding e true_cls_def
      by (meson in_Union_mset_iff nth_mem_mset union_iff)
  qed
qed

lemma filter_neg_atm_of_S: "{#Neg (atm_of L). L \<in># S C#} = S C"
  by (simp add: S_selects_neg_lits)

text \<open>
This corresponds to Lemma 3.13:
\<close>

lemma ord_resolve_reductive:
  assumes "ord_resolve CAs DA AAs As E"
  shows "E < DA"
  using assms
proof (cases rule: ord_resolve.cases)
  case (ord_resolve n Cs D)
  note DA = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4) and
    ai_len = this(6) and nz = this(7) and cas = this(8) and maxim = this(12)

  show ?thesis
  proof (cases "\<Sum>\<^sub># (mset Cs) = {#}")
    case True
    have "negs (mset As) \<noteq> {#}"
       using nz ai_len by auto
    then show ?thesis
       unfolding True e DA by auto
  next
    case False

    define max_A_of_Cs where
      "max_A_of_Cs = Max (atms_of (\<Sum>\<^sub># (mset Cs)))"

    have
      mc_in: "max_A_of_Cs \<in> atms_of (\<Sum>\<^sub># (mset Cs))" and
      mc_max: "\<And>B. B \<in> atms_of (\<Sum>\<^sub># (mset Cs)) \<Longrightarrow> B \<le> max_A_of_Cs"
      using max_A_of_Cs_def False by auto

    then have "\<exists>C_max \<in> set Cs. max_A_of_Cs \<in> atms_of (C_max)"
      by (metis atm_imp_pos_or_neg_lit in_Union_mset_iff neg_lit_in_atms_of pos_lit_in_atms_of
          set_mset_mset)
    then obtain max_i where
      cm_in_cas: "max_i < length CAs" and
      mc_in_cm: "max_A_of_Cs \<in> atms_of (Cs ! max_i)"
      using in_set_conv_nth[of _ CAs] by (metis cas_len cs_len in_set_conv_nth)

    define CA_max where "CA_max = CAs ! max_i"
    define A_max where "A_max = As ! max_i"
    define C_max where "C_max = Cs ! max_i"

    have mc_lt_ma: "max_A_of_Cs < A_max"
      using maxim cm_in_cas mc_in_cm cas_len unfolding strictly_maximal_wrt_def A_max_def by auto

    then have ucas_ne_neg_aa: "\<Sum>\<^sub># (mset Cs) \<noteq> negs (mset As)"
      using mc_in mc_max mc_lt_ma cm_in_cas cas_len ai_len unfolding A_max_def
      by (metis atms_of_negs nth_mem set_mset_mset leD)
    moreover have ucas_lt_ma: "\<forall>B \<in> atms_of (\<Sum>\<^sub># (mset Cs)). B < A_max"
      using mc_max mc_lt_ma by fastforce
    moreover have "\<not> Neg A_max \<in># \<Sum>\<^sub># (mset Cs)"
      using ucas_lt_ma neg_lit_in_atms_of[of A_max "\<Sum>\<^sub># (mset Cs)"] by auto
    moreover have "Neg A_max \<in># negs (mset As)"
      using cm_in_cas cas_len ai_len A_max_def by auto
    ultimately have "\<Sum>\<^sub># (mset Cs) < negs (mset As)"
      unfolding less_multiset\<^sub>H\<^sub>O
      by (metis (no_types) atms_less_eq_imp_lit_less_eq_neg count_greater_zero_iff
          count_inI le_imp_less_or_eq less_imp_not_less not_le)
    then show ?thesis
      unfolding e DA by auto
  qed
qed

text \<open>
This corresponds to Theorem 3.15:
\<close>

theorem ord_resolve_counterex_reducing:
  assumes
    ec_ni_n: "{#} \<notin> N" and
    d_in_n: "DA \<in> N" and
    d_cex: "\<not> INTERP N \<Turnstile> DA" and
    d_min: "\<And>C. C \<in> N \<Longrightarrow> \<not> INTERP N \<Turnstile> C \<Longrightarrow> DA \<le> C"
  obtains CAs AAs As E where
    "set CAs \<subseteq> N"
    "INTERP N \<Turnstile>m mset CAs"
    "\<And>CA. CA \<in> set CAs \<Longrightarrow> productive N CA"
    "ord_resolve CAs DA AAs As E"
    "\<not> INTERP N \<Turnstile> E"
    "E < DA"
proof -
  have d_ne: "DA \<noteq> {#}"
    using d_in_n ec_ni_n by blast
  have "\<exists>As. As \<noteq> [] \<and> negs (mset As) \<le># DA \<and> eligible As DA"
  proof (cases "S DA = {#}")
    assume s_d_e: "S DA = {#}"

    define A where "A = Max (atms_of DA)"
    define As where "As = [A]"
    define D where "D = DA-{#Neg A #}"

    have na_in_d: "Neg A \<in># DA"
      unfolding A_def using s_d_e d_ne d_in_n d_cex d_min
      by (metis Max_in_lits Max_lit_eq_pos_or_neg_Max_atm max_pos_imp_Interp Interp_imp_INTERP)
    then have das: "DA = D + negs (mset As)"
      unfolding D_def As_def by auto
    moreover from na_in_d have "negs (mset As) \<subseteq># DA"
      by (simp add: As_def)
    moreover have hd: "As ! 0 = Max (atms_of (D + negs (mset As)))"
      using A_def As_def das by auto
    then have "eligible As DA"
      using eligible s_d_e As_def das maximal_wrt_def by auto
    ultimately show ?thesis
      using As_def by blast
  next
    assume s_d_e: "S DA \<noteq> {#}"

    define As :: "'a list" where
      "As = list_of_mset {#atm_of L. L \<in># S DA#}"
    define D :: "'a clause" where
      "D = DA - negs {#atm_of L. L \<in># S DA#}"

    have "As \<noteq> []" unfolding As_def using s_d_e
      by (metis image_mset_is_empty_iff list_of_mset_empty)
    moreover have da_sub_as: "negs {#atm_of L. L \<in># S DA#} \<subseteq># DA"
      using S_selects_subseteq by (auto simp: filter_neg_atm_of_S)
    then have "negs (mset As) \<subseteq># DA"
      unfolding As_def by auto
    moreover have das: "DA = D + negs (mset As)"
      using da_sub_as unfolding D_def As_def by auto
    moreover have "S DA = negs {#atm_of L. L \<in># S DA#}"
      by (auto simp: filter_neg_atm_of_S)
    then have "S DA = negs (mset As)"
      unfolding As_def by auto
    then have "eligible As DA"
      unfolding das using eligible by auto
    ultimately show ?thesis
      by blast
  qed
  then obtain As :: "'a list" where
    as_ne: "As \<noteq> []" and
    negs_as_le_d: "negs (mset As) \<le># DA" and
    s_d: "eligible As DA"
    by blast

  define D :: "'a clause" where
    "D = DA - negs (mset As)"

  have "set As \<subseteq> INTERP N"
    using d_cex negs_as_le_d by force
  then have prod_ex: "\<forall>A \<in> set As. \<exists>D. produces N D A"
    unfolding INTERP_def
    by (metis (no_types, lifting) INTERP_def subsetCE UN_E not_produces_imp_notin_production)
  then have "\<And>A. \<exists>D. produces N D A \<longrightarrow> A \<in> set As"
    using ec_ni_n by (auto intro: productive_in_N)
  then have "\<And>A. \<exists>D. produces N D A \<longleftrightarrow> A \<in> set As"
    using prod_ex by blast
  then obtain CA_of where c_of0: "\<And>A. produces N (CA_of A) A \<longleftrightarrow> A \<in> set As"
    by metis
  then have prod_c0: "\<forall>A \<in> set As. produces N (CA_of A) A"
    by blast

  define C_of where
    "\<And>A. C_of A = {#L \<in># CA_of A. L \<noteq> Pos A#}"
  define Aj_of where
    "\<And>A. Aj_of A = image_mset atm_of {#L \<in># CA_of A. L = Pos A#}"

  have pospos: "\<And>LL A. {#Pos (atm_of x). x \<in># {#L \<in># LL. L = Pos A#}#} = {#L \<in># LL. L = Pos A#}"
    by (metis (mono_tags, lifting) image_filter_cong literal.sel(1) multiset.map_ident)
  have ca_of_c_of_aj_of: "\<And>A. CA_of A = C_of A + poss (Aj_of A)"
    using pospos[of _ "CA_of _"] by (simp add: C_of_def Aj_of_def)

  define n :: nat where
    "n = length As"
  define Cs :: "'a clause list" where
    "Cs = map C_of As"
  define AAs :: "'a multiset list" where
    "AAs = map Aj_of As"
  define CAs :: "'a literal multiset list" where
    "CAs = map CA_of As"

  have m_nz: "\<And>A. A \<in> set As \<Longrightarrow> Aj_of A \<noteq> {#}"
    unfolding Aj_of_def using prod_c0 produces_imp_Pos_in_lits
    by (metis (full_types) filter_mset_empty_conv image_mset_is_empty_iff)

  have prod_c: "productive N CA" if ca_in: "CA \<in> set CAs" for CA
  proof -
    obtain i where i_p: "i < length CAs" "CAs ! i = CA"
      using ca_in by (meson in_set_conv_nth)
    have "production N (CA_of (As ! i)) = {As ! i}"
      using i_p CAs_def prod_c0 by auto
    then show "productive N CA"
      using i_p CAs_def by auto
  qed
  then have cs_subs_n: "set CAs \<subseteq> N"
    using productive_in_N by auto
  have cs_true: "INTERP N \<Turnstile>m mset CAs"
    unfolding true_cls_mset_def using prod_c productive_imp_INTERP by auto

  have "\<And>A. A \<in> set As \<Longrightarrow> \<not> Neg A \<in># CA_of A"
    using prod_c0 produces_imp_neg_notin_lits by auto
  then have a_ni_c': "\<And>A. A \<in> set As \<Longrightarrow> A \<notin> atms_of (C_of A)"
    unfolding C_of_def using atm_imp_pos_or_neg_lit by force
  have c'_le_c: "\<And>A. C_of A \<le> CA_of A"
    unfolding C_of_def by (auto intro: subset_eq_imp_le_multiset)
  have a_max_c: "\<And>A. A \<in> set As \<Longrightarrow> A = Max (atms_of (CA_of A))"
    using prod_c0 productive_imp_produces_Max_atom[of N] by auto
  then have "\<And>A. A \<in> set As \<Longrightarrow> C_of A \<noteq> {#} \<Longrightarrow> Max (atms_of (C_of A)) \<le> A"
    using c'_le_c by (metis less_eq_Max_atms_of)
  moreover have "\<And>A. A \<in> set As \<Longrightarrow> C_of A \<noteq> {#} \<Longrightarrow> Max (atms_of (C_of A)) \<noteq> A"
    using a_ni_c' Max_in by (metis (no_types) atms_empty_iff_empty finite_atms_of)
  ultimately have max_c'_lt_a: "\<And>A. A \<in> set As \<Longrightarrow> C_of A \<noteq> {#} \<Longrightarrow> Max (atms_of (C_of A)) < A"
    by (metis order.strict_iff_order)

  have le_cs_as: "length CAs = length As"
    unfolding CAs_def by simp

  have "length CAs = n"
    by (simp add: le_cs_as n_def)
  moreover have "length Cs = n"
    by (simp add: Cs_def n_def)
  moreover have "length AAs = n"
    by (simp add: AAs_def n_def)
  moreover have "length As = n"
    using n_def by auto
  moreover have "n \<noteq> 0"
    by (simp add: as_ne n_def)
  moreover have " \<forall>i. i < length AAs \<longrightarrow> (\<forall>A \<in># AAs ! i. A = As ! i)"
    using AAs_def Aj_of_def by auto

  have "\<And>x B. production N (CA_of x) = {x} \<Longrightarrow> B \<in># CA_of x \<Longrightarrow> B \<noteq> Pos x \<Longrightarrow> atm_of B < x"
    by (metis atm_of_lit_in_atms_of insert_not_empty le_imp_less_or_eq Pos_atm_of_iff
        Neg_atm_of_iff pos_neg_in_imp_true produces_imp_Pos_in_lits produces_imp_atms_leq
        productive_imp_not_interp)
  then have "\<And>B A. A\<in>set As \<Longrightarrow> B \<in># CA_of A \<Longrightarrow> B \<noteq> Pos A \<Longrightarrow> atm_of B < A"
    using prod_c0 by auto
  have "\<forall>i. i < length AAs \<longrightarrow> AAs ! i \<noteq> {#}"
    unfolding AAs_def using m_nz by simp
  have "\<forall>i < n. CAs ! i = Cs ! i + poss (AAs ! i)"
    unfolding CAs_def Cs_def AAs_def using ca_of_c_of_aj_of by (simp add: n_def)

  moreover have "\<forall>i < n. AAs ! i \<noteq> {#}"
    using \<open>\<forall>i < length AAs. AAs ! i \<noteq> {#}\<close> calculation(3) by blast
  moreover have "\<forall>i < n. \<forall>A \<in># AAs ! i. A = As ! i"
    by (simp add: \<open>\<forall>i < length AAs. \<forall>A \<in># AAs ! i. A = As ! i\<close> calculation(3))
  moreover have "eligible As DA"
    using s_d by auto
  then have "eligible As (D + negs (mset As))"
    using D_def negs_as_le_d by auto
  moreover have "\<And>i. i < length AAs \<Longrightarrow> strictly_maximal_wrt (As ! i) ((Cs ! i))"
    by (simp add: C_of_def Cs_def \<open>\<And>x B. \<lbrakk>production N (CA_of x) = {x}; B \<in># CA_of x; B \<noteq> Pos x\<rbrakk> \<Longrightarrow> atm_of B < x\<close> atms_of_def calculation(3) n_def prod_c0 strictly_maximal_wrt_def)

  have "\<forall>i < n. strictly_maximal_wrt (As ! i) (Cs ! i)"
    by (simp add: \<open>\<And>i. i < length AAs \<Longrightarrow> strictly_maximal_wrt (As ! i) (Cs ! i)\<close> calculation(3))
  moreover have "\<forall>CA \<in> set CAs. S CA = {#}"
    using prod_c producesD productive_imp_produces_Max_literal by blast
  have "\<forall>CA\<in>set CAs. S CA = {#}"
    using \<open>\<forall>CA\<in>set CAs. S CA = {#}\<close> by simp
  then have "\<forall>i < n. S (CAs ! i) = {#}"
    using \<open>length CAs = n\<close> nth_mem by blast
  ultimately have res_e: "ord_resolve CAs (D + negs (mset As)) AAs As (\<Sum>\<^sub># (mset Cs) + D)"
    using ord_resolve by auto

  have "\<And>A. A \<in> set As \<Longrightarrow> \<not> interp N (CA_of A) \<Turnstile> CA_of A"
    by (simp add: prod_c0 producesD)
  then have "\<And>A. A \<in> set As \<Longrightarrow> \<not> Interp N (CA_of A) \<Turnstile> C_of A"
    unfolding prod_c0 C_of_def Interp_def true_cls_def using true_lit_def not_gr_zero prod_c0
    by auto
  then have c'_at_n: "\<And>A. A \<in> set As \<Longrightarrow> \<not> INTERP N \<Turnstile> C_of A"
    using a_max_c c'_le_c max_c'_lt_a not_Interp_imp_not_INTERP unfolding true_cls_def
    by (metis true_cls_def true_cls_empty)

  have "\<not> INTERP N \<Turnstile> \<Sum>\<^sub># (mset Cs)"
    unfolding Cs_def true_cls_def using c'_at_n by fastforce
  moreover have "\<not> INTERP N \<Turnstile> D"
    using d_cex by (metis D_def add_diff_cancel_right' negs_as_le_d subset_mset.add_diff_assoc2
        true_cls_def union_iff)
  ultimately have e_cex: "\<not> INTERP N \<Turnstile> \<Sum>\<^sub># (mset Cs) + D"
    by simp

  have "set CAs \<subseteq> N"
    by (simp add: cs_subs_n)
  moreover have "INTERP N \<Turnstile>m mset CAs"
    by (simp add: cs_true)
  moreover have "\<And>CA. CA \<in> set CAs \<Longrightarrow> productive N CA"
    by (simp add: prod_c)
  moreover have "ord_resolve CAs DA AAs As (\<Sum>\<^sub># (mset Cs) + D)"
    using D_def negs_as_le_d res_e by auto
  moreover have "\<not> INTERP N \<Turnstile> \<Sum>\<^sub># (mset Cs) + D"
    using e_cex by simp
  moreover have "\<Sum>\<^sub># (mset Cs) + D < DA"
    using calculation(4) ord_resolve_reductive by auto
  ultimately show thesis
    ..
qed

lemma ord_resolve_atms_of_concl_subset:
  assumes "ord_resolve CAs DA AAs As E"
  shows "atms_of E \<subseteq> (\<Union>C \<in> set CAs. atms_of C) \<union> atms_of DA"
  using assms
proof (cases rule: ord_resolve.cases)
  case (ord_resolve n Cs D)
  note DA = this(1) and e = this(2) and cas_len = this(3) and cs_len = this(4) and cas = this(8)

  have "\<forall>i < n. set_mset (Cs ! i) \<subseteq> set_mset (CAs ! i)"
    using cas by auto
  then have "\<forall>i < n. Cs ! i \<subseteq># \<Sum>\<^sub># (mset CAs)"
    by (metis cas cas_len mset_subset_eq_add_left nth_mem_mset sum_mset.remove union_assoc)
  then have "\<forall>C \<in> set Cs. C \<subseteq># \<Sum>\<^sub># (mset CAs)"
    using cs_len in_set_conv_nth[of _ Cs] by auto
  then have "set_mset (\<Sum>\<^sub># (mset Cs)) \<subseteq> set_mset (\<Sum>\<^sub># (mset CAs))"
    by auto (meson in_mset_sum_list2 mset_subset_eqD)
  then have "atms_of (\<Sum>\<^sub># (mset Cs)) \<subseteq> atms_of (\<Sum>\<^sub># (mset CAs))"
    by (meson lits_subseteq_imp_atms_subseteq mset_subset_eqD subsetI)
  moreover have "atms_of (\<Sum>\<^sub># (mset CAs)) = (\<Union>CA \<in> set CAs. atms_of CA)"
    by (intro set_eqI iffI, simp_all,
      metis in_mset_sum_list2 atm_imp_pos_or_neg_lit neg_lit_in_atms_of pos_lit_in_atms_of,
      metis in_mset_sum_list atm_imp_pos_or_neg_lit neg_lit_in_atms_of pos_lit_in_atms_of)
  ultimately have "atms_of (\<Sum>\<^sub># (mset Cs)) \<subseteq> (\<Union>CA \<in> set CAs. atms_of CA)"
    by auto
  moreover have "atms_of D \<subseteq> atms_of DA"
    using DA by auto
  ultimately show ?thesis
    unfolding e by auto
qed

subsection \<open>Inference System\<close>

text \<open>
Theorem 3.16 is subsumed in the counterexample-reducing inference system framework, which is
instantiated below. Unlike its unordered cousin, ordered resolution is additionally a reductive
inference system.
\<close>

definition ord_\<Gamma> :: "'a inference set" where
  "ord_\<Gamma> = {Infer (mset CAs) DA E | CAs DA AAs As E. ord_resolve CAs DA AAs As E}"

sublocale ord_\<Gamma>_sound_counterex_reducing?:
  sound_counterex_reducing_inference_system "ground_resolution_with_selection.ord_\<Gamma> S"
    "ground_resolution_with_selection.INTERP S" +
  reductive_inference_system "ground_resolution_with_selection.ord_\<Gamma> S"
proof unfold_locales
  fix N :: "'a clause set" and DA :: "'a clause"
  assume "{#} \<notin> N" and "DA \<in> N" and "\<not> INTERP N \<Turnstile> DA" and "\<And>C. C \<in> N \<Longrightarrow> \<not> INTERP N \<Turnstile> C \<Longrightarrow> DA \<le> C"
  then obtain CAs AAs As E where
    dd_sset_n: "set CAs \<subseteq> N" and
    dd_true: "INTERP N \<Turnstile>m mset CAs" and
    res_e: "ord_resolve CAs DA AAs As E" and
    e_cex: "\<not> INTERP N \<Turnstile> E" and
    e_lt_c: "E < DA"
    using ord_resolve_counterex_reducing[of N DA thesis] by auto

  have "Infer (mset CAs) DA E \<in> ord_\<Gamma>"
    using res_e unfolding ord_\<Gamma>_def by (metis (mono_tags, lifting) mem_Collect_eq)
  then show "\<exists>CC E. set_mset CC \<subseteq> N \<and> INTERP N \<Turnstile>m CC \<and> Infer CC DA E \<in> ord_\<Gamma>
    \<and> \<not> INTERP N \<Turnstile> E \<and> E < DA"
    using dd_sset_n dd_true e_cex e_lt_c by (metis set_mset_mset)
qed (auto simp: ord_\<Gamma>_def intro: ord_resolve_sound ord_resolve_reductive)

lemmas clausal_logic_compact = ord_\<Gamma>_sound_counterex_reducing.clausal_logic_compact

end

text \<open>
A second proof of Theorem 3.12, compactness of clausal logic:
\<close>

lemmas clausal_logic_compact = ground_resolution_with_selection.clausal_logic_compact

end


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

ML "Header.initialize
    [\"FoldlDecomp\", \"MapDecomp\", \"MapFunctor\", \"FilterProm\",
     \"ZipSpec\", \"ga_selector_pre\", \"ga_injective_suc\",
     \"ga_disjoint_0_suc\", \"ga_selector_undef_pre_0\", \"X1_def_Nat\",
     \"X2_def_Nat\", \"X3_def_Nat\", \"X4_def_Nat\", \"X5_def_Nat\",
     \"X6_def_Nat\", \"X7_def_Nat\", \"X8_def_Nat\", \"X9_def_Nat\",
     \"decimal_def\", \"ga_comm___XPlus__\", \"ga_assoc___XPlus__\",
     \"ga_right_unit___XPlus__\", \"ga_left_unit___XPlus__\",
     \"ga_left_comm___XPlus__\", \"ga_comm___Xx__\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"ga_left_comm___Xx__\", \"ga_comm_min\",
     \"ga_assoc_min\", \"ga_left_comm_min\", \"ga_comm_max\",
     \"ga_assoc_max\", \"ga_right_unit_max\", \"ga_left_unit_max\",
     \"ga_left_comm_max\", \"leq_def1_Nat\", \"leq_def2_Nat\",
     \"leq_def3_Nat\", \"geq_def_Nat\", \"less_def_Nat\",
     \"greater_def_Nat\", \"even_0_Nat\", \"even_suc_Nat\",
     \"odd_def_Nat\", \"factorial_0\", \"factorial_suc\", \"add_0_Nat\",
     \"add_suc_Nat\", \"mult_0_Nat\", \"mult_suc_Nat\", \"power_0_Nat\",
     \"power_suc_Nat\", \"min_def_Nat\", \"max_def_Nat\",
     \"subTotal_def1_Nat\", \"subTotal_def2_Nat\", \"sub_dom_Nat\",
     \"sub_def_Nat\", \"divide_dom_Nat\", \"divide_0_Nat\",
     \"divide_Pos_Nat\", \"div_dom_Nat\", \"div_Nat\", \"mod_dom_Nat\",
     \"mod_Nat\", \"distr1_Nat\", \"distr2_Nat\", \"min_0\",
     \"div_mod_Nat\", \"power_Nat\", \"equality_Int\", \"NatToInt\",
     \"IntToNat\", \"ga_comm___XPlus___1\", \"ga_assoc___XPlus___1\",
     \"ga_right_unit___XPlus___1\", \"ga_left_unit___XPlus___1\",
     \"ga_left_comm___XPlus___1\", \"ga_comm___Xx___1\",
     \"ga_assoc___Xx___1\", \"ga_right_unit___Xx___1\",
     \"ga_left_unit___Xx___1\", \"ga_left_comm___Xx___1\",
     \"ga_comm_min_1\", \"ga_comm_max_1\", \"ga_assoc_min_1\",
     \"ga_assoc_max_1\", \"ga_left_comm_min_1\", \"ga_left_comm_max_1\",
     \"geq_def_Int\", \"less_def_Int\", \"greater_def_Int\",
     \"even_def_Int\", \"odd_def_Int\", \"odd_alt_Int\",
     \"neg_def_Int\", \"sign_def_Int\", \"abs_def_Int\",
     \"add_def_Int\", \"mult_def_Int\", \"sub_def_Int\",
     \"min_def_Int\", \"max_def_Int\", \"power_neg1_Int\",
     \"power_others_Int\", \"divide_dom2_Int\", \"divide_alt_Int\",
     \"divide_Int\", \"div_dom_Int\", \"div_Int\", \"quot_dom_Int\",
     \"quot_neg_Int\", \"quot_nonneg_Int\", \"rem_dom_Int\",
     \"quot_rem_Int\", \"rem_nonneg_Int\", \"mod_dom_Int\", \"mod_Int\",
     \"distr1_Int\", \"distr2_Int\", \"Int_Nat_sub_compat\",
     \"abs_decomp_Int\", \"mod_abs_Int\", \"div_mod_Int\",
     \"quot_abs_Int\", \"rem_abs_Int\", \"quot_rem_Int_1\",
     \"power_Int\", \"NotFalse\", \"NotTrue\", \"AndFalse\",
     \"AndTrue\", \"AndSym\", \"OrDef\", \"OtherwiseDef\",
     \"NotFalse1\", \"NotTrue1\", \"notNot1\", \"notNot2\", \"Comp\",
     \"LengthNil\", \"LengthCons\", \"NotDefHead\", \"HeadDef\",
     \"FoldrNil\", \"FoldrCons\", \"FoldlNil\", \"FoldlCons\",
     \"MapNil\", \"MapCons\", \"XPlusXPlusNil\", \"XPlusXPlusCons\",
     \"FilterNil\", \"FilterConsT\", \"FilterConsF\", \"ZipNil\",
     \"ZipConsNil\", \"ZipConsCons\", \"UnzipNil\", \"UnzipCons\"]"

typedecl X_Int

datatype Nat = X0X2 ("0''''") | X_suc "Nat" ("suc/'(_')" [3] 999)
datatype Bool = X_False ("False''") | X_True ("True''")
datatype 'a List = X_Cons 'a "'a List" | X_Nil ("Nil''")

consts
IntToNat__X :: "X_Int => Nat option" ("(IntToNat/ _)" [56] 56)
NatToInt__X :: "Nat => X_Int" ("(NatToInt/ _)" [56] 56)
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
X0X1 :: "X_Int" ("0''")
X1X1 :: "X_Int" ("1''")
X1X2 :: "Nat" ("1''''")
X2X1 :: "X_Int" ("2''")
X2X2 :: "Nat" ("2''''")
X3X1 :: "X_Int" ("3''")
X3X2 :: "Nat" ("3''''")
X4X1 :: "X_Int" ("4''")
X4X2 :: "Nat" ("4''''")
X5X1 :: "X_Int" ("5''")
X5X2 :: "Nat" ("5''''")
X6X1 :: "X_Int" ("6''")
X6X2 :: "Nat" ("6''''")
X7X1 :: "X_Int" ("7''")
X7X2 :: "Nat" ("7''''")
X8X1 :: "X_Int" ("8''")
X8X2 :: "Nat" ("8''''")
X9X1 :: "X_Int" ("9''")
X9X2 :: "Nat" ("9''''")
XMinus__X :: "X_Int => X_Int" ("(-''/ _)" [56] 56)
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XAtXAt__X :: "Nat => Nat => Nat" ("(_/ @@/ _)" [54,54] 52)
X__XCaret__XX1 :: "X_Int => Nat => X_Int" ("(_/ ^''/ _)" [54,54] 52)
X__XCaret__XX2 :: "Nat => Nat => Nat" ("(_/ ^''''/ _)" [54,54] 52)
X__XExclam :: "Nat => Nat" ("(_/ !'')" [58] 58)
X__XGtXEq__XX1 :: "X_Int => X_Int => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGtXEq__XX2 :: "Nat => Nat => bool" ("(_/ >=''''/ _)" [44,44] 42)
X__XGt__XX1 :: "X_Int => X_Int => bool" ("(_/ >''/ _)" [44,44] 42)
X__XGt__XX2 :: "Nat => Nat => bool" ("(_/ >''''/ _)" [44,44] 42)
X__XLtXEq__XX1 :: "X_Int => X_Int => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLtXEq__XX2 :: "Nat => Nat => bool" ("(_/ <=''''/ _)" [44,44] 42)
X__XLt__XX1 :: "X_Int => X_Int => bool" ("(_/ <''/ _)" [44,44] 42)
X__XLt__XX2 :: "Nat => Nat => bool" ("(_/ <''''/ _)" [44,44] 42)
X__XMinusXExclam__X :: "Nat => Nat => Nat" ("(_/ -!/ _)" [54,54] 52)
X__XMinusXQuest__X :: "Nat => Nat => Nat option" ("(_/ -?/ _)" [54,54] 52)
X__XMinus__XX1 :: "X_Int => X_Int => X_Int" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Nat => Nat => X_Int" ("(_/ -''''/ _)" [54,54] 52)
X__XPlusXPlus__X :: "'a List => 'a List => 'a List" ("(_/ ++''/ _)" [54,54] 52)
X__XPlus__XX1 :: "X_Int => X_Int => X_Int" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Nat => Nat => Nat" ("(_/ +''''/ _)" [54,54] 52)
X__XSlashXQuest__XX1 :: "X_Int => X_Int => X_Int option" ("(_/ '/?''/ _)" [54,54] 52)
X__XSlashXQuest__XX2 :: "Nat => Nat => Nat option" ("(_/ '/?''''/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
X__Xx__XX1 :: "X_Int => X_Int => X_Int" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Nat => Nat => Nat" ("(_/ *''''/ _)" [54,54] 52)
X__div__XX1 :: "X_Int => X_Int => X_Int option" ("(_/ div''/ _)" [54,54] 52)
X__div__XX2 :: "Nat => Nat => Nat option" ("(_/ div''''/ _)" [54,54] 52)
X__mod__XX1 :: "X_Int => X_Int => Nat option" ("(_/ mod''/ _)" [54,54] 52)
X__mod__XX2 :: "Nat => Nat => Nat option" ("(_/ mod''''/ _)" [54,54] 52)
X__o__X :: "('b => 'c) * ('a => 'b) => 'a => 'c"
X__quot__X :: "X_Int => X_Int => X_Int option" ("(_/ quot/ _)" [54,54] 52)
X__rem__X :: "X_Int => X_Int => X_Int option" ("(_/ rem/ _)" [54,54] 52)
X_abs :: "X_Int => Nat" ("abs''/'(_')" [3] 999)
X_evenX1 :: "X_Int => bool" ("even''/'(_')" [3] 999)
X_evenX2 :: "Nat => bool" ("even''''/'(_')" [3] 999)
X_filter :: "('a => Bool) => 'a List => 'a List" ("filter''/'(_,/ _')" [3,3] 999)
X_foldl :: "('a * 'b => 'a) => 'a => 'b List => 'a" ("foldl''/'(_,/ _,/ _')" [3,3,3] 999)
X_foldr :: "('a * 'b => 'b) => 'b => 'a List => 'b" ("foldr''/'(_,/ _,/ _')" [3,3,3] 999)
X_head :: "'a List => 'a" ("head/'(_')" [3] 999)
X_length :: "'a List => X_Int" ("length''/'(_')" [3] 999)
X_map :: "('a => 'b) => 'a List => 'b List" ("map''/'(_,/ _')" [3,3] 999)
X_maxX1 :: "X_Int => X_Int => X_Int" ("max''/'(_,/ _')" [3,3] 999)
X_maxX2 :: "Nat => Nat => Nat" ("max''''/'(_,/ _')" [3,3] 999)
X_minX1 :: "X_Int => X_Int => X_Int" ("min''/'(_,/ _')" [3,3] 999)
X_minX2 :: "Nat => Nat => Nat" ("min''''/'(_,/ _')" [3,3] 999)
X_oddX1 :: "X_Int => bool" ("odd''/'(_')" [3] 999)
X_oddX2 :: "Nat => bool" ("odd''''/'(_')" [3] 999)
X_pre :: "Nat => Nat option" ("pre/'(_')" [3] 999)
X_sign :: "X_Int => X_Int" ("sign/'(_')" [3] 999)
X_unzip :: "('a * 'b) List => 'a List * 'b List" ("unzip/'(_')" [3] 999)
X_zip :: "'a List => 'b List => ('a * 'b) List" ("zip''/'(_,/ _')" [3,3] 999)
otherwiseH :: "Bool"

instance Bool:: type ..
instance List::("type") type ..
instance Nat:: type ..
instance X_Int:: type ..

axioms
ga_selector_pre [rule_format] : "ALL XX1. pre(suc(XX1)) = Some XX1"

ga_injective_suc [rule_format] :
"ALL XX1. ALL Y1. suc(XX1) = suc(Y1) = (XX1 = Y1)"

ga_disjoint_0_suc [rule_format] : "ALL Y1. ~ 0'' = suc(Y1)"

ga_selector_undef_pre_0 [rule_format] : "~ defOp (pre(0''))"

X1_def_Nat [rule_format] : "1'' = suc(0'')"

X2_def_Nat [rule_format] : "2'' = suc(1'')"

X3_def_Nat [rule_format] : "3'' = suc(2'')"

X4_def_Nat [rule_format] : "4'' = suc(3'')"

X5_def_Nat [rule_format] : "5'' = suc(4'')"

X6_def_Nat [rule_format] : "6'' = suc(5'')"

X7_def_Nat [rule_format] : "7'' = suc(6'')"

X8_def_Nat [rule_format] : "8'' = suc(7'')"

X9_def_Nat [rule_format] : "9'' = suc(8'')"

decimal_def [rule_format] :
"ALL m. ALL X_n. m @@ X_n = (m *'' suc(9'')) +'' X_n"

ga_comm___XPlus__ [rule_format] : "ALL x. ALL y. x +'' y = y +'' x"

ga_assoc___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. (x +'' y) +'' z = x +'' (y +'' z)"

ga_right_unit___XPlus__ [rule_format] : "ALL x. x +'' 0'' = x"

ga_left_unit___XPlus__ [rule_format] : "ALL x. 0'' +'' x = x"

ga_left_comm___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. x +'' (y +'' z) = y +'' (x +'' z)"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 1'' *'' x = x"

ga_left_comm___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. x *'' (y *'' z) = y *'' (x *'' z)"

ga_comm_min [rule_format] :
"ALL x. ALL y. min''(x, y) = min''(y, x)"

ga_assoc_min [rule_format] :
"ALL x.
 ALL y. ALL z. min''(min''(x, y), z) = min''(x, min''(y, z))"

ga_left_comm_min [rule_format] :
"ALL x.
 ALL y. ALL z. min''(x, min''(y, z)) = min''(y, min''(x, z))"

ga_comm_max [rule_format] :
"ALL x. ALL y. max''(x, y) = max''(y, x)"

ga_assoc_max [rule_format] :
"ALL x.
 ALL y. ALL z. max''(max''(x, y), z) = max''(x, max''(y, z))"

ga_right_unit_max [rule_format] : "ALL x. max''(x, 0'') = x"

ga_left_unit_max [rule_format] : "ALL x. max''(0'', x) = x"

ga_left_comm_max [rule_format] :
"ALL x.
 ALL y. ALL z. max''(x, max''(y, z)) = max''(y, max''(x, z))"

leq_def1_Nat [rule_format] : "ALL X_n. 0'' <='' X_n"

leq_def2_Nat [rule_format] : "ALL X_n. ~ suc(X_n) <='' 0''"

leq_def3_Nat [rule_format] :
"ALL m. ALL X_n. (suc(m) <='' suc(X_n)) = (m <='' X_n)"

geq_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >='' X_n) = (X_n <='' m)"

less_def_Nat [rule_format] :
"ALL m. ALL X_n. (m <'' X_n) = (m <='' X_n & ~ m = X_n)"

greater_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >'' X_n) = (X_n <'' m)"

even_0_Nat [rule_format] : "even''(0'')"

even_suc_Nat [rule_format] : "ALL m. even''(suc(m)) = odd''(m)"

odd_def_Nat [rule_format] : "ALL m. odd''(m) = (~ even''(m))"

factorial_0 [rule_format] : "0'' !' = 1''"

factorial_suc [rule_format] :
"ALL X_n. suc(X_n) !' = suc(X_n) *'' X_n !'"

add_0_Nat [rule_format] : "ALL m. 0'' +'' m = m"

add_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) +'' m = suc(X_n +'' m)"

mult_0_Nat [rule_format] : "ALL m. 0'' *'' m = 0''"

mult_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) *'' m = (X_n *'' m) +'' m"

power_0_Nat [rule_format] : "ALL m. m ^'' 0'' = 1''"

power_suc_Nat [rule_format] :
"ALL m. ALL X_n. m ^'' suc(X_n) = m *'' (m ^'' X_n)"

min_def_Nat [rule_format] :
"ALL m. ALL X_n. min''(m, X_n) = (if m <='' X_n then m else X_n)"

max_def_Nat [rule_format] :
"ALL m. ALL X_n. max''(m, X_n) = (if m <='' X_n then X_n else m)"

subTotal_def1_Nat [rule_format] :
"ALL m. ALL X_n. m >'' X_n --> X_n -! m = 0''"

subTotal_def2_Nat [rule_format] :
"ALL m. ALL X_n. m <='' X_n --> Some (X_n -! m) = X_n -? m"

sub_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m -? X_n) = (m >='' X_n)"

sub_def_Nat [rule_format] :
"ALL m. ALL X_n. ALL r. m -? X_n = Some r = (m = r +'' X_n)"

divide_dom_Nat [rule_format] :
"ALL m.
 ALL X_n.
 defOp (m /?'' X_n) = (~ X_n = 0'' & m mod'' X_n = Some 0'')"

divide_0_Nat [rule_format] : "ALL m. ~ defOp (m /?'' 0'')"

divide_Pos_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r. X_n >'' 0'' --> m /?'' X_n = Some r = (m = r *'' X_n)"

div_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m div'' X_n) = (~ X_n = 0'')"

div_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div'' X_n = Some r = (EX s. m = (X_n *'' r) +'' s & s <'' X_n)"

mod_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m mod'' X_n) = (~ X_n = 0'')"

mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m mod'' X_n = Some s = (EX r. m = (X_n *'' r) +'' s & s <'' X_n)"

distr1_Nat [rule_format] :
"ALL r. ALL s. ALL t. (r +'' s) *'' t = (r *'' t) +'' (s *'' t)"

distr2_Nat [rule_format] :
"ALL r. ALL s. ALL t. t *'' (r +'' s) = (t *'' r) +'' (t *'' s)"

min_0 [rule_format] : "ALL m. min''(m, 0'') = 0''"

div_mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0'' -->
 Some m =
 (case case m div'' X_n of
       None => None |
       Some Xc2 => Some (Xc2 *'' X_n) of
  None => None |
  Some Xc0 =>
  (case m mod'' X_n of
   None => None |
   Some Xc1 => Some (Xc0 +'' Xc1)))"

power_Nat [rule_format] :
"ALL m. ALL r. ALL s. m ^'' (r +'' s) = (m ^'' r) *'' (m ^'' s)"

equality_Int [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a -'' b = c -'' d = (a +'' d = c +'' b)"

NatToInt [rule_format] : "ALL a. NatToInt a = a -'' 0''"

IntToNat [rule_format] :
"ALL a. ALL b. IntToNat (a -'' b) = Some (a -! b)"

ga_comm___XPlus___1 [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___XPlus___1 [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___XPlus___1 [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___XPlus___1 [rule_format] : "ALL x. 0' +' x = x"

ga_left_comm___XPlus___1 [rule_format] :
"ALL x. ALL y. ALL z. x +' (y +' z) = y +' (x +' z)"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *' y = y *' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1' *' x = x"

ga_left_comm___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. x *' (y *' z) = y *' (x *' z)"

ga_comm_min_1 [rule_format] :
"ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max_1 [rule_format] :
"ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min_1 [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max_1 [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min_1 [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max_1 [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

geq_def_Int [rule_format] :
"ALL m. ALL X_n. (m >=' X_n) = (X_n <=' m)"

less_def_Int [rule_format] :
"ALL m. ALL X_n. (m <' X_n) = (m <=' X_n & ~ m = X_n)"

greater_def_Int [rule_format] :
"ALL m. ALL X_n. (m >' X_n) = (X_n <' m)"

even_def_Int [rule_format] : "ALL m. even'(m) = even''(abs'(m))"

odd_def_Int [rule_format] : "ALL m. odd'(m) = (~ even'(m))"

odd_alt_Int [rule_format] : "ALL m. odd'(m) = odd''(abs'(m))"

neg_def_Int [rule_format] : "ALL a. ALL b. -' (a -'' b) = b -'' a"

sign_def_Int [rule_format] :
"ALL m.
 sign(m) = (if m = 0' then 0' else if m >' 0' then 1' else -' 1')"

abs_def_Int [rule_format] :
"ALL m.
 Some (abs'(m)) = (if m <' 0' then IntToNat -' m else IntToNat m)"

add_def_Int [rule_format] :
"ALL a.
 ALL b.
 ALL c. ALL d. (a -'' b) +' (c -'' d) = (a +'' c) -'' (b +'' d)"

mult_def_Int [rule_format] :
"ALL a.
 ALL b.
 ALL c.
 ALL d.
 (a -'' b) *' (c -'' d) =
 ((a *'' c) +'' (b *'' d)) -'' ((b *'' c) +'' (a *'' d))"

sub_def_Int [rule_format] :
"ALL m. ALL X_n. m -' X_n = m +' -' X_n"

min_def_Int [rule_format] :
"ALL m. ALL X_n. min'(m, X_n) = (if m <=' X_n then m else X_n)"

max_def_Int [rule_format] :
"ALL m. ALL X_n. max'(m, X_n) = (if m <=' X_n then X_n else m)"

power_neg1_Int [rule_format] :
"ALL a. -' 1' ^' a = (if even''(a) then 1' else -' 1')"

power_others_Int [rule_format] :
"ALL m.
 ALL a.
 ~ m = -' 1' --> m ^' a = (sign(m) ^' a) *' (NatToInt abs'(m) ^' a)"

divide_dom2_Int [rule_format] :
"ALL m. ALL X_n. defOp (m /?' X_n) = (m mod' X_n = Some 0'')"

divide_alt_Int [rule_format] :
"ALL m.
 ALL X_n. ALL r. m /?' X_n = Some r = (~ X_n = 0' & X_n *' r = m)"

divide_Int [rule_format] :
"ALL m.
 ALL X_n.
 m /?' X_n =
 (case NatToInt abs'(m) /?' NatToInt abs'(X_n) of
  None => None |
  Some Xc0 => Some ((sign(m) *' sign(X_n)) *' Xc0))"

div_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m div' X_n) = (~ X_n = 0')"

div_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div' X_n = Some r =
 (EX a. m = (X_n *' r) +' NatToInt a & a <'' abs'(X_n))"

quot_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m quot X_n) = (~ X_n = 0')"

quot_neg_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m <' 0' -->
 m quot X_n = Some r =
 (EX s.
  m = (X_n *' r) +' s & 0' >=' s & s >' -' NatToInt abs'(X_n))"

quot_nonneg_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m >=' 0' -->
 m quot X_n = Some r =
 (EX s. m = (X_n *' r) +' s & 0' <=' s & s <' NatToInt abs'(X_n))"

rem_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m rem X_n) = (~ X_n = 0')"

quot_rem_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m <' 0' -->
 m rem X_n = Some s =
 (EX r.
  m = (X_n *' r) +' s & 0' >=' s & s >' -' NatToInt abs'(X_n))"

rem_nonneg_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m >=' 0' -->
 m rem X_n = Some s =
 (EX r. m = (X_n *' r) +' s & 0' <=' s & s <' NatToInt abs'(X_n))"

mod_dom_Int [rule_format] :
"ALL m. ALL X_n. defOp (m mod' X_n) = (~ X_n = 0')"

mod_Int [rule_format] :
"ALL m.
 ALL X_n.
 ALL a.
 m mod' X_n = Some a =
 (EX r. m = (X_n *' r) +' NatToInt a & a <'' abs'(X_n))"

distr1_Int [rule_format] :
"ALL r. ALL s. ALL t. (r +' s) *' t = (r *' t) +' (s *' t)"

distr2_Int [rule_format] :
"ALL r. ALL s. ALL t. t *' (r +' s) = (t *' r) +' (t *' s)"

Int_Nat_sub_compat [rule_format] :
"ALL a. ALL b. defOp (a -? b) --> a -? b = IntToNat (a -'' b)"

abs_decomp_Int [rule_format] :
"ALL m. m = sign(m) *' NatToInt abs'(m)"

mod_abs_Int [rule_format] :
"ALL m. ALL X_n. m mod' X_n = m mod' NatToInt abs'(X_n)"

div_mod_Int [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 Some m =
 (case case m div' X_n of
       None => None |
       Some Xc3 => Some (Xc3 *' X_n) of
  None => None |
  Some Xc0 =>
  (case case m mod' X_n of
        None => None |
        Some Xc2 => Some (NatToInt Xc2) of
   None => None |
   Some Xc1 => Some (Xc0 +' Xc1)))"

quot_abs_Int [rule_format] :
"ALL m.
 ALL X_n.
 (case case m quot X_n of
       None => None |
       Some Xc1 => Some (abs'(Xc1)) of
  None => None |
  Some Xc0 => Some (NatToInt Xc0)) =
 NatToInt abs'(m) quot NatToInt abs'(X_n)"

rem_abs_Int [rule_format] :
"ALL m.
 ALL X_n.
 (case case m rem X_n of
       None => None |
       Some Xc1 => Some (abs'(Xc1)) of
  None => None |
  Some Xc0 => Some (NatToInt Xc0)) =
 NatToInt abs'(m) rem NatToInt abs'(X_n)"

quot_rem_Int_1 [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 Some m =
 (case case m quot X_n of
       None => None |
       Some Xc2 => Some (Xc2 *' X_n) of
  None => None |
  Some Xc0 =>
  (case m rem X_n of
   None => None |
   Some Xc1 => Some (Xc0 +' Xc1)))"

power_Int [rule_format] :
"ALL m. ALL a. ALL b. m ^' (a +'' b) = (m ^' a) *' (m ^' b)"

NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndFalse [rule_format] : "ALL x. False' && x = False'"

AndTrue [rule_format] : "ALL x. True' && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

NotFalse1 [rule_format] : "ALL x. Not' x = True' = (x = False')"

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

notNot1 [rule_format] : "ALL x. (~ x = True') = (Not' x = True')"

notNot2 [rule_format] : "ALL x. (~ x = False') = (Not' x = False')"

Comp [rule_format] :
"ALL f. ALL g. Some o X__o__X (f, g) = Some o (% x. f (g x))"

LengthNil [rule_format] : "length'(Nil') = 0'"

LengthCons [rule_format] :
"ALL x. ALL xs. length'(X_Cons x xs) = length'(xs) +' 1'"

NotDefHead [rule_format] : "~ True"

HeadDef [rule_format] : "ALL x. ALL xs. head(X_Cons x xs) = x"

FoldrNil [rule_format] : "ALL f. ALL s. foldr'(f, s, Nil') = s"

FoldrCons [rule_format] :
"ALL f.
 ALL s.
 ALL x. ALL xs. foldr'(f, s, X_Cons x xs) = f (x, foldr'(f, s, xs))"

FoldlNil [rule_format] : "ALL g. ALL t. foldl'(g, t, Nil') = t"

FoldlCons [rule_format] :
"ALL g.
 ALL t.
 ALL z. ALL zs. foldl'(g, t, X_Cons z zs) = foldl'(g, g (t, z), zs)"

MapNil [rule_format] : "ALL h. map'(h, Nil') = Nil'"

MapCons [rule_format] :
"ALL h.
 ALL x. ALL xs. map'(h, X_Cons x xs) = X_Cons (h x) (map'(h, xs))"

XPlusXPlusNil [rule_format] : "ALL l. Nil' ++' l = l"

XPlusXPlusCons [rule_format] :
"ALL l. ALL x. ALL xs. X_Cons x xs ++' l = X_Cons x (xs ++' l)"

FilterNil [rule_format] : "ALL p. filter'(p, Nil') = Nil'"

FilterConsT [rule_format] :
"ALL p.
 ALL x.
 ALL xs.
 p x = True' -->
 filter'(p, X_Cons x xs) = X_Cons x (filter'(p, xs))"

FilterConsF [rule_format] :
"ALL p.
 ALL x.
 ALL xs. p x = False' --> filter'(p, X_Cons x xs) = filter'(p, xs)"

ZipNil [rule_format] : "ALL l. zip'(Nil', l) = Nil'"

ZipConsNil [rule_format] :
"ALL l. ALL x. ALL xs. l = Nil' --> zip'(X_Cons x xs, l) = Nil'"

ZipConsCons [rule_format] :
"ALL l.
 ALL x.
 ALL xs.
 ALL y.
 ALL ys.
 l = X_Cons y ys -->
 zip'(X_Cons x xs, l) = X_Cons (x, y) (zip'(xs, ys))"

UnzipNil [rule_format] : "unzip(Nil') = (Nil', Nil')"

UnzipCons [rule_format] :
"ALL ps.
 ALL x.
 ALL z.
 unzip(X_Cons (x, z) ps) =
 (let (ys, zs) = unzip(ps) in (X_Cons x ys, X_Cons z zs))"

declare ga_selector_pre [simp]
declare ga_selector_undef_pre_0 [simp]
declare ga_comm___XPlus__ [simp]
declare ga_assoc___XPlus__ [simp]
declare ga_right_unit___XPlus__ [simp]
declare ga_left_unit___XPlus__ [simp]
declare ga_left_comm___XPlus__ [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare ga_left_comm___Xx__ [simp]
declare ga_comm_min [simp]
declare ga_assoc_min [simp]
declare ga_left_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_max [simp]
declare ga_right_unit_max [simp]
declare ga_left_unit_max [simp]
declare ga_left_comm_max [simp]
declare leq_def1_Nat [simp]
declare leq_def2_Nat [simp]
declare leq_def3_Nat [simp]
declare even_0_Nat [simp]
declare even_suc_Nat [simp]
declare factorial_0 [simp]
declare add_0_Nat [simp]
declare mult_0_Nat [simp]
declare power_0_Nat [simp]
declare subTotal_def1_Nat [simp]
declare subTotal_def2_Nat [simp]
declare sub_dom_Nat [simp]
declare divide_0_Nat [simp]
declare min_0 [simp]
declare ga_comm___XPlus___1 [simp]
declare ga_assoc___XPlus___1 [simp]
declare ga_right_unit___XPlus___1 [simp]
declare ga_left_unit___XPlus___1 [simp]
declare ga_left_comm___XPlus___1 [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare ga_left_comm___Xx___1 [simp]
declare ga_comm_min_1 [simp]
declare ga_comm_max_1 [simp]
declare ga_assoc_min_1 [simp]
declare ga_assoc_max_1 [simp]
declare ga_left_comm_min_1 [simp]
declare ga_left_comm_max_1 [simp]
declare neg_def_Int [simp]
declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare LengthNil [simp]
declare NotDefHead [simp]
declare HeadDef [simp]
declare FoldrNil [simp]
declare FoldlNil [simp]
declare MapNil [simp]
declare XPlusXPlusNil [simp]
declare FilterNil [simp]
declare FilterConsF [simp]
declare ZipNil [simp]

theorem FoldlDecomp :
"ALL e.
 ALL i.
 ALL xs.
 ALL zs. foldl'(i, e, xs ++' zs) = foldl'(i, foldl'(i, e, xs), zs)"
using HeadDef by auto

ML "Header.record \"FoldlDecomp\""

theorem MapDecomp :
"ALL f.
 ALL xs. ALL zs. map'(f, xs ++' zs) = map'(f, xs) ++' map'(f, zs)"
using HeadDef by auto

ML "Header.record \"MapDecomp\""

theorem MapFunctor :
"ALL f.
 ALL g. ALL xs. map'(X__o__X (g, f), xs) = map'(g, map'(f, xs))"
using HeadDef by auto

ML "Header.record \"MapFunctor\""

theorem FilterProm :
"ALL f.
 ALL p.
 ALL xs.
 filter'(p, map'(f, xs)) = map'(f, filter'(X__o__X (p, f), xs))"
using HeadDef by auto

ML "Header.record \"FilterProm\""

theorem ZipSpec :
"ALL xs.
 ALL ys.
 length'(xs) = length'(ys) --> unzip(zip'(xs, ys)) = (xs, ys)"
using HeadDef by auto

ML "Header.record \"ZipSpec\""

end


section \<open>The Knuth--Bendix Order as an instance of WPO\<close>

text \<open>Making the Knuth--Bendix an instance of WPO is more complicated than in the
  case of RPO and LPO, because of syntactic and semantic differences.
  We face the two main challenges in two different theories and sub-sections.\<close>

subsection \<open>Aligning least elements\<close>

text \<open>In all of RPO, LPO and WPO there is the concept of a minimal term, e.g.,
  a constant term $c$ where $c$ is least in precedence among \emph{all function symbols}.
  By contrast, in KBO a constant $c$ is minimal if it has minimal weight and has
  least precende \emph{among all constants of minimal weight}.\<close>

text \<open>In this theory we prove that for any KBO one can modify the precedence in a way
  that least constants $c$ also have least precendence among \emph{all function symbols},
  without changing the defined order. Hence, afterwards it will be simpler to relate such
  a KBO to WPO.\<close>

theory KBO_Transformation
  imports WPO Knuth_Bendix_Order.KBO
begin

context admissible_kbo
begin

lemma weight_w0_unary:
  assumes *: "weight t = w0" "t = Fun f ts" "ts = t1 # ts'"
  shows "ts' = []" "w (f,1) = 0"
proof -
  have "w0 + sum_list (map weight ts') \<le> weight t1 + sum_list (map weight ts')"
    by (rule add_right_mono, rule weight_w0)
  also have "\<dots> = sum_list (map weight ts)" unfolding * by simp
  also have "\<dots> \<le> sum_list (map weight (scf_list (scf (f, length ts)) ts))"
    by (rule sum_list_scf_list, insert scf, auto)
  finally have "w (f,length ts) + w0 + sum_list (map weight ts') \<le> weight t" unfolding * by simp
  with *(1) have sum: "sum_list (map weight ts') = 0" and wf: "w (f,length ts) = 0" by auto
  with weight_gt_0 show ts': "ts' = []" by (cases ts', auto)
  with wf show "w (f,1) = 0" using * by auto
qed

definition lConsts :: "('f \<times> nat)set" where "lConsts = { (f,0) | f. least f}"
definition pr_strict' where "pr_strict' f g = (f \<notin> lConsts \<and> (pr_strict f g \<or> g \<in> lConsts))"
definition pr_weak' where "pr_weak' f g = ((f \<notin> lConsts \<and> pr_weak f g) \<or> g \<in> lConsts)"

lemma admissible_kbo': "admissible_kbo w w0 pr_strict' pr_weak' least scf"
  apply (unfold_locales)
  subgoal by (rule w0)
  subgoal by (rule w0)
  subgoal for f g n using adm[of f g n] unfolding pr_weak'_def by (auto simp: lConsts_def)
  subgoal for f using least[of f] unfolding pr_weak'_def lConsts_def by auto
  subgoal by (rule scf)
  subgoal for f using pr_weak_refl[of f] unfolding pr_weak'_def by auto
  subgoal for f g h using pr_weak_trans[of f g h] unfolding pr_weak'_def by auto
  subgoal for f g using pr_strict[of f g] unfolding pr_strict'_def pr_weak'_def by auto
proof -
  show "SN {(x, y). pr_strict' x y}" (is "SN ?R")
  proof
    fix f
    assume "\<forall> i. (f i, f (Suc i)) \<in> ?R"
    hence steps: "\<And> i. (f i, f (Suc i)) \<in> ?R" by blast
    have "f i \<notin> lConsts" for i using steps[of i] unfolding pr_strict'_def by auto
    hence "pr_strict (f i) (f (Suc i))" for i using steps[of i] unfolding pr_strict'_def by auto
    with pr_SN show False by auto
  qed
qed

lemma least_pr_weak': "least f \<Longrightarrow> pr_weak' g (f,0)" unfolding lConsts_def pr_weak'_def by auto

lemma least_pr_weak'_trans: "least f \<Longrightarrow> pr_weak' (f,0) g \<Longrightarrow> least (fst g) \<and> snd g = 0"
  unfolding lConsts_def pr_weak'_def by auto

context
begin
interpretation kbo': admissible_kbo w w0 pr_strict' pr_weak' least scf
  by (rule admissible_kbo')

lemma kbo'_eq_kbo: "kbo'.kbo s t = kbo s t"
proof (induct s t rule: kbo.induct)
  case (1 s t)
  note simps = kbo.simps[of s t] kbo'.kbo.simps[of s t]
  show ?case unfolding simps
    apply (intro if_cong refl, intro term.case_cong refl)
  proof -
    fix f ss g ts
    assume *: "vars_term_ms (SCF t) \<subseteq># vars_term_ms (SCF s) \<and> weight t \<le> weight s"
      "\<not> weight t < weight s"
      and s: "s = Fun f ss"
      and t: "t = Fun g ts"
    let ?g = "(g,length ts)"
    let ?f = "(f,length ss)"
    have IH: "(if pr_strict ?f ?g then (True, True)
        else if pr_weak ?f ?g then lex_ext_unbounded kbo ss ts else (False, False))
      = (if pr_strict ?f ?g then (True, True)
        else if pr_weak ?f ?g then lex_ext_unbounded kbo'.kbo ss ts else (False, False))"
      by (intro if_cong refl lex_ext_unbounded_cong, insert 1[OF * s t], auto)
    let ?P = "pr_strict' ?f ?g = pr_strict ?f ?g \<and> (\<not> pr_strict ?f ?g \<longrightarrow> pr_weak' ?f ?g = pr_weak ?f ?g)"
    show "(if pr_strict' ?f ?g then (True, True)
        else if pr_weak' ?f ?g then lex_ext_unbounded kbo'.kbo ss ts else (False, False)) =
       (if pr_strict ?f ?g then (True, True)
        else if pr_weak ?f ?g then lex_ext_unbounded kbo ss ts else (False, False))"
    proof (cases ?P)
      case True
      thus ?thesis unfolding IH by auto
    next
      case notP: False
      hence fgC: "?f \<in> lConsts \<or> ?g \<in> lConsts" unfolding pr_strict'_def pr_weak'_def by auto
      hence weight: "weight s = w0" "weight t = w0" using * unfolding lConsts_def least s t by auto
      show ?thesis
      proof (cases "ss = [] \<and> ts = []")
        case empty: True
        with weight have "w ?f = w0" "w ?g = w0" unfolding s t by auto
        with empty have ?P unfolding pr_strict'_def pr_weak'_def using pr_weak_trans[of _ "(g,0)" "(f,0)"]
            pr_weak_trans[of _ "(f,0)" "(g,0)"]
          by (auto simp: lConsts_def pr_strict least)
        with notP show ?thesis by blast
      next
        case False
        {
          fix f and t :: "('f,'a)term"  and t1 ts' ts and g
          assume *: "weight t = w0" "t = Fun f ts" "ts = t1 # ts'"
          from weight_w0_unary[OF this]
          have ts': "ts' = []" and w: "w (f,1) = 0" .
          from adm[OF w] ts'
          have "pr_weak (f, Suc (length ts')) g" by (cases g, auto)
        } note unary = this
        from fgC have "ss = [] \<or> ts = []" unfolding lConsts_def least by auto
        thus ?thesis
        proof
          assume ss: "ss = []"
          with False obtain t1 ts' where ts: "ts = t1 # ts'" by (cases ts, auto)
          show ?thesis unfolding ss ts using unary[OF weight(2) t ts]
            by (simp add: lex_ext_unbounded.simps pr_strict'_def lConsts_def pr_strict)
        next
          assume ts: "ts = []"
          with False obtain s1 ss' where ss: "ss = s1 # ss'" by (cases ss, auto)
          show ?thesis unfolding ss ts using unary[OF weight(1) s ss]
            by (simp add: lex_ext_unbounded.simps pr_strict'_def pr_weak'_def lConsts_def pr_strict)
        qed
      qed
    qed
  qed
qed
end
end
end