(*  Title:      HOL/Library/AList_Mapping.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Implementation of mappings with Association Lists\<close>

theory AList_Mapping
  imports AList Mapping
begin

lift_definition Mapping :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping" is map_of .

code_datatype Mapping

lemma lookup_Mapping [simp, code]: "Mapping.lookup (Mapping xs) = map_of xs"
  by transfer rule

lemma keys_Mapping [simp, code]: "Mapping.keys (Mapping xs) = set (map fst xs)"
  by transfer (simp add: dom_map_of_conv_image_fst)

lemma empty_Mapping [code]: "Mapping.empty = Mapping []"
  by transfer simp

lemma is_empty_Mapping [code]: "Mapping.is_empty (Mapping xs) \<longleftrightarrow> List.null xs"
  by (cases xs) (simp_all add: is_empty_def null_def)

lemma update_Mapping [code]: "Mapping.update k v (Mapping xs) = Mapping (AList.update k v xs)"
  by transfer (simp add: update_conv')

lemma delete_Mapping [code]: "Mapping.delete k (Mapping xs) = Mapping (AList.delete k xs)"
  by transfer (simp add: delete_conv')

lemma ordered_keys_Mapping [code]:
  "Mapping.ordered_keys (Mapping xs) = sort (remdups (map fst xs))"
  by (simp only: ordered_keys_def keys_Mapping sorted_list_of_set_sort_remdups) simp

lemma entries_Mapping [code]:
  "Mapping.entries (Mapping xs) = set (AList.clearjunk xs)"
  by transfer (fact graph_map_of)

lemma ordered_entries_Mapping [code]:
  "Mapping.ordered_entries (Mapping xs) = sort_key fst (AList.clearjunk xs)"
proof -
  have distinct: "distinct (sort_key fst (AList.clearjunk xs))"
    using distinct_clearjunk distinct_map distinct_sort by blast
  note folding_Map_graph.idem_if_sorted_distinct[where ?m="map_of xs", OF _ sorted_sort_key distinct]
  then show ?thesis
    unfolding ordered_entries_def
    by (transfer fixing: xs) (auto simp: graph_map_of)
qed

lemma fold_Mapping [code]:
  "Mapping.fold f (Mapping xs) a = List.fold (case_prod f) (sort_key fst (AList.clearjunk xs)) a"
  by (simp add: Mapping.fold_def ordered_entries_Mapping)

lemma size_Mapping [code]: "Mapping.size (Mapping xs) = length (remdups (map fst xs))"
  by (simp add: size_def length_remdups_card_conv dom_map_of_conv_image_fst)

lemma tabulate_Mapping [code]: "Mapping.tabulate ks f = Mapping (map (\<lambda>k. (k, f k)) ks)"
  by transfer (simp add: map_of_map_restrict)

lemma bulkload_Mapping [code]:
  "Mapping.bulkload vs = Mapping (map (\<lambda>n. (n, vs ! n)) [0..<length vs])"
  by transfer (simp add: map_of_map_restrict fun_eq_iff)

lemma equal_Mapping [code]:
  "HOL.equal (Mapping xs) (Mapping ys) \<longleftrightarrow>
    (let ks = map fst xs; ls = map fst ys
     in (\<forall>l\<in>set ls. l \<in> set ks) \<and> (\<forall>k\<in>set ks. k \<in> set ls \<and> map_of xs k = map_of ys k))"
proof -
  have *: "(a, b) \<in> set xs \<Longrightarrow> a \<in> fst ` set xs" for a b xs
    by (auto simp add: image_def intro!: bexI)
  show ?thesis
    apply transfer
    apply (auto intro!: map_of_eqI)
     apply (auto dest!: map_of_eq_dom intro: *)
    done
qed

lemma map_values_Mapping [code]:
  "Mapping.map_values f (Mapping xs) = Mapping (map (\<lambda>(x,y). (x, f x y)) xs)"
  for f :: "'c \<Rightarrow> 'a \<Rightarrow> 'b" and xs :: "('c \<times> 'a) list"
  apply transfer
  apply (rule ext)
  subgoal for f xs x by (induct xs) auto
  done

lemma combine_with_key_code [code]:
  "Mapping.combine_with_key f (Mapping xs) (Mapping ys) =
     Mapping.tabulate (remdups (map fst xs @ map fst ys))
       (\<lambda>x. the (combine_options (f x) (map_of xs x) (map_of ys x)))"
  apply transfer
  apply (rule ext)
  apply (rule sym)
  subgoal for f xs ys x
    apply (cases "map_of xs x"; cases "map_of ys x"; simp)
       apply (force simp: map_of_eq_None_iff combine_options_def option.the_def o_def image_iff
        dest: map_of_SomeD split: option.splits)+
    done
  done

lemma combine_code [code]:
  "Mapping.combine f (Mapping xs) (Mapping ys) =
     Mapping.tabulate (remdups (map fst xs @ map fst ys))
       (\<lambda>x. the (combine_options f (map_of xs x) (map_of ys x)))"
  apply transfer
  apply (rule ext)
  apply (rule sym)
  subgoal for f xs ys x
    apply (cases "map_of xs x"; cases "map_of ys x"; simp)
       apply (force simp: map_of_eq_None_iff combine_options_def option.the_def o_def image_iff
        dest: map_of_SomeD split: option.splits)+
    done
  done

lemma map_of_filter_distinct:  (* TODO: move? *)
  assumes "distinct (map fst xs)"
  shows "map_of (filter P xs) x =
    (case map_of xs x of
      None \<Rightarrow> None
    | Some y \<Rightarrow> if P (x,y) then Some y else None)"
  using assms
  by (auto simp: map_of_eq_None_iff filter_map distinct_map_filter dest: map_of_SomeD
      simp del: map_of_eq_Some_iff intro!: map_of_is_SomeI split: option.splits)

lemma filter_Mapping [code]:
  "Mapping.filter P (Mapping xs) = Mapping (filter (\<lambda>(k,v). P k v) (AList.clearjunk xs))"
  apply transfer
  apply (rule ext)
  apply (subst map_of_filter_distinct)
   apply (simp_all add: map_of_clearjunk split: option.split)
  done

lemma [code nbe]: "HOL.equal (x :: ('a, 'b) mapping) x \<longleftrightarrow> True"
  by (fact equal_refl)

end


(*
 * 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 Chapter2_HoareHeap
imports "../../AutoCorres"
begin
(*>*)

section  {* More Complex Functions with AutoCorres *}

text {*

  In the previous section we saw how to use the C-Parser and AutoCorres
  to prove properties about some very simple C programs.

  Real life C programs tend to be far more complex however; they
  read and write to local variables, have loops and use pointers to
  access the heap. In this section we will look at some simple programs
  which use loops and access the heap to show how AutoCorres can
  allow such constructs to be reasoned about.

*}

subsection {* A simple loop: \texttt{mult\_by\_add} *}

text {*

  Our C function \texttt{mult\_by\_add} implements a multiply operation
  by successive additions:

\lstinputlisting[language=C, firstline=15]{../../mult_by_add.c}

  We start by translating the program using the C parser and AutoCorres,
  and entering the generated locale \texttt{mult\_by\_add}.
*}

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

text {*
  The C parser produces the SIMPL output as follows:
*}

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

text {*
  Which is abstracted by AutoCorres to the following:
*}

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

text {*

  In this case AutoCorres has abstracted \texttt{mult\_by\_add} into a
  \emph{monadic} form. Monads are a pattern frequently used in
  functional programming to represent imperative-style control-flow; an
  in-depth introduction to monads can be found elsewhere.

  The monads used by AutoCorres in this example is a
  \emph{non-deterministic state monad}; program state is implicitly
  passed between each statement, and results of computations may produce
  more than one (or possibly zero) results\footnote{Non-determinism
  becomes useful when modelling hardware, for example, where the exact
  results of the hardware cannot be determined ahead of time.}.
*}
  (* FIXME : probably describe below in further detail. *)
text {*
  The bulk of @{term "mult_by_add'"} is wrapped inside the @{term
  "whileLoop"} \emph{monad combinator}, which is really just a fancy way
  of describing the method used by AutoCorres to encode (potentially
  non-terminating) loops using monads.

  If we want to describe the behaviour of this program, we can use
  Hoare logic as follows:

    @{term [display] "\<lbrace> P \<rbrace> mult_by_add' a b \<lbrace> Q \<rbrace>"}

  This predicate states that, assuming @{term "P"} holds on the initial
  program state, if we execute @{term "mult_by_add' a b"}, then
  @{term "Q"} will hold on the final state of the program.

  There are a few details: while @{term "P"} has type
  @{typ "'s \<Rightarrow> bool"} (i.e., takes a state and returns true if
  it satisifies the precondition), @{term "Q"} has an additional
  parameter @{typ "'r \<Rightarrow> 's \<Rightarrow> bool"}. The additional parameter
  @{typ "'r"} is the \emph{return value} of the function; so, in
  our \texttt{mult\_by\_add'} example, it will be the result of
  the multiplication.

  For example one useful property to prove on our program would
  be:

    @{term [display] "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>"}

  That is, for all possible input states, our \texttt{mult\_by\_add'}
  function returns the product of @{term "a"} and @{term "b"}.

  Unfortunately, this is not sufficient. As mentioned in the previous
  section, AutoCorres produces a theorem for each function it abstracts
  stating that, \emph{assuming the function does not fail}, then the
  generated function is a valid abstraction of the concrete function.
  Thus, if we wish to reason about our concrete C function, we must
  also show non-failure on the abstract program. This can be done
  using the predicate @{term "no_fail"} as follows:

    @{term [display] "\<And>a b. no_fail (\<lambda>s. True) (mult_by_add' a b)"}

  Here @{term "\<lambda>s. True"} is the precondition on the input state.

  Instead of proving our Hoare triple and @{term no_fail} separately,
  we can prove them together using the ``valid no fail'' framework
  as follows:

    @{thm [display] validNF_def}

  Our proof of @{term mult_by_add'} could then proceed as follows:

*}

lemma mult_by_add_correct:
    "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  txt {* Unfold abstracted definition *}
  apply (unfold mult_by_add'_def)
  txt {* Annotate the loop with an invariant and a measure. *}
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', result) s. result = (a - a') * b"
        and M="\<lambda>((a', result), s). a'"] )
  txt {* Run the ``weakest precondition'' tool \texttt{wp}. *}
  apply wp
  txt {* Solve the program correctness goals. *}
     apply (simp add: field_simps)
    apply unat_arith
   apply (auto simp: field_simps not_less)
  done

(* FIXME: Update the following explanation. *)
text {*
  The proof is straight-forward, but uses a few different techniques:
  The first is that we annotate the loop with a loop invariant and a
  measure, using the rule @{thm whileLoop_add_inv}. We then run the
  \texttt{wp} tool which applys a large set of
  \emph{weakest precondition} rules on the program\footnote{This set of
  rules includes a rule which can handle annotated @{term whileLoop}
  terms, but will not attempt to process @{term whileLoop} terms without
  annotations.}. We finially discharge the remaining subgoals left from
  the \texttt{wp} tool using \texttt{auto}, and our proof is complete.

  In the next section, we will look at how we can use AutoCorres to
  verify a C program that reads and writes to the heap.

*}

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


theory prop_15
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  (*hipster plus *)
  theorem x0 :
    "(plus x (S x)) = (S (plus x x))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


section\<open>Concepts involved in instances of Replacement\<close>
theory Fm_Definitions
  imports
    Transitive_Models.Renaming_Auto
    Transitive_Models.Aleph_Relative
    FrecR_Arities
begin

(* Really, I have no idea why is this needed again. At the end of the
   imported theories, notation works just fine. *)
no_notation Aleph (\<open>\<aleph>_\<close> [90] 90)

text\<open>In this theory we put every concept that should be synthesized in a formula
to have an instance of replacement.

The automatic synthesis of a concept /foo/ requires that every concept used to
define /foo/ is already synthesized. We try to use our meta-programs to synthesize
concepts: given the absolute concept /foo/ we relativize in relational form
obtaining /is\_foo/ and the we synthesize the formula /is\_foo\_fm/.
The meta-program that synthesizes formulas also produce satisfactions lemmas.

Having one file to collect every formula needed for replacements breaks
the reading flow: we need to introduce the concept in this theory in order
to use the meta-programs; moreover there are some concepts for which we prove
here the satisfaction lemmas manually, while for others we prove them
on its theory.
\<close>

declare arity_subset_fm [simp del] arity_ordinal_fm[simp del, arity] arity_transset_fm[simp del]
  FOL_arities[simp del]

synthesize "setdiff" from_definition "setdiff" assuming "nonempty"
arity_theorem for "setdiff_fm"

synthesize "is_converse" from_definition assuming "nonempty"
arity_theorem for "is_converse_fm"

relationalize "first_rel" "is_first" external
synthesize "first_fm" from_definition "is_first" assuming "nonempty"

relationalize "minimum_rel" "is_minimum" external
definition is_minimum' where
  "is_minimum'(M,R,X,u) \<equiv> (M(u) \<and> u \<in> X \<and> (\<forall>v[M]. \<exists>a[M]. (v \<in> X \<longrightarrow> v \<noteq> u \<longrightarrow> a \<in> R) \<and> pair(M, u, v, a))) \<and>
    (\<exists>x[M].
        (M(x) \<and> x \<in> X \<and> (\<forall>v[M]. \<exists>a[M]. (v \<in> X \<longrightarrow> v \<noteq> x \<longrightarrow> a \<in> R) \<and> pair(M, x, v, a))) \<and>
        (\<forall>y[M]. M(y) \<and> y \<in> X \<and> (\<forall>v[M]. \<exists>a[M]. (v \<in> X \<longrightarrow> v \<noteq> y \<longrightarrow> a \<in> R) \<and> pair(M, y, v, a)) \<longrightarrow> y = x)) \<or>
    \<not> (\<exists>x[M]. (M(x) \<and> x \<in> X \<and> (\<forall>v[M]. \<exists>a[M]. (v \<in> X \<longrightarrow> v \<noteq> x \<longrightarrow> a \<in> R) \<and> pair(M, x, v, a))) \<and>
               (\<forall>y[M]. M(y) \<and> y \<in> X \<and> (\<forall>v[M]. \<exists>a[M]. (v \<in> X \<longrightarrow> v \<noteq> y \<longrightarrow> a \<in> R) \<and> pair(M, y, v, a)) \<longrightarrow> y = x)) \<and>
    empty(M, u)"

synthesize "minimum" from_definition "is_minimum'" assuming "nonempty"
arity_theorem for "minimum_fm"

lemma is_lambda_iff_sats[iff_sats]:
  assumes is_F_iff_sats:
    "!!a0 a1 a2.
        [|a0\<in>Aa; a1\<in>Aa; a2\<in>Aa|]
        ==> is_F(a1, a0) \<longleftrightarrow> sats(Aa, is_F_fm, Cons(a0,Cons(a1,Cons(a2,env))))"
  shows
    "nth(A, env) = Ab \<Longrightarrow>
    nth(r, env) = ra \<Longrightarrow>
    A \<in> nat \<Longrightarrow>
    r \<in> nat \<Longrightarrow>
    env \<in> list(Aa) \<Longrightarrow>
    is_lambda(##Aa, Ab, is_F, ra) \<longleftrightarrow> Aa, env \<Turnstile> lambda_fm(is_F_fm,A, r)"
  using sats_lambda_fm[OF assms, of A r] by simp

\<comment> \<open>same as @{thm [source] sats_is_wfrec_fm}, but changing length assumptions to
    \<^term>\<open>0\<close> being in the model\<close>
lemma sats_is_wfrec_fm':
  assumes MH_iff_sats:
    "!!a0 a1 a2 a3 a4.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
    "[|x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A); 0 \<in> A|]
       ==> sats(A, is_wfrec_fm(p,x,y,z), env) \<longleftrightarrow>
           is_wfrec(##A, MH, nth(x,env), nth(y,env), nth(z,env))"
  using MH_iff_sats [THEN iff_sym] nth_closed sats_is_recfun_fm
  by (simp add: is_wfrec_fm_def is_wfrec_def) blast

lemma is_wfrec_iff_sats'[iff_sats]:
  assumes MH_iff_sats:
    "!!a0 a1 a2 a3 a4.
        [|a0\<in>Aa; a1\<in>Aa; a2\<in>Aa; a3\<in>Aa; a4\<in>Aa|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(Aa, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
    "nth(x, env) = xx" "nth(y, env) = yy" "nth(z, env) = zz"
    "x \<in> nat" "y \<in> nat" "z \<in> nat" "env \<in> list(Aa)" "0 \<in> Aa"
  shows
    "is_wfrec(##Aa, MH, xx, yy, zz) \<longleftrightarrow> Aa, env \<Turnstile> is_wfrec_fm(p,x,y,z)"
  using assms(2-4) sats_is_wfrec_fm'[OF assms(1,5-9)] by simp

lemma is_wfrec_on_iff_sats[iff_sats]:
  assumes MH_iff_sats:
    "!!a0 a1 a2 a3 a4.
        [|a0\<in>Aa; a1\<in>Aa; a2\<in>Aa; a3\<in>Aa; a4\<in>Aa|]
        ==> MH(a2, a1, a0) \<longleftrightarrow> sats(Aa, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
    "nth(x, env) = xx \<Longrightarrow>
    nth(y, env) = yy \<Longrightarrow>
    nth(z, env) = zz \<Longrightarrow>
    x \<in> nat \<Longrightarrow>
    y \<in> nat \<Longrightarrow>
    z \<in> nat \<Longrightarrow>
    env \<in> list(Aa) \<Longrightarrow>
    0 \<in> Aa \<Longrightarrow> is_wfrec_on(##Aa, MH, aa,xx, yy, zz) \<longleftrightarrow> Aa, env \<Turnstile> is_wfrec_fm(p,x,y,z)"
  using assms sats_is_wfrec_fm'[OF assms] unfolding is_wfrec_on_def by simp

text\<open>Formulas for particular replacement instances\<close>

text\<open>Now we introduce some definitions used in the definition of check; which
is defined by well-founded recursion using replacement in the recursive call.\<close>

\<comment> \<open>The well-founded relation for defining check.\<close>
definition
  rcheck :: "i \<Rightarrow> i" where
  "rcheck(x) \<equiv> Memrel(eclose({x}))^+"

relativize "rcheck" "is_rcheck"
synthesize "is_rcheck" from_definition
arity_theorem for "is_rcheck_fm"

\<comment> \<open>The function used for the replacement.\<close>
definition
  PHcheck :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
  "PHcheck(M,o,f,y,p) \<equiv> M(p) \<and> (\<exists>fy[M]. fun_apply(M,f,y,fy) \<and> pair(M,fy,o,p))"

synthesize "PHcheck" from_definition assuming "nonempty"
arity_theorem for "PHcheck_fm"

\<comment> \<open>The recursive call for check. We could use the meta-program relationalize for
this; but it makes some proofs more involved.\<close>
definition
  is_Hcheck :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
  "is_Hcheck(M,o,z,f,hc)  \<equiv> is_Replace(M,z,PHcheck(M,o,f),hc)"

synthesize "is_Hcheck" from_definition assuming "nonempty"

lemma arity_is_Hcheck_fm:
  assumes "m\<in>nat" "n\<in>nat" "p\<in>nat" "o\<in>nat"
  shows "arity(is_Hcheck_fm(m,n,p,o)) = succ(o) \<union> succ(n) \<union> succ(p) \<union> succ(m) "
  unfolding is_Hcheck_fm_def
  using assms arity_Replace_fm[rule_format,OF PHcheck_fm_type _ _ _ arity_PHcheck_fm]
    pred_Un_distrib Un_assoc Un_nat_type
  by simp

\<comment> \<open>The relational version of check is hand-made because our automatic tool
does not handle \<^term>\<open>wfrec\<close>.\<close>
definition
  is_check :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_check(M,o,x,z) \<equiv> \<exists>rch[M]. is_rcheck(M,x,rch) \<and>
      is_wfrec(M,is_Hcheck(M,o),rch,x,z)"

\<comment> \<open>Finally, we internalize the formula.\<close>
definition
  check_fm :: "[i,i,i] \<Rightarrow> i" where
  "check_fm(o,x,z) \<equiv> Exists(And(is_rcheck_fm(1+\<^sub>\<omega>x,0),
                      is_wfrec_fm(is_Hcheck_fm(6+\<^sub>\<omega>o,2,1,0),0,1+\<^sub>\<omega>x,1+\<^sub>\<omega>z)))"

lemma check_fm_type[TC]: "x\<in>nat \<Longrightarrow> o\<in>nat \<Longrightarrow> z\<in>nat \<Longrightarrow> check_fm(x,o,z) \<in> formula"
  by (simp add:check_fm_def)

lemma sats_check_fm :
  assumes
    "o\<in>nat" "x\<in>nat" "z\<in>nat" "env\<in>list(M)" "0\<in>M"
  shows
    "(M , env \<Turnstile> check_fm(o,x,z)) \<longleftrightarrow> is_check(##M,nth(o,env),nth(x,env),nth(z,env))"
proof -
  have sats_is_Hcheck_fm:
    "\<And>a0 a1 a2 a3 a4 a6. \<lbrakk> a0\<in>M; a1\<in>M; a2\<in>M; a3\<in>M; a4\<in>M;a6 \<in>M\<rbrakk> \<Longrightarrow>
         is_Hcheck(##M,a6,a2, a1, a0) \<longleftrightarrow>
         (M , [a0,a1,a2,a3,a4,r,a6]@env \<Turnstile> is_Hcheck_fm(6,2,1,0))" if "r\<in>M" for r
    using that assms
    by simp
  then
  have "(M , [r]@env \<Turnstile> is_wfrec_fm(is_Hcheck_fm(6+\<^sub>\<omega>o,2,1,0),0,1+\<^sub>\<omega>x,1+\<^sub>\<omega>z))
        \<longleftrightarrow> is_wfrec(##M,is_Hcheck(##M,nth(o,env)),r,nth(x,env),nth(z,env))"
    if "r\<in>M" for r
    using that assms is_wfrec_iff_sats'[symmetric]
    by simp
  then
  show ?thesis
    unfolding is_check_def check_fm_def
    using assms is_rcheck_iff_sats[symmetric]
    by simp
qed

lemma iff_sats_check_fm[iff_sats] :
  assumes
    "nth(o, env) = oa" "nth(x, env) = xa" "nth(z, env) = za" "o \<in> nat" "x \<in> nat" "z \<in> nat" "env \<in> list(A)" "0 \<in> A"
  shows "is_check(##A, oa,xa, za) \<longleftrightarrow> A, env \<Turnstile> check_fm(o,x,z)"
  using assms sats_check_fm[symmetric]
  by auto

lemma arity_check_fm[arity]:
  assumes "m\<in>nat" "n\<in>nat" "o\<in>nat"
  shows "arity(check_fm(m,n,o)) = succ(o) \<union> succ(n) \<union> succ(m) "
  unfolding check_fm_def
  using assms arity_is_wfrec_fm[rule_format,OF _ _ _ _ _ arity_is_Hcheck_fm]
    pred_Un_distrib Un_assoc arity_tran_closure_fm
  by (auto simp add:arity)

notation check_fm (\<open>\<cdot>_\<^sup>v_ is _\<cdot>\<close>)

\<comment> \<open>The pair of elements belongs to some set. The intended set is the preorder.\<close>
definition
  is_leq :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_leq(A,l,q,p) \<equiv> \<exists>qp[A]. (pair(A,q,p,qp) \<and> qp\<in>l)"

synthesize "is_leq" from_definition assuming "nonempty"
arity_theorem for "is_leq_fm"

abbreviation
  fm_leq :: "[i,i,i] \<Rightarrow> i" (\<open>\<cdot>_\<preceq>\<^bsup>_\<^esup>_\<cdot>\<close>) where
  "fm_leq(A,l,B) \<equiv> is_leq_fm(l,A,B)"

subsection\<open>Formulas used to prove some generic instances.\<close>

definition \<rho>_repl :: "i\<Rightarrow>i" where
  "\<rho>_repl(l) \<equiv> rsum({\<langle>0, 1\<rangle>, \<langle>1, 0\<rangle>}, id(l), 2, 3, l)"

lemma f_type : "{\<langle>0, 1\<rangle>, \<langle>1, 0\<rangle>} \<in> 2 \<rightarrow> 3"
  using Pi_iff unfolding function_def by auto

\<comment> \<open>thm\<open>Internalize.sum_type\<close> clashes with thm\<open>Renaming.sum_type\<close>.\<close>
hide_fact Internalize.sum_type

lemma ren_type :
  assumes "l\<in>nat"
  shows "\<rho>_repl(l) : 2+\<^sub>\<omega>l \<rightarrow> 3+\<^sub>\<omega>l"
  using sum_type[of 2 3 l l "{\<langle>0, 1\<rangle>, \<langle>1, 0\<rangle>}" "id(l)"] f_type assms id_type
  unfolding \<rho>_repl_def by auto

definition Lambda_in_M_fm where [simp]:"Lambda_in_M_fm(\<phi>,len) \<equiv>
  \<cdot>(\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and>
   ren(\<phi>) ` (2 +\<^sub>\<omega> len) ` (3 +\<^sub>\<omega> len) ` \<rho>_repl(len) \<cdot>\<cdot>) \<and> \<cdot>0 \<in> len +\<^sub>\<omega> 2\<cdot>\<cdot>"

lemma Lambda_in_M_fm_type[TC]: "\<phi>\<in>formula \<Longrightarrow> len\<in>nat \<Longrightarrow> Lambda_in_M_fm(\<phi>,len) \<in>formula"
  using ren_tc[of \<phi> "2+\<^sub>\<omega>len" "3+\<^sub>\<omega>len" "\<rho>_repl(len)"] ren_type
  unfolding Lambda_in_M_fm_def
  by simp

definition \<rho>_pair_repl :: "i\<Rightarrow>i" where
  "\<rho>_pair_repl(l) \<equiv> rsum({\<langle>0, 0\<rangle>, \<langle>1, 1\<rangle>, \<langle>2, 3\<rangle>}, id(l), 3, 4, l)"

definition LambdaPair_in_M_fm where "LambdaPair_in_M_fm(\<phi>,len) \<equiv>
  \<cdot>(\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and>
             ren((\<cdot>\<exists>(\<cdot>\<exists>\<cdot>\<cdot>fst(2) is 0\<cdot> \<and> \<cdot>\<cdot>snd(2) is 1\<cdot> \<and> ren(\<phi>) ` (3 +\<^sub>\<omega> len) ` (4 +\<^sub>\<omega> len) ` \<rho>_pair_repl(len) \<cdot>\<cdot>\<cdot>)\<cdot>)) ` (2 +\<^sub>\<omega> len) `
             (3 +\<^sub>\<omega> len) `
             \<rho>_repl(len) \<cdot>\<cdot>) \<and>
          \<cdot>0 \<in> len +\<^sub>\<omega> 2\<cdot>\<cdot> "

lemma f_type' : "{\<langle>0,0 \<rangle>, \<langle>1, 1\<rangle>, \<langle>2, 3\<rangle>} \<in> 3 \<rightarrow> 4"
  using Pi_iff unfolding function_def by auto

lemma ren_type' :
  assumes "l\<in>nat"
  shows "\<rho>_pair_repl(l) : 3+\<^sub>\<omega>l \<rightarrow> 4+\<^sub>\<omega>l"
  using sum_type[of 3 4 l l "{\<langle>0, 0\<rangle>, \<langle>1, 1\<rangle>, \<langle>2, 3\<rangle>}" "id(l)"] f_type' assms id_type
  unfolding \<rho>_pair_repl_def by auto

lemma LambdaPair_in_M_fm_type[TC]: "\<phi>\<in>formula \<Longrightarrow> len\<in>nat \<Longrightarrow> LambdaPair_in_M_fm(\<phi>,len) \<in>formula"
  using ren_tc[OF _ _ _ ren_type',of \<phi> "len"] Lambda_in_M_fm_type
  unfolding LambdaPair_in_M_fm_def
  by simp

subsection\<open>The relation \<^term>\<open>frecrel\<close>\<close>

definition
  frecrelP :: "[i\<Rightarrow>o,i] \<Rightarrow> o" where
  "frecrelP(M,xy) \<equiv> (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,xy) \<and> is_frecR(M,x,y))"

synthesize "frecrelP" from_definition
arity_theorem for "frecrelP_fm"

definition
  is_frecrel :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_frecrel(M,A,r) \<equiv> \<exists>A2[M]. cartprod(M,A,A,A2) \<and> is_Collect(M,A2, frecrelP(M) ,r)"

synthesize "frecrel" from_definition "is_frecrel"
arity_theorem for "frecrel_fm"

definition
  names_below :: "i \<Rightarrow> i \<Rightarrow> i" where
  "names_below(P,x) \<equiv> 2\<times>ecloseN(x)\<times>ecloseN(x)\<times>P"

lemma names_belowsD:
  assumes "x \<in> names_below(P,z)"
  obtains f n1 n2 p where
    "x = \<langle>f,n1,n2,p\<rangle>" "f\<in>2" "n1\<in>ecloseN(z)" "n2\<in>ecloseN(z)" "p\<in>P"
  using assms unfolding names_below_def by auto

synthesize "number2" from_definition

lemma number2_iff :
  "(A)(c) \<Longrightarrow> number2(A,c) \<longleftrightarrow> (\<exists>b[A]. \<exists>a[A]. successor(A, b, c) \<and> successor(A, a, b) \<and> empty(A, a))"
  unfolding number2_def number1_def by auto
arity_theorem for "number2_fm"

reldb_add "ecloseN" "is_ecloseN"
relativize "names_below" "is_names_below"
synthesize "is_names_below" from_definition
arity_theorem for "is_names_below_fm"

definition
  is_tuple :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
  "is_tuple(M,z,t1,t2,p,t) \<equiv> \<exists>t1t2p[M]. \<exists>t2p[M]. pair(M,t2,p,t2p) \<and> pair(M,t1,t2p,t1t2p) \<and>
                                                  pair(M,z,t1t2p,t)"

synthesize "is_tuple" from_definition
arity_theorem for "is_tuple_fm"

subsection\<open>Definition of Forces\<close>

subsubsection\<open>Definition of \<^term>\<open>forces\<close> for equality and membership\<close>
text\<open>$p\forces \tau = \theta$ if for every $q\leqslant p$ both $q\forces \sigma \in \tau$
and $q\forces \sigma \in \theta$ hold for all $\sigma \in \dom(\tau)\cup \dom(\theta)$.\<close>
definition
  eq_case :: "[i,i,i,i,i,i] \<Rightarrow> o" where
  "eq_case(\<tau>,\<theta>,p,P,leq,f) \<equiv> \<forall>\<sigma>. \<sigma> \<in> domain(\<tau>) \<union> domain(\<theta>) \<longrightarrow>
      (\<forall>q. q\<in>P \<and> \<langle>q,p\<rangle>\<in>leq \<longrightarrow> (f`\<langle>1,\<sigma>,\<tau>,q\<rangle>=1  \<longleftrightarrow> f`\<langle>1,\<sigma>,\<theta>,q\<rangle> =1))"

relativize "eq_case" "is_eq_case"
synthesize "eq_case" from_definition "is_eq_case"

text\<open>$p\forces \tau \in \theta$ if for every $v\leqslant p$
  there exist $q$, $r$, and $\sigma$ such that
  $v\leqslant q$, $q\leqslant r$, $\langle \sigma,r\rangle \in \tau$, and
  $q\forces \pi = \sigma$.\<close>
definition
  mem_case :: "[i,i,i,i,i,i] \<Rightarrow> o" where
  "mem_case(\<tau>,\<theta>,p,P,leq,f) \<equiv> \<forall>v\<in>P. \<langle>v,p\<rangle>\<in>leq \<longrightarrow>
    (\<exists>q. \<exists>\<sigma>. \<exists>r. r\<in>P \<and> q\<in>P \<and> \<langle>q,v\<rangle>\<in>leq \<and> \<langle>\<sigma>,r\<rangle> \<in> \<theta> \<and> \<langle>q,r\<rangle>\<in>leq \<and>  f`\<langle>0,\<tau>,\<sigma>,q\<rangle> = 1)"

relativize "mem_case" "is_mem_case"
synthesize "mem_case" from_definition "is_mem_case"
arity_theorem intermediate for "eq_case_fm"
lemma arity_eq_case_fm[arity]:
  assumes
    "n1\<in>nat" "n2\<in>nat" "p\<in>nat" "P\<in>nat" "leq\<in>nat" "f\<in>nat"
  shows
    "arity(eq_case_fm(n1,n2,p,P,leq,f)) =
    succ(n1) \<union> succ(n2) \<union> succ(p) \<union> succ(P) \<union> succ(leq) \<union> succ(f)"
  using assms arity_eq_case_fm'
  by auto

arity_theorem intermediate for "mem_case_fm"
lemma arity_mem_case_fm[arity] :
  assumes
    "n1\<in>nat" "n2\<in>nat" "p\<in>nat" "P\<in>nat" "leq\<in>nat" "f\<in>nat"
  shows
    "arity(mem_case_fm(n1,n2,p,P,leq,f)) =
    succ(n1) \<union> succ(n2) \<union> succ(p) \<union> succ(P) \<union> succ(leq) \<union> succ(f)"
  using assms arity_mem_case_fm'
  by auto

definition
  Hfrc :: "[i,i,i,i] \<Rightarrow> o" where
  "Hfrc(P,leq,fnnc,f) \<equiv> \<exists>ft. \<exists>\<tau>. \<exists>\<theta>. \<exists>p. p\<in>P \<and> fnnc = \<langle>ft,\<tau>,\<theta>,p\<rangle> \<and>
     (  ft = 0 \<and>  eq_case(\<tau>,\<theta>,p,P,leq,f)
      \<or> ft = 1 \<and> mem_case(\<tau>,\<theta>,p,P,leq,f))"

relativize "Hfrc" "is_Hfrc"
synthesize "Hfrc" from_definition "is_Hfrc"

definition
  is_Hfrc_at :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
  "is_Hfrc_at(M,P,leq,fnnc,f,b) \<equiv>
            (empty(M,b) \<and> \<not> is_Hfrc(M,P,leq,fnnc,f))
          \<or> (number1(M,b) \<and> is_Hfrc(M,P,leq,fnnc,f))"

synthesize "Hfrc_at" from_definition "is_Hfrc_at"
arity_theorem intermediate for "Hfrc_fm"

lemma arity_Hfrc_fm[arity] :
  assumes
    "P\<in>nat" "leq\<in>nat" "fnnc\<in>nat" "f\<in>nat"
  shows
    "arity(Hfrc_fm(P,leq,fnnc,f)) = succ(P) \<union> succ(leq) \<union> succ(fnnc) \<union> succ(f)"
  using assms arity_Hfrc_fm'
  by auto

arity_theorem for "Hfrc_at_fm"

subsubsection\<open>The well-founded relation \<^term>\<open>forcerel\<close>\<close>
definition
  forcerel :: "i \<Rightarrow> i \<Rightarrow> i" where
  "forcerel(P,x) \<equiv> frecrel(names_below(P,x))^+"

definition
  is_forcerel :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_forcerel(M,P,x,z) \<equiv> \<exists>r[M]. \<exists>nb[M]. tran_closure(M,r,z) \<and>
                        (is_names_below(M,P,x,nb) \<and> is_frecrel(M,nb,r))"
synthesize "is_forcerel" from_definition
arity_theorem for "is_forcerel_fm"

subsection\<open>\<^term>\<open>frc_at\<close>, forcing for atomic formulas\<close>
definition
  frc_at :: "[i,i,i] \<Rightarrow> i" where
  "frc_at(P,leq,fnnc) \<equiv> wfrec(frecrel(names_below(P,fnnc)),fnnc,
                              \<lambda>x f. bool_of_o(Hfrc(P,leq,x,f)))"

\<comment> \<open>The relational form is defined manually because it uses \<^term>\<open>wfrec\<close>.\<close>
definition
  is_frc_at :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
  "is_frc_at(M,P,leq,x,z) \<equiv> \<exists>r[M]. is_forcerel(M,P,x,r) \<and>
                                    is_wfrec(M,is_Hfrc_at(M,P,leq),r,x,z)"

definition
  frc_at_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "frc_at_fm(p,l,x,z) \<equiv> Exists(And(is_forcerel_fm(succ(p),succ(x),0),
          is_wfrec_fm(Hfrc_at_fm(6+\<^sub>\<omega>p,6+\<^sub>\<omega>l,2,1,0),0,succ(x),succ(z))))"

lemma frc_at_fm_type [TC] :
  "\<lbrakk>p\<in>nat;l\<in>nat;x\<in>nat;z\<in>nat\<rbrakk> \<Longrightarrow> frc_at_fm(p,l,x,z)\<in>formula"
  unfolding frc_at_fm_def by simp

lemma arity_frc_at_fm[arity] :
  assumes "p\<in>nat" "l\<in>nat" "x\<in>nat" "z\<in>nat"
  shows "arity(frc_at_fm(p,l,x,z)) = succ(p) \<union> succ(l) \<union> succ(x) \<union> succ(z)"
proof -
  let ?\<phi> = "Hfrc_at_fm(6 +\<^sub>\<omega> p, 6 +\<^sub>\<omega> l, 2, 1, 0)"
  note assms
  moreover from this
  have  "arity(?\<phi>) = (7+\<^sub>\<omega>p) \<union> (7+\<^sub>\<omega>l)" "?\<phi> \<in> formula"
    using arity_Hfrc_at_fm ord_simp_union
    by auto
  moreover from calculation
  have "arity(is_wfrec_fm(?\<phi>, 0, succ(x), succ(z))) = 2+\<^sub>\<omega>p \<union> (2+\<^sub>\<omega>l) \<union> (2+\<^sub>\<omega>x) \<union> (2+\<^sub>\<omega>z)"
    using arity_is_wfrec_fm[OF \<open>?\<phi>\<in>_\<close> _ _ _ _ \<open>arity(?\<phi>) = _\<close>] pred_Un_distrib pred_succ_eq
      union_abs1
    by auto
  moreover from assms
  have "arity(is_forcerel_fm(succ(p),succ(x),0)) = 2+\<^sub>\<omega>p \<union> (2+\<^sub>\<omega>x)"
    using arity_is_forcerel_fm ord_simp_union
    by auto
  ultimately
  show ?thesis
    unfolding frc_at_fm_def
    using arity_is_forcerel_fm pred_Un_distrib
    by (auto simp:FOL_arities)
qed

lemma sats_frc_at_fm :
  assumes
    "p\<in>nat" "l\<in>nat" "i\<in>nat" "j\<in>nat" "env\<in>list(A)" "i < length(env)" "j < length(env)"
  shows
    "(A , env \<Turnstile> frc_at_fm(p,l,i,j)) \<longleftrightarrow>
     is_frc_at(##A,nth(p,env),nth(l,env),nth(i,env),nth(j,env))"
proof -
  {
    fix r pp ll
    assume "r\<in>A"
    have "is_Hfrc_at(##A,nth(p,env),nth(l,env),a2, a1, a0) \<longleftrightarrow>
         (A, [a0,a1,a2,a3,a4,r]@env \<Turnstile> Hfrc_at_fm(6+\<^sub>\<omega>p,6+\<^sub>\<omega>l,2,1,0))"
      if "a0\<in>A" "a1\<in>A" "a2\<in>A" "a3\<in>A" "a4\<in>A" for a0 a1 a2 a3 a4
      using  that assms \<open>r\<in>A\<close>
        Hfrc_at_iff_sats[of "6+\<^sub>\<omega>p" "6+\<^sub>\<omega>l" 2 1 0 "[a0,a1,a2,a3,a4,r]@env" A]  by simp
    with \<open>r\<in>A\<close>
    have "(A,[r]@env \<Turnstile> is_wfrec_fm(Hfrc_at_fm(6+\<^sub>\<omega>p, 6+\<^sub>\<omega>l,2,1,0),0, i+\<^sub>\<omega>1, j+\<^sub>\<omega>1)) \<longleftrightarrow>
         is_wfrec(##A, is_Hfrc_at(##A, nth(p,env), nth(l,env)), r,nth(i, env), nth(j, env))"
      using assms sats_is_wfrec_fm
      by simp
  }
  moreover
  have "(A, Cons(r, env) \<Turnstile> is_forcerel_fm(succ(p), succ(i), 0)) \<longleftrightarrow>
        is_forcerel(##A,nth(p,env),nth(i,env),r)" if "r\<in>A" for r
    using assms sats_is_forcerel_fm that
    by simp
  ultimately
  show ?thesis
    unfolding is_frc_at_def frc_at_fm_def
    using assms
    by simp
qed

lemma frc_at_fm_iff_sats:
  assumes "nth(i,env) = w" "nth(j,env) = x" "nth(k,env) = y" "nth(l,env) = z"
    "i \<in> nat" "j \<in> nat" "k \<in> nat" "l\<in>nat" "env \<in> list(A)" "k<length(env)" "l<length(env)"
  shows "is_frc_at(##A, w, x, y,z) \<longleftrightarrow> (A , env \<Turnstile> frc_at_fm(i,j,k,l))"
  using assms sats_frc_at_fm
  by simp

declare frc_at_fm_iff_sats [iff_sats]

definition
  forces_eq' :: "[i,i,i,i,i] \<Rightarrow> o" where
  "forces_eq'(P,l,p,t1,t2) \<equiv> frc_at(P,l,\<langle>0,t1,t2,p\<rangle>) = 1"

definition
  forces_mem' :: "[i,i,i,i,i] \<Rightarrow> o" where
  "forces_mem'(P,l,p,t1,t2) \<equiv> frc_at(P,l,\<langle>1,t1,t2,p\<rangle>) = 1"

definition
  forces_neq' :: "[i,i,i,i,i] \<Rightarrow> o" where
  "forces_neq'(P,l,p,t1,t2) \<equiv> \<not> (\<exists>q\<in>P. \<langle>q,p\<rangle>\<in>l \<and> forces_eq'(P,l,q,t1,t2))"

definition
  forces_nmem' :: "[i,i,i,i,i] \<Rightarrow> o" where
  "forces_nmem'(P,l,p,t1,t2) \<equiv> \<not> (\<exists>q\<in>P. \<langle>q,p\<rangle>\<in>l \<and> forces_mem'(P,l,q,t1,t2))"

\<comment> \<open>The following definitions are explicitly defined to avoid the expansion
of concepts.\<close>
definition
  is_forces_eq' :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
  "is_forces_eq'(M,P,l,p,t1,t2) \<equiv> \<exists>o[M]. \<exists>z[M]. \<exists>t[M]. number1(M,o) \<and> empty(M,z) \<and>
                                is_tuple(M,z,t1,t2,p,t) \<and> is_frc_at(M,P,l,t,o)"

definition
  is_forces_mem' :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
  "is_forces_mem'(M,P,l,p,t1,t2) \<equiv> \<exists>o[M]. \<exists>t[M]. number1(M,o) \<and>
                                is_tuple(M,o,t1,t2,p,t) \<and> is_frc_at(M,P,l,t,o)"

definition
  is_forces_neq' :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
  "is_forces_neq'(M,P,l,p,t1,t2) \<equiv>
      \<not> (\<exists>q[M]. q\<in>P \<and> (\<exists>qp[M]. pair(M,q,p,qp) \<and> qp\<in>l \<and> is_forces_eq'(M,P,l,q,t1,t2)))"

definition
  is_forces_nmem' :: "[i\<Rightarrow>o,i,i,i,i,i] \<Rightarrow> o" where
  "is_forces_nmem'(M,P,l,p,t1,t2) \<equiv>
      \<not> (\<exists>q[M]. \<exists>qp[M]. q\<in>P \<and> pair(M,q,p,qp) \<and> qp\<in>l \<and> is_forces_mem'(M,P,l,q,t1,t2))"

synthesize "forces_eq" from_definition "is_forces_eq'"
synthesize "forces_mem" from_definition "is_forces_mem'"
synthesize "forces_neq" from_definition "is_forces_neq'" assuming "nonempty"
synthesize "forces_nmem" from_definition "is_forces_nmem'" assuming "nonempty"

context
  notes Un_assoc[simp] Un_trasposition_aux2[simp]
begin
arity_theorem for "forces_eq_fm"
arity_theorem for "forces_mem_fm"
arity_theorem for "forces_neq_fm"
arity_theorem for "forces_nmem_fm"
end

subsection\<open>Forcing for general formulas\<close>

definition
  ren_forces_nand :: "i\<Rightarrow>i" where
  "ren_forces_nand(\<phi>) \<equiv> Exists(And(Equal(0,1),iterates(\<lambda>p. incr_bv(p)`1 , 2, \<phi>)))"

lemma ren_forces_nand_type[TC] :
  "\<phi>\<in>formula \<Longrightarrow> ren_forces_nand(\<phi>) \<in>formula"
  unfolding ren_forces_nand_def
  by simp

lemma arity_ren_forces_nand :
  assumes "\<phi>\<in>formula"
  shows "arity(ren_forces_nand(\<phi>)) \<le> succ(arity(\<phi>))"
proof -
  consider (lt) "1<arity(\<phi>)" | (ge) "\<not> 1 < arity(\<phi>)"
    by auto
  then
  show ?thesis
  proof cases
    case lt
    with \<open>\<phi>\<in>_\<close>
    have "2 < succ(arity(\<phi>))" "2<arity(\<phi>)+\<^sub>\<omega>2"
      using succ_ltI by auto
    with \<open>\<phi>\<in>_\<close>
    have "arity(iterates(\<lambda>p. incr_bv(p)`1,2,\<phi>)) = 2+\<^sub>\<omega>arity(\<phi>)"
      using arity_incr_bv_lemma lt
      by auto
    with \<open>\<phi>\<in>_\<close>
    show ?thesis
      unfolding ren_forces_nand_def
      using lt pred_Un_distrib union_abs1 Un_assoc[symmetric] Un_le_compat
      by (simp add:FOL_arities)
  next
    case ge
    with \<open>\<phi>\<in>_\<close>
    have "arity(\<phi>) \<le> 1" "pred(arity(\<phi>)) \<le> 1"
      using not_lt_iff_le le_trans[OF le_pred]
      by simp_all
    with \<open>\<phi>\<in>_\<close>
    have "arity(iterates(\<lambda>p. incr_bv(p)`1,2,\<phi>)) = (arity(\<phi>))"
      using arity_incr_bv_lemma ge
      by simp
    with \<open>arity(\<phi>) \<le> 1\<close> \<open>\<phi>\<in>_\<close> \<open>pred(_) \<le> 1\<close>
    show ?thesis
      unfolding ren_forces_nand_def
      using  pred_Un_distrib union_abs1 Un_assoc[symmetric] union_abs2
      by (simp add:FOL_arities)
  qed
qed

lemma sats_ren_forces_nand:
  "[q,P,leq,o,p] @ env \<in> list(M) \<Longrightarrow> \<phi>\<in>formula \<Longrightarrow>
   (M, [q,p,P,leq,o] @ env \<Turnstile> ren_forces_nand(\<phi>)) \<longleftrightarrow> (M, [q,P,leq,o] @ env \<Turnstile> \<phi>)"
  unfolding ren_forces_nand_def
  using sats_incr_bv_iff [of _ _ M _ "[q]"]
  by simp

definition
  ren_forces_forall :: "i\<Rightarrow>i" where
  "ren_forces_forall(\<phi>) \<equiv>
      Exists(Exists(Exists(Exists(Exists(
        And(Equal(0,6),And(Equal(1,7),And(Equal(2,8),And(Equal(3,9),
        And(Equal(4,5),iterates(\<lambda>p. incr_bv(p)`5 , 5, \<phi>)))))))))))"

lemma arity_ren_forces_all :
  assumes "\<phi>\<in>formula"
  shows "arity(ren_forces_forall(\<phi>)) = 5 \<union> arity(\<phi>)"
proof -
  consider (lt) "5<arity(\<phi>)" | (ge) "\<not> 5 < arity(\<phi>)"
    by auto
  then
  show ?thesis
  proof cases
    case lt
    with \<open>\<phi>\<in>_\<close>
    have "5 < succ(arity(\<phi>))" "5<arity(\<phi>)+\<^sub>\<omega>2"  "5<arity(\<phi>)+\<^sub>\<omega>3"  "5<arity(\<phi>)+\<^sub>\<omega>4"
      using succ_ltI by auto
    with \<open>\<phi>\<in>_\<close>
    have "arity(iterates(\<lambda>p. incr_bv(p)`5,5,\<phi>)) = 5+\<^sub>\<omega>arity(\<phi>)"
      using arity_incr_bv_lemma lt
      by simp
    with \<open>\<phi>\<in>_\<close>
    show ?thesis
      unfolding ren_forces_forall_def
      using pred_Un_distrib union_abs1 Un_assoc[symmetric] union_abs2
      by (simp add:FOL_arities)
  next
    case ge
    with \<open>\<phi>\<in>_\<close>
    have "arity(\<phi>) \<le> 5" "pred^5(arity(\<phi>)) \<le> 5"
      using not_lt_iff_le le_trans[OF le_pred]
      by simp_all
    with \<open>\<phi>\<in>_\<close>
    have "arity(iterates(\<lambda>p. incr_bv(p)`5,5,\<phi>)) = arity(\<phi>)"
      using arity_incr_bv_lemma ge
      by simp
    with \<open>arity(\<phi>) \<le> 5\<close> \<open>\<phi>\<in>_\<close> \<open>pred^5(_) \<le> 5\<close>
    show ?thesis
      unfolding ren_forces_forall_def
      using  pred_Un_distrib union_abs1 Un_assoc[symmetric] union_abs2
      by (simp add:FOL_arities)
  qed
qed

lemma ren_forces_forall_type[TC] :
  "\<phi>\<in>formula \<Longrightarrow> ren_forces_forall(\<phi>) \<in>formula"
  unfolding ren_forces_forall_def by simp

lemma sats_ren_forces_forall :
  "[x,P,leq,o,p] @ env \<in> list(M) \<Longrightarrow> \<phi>\<in>formula \<Longrightarrow>
    (M, [x,p,P,leq,o] @ env \<Turnstile> ren_forces_forall(\<phi>)) \<longleftrightarrow> (M, [p,P,leq,o,x] @ env \<Turnstile> \<phi>)"
  unfolding ren_forces_forall_def
  using sats_incr_bv_iff [of _ _ M _ "[p,P,leq,o,x]"]
  by simp

subsubsection\<open>The primitive recursion\<close>

consts forces' :: "i\<Rightarrow>i"
primrec
  "forces'(Member(x,y)) = forces_mem_fm(1,2,0,x+\<^sub>\<omega>4,y+\<^sub>\<omega>4)"
  "forces'(Equal(x,y))  = forces_eq_fm(1,2,0,x+\<^sub>\<omega>4,y+\<^sub>\<omega>4)"
  "forces'(Nand(p,q))   =
        Neg(Exists(And(Member(0,2),And(is_leq_fm(3,0,1),And(ren_forces_nand(forces'(p)),
                                         ren_forces_nand(forces'(q)))))))"
  "forces'(Forall(p))   = Forall(ren_forces_forall(forces'(p)))"

definition
  forces :: "i\<Rightarrow>i" where
  "forces(\<phi>) \<equiv> And(Member(0,1),forces'(\<phi>))"

lemma forces'_type [TC]:  "\<phi>\<in>formula \<Longrightarrow> forces'(\<phi>) \<in> formula"
  by (induct \<phi> set:formula; simp)

lemma forces_type[TC] : "\<phi>\<in>formula \<Longrightarrow> forces(\<phi>) \<in> formula"
  unfolding forces_def by simp

subsection\<open>The arity of \<^term>\<open>forces\<close>\<close>

lemma arity_forces_at:
  assumes  "x \<in> nat" "y \<in> nat"
  shows "arity(forces(Member(x, y))) = (succ(x) \<union> succ(y)) +\<^sub>\<omega> 4"
    "arity(forces(Equal(x, y))) = (succ(x) \<union> succ(y)) +\<^sub>\<omega> 4"
  unfolding forces_def
  using assms arity_forces_mem_fm arity_forces_eq_fm succ_Un_distrib ord_simp_union
  by (auto simp:FOL_arities,(rule_tac le_anti_sym,simp_all,(rule_tac not_le_anti_sym,simp_all))+)

lemma arity_forces':
  assumes "\<phi>\<in>formula"
  shows "arity(forces'(\<phi>)) \<le> arity(\<phi>) +\<^sub>\<omega> 4"
  using assms
proof (induct set:formula)
  case (Member x y)
  then
  show ?case
    using arity_forces_mem_fm succ_Un_distrib ord_simp_union leI not_le_iff_lt
    by simp
next
  case (Equal x y)
  then
  show ?case
    using arity_forces_eq_fm succ_Un_distrib ord_simp_union leI not_le_iff_lt
    by simp
next
  case (Nand \<phi> \<psi>)
  let ?\<phi>' = "ren_forces_nand(forces'(\<phi>))"
  let ?\<psi>' = "ren_forces_nand(forces'(\<psi>))"
  have "arity(is_leq_fm(3, 0, 1)) = 4"
    using arity_is_leq_fm succ_Un_distrib ord_simp_union
    by simp
  have "3 \<le> (4+\<^sub>\<omega>arity(\<phi>)) \<union> (4+\<^sub>\<omega>arity(\<psi>))" (is "_ \<le> ?rhs")
    using ord_simp_union by simp
  from \<open>\<phi>\<in>_\<close> Nand
  have "pred(arity(?\<phi>')) \<le> ?rhs"  "pred(arity(?\<psi>')) \<le> ?rhs"
  proof -
    from \<open>\<phi>\<in>_\<close> \<open>\<psi>\<in>_\<close>
    have A:"pred(arity(?\<phi>')) \<le> arity(forces'(\<phi>))"
      "pred(arity(?\<psi>')) \<le> arity(forces'(\<psi>))"
      using pred_mono[OF _  arity_ren_forces_nand] pred_succ_eq
      by simp_all
    from Nand
    have "3 \<union> arity(forces'(\<phi>)) \<le> arity(\<phi>) +\<^sub>\<omega> 4"
      "3 \<union> arity(forces'(\<psi>)) \<le> arity(\<psi>) +\<^sub>\<omega> 4"
      using Un_le by simp_all
    with Nand
    show "pred(arity(?\<phi>')) \<le> ?rhs"
      "pred(arity(?\<psi>')) \<le> ?rhs"
      using le_trans[OF A(1)] le_trans[OF A(2)] le_Un_iff
      by simp_all
  qed
  with Nand \<open>_=4\<close>
  show ?case
    using pred_Un_distrib Un_assoc[symmetric] succ_Un_distrib union_abs1 Un_leI3[OF \<open>3 \<le> ?rhs\<close>]
    by (simp add:FOL_arities)
next
  case (Forall \<phi>)
  let ?\<phi>' = "ren_forces_forall(forces'(\<phi>))"
  show ?case
  proof (cases "arity(\<phi>) = 0")
    case True
    with Forall
    show ?thesis
    proof -
      from Forall True
      have "arity(forces'(\<phi>)) \<le> 5"
        using le_trans[of _ 4 5] by auto
      with \<open>\<phi>\<in>_\<close>
      have "arity(?\<phi>') \<le> 5"
        using arity_ren_forces_all[OF forces'_type[OF \<open>\<phi>\<in>_\<close>]] union_abs2
        by auto
      with Forall True
      show ?thesis
        using pred_mono[OF _ \<open>arity(?\<phi>') \<le> 5\<close>]
        by simp
    qed
  next
    case False
    with Forall
    show ?thesis
    proof -
      from Forall False
      have "arity(?\<phi>') = 5 \<union> arity(forces'(\<phi>))"
        "arity(forces'(\<phi>)) \<le> 5 +\<^sub>\<omega> arity(\<phi>)"
        "4 \<le> 3+\<^sub>\<omega>arity(\<phi>)"
        using Ord_0_lt arity_ren_forces_all
          le_trans[OF _ add_le_mono[of 4 5, OF _ le_refl]]
        by auto
      with \<open>\<phi>\<in>_\<close>
      have "5 \<union> arity(forces'(\<phi>)) \<le> 5+\<^sub>\<omega>arity(\<phi>)"
        using ord_simp_union by auto
      with \<open>\<phi>\<in>_\<close> \<open>arity(?\<phi>') = 5 \<union> _\<close>
      show ?thesis
        using pred_Un_distrib succ_pred_eq[OF _ \<open>arity(\<phi>)\<noteq>0\<close>]
          pred_mono[OF _ Forall(2)] Un_le[OF \<open>4\<le>3+\<^sub>\<omega>arity(\<phi>)\<close>]
        by simp
    qed
  qed
qed

lemma arity_forces :
  assumes "\<phi>\<in>formula"
  shows "arity(forces(\<phi>)) \<le> 4+\<^sub>\<omega>arity(\<phi>)"
  unfolding forces_def
  using assms arity_forces' le_trans ord_simp_union FOL_arities by auto

lemma arity_forces_le :
  assumes "\<phi>\<in>formula" "n\<in>nat" "arity(\<phi>) \<le> n"
  shows "arity(forces(\<phi>)) \<le> 4+\<^sub>\<omega>n"
  using assms le_trans[OF _ add_le_mono[OF le_refl[of 5] \<open>arity(\<phi>)\<le>_\<close>]] arity_forces
  by auto

definition rename_split_fm where
  "rename_split_fm(\<phi>) \<equiv> (\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>\<cdot>\<cdot>snd(9) is 0\<cdot> \<and> \<cdot>\<cdot>fst(9) is 4\<cdot> \<and> \<cdot>\<cdot>1=11\<cdot> \<and>
    \<cdot>\<cdot>2=12\<cdot> \<and> \<cdot>\<cdot>3=13\<cdot> \<and> \<cdot>\<cdot>5=7\<cdot> \<and>
    (\<lambda>p. incr_bv(p)`6)^8(forces(\<phi>)) \<cdot>\<cdot>\<cdot>\<cdot>\<cdot>\<cdot>\<cdot>)\<cdot>)\<cdot>)\<cdot>)\<cdot>)\<cdot>)"

lemma rename_split_fm_type[TC]: "\<phi>\<in>formula \<Longrightarrow> rename_split_fm(\<phi>)\<in>formula"
  unfolding rename_split_fm_def by simp

schematic_goal arity_rename_split_fm: "\<phi>\<in>formula \<Longrightarrow> arity(rename_split_fm(\<phi>)) = ?m"
  using arity_forces[of \<phi>] forces_type unfolding rename_split_fm_def
  by (simp add:arity Un_assoc[symmetric] union_abs1)

lemma arity_rename_split_fm_le:
  assumes "\<phi>\<in>formula"
  shows "arity(rename_split_fm(\<phi>)) \<le> 8 \<union> (6 +\<^sub>\<omega> arity(\<phi>))"
proof -
  from assms
  have arity_forces_6: "\<not> 1 < arity(\<phi>) \<Longrightarrow> 6 \<le> n \<Longrightarrow> arity(forces(\<phi>)) \<le> n" for n
    using le_trans lt_trans[of _ 5 n] not_lt_iff_le[of 1 "arity(\<phi>)"]
    by (auto intro!:le_trans[OF arity_forces])
  have pred1_arity_forces: "\<not> 1 < arity(\<phi>) \<Longrightarrow> pred^n(arity(forces(\<phi>))) \<le> 8" if "n\<in>nat" for n
    using that pred_le[of 7] le_succ[THEN [2] le_trans] arity_forces_6
    by (induct rule:nat_induct) auto
  have arity_forces_le_succ6: "pred^n(arity(forces(\<phi>))) \<le> succ(succ(succ(succ(succ(succ(arity(\<phi>)))))))"
    if "n\<in>nat" for n
    using that assms arity_forces[of \<phi>, THEN le_trans,
        OF _ le_succ, THEN le_trans, OF _ _ le_succ] le_trans[OF pred_le[OF _ le_succ]]
    by (induct rule:nat_induct) auto
  note trivial_arities = arity_forces_6
    arity_forces_le_succ6[of 1, simplified] arity_forces_le_succ6[of 2, simplified]
    arity_forces_le_succ6[of 3, simplified] arity_forces_le_succ6[of 4, simplified]
    arity_forces_le_succ6[of 5, simplified] arity_forces_le_succ6[of 6, simplified]
    pred1_arity_forces[of 1, simplified] pred1_arity_forces[of 2, simplified]
    pred1_arity_forces[of 3, simplified] pred1_arity_forces[of 4, simplified]
    pred1_arity_forces[of 5, simplified] pred1_arity_forces[of 6, simplified]
  show ?thesis
    using assms arity_forces[of \<phi>] arity_forces[of \<phi>, THEN le_trans, OF _ le_succ]
      arity_forces[of \<phi>, THEN le_trans, OF _ le_succ, THEN le_trans, OF _ _ le_succ]
    unfolding rename_split_fm_def
    by (simp add:arity Un_assoc[symmetric] union_abs1 arity_forces[of \<phi>] forces_type)
      ((subst arity_incr_bv_lemma; auto simp: arity ord_simp_union forces_type trivial_arities)+)
qed

definition body_ground_repl_fm where
  "body_ground_repl_fm(\<phi>) \<equiv> (\<cdot>\<exists>(\<cdot>\<exists>\<cdot>is_Vset_fm(2, 0) \<and> \<cdot>\<cdot>1 \<in> 0\<cdot> \<and> rename_split_fm(\<phi>) \<cdot>\<cdot>\<cdot>)\<cdot>)"

lemma body_ground_repl_fm_type[TC]: "\<phi>\<in>formula \<Longrightarrow> body_ground_repl_fm(\<phi>)\<in>formula"
  unfolding body_ground_repl_fm_def by simp

lemma arity_body_ground_repl_fm_le:
  notes le_trans[trans]
  assumes "\<phi>\<in>formula"
  shows "arity(body_ground_repl_fm(\<phi>)) \<le> 6 \<union> (arity(\<phi>) +\<^sub>\<omega> 4)"
proof -
  from \<open>\<phi>\<in>formula\<close>
  have ineq: "n \<union> pred(pred(arity(rename_split_fm(\<phi>))))
    \<le> m \<union> pred(pred(8 \<union> (arity(\<phi>) +\<^sub>\<omega>6 )))" if "n \<le> m" "n\<in>nat" "m\<in>nat" for n m
    using that arity_rename_split_fm_le[of \<phi>, THEN [2] pred_mono, THEN [2] pred_mono,
        THEN [2] Un_mono[THEN subset_imp_le, OF _ le_imp_subset]] le_imp_subset
    by auto
  moreover
  have eq1: "pred(pred(pred(4 \<union> 2 \<union> pred(pred(pred(
    pred(pred(pred(pred(pred(9 \<union> 1 \<union> 3 \<union> 2))))))))))) = 1"
    by (auto simp:pred_Un_distrib)
  ultimately
  have "pred(pred(pred(4 \<union> 2 \<union> pred(pred(pred(
    pred(pred(pred(pred(pred(9 \<union> 1 \<union> 3 \<union> 2))))))))))) \<union>
    pred(pred(arity(rename_split_fm(\<phi>)))) \<le>
    1 \<union> pred(pred(8 \<union> (arity(\<phi>) +\<^sub>\<omega>6 )))"
    by auto
  also from \<open>\<phi>\<in>formula\<close>
  have "1 \<union> pred(pred(8 \<union> (arity(\<phi>) +\<^sub>\<omega>6 ))) \<le> 6 \<union> (4+\<^sub>\<omega>arity(\<phi>))"
    by (auto simp:pred_Un_distrib Un_assoc[symmetric] ord_simp_union)
  finally
  show ?thesis
    using  \<open>\<phi>\<in>formula\<close> unfolding body_ground_repl_fm_def
    by (simp add:arity pred_Un_distrib, subst arity_transrec_fm[of "is_HVfrom_fm(8,2,1,0)" 3 1])
      (simp add:arity pred_Un_distrib,simp_all,
        auto simp add:eq1 arity_is_HVfrom_fm[of 8 2 1 0])
qed

definition ground_repl_fm where
  "ground_repl_fm(\<phi>) \<equiv> least_fm(body_ground_repl_fm(\<phi>), 1)"

lemma ground_repl_fm_type[TC]:
  "\<phi>\<in>formula \<Longrightarrow> ground_repl_fm(\<phi>) \<in> formula"
  unfolding ground_repl_fm_def by simp

lemma arity_ground_repl_fm:
  assumes "\<phi>\<in>formula"
  shows "arity(ground_repl_fm(\<phi>)) \<le> 5 \<union> (3 +\<^sub>\<omega> arity(\<phi>))"
proof -
  from assms
  have "pred(arity(body_ground_repl_fm(\<phi>))) \<le> 5 \<union> (3 +\<^sub>\<omega> arity(\<phi>))"
    using arity_body_ground_repl_fm_le pred_mono succ_Un_distrib
    by (rule_tac pred_le) auto
  with assms
  have "2 \<union> pred(arity(body_ground_repl_fm(\<phi>))) \<le> 5 \<union> (3 +\<^sub>\<omega> arity(\<phi>))"
    using Un_le le_Un_iff by auto
  then
  show ?thesis
    using assms arity_forces arity_body_ground_repl_fm_le
    unfolding least_fm_def ground_repl_fm_def
    apply (auto simp add:arity Un_assoc[symmetric])
    apply (simp add: pred_Un Un_assoc, simp add: Un_assoc[symmetric] union_abs1 pred_Un)
    by(simp only: Un_commute, subst Un_commute, simp add:ord_simp_union,force)
qed

synthesize "is_ordermap" from_definition assuming "nonempty"

synthesize "is_ordertype" from_definition assuming "nonempty"

synthesize "is_order_body" from_definition assuming "nonempty"
arity_theorem for "is_order_body_fm"

definition omap_wfrec_body where
  "omap_wfrec_body(A,r) \<equiv> (\<cdot>\<exists>\<cdot>image_fm(2, 0, 1) \<and> pred_set_fm(9+\<^sub>\<omega>A, 3,9+\<^sub>\<omega>r, 0) \<cdot>\<cdot>)"

lemma type_omap_wfrec_body_fm :"A\<in>nat \<Longrightarrow> r\<in>nat \<Longrightarrow> omap_wfrec_body(A,r)\<in>formula"
  unfolding omap_wfrec_body_def by simp

lemma arity_omap_wfrec_aux : "A\<in>nat \<Longrightarrow> r\<in>nat \<Longrightarrow> arity(omap_wfrec_body(A,r)) = (9+\<^sub>\<omega>A) \<union> (9+\<^sub>\<omega>r)"
  unfolding omap_wfrec_body_def
  using arity_image_fm arity_pred_set_fm pred_Un_distrib union_abs2[of 3] union_abs1
  by (simp add:FOL_arities, auto simp add:Un_assoc[symmetric] union_abs1)

lemma arity_omap_wfrec: "A\<in>nat \<Longrightarrow> r\<in>nat \<Longrightarrow>
  arity(is_wfrec_fm(omap_wfrec_body(A,r),r+\<^sub>\<omega>3, 1, 0)) = (4+\<^sub>\<omega>A) \<union> (4+\<^sub>\<omega>r)"
  using Arities.arity_is_wfrec_fm[OF _ _ _ _ _ arity_omap_wfrec_aux,of A r "3+\<^sub>\<omega>r" 1 0]
    pred_Un_distrib union_abs1 union_abs2 type_omap_wfrec_body_fm
  by auto

lemma arity_isordermap: "A\<in>nat \<Longrightarrow> r\<in>nat \<Longrightarrow>d\<in>nat\<Longrightarrow>
   arity(is_ordermap_fm(A,r,d)) = succ(d) \<union> (succ(A) \<union> succ(r))"
  unfolding is_ordermap_fm_def
  using arity_lambda_fm[where i="(4+\<^sub>\<omega>A) \<union> (4+\<^sub>\<omega>r)",OF _ _ _ _ arity_omap_wfrec,
      unfolded omap_wfrec_body_def] pred_Un_distrib union_abs1
  by auto

lemma arity_is_ordertype: "A\<in>nat \<Longrightarrow> r\<in>nat \<Longrightarrow>d\<in>nat\<Longrightarrow>
   arity(is_ordertype_fm(A,r,d)) = succ(d) \<union> (succ(A) \<union> succ(r))"
  unfolding is_ordertype_fm_def
  using arity_isordermap arity_image_fm pred_Un_distrib FOL_arities
  by auto

lemma arity_is_order_body: "arity(is_order_body_fm(0,1)) = 2"
  using arity_is_order_body_fm arity_is_ordertype ord_simp_union
  by (simp add:FOL_arities)

definition H_order_pred where
  "H_order_pred(A,r) \<equiv>  \<lambda>x f . f `` Order.pred(A, x, r)"

relationalize "H_order_pred" "is_H_order_pred"

synthesize "is_H_order_pred" from_definition assuming "nonempty"

definition order_pred_wfrec_body where
  "order_pred_wfrec_body(M,A,r,z,x) \<equiv> \<exists>y[M].
                pair(M, x, y, z) \<and>
                (\<exists>f[M].
                    (\<forall>z[M].
                        z \<in> f \<longleftrightarrow>
                        (\<exists>xa[M].
                            \<exists>y[M].
                               \<exists>xaa[M].
                                  \<exists>sx[M].
                                     \<exists>r_sx[M].
                                        \<exists>f_r_sx[M].
                                           pair(M, xa, y, z) \<and>
                                           pair(M, xa, x, xaa) \<and>
                                           upair(M, xa, xa, sx) \<and>
                                           pre_image(M, r, sx, r_sx) \<and>
                                           restriction(M, f, r_sx, f_r_sx) \<and>
                                           xaa \<in> r \<and> (\<exists>a[M]. image(M, f_r_sx, a, y) \<and> pred_set(M, A, xa, r, a)))) \<and>
                    (\<exists>a[M]. image(M, f, a, y) \<and> pred_set(M, A, x, r, a)))"

synthesize "order_pred_wfrec_body" from_definition
arity_theorem for "order_pred_wfrec_body_fm"

definition ordtype_replacement_fm where "ordtype_replacement_fm \<equiv>  (\<cdot>\<exists>\<cdot>is_order_body_fm(1, 0) \<and> \<cdot>\<langle>1,0\<rangle> is 2 \<cdot>\<cdot>\<cdot>)"
definition wfrec_ordertype_fm where "wfrec_ordertype_fm \<equiv> order_pred_wfrec_body_fm(3,2,1,0)"
definition replacement_is_aleph_fm where "replacement_is_aleph_fm \<equiv> \<cdot>\<cdot>0 is ordinal\<cdot> \<and> \<cdot>\<aleph>(0) is 1\<cdot>\<cdot>"

definition
  funspace_succ_rep_intf where
  "funspace_succ_rep_intf \<equiv> \<lambda>p z n. \<exists>f b. p = <f,b> & z = {cons(<n,b>, f)}"

relativize functional "funspace_succ_rep_intf" "funspace_succ_rep_intf_rel"

\<comment> \<open>The definition obtained next uses \<^term>\<open>is_cons\<close> instead of \<^term>\<open>upair\<close>
  as in Paulson's \<^file>\<open>~~/src/ZF/Constructible/Relative.thy\<close>.\<close>
relationalize "funspace_succ_rep_intf_rel" "is_funspace_succ_rep_intf"

synthesize "is_funspace_succ_rep_intf" from_definition

arity_theorem for "is_funspace_succ_rep_intf_fm"

definition wfrec_Hfrc_at_fm where "wfrec_Hfrc_at_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(Hfrc_at_fm(8, 9, 2, 1, 0), 5, 1, 0) \<cdot>\<cdot>)"
definition list_repl1_intf_fm where "list_repl1_intf_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(iterates_MH_fm(list_functor_fm(13, 1, 0), 10, 2, 1, 0), 3, 1, 0) \<cdot>\<cdot>)"
definition list_repl2_intf_fm where "list_repl2_intf_fm \<equiv> \<cdot>\<cdot>0 \<in> 4\<cdot> \<and> is_iterates_fm(list_functor_fm(13, 1, 0), 3, 0, 1) \<cdot>"
definition formula_repl2_intf_fm where "formula_repl2_intf_fm \<equiv> \<cdot>\<cdot>0 \<in> 3\<cdot> \<and> is_iterates_fm(formula_functor_fm(1, 0), 2, 0, 1) \<cdot>"
definition eclose_abs_fm where "eclose_abs_fm \<equiv> \<cdot>\<cdot>0 \<in> 3\<cdot> \<and> is_iterates_fm(\<cdot>\<Union>1 is 0\<cdot>, 2, 0, 1) \<cdot>"
definition powapply_repl_fm where "powapply_repl_fm \<equiv> is_Powapply_fm(2,0,1)"
definition wfrec_rank_fm where "wfrec_rank_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(is_Hrank_fm(2, 1, 0), 3, 1, 0) \<cdot>\<cdot>)"
definition transrec_VFrom_fm where "transrec_VFrom_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(is_HVfrom_fm(8, 2, 1, 0), 4, 1, 0) \<cdot>\<cdot>)"
definition wfrec_Hcheck_fm where "wfrec_Hcheck_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(is_Hcheck_fm(8, 2, 1, 0), 4, 1, 0) \<cdot>\<cdot>) "
definition repl_PHcheck_fm where "repl_PHcheck_fm \<equiv> PHcheck_fm(2,3,0,1)"
definition tl_repl_intf_fm where "tl_repl_intf_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(iterates_MH_fm(tl_fm(1,0), 9, 2, 1, 0), 3, 1, 0) \<cdot>\<cdot>)"
definition formula_repl1_intf_fm where "formula_repl1_intf_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(iterates_MH_fm(formula_functor_fm(1,0), 9, 2, 1, 0), 3, 1, 0) \<cdot>\<cdot>)"
definition eclose_closed_fm where "eclose_closed_fm \<equiv> (\<cdot>\<exists>\<cdot>pair_fm(1, 0, 2) \<and> is_wfrec_fm(iterates_MH_fm(\<cdot>\<Union>1 is 0\<cdot>, 9, 2, 1, 0), 3, 1, 0) \<cdot>\<cdot>)"

definition replacement_assm where
  "replacement_assm(M,env,\<phi>) \<equiv> \<phi> \<in> formula \<longrightarrow> env \<in> list(M) \<longrightarrow>
  arity(\<phi>) \<le> 2 +\<^sub>\<omega> length(env) \<longrightarrow>
    strong_replacement(##M,\<lambda>x y. (M , [x,y]@env \<Turnstile> \<phi>))"

definition ground_replacement_assm where
  "ground_replacement_assm(M,env,\<phi>) \<equiv> replacement_assm(M,env,ground_repl_fm(\<phi>))"

end


theory Introduction
imports Setup
begin (*<*)

ML \<open>
  Isabelle_System.mkdirs (File.tmp_path (Path.basic "examples"))
\<close> (*>*)

section \<open>Introduction\<close>

text \<open>
  This tutorial introduces the code generator facilities of @{text
  "Isabelle/HOL"}.  It allows to turn (a certain class of) HOL
  specifications into corresponding executable code in the programming
  languages @{text SML} @{cite SML}, @{text OCaml} @{cite OCaml},
  @{text Haskell} @{cite "haskell-revised-report"} and @{text Scala}
  @{cite "scala-overview-tech-report"}.

  To profit from this tutorial, some familiarity and experience with
  @{theory HOL} @{cite "isa-tutorial"} and its basic theories is assumed.
\<close>

subsection \<open>Code generation principle: shallow embedding \label{sec:principle}\<close>

text \<open>
  The key concept for understanding Isabelle's code generation is
  \emph{shallow embedding}: logical entities like constants, types and
  classes are identified with corresponding entities in the target
  language.  In particular, the carrier of a generated program's
  semantics are \emph{equational theorems} from the logic.  If we view
  a generated program as an implementation of a higher-order rewrite
  system, then every rewrite step performed by the program can be
  simulated in the logic, which guarantees partial correctness
  @{cite "Haftmann-Nipkow:2010:code"}.
\<close>

subsection \<open>A quick start with the Isabelle/HOL toolbox \label{sec:queue_example}\<close>

text \<open>
  In a HOL theory, the @{command_def datatype} and @{command_def
  definition}/@{command_def primrec}/@{command_def fun} declarations
  form the core of a functional programming language.  By default
  equational theorems stemming from those are used for generated code,
  therefore \qt{naive} code generation can proceed without further
  ado.

  For example, here a simple \qt{implementation} of amortised queues:
\<close>

datatype %quote 'a queue = AQueue "'a list" "'a list"

definition %quote empty :: "'a queue" where
  "empty = AQueue [] []"

primrec %quote enqueue :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
  "enqueue x (AQueue xs ys) = AQueue (x # xs) ys"

fun %quote dequeue :: "'a queue \<Rightarrow> 'a option \<times> 'a queue" where
    "dequeue (AQueue [] []) = (None, AQueue [] [])"
  | "dequeue (AQueue xs (y # ys)) = (Some y, AQueue xs ys)"
  | "dequeue (AQueue xs []) =
      (case rev xs of y # ys \<Rightarrow> (Some y, AQueue [] ys))" (*<*)

lemma %invisible dequeue_nonempty_Nil [simp]:
  "xs \<noteq> [] \<Longrightarrow> dequeue (AQueue xs []) = (case rev xs of y # ys \<Rightarrow> (Some y, AQueue [] ys))"
  by (cases xs) (simp_all split: list.splits) (*>*)

text \<open>\noindent Then we can generate code e.g.~for @{text SML} as follows:\<close>

export_code %quote empty dequeue enqueue in SML
  module_name Example file "$ISABELLE_TMP/examples/example.ML"

text \<open>\noindent resulting in the following code:\<close>

text %quotetypewriter \<open>
  @{code_stmts empty enqueue dequeue (SML)}
\<close>

text \<open>
  \noindent The @{command_def export_code} command takes a
  space-separated list of constants for which code shall be generated;
  anything else needed for those is added implicitly.  Then follows a
  target language identifier and a freely chosen module name.  A file
  name denotes the destination to store the generated code.  Note that
  the semantics of the destination depends on the target language: for
  @{text SML}, @{text OCaml} and @{text Scala} it denotes a \emph{file},
  for @{text Haskell} it denotes a \emph{directory} where a file named as the
  module name (with extension @{text ".hs"}) is written:
\<close>

export_code %quote empty dequeue enqueue in Haskell
  module_name Example file "$ISABELLE_TMP/examples/"

text \<open>
  \noindent This is the corresponding code:
\<close>

text %quotetypewriter \<open>
  @{code_stmts empty enqueue dequeue (Haskell)}
\<close>

text \<open>
  \noindent For more details about @{command export_code} see
  \secref{sec:further}.
\<close>

subsection \<open>Type classes\<close>

text \<open>
  Code can also be generated from type classes in a Haskell-like
  manner.  For illustration here an example from abstract algebra:
\<close>

class %quote semigroup =
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

class %quote monoid = semigroup +
  fixes neutral :: 'a ("\<one>")
  assumes neutl: "\<one> \<otimes> x = x"
    and neutr: "x \<otimes> \<one> = x"

instantiation %quote nat :: monoid
begin

primrec %quote mult_nat where
    "0 \<otimes> n = (0::nat)"
  | "Suc m \<otimes> n = n + m \<otimes> n"

definition %quote neutral_nat where
  "\<one> = Suc 0"

lemma %quote add_mult_distrib:
  fixes n m q :: nat
  shows "(n + m) \<otimes> q = n \<otimes> q + m \<otimes> q"
  by (induct n) simp_all

instance %quote proof
  fix m n q :: nat
  show "m \<otimes> n \<otimes> q = m \<otimes> (n \<otimes> q)"
    by (induct m) (simp_all add: add_mult_distrib)
  show "\<one> \<otimes> n = n"
    by (simp add: neutral_nat_def)
  show "m \<otimes> \<one> = m"
    by (induct m) (simp_all add: neutral_nat_def)
qed

end %quote

text \<open>
  \noindent We define the natural operation of the natural numbers
  on monoids:
\<close>

primrec %quote (in monoid) pow :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" where
    "pow 0 a = \<one>"
  | "pow (Suc n) a = a \<otimes> pow n a"

text \<open>
  \noindent This we use to define the discrete exponentiation
  function:
\<close>

definition %quote bexp :: "nat \<Rightarrow> nat" where
  "bexp n = pow n (Suc (Suc 0))"

text \<open>
  \noindent The corresponding code in Haskell uses that language's
  native classes:
\<close>

text %quotetypewriter \<open>
  @{code_stmts bexp (Haskell)}
\<close>

text \<open>
  \noindent This is a convenient place to show how explicit dictionary
  construction manifests in generated code -- the same example in
  @{text SML}:
\<close>

text %quotetypewriter \<open>
  @{code_stmts bexp (SML)}
\<close>

text \<open>
  \noindent Note the parameters with trailing underscore (@{verbatim
  "A_"}), which are the dictionary parameters.
\<close>

subsection \<open>How to continue from here\<close>

text \<open>
  What you have seen so far should be already enough in a lot of
  cases.  If you are content with this, you can quit reading here.

  Anyway, to understand situations where problems occur or to increase
  the scope of code generation beyond default, it is necessary to gain
  some understanding how the code generator actually works:

  \begin{itemize}

    \item The foundations of the code generator are described in
      \secref{sec:foundations}.

    \item In particular \secref{sec:utterly_wrong} gives hints how to
      debug situations where code generation does not succeed as
      expected.

    \item The scope and quality of generated code can be increased
      dramatically by applying refinement techniques, which are
      introduced in \secref{sec:refinement}.

    \item Inductive predicates can be turned executable using an
      extension of the code generator \secref{sec:inductive}.

    \item If you want to utilize code generation to obtain fast
      evaluators e.g.~for decision procedures, have a look at
      \secref{sec:evaluation}.

    \item You may want to skim over the more technical sections
      \secref{sec:adaptation} and \secref{sec:further}.

    \item The target language Scala @{cite "scala-overview-tech-report"}
      comes with some specialities discussed in \secref{sec:scala}.

    \item For exhaustive syntax diagrams etc. you should visit the
      Isabelle/Isar Reference Manual @{cite "isabelle-isar-ref"}.

  \end{itemize}

  \bigskip

  \begin{center}\fbox{\fbox{\begin{minipage}{8cm}

    \begin{center}\textit{Happy proving, happy hacking!}\end{center}

  \end{minipage}}}\end{center}
\<close>

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Example I: absence of replacement in \<open>V\<^sub>\<omega>\<^sub>+\<^sub>\<omega>\<close>\<close>
theory CZH_EX_Replacement
  imports CZH_Sets_ZQR
begin

text\<open>
The statement of the main result presented in this subsection
can be found in \<^cite>\<open>"noauthor_wikipedia_2001"\<close>\footnote{
\url{https://en.wikipedia.org/wiki/Zermelo_set_theory}
}
\<close>

definition repl_ex_fun :: V
  where "repl_ex_fun = (\<lambda>i\<in>\<^sub>\<circ>\<omega>. Vfrom \<omega> i)"

mk_VLambda repl_ex_fun_def
  |vsv repl_ex_fun_vsv|
  |vdomain repl_ex_fun_vdomain|
  |app repl_ex_fun_app|

lemma repl_ex_fun_vrange: "\<R>\<^sub>\<circ> repl_ex_fun \<subseteq>\<^sub>\<circ> Vset (\<omega> + \<omega>)"
proof(intro vsv.vsv_vrange_vsubset, unfold repl_ex_fun_vdomain)
  fix x assume prems: "x \<in>\<^sub>\<circ> \<omega>"
  then show "repl_ex_fun\<lparr>x\<rparr> \<in>\<^sub>\<circ> Vset (\<omega> + \<omega>)"
  proof(induction rule: omega_induct)
    case 0 then show ?case
      by
        (
          auto
            simp: repl_ex_fun_app intro!: vreal_in_Vset_\<omega>2 omega_vsubset_vreal
        )
  next
    case (succ n)
    then have Ord_n: "Ord n" by auto
    have Limit_\<omega>\<omega>: "Limit (\<omega> + \<omega>)" by auto
    from succ show ?case
      by
        (
          auto
            simp: Vfrom_succ_Ord[OF Ord_n, of \<omega>] repl_ex_fun_app
            intro: Limit_\<omega>\<omega>
            intro!: omega_vsubset_vreal vreal_in_Vset_\<omega>2
        )
  qed
qed (unfold repl_ex_fun_def, auto)

lemma Limit_vsv_not_in_Vset_if_vrange_not_in_Vset:
  assumes "Limit \<alpha>" and "\<R>\<^sub>\<circ> f \<notin>\<^sub>\<circ> Vset \<alpha>"
  shows "f \<notin>\<^sub>\<circ> Vset \<alpha>"
proof(rule ccontr, unfold not_not)
  assume "f \<in>\<^sub>\<circ> Vset \<alpha>"
  with assms(1) have "\<R>\<^sub>\<circ> f \<in>\<^sub>\<circ> Vset \<alpha>" by (simp add: vrange_in_VsetI)
  with assms(2) show False by simp
qed

lemma Ord_not_in_Vset:
  assumes "Ord \<alpha>"
  shows "\<alpha> \<notin>\<^sub>\<circ> Vset \<alpha>"
  using assms
proof(induction rule: Ord_induct3')
  case (succ \<alpha>)
  then have succ\<alpha>: "Vset (succ \<alpha>) = VPow (Vset \<alpha>)" by (simp add: Vset_succ)
  show ?case
  proof(rule ccontr, unfold not_not)
    assume "succ \<alpha> \<in>\<^sub>\<circ> Vset (succ \<alpha>)"
    then have "vinsert \<alpha> \<alpha> \<in>\<^sub>\<circ> VPow (Vset \<alpha>)"
      unfolding succ\<alpha> by (simp add: succ_def)
    with succ(2) show False by auto
  qed
next
  case (Limit \<alpha>) show ?case
  proof(rule ccontr, unfold not_not)
    assume "(\<Union>\<^sub>\<circ>\<xi>\<in>\<^sub>\<circ>\<alpha>. \<xi>) \<in>\<^sub>\<circ> Vset (\<Union>\<^sub>\<circ>\<xi>\<in>\<^sub>\<circ>\<alpha>. \<xi>)"
    with Limit(1) have "\<alpha> \<in>\<^sub>\<circ> Vset \<alpha>" by auto
    with Limit(1) obtain i where i: "i \<in>\<^sub>\<circ> \<alpha>" and "(\<Union>\<^sub>\<circ>\<xi>\<in>\<^sub>\<circ>\<alpha>. \<xi>) \<in>\<^sub>\<circ> Vset i"
      by (metis Limit_Vfrom_eq Limit_vifunion_def vifunion_iff)
    moreover with Limit(1) have "\<alpha> \<in>\<^sub>\<circ> Vset i" by auto
    ultimately have "i \<in>\<^sub>\<circ> Vset i" by auto
    with Limit(2)[OF i] show False by auto
  qed
qed simp

lemma Ord_succ_vsusbset_Vfrom_succ:
  assumes "Transset A" and "Ord a" and "a \<in>\<^sub>\<circ> Vfrom A i"
  shows "succ a \<subseteq>\<^sub>\<circ> Vfrom A (succ i)"
proof(intro vsubsetI)
  from Vfrom_in_mono[OF vsubset_reflexive] have i_succi:
    "Vfrom A i \<in>\<^sub>\<circ> Vfrom A (succ i)"
    by simp
  fix x assume prems: "x \<in>\<^sub>\<circ> succ a"
  then consider \<open>x \<in>\<^sub>\<circ> a\<close> | \<open>x = a\<close> unfolding succ_def by auto
  then show "x \<in>\<^sub>\<circ> Vfrom A (succ i)"
  proof cases
    case 1
    have "x \<in>\<^sub>\<circ> Vfrom A i" by (rule Vfrom_trans[OF assms(1) 1 assms(3)])
    then show "x \<in>\<^sub>\<circ> Vfrom A (succ i)" by (rule Vfrom_trans[OF assms(1) _ i_succi])
  next
    case 2 from assms(3) show ?thesis
      unfolding 2 by (intro Vfrom_trans[OF assms(1) _ i_succi])
  qed
qed

lemma Ord_succ_in_Vfrom_succ:
  assumes "Transset A" and "Ord a" and "a \<in>\<^sub>\<circ> Vfrom A i"
  shows "succ a \<in>\<^sub>\<circ> Vfrom A (succ (succ i))"
  using Ord_succ_vsusbset_Vfrom_succ[OF assms] by (simp add: Vfrom_succ)

lemma \<omega>_vplus_in_Vfrom_\<omega>:
  assumes "j \<in>\<^sub>\<circ> \<omega>"
  shows "\<omega> + j \<in>\<^sub>\<circ> Vfrom \<omega> (succ (2\<^sub>\<nat> * j))"
  using assms
proof(induction rule: omega_induct)
  case 0
  have "\<omega> \<in>\<^sub>\<circ> Vfrom \<omega> (succ 0)"
    unfolding Vfrom_succ_Ord[where i=0, simplified] by auto
  then show ?case by simp
next
  case (succ n)
  from succ(1) obtain m where n_def: "n = m\<^sub>\<nat>" by (auto elim: nat_of_omega)
  from succ(1) have \<omega>_succn: "\<omega> + succ n = succ (\<omega> + n)" by (simp add: plus_V_succ_right)
  from succ(1) have succ_2succn: "succ (2\<^sub>\<nat> * succ n) = succ (succ (succ (2\<^sub>\<nat> * n)))"
    unfolding n_def by (cs_concl_step nat_omega_simps)+ auto
  show ?case
    unfolding \<omega>_succn succ_2succn
    by (intro Ord_succ_in_Vfrom_succ succ)
      (auto simp: succ(1) intro: Ord_is_Transset)
qed

lemma repl_ex_fun_vrange_not_in_Vset: "\<R>\<^sub>\<circ> repl_ex_fun \<notin>\<^sub>\<circ> Vset (\<omega> + \<omega>)"
proof(rule ccontr, unfold not_not)
  assume prems: "\<R>\<^sub>\<circ> repl_ex_fun \<in>\<^sub>\<circ> Vset (\<omega> + \<omega>)"
  then have "\<Union>\<^sub>\<circ>(\<R>\<^sub>\<circ> repl_ex_fun) \<in>\<^sub>\<circ> Vset (\<omega> + \<omega>)" by (simp add: VUnion_in_VsetI)
  moreover have "\<omega> + \<omega> \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<R>\<^sub>\<circ> repl_ex_fun)"
  proof(intro vsubsetI)
    fix x assume prems: "x \<in>\<^sub>\<circ> \<omega> + \<omega>"
    from prems consider \<open>x \<in>\<^sub>\<circ> \<omega>\<close> | \<open>x \<notin>\<^sub>\<circ> \<omega>\<close> by auto
    then show "x \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<R>\<^sub>\<circ> repl_ex_fun)"
    proof cases
      case 1
      show ?thesis
      proof(rule VUnionI)
        show "Vfrom \<omega> 0 \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> repl_ex_fun"
          unfolding repl_ex_fun_def by blast
        from 1 show "x \<in>\<^sub>\<circ> Vfrom \<omega> 0" by auto
      qed
    next
      case 2
      with prems obtain j where x_def: "x = \<omega> + j" and j: "j \<in>\<^sub>\<circ> \<omega>"
        by (auto elim: mem_plus_V_E)
      show ?thesis
      proof(rule VUnionI)
        from j show "Vfrom \<omega> (succ (2\<^sub>\<nat> * j)) \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> repl_ex_fun"
          unfolding repl_ex_fun_def by blast
        show "x \<in>\<^sub>\<circ> Vfrom \<omega> (succ (2\<^sub>\<nat> * j))"
          by (rule \<omega>_vplus_in_Vfrom_\<omega>[OF j, folded x_def])
      qed
    qed
  qed
  ultimately have "\<omega> + \<omega> \<in>\<^sub>\<circ> Vset (\<omega> + \<omega>)" by auto
  with Ord_not_in_Vset show False by auto
qed

lemma repl_ex_fun_not_in_Vset: "repl_ex_fun \<notin>\<^sub>\<circ> Vset (\<omega> + \<omega>)"
  by (rule Limit_vsv_not_in_Vset_if_vrange_not_in_Vset)
    (auto simp: repl_ex_fun_vrange_not_in_Vset)

text\<open>\newpage\<close>

end


(*  Title:       Refutational Inference Systems
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Refutational Inference Systems\<close>

theory Inference_System
  imports Herbrand_Interpretation
begin

text \<open>
This theory gathers results from Section 2.4 (``Refutational Theorem Proving''), 3 (``Standard
Resolution''), and 4.2 (``Counterexample-Reducing Inference Systems'') of Bachmair and Ganzinger's
chapter.
\<close>

subsection \<open>Preliminaries\<close>

text \<open>
Inferences have one distinguished main premise, any number of side premises, and a conclusion.
\<close>

datatype 'a inference =
  Infer (side_prems_of: "'a clause multiset") (main_prem_of: "'a clause") (concl_of: "'a clause")

abbreviation prems_of :: "'a inference \<Rightarrow> 'a clause multiset" where
  "prems_of \<gamma> \<equiv> side_prems_of \<gamma> + {#main_prem_of \<gamma>#}"

abbreviation concls_of :: "'a inference set \<Rightarrow> 'a clause set" where
  "concls_of \<Gamma> \<equiv> concl_of ` \<Gamma>"

definition infer_from :: "'a clause set \<Rightarrow> 'a inference \<Rightarrow> bool" where
  "infer_from CC \<gamma> \<longleftrightarrow> set_mset (prems_of \<gamma>) \<subseteq> CC"

locale inference_system =
  fixes \<Gamma> :: "'a inference set"
begin

definition inferences_from :: "'a clause set \<Rightarrow> 'a inference set" where
  "inferences_from CC = {\<gamma>. \<gamma> \<in> \<Gamma> \<and> infer_from CC \<gamma>}"

definition inferences_between :: "'a clause set \<Rightarrow> 'a clause \<Rightarrow> 'a inference set" where
  "inferences_between CC C = {\<gamma>. \<gamma> \<in> \<Gamma> \<and> infer_from (CC \<union> {C}) \<gamma> \<and> C \<in># prems_of \<gamma>}"

lemma inferences_from_mono: "CC \<subseteq> DD \<Longrightarrow> inferences_from CC \<subseteq> inferences_from DD"
  unfolding inferences_from_def infer_from_def by fast

definition saturated :: "'a clause set \<Rightarrow> bool" where
  "saturated N \<longleftrightarrow> concls_of (inferences_from N) \<subseteq> N"

lemma saturatedD:
  assumes
    satur: "saturated N" and
    inf: "Infer CC D E \<in> \<Gamma>" and
    cc_subs_n: "set_mset CC \<subseteq> N" and
    d_in_n: "D \<in> N"
  shows "E \<in> N"
proof -
  have "Infer CC D E \<in> inferences_from N"
    unfolding inferences_from_def infer_from_def using inf cc_subs_n d_in_n by simp
  then have "E \<in> concls_of (inferences_from N)"
    unfolding image_iff by (metis inference.sel(3))
  then show "E \<in> N"
    using satur unfolding saturated_def by blast
qed

end

text \<open>
Satisfiability preservation is a weaker requirement than soundness.
\<close>

locale sat_preserving_inference_system = inference_system +
  assumes \<Gamma>_sat_preserving: "satisfiable N \<Longrightarrow> satisfiable (N \<union> concls_of (inferences_from N))"

locale sound_inference_system = inference_system +
  assumes \<Gamma>_sound: "Infer CC D E \<in> \<Gamma> \<Longrightarrow> I \<Turnstile>m CC \<Longrightarrow> I \<Turnstile> D \<Longrightarrow> I \<Turnstile> E"
begin

lemma \<Gamma>_sat_preserving:
  assumes sat_n: "satisfiable N"
  shows "satisfiable (N \<union> concls_of (inferences_from N))"
proof -
  obtain I where i: "I \<Turnstile>s N"
    using sat_n by blast
  then have "\<And>CC D E. Infer CC D E \<in> \<Gamma> \<Longrightarrow> set_mset CC \<subseteq> N \<Longrightarrow> D \<in> N \<Longrightarrow> I \<Turnstile> E"
    using \<Gamma>_sound unfolding true_clss_def true_cls_mset_def by (simp add: subset_eq)
  then have "\<And>\<gamma>. \<gamma> \<in> \<Gamma> \<Longrightarrow> infer_from N \<gamma> \<Longrightarrow> I \<Turnstile> concl_of \<gamma>"
    unfolding infer_from_def by (case_tac \<gamma>) clarsimp
  then have "I \<Turnstile>s concls_of (inferences_from N)"
    unfolding inferences_from_def image_def true_clss_def infer_from_def by blast
  then have "I \<Turnstile>s N \<union> concls_of (inferences_from N)"
    using i by simp
  then show ?thesis
    by blast
qed

sublocale sat_preserving_inference_system
  by unfold_locales (erule \<Gamma>_sat_preserving)

end

locale reductive_inference_system = inference_system \<Gamma> for \<Gamma> :: "('a :: wellorder) inference set" +
  assumes \<Gamma>_reductive: "\<gamma> \<in> \<Gamma> \<Longrightarrow> concl_of \<gamma> < main_prem_of \<gamma>"

subsection \<open>Refutational Completeness\<close>

text \<open>
Refutational completeness can be established once and for all for counterexample-reducing inference
systems. The material formalized here draws from both the general framework of Section 4.2 and the
concrete instances of Section 3.
\<close>

locale counterex_reducing_inference_system =
  inference_system \<Gamma> for \<Gamma> :: "('a :: wellorder) inference set" +
  fixes I_of :: "'a clause set \<Rightarrow> 'a interp"
  assumes \<Gamma>_counterex_reducing:
    "{#} \<notin> N \<Longrightarrow> D \<in> N \<Longrightarrow> \<not> I_of N \<Turnstile> D \<Longrightarrow> (\<And>C. C \<in> N \<Longrightarrow> \<not> I_of N \<Turnstile> C \<Longrightarrow> D \<le> C) \<Longrightarrow>
     \<exists>CC E. set_mset CC \<subseteq> N \<and> I_of N \<Turnstile>m CC \<and> Infer CC D E \<in> \<Gamma> \<and> \<not> I_of N \<Turnstile> E \<and> E < D"
begin

lemma ex_min_counterex:
  fixes N :: "('a :: wellorder) clause set"
  assumes "\<not> I \<Turnstile>s N"
  shows "\<exists>C \<in> N. \<not> I \<Turnstile> C \<and> (\<forall>D \<in> N. D < C \<longrightarrow> I \<Turnstile> D)"
proof -
  obtain C where "C \<in> N" and "\<not> I \<Turnstile> C"
    using assms unfolding true_clss_def by auto
  then have c_in: "C \<in> {C \<in> N. \<not> I \<Turnstile> C}"
    by blast
  show ?thesis
    using wf_eq_minimal[THEN iffD1, rule_format, OF wf_less_multiset c_in] by blast
qed

(* Theorem 4.4 (generalizes Theorems 3.9 and 3.16) *)

theorem saturated_model:
  assumes
    satur: "saturated N" and
    ec_ni_n: "{#} \<notin> N"
  shows "I_of N \<Turnstile>s N"
proof -
  {
    assume "\<not> I_of N \<Turnstile>s N"
    then obtain D where
      d_in_n: "D \<in> N" and
      d_cex: "\<not> I_of N \<Turnstile> D" and
      d_min: "\<And>C. C \<in> N \<Longrightarrow> C < D \<Longrightarrow> I_of N \<Turnstile> C"
      by (meson ex_min_counterex)
    then obtain CC E where
      cc_subs_n: "set_mset CC \<subseteq> N" and
      inf_e: "Infer CC D E \<in> \<Gamma>" and
      e_cex: "\<not> I_of N \<Turnstile> E" and
      e_lt_d: "E < D"
      using \<Gamma>_counterex_reducing[OF ec_ni_n] not_less by metis
    from cc_subs_n inf_e have "E \<in> N"
      using d_in_n satur by (blast dest: saturatedD)
    then have False
      using e_cex e_lt_d d_min not_less by blast
  }
  then show ?thesis
    by satx
qed

text \<open>
Cf. Corollary 3.10:
\<close>

corollary saturated_complete: "saturated N \<Longrightarrow> \<not> satisfiable N \<Longrightarrow> {#} \<in> N"
  using saturated_model by blast

end

subsection \<open>Compactness\<close>

text \<open>
Bachmair and Ganzinger claim that compactness follows from refutational completeness but leave the
proof to the readers' imagination. Our proof relies on an inductive definition of saturation in
terms of a base set of clauses.
\<close>

context inference_system
begin

inductive_set saturate :: "'a clause set \<Rightarrow> 'a clause set" for CC :: "'a clause set" where
  base: "C \<in> CC \<Longrightarrow> C \<in> saturate CC"
| step: "Infer CC' D E \<in> \<Gamma> \<Longrightarrow> (\<And>C'. C' \<in># CC' \<Longrightarrow> C' \<in> saturate CC) \<Longrightarrow> D \<in> saturate CC \<Longrightarrow>
    E \<in> saturate CC"

lemma saturate_mono: "C \<in> saturate CC \<Longrightarrow> CC \<subseteq> DD \<Longrightarrow> C \<in> saturate DD"
  by (induct rule: saturate.induct) (auto intro: saturate.intros)

lemma saturated_saturate[simp, intro]: "saturated (saturate N)"
  unfolding saturated_def inferences_from_def infer_from_def image_def
  by clarify (rename_tac x, case_tac x, auto elim!: saturate.step)

lemma saturate_finite: "C \<in> saturate CC \<Longrightarrow> \<exists>DD. DD \<subseteq> CC \<and> finite DD \<and> C \<in> saturate DD"
proof (induct rule: saturate.induct)
  case (base C)
  then have "{C} \<subseteq> CC" and "finite {C}" and "C \<in> saturate {C}"
    by (auto intro: saturate.intros)
  then show ?case
    by blast
next
  case (step CC' D E)
  obtain DD_of where
    "\<And>C. C \<in># CC' \<Longrightarrow> DD_of C \<subseteq> CC \<and> finite (DD_of C) \<and> C \<in> saturate (DD_of C)"
    using step(3) by metis
  then have
    "(\<Union>C \<in> set_mset CC'. DD_of C) \<subseteq> CC"
    "finite (\<Union>C \<in> set_mset CC'. DD_of C) \<and> set_mset CC' \<subseteq> saturate (\<Union>C \<in> set_mset CC'. DD_of C)"
    by (auto intro: saturate_mono)
  then obtain DD where
    d_sub: "DD \<subseteq> CC" and d_fin: "finite DD" and in_sat_d: "set_mset CC' \<subseteq> saturate DD"
    by blast
  obtain EE where
    e_sub: "EE \<subseteq> CC" and e_fin: "finite EE" and in_sat_ee: "D \<in> saturate EE"
    using step(5) by blast
  have "DD \<union> EE \<subseteq> CC"
    using d_sub e_sub step(1) by fast
  moreover have "finite (DD \<union> EE)"
    using d_fin e_fin by fast
  moreover have "E \<in> saturate (DD \<union> EE)"
    using in_sat_d in_sat_ee step.hyps(1)
    by (blast intro: inference_system.saturate.step saturate_mono)
  ultimately show ?case
    by blast
qed

end

context sound_inference_system
begin

theorem saturate_sound: "C \<in> saturate CC \<Longrightarrow> I \<Turnstile>s CC \<Longrightarrow> I \<Turnstile> C"
  by (induct rule: saturate.induct) (auto simp: true_cls_mset_def true_clss_def \<Gamma>_sound)

end

context sat_preserving_inference_system
begin

text \<open>
This result surely holds, but we have yet to prove it. The challenge is: Every time a new clause is
introduced, we also get a new interpretation (by the definition of
\<open>sat_preserving_inference_system\<close>). But the interpretation we want here is then the one that
exists "at the limit". Maybe we can use compactness to prove it.
\<close>

theorem saturate_sat_preserving: "satisfiable CC \<Longrightarrow> satisfiable (saturate CC)"
  oops

end

locale sound_counterex_reducing_inference_system =
  counterex_reducing_inference_system + sound_inference_system
begin

text \<open>
Compactness of clausal logic is stated as Theorem 3.12 for the case of unordered ground resolution.
The proof below is a generalization to any sound counterexample-reducing inference system. The
actual theorem will become available once the locale has been instantiated with a concrete inference
system.
\<close>

theorem clausal_logic_compact:
  fixes N :: "('a :: wellorder) clause set"
  shows "\<not> satisfiable N \<longleftrightarrow> (\<exists>DD \<subseteq> N. finite DD \<and> \<not> satisfiable DD)"
proof
  assume "\<not> satisfiable N"
  then have "{#} \<in> saturate N"
    using saturated_complete saturated_saturate saturate.base unfolding true_clss_def by meson
  then have "\<exists>DD \<subseteq> N. finite DD \<and> {#} \<in> saturate DD"
    using saturate_finite by fastforce
  then show "\<exists>DD \<subseteq> N. finite DD \<and> \<not> satisfiable DD"
    using saturate_sound by auto
next
  assume "\<exists>DD \<subseteq> N. finite DD \<and> \<not> satisfiable DD"
  then show "\<not> satisfiable N"
    by (blast intro: true_clss_mono)
qed

end

end


section \<open>Examples for Nameful WS1S Formulas\<close>

(*<*)
theory WS1S_Nameful_Examples
imports Formula_Derivatives.WS1S_Nameful Show.Show_Instances
begin
(*>*)

lift_definition x :: fo is "''x''" by simp
lift_definition y :: fo is "''y''" by simp
lift_definition z :: fo is "''z''" by simp
lift_definition X :: so is "''X''" by simp
lift_definition Y :: so is "''Y''" by simp
lift_definition Z :: so is "''Z''" by simp
lift_definition Xi :: "nat \<Rightarrow> so" is "\<lambda>i. ''X'' @ show i" by simp

abbreviation Imp where "Imp \<phi> \<psi> \<equiv> Or (Not \<phi>) \<psi>"
(*true in M2L, false in WS1S*)
definition "M2L = Ex2 X (All1 x (In x X))"
(*false in M2L, true in WS1S*)
definition "\<Phi> = All1 x (Ex1 y (Lt x y))"

abbreviation Globally ("\<box>_" [40] 40) where
  "Globally P t ==  All1 z (Imp (Not (Lt t z)) (P z))"
abbreviation Future ("\<diamond>_" [40] 40) where
  "Future P t == Ex1 z (And (Not (Lt t z)) (P z))"
abbreviation IMP (infixr "\<rightarrow>" 50) where "IMP P1 P2 t == Imp (P1 t) (P2 t)"

definition \<Psi> :: "nat \<Rightarrow> ws1s" where
  "\<Psi> n = All1 x
     (((\<box>(foldr (\<lambda>i \<phi>. (\<lambda>m. In m (Xi i)) \<rightarrow> \<phi>) [0..<n] (\<lambda>m. (In m (Xi n))))) \<rightarrow>
     foldr (\<lambda>i \<phi>. (\<box>(\<lambda>m. (In m (Xi i)))) \<rightarrow> \<phi>) [0..<n]
       (\<box>(\<lambda>m. (In m (Xi n))))) x)"

method_setup check_equiv = \<open>
  let
    fun tac ctxt =
      let
        val conv = @{computation_check terms: Trueprop
          "0 :: nat" "1 :: nat" "2 :: nat" "3 :: nat" Suc
          "plus :: nat \<Rightarrow> _" "minus :: nat \<Rightarrow> _"
          "times :: nat \<Rightarrow> _" "divide :: nat \<Rightarrow> _" "modulo :: nat \<Rightarrow> _"
          "0 :: int" "1 :: int" "2 :: int" "3 :: int" "-1 :: int"
          Thm x y z X Y Z Xi \<Psi> \<Phi> M2L eqv datatypes: formula "int list" integer idx
         "nat \<times> nat" "nat option" "bool option" ws1s} ctxt
      in
        CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
        resolve_tac ctxt [TrueI]
      end
  in
    Scan.succeed (SIMPLE_METHOD' o tac)
  end
\<close>

lemma "Thm (Not M2L)"
  by check_equiv

lemma "Thm \<Phi>"
  by check_equiv

lemma "eqv (And (Eq_Const x 10) (Eq_Const x 10000)) F"
  by check_equiv

lemma "Thm (\<Psi> 0)"
  by check_equiv

lemma "Thm (\<Psi> 1)"
  by check_equiv

lemma "Thm (\<Psi> 2)"
  by check_equiv

lemma "Thm (\<Psi> 3)"
  by check_equiv

lemma "Thm (\<Psi> 4)"
  by check_equiv

lemma "Thm (\<Psi> 5)"
  by check_equiv

lemma "Thm (\<Psi> 10)"
  by check_equiv

lemma "Thm (\<Psi> 15)"
  by check_equiv

(*<*)
end
(*>*)


theory Lib_List_toString
imports Lib_Numbers_toString
begin

section\<open>Printing Lists\<close>

fun intersperse :: "'a \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
"intersperse _ [] = []" |
"intersperse a [x] = x" |
"intersperse a (x#xs) = x @ a # intersperse a xs"

(*this is similar to space_implode or Data.List.intersperse (in Haskell)*)
definition list_separated_toString :: "string \<Rightarrow> ('a \<Rightarrow> string) \<Rightarrow> 'a list \<Rightarrow> string" where
  "list_separated_toString sep toStr ls = concat (splice (map toStr ls) (replicate (length ls - 1) sep))"

text\<open>A slightly more efficient code equation, which is actually not really faster (in certain languages)\<close>
fun list_separated_toString_helper :: "string \<Rightarrow> ('a \<Rightarrow> string) \<Rightarrow> 'a list \<Rightarrow> string" where
  "list_separated_toString_helper sep toStr [] = ''''" |
  "list_separated_toString_helper sep toStr [l] = toStr l" |
  "list_separated_toString_helper sep toStr (l#ls) = (toStr l)@sep@list_separated_toString_helper sep toStr ls"
lemma list_separated_toString_helper: "list_separated_toString = list_separated_toString_helper"
proof -
  { fix sep and toStr::"('a \<Rightarrow> char list)" and ls
    have "list_separated_toString sep toStr ls = list_separated_toString_helper sep toStr ls"
      by(induction sep toStr ls rule: list_separated_toString_helper.induct) (simp_all add: list_separated_toString_def)
  } thus ?thesis by(simp add: fun_eq_iff)
qed

lemma list_separated_toString_intersperse:
  "intersperse sep (map f xs) = list_separated_toString [sep] f xs"
  apply(simp add: list_separated_toString_helper)
  apply(induction "[sep]" f xs rule: list_separated_toString_helper.induct)
    by simp+

definition list_toString :: "('a \<Rightarrow> string) \<Rightarrow> 'a list \<Rightarrow> string" where
  "list_toString toStr ls = ''[''@ list_separated_toString '', '' toStr ls @'']''"

lemma "list_toString string_of_nat [1,2,3] = ''[1, 2, 3]''" by eval

end