(*  Title:      HOL/SPARK/SPARK.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG

Declaration of proof functions for SPARK/Ada verification environment.
*)

theory SPARK
imports SPARK_Setup
begin

text \<open>Bitwise logical operators\<close>

spark_proof_functions
  bit__and (integer, integer) : integer = "op AND"
  bit__or (integer, integer) : integer = "op OR"
  bit__xor (integer, integer) : integer = "op XOR"

lemmas [simp] =
  OR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 8, simplified]
  OR_upper [of _ 16, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 16, simplified]
  OR_upper [of _ 32, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 32, simplified]
  OR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 64, simplified]

lemmas [simp] =
  XOR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 8, simplified]
  XOR_upper [of _ 16, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 16, simplified]
  XOR_upper [of _ 32, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 32, simplified]
  XOR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 64, simplified]

lemma bit_not_spark_eq:
  "NOT (word_of_int x :: ('a::len0) word) =
  word_of_int (2 ^ len_of TYPE('a) - 1 - x)"
proof -
  have "word_of_int x + NOT (word_of_int x) =
    word_of_int x + (word_of_int (2 ^ len_of TYPE('a) - 1 - x)::'a word)"
    by (simp only: bwsimps bin_add_not Min_def)
      (simp add: word_of_int_hom_syms word_of_int_2p_len)
  then show ?thesis by (rule add_left_imp_eq)
qed

lemmas [simp] =
  bit_not_spark_eq [where 'a=8, simplified]
  bit_not_spark_eq [where 'a=16, simplified]
  bit_not_spark_eq [where 'a=32, simplified]
  bit_not_spark_eq [where 'a=64, simplified]

text \<open>Minimum and maximum\<close>

spark_proof_functions
  integer__min = "min :: int \<Rightarrow> int \<Rightarrow> int"
  integer__max = "max :: int \<Rightarrow> int \<Rightarrow> int"

end


section "Execution Invariants (Part 3)"
theory execution_invariants_unused
  imports repliss_sem execution_invariants consistency commutativity  invariant_simps
begin

text "These are execution invariants not needed for the soundness proof, but which still
 might be useful for verifying some applications."

lemma causallyConsistent_downwards_closure:
assumes wf: "state_wellFormed S"
shows "causallyConsistent (happensBefore S) (cs \<down> happensBefore S)"
apply (auto simp add: causallyConsistent_def downwardsClosure_def)
  by (meson local.wf transD wellFormed_state_causality(2))

lemma consistentSnapshot_txns:
assumes wf: "state_wellFormed S"
  and comitted: "txns \<subseteq> committedTransactions S"
shows "consistentSnapshot S (callsInTransaction S txns \<down> happensBefore S)"
unfolding consistentSnapshotH_def proof (intro conjI)

  show "callsInTransaction S txns \<down> happensBefore S \<subseteq> dom (calls S)"
    apply (auto simp add: callsInTransactionH_def downwardsClosure_def)
    using local.wf wellFormed_callOrigin_dom2 apply fastforce
    by (simp add: domD happensBefore_in_calls_left local.wf)

  show "causallyConsistent (happensBefore S) (callsInTransaction S txns \<down> happensBefore S)"
    apply (auto simp add: callsInTransactionH_def downwardsClosure_def causallyConsistent_def)
    by (meson happensBefore_transitive local.wf transD)

  show "transactionConsistent (callOrigin S) (txStatus S) (callsInTransaction S txns \<down> happensBefore S)"
  proof (induct rule: show_transactionConsistent)
    case (only_committed c tx)
    then show ?case
      apply (auto simp add: callsInTransactionH_def downwardsClosure_def)
      using comitted apply blast
      using comitted local.wf wellFormed_state_transaction_consistent(4) by fastforce
  next
    case (all_from_same c1 c2)
    then show ?case
      apply (auto simp add: callsInTransactionH_def downwardsClosure_def)
      by (metis local.wf wellFormed_state_transaction_consistent(3))
  qed
qed

lemma wellFormed_visibleCallsSubsetCalls:
  assumes a1: "state_wellFormed A"
    and a2: "visibleCalls A s \<triangleq> vis"
  shows "vis \<subseteq> dom (calls A)"
  using a1 a2 wellFormed_visibleCallsSubsetCalls_h(2) by blast

lemma wf_current_tx_not_before_others:
  assumes wf: "state_wellFormed S"
    and "visibleCalls S i \<triangleq> Vis"
    and "currentTx S i \<triangleq> tx"
    and "callOrigin S x \<triangleq> tx"
    and "callOrigin S y \<noteq> Some tx"
  shows "(x,y) \<notin> happensBefore S"
proof -
  obtain tt :: "(callId \<Rightarrow> txId option) \<Rightarrow> callId \<Rightarrow> txId" where
    "\<forall>x0 x1. (\<exists>v2. x0 x1 \<triangleq> v2) = x0 x1 \<triangleq> tt x0 x1"
    by moura
  then have "\<forall>c f. c \<notin> dom f \<or> f c \<triangleq> tt f c"
    by blast
  then have "(x, y) \<notin> happensBefore S \<or> y \<notin> dom (callOrigin S)"
    by (metis (no_types) assms(3) assms(4) assms(5) local.wf option.inject txStatus.distinct(1) wellFormed_currentTx_unique_h(2) wellFormed_state_transaction_consistent(4))
  then show ?thesis
    by (meson domIff local.wf wellFormed_callOrigin_dom3 wellFormed_happensBefore_calls_r)
qed

lemma downwardsClosure_subset2:
  "x \<in> S \<down> R \<Longrightarrow> x \<in> S \<union> fst ` R"
  by (meson downwardsClosure_subset subsetCE)

text \<open>
 There can be no action on a invocId after a fail or return:
 (except for invariant checks)
\<close>
lemma nothing_after_fail_or_return:
  assumes steps: "initialState program ~~ tr \<leadsto>* S"
    and fail_or_return: "tr!i = (s, ACrash) \<or> tr!i = (s, AReturn res)"
    and i_in_range: "i < length tr"
  shows "\<nexists>j. j>i \<and> j<length tr \<and> get_invoc(tr!j) = s \<and> \<not>is_AInvcheck (get_action (tr!j))"
  using steps fail_or_return i_in_range proof (induct rule: steps_induct)
  case initial
  then show ?case by auto
next
  case (step S' tr a S'')
  show "\<not> (\<exists>j>i. j < length (tr @ [a]) \<and> get_invoc ((tr @ [a]) ! j) = s \<and> \<not> is_AInvcheck (get_action ((tr @ [a]) ! j)))"
  proof (rule ccontr, auto)
    fix j
    assume a1: "j < Suc (length tr)"
      and a2: "i < j"
      and a3: "s = get_invoc ((tr @ [a]) ! j)"
      and a4: "\<not> is_AInvcheck (get_action ((tr @ [a]) ! j))"

    have j_def: "j = length tr"
    proof (rule ccontr)
      assume "j \<noteq> length tr"
      then have "j < length tr" using a1 by simp
      then have "s \<noteq> get_invoc ((tr @ [a]) ! j)"
        by (metis a2 a4 length_append_singleton less_Suc_eq nth_append order.asym step.IH step.prems(1) step.prems(2))
      with a3 show False by simp
    qed

    obtain a_op where a_def: "a = (s, a_op)" using j_def a3
      by (metis nth_append_length prod.collapse)

    from \<open>(tr @ [a]) ! i = (s, ACrash) \<or> (tr @ [a]) ! i = (s, AReturn res)\<close>
    have no_ls: "localState S' s = None"
      and op: "invocOp S' s \<noteq> None"
       apply (metis a2 everything_starts_with_an_invocation j_def nth_append step.steps)
      by (metis a2 everything_starts_with_an_invocation j_def nth_append step.prems(1) step.steps)

    have fst_a: "get_invoc a = s" using a_def by simp

    from \<open>S' ~~ a \<leadsto> S''\<close> a_def
    have "S' ~~ (s, a_op) \<leadsto> S''" by simp

    then show False
      apply (rule step.cases)
              apply (auto simp add: no_ls a3 op j_def)
              apply (auto simp add: fst_a no_ls op)
      using a4 a_def is_AInvcheck_def j_def by auto
  qed
qed

text \<open>
 We have visible calls iff we have some local state.
\<close>
lemma visibleCalls_iff_localState:
  assumes steps: "initialState program ~~ tr \<leadsto>* S"
  shows "localState S s = None \<longleftrightarrow> visibleCalls S s = None"
  using steps
proof (induct rule: steps_induct)
  case initial
  then show ?case
    by (simp add: initialState_def)
next
  case (step S' tr a S'')
  from \<open>S' ~~ a \<leadsto> S''\<close>
  show ?case
    apply (rule step.cases)
    using step.IH  by (auto simp add: step)
qed

lemma i_callOriginI_notI1:
  assumes "state_wellFormed S_pre"
    and "invocOp S_pre i = None"
  shows "i_callOriginI S_pre c \<noteq> Some i"
  by (simp add: assms(1) assms(2) i_callOriginI_h_def option.case_eq_if wf_no_invocation_no_origin)

lemma i_callOriginI_notI2:
  assumes "state_wellFormed S_pre"
    and "i_callOriginI S_pre c = Some i"
  shows "invocOp S_pre i \<noteq> None"
  using assms(1) assms(2) i_callOriginI_notI1 by blast

text \<open>
Updating the invocId happens-before in the first transaction of an invocId.

\<close>
lemma invocation_happensBeforeH_update:
  assumes  Orig'_def: "\<And>c. Orig' c = (case Orig c of Some i \<Rightarrow> Some i | None \<Rightarrow> if c\<in>set cs then Some i else None)"
    and cs_no_orig: "\<And>c. c \<in> set cs \<Longrightarrow> Orig c = None"
    and cs_notin_vis: "\<And>c. c \<in> set cs \<Longrightarrow> c \<notin> vis"
    and cs_notin_hb1: "\<And>c x. c \<in> set cs \<Longrightarrow> (x,c) \<notin> Hb"
    and cs_notin_hb2: "\<And>c x. c \<in> set cs \<Longrightarrow> (c,x) \<notin> Hb"
    and invoc_fresh: "\<And>c. Orig c \<noteq> Some i"
    and cs_nonempty: "cs \<noteq> []"
  shows
    "invocation_happensBeforeH Orig' (updateHb Hb vis cs)
   = invocation_happensBeforeH Orig Hb \<union> {i'. (\<forall>c. Orig c \<triangleq> i' \<longrightarrow> c \<in> vis) \<and> (\<exists>c. Orig c \<triangleq> i') }  \<times>  {i} "
  using invoc_fresh  apply (auto simp add: invocation_happensBeforeH_def  in_img_simp updateHb_cases)
                apply (auto simp add: Orig'_def cs_notin_hb1  cs_notin_hb2 cs_notin_vis cs_no_orig  split: option.splits if_splits)
  using cs_no_orig in_sequence_in2 apply fastforce
  using cs_no_orig in_sequence_in1 apply fastforce
        apply (metis cs_no_orig in_sequence_in2 option.simps(3))
       apply (metis cs_no_orig in_sequence_in2 option.distinct(1))
  using cs_no_orig in_sequence_in2 apply fastforce
     apply (metis cs_no_orig option.distinct(1) option.sel)
    apply (metis cs_no_orig option.distinct(1) option.sel)
  using cs_notin_vis option.simps(3) apply fastforce
  using cs_nonempty last_in_set by blast

lemma state_wellFormed_txStatus_callOrigin:
  assumes "state_wellFormed S"
and "callOrigin S c \<triangleq> tx"
shows "txStatus S tx \<noteq> None"
  using assms proof (induct rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step S a S')
  thus ?case
    by (auto simp add: step.simps inTransaction_localState split: if_splits dest:  wellFormed_currentTx_unique_h(2) )
qed

lemma state_wellFormed_txStatus_txOrigin:
  assumes "state_wellFormed S"
and "txOrigin S tx \<triangleq> i"
shows "txStatus S tx \<noteq> None"
  using assms proof (induct rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step S a S')
  thus ?case
    by (auto simp add: step.simps inTransaction_localState split: if_splits dest:  wellFormed_currentTx_unique_h(2) )
qed

lemma state_wellFormed_current_transaction_origin:
  assumes "state_wellFormed S"
and "currentTx S i \<triangleq> tx"
shows "txOrigin S tx \<triangleq> i"
  using assms proof (induct rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step S a S')
  thus ?case
    by (auto simp add: step.simps  split: if_splits dest: state_wellFormed_txStatus_txOrigin)

qed

lemma state_wellFormed_ls_visibleCalls_callOrigin:
  assumes "state_wellFormed S"
and "callOrigin S c \<triangleq> tx"
and "txOrigin S tx \<triangleq> i"
and "visibleCalls S i \<triangleq> vis"
  shows "c \<in> vis"
  using assms proof (induct  arbitrary: vis rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step S a S' vis')
  thus ?case
    by (auto simp add: step.simps inTransaction_localState chooseSnapshot_def state_wellFormed_current_transaction_origin  split: if_splits
          dest: wf_no_txStatus_origin_for_nothing  wf_no_invocation_no_origin )

qed

text_raw \<open>\DefineSnippet{state_wellFormed_same_invocation_sequential}{\<close>
lemma state_wellFormed_same_invocation_sequential:
  assumes "state_wellFormed S"
    and "callOrigin S c1 \<triangleq> tx1"
    and "txOrigin S tx1 \<triangleq> i"
    and "callOrigin S c2 \<triangleq> tx2"
    and "txOrigin S tx2 \<triangleq> i"
    and "c1 \<noteq> c2"
shows "(c1,c2)\<in>happensBefore S \<or> (c2,c1)\<in>happensBefore S"
text_raw \<open>}%EndSnippet\<close>
 using assms proof (induct  arbitrary:  rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step t a s)
  then show ?case
    using state_wellFormed_txStatus_callOrigin[OF \<open>state_wellFormed t\<close>]
          wf_no_txStatus_origin_for_nothing[OF \<open>state_wellFormed t\<close>]
          state_wellFormed_current_transaction_origin[OF \<open>state_wellFormed t\<close>]
          state_wellFormed_ls_visibleCalls_callOrigin[OF \<open>state_wellFormed t\<close>]
    by  (auto simp add: step.simps split: if_splits)
qed

text_raw \<open>\DefineSnippet{state_wellFormed_vis_subset_calls}{\<close>
lemma state_wellFormed_vis_subset_calls:
  assumes "state_wellFormed S"
    and "visibleCalls S i \<triangleq> vis"
    and "c \<in> vis"
shows "c \<in> dom (calls S)"
text_raw \<open>}%EndSnippet\<close>
  by (meson assms subset_h1 wellFormed_visibleCallsSubsetCalls_h(2))

text_raw \<open>\DefineSnippet{state_wellFormed_hb_antisym}{\<close>
lemma state_wellFormed_hb_antisym:
  assumes "state_wellFormed S"
  assumes "(x,y) \<in> happensBefore S"
  shows "(y,x) \<notin> happensBefore S"
  text_raw \<open>}%EndSnippet\<close>
  by (meson assms happensBefore_irrefl happensBefore_transitive irrefl_def transE)

text_raw \<open>\DefineSnippet{state_wellFormed_hb_antisym2}{\<close>
lemma state_wellFormed_hb_antisym2:
  assumes "state_wellFormed S"
  shows "antisym (happensBefore S)"
  text_raw \<open>}%EndSnippet\<close>
using antisym_def assms state_wellFormed_hb_antisym by auto

text_raw \<open>\DefineSnippet{state_wellFormed_transactionOrigin_callOrigin}{\<close>
lemma state_wellFormed_transactionOrigin_callOrigin:
  assumes "state_wellFormed S"
    and "txOrigin S tx = None"
  shows "callOrigin S c \<noteq> Some tx"
text_raw \<open>}%EndSnippet\<close>
  using assms state_wellFormed_txStatus_callOrigin wf_txOrigin_and_status by blast

text_raw \<open>\DefineSnippet{wf_transaction_consistent_l}{\<close>
lemma wf_transaction_consistent_l:
  assumes "state_wellFormed S"
    and "callOrigin S y1 = callOrigin S y2"
    and "callOrigin S x \<noteq> callOrigin S y1"
    and "(y1, x)\<in>happensBefore S"
  shows "(y2, x)\<in>happensBefore S"
text_raw \<open>}%EndSnippet\<close>
  by (metis assms wellFormed_state_transaction_consistent(3))

text_raw \<open>\DefineSnippet{wf_transaction_consistent_r}{\<close>
lemma wf_transaction_consistent_r:
  assumes "state_wellFormed S"
    and "callOrigin S y1 = callOrigin S y2"
    and "callOrigin S x \<noteq> callOrigin S y1"
    and "(x, y1)\<in>happensBefore S"
  shows "(x, y2)\<in>happensBefore S"
text_raw \<open>}%EndSnippet\<close>
 by (metis assms wellFormed_state_transaction_consistent(3))

lemma growth_callOrigin:
  assumes "state_monotonicGrowth i S S'"
    and "callOrigin S c \<triangleq> tx"
  shows "callOrigin S' c \<triangleq> tx"
  using assms(1) assms(2) state_monotonicGrowth_callOrigin by blast

end


(*
 * Copyright 2019, Data61
 *
 * 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(DATA61_BSD)
 *)

theory Guess_ExI
imports
  Eisbach_Methods
  Apply_Debug
begin

(*
This file contains the experimental methods guess_exI and guess_spec. Each, as the name suggests,
attempts to guess an instantiation for their respective rules. It does so by looking
for a matching premise for the quantifying binder, checking that
this could be the only match for safety.
*)

method abs_used for P = (match (P) in "\<lambda>s. ?P" \<Rightarrow> \<open>fail\<close> \<bar> _ \<Rightarrow> \<open>-\<close>)

method in_conj for P Q = (
      match (Q) in "P" \<Rightarrow> \<open>-\<close>
    | match (Q) in "\<lambda>y. A y \<and> B y"  for A B  \<Rightarrow>
            \<open> match (A) in "(Q' :: 'b)" for Q' \<Rightarrow> \<open>match (B) in "(Q'' :: 'b)"  for Q'' \<Rightarrow>
             \<open> in_conj P Q' | in_conj P Q''\<close>\<close>\<close>
    )

method guess_exI =
    (require_determ \<open>(match conclusion in "\<exists>x. Q x" for Q \<Rightarrow>
                            \<open>match premises in "P y" for P y \<Rightarrow>
                             \<open>abs_used P, in_conj P Q, rule exI[where x=y]\<close>\<close>)\<close>)

lemma fun_uncurry:
  "(P \<longrightarrow> Q \<longrightarrow> R) \<longleftrightarrow> (P \<and> Q) \<longrightarrow> R"
  by auto

method guess_spec_inner for P uses I =
    ((match I in "\<forall>x. C x \<longrightarrow> _ x" for C \<Rightarrow> \<open>in_conj P C\<close> ))

method guess_spec =
    (require_determ \<open>(match premises in I:"\<forall>x. _ x \<longrightarrow> _ x" \<Rightarrow>
                            \<open>match premises in "P y" for P y \<Rightarrow>
                            \<open>abs_used P, guess_spec_inner P I:I[simplified fun_uncurry],
                                         insert I, drule spec[where x=y]\<close>\<close>)\<close>)

text \<open>Tests and examples\<close>
experiment begin

 lemma
    assumes Q: "Q x"
    shows  "P x \<Longrightarrow> \<forall>x. Q x \<longrightarrow> P x \<longrightarrow> R  \<Longrightarrow> R"
    by (guess_spec, blast intro: Q)

  (* Conflicting premises are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; P y \<rbrakk> \<Longrightarrow>  \<forall>x. Q x \<longrightarrow> P x \<longrightarrow> R \<Longrightarrow> R"
    apply (fails \<open>guess_spec\<close>)
    by (blast intro: Q)

  (* Conflicts between different conjuncts are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<forall>x. Q x \<longrightarrow> P x \<longrightarrow> R \<Longrightarrow> R"
    apply (fails \<open>guess_spec\<close>)
    by (blast intro: Q)
end

text \<open>Tests and examples\<close>
experiment begin
  lemma "P x \<Longrightarrow> \<exists>x. P x"
    by guess_exI

  lemma
    assumes Q: "Q x"
    shows "P x \<Longrightarrow> \<exists>x. Q x \<and> P x"
    apply guess_exI
    by (blast intro: Q)

  (* Conflicting premises are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; P y \<rbrakk> \<Longrightarrow> \<exists>x. Q x \<and> P x"
    apply (fails \<open>guess_exI\<close>)
    by (blast intro: Q)

  (* Conflicts between different conjuncts are checked *)
  lemma
    assumes Q: "Q x"
    shows "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<exists>x. Q x \<and> P x"
    apply (fails \<open>guess_exI\<close>)
    by (blast intro: Q)
end

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 ExpandAll (* FIXME: bitrotted *)
imports "~~/src/HOL/Main"
begin

lemma expand_forall:
  "\<lbrakk> \<And>x. f (g x) = h x; (\<forall>x. f x) = P; surj g \<rbrakk> \<Longrightarrow> (\<forall>x. h x) = P"
  apply (simp add: surj_def)
  apply metis
  done

lemma expand_exists:
  "\<lbrakk> \<And>x. f (g x) = h x; (\<exists>x. f x) = P; surj g \<rbrakk> \<Longrightarrow> (\<exists>x. h x) = P"
  apply (simp add: surj_def)
  apply metis
  done

lemma expand_one_split:
  "\<lbrakk> \<And>a. (\<forall>b. P a b) = Q a \<rbrakk> \<Longrightarrow> (\<forall>v. (\<lambda>(a, b). P a b) v) = (\<forall>a. Q a)"
  "\<lbrakk> \<And>a. (\<exists>b. P a b) = Q a \<rbrakk> \<Longrightarrow> (\<exists>v. (\<lambda>(a, b). P a b) v) = (\<exists>a. Q a)"
  by simp+

ML {*
(* given patterns, e.g. fst, snd, replace
  \<forall>x. P (fst x) (snd x) with \<forall>x y. P x y

  more useful for things that aren't actually tuples,
  e.g. replace \<forall>xs. P (xs ! 0) (xs ! 2) with \<forall>x y. P x y

  pats here is a function for finding such pats

  ditto \<exists>x. P (fst x) (snd x)
*)

fun lambda_tuple [x] body =
      lambda x body
  | lambda_tuple (x::xs) body =
      HOLogic.mk_split (lambda x (lambda_tuple xs body))
  | lambda_tuple [] body =
      raise TERM ("lambda_tuple: empty", [body])

fun expand_forall_pats ctxt pats tac t = let
    val (T, bdy, thm) = case t of
        (Const (@{const_name All}, T) $ bdy) => (T, bdy, @{thm expand_forall})
      | (Const (@{const_name Ex}, T) $ bdy) => (T, bdy, @{thm expand_exists})
      | _ => raise TERM ("expand_forall_pats: not All or Ex", [t])

    val thy = Proof_Context.theory_of ctxt

    val x = Variable.variant_frees ctxt [bdy]
        [("x", domain_type (domain_type T))]
      |> the_single |> Free

    val bdy_x = betapply (bdy, x)
    val pat_xs = pats x bdy_x |> sort_distinct Term_Ord.fast_term_ord

    val ys = map (fn pat_x => ("y", fastype_of pat_x)) pat_xs
     |> Variable.variant_frees ctxt [bdy_x] |> map Free

    val f = Pattern.rewrite_term thy (pat_xs ~~ ys) [] bdy_x
      |> tap (fn f => exists_subterm (curry (op =) x) f
      andalso raise TERM ("expand_forall_pats: not all converted",
          [x] @ pat_xs @ ys))
      |> lambda_tuple ys

    val g = lambda x (HOLogic.mk_tuple pat_xs)

    val numsplits = length pat_xs - 1

  in cterm_instantiate
    [(@{cpat "?f\<Colon>?'b \<Rightarrow> bool"}, Thm.cterm_of ctxt f),
        (@{cpat "?g\<Colon>?'a \<Rightarrow> ?'b"}, Thm.cterm_of ctxt g),
        (@{cpat "?h\<Colon>?'a \<Rightarrow> bool"}, Thm.cterm_of ctxt bdy)]
    thm
    |> EVERY (
        replicate numsplits (rtac @{thm trans[OF split_conv]} 1)
      @ [rtac @{thm refl} 1]
      @ replicate numsplits (resolve_tac ctxt @{thms expand_one_split} 1)
      @ [rtac @{thm refl} 1, tac pat_xs])
    |> Seq.hd
  end

fun mk_expand_forall_simproc s T pats tac thy
  = let
    val opT = (T --> HOLogic.boolT) --> HOLogic.boolT
    val P = Free ("P", T --> HOLogic.boolT)
  in Simplifier.simproc_global_i thy s
      [Const (@{const_name All}, opT) $ P, Const (@{const_name Ex}, opT) $ P]
      (fn ctxt  => (try (expand_forall_pats ctxt pats (tac ctxt) #> mk_meta_eq)))
  end
*}

ML {*
fun get_nths xs (t as (Const (@{const_name nth}, _) $ ys $ _))
    = if xs aconv ys then [t] else []
  | get_nths xs (t as (Const (@{const_name hd}, _) $ ys))
    = if xs aconv ys then [t] else []
  | get_nths xs (f $ x) = get_nths xs f @ get_nths xs x
  | get_nths xs (Abs (_, _, t)) = get_nths xs t
  | get_nths _ _ = []
*}

lemma surj_via_mapI:
  "surj (\<lambda>g. f (map g [0 ..< n])) \<Longrightarrow> surj (\<lambda>xs. f xs)"
  by (auto simp add: surj_def)

lemma surj_tup_apply_eq:
  "surj (\<lambda>f. (f x, g f)) = (\<forall>v. surj (\<lambda>f. g (f (x := v))))"
  apply (simp add: surj_def)
  apply (rule arg_cong[where f=All, OF ext])+
  apply safe
   apply (metis fun_upd_triv)
  apply (rule_tac x="f (x := y)" for f y in exI, fastforce)
  done

lemma surj_apply:
  "surj (\<lambda>f. f x)"
  by auto

lemma hd_map:
  "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"
  by (clarsimp simp: neq_Nil_conv)

ML {*
fun inst_surj_via_mapI ctxt nths = let
    fun get_nth (f $ (@{term Suc} $ n))
      = get_nth (f $ n) + 1
      | get_nth (Const (@{const_name nth}, _) $ _ $ n)
      = HOLogic.dest_number n |> snd
      | get_nth (Const (@{const_name hd}, _) $ _) = 0
      | get_nth t = raise TERM ("get_nth", [t])
    val max_n = map get_nth nths |> foldr1 (uncurry Integer.max)
    val n = HOLogic.mk_number @{typ nat} (max_n + 1)
      |> Thm.cterm_of ctxt
    val t = cterm_instantiate [(@{cpat "?n\<Colon>nat"}, n)] @{thm surj_via_mapI}
    val ss = put_simpset (simpset_of @{context}) ctxt addsimps @{thms surj_tup_apply_eq surj_apply hd_map}
            (* FIXME: should build up right simpset instead of taking the current one *)
  in rtac t 1 THEN simp_tac ss 1 end
*}

ML {*
val t = expand_forall_pats @{context} get_nths
  (inst_surj_via_mapI @{context})
  @{term "\<forall>xs. xs ! 1 + xs ! 3 + xs ! 42 + hd xs < (12 :: nat)"}
*}

ML {*
val expand_forall_nths_simproc
  = mk_expand_forall_simproc "expand_forall_nths" @{typ "'a list"}
    get_nths inst_surj_via_mapI @{theory}
*}

lemma test:
  "(\<forall>xs. xs ! Suc 0 = 1 \<and> xs ! 2 = 3 \<longrightarrow> P (xs ! Suc 0 + xs ! 2)) = P (1 + 3)
      \<and> (\<exists>xs. xs ! 3 = xs ! 4)"
  apply (tactic {* simp_tac (put_simpset HOL_basic_ss @{context} addsimprocs [expand_forall_nths_simproc]) 1 *})
  apply simp
  done

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedSet, implemented iterators, min, max, to_sorted_list

*)

section \<open>\isaheader{Set Implementation by Red-Black-Tree}\<close>
theory RBTSetImpl
imports
  "../spec/SetSpec"
  RBTMapImpl
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw \<open>\label{thy:RBTSetImpl}\<close>
(*@impl Set
  @type ('a::linorder) rs
  @abbrv rs,r
  Sets over linearly ordered elements implemented by red-black trees.
*)

subsection "Definitions"
type_synonym
  'a rs = "('a::linorder,unit) rm"

setup Locale_Code.open_block
interpretation rs_sbm: OSetByOMap rm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition rs_ops :: "('x::linorder,'x rs) oset_ops"
  where [icf_rec_def]: "rs_ops \<equiv> rs_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation rs: StdOSetDefs rs_ops .
interpretation rs: StdOSet rs_ops
  unfolding rs_ops_def
  by (rule rs_sbm.obasic.dflt_oops_impl)

interpretation rs: StdSet_no_invar rs_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "rs"\<close>

lemmas rbt_it_to_it_map_code_unfold[code_unfold] =
  it_to_it_map_fold'[OF pi_rm]
  it_to_it_map_fold'[OF pi_rm_rev]

lemma pi_rs[proper_it]:
  "proper_it' rs.iteratei rs.iteratei"
  "proper_it' rs.iterateoi rs.iterateoi"
  "proper_it' rs.rev_iterateoi rs.rev_iterateoi"
  unfolding rs.iteratei_def[abs_def] rs.iterateoi_def[abs_def]
    rs.rev_iterateoi_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation
  pi_rs: proper_it_loc rs.iteratei rs.iteratei +
  pi_rs_o: proper_it_loc rs.iterateoi rs.iterateoi +
  pi_rs_ro: proper_it_loc rs.rev_iterateoi rs.rev_iterateoi
  by unfold_locales (rule pi_rs)+

definition "rs_image_filter \<equiv> undefined"
definition "rs_image \<equiv> undefined"

lemma rs_ops_unfold[code_unfold]:
    "set_op_\<alpha> rs_ops = rs.\<alpha>"
    "set_op_invar rs_ops = rs.invar"
    "set_op_empty rs_ops = rs.empty"
    "set_op_sng rs_ops = rs.sng"
    "set_op_memb rs_ops = rs.memb"
    "set_op_ins rs_ops = rs.ins"
    "set_op_ins_dj rs_ops = rs.ins_dj"
    "set_op_delete rs_ops = rs.delete"
    "set_op_isEmpty rs_ops = rs.isEmpty"
    "set_op_isSng rs_ops = rs.isSng"
    "set_op_ball rs_ops = rs.ball"
    "set_op_bex rs_ops = rs.bex"
    "set_op_size rs_ops = rs.size"
    "set_op_size_abort rs_ops = rs.size_abort"
    "set_op_union rs_ops = rs.union"
    "set_op_union_dj rs_ops = rs.union_dj"
    "set_op_diff rs_ops = rs.diff"
    "set_op_filter rs_ops = rs.filter"
    "set_op_inter rs_ops = rs.inter"
    "set_op_subset rs_ops = rs.subset"
    "set_op_equal rs_ops = rs.equal"
    "set_op_disjoint rs_ops = rs.disjoint"
    "set_op_disjoint_witness rs_ops = rs.disjoint_witness"
    "set_op_sel rs_ops = rs.sel"
    "set_op_to_list rs_ops = rs.to_list"
    "set_op_from_list rs_ops = rs.from_list"
    "set_op_min rs_ops = rs.min"
    "set_op_max rs_ops = rs.max"
    by (auto simp add: rs_ops_def)

definition test_codegen where "test_codegen \<equiv> (
  rs.empty,
  rs.memb,
  rs.ins,
  rs.delete,
  rs.list_it,
  rs.sng,
  rs.isEmpty,
  rs.isSng,
  rs.ball,
  rs.bex,
  rs.size,
  rs.size_abort,
  rs.union,
  rs.union_dj,
  rs.diff,
  rs.filter,
  rs.inter,
  rs.subset,
  rs.equal,
  rs.disjoint,
  rs.disjoint_witness,
  rs.sel,
  rs.to_list,
  rs.from_list,

  rs.ordered_list_it,
  rs.rev_list_it,
  rs.min,
  rs.max,
  rs.to_sorted_list,
  rs.to_rev_list
)"

export_code test_codegen checking SML

end


(*  Title:       Integration of IsaFoR Terms and the Knuth-Bendix Order
    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>Integration of \textsf{IsaFoR} Terms and the Knuth--Bendix Order\<close>

text \<open>
This theory implements the abstract interface for atoms and substitutions using
the \textsf{IsaFoR} library.
\<close>

theory IsaFoR_Term
  imports
    Deriving.Derive
    Ordered_Resolution_Prover.Abstract_Substitution
    First_Order_Terms.Unification
    First_Order_Terms.Subsumption
    "HOL-Cardinals.Wellorder_Extension"
    Open_Induction.Restricted_Predicates
    Knuth_Bendix_Order.KBO
begin

hide_const (open) mgu

abbreviation subst_apply_literal ::
  "('f, 'v) term literal \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term literal" (infixl "\<cdot>lit" 60) where
  "L \<cdot>lit \<sigma> \<equiv> map_literal (\<lambda>A. A \<cdot> \<sigma>) L"

definition subst_apply_clause ::
  "('f, 'v) term clause \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term clause" (infixl "\<cdot>cls" 60) where
  "C \<cdot>cls \<sigma> = image_mset (\<lambda>L. L \<cdot>lit \<sigma>) C"

abbreviation vars_lit :: "('f, 'v) term literal \<Rightarrow> 'v set" where
  "vars_lit L \<equiv> vars_term (atm_of L)"

definition vars_clause :: "('f, 'v) term clause \<Rightarrow> 'v set" where
  "vars_clause C = Union (set_mset (image_mset vars_lit C))"

definition vars_clause_list :: "('f, 'v) term clause list \<Rightarrow> 'v set" where
  "vars_clause_list Cs = Union (vars_clause ` set Cs) "

definition vars_partitioned :: "('f,'v) term clause list \<Rightarrow> bool" where
  "vars_partitioned Cs \<longleftrightarrow>
   (\<forall>i < length Cs. \<forall>j < length Cs. i \<noteq> j \<longrightarrow> (vars_clause (Cs ! i) \<inter> vars_clause (Cs ! j)) = {})"

lemma vars_clause_mono: "S \<subseteq># C \<Longrightarrow> vars_clause S \<subseteq> vars_clause C"
  unfolding vars_clause_def by auto

interpretation substitution_ops "(\<cdot>)" Var "(\<circ>\<^sub>s)" .

lemma is_ground_atm_is_ground_on_var:
  assumes "is_ground_atm (A \<cdot> \<sigma>)" and "v \<in> vars_term A"
  shows "is_ground_atm (\<sigma> v)"
using assms proof (induction A)
  case (Var x)
  then show ?case by auto
next
  case (Fun f ts)
  then show ?case unfolding is_ground_atm_def
    by auto
qed

lemma is_ground_lit_is_ground_on_var:
  assumes ground_lit: "is_ground_lit (subst_lit L \<sigma>)" and v_in_L: "v \<in> vars_lit L"
  shows "is_ground_atm (\<sigma> v)"
proof -
  let ?A = "atm_of L"
  from v_in_L have A_p: "v \<in> vars_term ?A"
    by auto
  then have "is_ground_atm (?A \<cdot> \<sigma>)"
    using ground_lit unfolding is_ground_lit_def by auto
  then show ?thesis
    using A_p is_ground_atm_is_ground_on_var by metis
qed

lemma is_ground_cls_is_ground_on_var:
  assumes
    ground_clause: "is_ground_cls (subst_cls C \<sigma>)" and
    v_in_C: "v \<in> vars_clause C"
  shows "is_ground_atm (\<sigma> v)"
proof -
  from v_in_C obtain L where L_p: "L \<in># C" "v \<in> vars_lit L"
    unfolding vars_clause_def by auto
  then have "is_ground_lit (subst_lit L \<sigma>)"
    using ground_clause unfolding is_ground_cls_def subst_cls_def by auto
  then show ?thesis
    using L_p is_ground_lit_is_ground_on_var by metis
qed

lemma is_ground_cls_list_is_ground_on_var:
  assumes ground_list: "is_ground_cls_list (subst_cls_list Cs \<sigma>)"
    and v_in_Cs: "v \<in> vars_clause_list Cs"
  shows "is_ground_atm (\<sigma> v)"
proof -
  from v_in_Cs obtain C where C_p: "C \<in> set Cs" "v \<in> vars_clause C"
    unfolding vars_clause_list_def by auto
  then have "is_ground_cls (subst_cls C \<sigma>)"
    using ground_list unfolding is_ground_cls_list_def subst_cls_list_def by auto
  then show ?thesis
    using C_p is_ground_cls_is_ground_on_var by metis
qed

lemma same_on_vars_lit:
  assumes "\<forall>v \<in> vars_lit L. \<sigma> v = \<tau> v"
  shows "subst_lit L \<sigma> = subst_lit L \<tau>"
  using assms
proof (induction L)
  case (Pos x)
  then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
    using term_subst_eq by metis+
  then show ?case
    unfolding subst_lit_def using Pos by auto
next
  case (Neg x)
  then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
    using term_subst_eq by metis+
  then show ?case
    unfolding subst_lit_def using Neg by auto
qed

lemma in_list_of_mset_in_S:
  assumes "i < length (list_of_mset S)"
  shows "list_of_mset S ! i \<in># S"
proof -
  from assms have "list_of_mset S ! i \<in> set (list_of_mset S)"
    by auto
  then have "list_of_mset S ! i \<in># mset (list_of_mset S)"
    by (meson in_multiset_in_set)
  then show ?thesis
    by auto
qed

lemma same_on_vars_clause:
  assumes "\<forall>v \<in> vars_clause S. \<sigma> v = \<tau> v"
  shows "subst_cls S \<sigma> = subst_cls S \<tau>"
  by (smt assms image_eqI image_mset_cong2 mem_simps(9) same_on_vars_lit set_image_mset
      subst_cls_def vars_clause_def)

interpretation substitution "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)"
proof unfold_locales
  show "\<And>A. A \<cdot> Var = A"
    by auto
next
  show "\<And>A \<tau> \<sigma>. A \<cdot> \<tau> \<circ>\<^sub>s \<sigma> = A \<cdot> \<tau> \<cdot> \<sigma>"
    by auto
next
  show "\<And>\<sigma> \<tau>. (\<And>A. A \<cdot> \<sigma> = A \<cdot> \<tau>) \<Longrightarrow> \<sigma> = \<tau>"
    by (simp add: subst_term_eqI)
next
  fix C :: "('f, nat) term clause"
  fix \<sigma>
  assume "is_ground_cls (subst_cls C \<sigma>)"
  then have ground_atms_\<sigma>: "\<And>v. v \<in> vars_clause C \<Longrightarrow> is_ground_atm (\<sigma> v)"
    by (meson is_ground_cls_is_ground_on_var)

  define some_ground_trm :: "('f, nat) term" where "some_ground_trm = (Fun undefined [])"
  have ground_trm: "is_ground_atm some_ground_trm"
    unfolding is_ground_atm_def some_ground_trm_def by auto
  define \<tau> where "\<tau> = (\<lambda>v. if v \<in> vars_clause C then \<sigma> v else some_ground_trm)"
  then have \<tau>_\<sigma>: "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
    unfolding \<tau>_def by auto

  have all_ground_\<tau>: "is_ground_atm (\<tau> v)" for v
  proof (cases "v \<in> vars_clause C")
    case True
    then show ?thesis
      using ground_atms_\<sigma> \<tau>_\<sigma> by auto
  next
    case False
    then show ?thesis
      unfolding \<tau>_def using ground_trm by auto
  qed
  have "is_ground_subst \<tau>"
    unfolding is_ground_subst_def
  proof
    fix A
    show "is_ground_atm (subst_atm_abbrev A \<tau>)"
    proof (induction A)
      case (Var v)
      then show ?case using all_ground_\<tau> by auto
    next
      case (Fun f As)
      then show ?case using all_ground_\<tau>
        by (simp add: is_ground_atm_def)
    qed
  qed
  moreover have "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
    using \<tau>_\<sigma> unfolding vars_clause_list_def
    by blast
  then have "subst_cls C \<sigma> = subst_cls C \<tau>"
    using same_on_vars_clause by auto
  ultimately show "\<exists>\<tau>. is_ground_subst \<tau> \<and> subst_cls C \<tau> = subst_cls C \<sigma>"
    by auto
next
  show "wfP (strictly_generalizes_atm :: ('f, 'v) term \<Rightarrow> _ \<Rightarrow> _)"
    unfolding wfP_def
    by (rule wf_subset[OF wf_subsumes])
      (auto simp: strictly_generalizes_atm_def generalizes_atm_def term_subsumable.subsumes_def
        subsumeseq_term.simps)
qed

lemma vars_partitioned_var_disjoint:
  assumes "vars_partitioned Cs"
  shows "var_disjoint Cs"
  unfolding var_disjoint_def
proof (intro allI impI)
  fix \<sigma>s :: \<open>('b \<Rightarrow> ('a, 'b) term) list\<close>
  assume "length \<sigma>s = length Cs"
  with assms[unfolded vars_partitioned_def] Fun_More.fun_merge[of "map vars_clause Cs" "nth \<sigma>s"]
  obtain \<sigma> where
    \<sigma>_p: "\<forall>i < length (map vars_clause Cs). \<forall>x \<in> map vars_clause Cs ! i. \<sigma> x = (\<sigma>s ! i) x"
    by auto
  have "\<forall>i < length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
  proof (rule, rule, rule, rule)
    fix i :: nat and S :: "('a, 'b) term literal multiset"
    assume
      "i < length Cs" and
      "S \<subseteq># Cs ! i"
    then have "\<forall>v \<in> vars_clause S. (\<sigma>s ! i) v = \<sigma> v"
      using vars_clause_mono[of S "Cs ! i"] \<sigma>_p by auto
    then show "subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
      using same_on_vars_clause by auto
  qed
  then show "\<exists>\<tau>. \<forall>i<length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<tau>"
    by auto
qed

lemma vars_in_instance_in_range_term:
  "vars_term (subst_atm_abbrev A \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
  by (induction A) auto

lemma vars_in_instance_in_range_lit: "vars_lit (subst_lit L \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
proof (induction L)
  case (Pos A)
  have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
    using vars_in_instance_in_range_term[of A \<sigma>] by blast
  then show ?case by auto
next
  case (Neg A)
  have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
    using vars_in_instance_in_range_term[of A \<sigma>] by blast
  then show ?case by auto
qed

lemma vars_in_instance_in_range_cls:
  "vars_clause (subst_cls C \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
  unfolding vars_clause_def subst_cls_def using vars_in_instance_in_range_lit[of _ \<sigma>] by auto

primrec renamings_apart :: "('f, nat) term clause list \<Rightarrow> (('f, nat) subst) list" where
  "renamings_apart [] = []"
| "renamings_apart (C # Cs) =
   (let \<sigma>s = renamings_apart Cs in
      (\<lambda>v. Var (v + Max (vars_clause_list (subst_cls_lists Cs \<sigma>s) \<union> {0}) + 1)) # \<sigma>s)"

definition var_map_of_subst :: "('f, nat) subst \<Rightarrow> nat \<Rightarrow> nat" where
  "var_map_of_subst \<sigma> v = the_Var (\<sigma> v)"

lemma len_renamings_apart: "length (renamings_apart Cs) = length Cs"
  by (induction Cs) (auto simp: Let_def)

lemma renamings_apart_is_Var: "\<forall>\<sigma> \<in> set (renamings_apart Cs). \<forall>x. is_Var (\<sigma> x)"
  by (induction Cs) (auto simp: Let_def)

lemma renamings_apart_inj: "\<forall>\<sigma> \<in> set (renamings_apart Cs). inj \<sigma>"
proof (induction Cs)
  case (Cons a Cs)
  then have "inj (\<lambda>v. Var (Suc (v + Max (vars_clause_list
               (subst_cls_lists Cs (renamings_apart Cs)) \<union> {0}))))"
    by (meson add_right_imp_eq injI nat.inject term.inject(1))
  then show ?case
    using Cons by (auto simp: Let_def)
qed auto

lemma finite_vars_clause[simp]: "finite (vars_clause x)"
  unfolding vars_clause_def by auto

lemma finite_vars_clause_list[simp]: "finite (vars_clause_list Cs)"
  unfolding vars_clause_list_def by (induction Cs) auto

lemma Suc_Max_notin_set: "finite X \<Longrightarrow> Suc (v + Max (insert 0 X)) \<notin> X"
  by (metis Max.boundedE Suc_n_not_le_n empty_iff finite.insertI le_add2 vimageE vimageI
      vimage_Suc_insert_0)

lemma vars_partitioned_Nil[simp]: "vars_partitioned []"
  unfolding vars_partitioned_def by auto

lemma subst_cls_lists_Nil[simp]: "subst_cls_lists Cs [] = []"
  unfolding subst_cls_lists_def by auto

lemma vars_clause_hd_partitioned_from_tl:
  assumes "Cs \<noteq>[]"
  shows "vars_clause (hd (subst_cls_lists Cs (renamings_apart Cs)))
    \<inter> vars_clause_list (tl (subst_cls_lists Cs (renamings_apart Cs))) = {}"
  using assms
proof (induction Cs)
  case (Cons C Cs)
  define \<sigma>' :: "nat \<Rightarrow> nat"
    where "\<sigma>' = (\<lambda>v. (Suc (v + Max ((vars_clause_list (subst_cls_lists Cs
                        (renamings_apart Cs))) \<union> {0}))))"
  define \<sigma> :: "nat \<Rightarrow> ('a, nat) term"
    where "\<sigma> = (\<lambda>v. Var (\<sigma>' v))"

  have "vars_clause (subst_cls C \<sigma>) \<subseteq> \<Union> (vars_term ` range \<sigma>)"
    using vars_in_instance_in_range_cls[of C "hd (renamings_apart (C # Cs))"] \<sigma>_def \<sigma>'_def
    by (auto simp: Let_def)
  moreover have "\<Union> (vars_term ` range \<sigma>)
    \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
  proof -
    have "range \<sigma>' \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
      unfolding \<sigma>'_def using Suc_Max_notin_set by auto
    then show ?thesis
      unfolding \<sigma>_def \<sigma>'_def by auto
  qed
  ultimately have "vars_clause (subst_cls C \<sigma>)
     \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
    by auto
  then show ?case
    unfolding \<sigma>_def \<sigma>'_def unfolding subst_cls_lists_def
    by (simp add: Let_def subst_cls_lists_def)
qed auto

lemma vars_partitioned_renamings_apart: "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
proof (induction Cs)
  case (Cons C Cs)
  {
    fix i :: nat and j :: nat
    assume ij:
      "i < Suc (length Cs)"
      "j < i"
    have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
    proof (cases i; cases j)
      fix j' :: nat
      assume i'j':
        "i = 0"
        "j = Suc j'"
      then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
        using ij by auto
    next
      fix i' :: nat
      assume i'j':
        "i = Suc i'"
        "j = 0"
      have disjoin_C_Cs: "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
        vars_clause_list ((subst_cls_lists Cs (renamings_apart Cs))) = {}"
        using vars_clause_hd_partitioned_from_tl[of "C # Cs"]
        by (simp add: Let_def subst_cls_lists_def)
      {
        fix x
        assume asm: "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
        then have "(subst_cls_lists Cs (renamings_apart Cs) ! i')
          \<in> set (subst_cls_lists Cs (renamings_apart Cs))"
          using i'j' ij unfolding subst_cls_lists_def
          by (metis Suc_less_SucD length_map len_renamings_apart length_zip min_less_iff_conj
              nth_mem)
        moreover from asm have
          "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
          using i'j' ij
          unfolding subst_cls_lists_def by simp
        ultimately have "\<exists>D \<in> set (subst_cls_lists Cs (renamings_apart Cs)). x \<in> vars_clause D"
            by auto
      }
      then have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')
        \<subseteq> Union (set (map vars_clause ((subst_cls_lists Cs (renamings_apart Cs)))))"
        by auto
      then have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
        vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') =
        {}" using disjoin_C_Cs unfolding vars_clause_list_def by auto
      moreover
      have "subst_cls_lists Cs (renamings_apart Cs) ! i' =
        subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i"
        using i'j' ij unfolding subst_cls_lists_def by (simp add: Let_def)
      ultimately
      show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
        using i'j' by (simp add: Int_commute)
    next
      fix i' :: nat and j' :: nat
      assume i'j':
        "i = Suc i'"
        "j = Suc j'"
      have "i'<length (subst_cls_lists Cs (renamings_apart Cs))"
        using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
      moreover
      have "j'<length (subst_cls_lists Cs (renamings_apart Cs))"
        using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
      moreover
      have "i' \<noteq> j'"
        using \<open>i = Suc i'\<close> \<open>j = Suc j'\<close> ij by blast
      ultimately
      have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') \<inter>
          vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! j') =
          {}"
        using Cons unfolding vars_partitioned_def by auto
      then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
        unfolding i'j'
        by (simp add: subst_cls_lists_def Let_def)
    next
      assume
        \<open>i = 0\<close> and
        \<open>j = 0\<close>
      then show \<open>vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}\<close> using ij by auto
    qed
  }
  then show ?case
    unfolding vars_partitioned_def
    by (metis (no_types, lifting) Int_commute Suc_lessI len_renamings_apart length_map
        length_nth_simps(2) length_zip min.idem nat.inject not_less_eq subst_cls_lists_def)
qed auto

interpretation substitution_renamings "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)" renamings_apart "Fun undefined"
proof unfold_locales
  fix Cs :: "('f, nat) term clause list"
  show "length (renamings_apart Cs) = length Cs"
    using len_renamings_apart by auto
next
  fix Cs :: "('f, nat) term clause list"
  fix \<rho> ::  "nat \<Rightarrow> ('f, nat) Term.term"
  assume \<rho>_renaming: "\<rho> \<in> set (renamings_apart Cs)"
  {
    have inj_is_renaming:
      "\<And>\<sigma> :: ('f, nat) subst. (\<And>x. is_Var (\<sigma> x)) \<Longrightarrow> inj \<sigma> \<Longrightarrow> is_renaming \<sigma>"
    proof -
      fix \<sigma> :: "('f, nat) subst"
      fix x
      assume is_var_\<sigma>: "\<And>x. is_Var (\<sigma> x)"
      assume inj_\<sigma>: "inj \<sigma>"
      define \<sigma>' where "\<sigma>' = var_map_of_subst \<sigma>"
      have \<sigma>: "\<sigma> = Var \<circ> \<sigma>'"
        unfolding \<sigma>'_def var_map_of_subst_def using is_var_\<sigma> by auto

      from is_var_\<sigma> inj_\<sigma> have "inj \<sigma>'"
        unfolding is_renaming_def unfolding subst_domain_def inj_on_def \<sigma>'_def var_map_of_subst_def
         by (metis term.collapse(1))
      then have "inv \<sigma>' \<circ> \<sigma>' = id"
        using inv_o_cancel[of \<sigma>'] by simp
      then have "Var \<circ> (inv \<sigma>' \<circ> \<sigma>') = Var"
        by simp
      then have "\<forall>x. (Var \<circ> (inv \<sigma>' \<circ> \<sigma>')) x = Var x"
        by metis
      then have "\<forall>x. ((Var \<circ> \<sigma>') \<circ>\<^sub>s (Var \<circ> (inv \<sigma>'))) x = Var x"
        unfolding subst_compose_def by auto
      then have "\<sigma> \<circ>\<^sub>s (Var \<circ> (inv \<sigma>')) = Var"
        using \<sigma> by auto
      then show "is_renaming \<sigma>"
        unfolding is_renaming_def by blast
    qed
    then have "\<forall>\<sigma> \<in> (set (renamings_apart Cs)). is_renaming \<sigma>"
      using renamings_apart_is_Var renamings_apart_inj by blast
  }
  then show "is_renaming \<rho>"
    using \<rho>_renaming by auto
next
  fix Cs :: "('f, nat) term clause list"
  have "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
    using vars_partitioned_renamings_apart by auto
  then show "var_disjoint (subst_cls_lists Cs (renamings_apart Cs))"
    using vars_partitioned_var_disjoint by auto
next
  show "\<And>\<sigma> As Bs. Fun undefined As \<cdot> \<sigma> = Fun undefined Bs \<longleftrightarrow> map (\<lambda>A. A \<cdot> \<sigma>) As = Bs"
    by simp
qed

fun pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
  "pairs (x # y # xs) = (x, y) # pairs (y # xs)" |
  "pairs _ = []"

derive compare "term"
derive compare "literal"

lemma class_linorder_compare: "class.linorder (le_of_comp compare) (lt_of_comp compare)"
  apply standard
      apply (simp_all add: lt_of_comp_def le_of_comp_def split: order.splits)
     apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
    apply (metis comparator_compare comparator_def order.distinct(5))
   apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
  by (metis comparator.sym comparator_compare invert_order.simps(2) order.distinct(5))

context begin
interpretation compare_linorder: linorder
  "le_of_comp compare"
  "lt_of_comp compare"
  by (rule class_linorder_compare)

definition Pairs where
  "Pairs AAA = concat (compare_linorder.sorted_list_of_set
     ((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))"

lemma unifies_all_pairs_iff:
  "(\<forall>p \<in> set (pairs xs). fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>) \<longleftrightarrow> (\<forall>a \<in> set xs. \<forall>b \<in> set xs. a \<cdot> \<sigma> = b \<cdot> \<sigma>)"
proof (induct xs rule: pairs.induct)
  case (1 x y xs)
  then show ?case
    unfolding pairs.simps list.set ball_Un ball_simps simp_thms fst_conv snd_conv by metis
qed simp_all

lemma in_pair_in_set:
  assumes "(A,B) \<in> set ((pairs As))"
  shows "A \<in> set As \<and> B \<in> set As"
  using assms
proof (induction As)
  case (Cons A As)
  note Cons_outer = this
  show ?case
  proof (cases As)
    case Nil
    then show ?thesis
      using Cons_outer by auto
  next
    case (Cons B As')
    then show ?thesis using Cons_outer by auto
  qed
qed auto

lemma in_pairs_sorted_list_of_set_in_set:
  assumes
    "finite AAA"
    "\<forall>AA \<in> AAA. finite AA"
    "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA" and
    "(A :: _ :: compare, B) \<in> set AB_pairs"
  shows "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
proof -
  from assms have "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA"
    by auto
  then obtain AA where
    AA_p: "AA \<in> AAA \<and> (pairs \<circ> compare_linorder.sorted_list_of_set) AA = AB_pairs"
    by auto
  have "(A, B) \<in> set (pairs (compare_linorder.sorted_list_of_set AA))"
    using AA_p[] assms(4) by auto
  then have "A \<in> set (compare_linorder.sorted_list_of_set AA)" and
    "B \<in> set (compare_linorder.sorted_list_of_set AA)"
    using in_pair_in_set[of A] by auto
  then show ?thesis
    using assms(2) AA_p by auto
qed

lemma unifiers_Pairs:
  assumes
    "finite AAA" and
    "\<forall>AA \<in> AAA. finite AA"
  shows "unifiers (set (Pairs AAA)) = {\<sigma>. is_unifiers \<sigma> AAA}"
proof (rule; rule)
  fix \<sigma> :: "('a, 'b) subst"
  assume asm: "\<sigma> \<in> unifiers (set (Pairs AAA))"
  have "\<And>AA. AA \<in> AAA \<Longrightarrow> card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
  proof -
    fix AA :: "('a, 'b) term set"
    assume asm': "AA \<in> AAA"
    then have "\<forall>p \<in> set (pairs (compare_linorder.sorted_list_of_set AA)).
      subst_atm_abbrev (fst p) \<sigma> = subst_atm_abbrev (snd p) \<sigma>"
      using assms asm unfolding Pairs_def by auto
    then have "\<forall>A \<in> AA. \<forall>B \<in> AA. subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
      using assms asm' unfolding unifies_all_pairs_iff
      using compare_linorder.sorted_list_of_set by blast
    then show "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
      by (smt imageE card.empty card_Suc_eq card_mono finite.intros(1) finite_insert le_SucI
           singletonI subsetI)
  qed
  then show "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"
    using assms by (auto simp: is_unifiers_def is_unifier_def subst_atms_def)
next
  fix \<sigma> :: "('a, 'b) subst"
  assume asm: "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"

  {
    fix AB_pairs A B
    assume
      "AB_pairs \<in> set (compare_linorder.sorted_list_of_set
         ((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))" and
      "(A, B) \<in> set AB_pairs"
    then have "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
      using assms by (simp add: in_pairs_sorted_list_of_set_in_set)
    then obtain AA where
     a: "AA \<in> AAA" "A \<in> AA" "B \<in> AA"
      by blast
    from a assms asm have card_AA_\<sigma>: "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
      unfolding is_unifiers_def is_unifier_def subst_atms_def by auto
    have "subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
    proof (cases "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = Suc 0")
      case True
      moreover
      have "subst_atm_abbrev A \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
        using a assms asm card_AA_\<sigma> by auto
      moreover
      have "subst_atm_abbrev B \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
        using a assms asm card_AA_\<sigma> by auto
      ultimately
      show ?thesis
        using a assms asm card_AA_\<sigma> by (metis (no_types, lifting) card_Suc_eq singletonD)
    next
      case False
      then have "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = 0"
        using a assms asm card_AA_\<sigma>
        by arith
      then show ?thesis
        using a assms asm card_AA_\<sigma> by auto
    qed
  }
  then show "\<sigma> \<in> unifiers (set (Pairs AAA))"
    unfolding Pairs_def unifiers_def by auto
qed

end

definition "mgu_sets AAA = map_option subst_of (unify (Pairs AAA) [])"

lemma mgu_sets_is_imgu:
  fixes AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
  assumes fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
  shows "is_imgu \<sigma> AAA"
proof -
  have "Unifiers.is_imgu \<sigma> (set (Pairs AAA))"
    using assms unify_sound unfolding mgu_sets_def by blast
  thus ?thesis
    unfolding Unifiers.is_imgu_def is_imgu_def unifiers_Pairs[OF fin]
    by simp
qed

interpretation mgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" renamings_apart
  "Fun undefined" mgu_sets
proof unfold_locales
  fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
  assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
  thus "is_mgu \<sigma> AAA"
    using mgu_sets_is_imgu by auto
next
  fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
  assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "is_unifiers \<sigma> AAA"
  then have "\<sigma> \<in> unifiers (set (Pairs AAA))"
    unfolding is_mgu_def unifiers_Pairs[OF fin] by auto
  then show "\<exists>\<tau>. mgu_sets AAA = Some \<tau>"
    using unify_complete unfolding mgu_sets_def by blast
qed

interpretation imgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" renamings_apart
  "Fun undefined" mgu_sets
proof unfold_locales
  fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
  assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
  thus "is_imgu \<sigma> AAA"
    by (rule mgu_sets_is_imgu)
qed

derive linorder prod
derive linorder list

text \<open>
This part extends and integrates and the Knuth--Bendix order defined in
\textsf{IsaFoR}.
\<close>

record 'f weights =
  w :: "'f \<times> nat \<Rightarrow> nat"
  w0 :: nat
  pr_strict :: "'f \<times> nat \<Rightarrow> 'f \<times> nat \<Rightarrow> bool"
  least :: "'f \<Rightarrow> bool"
  scf :: "'f \<times> nat \<Rightarrow> nat \<Rightarrow> nat"

class weighted =
  fixes weights :: "'a weights"
  assumes weights_adm:
    "admissible_kbo
       (w weights) (w0 weights) (pr_strict weights) ((pr_strict weights)\<^sup>=\<^sup>=) (least weights) (scf weights)"
  and pr_strict_total: "fi = gj \<or> pr_strict weights fi gj \<or> pr_strict weights gj fi"
  and pr_strict_asymp: "asymp (pr_strict weights)"
  and scf_ok: "i < n \<Longrightarrow> scf weights (f, n) i \<le> 1"

instantiation unit :: weighted begin

definition weights_unit :: "unit weights" where "weights_unit =
  \<lparr>w = Suc \<circ> snd, w0 = 1, pr_strict = \<lambda>(_, n) (_, m). n > m, least = \<lambda>_. True, scf = \<lambda>_ _. 1\<rparr>"

instance
  by (intro_classes, unfold_locales) (auto simp: weights_unit_def SN_iff_wf irreflp_def
      intro: asympI intro!: wf_subset[OF wf_inv_image[OF wf], of _ snd])
end

global_interpretation KBO:
  admissible_kbo
    "w (weights :: 'f :: weighted weights)" "w0 (weights :: 'f :: weighted weights)"
    "pr_strict weights" "((pr_strict weights)\<^sup>=\<^sup>=)" "least weights" "scf weights"
    defines weight = KBO.weight
    and kbo = KBO.kbo
  by (simp add: weights_adm)

lemma kbo_code[code]: "kbo s t =
  (let wt = weight t; ws = weight s in
  if vars_term_ms (KBO.SCF t) \<subseteq># vars_term_ms (KBO.SCF s) \<and> wt \<le> ws
  then
    (if wt < ws then (True, True)
    else
      (case s of
        Var y \<Rightarrow> (False, case t of Var x \<Rightarrow> True | Fun g ts \<Rightarrow> ts = [] \<and> least weights g)
      | Fun f ss \<Rightarrow>
          (case t of
            Var x \<Rightarrow> (True, True)
          | Fun g ts \<Rightarrow>
              if pr_strict weights (f, length ss) (g, length ts) then (True, True)
              else if (f, length ss) = (g, length ts) then lex_ext_unbounded kbo ss ts
              else (False, False))))
  else (False, False))"
  by (subst KBO.kbo.simps) (auto simp: Let_def split: term.splits)

definition "less_kbo s t = fst (kbo t s)"

lemma less_kbo_gtotal: "ground s \<Longrightarrow> ground t \<Longrightarrow> s = t \<or> less_kbo s t \<or> less_kbo t s"
  unfolding less_kbo_def using KBO.S_ground_total by (metis pr_strict_total subset_UNIV)

lemma less_kbo_subst:
  fixes \<sigma> :: "('f :: weighted, 'v) subst"
  shows "less_kbo s t \<Longrightarrow> less_kbo (s \<cdot> \<sigma>) (t \<cdot> \<sigma>)"
  unfolding less_kbo_def by (rule KBO.S_subst)

lemma wfP_less_kbo: "wfP less_kbo"
proof -
  have "SN {(x, y). fst (kbo x y)}"
    using pr_strict_asymp by (fastforce simp: asympI irreflp_def intro!: KBO.S_SN scf_ok)
  then show ?thesis
    unfolding SN_iff_wf wfP_def by (rule wf_subset) (auto simp: less_kbo_def)
qed

instantiation "term" :: (weighted, type) linorder begin

definition "leq_term = (SOME leq. {(s,t). less_kbo s t} \<subseteq> leq \<and> Well_order leq \<and> Field leq = UNIV)"

lemma less_trm_extension: "{(s,t). less_kbo s t} \<subseteq> leq_term"
  unfolding leq_term_def
  by (rule someI2_ex[OF total_well_order_extension[OF wfP_less_kbo[unfolded wfP_def]]]) auto

lemma less_trm_well_order: "well_order leq_term"
  unfolding leq_term_def
  by (rule someI2_ex[OF total_well_order_extension[OF wfP_less_kbo[unfolded wfP_def]]]) auto

definition less_eq_term :: "('a :: weighted, 'b) term \<Rightarrow> _ \<Rightarrow> bool" where
  "less_eq_term = in_rel leq_term"
definition less_term :: "('a :: weighted, 'b) term \<Rightarrow> _ \<Rightarrow> bool" where
  "less_term s t = strict (\<le>) s t"

lemma leq_term_minus_Id: "leq_term - Id = {(x,y). x < y}"
  using less_trm_well_order
  unfolding well_order_on_def linear_order_on_def partial_order_on_def antisym_def less_term_def less_eq_term_def
  by auto

lemma less_term_alt: "(<) = in_rel (leq_term - Id)"
  by (simp add: in_rel_Collect_case_prod_eq leq_term_minus_Id)

instance
proof (standard, goal_cases less_less_eq refl trans antisym total)
  case (less_less_eq x y)
  then show ?case unfolding less_term_def ..
next
case (refl x)
  then show ?case using less_trm_well_order
    unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      less_eq_term_def by auto
next
case (trans x y z)
  then show ?case using less_trm_well_order
    unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def trans_def
      less_eq_term_def by auto
next
  case (antisym x y)
  then show ?case using less_trm_well_order
    unfolding well_order_on_def linear_order_on_def partial_order_on_def antisym_def
      less_eq_term_def by auto
next
  case (total x y)
  then show ?case using less_trm_well_order
    unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      Relation.total_on_def less_eq_term_def by (cases "x = y") auto
qed

end

instantiation "term" :: (weighted, type) wellorder begin
instance
  using less_trm_well_order[unfolded well_order_on_def wf_def leq_term_minus_Id, THEN conjunct2]
  by intro_classes (atomize, auto)
end

lemma ground_less_less_kbo: "ground s \<Longrightarrow> ground t \<Longrightarrow> s < t \<Longrightarrow> less_kbo s t"
  using less_kbo_gtotal[of s t] less_trm_extension
  by (auto simp: less_term_def less_eq_term_def)

lemma less_kbo_less: "less_kbo s t \<Longrightarrow> s < t"
  using less_trm_extension
  by (auto simp: less_term_alt less_kbo_def KBO.S_irrefl)

lemma is_ground_atm_ground: "is_ground_atm t \<longleftrightarrow> ground t"
  unfolding is_ground_atm_def
  by (induct t) (fastforce simp: in_set_conv_nth list_eq_iff_nth_eq)+

end


(*  Title:      Example_TLS.thy
    Author:     Andreas Viktor Hess, DTU
    SPDX-License-Identifier: BSD-3-Clause
*)

section \<open>Proving Type-Flaw Resistance of the TLS Handshake Protocol\<close>
theory Example_TLS
imports "../Typed_Model"
begin

declare [[code_timing]]

subsection \<open>TLS example: Datatypes and functions setup\<close>
datatype ex_atom = PrivKey | SymKey | PubConst | Agent | Nonce | Bot

datatype ex_fun =
  clientHello | clientKeyExchange | clientFinished
| serverHello | serverCert | serverHelloDone
| finished | changeCipher | x509 | prfun | master | pmsForm
| sign | hash | crypt | pub | concat | privkey nat
| pubconst ex_atom nat

type_synonym ex_type = "(ex_fun, ex_atom) term_type"
type_synonym ex_var = "ex_type \<times> nat"

instance ex_atom::finite
proof
  let ?S = "UNIV::ex_atom set"
  have "?S = {PrivKey, SymKey, PubConst, Agent, Nonce, Bot}" by (auto intro: ex_atom.exhaust)
  thus "finite ?S" by (metis finite.emptyI finite.insertI)
qed

type_synonym ex_term = "(ex_fun, ex_var) term"
type_synonym ex_terms = "(ex_fun, ex_var) terms"

primrec arity::"ex_fun \<Rightarrow> nat" where
  "arity changeCipher = 0"
| "arity clientFinished = 4"
| "arity clientHello = 5"
| "arity clientKeyExchange = 1"
| "arity concat = 5"
| "arity crypt = 2"
| "arity finished = 1"
| "arity hash = 1"
| "arity master = 3"
| "arity pmsForm = 1"
| "arity prfun = 1"
| "arity (privkey _) = 0"
| "arity pub = 1"
| "arity (pubconst _ _) = 0"
| "arity serverCert = 1"
| "arity serverHello = 5"
| "arity serverHelloDone = 0"
| "arity sign = 2"
| "arity x509 = 2"

fun public::"ex_fun \<Rightarrow> bool" where
  "public (privkey _) = False"
| "public _ = True"

fun Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t::"ex_term list \<Rightarrow> (ex_term list \<times> ex_term list)" where
  "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t [Fun pub [k],m] = ([k], [m])"
| "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t _ = ([], [])"

fun Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n::"ex_term list \<Rightarrow> (ex_term list \<times> ex_term list)" where
  "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n [k,m] = ([], [m])"
| "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n _ = ([], [])"

fun Ana::"ex_term \<Rightarrow> (ex_term list \<times> ex_term list)" where
  "Ana (Fun crypt T) = Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t T"
| "Ana (Fun finished T) = ([], T)"
| "Ana (Fun master T) = ([], T)"
| "Ana (Fun pmsForm T) = ([], T)"
| "Ana (Fun serverCert T) = ([], T)"
| "Ana (Fun serverHello T) = ([], T)"
| "Ana (Fun sign T) = Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n T"
| "Ana (Fun x509 T) = ([], T)"
| "Ana _ = ([], [])"

subsection \<open>TLS example: Locale interpretation\<close>
lemma assm1:
  "Ana t = (K,M) \<Longrightarrow> fv\<^sub>s\<^sub>e\<^sub>t (set K) \<subseteq> fv t"
  "Ana t = (K,M) \<Longrightarrow> (\<And>g S'. Fun g S' \<sqsubseteq> t \<Longrightarrow> length S' = arity g)
                \<Longrightarrow> k \<in> set K \<Longrightarrow> Fun f T' \<sqsubseteq> k \<Longrightarrow> length T' = arity f"
  "Ana t = (K,M) \<Longrightarrow> K \<noteq> [] \<or> M \<noteq> [] \<Longrightarrow> Ana (t \<cdot> \<delta>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>, M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>)"
by (rule Ana.cases[of "t"], auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)+

lemma assm2: "Ana (Fun f T) = (K, M) \<Longrightarrow> set M \<subseteq> set T"
by (rule Ana.cases[of "Fun f T"]) (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)

lemma assm6: "0 < arity f \<Longrightarrow> public f" by (cases f) simp_all

global_interpretation im: intruder_model arity public Ana
  defines wf\<^sub>t\<^sub>r\<^sub>m = "im.wf\<^sub>t\<^sub>r\<^sub>m"
    and wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s = "im.wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s"
by unfold_locales (metis assm1(1), metis assm1(2), rule Ana.simps, metis assm2, metis assm1(3))

subsection \<open>TLS Example: Typing function\<close>
definition \<Gamma>\<^sub>v::"ex_var \<Rightarrow> ex_type" where
  "\<Gamma>\<^sub>v v = (if (\<forall>t \<in> subterms (fst v). case t of
                (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T
              | _ \<Rightarrow> True)
           then fst v else TAtom Bot)"

fun \<Gamma>::"ex_term \<Rightarrow> ex_type" where
  "\<Gamma> (Var v) = \<Gamma>\<^sub>v v"
| "\<Gamma> (Fun (privkey _) _) = TAtom PrivKey"
| "\<Gamma> (Fun changeCipher _) = TAtom PubConst"
| "\<Gamma> (Fun serverHelloDone _) = TAtom PubConst"
| "\<Gamma> (Fun (pubconst \<tau> _) _) = TAtom \<tau>"
| "\<Gamma> (Fun f T) = TComp f (map \<Gamma> T)"

subsection \<open>TLS Example: Locale interpretation (typed model)\<close>
lemma assm7: "arity c = 0 \<Longrightarrow> \<exists>a. \<forall>X. \<Gamma> (Fun c X) = TAtom a" by (cases c) simp_all

lemma assm8: "0 < arity f \<Longrightarrow> \<Gamma> (Fun f X) = TComp f (map \<Gamma> X)" by (cases f) simp_all

lemma assm9: "infinite {c. \<Gamma> (Fun c []) = TAtom a \<and> public c}"
proof -
  let ?T = "(range (pubconst a))::ex_fun set"
  have *:
      "\<And>x y::nat. x \<in> UNIV \<Longrightarrow> y \<in> UNIV \<Longrightarrow> (pubconst a x = pubconst a y) = (x = y)"
      "\<And>x::nat. x \<in> UNIV \<Longrightarrow> pubconst a x \<in> ?T"
      "\<And>y::ex_fun. y \<in> ?T \<Longrightarrow> \<exists>x \<in> UNIV. y = pubconst a x"
    by auto
  have "?T \<subseteq> {c. \<Gamma> (Fun c []) = TAtom a \<and> public c}" by auto
  moreover have "\<exists>f::nat \<Rightarrow> ex_fun. bij_betw f UNIV ?T"
    using bij_betwI'[OF *] by blast
  hence "infinite ?T" by (metis nat_not_finite bij_betw_finite)
  ultimately show ?thesis using infinite_super by blast
qed

lemma assm10:
  assumes "TComp f T \<sqsubseteq> \<Gamma> (Var x)"
  shows "arity f > 0"
proof -
  have *: "TComp f T \<sqsubseteq> \<Gamma>\<^sub>v x" using assms by simp
  hence "\<Gamma>\<^sub>v x \<noteq> TAtom Bot" unfolding \<Gamma>\<^sub>v_def by force
  hence "\<forall>t \<in> subterms (fst x). case t of
                (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T
              | _ \<Rightarrow> True"
    unfolding \<Gamma>\<^sub>v_def by argo
  thus ?thesis using * unfolding \<Gamma>\<^sub>v_def by fastforce
qed

lemma assm11: "im.wf\<^sub>t\<^sub>r\<^sub>m (\<Gamma> (Var x))"
proof -
  have "im.wf\<^sub>t\<^sub>r\<^sub>m (\<Gamma>\<^sub>v x)" unfolding \<Gamma>\<^sub>v_def im.wf\<^sub>t\<^sub>r\<^sub>m_def by auto
  thus ?thesis by simp
qed

lemma assm12: "\<Gamma> (Var (\<tau>, n)) = \<Gamma> (Var (\<tau>, m))"
  apply (cases "\<forall>t \<in> subterms \<tau>. case t of
                (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T
              | _ \<Rightarrow> True")
  by (auto simp add: \<Gamma>\<^sub>v_def)

lemma Ana_const: "arity c = 0 \<Longrightarrow> Ana (Fun c T) = ([],[])"
by (cases c) simp_all

lemma Ana_keys_subterm: "Ana t = (K,T) \<Longrightarrow> k \<in> set K \<Longrightarrow> k \<sqsubset> t"
proof (induct t rule: Ana.induct)
  case (1 U)
  then obtain m where "U = [Fun pub [k], m]" "K = [k]" "T = [m]"
    by (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)
  thus ?case using Fun_subterm_inside_params[of k crypt U] by auto
qed (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)

global_interpretation tm: typed_model' arity public Ana \<Gamma>
  by (unfold_locales, unfold wf\<^sub>t\<^sub>r\<^sub>m_def[symmetric])
     (metis assm7, metis assm8, metis assm10, metis assm11, metis assm12, metis Ana_const,
      metis Ana_keys_subterm)

subsection \<open>TLS example: Proving type-flaw resistance\<close>
abbreviation \<Gamma>\<^sub>v_clientHello where
  "\<Gamma>\<^sub>v_clientHello \<equiv>
    TComp clientHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]"

abbreviation \<Gamma>\<^sub>v_serverHello where
  "\<Gamma>\<^sub>v_serverHello \<equiv>
    TComp serverHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]"

abbreviation \<Gamma>\<^sub>v_pub where
  "\<Gamma>\<^sub>v_pub \<equiv> TComp pub [TAtom PrivKey]"

abbreviation \<Gamma>\<^sub>v_x509 where
  "\<Gamma>\<^sub>v_x509 \<equiv> TComp x509 [TAtom Agent, \<Gamma>\<^sub>v_pub]"

abbreviation \<Gamma>\<^sub>v_sign where
  "\<Gamma>\<^sub>v_sign \<equiv> TComp sign [TAtom PrivKey, \<Gamma>\<^sub>v_x509]"

abbreviation \<Gamma>\<^sub>v_serverCert where
  "\<Gamma>\<^sub>v_serverCert \<equiv> TComp serverCert [\<Gamma>\<^sub>v_sign]"

abbreviation \<Gamma>\<^sub>v_pmsForm where
  "\<Gamma>\<^sub>v_pmsForm \<equiv> TComp pmsForm [TAtom SymKey]"

abbreviation \<Gamma>\<^sub>v_crypt where
  "\<Gamma>\<^sub>v_crypt \<equiv> TComp crypt [\<Gamma>\<^sub>v_pub, \<Gamma>\<^sub>v_pmsForm]"

abbreviation \<Gamma>\<^sub>v_clientKeyExchange where
  "\<Gamma>\<^sub>v_clientKeyExchange \<equiv>
    TComp clientKeyExchange [\<Gamma>\<^sub>v_crypt]"

abbreviation \<Gamma>\<^sub>v_HSMsgs where
  "\<Gamma>\<^sub>v_HSMsgs \<equiv> TComp concat [
    \<Gamma>\<^sub>v_clientHello,
    \<Gamma>\<^sub>v_serverHello,
    \<Gamma>\<^sub>v_serverCert,
    TAtom PubConst,
    \<Gamma>\<^sub>v_clientKeyExchange]"

(* Variables from TLS *)
abbreviation "T\<^sub>1 n \<equiv> Var (TAtom Nonce,n)"
abbreviation "T\<^sub>2 n \<equiv> Var (TAtom Nonce,n)"
abbreviation "R\<^sub>A n \<equiv> Var (TAtom Nonce,n)"
abbreviation "R\<^sub>B n \<equiv> Var (TAtom Nonce,n)"
abbreviation "S n \<equiv> Var (TAtom Nonce,n)"
abbreviation "Cipher n \<equiv> Var (TAtom Nonce,n)"
abbreviation "Comp n \<equiv> Var (TAtom Nonce,n)"
abbreviation "B n \<equiv> Var (TAtom Agent,n)"
abbreviation "Pr\<^sub>c\<^sub>a n \<equiv> Var (TAtom PrivKey,n)"
abbreviation "PMS n \<equiv> Var (TAtom SymKey,n)"
abbreviation "P\<^sub>B n \<equiv> Var (TComp pub [TAtom PrivKey],n)"
abbreviation "HSMsgs n \<equiv> Var (\<Gamma>\<^sub>v_HSMsgs,n)"

subsubsection \<open>Defining the over-approximation set\<close>
abbreviation clientHello\<^sub>t\<^sub>r\<^sub>m where
  "clientHello\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun clientHello [T\<^sub>1 0, R\<^sub>A 1, S 2, Cipher 3, Comp 4]"

abbreviation serverHello\<^sub>t\<^sub>r\<^sub>m where
  "serverHello\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun serverHello [T\<^sub>2 0, R\<^sub>B 1, S 2, Cipher 3, Comp 4]"

abbreviation serverCert\<^sub>t\<^sub>r\<^sub>m where
  "serverCert\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun serverCert [Fun sign [Pr\<^sub>c\<^sub>a 0, Fun x509 [B 1, P\<^sub>B 2]]]"

abbreviation serverHelloDone\<^sub>t\<^sub>r\<^sub>m where
  "serverHelloDone\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun serverHelloDone []"

abbreviation clientKeyExchange\<^sub>t\<^sub>r\<^sub>m where
  "clientKeyExchange\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun clientKeyExchange [Fun crypt [P\<^sub>B 0, Fun pmsForm [PMS 1]]]"

abbreviation changeCipher\<^sub>t\<^sub>r\<^sub>m where
  "changeCipher\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun changeCipher []"

abbreviation finished\<^sub>t\<^sub>r\<^sub>m where
  "finished\<^sub>t\<^sub>r\<^sub>m \<equiv> Fun finished [Fun prfun [
      Fun clientFinished [
          Fun prfun [Fun master [PMS 0, R\<^sub>A 1, R\<^sub>B 2]],
          R\<^sub>A 3, R\<^sub>B 4, Fun hash [HSMsgs 5]
      ]
  ]]"

definition M\<^sub>T\<^sub>L\<^sub>S::"ex_term list" where
  "M\<^sub>T\<^sub>L\<^sub>S \<equiv> [
    clientHello\<^sub>t\<^sub>r\<^sub>m,
    serverHello\<^sub>t\<^sub>r\<^sub>m,
    serverCert\<^sub>t\<^sub>r\<^sub>m,
    serverHelloDone\<^sub>t\<^sub>r\<^sub>m,
    clientKeyExchange\<^sub>t\<^sub>r\<^sub>m,
    changeCipher\<^sub>t\<^sub>r\<^sub>m,
    finished\<^sub>t\<^sub>r\<^sub>m
]"

subsection \<open>Theorem: The TLS handshake protocol is type-flaw resistant\<close>
theorem "tm.tfr\<^sub>s\<^sub>e\<^sub>t (set M\<^sub>T\<^sub>L\<^sub>S)"
by (rule tm.tfr\<^sub>s\<^sub>e\<^sub>t_if_comp_tfr\<^sub>s\<^sub>e\<^sub>t') eval

end


chapter \<open> Classical Soundness and Completeness \label{sec:classical-propositional-calculus} \<close>

theory Classical_Logic_Completeness
  imports Classical_Logic
begin

text \<open> The following presents soundness completeness of the classical propositional
       calculus for propositional semantics. The classical propositional calculus
       is sometimes referred to as the \<^emph>\<open>sentential calculus\<close>.
       We give a concrete algebraic data type for propositional
       formulae in \S\ref{sec:classical-calculus-syntax}. We inductively
       define a logical judgement \<open>\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p\<close> for these formulae.
       We also define the Tarski truth relation \<open>\<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p\<close> inductively,
       which we present in \S\ref{sec:propositional-semantics}.\<close>

text \<open> The most significant results here are the \<^emph>\<open>embedding theorems\<close>.
       These theorems show that the propositional calculus
       can be embedded in any logic extending @{class classical_logic}.
       These theorems are proved in \S\ref{sec:propositional-embedding}. \<close>

section \<open> Syntax \label{sec:classical-calculus-syntax} \<close>

text \<open> Here we provide the usual language for formulae in the propositional
       calculus. It contains  \<^emph>\<open>falsum\<close> \<open>\<^bold>\<bottom>\<close>, implication \<open>(\<^bold>\<rightarrow>)\<close>, and a way of
       constructing \<^emph>\<open>atomic\<close> propositions \<open>\<lambda> \<phi> . \<^bold>\<langle> \<phi> \<^bold>\<rangle>\<close>. Defining the
       language is straight-forward using an algebraic data type. \<close>

datatype 'a classical_propositional_formula =
      Falsum ("\<^bold>\<bottom>")
    | Proposition 'a ("\<^bold>\<langle> _ \<^bold>\<rangle>" [45])
    | Implication
        "'a classical_propositional_formula"
        "'a classical_propositional_formula" (infixr "\<^bold>\<rightarrow>" 70)

section \<open> Propositional Calculus \<close>

text \<open> In this section we recursively define what a proof is in the classical
       propositional calculus. We provide the familiar \<^emph>\<open>K\<close> and \<^emph>\<open>S\<close> axioms,
       as well as \<^emph>\<open>double negation\<close> and \<^emph>\<open>modus ponens\<close>. \<close>

named_theorems classical_propositional_calculus
  "Rules for the Propositional Calculus"

inductive classical_propositional_calculus ::
  "'a classical_propositional_formula \<Rightarrow> bool" ("\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p _" [60] 55)
  where
     axiom_k [classical_propositional_calculus]:
       "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<^bold>\<rightarrow> \<psi> \<^bold>\<rightarrow> \<phi>"
   | axiom_s [classical_propositional_calculus]:
       "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p (\<phi> \<^bold>\<rightarrow> \<psi> \<^bold>\<rightarrow> \<chi>) \<^bold>\<rightarrow> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<rightarrow> \<phi> \<^bold>\<rightarrow> \<chi>"
   | double_negation [classical_propositional_calculus]:
       "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p ((\<phi> \<^bold>\<rightarrow> \<^bold>\<bottom>) \<^bold>\<rightarrow> \<^bold>\<bottom>) \<^bold>\<rightarrow> \<phi>"
   | modus_ponens [classical_propositional_calculus]:
        "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<^bold>\<rightarrow> \<psi> \<Longrightarrow> \<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<Longrightarrow> \<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<psi>"

text \<open> Our proof system for our propositional calculus is trivially
       an instance of @{class classical_logic}. The introduction rules
       for \<open>\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p\<close> naturally reflect the axioms of the classical logic
       axiom class. \<close>

instantiation classical_propositional_formula
  :: (type) classical_logic
begin
definition [simp]: "\<bottom> = \<^bold>\<bottom>"
definition [simp]: "\<turnstile> \<phi> = \<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
definition [simp]: "\<phi> \<rightarrow> \<psi> = \<phi> \<^bold>\<rightarrow> \<psi>"
instance by standard (simp add: classical_propositional_calculus)+
end

section \<open> Propositional Semantics \label{sec:propositional-semantics} \<close>

text \<open> Below we give the typical definition of the Tarski truth relation
       \<open> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p\<close>. \<close>

primrec classical_propositional_semantics ::
  "'a set \<Rightarrow> 'a classical_propositional_formula \<Rightarrow> bool"
  (infix "\<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p" 65)
  where
       "\<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<^bold>\<langle> p \<^bold>\<rangle> = (p \<in> \<MM>)"
    |  "\<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<^bold>\<rightarrow> \<psi> = (\<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<longrightarrow> \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<psi>)"
    |  "\<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<^bold>\<bottom> = False"

text \<open> Soundness of our calculus for these semantics is trivial. \<close>

theorem classical_propositional_calculus_soundness:
  "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<Longrightarrow> \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
  by (induct rule: classical_propositional_calculus.induct, simp+)

section \<open> Soundness and Completeness Proofs \label{sec:classical-logic-completeness}\<close>

definition strong_classical_propositional_deduction ::
  "'a classical_propositional_formula set
    \<Rightarrow> 'a classical_propositional_formula \<Rightarrow> bool"
  (infix "\<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p" 65)
  where
    [simp]: "\<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<equiv> \<Gamma> \<tturnstile> \<phi>"

definition strong_classical_propositional_tarski_truth ::
  "'a classical_propositional_formula set
    \<Rightarrow> 'a classical_propositional_formula \<Rightarrow> bool"
  (infix "\<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p" 65)
  where
    [simp]: "\<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<equiv> \<forall> \<MM>.(\<forall> \<gamma> \<in> \<Gamma>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<gamma>) \<longrightarrow> \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"

definition theory_propositions ::
  "'a classical_propositional_formula set \<Rightarrow> 'a set" ("\<^bold>\<lbrace> _ \<^bold>\<rbrace>" [50])
  where
    [simp]: "\<^bold>\<lbrace> \<Gamma> \<^bold>\<rbrace> = {p . \<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<^bold>\<langle> p \<^bold>\<rangle>}"

text \<open> Below we give the main lemma for completeness: the \<^emph>\<open>truth lemma\<close>.
       This proof connects the maximally consistent sets developed in \S\ref{sec:implicational-maximally-consistent-sets}
       and \S\ref{sec:mcs} with the semantics given in
       \S\ref{sec:propositional-semantics}. \<close>

text \<open> All together, the technique we are using essentially follows the
       approach by Blackburn et al. @{cite \<open>\S 4.2, pgs. 196-201\<close> blackburnSectionCanonicalModels2001}. \<close>

lemma truth_lemma:
  assumes "MCS \<Gamma>"
  shows "\<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<equiv> \<^bold>\<lbrace> \<Gamma> \<^bold>\<rbrace> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
proof (induct \<phi>)
  case Falsum
  then show ?case using assms by auto
next
  case (Proposition x)
  then show ?case by simp
next
  case (Implication \<psi> \<chi>)
  thus ?case
    unfolding strong_classical_propositional_deduction_def
    by (metis
          assms
          maximally_consistent_set_def
          formula_maximally_consistent_set_def_implication
          classical_propositional_semantics.simps(2)
          implication_classical_propositional_formula_def
          set_deduction_modus_ponens
          set_deduction_reflection)
qed

text \<open> Here the truth lemma above is combined with @{thm formula_maximally_consistent_extension [no_vars]}
 proven in \S\ref{sec:propositional-semantics}.  These theorems together
  give rise to strong completeness for the propositional calculus. \<close>

theorem classical_propositional_calculus_strong_soundness_and_completeness:
  "\<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> = \<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
proof -
  have soundness: "\<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<Longrightarrow> \<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
  proof -
    assume "\<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
    from this obtain \<Gamma>' where \<Gamma>': "set \<Gamma>' \<subseteq> \<Gamma>" "\<Gamma>' :\<turnstile> \<phi>"
    by (simp add: set_deduction_def, blast)
    {
      fix \<MM>
      assume "\<forall> \<gamma> \<in> \<Gamma>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<gamma>"
      hence "\<forall> \<gamma> \<in> set \<Gamma>'. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<gamma>" using \<Gamma>'(1) by auto
      hence "\<forall> \<phi>. \<Gamma>' :\<turnstile> \<phi> \<longrightarrow> \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
      proof (induct \<Gamma>')
        case Nil
        then show ?case
          by (simp add:
                classical_propositional_calculus_soundness
                list_deduction_def)
      next
        case (Cons \<psi> \<Gamma>')
        thus ?case using list_deduction_theorem by fastforce
      qed
      with \<Gamma>'(2) have "\<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>" by blast
    }
    thus "\<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
      using strong_classical_propositional_tarski_truth_def by blast
  qed
  have completeness: "\<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<Longrightarrow> \<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
  proof (erule contrapos_pp)
    assume "\<not> \<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
    hence "\<exists> \<MM>. (\<forall> \<gamma> \<in> \<Gamma>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<gamma>) \<and> \<not> \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
    proof -
      from \<open>\<not> \<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>\<close> obtain \<Omega> where \<Omega>: "\<Gamma> \<subseteq> \<Omega>" "\<phi>-MCS \<Omega>"
        by (meson
              formula_consistent_def
              formula_maximally_consistent_extension
              strong_classical_propositional_deduction_def)
      hence "(\<phi> \<rightarrow> \<bottom>) \<in> \<Omega>"
        using formula_maximally_consistent_set_def_negation by blast
      hence "\<not> \<^bold>\<lbrace> \<Omega> \<^bold>\<rbrace> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
        using \<Omega>
              formula_consistent_def
              formula_maximal_consistency
              formula_maximally_consistent_set_def_def
              truth_lemma
        unfolding strong_classical_propositional_deduction_def
        by blast
      moreover have "\<forall> \<gamma> \<in> \<Gamma>. \<^bold>\<lbrace> \<Omega> \<^bold>\<rbrace> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<gamma>"
        using
          formula_maximal_consistency
          truth_lemma
          \<Omega>
          set_deduction_reflection
        unfolding strong_classical_propositional_deduction_def
        by blast
      ultimately show ?thesis by auto
    qed
    thus "\<not> \<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
      unfolding strong_classical_propositional_tarski_truth_def
      by simp
  qed
  from soundness completeness show "\<Gamma> \<tturnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> = \<Gamma> \<TTurnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>"
    by linarith
qed

text \<open> For our applications in \S{sec:propositional-embedding},
       we will only need a weaker form of soundness and completeness
       rather than the stronger form proved above.\<close>

theorem classical_propositional_calculus_soundness_and_completeness:
  "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> = (\<forall>\<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi>)"
  using classical_propositional_calculus_soundness [where \<phi>="\<phi>"]
        classical_propositional_calculus_strong_soundness_and_completeness
            [where \<phi>="\<phi>" and \<Gamma>="{}"]
        strong_classical_propositional_deduction_def
            [where \<phi>="\<phi>" and \<Gamma>="{}"]
        strong_classical_propositional_tarski_truth_def
            [where \<phi>="\<phi>" and \<Gamma>="{}"]
        deduction_classical_propositional_formula_def [where \<phi>="\<phi>"]
        set_deduction_base_theory [where \<phi>="\<phi>"]
  by metis

instantiation classical_propositional_formula
  :: (type) consistent_classical_logic
begin
instance by standard
  (simp add: classical_propositional_calculus_soundness_and_completeness)
end

section \<open> Embedding Theorem For the Propositional Calculus \label{sec:propositional-embedding} \<close>

text \<open> A recurring technique to prove theorems in logic moving forward is
       \<^emph>\<open>embed\<close> our theorem into the classical propositional calculus. \<close>

text \<open> Using our embedding, we can leverage completeness to turn our
       problem into semantics and dispatch to Isabelle/HOL's classical
       theorem provers.\<close>

text \<open> In future work we may make a tactic for this, but for now we just
       manually leverage the technique throughout our subsequent proofs. \<close>

primrec (in classical_logic)
   classical_propositional_formula_embedding
   :: "'a classical_propositional_formula \<Rightarrow> 'a" ("\<^bold>\<lparr> _ \<^bold>\<rparr>" [50]) where
     "\<^bold>\<lparr> \<^bold>\<langle> p \<^bold>\<rangle> \<^bold>\<rparr> = p"
   | "\<^bold>\<lparr> \<phi> \<^bold>\<rightarrow> \<psi> \<^bold>\<rparr> = \<^bold>\<lparr> \<phi> \<^bold>\<rparr> \<rightarrow> \<^bold>\<lparr> \<psi> \<^bold>\<rparr>"
   | "\<^bold>\<lparr> \<^bold>\<bottom> \<^bold>\<rparr> = \<bottom>"

theorem (in classical_logic) propositional_calculus:
  "\<turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<Longrightarrow> \<turnstile> \<^bold>\<lparr> \<phi> \<^bold>\<rparr>"
  by (induct rule: classical_propositional_calculus.induct,
      (simp add: axiom_k axiom_s double_negation modus_ponens)+)

text \<open> The following theorem in particular shows that it suffices to
       prove theorems using classical semantics to prove theorems about
       the logic under investigation. \<close>

theorem (in classical_logic) propositional_semantics:
  "\<forall>\<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<phi> \<Longrightarrow> \<turnstile> \<^bold>\<lparr> \<phi> \<^bold>\<rparr>"
  by (simp add:
        classical_propositional_calculus_soundness_and_completeness
        propositional_calculus)

end