(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header "Reasoning about PreFormulas"

theory PreFormulas
imports Semantics
begin

text{*
  Semantic separation of formulas and pre-formulas requires a deep embedding.
  We introduce a syntactically distinct notion of validity, written @{text "|~ A"},
  for pre-formulas. Although it is semantically identical to @{text "\<turnstile> A"}, it
  helps users distinguish pre-formulas from formulas in \tlastar{} proofs.
*}

definition PreValid :: "('w::world) form \<Rightarrow> bool"
where "PreValid A \<equiv> \<forall> w. w \<Turnstile> A"

syntax
  "_PreValid"      :: "lift \<Rightarrow> bool"     ("(|~ _)" 5)

translations
  "_PreValid"  \<rightleftharpoons> "CONST PreValid"

lemma prefI[intro!]: "(\<And> w. w \<Turnstile> A) \<Longrightarrow> |~ A"
  by (simp add: PreValid_def)

method_setup pref_unlift = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (rtac @{thm prefI} THEN' rewrite_goal_tac ctxt @{thms intensional_rews}))
*} "int_unlift for PreFormulas"

lemma prefeq_reflection: assumes P1: "|~ x=y" shows  "(x \<equiv> y)"
using P1 by (intro eq_reflection) force

lemma pref_True[simp]: "|~ #True"
  by auto

lemma pref_eq: "|~ X = Y \<Longrightarrow> X = Y"
  by (auto simp: prefeq_reflection)

lemma pref_iffI:
  assumes "|~ F \<longrightarrow> G" and "|~ G \<longrightarrow> F"
  shows "|~ F = G"
  using assms by force

lemma pref_iffD1: assumes "|~ F = G" shows "|~ F \<longrightarrow> G"
  using assms by auto

lemma pref_iffD2: assumes "|~ F = G" shows "|~ G \<longrightarrow> F"
  using assms by auto

lemma unl_pref_imp:
  assumes "|~ F \<longrightarrow> G" shows "\<And> w. w \<Turnstile> F \<Longrightarrow> w \<Turnstile> G"
  using assms by auto

lemma pref_imp_trans:
  assumes "|~ F \<longrightarrow> G" and "|~ G \<longrightarrow> H"
  shows "|~ F \<longrightarrow> H"
  using assms by force

subsection "Lemmas about @{text Unchanged}"

text {*
  Many of the \tlastar{} axioms only require a state function witness
  which leaves the state space unchanged. An obvious witness is the
  @{term id} function. The lemmas require that the given formula is
  invariant under stuttering.
*}

lemma pre_id_unch: assumes h: "stutinv F"
  shows "|~ F \<and> Unchanged id \<longrightarrow> \<circ>F"
proof (pref_unlift, clarify)
  fix s
  assume a1: "s \<Turnstile> F" and  a2: "s \<Turnstile> Unchanged id"
  from a2 have "(id (second s) = id (first s))" by (simp add: unch_defs)
  hence "s \<approx> (tail s)" by (simp add: addfirststut)
  with h a1 have "(tail s) \<Turnstile> F" by (simp add: stutinv_def)
  thus "s \<Turnstile> \<circ>F" by (unfold nexts_def)
qed

lemma pre_ex_unch:
  assumes h: "stutinv F"
  shows "\<exists>(v::'a::world \<Rightarrow> 'a). ( |~ F \<and> Unchanged v \<longrightarrow> \<circ>F)"
using pre_id_unch[OF h] by blast

lemma unch_pair: "|~ Unchanged (x,y) = (Unchanged x \<and> Unchanged y)"
  by (auto simp: unch_def before_def after_def nexts_def)

lemmas unch_eq1 = unch_pair[THEN pref_eq]
lemmas unch_eq2 = unch_pair[THEN prefeq_reflection]

lemma angle_actrans_sem: "|~ \<langle>F\<rangle>_v = (F \<and> v$ \<noteq> $v)"
  by (auto simp: angle_actrans_def actrans_def unch_def)

lemmas angle_actrans_sem_eq = angle_actrans_sem[THEN pref_eq]

subsection "Lemmas about @{text after}"

lemma after_const: "|~ (#c)` = #c"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun1: "|~ f<x>` = f<x`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun2: "|~ f<x,y>` = f <x`,y`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun3: "|~ f<x,y,z>` = f <x`,y`,z`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun4: "|~ f<x,y,z,zz>` = f <x`,y`,z`,zz`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_forall: "|~ (\<forall> x. P x)` = (\<forall> x. (P x)`)"
  by (auto simp: nexts_def before_def after_def)

lemma after_exists: "|~ (\<exists> x. P x)` = (\<exists> x. (P x)`)"
  by (auto simp: nexts_def before_def after_def)

lemma after_exists1: "|~ (\<exists>! x. P x)` = (\<exists>! x. (P x)`)"
  by (auto simp: nexts_def before_def after_def)

lemmas all_after = after_const after_fun1 after_fun2 after_fun3 after_fun4
  after_forall after_exists after_exists1

lemmas all_after_unl = all_after[THEN prefD]
lemmas all_after_eq = all_after[THEN prefeq_reflection]

subsection "Lemmas about @{text before}"

lemma before_const: "\<turnstile> $(#c) = #c"
  by (auto simp: before_def)

lemma before_fun1: "\<turnstile> $(f<x>) = f <$x>"
  by (auto simp: before_def)

lemma before_fun2: "\<turnstile> $(f<x,y>) = f <$x,$y>"
  by (auto simp: before_def)

lemma before_fun3: "\<turnstile> $(f<x,y,z>) = f <$x,$y,$z>"
  by (auto simp: before_def)

lemma before_fun4: "\<turnstile> $(f<x,y,z,zz>) = f <$x,$y,$z,$zz>"
  by (auto simp: before_def)

lemma before_forall: "\<turnstile> $(\<forall> x. P x) = (\<forall> x. $(P x))"
  by (auto simp: before_def)

lemma before_exists: "\<turnstile> $(\<exists> x. P x) = (\<exists> x. $(P x))"
  by (auto simp: before_def)

lemma before_exists1: "\<turnstile> $(\<exists>! x. P x) = (\<exists>! x. $(P x))"
  by (auto simp: before_def)

lemmas all_before = before_const before_fun1 before_fun2 before_fun3 before_fun4
  before_forall before_exists before_exists1

lemmas all_before_unl = all_before[THEN intD]
lemmas all_before_eq = all_before[THEN inteq_reflection]

subsection "Some general properties"

lemma angle_actrans_conj: "|~ (\<langle>F \<and> G\<rangle>_v) = (\<langle>F\<rangle>_v \<and> \<langle>G\<rangle>_v)"
  by (auto simp: angle_actrans_def actrans_def unch_def)

lemma angle_actrans_disj: "|~ (\<langle>F \<or> G\<rangle>_v) = (\<langle>F\<rangle>_v \<or> \<langle>G\<rangle>_v)"
  by (auto simp: angle_actrans_def actrans_def unch_def)

lemma int_eq_true: "\<turnstile> P \<Longrightarrow> \<turnstile> P = #True"
  by auto

lemma pref_eq_true: "|~ P \<Longrightarrow> |~ P = #True"
  by auto

subsection "Unlifting attributes and methods"

text {* Attribute which unlifts an intensional formula or preformula *}
ML {*
fun unl_rewr ctxt thm =
    let
       val unl = (thm RS @{thm intD}) handle THM _ => (thm RS @{thm prefD})
                                      handle THM _ => thm
       val rewr = rewrite_rule ctxt @{thms intensional_rews}
     in
       unl |> rewr
     end;
*}
attribute_setup unlifted = {*
  Scan.succeed (Thm.rule_attribute (unl_rewr o Context.proof_of))
*} "unlift intensional formulas"

attribute_setup unlift_rule = {*
  Scan.succeed
    (Thm.rule_attribute
      (Context.proof_of #> (fn ctxt => Object_Logic.rulify ctxt o unl_rewr ctxt)))
*} "unlift and rulify intensional formulas"

text {*
  Attribute which turns an intensional formula or preformula into a rewrite rule.
  Formulas @{text F} that are not equalities are turned into @{text "F \<equiv> #True"}.
*}
ML {*
fun int_rewr thm =
   (thm RS @{thm inteq_reflection})
     handle THM _ => (thm RS @{thm prefeq_reflection})
     handle THM _ => ((thm RS @{thm int_eq_true}) RS @{thm inteq_reflection})
     handle THM _ => ((thm RS @{thm pref_eq_true}) RS @{thm prefeq_reflection});
*}

attribute_setup simp_unl = {*
    Attrib.add_del
      (Thm.declaration_attribute
        (fn th => Simplifier.map_ss (Simplifier.add_simp (int_rewr th))))
      (K (NONE, NONE))  (* note only adding -- removing is ignored *)
*} "add thm unlifted from rewrites from intensional formulas or preformulas"

attribute_setup int_rewrite = {* Scan.succeed (Thm.rule_attribute (fn _ => int_rewr)) *}
  "produce rewrites from intensional formulas or preformulas"

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>The Smith normal form algorithm in HOL Analysis\<close>

theory SNF_Algorithm_HOL_Analysis
  imports
    SNF_Algorithm
    Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin

subsection \<open>Transferring the result from JNF to HOL Anaylsis\<close>

(*Now, we transfer the algorithm to HMA and get the final lemma.*)

definition Smith_mxn_HMA :: "(('a::comm_ring_1^2) \<Rightarrow> (('a^2) \<times> ('a^2^2)))
   \<Rightarrow> (('a^2^2) \<Rightarrow> (('a^2^2) \<times> ('a^2^2) \<times> ('a^2^2))) \<Rightarrow> ('a\<Rightarrow>'a\<Rightarrow>'a) \<Rightarrow> ('a^'n::mod_type^'m::mod_type)
  \<Rightarrow> (('a^'m::mod_type^'m::mod_type)\<times> ('a^'n::mod_type^'m::mod_type) \<times> ('a^'n::mod_type^'n::mod_type))"
  where
"Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A =
  (let Smith_1x2_JNF = (\<lambda>A'. let (S',Q') = Smith_1x2 (Mod_Type_Connect.to_hma\<^sub>v (Matrix.row A' 0))
                        in (mat_of_row (Mod_Type_Connect.from_hma\<^sub>v S'), Mod_Type_Connect.from_hma\<^sub>m Q'));
       Smith_2x2_JNF = (\<lambda>A'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hma\<^sub>m A')
                        in (Mod_Type_Connect.from_hma\<^sub>m P', Mod_Type_Connect.from_hma\<^sub>m S', Mod_Type_Connect.from_hma\<^sub>m Q'));
       (P,S,Q) = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op (Mod_Type_Connect.from_hma\<^sub>m A)
  in (Mod_Type_Connect.to_hma\<^sub>m P, Mod_Type_Connect.to_hma\<^sub>m S, Mod_Type_Connect.to_hma\<^sub>m Q)
  )"

definition "is_SNF_HMA A R = (case R of (P,S,Q) \<Rightarrow>
   invertible P \<and> invertible Q
  \<and> Smith_normal_form S \<and> S = P ** A ** Q)"

subsection \<open>Soundness in HOL Anaylsis\<close>

lemma is_SNF_Smith_mxn_HMA:
  fixes A::"'a::comm_ring_1 ^ 'n::mod_type ^ 'm::mod_type"
  assumes PSQ: "(P,S,Q) = Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A"
  and SNF_1x2_works: "\<forall>A. let (S',Q) = Smith_1x2 A in S' $h 1 = 0 \<and> invertible Q \<and> S' = A v* Q"
    and SNF_2x2_works: "\<forall>A. is_SNF_HMA A (Smith_2x2 A)"
    and d: "is_div_op div_op"
  shows "is_SNF_HMA A (P,S,Q)"
proof -
  let ?A = "Mod_Type_Connect.from_hma\<^sub>m A"
  define Smith_1x2_JNF where "Smith_1x2_JNF = (\<lambda>A'. let (S',Q')
    = Smith_1x2 (Mod_Type_Connect.to_hma\<^sub>v (Matrix.row A' 0))
    in (mat_of_row (Mod_Type_Connect.from_hma\<^sub>v S'), Mod_Type_Connect.from_hma\<^sub>m Q'))"
  define Smith_2x2_JNF where "Smith_2x2_JNF = (\<lambda>A'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hma\<^sub>m A')
    in (Mod_Type_Connect.from_hma\<^sub>m P', Mod_Type_Connect.from_hma\<^sub>m S', Mod_Type_Connect.from_hma\<^sub>m Q'))"
  obtain P' S' Q' where P'S'Q': "(P',S',Q') = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A"
    by (metis prod_cases3)
  have PSQ_P'S'Q': "(P,S,Q) =
      (Mod_Type_Connect.to_hma\<^sub>m P', Mod_Type_Connect.to_hma\<^sub>m S', Mod_Type_Connect.to_hma\<^sub>m Q')"
    using PSQ P'S'Q' Smith_1x2_JNF_def Smith_2x2_JNF_def
    unfolding Smith_mxn_HMA_def Let_def by (metis case_prod_conv)
  have SNF_1x2_works': "\<forall>(A::'a mat) \<in> carrier_mat 1 2. is_SNF A (1\<^sub>m 1, (Smith_1x2_JNF A))"
  proof (rule+)
    fix A'::"'a mat" assume A': "A' \<in> carrier_mat 1 2"
    let ?A' = "(Mod_Type_Connect.to_hma\<^sub>v (Matrix.row A' 0))::'a^2"
    obtain S2 Q2 where S'Q': "(S2,Q2) = Smith_1x2 ?A'"
      by (metis surjective_pairing)
    let ?S2 = "(Mod_Type_Connect.from_hma\<^sub>v S2)"
    let ?S' = "mat_of_row ?S2"
    let ?Q' = "Mod_Type_Connect.from_hma\<^sub>m Q2"
    have [transfer_rule]: "Mod_Type_Connect.HMA_V ?S2 S2"
      unfolding Mod_Type_Connect.HMA_V_def by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q2"
      unfolding Mod_Type_Connect.HMA_M_def by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 (1::2)"
      unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
    have c[transfer_rule]: "Mod_Type_Connect.HMA_V ((Matrix.row A' 0)) ?A'"
      unfolding Mod_Type_Connect.HMA_V_def
      by (rule from_hma_to_hma\<^sub>v[symmetric], insert A', auto simp add: Matrix.row_def)
    have *: "Smith_1x2_JNF A' = (?S', ?Q')" by (metis Smith_1x2_JNF_def S'Q' case_prod_conv)
    show "is_SNF A' (1\<^sub>m 1, Smith_1x2_JNF A')" unfolding *
    proof (rule is_SNF_intro)
      let ?row_A' = "(Matrix.row A' 0)"
      have w: "S2 $h 1 = 0 \<and> invertible Q2 \<and> S2 = ?A' v* Q2"
        using SNF_1x2_works by (metis (mono_tags, lifting) S'Q' fst_conv prod.case_eq_if snd_conv)
      have "?S2 $v 1 = 0" using w[untransferred] by auto
      thus "Smith_normal_form_mat ?S'" unfolding Smith_normal_form_mat_def isDiagonal_mat_def
        by (auto simp add: less_2_cases_iff)
      have S2_Q2_A: "S2 = transpose Q2 *v ?A'" using w transpose_matrix_vector by auto
      have S2_Q2_A': "?S2 = transpose_mat ?Q' *\<^sub>v ((Matrix.row A' 0))" using S2_Q2_A by transfer'
      show "1\<^sub>m 1 \<in> carrier_mat (dim_row A') (dim_row A')" using A' by auto
      show "?Q' \<in> carrier_mat (dim_col A') (dim_col A')" using A' by auto
      show "invertible_mat (1\<^sub>m 1)" by auto
      show "invertible_mat ?Q'" using w[untransferred] by auto
      have "?S' = A' * ?Q'"
      proof (rule eq_matI)
        show "dim_row ?S' = dim_row (A' * ?Q')" and "dim_col ?S' = dim_col (A' * ?Q')"
          using A' by auto
        fix i j assume i: "i < dim_row (A' * ?Q')" and j: "j < dim_col (A' * ?Q')"
        have "?S' $$ (i, j) = ?S' $$ (0, j)"
          by (metis A' One_nat_def carrier_matD(1) i index_mult_mat(2) less_Suc0)
        also have "... =?S2 $v j" using j by auto
        also have "... = (transpose_mat ?Q' *\<^sub>v ?row_A') $v j" unfolding S2_Q2_A' by simp
        also have "... = Matrix.row (transpose_mat ?Q') j \<bullet> ?row_A'"
          by (rule index_mult_mat_vec, insert j, auto)
        also have "... = Matrix.col ?Q' j \<bullet> ?row_A'" using j by auto
        also have "... = ?row_A' \<bullet> Matrix.col ?Q' j"
          by (metis (no_types, lifting) Mod_Type_Connect.HMA_V_def Mod_Type_Connect.from_hma\<^sub>m_def
              Mod_Type_Connect.from_hma\<^sub>v_def c col_def comm_scalar_prod dim_row_mat(1) vec_carrier)
        also have "... = (A' * ?Q') $$ (0, j)" using A' j by auto
        finally show "?S' $$ (i, j) = (A' * ?Q') $$ (i, j)" using i j A' by auto
      qed
      thus "?S' = 1\<^sub>m 1 * A' * ?Q'" using A' by auto
    qed
  qed
  have SNF_2x2_works': "\<forall>(A::'a mat) \<in> carrier_mat 2 2. is_SNF A (Smith_2x2_JNF A)"
  proof
    fix A'::"'a mat" assume A': "A' \<in> carrier_mat 2 2"
    let ?A' = "Mod_Type_Connect.to_hma\<^sub>m A'::'a^2^2"
    obtain P2 S2 Q2 where P2S2Q2: "(P2, S2, Q2) = Smith_2x2 ?A'"
      by (metis prod_cases3)
    let ?P2 = "Mod_Type_Connect.from_hma\<^sub>m P2"
    let ?S2 = "Mod_Type_Connect.from_hma\<^sub>m S2"
    let ?Q2 = "Mod_Type_Connect.from_hma\<^sub>m Q2"
    have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q2 Q2"
      and [transfer_rule]: "Mod_Type_Connect.HMA_M ?P2 P2"
      and [transfer_rule]: "Mod_Type_Connect.HMA_M ?S2 S2"
      and [transfer_rule]: "Mod_Type_Connect.HMA_M A' ?A'"
      unfolding Mod_Type_Connect.HMA_M_def using A' by auto
    have "is_SNF A' (?P2,?S2,?Q2)"
    proof -
      have P2: "?P2 \<in> carrier_mat (dim_row A') (dim_row A')" and
        Q2: "?Q2 \<in> carrier_mat (dim_col A') (dim_col A')" using A' by auto
      have "is_SNF_HMA ?A' (P2,S2,Q2)" using SNF_2x2_works by (simp add: P2S2Q2)
      hence "invertible P2 \<and> invertible Q2 \<and> Smith_normal_form S2 \<and> S2 = P2 ** ?A' ** Q2"
        unfolding is_SNF_HMA_def by auto
      from this[untransferred] show ?thesis using P2 Q2 unfolding is_SNF_def by auto
    qed
    thus "is_SNF A' (Smith_2x2_JNF A')" using P2S2Q2 by (metis Smith_2x2_JNF_def case_prod_conv)
  qed
  interpret Smith_Impl Smith_1x2_JNF Smith_2x2_JNF div_op
    using SNF_2x2_works' SNF_1x2_works' d by (unfold_locales, auto)
  have A: "?A \<in> carrier_mat CARD('m) CARD('n)" by auto
  have "is_SNF ?A (Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A)"
    by (rule is_SNF_Smith_mxn[OF A])
  hence inv_P': "invertible_mat P'"
    and Smith_S': "Smith_normal_form_mat S'" and inv_Q': "invertible_mat Q'"
    and S'_P'AQ': "S' = P' * ?A * Q'"
    and P': "P' \<in> carrier_mat (dim_row ?A) (dim_row ?A)"
    and Q': "Q' \<in> carrier_mat (dim_col ?A) (dim_col ?A)"
    unfolding is_SNF_def P'S'Q'[symmetric] by auto
  have S': "S' \<in> carrier_mat (dim_row ?A) (dim_col ?A)" using P' Q' S'_P'AQ' by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_M P' P"
  and [transfer_rule]: "Mod_Type_Connect.HMA_M S' S"
  and [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q"
  and [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A"
    unfolding Mod_Type_Connect.HMA_M_def using PSQ_P'S'Q'
    using from_hma_to_hma\<^sub>m[symmetric] P' A Q' S' by auto
  have inv_Q: "invertible Q" using inv_Q' by transfer
  moreover have Smith_S: "Smith_normal_form S" using Smith_S' by transfer
  moreover have inv_P: "invertible P" using inv_P' by transfer
  moreover have "S = P ** A ** Q" using S'_P'AQ' by transfer
  thus ?thesis using inv_Q inv_P Smith_S unfolding is_SNF_HMA_def by auto
qed
end


(*  Title:      HOL/ex/Simproc_Tests.thy
    Author:     Brian Huffman
*)

section \<open>Testing of arithmetic simprocs\<close>

theory Simproc_Tests
imports Main
begin

text \<open>
  This theory tests the various simprocs defined in \<^file>\<open>~~/src/HOL/Nat.thy\<close> and
  \<^file>\<open>~~/src/HOL/Numeral_Simprocs.thy\<close>. Many of the tests are derived from commented-out code
  originally found in \<^file>\<open>~~/src/HOL/Tools/numeral_simprocs.ML\<close>.
\<close>

subsection \<open>ML bindings\<close>

ML \<open>
  fun test ctxt ps =
    CHANGED (asm_simp_tac (put_simpset HOL_basic_ss ctxt addsimprocs ps) 1)
\<close>

subsection \<open>Cancellation simprocs from \<open>Nat.thy\<close>\<close>

notepad begin
  fix a b c d :: nat
  {
    assume "b = Suc c" have "a + b = Suc (c + a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_sums\<close>]\<close>) fact
  next
    assume "b < Suc c" have "a + b < Suc (c + a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_sums\<close>]\<close>) fact
  next
    assume "b \<le> Suc c" have "a + b \<le> Suc (c + a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_sums\<close>]\<close>) fact
  next
    assume "b - Suc c = d" have "a + b - Suc (c + a) = d"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_sums\<close>]\<close>) fact
  }
end

schematic_goal "\<And>(y::?'b::size). size (?x::?'a::size) \<le> size y + size ?x"
  by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_sums\<close>]\<close>) (rule le0)
(* TODO: test more simprocs with schematic variables *)

subsection \<open>Abelian group cancellation simprocs\<close>

notepad begin
  fix a b c u :: "'a::ab_group_add"
  {
    assume "(a + 0) - (b + 0) = u" have "(a + c) - (b + c) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>group_cancel_diff\<close>]\<close>) fact
  next
    assume "a + 0 = b + 0" have "a + c = b + c"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>group_cancel_eq\<close>]\<close>) fact
  }
end
(* TODO: more tests for Groups.group_cancel_{add,diff,eq,less,le} *)

subsection \<open>\<open>int_combine_numerals\<close>\<close>

(* FIXME: int_combine_numerals often unnecessarily regroups addition
and rewrites subtraction to negation. Ideally it should behave more
like Groups.abel_cancel_sum, preserving the shape of terms as much as
possible. *)

notepad begin
  fix a b c d oo uu i j k l u v w x y z :: "'a::comm_ring_1"
  {
    assume "a + - b = u" have "(a + c) - (b + c) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "10 + (2 * l + oo) = uu"
    have "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-3 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "7 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 5 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-4 * (u * v) + (2 * x + y) = w"
    have "(2*x - (u*v) + y) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "2 * x * u * v + y = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u*4 = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "3 * (u * v) + (2 * x * u * v + y) = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-3 * (u * v) + (- (x * u * v) + - y) = w"
    have "u*v - (x*u*v + (u*v)*4 + y) = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "a + - c = d"
    have "a + -(b+c) + b = d"
      apply (simp only: minus_add_distrib)
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-2 * b + (a + - c) = d"
    have "a + -(b+c) - b = d"
      apply (simp only: minus_add_distrib)
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-7 + (i + (j + (k + (- u + - y)))) = z"
    have "(i + j + -2 + k) - (u + 5 + y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-27 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - 15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "27 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - -15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "3 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - -15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>inteq_cancel_numerals\<close>\<close>

notepad begin
  fix i j k u vv w y z w' y' z' :: "'a::comm_ring_1"
  {
    assume "u = 0" have "2*u = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) fact
(* conclusion matches Rings.ring_1_no_zero_divisors_class.mult_cancel_right2 *)
  next
    assume "i + (j + k) = 3 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) fact
  next
    assume "7 + (j + (i + k)) = y"
    have "(i + j*2 + 12 + k) = j + 5 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) fact
  next
    assume "u + (6*z + (4*y + 6*w)) = 6*z' + (4*y' + (6*w' + vv))"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + vv"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>, \<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>intless_cancel_numerals\<close>\<close>

notepad begin
  fix b c i j k u y :: "'a::linordered_idom"
  {
    assume "y < 2 * b" have "y - b < b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>intless_cancel_numerals\<close>]\<close>) fact
  next
    assume "c + y < 4 * b" have "y - (3*b + c) < b - 2*c"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>intless_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) < 8 + (u + y)"
    have "(i + j + -3 + k) < u + 5 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>intless_cancel_numerals\<close>]\<close>) fact
  next
    assume "9 + (i + (j + k)) < u + y"
    have "(i + j + 3 + k) < u + -6 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>intless_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>ring_eq_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y :: "'a::{idom,ring_char_0}"
  {
    assume "3*x = 4*y" have "9*x = 12 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "-3*x = 4*y" have "-99*x = 132 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "111*x = -44*y" have "999*x = -396 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "11*x = 9*y" have "-99*x = -81 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "2*x = y" have "-2 * x = -1 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "2*x = y" have "-2 * x = -y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_numeral_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>int_div_cancel_numeral_factors\<close>\<close>

notepad begin
  fix x y z :: "'a::{unique_euclidean_semiring,comm_ring_1,ring_char_0}"
  {
    assume "(3*x) div (4*y) = z" have "(9*x) div (12*y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_numeral_factors\<close>]\<close>) fact
  next
    assume "(-3*x) div (4*y) = z" have "(-99*x) div (132*y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_numeral_factors\<close>]\<close>) fact
  next
    assume "(111*x) div (-44*y) = z" have "(999*x) div (-396*y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_numeral_factors\<close>]\<close>) fact
  next
    assume "(11*x) div (9*y) = z" have "(-99*x) div (-81*y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_numeral_factors\<close>]\<close>) fact
  next
    assume "(2*x) div y = z"
    have "(-2 * x) div (-1 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_numeral_factors\<close>]\<close>) fact
  }
end

subsection \<open>\<open>ring_less_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y :: "'a::linordered_idom"
  {
    assume "3*x < 4*y" have "9*x < 12 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_less_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "-3*x < 4*y" have "-99*x < 132 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_less_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "111*x < -44*y" have "999*x < -396 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_less_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "9*y < 11*x" have "-99*x < -81 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_less_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "y < 2*x" have "-2 * x < -y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_less_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "23*y < x" have "-x < -23 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_less_cancel_numeral_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>ring_le_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y :: "'a::linordered_idom"
  {
    assume "3*x \<le> 4*y" have "9*x \<le> 12 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "-3*x \<le> 4*y" have "-99*x \<le> 132 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "111*x \<le> -44*y" have "999*x \<le> -396 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "9*y \<le> 11*x" have "-99*x \<le> -81 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "y \<le> 2*x" have "-2 * x \<le> -1 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "23*y \<le> x" have "-x \<le> -23 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "y \<le> 0" have "0 \<le> y * -2"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "- x \<le> y" have "- (2 * x) \<le> 2*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_le_cancel_numeral_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>divide_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y z :: "'a::{field,ring_char_0}"
  {
    assume "(3*x) / (4*y) = z" have "(9*x) / (12 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "(-3*x) / (4*y) = z" have "(-99*x) / (132 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "(111*x) / (-44*y) = z" have "(999*x) / (-396 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "(11*x) / (9*y) = z" have "(-99*x) / (-81 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "(2*x) / y = z" have "(-2 * x) / (-1 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_numeral_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>ring_eq_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k x y :: "'a::idom"
  {
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> a*c = 1" have "a*(b*c) = b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d*x" have "a*(b*c) = d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>int_div_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k uu x y :: "'a::unique_euclidean_semiring"
  {
    assume "(if k = 0 then 0 else x div y) = uu"
    have "(x*k) div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else 1 div y) = uu"
    have "(k) div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) div b = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c div (d * x)) = uu"
    have "(a*(b*c)) div (d*b*(x*a)) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  }
end

lemma shows "a*(b*c)/(y*z) = d*(b::'a::linordered_field)*(x*a)/z"
oops \<comment> \<open>FIXME: need simproc to cover this case\<close>

subsection \<open>\<open>divide_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k uu x y :: "'a::field"
  {
    assume "(if k = 0 then 0 else x / y) = uu"
    have "(x*k) / (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else 1 / y) = uu"
    have "(k) / (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) / b = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c / (d * x)) = uu"
    have "(a*(b*c)) / (d*b*(x*a)) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  }
end

lemma
  fixes a b c d x y z :: "'a::linordered_field"
  shows "a*(b*c)/(y*z) = d*(b)*(x*a)/z"
oops \<comment> \<open>FIXME: need simproc to cover this case\<close>

subsection \<open>\<open>linordered_ring_less_cancel_factor\<close>\<close>

notepad begin
  fix x y z :: "'a::linordered_idom"
  {
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < y*z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < z*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < y*z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < z*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    txt "This simproc now uses the simplifier to prove that terms to
      be canceled are positive/negative."
    assume z_pos: "0 < z"
    assume "x < y" have "z*x < z*y"
      by (tactic \<open>CHANGED (asm_simp_tac (put_simpset HOL_basic_ss \<^context>
        addsimprocs [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]
        addsimps [@{thm z_pos}]) 1)\<close>) fact
  }
end

subsection \<open>\<open>linordered_ring_le_cancel_factor\<close>\<close>

notepad begin
  fix x y z :: "'a::linordered_idom"
  {
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> x*z \<le> y*z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> z*x \<le> z*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_le_cancel_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>field_combine_numerals\<close>\<close>

notepad begin
  fix x y z uu :: "'a::{field,ring_char_0}"
  {
    assume "5 / 6 * x = uu" have "x / 2 + x / 3 = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>) fact
  next
    assume "6 / 9 * x + y = uu" have "x / 3 + y + x / 3 = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>) fact
  next
    assume "9 / 9 * x = uu" have "2 * x / 3 + x / 3 = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>) fact
  next
    assume "y + z = uu"
    have "x / 2 + y - 3 * x / 6 + z = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>) fact
  next
    assume "1 / 15 * x + y = uu"
    have "7 * x / 5 + y - 4 * x / 3 = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>) fact
  }
end

lemma
  fixes x :: "'a::{linordered_field}"
  shows "2/3 * x + x / 3 = uu"
apply (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>)?
oops \<comment> \<open>FIXME: test fails\<close>

subsection \<open>\<open>nat_combine_numerals\<close>\<close>

notepad begin
  fix i j k m n u :: nat
  {
    assume "4*k = u" have "k + 3*k = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    (* FIXME "Suc (i + 3) \<equiv> i + 4" *)
    assume "4 * Suc 0 + i = u" have "Suc (i + 3) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    (* FIXME "Suc (i + j + 3 + k) \<equiv> i + j + 4 + k" *)
    assume "4 * Suc 0 + (i + (j + k)) = u" have "Suc (i + j + 3 + k) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    assume "2 * j + 4 * k = u" have "k + j + 3*k + j = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    assume "6 * Suc 0 + (5 * (i * j) + (4 * k + i)) = u"
    have "Suc (j*i + i + k + 5 + 3*k + i*j*4) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    assume "5 * (m * n) = u" have "(2*n*m) + (3*(m*n)) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>nateq_cancel_numerals\<close>\<close>

notepad begin
  fix i j k l oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "Suc 0 * u = 0" have "2*u = (u::nat)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * u = Suc 0" have "2*u = Suc (u)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) = 3 * Suc 0 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = u + 5 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "11 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = Suc (u + y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) = 2 * Suc 0 + (u + y)"
    have "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + 3 * z) = Suc 0"
    have "2*y + 3*z + 2*u = Suc (u)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + (3 * z + (6 * w + (2 * y + 3 * z)))) = Suc 0"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + (3 * z + (6 * w + (2 * y + 3 * z)))) =
      2 * y' + (3 * z' + (6 * w' + (2 * y' + (3 * z' + vv))))"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u =
      2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + vv"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "2 * u + (2 * z + (5 * Suc 0 + 2 * y)) = vv"
    have "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>natless_cancel_numerals\<close>\<close>

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l1 l2 xs :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c i j k l m oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "0 < j" have "(2*length xs < 2*length xs + j)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  next
    assume "0 < j" have "(2*length xs < length xs * 2 + j)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) < u + y"
    have "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  next
    assume "0 < Suc 0 * (m * n) + u" have "(2*n*m) < (3*(m*n)) + u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>natle_cancel_numerals\<close>\<close>

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l2 l3 :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c e i j k l oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "u + y \<le> 36 * Suc 0 + (i + (j + k))"
    have "Suc (Suc (Suc (Suc (Suc (u + y))))) \<le> ((i + j) + 41 + k)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  next
    assume "5 * Suc 0 + (case length (f c) of 0 \<Rightarrow> 0 | Suc k \<Rightarrow> k) = 0"
    have "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) \<le> Suc 0)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  next
    assume "6 + length l2 = 0" have "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) \<le> length l1"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  next
    assume "5 + length l3 = 0"
    have "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) \<le> length (compT P E A ST mxr e))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  next
    assume "5 + length (compT P E (A \<union> A' e) ST mxr c) = 0"
    have "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length (compT P E (A Un A' e) ST mxr c))))))) \<le> length (compT P E A ST mxr e))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>natdiff_cancel_numerals\<close>\<close>

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l2 l3 :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c e i j k l oo u uu vv v w x y z zz w' y' z' :: "nat"
  {
    assume "i + (j + k) - 3 * Suc 0 = y" have "(i + j + 12 + k) - 15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) - 0 = y" have "(i + j + 12 + k) - 5 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "u - Suc 0 * Suc 0 = y" have "Suc u - 2 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * Suc 0 + u - 0 = y" have "Suc (Suc (Suc u)) - 2 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * Suc 0 + (i + (j + k)) - 0 = y"
    have "(i + j + 2 + k) - 1 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) - Suc 0 * Suc 0 = y"
    have "(i + j + 1 + k) - 2 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "2 * x + y - 2 * (u * v) = w"
    have "(2*x + (u*v) + y) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "2 * x * u * v + (5 + y) - 0 = w"
    have "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "3 * (u * v) + (2 * x * u * v + y) - 0 = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "3 * u + (2 + (2 * x * u * v + y)) - 0 = w"
    have "Suc (Suc (2*x*u*v + u*4 + y)) - u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc (Suc 0 * (u * v)) - 0 = w"
    have "Suc ((u*v)*4) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "2 - 0 = w" have "Suc (Suc ((u*v)*3)) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "17 * Suc 0 + (i + (j + k)) - (u + y) = zz"
    have "(i + j + 32 + k) - (u + 15 + y) = zz"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "u + y - 0 = v" have "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>Factor-cancellation simprocs for type \<^typ>\<open>nat\<close>\<close>

text \<open>\<open>nat_eq_cancel_factor\<close>, \<open>nat_less_cancel_factor\<close>,
\<open>nat_le_cancel_factor\<close>, \<open>nat_divide_cancel_factor\<close>, and
\<open>nat_dvd_cancel_factor\<close>.\<close>

notepad begin
  fix a b c d k x y uu :: nat
  {
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> Suc 0 = y" have "k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> a * c = Suc 0" have "a*(b*c) = b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d * x" have "a*(b*c) = d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<and> x < y" have "x*k < k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<and> Suc 0 < y" have "k < k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < b \<and> a * c < Suc 0" have "a*(b*c) < b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < a \<and> 0 < b \<and> c < d * x" have "a*(b*c) < d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<longrightarrow> x \<le> y" have "x*k \<le> k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<longrightarrow> Suc 0 \<le> y" have "k \<le> k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < b \<longrightarrow> a * c \<le> Suc 0" have "a*(b*c) \<le> b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < a \<longrightarrow> 0 < b \<longrightarrow> c \<le> d * x" have "a*(b*c) \<le> d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else x div y) = uu" have "(x*k) div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else Suc 0 div y) = uu" have "k div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu" have "(a*(b*c)) div (b) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c div (d * x)) = uu"
    have "(a*(b*c)) div (d*b*(x*a)) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> x dvd y" have "(x*k) dvd (k*y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> Suc 0 dvd y" have "k dvd (k*y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> a * c dvd Suc 0" have "(a*(b*c)) dvd (b)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> Suc 0 dvd a * c" have "b dvd (a*(b*c))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c dvd d * x" have "(a*(b*c)) dvd (d*b*(x*a))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  }
end

subsection \<open>Numeral-cancellation simprocs for type \<^typ>\<open>nat\<close>\<close>

notepad begin
  fix x y z :: nat
  {
    assume "3 * x = 4 * y" have "9*x = 12 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "3 * x < 4 * y" have "9*x < 12 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "3 * x \<le> 4 * y" have "9*x \<le> 12 * y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "(3 * x) div (4 * y) = z" have "(9*x) div (12 * y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_numeral_factor\<close>]\<close>) fact
  next
    assume "(3 * x) dvd (4 * y)" have "(9*x) dvd (12 * y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_numeral_factor\<close>]\<close>) fact
  }
end

subsection \<open>Integer numeral div/mod simprocs\<close>

notepad begin
  have "(10::int) div 3 = 3"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(10::int) mod 3 = 1"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(10::int) div -3 = -4"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(10::int) mod -3 = -2"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) div 3 = -4"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) mod 3 = 2"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) div -3 = 3"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) mod -3 = -1"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(8452::int) mod 3 = 1"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(59485::int) div 434 = 137"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(1000006::int) mod 10 = 6"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000000 div 2 = (5000000::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000001 mod 2 = (1::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000055 div 32 = (312501::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000055 mod 32 = (23::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "100094 div 144 = (695::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "100094 mod 144 = (14::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
end

end


theory Residual
imports
  Nominal2.Nominal2
begin

section \<open>Residuals\<close>

subsection \<open>Binding names\<close>

text \<open>To define $\alpha$-equivalence, we require actions to be equipped with an equivariant
function~@{term bn} that gives their binding names. Actions may only bind finitely many names. This
is necessary to ensure that we can use a finite permutation to rename the binding names in an
action.\<close>

class bn = fs +
  fixes bn :: "'a \<Rightarrow> atom set"
  assumes bn_eqvt: "p \<bullet> (bn \<alpha>) = bn (p \<bullet> \<alpha>)"
  and bn_finite: "finite (bn \<alpha>)"

lemma bn_subset_supp: "bn \<alpha> \<subseteq> supp \<alpha>"
by (metis (erased, hide_lams) bn_eqvt bn_finite eqvt_at_def finite_supp supp_eqvt_at supp_finite_atom_set)

subsection \<open>Raw residuals and \texorpdfstring{$\alpha$}{alpha}-equivalence\<close>

text \<open>Raw residuals are simply pairs of actions and states. Binding names in the action bind into
(the action and) the state.\<close>

fun alpha_residual :: "('act::bn \<times> 'state::pt) \<Rightarrow> ('act \<times> 'state) \<Rightarrow> bool" where
  "alpha_residual (\<alpha>1,P1) (\<alpha>2,P2) \<longleftrightarrow> [bn \<alpha>1]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"

text \<open>$\alpha$-equivalence is equivariant.\<close>

lemma alpha_residual_eqvt [eqvt]:
  assumes "alpha_residual r1 r2"
  shows "alpha_residual (p \<bullet> r1) (p \<bullet> r2)"
using assms by (cases r1, cases r2) (simp, metis Pair_eqvt bn_eqvt permute_Abs_set)

text \<open>$\alpha$-equivalence is an equivalence relation.\<close>

lemma alpha_residual_reflp: "reflp alpha_residual"
by (metis alpha_residual.simps prod.exhaust reflpI)

lemma alpha_residual_symp: "symp alpha_residual"
by (metis alpha_residual.simps prod.exhaust sympI)

lemma alpha_residual_transp: "transp alpha_residual"
by (rule transpI) (metis alpha_residual.simps prod.exhaust)

lemma alpha_residual_equivp: "equivp alpha_residual"
by (metis alpha_residual_reflp alpha_residual_symp alpha_residual_transp equivpI)

subsection \<open>Residuals\<close>

text \<open>Residuals are raw residuals quotiented by $\alpha$-equivalence.\<close>

quotient_type
  ('act,'state) residual = "'act::bn \<times> 'state::pt" / "alpha_residual"
  by (fact alpha_residual_equivp)

lemma residual_abs_rep [simp]: "abs_residual (rep_residual res) = res"
by (metis Quotient_residual Quotient_abs_rep)

lemma residual_rep_abs [simp]: "alpha_residual (rep_residual (abs_residual r)) r"
by (metis residual.abs_eq_iff residual_abs_rep)

text \<open>The permutation operation is lifted from raw residuals.\<close>

instantiation residual :: (bn,pt) pt
begin

  lift_definition permute_residual :: "perm \<Rightarrow> ('a,'b) residual \<Rightarrow> ('a,'b) residual"
    is permute
  by (fact alpha_residual_eqvt)

  instance
  proof
    fix res :: "(_,_) residual"
    show "0 \<bullet> res = res"
      by transfer (metis alpha_residual_equivp equivp_reflp permute_zero)
  next
    fix p q :: perm and res :: "(_,_) residual"
    show "(p + q) \<bullet> res = p \<bullet> q \<bullet> res"
      by transfer (metis alpha_residual_equivp equivp_reflp permute_plus)
  qed

end

text \<open>The abstraction function from raw residuals to residuals is equivariant. The representation
function is equivariant modulo $\alpha$-equivalence.\<close>

lemmas permute_residual.abs_eq [eqvt, simp]

lemma alpha_residual_permute_rep_commute [simp]: "alpha_residual (p \<bullet> rep_residual res) (rep_residual (p \<bullet> res))"
by (metis residual.abs_eq_iff residual_abs_rep permute_residual.abs_eq)

subsection \<open>Notation for pairs as residuals\<close>

abbreviation abs_residual_pair :: "'act::bn \<Rightarrow> 'state::pt \<Rightarrow> ('act,'state) residual" ("\<langle>_,_\<rangle>" [0,0] 1000)
where
  "\<langle>\<alpha>,P\<rangle> == abs_residual (\<alpha>,P)"

lemma abs_residual_pair_eqvt [simp]: "p \<bullet> \<langle>\<alpha>,P\<rangle> = \<langle>p \<bullet> \<alpha>, p \<bullet> P\<rangle>"
by (metis Pair_eqvt permute_residual.abs_eq)

subsection \<open>Support of residuals\<close>

text \<open>We only consider finitely supported states now.\<close>

lemma supp_abs_residual_pair: "supp \<langle>\<alpha>, P::'state::fs\<rangle> = supp (\<alpha>,P) - bn \<alpha>"
proof -
  have "supp \<langle>\<alpha>,P\<rangle> = supp ([bn \<alpha>]set. (\<alpha>, P))"
    by (simp add: supp_def residual.abs_eq_iff bn_eqvt)
  then show ?thesis by (simp add: supp_Abs)
qed

lemma bn_abs_residual_fresh [simp]: "bn \<alpha> \<sharp>* \<langle>\<alpha>,P::'state::fs\<rangle>"
by (simp add: fresh_star_def fresh_def supp_abs_residual_pair)

lemma finite_supp_abs_residual_pair [simp]: "finite (supp \<langle>\<alpha>, P::'state::fs\<rangle>)"
by (metis finite_Diff finite_supp supp_abs_residual_pair)

subsection \<open>Equality between residuals\<close>

lemma residual_eq_iff_perm: "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle> \<longleftrightarrow>
  (\<exists>p. supp (\<alpha>1, P1) - bn \<alpha>1 = supp (\<alpha>2, P2) - bn \<alpha>2 \<and> (supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> (\<alpha>1, P1) = (\<alpha>2, P2) \<and> p \<bullet> bn \<alpha>1 = bn \<alpha>2)"
  (is "?l \<longleftrightarrow> ?r")
proof
  assume *: "?l"
  then have "[bn \<alpha>1]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"
    by (simp add: residual.abs_eq_iff)
  then obtain p where "(bn \<alpha>1, (\<alpha>1,P1)) \<approx>set ((=)) supp p (bn \<alpha>2, (\<alpha>2,P2))"
    using Abs_eq_iff(1) by blast
  then show "?r"
    by (metis (mono_tags, lifting) alpha_set.simps)
next
  assume *: "?r"
  then obtain p where "(bn \<alpha>1, (\<alpha>1,P1)) \<approx>set ((=)) supp p (bn \<alpha>2, (\<alpha>2,P2))"
    using alpha_set.simps by blast
  then have "[bn \<alpha>1]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"
    using Abs_eq_iff(1) by blast
  then show "?l"
    by (simp add: residual.abs_eq_iff)
qed

lemma residual_eq_iff_perm_renaming: "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle> \<longleftrightarrow>
  (\<exists>p. supp (\<alpha>1, P1) - bn \<alpha>1 = supp (\<alpha>2, P2) - bn \<alpha>2 \<and> (supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> (\<alpha>1, P1) = (\<alpha>2, P2) \<and> p \<bullet> bn \<alpha>1 = bn \<alpha>2 \<and> supp p \<subseteq> bn \<alpha>1 \<union> p \<bullet> bn \<alpha>1)"
  (is "?l \<longleftrightarrow> ?r")
proof
  assume "?l"
  then obtain p where p: "supp (\<alpha>1, P1) - bn \<alpha>1 = supp (\<alpha>2, P2) - bn \<alpha>2 \<and> (supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> (\<alpha>1, P1) = (\<alpha>2, P2) \<and> p \<bullet> bn \<alpha>1 = bn \<alpha>2"
    by (metis residual_eq_iff_perm)
  moreover obtain q where q_p: "\<forall>b\<in>bn \<alpha>1. q \<bullet> b = p \<bullet> b" and supp_q: "supp q \<subseteq> bn \<alpha>1 \<union> p \<bullet> bn \<alpha>1"
    by (metis set_renaming_perm2)
  have "supp q \<subseteq> supp p"
  proof
    fix a assume *: "a \<in> supp q" then show "a \<in> supp p"
    proof (cases "a \<in> bn \<alpha>1")
      case True then show ?thesis
        using "*" q_p by (metis mem_Collect_eq supp_perm)
    next
      case False then have "a \<in> p \<bullet> bn \<alpha>1"
        using "*" supp_q using UnE subsetCE by blast
      with False have "p \<bullet> a \<noteq> a"
        by (metis mem_permute_iff)
      then show ?thesis
        using fresh_def fresh_perm by blast
    qed
  qed
  with p have "(supp (\<alpha>1, P1) - bn \<alpha>1) \<sharp>* q"
    by (meson fresh_def fresh_star_def subset_iff)
  moreover with p and q_p have "\<And>a. a \<in> supp \<alpha>1 \<Longrightarrow> q \<bullet> a = p \<bullet> a" and "\<And>a. a \<in> supp P1 \<Longrightarrow> q \<bullet> a = p \<bullet> a"
    by (metis Diff_iff fresh_perm fresh_star_def UnCI supp_Pair)+
  then have "q \<bullet> \<alpha>1 = p \<bullet> \<alpha>1" and "q \<bullet> P1 = p \<bullet> P1"
    by (metis supp_perm_perm_eq)+
  ultimately show "?r"
    using supp_q by (metis Pair_eqvt bn_eqvt)
next
  assume "?r" then show "?l"
    by (meson residual_eq_iff_perm)
qed

subsection \<open>Strong induction\<close>

lemma residual_strong_induct:
  assumes "\<And>(act::'act::bn) (state::'state::fs) (c::'a::fs). bn act \<sharp>* c \<Longrightarrow> P c \<langle>act,state\<rangle>"
  shows "P c residual"
proof (rule residual.abs_induct, clarify)
  fix act :: 'act and state :: 'state
  obtain p where 1: "(p \<bullet> bn act) \<sharp>* c" and 2: "supp \<langle>act,state\<rangle> \<sharp>* p"
    proof (rule at_set_avoiding2[of "bn act" c "\<langle>act,state\<rangle>", THEN exE])
      show "finite (bn act)" by (fact bn_finite)
    next
      show "finite (supp c)" by (fact finite_supp)
    next
      show "finite (supp \<langle>act,state\<rangle>)" by (fact finite_supp_abs_residual_pair)
    next
      show "bn act \<sharp>* \<langle>act,state\<rangle>" by (fact bn_abs_residual_fresh)
    qed metis
  from 2 have "\<langle>p \<bullet> act, p \<bullet> state\<rangle> = \<langle>act,state\<rangle>"
    using supp_perm_eq by fastforce
  then show "P c \<langle>act,state\<rangle>"
    using assms 1 by (metis bn_eqvt)
qed

subsection \<open>Other lemmas\<close>

lemma residual_empty_bn_eq_iff:
  assumes "bn \<alpha>1 = {}"
  shows "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle> \<longleftrightarrow> \<alpha>1 = \<alpha>2 \<and> P1 = P2"
proof
  assume "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle>"
  with assms have "[{}]set. (\<alpha>1, P1) = [bn \<alpha>2]set. (\<alpha>2, P2)"
    by (simp add: residual.abs_eq_iff)
  then obtain p where "({}, (\<alpha>1, P1)) \<approx>set ((=)) supp p (bn \<alpha>2, (\<alpha>2, P2))"
    using Abs_eq_iff(1) by blast
  then show "\<alpha>1 = \<alpha>2 \<and> P1 = P2"
    unfolding alpha_set using supp_perm_eq by fastforce
next
  assume "\<alpha>1 = \<alpha>2 \<and> P1 = P2" then show "\<langle>\<alpha>1,P1\<rangle> = \<langle>\<alpha>2,P2\<rangle>"
    by simp
qed

\<comment> \<open>The following lemma is not about residuals, but we have no better place for it.\<close>
lemma set_bounded_supp:
  assumes "finite S" and "\<And>x. x\<in>X \<Longrightarrow> supp x \<subseteq> S"
  shows "supp X \<subseteq> S"
proof -
  have "S supports X"
    unfolding supports_def proof (clarify)
    fix a b
    assume a: "a \<notin> S" and b: "b \<notin> S"
    {
      fix x
      assume "x \<in> X"
      then have "(a \<rightleftharpoons> b) \<bullet> x = x"
        using a b \<open>\<And>x. x\<in>X \<Longrightarrow> supp x \<subseteq> S\<close> by (meson fresh_def subsetCE swap_fresh_fresh)
    }
    then show "(a \<rightleftharpoons> b) \<bullet> X = X"
      by auto (metis (full_types) eqvt_bound mem_permute_iff, metis mem_permute_iff)
  qed
  then show "supp X \<subseteq> S"
    using assms(1) by (fact supp_is_subset)
qed

end


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

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

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

theory SPA imports Main
begin

section \<open>Syntax of First-Order Logic\<close>

type_synonym id = String.literal

datatype tm = Var id | Fun id \<open>tm list\<close>

datatype fm = Truth | Falsity | Pre id \<open>tm list\<close> | Imp fm fm | Iff fm fm | Con fm fm | Dis fm fm |
  Neg fm | Exi id fm | Uni id fm

section \<open>Definition of Rules and Axioms on Formulas\<close>

abbreviation (input) \<open>fail \<equiv> Truth\<close>

definition zip_eq :: \<open>tm list \<Rightarrow> tm list \<Rightarrow> fm list\<close>
  where
    \<open>zip_eq l l' \<equiv> map (\<lambda>(t, t'). Pre (STR ''='') [t, t']) (zip l l')\<close>

primrec occurs_in :: \<open>id \<Rightarrow> tm \<Rightarrow> bool\<close> and occurs_in_list :: \<open>id \<Rightarrow> tm list \<Rightarrow> bool\<close>
  where
    \<open>occurs_in i (Var x) = (i = x)\<close> |
    \<open>occurs_in i (Fun _ l) = occurs_in_list i l\<close> |
    \<open>occurs_in_list _ [] = False\<close> |
    \<open>occurs_in_list i (h # t) = (occurs_in i h \<or> occurs_in_list i t)\<close>

primrec free_in :: \<open>id \<Rightarrow> fm \<Rightarrow> bool\<close>
  where
    \<open>free_in _ Truth = False\<close> |
    \<open>free_in _ Falsity = False\<close> |
    \<open>free_in i (Pre _ l) = occurs_in_list i l\<close> |
    \<open>free_in i (Imp p q) = (free_in i p \<or> free_in i q)\<close> |
    \<open>free_in i (Iff p q) = (free_in i p \<or> free_in i q)\<close> |
    \<open>free_in i (Con p q) = (free_in i p \<or> free_in i q)\<close> |
    \<open>free_in i (Dis p q) = (free_in i p \<or> free_in i q)\<close> |
    \<open>free_in i (Neg p) = free_in i p\<close> |
    \<open>free_in i (Exi x p) = (i \<noteq> x \<and> free_in i p)\<close> |
    \<open>free_in i (Uni x p) = (i \<noteq> x \<and> free_in i p)\<close>

primrec equal_length :: \<open>tm list \<Rightarrow> tm list \<Rightarrow> bool\<close>
  where
    \<open>equal_length l [] = (case l of [] \<Rightarrow> True | _ # _ \<Rightarrow> False)\<close> |
    \<open>equal_length l (_ # r') = (case l of [] \<Rightarrow> False | _ # l' \<Rightarrow> equal_length l' r')\<close>

abbreviation (input) \<open>chain l l' p \<equiv> if equal_length l l' then foldr Imp (zip_eq l l') p else fail\<close>

definition modusponens' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>modusponens' r p' \<equiv> case r of Imp p q \<Rightarrow> if p = p' then q else fail | _ \<Rightarrow> fail\<close>

definition gen' :: \<open>id \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>gen' x p \<equiv> Uni x p\<close>

definition axiom_addimp' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_addimp' p q \<equiv> Imp p (Imp q p)\<close>

definition axiom_distribimp' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_distribimp' p q r \<equiv> Imp (Imp p (Imp q r)) (Imp (Imp p q) (Imp p r))\<close>

definition axiom_doubleneg' :: \<open>fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_doubleneg' p \<equiv> Imp (Imp (Imp p Falsity) Falsity) p\<close>

definition axiom_allimp' :: \<open>id \<Rightarrow> fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_allimp' x p q \<equiv> Imp (Uni x (Imp p q)) (Imp (Uni x p) (Uni x q))\<close>

definition axiom_impall' :: \<open>id \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_impall' x p \<equiv> if \<not> free_in x p then (Imp p (Uni x p)) else fail\<close>

definition axiom_existseq' :: \<open>id \<Rightarrow> tm \<Rightarrow> fm\<close>
  where
    \<open>axiom_existseq' x t \<equiv> if \<not> occurs_in x t then Exi x (Pre (STR ''='') [Var x, t]) else fail\<close>

definition axiom_eqrefl' :: \<open>tm \<Rightarrow> fm\<close>
  where
    \<open>axiom_eqrefl' t \<equiv> Pre (STR ''='') [t, t]\<close>

definition axiom_funcong' :: \<open>id \<Rightarrow> tm list \<Rightarrow> tm list \<Rightarrow> fm\<close>
  where
    \<open>axiom_funcong' i l l' \<equiv> chain l l' (Pre (STR ''='') [Fun i l, Fun i l'])\<close>

definition axiom_predcong' :: \<open>id \<Rightarrow> tm list \<Rightarrow> tm list \<Rightarrow> fm\<close>
  where
    \<open>axiom_predcong' i l l' \<equiv> chain l l' (Imp (Pre i l) (Pre i l'))\<close>

definition axiom_iffimp1' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_iffimp1' p q \<equiv> Imp (Iff p q) (Imp p q)\<close>

definition axiom_iffimp2' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_iffimp2' p q \<equiv> Imp (Iff p q) (Imp q p)\<close>

definition axiom_impiff' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_impiff' p q \<equiv> Imp (Imp p q) (Imp (Imp q p) (Iff p q))\<close>

definition axiom_true' :: fm
  where
    \<open>axiom_true' \<equiv> Iff Truth (Imp Falsity Falsity)\<close>

definition axiom_not' :: \<open>fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_not' p \<equiv> Iff (Neg p) (Imp p Falsity)\<close>

definition axiom_and' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_and' p q \<equiv> Iff (Con p q) (Imp (Imp p (Imp q Falsity)) Falsity)\<close>

definition axiom_or' :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_or' p q \<equiv> Iff (Dis p q) (Neg (Con (Neg p) (Neg q)))\<close>

definition axiom_exists' :: \<open>id \<Rightarrow> fm \<Rightarrow> fm\<close>
  where
    \<open>axiom_exists' x p \<equiv> Iff (Exi x p) (Neg (Uni x (Neg p)))\<close>

section \<open>Semantics of First-Order Logic\<close>

definition length2 :: \<open>tm list \<Rightarrow> bool\<close>
  where
    \<open>length2 l \<equiv> case l of [_,_] \<Rightarrow> True | _ \<Rightarrow> False\<close>

primrec \<comment> \<open>Semantics of terms\<close>
  semantics_term :: \<open>(id \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> tm \<Rightarrow> 'a\<close> and
  semantics_list :: \<open>(id \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> tm list \<Rightarrow> 'a list\<close>
  where
    \<open>semantics_term e _ (Var x) = e x\<close> |
    \<open>semantics_term e f (Fun i l) = f i (semantics_list e f l)\<close> |
    \<open>semantics_list _ _ [] = []\<close> |
    \<open>semantics_list e f (t # l) = semantics_term e f t # semantics_list e f l\<close>

primrec \<comment> \<open>Semantics of formulas\<close>
  semantics :: \<open>(id \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> fm \<Rightarrow> bool\<close>
  where
    \<open>semantics _ _ _ Truth = True\<close> |
    \<open>semantics _ _ _ Falsity = False\<close> |
    \<open>semantics e f g (Pre i l) = (if i = STR ''='' \<and> length2 l
      then (semantics_term e f (hd l) = semantics_term e f (hd (tl l)))
      else g i (semantics_list e f l))\<close> |
    \<open>semantics e f g (Imp p q) = (semantics e f g p \<longrightarrow> semantics e f g q)\<close> |
    \<open>semantics e f g (Iff p q) = (semantics e f g p \<longleftrightarrow> semantics e f g q)\<close> |
    \<open>semantics e f g (Con p q) = (semantics e f g p \<and> semantics e f g q)\<close> |
    \<open>semantics e f g (Dis p q) = (semantics e f g p \<or> semantics e f g q)\<close> |
    \<open>semantics e f g (Neg p) = (\<not> semantics e f g p)\<close> |
    \<open>semantics e f g (Exi x p) = (\<exists>v. semantics (e(x := v)) f g p)\<close> |
    \<open>semantics e f g (Uni x p) = (\<forall>v. semantics (e(x := v)) f g p)\<close>

section \<open>Definition of Proof System\<close>

inductive OK :: \<open>fm \<Rightarrow> bool\<close> ("\<turnstile> _" 0)
  where
    \<open>\<turnstile> s \<Longrightarrow> \<turnstile> s' \<Longrightarrow> \<turnstile> modusponens' s s'\<close> |
    \<open>\<turnstile> s \<Longrightarrow> \<turnstile> gen' _ s\<close> |
    \<open>\<turnstile> axiom_addimp' _ _\<close> |
    \<open>\<turnstile> axiom_distribimp' _ _ _\<close> |
    \<open>\<turnstile> axiom_doubleneg' _\<close> |
    \<open>\<turnstile> axiom_allimp' _ _ _\<close> |
    \<open>\<turnstile> axiom_impall' _ _\<close> |
    \<open>\<turnstile> axiom_existseq' _ _\<close> |
    \<open>\<turnstile> axiom_eqrefl' _\<close> |
    \<open>\<turnstile> axiom_funcong' _ _ _\<close> |
    \<open>\<turnstile> axiom_predcong' _ _ _\<close> |
    \<open>\<turnstile> axiom_iffimp1' _ _\<close> |
    \<open>\<turnstile> axiom_iffimp2' _ _\<close> |
    \<open>\<turnstile> axiom_impiff' _ _\<close> |
    \<open>\<turnstile> axiom_true'\<close> |
    \<open>\<turnstile> axiom_not' _\<close> |
    \<open>\<turnstile> axiom_and' _ _\<close> |
    \<open>\<turnstile> axiom_or' _ _\<close> |
    \<open>\<turnstile> axiom_exists' _ _\<close>

proposition \<open>\<turnstile> Imp p p\<close>
proof -
  have 1: \<open>\<turnstile> Imp (Imp p (Imp (Imp p p) p)) (Imp (Imp p (Imp p p)) (Imp p p))\<close>
    using OK.intros
    unfolding axiom_distribimp'_def
    by simp

  have 2: \<open>\<turnstile> Imp p (Imp (Imp p p) p)\<close>
    using OK.intros
    unfolding axiom_addimp'_def
    by simp

  have 3: \<open>\<turnstile> Imp (Imp p (Imp p p)) (Imp p p)\<close>
    using 1 2 OK.intros(1)
    unfolding modusponens'_def
    by fastforce

  have 4: \<open>\<turnstile> Imp p (Imp p p)\<close>
    using OK.intros
    unfolding axiom_addimp'_def
    by simp

  have 5: \<open>\<turnstile> Imp p p\<close>
    using 3 4 OK.intros(1)
    unfolding modusponens'_def
    by fastforce

  show ?thesis
    using 5
    by simp
qed

section \<open>Soundness of Proof System\<close>

lemma map':
  \<open>\<not> occurs_in x t \<Longrightarrow> semantics_term e f t = semantics_term (e(x := v)) f t\<close>
  \<open>\<not> occurs_in_list x l \<Longrightarrow> semantics_list e f l = semantics_list (e(x := v)) f l\<close>
  by (induct t and l rule: semantics_term.induct semantics_list.induct) simp_all

lemma map:
  \<open>\<not> free_in x p \<Longrightarrow> semantics e f g p \<longleftrightarrow> semantics (e(x := v)) f g p\<close>
proof (induct p arbitrary: e)
  fix e
  show \<open>\<not> free_in x Truth \<Longrightarrow> semantics e f g Truth \<longleftrightarrow> semantics (e(x := v)) f g Truth\<close>
    by simp
next
  fix e
  show \<open>\<not> free_in x Falsity \<Longrightarrow> semantics e f g Falsity \<longleftrightarrow> semantics (e(x := v)) f g Falsity\<close>
    by simp
next
  fix e i l
  show \<open>\<not> free_in x (Pre i l) \<Longrightarrow> semantics e f g (Pre i l) \<longleftrightarrow> semantics (e(x := v)) f g (Pre i l)\<close>
  proof -
    assume assm: \<open>\<not> free_in x (Pre i l)\<close>
    then have fresh: \<open>\<not> occurs_in_list x l\<close>
      by simp
    show \<open>semantics e f g (Pre i l) \<longleftrightarrow> semantics (e(x := v)) f g (Pre i l)\<close>
    proof cases
      assume eq: \<open>i = STR ''='' \<and> length2 l\<close>
      then have \<open>semantics e f g (Pre i l) \<longleftrightarrow>
          semantics_term e f (hd l) = semantics_term e f (hd (tl l))\<close>
        by simp
      also have \<open>\<dots> \<longleftrightarrow>
          semantics_term (e(x := v)) f (hd l) = semantics_term (e(x := v)) f (hd (tl l))\<close>
        using map'(1) fresh occurs_in_list.simps(2) eq list.case_eq_if list.collapse
        unfolding length2_def
        by metis
      finally show ?thesis
        using eq
        by simp
    next
      assume not_eq: \<open>\<not> (i = STR ''='' \<and> length2 l)\<close>
      then have \<open>semantics e f g (Pre i l) \<longleftrightarrow> g i (semantics_list e f l)\<close>
        by simp iprover
      also have \<open>\<dots> \<longleftrightarrow> g i (semantics_list (e(x := v)) f l)\<close>
        using map'(2) fresh
        by metis
      finally show ?thesis
        using not_eq
        by simp iprover
    qed
  qed
next
  fix p1 p2 e
  assume assm1: \<open>\<not> free_in x p1 \<Longrightarrow> semantics e f g p1 \<longleftrightarrow> semantics (e(x := v)) f g p1\<close> for e
  assume assm2: \<open>\<not> free_in x p2 \<Longrightarrow> semantics e f g p2 \<longleftrightarrow> semantics (e(x := v)) f g p2\<close> for e
  show \<open>\<not> free_in x (Imp p1 p2) \<Longrightarrow>
      semantics e f g (Imp p1 p2) \<longleftrightarrow> semantics (e(x := v)) f g (Imp p1 p2)\<close>
    using assm1 assm2
    by simp
next
  fix p1 p2 e
  assume assm1: \<open>\<not> free_in x p1 \<Longrightarrow> semantics e f g p1 \<longleftrightarrow> semantics (e(x := v)) f g p1\<close> for e
  assume assm2: \<open>\<not> free_in x p2 \<Longrightarrow> semantics e f g p2 \<longleftrightarrow> semantics (e(x := v)) f g p2\<close> for e
  show \<open>\<not> free_in x (Iff p1 p2) \<Longrightarrow>
      semantics e f g (Iff p1 p2) \<longleftrightarrow> semantics (e(x := v)) f g (Iff p1 p2)\<close>
    using assm1 assm2
    by simp
next
  fix p1 p2 e
  assume assm1: \<open>\<not> free_in x p1 \<Longrightarrow> semantics e f g p1 \<longleftrightarrow> semantics (e(x := v)) f g p1\<close> for e
  assume assm2: \<open>\<not> free_in x p2 \<Longrightarrow> semantics e f g p2 \<longleftrightarrow> semantics (e(x := v)) f g p2\<close> for e
  show \<open>\<not> free_in x (Con p1 p2) \<Longrightarrow>
      semantics e f g (Con p1 p2) \<longleftrightarrow> semantics (e(x := v)) f g (Con p1 p2)\<close>
    using assm1 assm2
    by simp
next
  fix p1 p2 e
  assume assm1: \<open>\<not> free_in x p1 \<Longrightarrow> semantics e f g p1 \<longleftrightarrow> semantics (e(x := v)) f g p1\<close> for e
  assume assm2: \<open>\<not> free_in x p2 \<Longrightarrow> semantics e f g p2 \<longleftrightarrow> semantics (e(x := v)) f g p2\<close> for e
  show \<open>\<not> free_in x (Dis p1 p2) \<Longrightarrow>
      semantics e f g (Dis p1 p2) \<longleftrightarrow> semantics (e(x := v)) f g (Dis p1 p2)\<close>
    using assm1 assm2
    by simp
next
  fix p e
  assume \<open>\<not> free_in x p \<Longrightarrow> semantics e f g p \<longleftrightarrow> semantics (e(x := v)) f g p\<close> for e
  then show \<open>\<not> free_in x (Neg p) \<Longrightarrow> semantics e f g (Neg p) \<longleftrightarrow> semantics (e(x := v)) f g (Neg p)\<close>
    by simp
next
  fix x1 p e
  assume \<open>\<not> free_in x p \<Longrightarrow> semantics e f g p \<longleftrightarrow> semantics (e(x := v)) f g p\<close> for e
  then show \<open>\<not> free_in x (Exi x1 p) \<Longrightarrow>
      semantics e f g (Exi x1 p) \<longleftrightarrow> semantics (e(x := v)) f g (Exi x1 p)\<close>
    by simp (metis fun_upd_twist fun_upd_upd)
next
  fix x1 p e
  assume \<open>\<not> free_in x p \<Longrightarrow> semantics e f g p \<longleftrightarrow> semantics (e(x := v)) f g p\<close> for e
  then show \<open>\<not> free_in x (Uni x1 p) \<Longrightarrow>
      semantics e f g (Uni x1 p) \<longleftrightarrow> semantics (e(x := v)) f g (Uni x1 p)\<close>
    by simp (metis fun_upd_twist fun_upd_upd)
qed

lemma length2_equiv:
  \<open>length2 l \<longleftrightarrow> [hd l, hd (tl l)] = l\<close>
proof -
  have \<open>length2 l \<Longrightarrow> [hd l, hd (tl l)] = l\<close>
    unfolding length2_def
    using list.case_eq_if list.exhaust_sel
    by metis
  then show ?thesis
    unfolding length2_def
    using list.case list.case_eq_if
    by metis
qed

lemma equal_length_sym:
  \<open>equal_length l l' \<Longrightarrow> equal_length l' l\<close>
proof (induct l' arbitrary: l)
  fix l
  assume \<open>equal_length l []\<close>
  then show \<open>equal_length [] l\<close>
    using equal_length.simps list.case_eq_if
    by metis
next
  fix l l' a
  assume sym: \<open>equal_length l l' \<Longrightarrow> equal_length l' l\<close> for l
  assume \<open>equal_length l (a # l')\<close>
  then show \<open>equal_length (a # l') l\<close>
    using equal_length.simps list.case_eq_if list.collapse list.inject sym
    by metis
qed

lemma equal_length2:
  \<open>equal_length l l' \<Longrightarrow> length2 l \<longleftrightarrow> length2 l'\<close>
proof -
  assume assm: \<open>equal_length l l'\<close>
  have \<open>equal_length l [t, t'] \<Longrightarrow> length2 l\<close> for t t'
    unfolding length2_def
    using equal_length.simps list.case_eq_if
    by metis
  moreover have \<open>equal_length [t, t'] l' \<Longrightarrow> length2 l'\<close> for t t'
    unfolding length2_def
    using equal_length.simps list.case_eq_if equal_length_sym
    by metis
  ultimately show ?thesis
    using assm length2_equiv
    by metis
qed

lemma imp_chain_equiv:
  \<open>semantics e f g (foldr Imp l p) \<longleftrightarrow> (\<forall>q \<in> set l. semantics e f g q) \<longrightarrow> semantics e f g p\<close>
  using imp_conjL
  by (induct l) simp_all

lemma imp_chain_zip_eq:
  \<open>equal_length l l' \<Longrightarrow>
      semantics e f g (foldr Imp (zip_eq l l') p) \<longleftrightarrow>
      semantics_list e f l = semantics_list e f l' \<longrightarrow> semantics e f g p\<close>
proof -
  assume \<open>equal_length l l'\<close>
  then have \<open>(\<forall>q \<in> set (zip_eq l l'). semantics e f g q) \<longleftrightarrow>
      semantics_list e f l = semantics_list e f l'\<close>
    unfolding zip_eq_def
    using length2_def
    by (induct l l' rule: list_induct2') simp_all
  then show ?thesis
    using imp_chain_equiv
    by iprover
qed

lemma funcong:
  \<open>equal_length l l' \<Longrightarrow>
      semantics e f g (foldr Imp (zip_eq l l') (Pre (STR ''='') [Fun i l, Fun i l']))\<close>
proof -
  assume assm: \<open>equal_length l l'\<close>
  show ?thesis
  proof cases
    assume \<open>semantics_list e f l = semantics_list e f l'\<close>
    then have \<open>semantics e f g (Pre (STR ''='') [Fun i l, Fun i l'])\<close>
      using length2_def
      by simp
    then show ?thesis
      using imp_chain_equiv
      by iprover
  next
    assume \<open>semantics_list e f l \<noteq> semantics_list e f l'\<close>
    then show ?thesis
      using assm imp_chain_zip_eq
      by iprover
  qed
qed

lemma predcong:
  \<open>equal_length l l' \<Longrightarrow>
      semantics e f g (foldr Imp (zip_eq l l') (Imp (Pre i l) (Pre i l')))\<close>
proof -
  assume assm: \<open>equal_length l l'\<close>
  show ?thesis
  proof cases
    assume eq: \<open>i = STR ''='' \<and> length2 l \<and> length2 l'\<close>
    show ?thesis
    proof cases
      assume \<open>semantics_list e f l = semantics_list e f l'\<close>
      then have \<open>semantics_list e f [hd l, hd (tl l)] = semantics_list e f [hd l', hd (tl l')]\<close>
        using eq length2_equiv
        by simp
      then have \<open>semantics e f g (Imp (Pre (STR ''='') l) (Pre (STR ''='') l'))\<close>
        using eq
        by simp
      then show ?thesis
        using eq imp_chain_equiv
        by iprover
    next
      assume \<open>semantics_list e f l \<noteq> semantics_list e f l'\<close>
      then show ?thesis
        using assm imp_chain_zip_eq
        by iprover
    qed
  next
    assume not_eq: \<open>\<not> (i = STR ''='' \<and> length2 l \<and> length2 l')\<close>
    show ?thesis
    proof cases
      assume \<open>semantics_list e f l = semantics_list e f l'\<close>
      then have \<open>semantics e f g (Imp (Pre i l) (Pre i l'))\<close>
        using assm not_eq equal_length2
        by simp iprover
      then show ?thesis
        using imp_chain_equiv
        by iprover
    next
      assume \<open>semantics_list e f l \<noteq> semantics_list e f l'\<close>
      then show ?thesis
        using assm imp_chain_zip_eq
        by iprover
    qed
  qed
qed

theorem soundness':
  \<open>\<turnstile> p \<Longrightarrow> semantics e f g p\<close>
proof (induct arbitrary: e rule: OK.induct)
  fix e s s'
  assume \<open>semantics e f g s\<close> \<open>semantics e f g s'\<close> for e
  then show \<open>semantics e f g (modusponens' s s')\<close>
    unfolding modusponens'_def
    by (cases s) simp_all
next
  fix e x s
  assume \<open>semantics e f g s\<close> for e
  then show \<open>semantics e f g (gen' x s)\<close>
    unfolding gen'_def
    by simp
next
  fix e p q
  show \<open>semantics e f g (axiom_addimp' p q)\<close>
    unfolding axiom_addimp'_def
    by simp
next
  fix e p q r
  show \<open>semantics e f g (axiom_distribimp' p q r)\<close>
    unfolding axiom_distribimp'_def
    by simp
next
  fix e g p
  show \<open>semantics e f g (axiom_doubleneg' p)\<close>
    unfolding axiom_doubleneg'_def
    by simp
next
  fix e x p q
  show \<open>semantics e f g (axiom_allimp' x p q)\<close>
    unfolding axiom_allimp'_def
    by simp
next
  fix e x p
  show \<open>semantics e f g (axiom_impall' x p)\<close>
    unfolding axiom_impall'_def
    using map
    by simp iprover
next
  fix e x t
  show \<open>semantics e f g (axiom_existseq' x t)\<close>
    unfolding axiom_existseq'_def
    using map'(1) length2_def
    by simp iprover
next
  fix e t
  show \<open>semantics e f g (axiom_eqrefl' t)\<close>
    unfolding axiom_eqrefl'_def
    using length2_def
    by simp
next
  fix e i l l'
  show \<open>semantics e f g (axiom_funcong' i l l')\<close>
    unfolding axiom_funcong'_def
    using funcong
    by simp standard
next
  fix e i l l'
  show \<open>semantics e f g (axiom_predcong' i l l')\<close>
    unfolding axiom_predcong'_def
    using predcong
    by simp standard
next
  fix e p q
  show \<open>semantics e f g (axiom_iffimp1' p q)\<close>
    unfolding axiom_iffimp1'_def
    by simp
next
  fix e p q
  show \<open>semantics e f g (axiom_iffimp2' p q)\<close>
    unfolding axiom_iffimp2'_def
    by simp
next
  fix e p q
  show \<open>semantics e f g (axiom_impiff' p q)\<close>
    unfolding axiom_impiff'_def
    by simp (rule impI, rule impI, rule iffI, erule mp, assumption, erule mp, assumption)
next
  fix e
  show \<open>semantics e f g (axiom_true')\<close>
    unfolding axiom_true'_def
    by simp
next
  fix e p
  show \<open>semantics e f g (axiom_not' p)\<close>
    unfolding axiom_not'_def
    by simp
next
  fix e p q
  show \<open>semantics e f g (axiom_and' p q)\<close>
    unfolding axiom_and'_def
    by simp
next
  fix e p q
  show \<open>semantics e f g (axiom_or' p q)\<close>
    unfolding axiom_or'_def
    by simp
next
  fix e x p
  show \<open>semantics e f g (axiom_exists' x p)\<close>
    unfolding axiom_exists'_def
    by simp
qed

corollary consistency': \<open>\<not> (\<turnstile> Falsity)\<close>
  using soundness'
  by fastforce

section \<open>Definition of Theorems as a Type\<close>

typedef "thm" = \<open>{p :: fm. \<turnstile> p}\<close>
proof -
  have \<open>\<turnstile> axiom_addimp' Truth Truth\<close>
    using OK.intros by auto
  then show ?thesis by blast
qed

definition \<open>concl \<equiv> Rep_thm\<close>
declare concl_def[simp]

setup_lifting type_definition_thm

section \<open>Soundness of Proof System as a Type\<close>

theorem soundness: \<open>semantics e f g (concl p)\<close>
  using soundness' Rep_thm
  by fastforce

theorem consistency: \<open>concl p \<noteq> Falsity\<close>
  using consistency' Rep_thm concl_def mem_Collect_eq
  by metis

section \<open>Definition of Rules and Axioms on Theorems\<close>

lift_definition modusponens :: \<open>thm \<Rightarrow> thm \<Rightarrow> thm\<close> is modusponens'
  using OK.intros(1) .

lift_definition gen :: \<open>id \<Rightarrow> thm \<Rightarrow> thm\<close> is gen'
  using OK.intros(2) .

lift_definition axiom_addimp :: \<open>fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_addimp'
  using OK.intros(3) .

lift_definition axiom_distribimp :: \<open>fm \<Rightarrow> fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_distribimp'
  using OK.intros(4) .

lift_definition axiom_doubleneg :: \<open>fm \<Rightarrow> thm\<close> is axiom_doubleneg'
  using OK.intros(5) .

lift_definition axiom_allimp :: \<open>id \<Rightarrow> fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_allimp'
  using OK.intros(6) .

lift_definition axiom_impall :: \<open>id \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_impall'
  using OK.intros(7) .

lift_definition axiom_existseq :: \<open>id \<Rightarrow> tm \<Rightarrow> thm\<close> is axiom_existseq'
  using OK.intros(8) .

lift_definition axiom_eqrefl :: \<open>tm \<Rightarrow> thm\<close> is axiom_eqrefl'
  using OK.intros(9) .

lift_definition axiom_funcong :: \<open>id \<Rightarrow> tm list \<Rightarrow> tm list \<Rightarrow> thm\<close> is axiom_funcong'
  using OK.intros(10) .

lift_definition axiom_predcong :: \<open>id \<Rightarrow> tm list \<Rightarrow> tm list \<Rightarrow> thm\<close> is axiom_predcong'
  using OK.intros(11) .

lift_definition axiom_iffimp1 :: \<open>fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_iffimp1'
  using OK.intros(12) .

lift_definition axiom_iffimp2 :: \<open>fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_iffimp2'
  using OK.intros(13) .

lift_definition axiom_impiff :: \<open>fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_impiff'
  using OK.intros(14) .

lift_definition axiom_true :: \<open>thm\<close> is axiom_true'
  using OK.intros(15) .

lift_definition axiom_not :: \<open>fm \<Rightarrow> thm\<close> is axiom_not'
  using OK.intros(16) .

lift_definition axiom_and :: \<open>fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_and'
  using OK.intros(17) .

lift_definition axiom_or :: \<open>fm \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_or'
  using OK.intros(18) .

lift_definition axiom_exists :: \<open>id \<Rightarrow> fm \<Rightarrow> thm\<close> is axiom_exists'
  using OK.intros(19) .

section \<open>ML Code Reflection\<close>

code_reflect
  Proven
  datatypes
    tm = Var | Fun
    and
    fm = Truth | Falsity | Pre | Imp | Iff | Con | Dis | Neg | Exi | Uni
  functions
    modusponens gen axiom_addimp axiom_distribimp axiom_doubleneg axiom_allimp axiom_impall
    axiom_existseq axiom_eqrefl axiom_funcong axiom_predcong axiom_iffimp1 axiom_iffimp2
    axiom_impiff axiom_true axiom_not axiom_and axiom_or axiom_exists concl

ML_file \<open>SPA.ML\<close>

ML_val \<open> auto "A ==> A" \<close>

ML_val \<open> auto "exists x. D(x) ==> forall x. D(x)" \<close>

ML_val \<open> auto "(forall x. ~R(x) ==> R(f(x))) ==> exists x. R(x) /\\ R(f(f(x)))" \<close>

end