(*  Title:       Verification Examples
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Verification examples \<close>

theory MTX_Examples
  imports MTX_Flows "Hybrid_Systems_VCs.HS_VC_Spartan"

begin

subsection \<open> Examples \<close>

abbreviation hoareT :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  ("PRE_ HP _ POST _" [85,85]85) where "PRE P HP X POST Q \<equiv> (P \<le> |X]Q)"

subsubsection \<open> Verification by uniqueness. \<close>

abbreviation mtx_circ :: "2 sq_mtx" ("A")
  where "A \<equiv> mtx
   ([0,  1] #
    [-1, 0] # [])"

abbreviation mtx_circ_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t else - s$1 * sin t + s$2 * cos t)"

lemma mtx_circ_flow_eq: "exp (t *\<^sub>R A) *\<^sub>V s = \<phi> t s"
  apply(rule local_flow.eq_solution[OF local_flow_sq_mtx_linear, symmetric])
    apply(rule ivp_solsI, simp_all add: sq_mtx_vec_mult_eq vec_eq_iff)
  unfolding UNIV_2 using exhaust_2
  by (force intro!: poly_derivatives simp: matrix_vector_mult_def)+

lemma mtx_circ:
  "PRE(\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2)
  HP x\<acute>=(*\<^sub>V) A & G
  POST (\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2)"
  apply(subst local_flow.fbox_g_ode[OF local_flow_sq_mtx_linear])
  unfolding mtx_circ_flow_eq by auto

no_notation mtx_circ ("A")
        and mtx_circ_flow ("\<phi>")

subsubsection \<open> Flow of diagonalisable matrix. \<close>

abbreviation mtx_hOsc :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx" ("A")
  where "A a b \<equiv> mtx
   ([0, 1] #
    [a, b] # [])"

abbreviation mtx_chB_hOsc :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx" ("P")
  where "P a b \<equiv> mtx
   ([a, b] #
    [1, 1] # [])"

lemma inv_mtx_chB_hOsc:
  "a \<noteq> b \<Longrightarrow> (P a b)\<^sup>-\<^sup>1 = (1/(a - b)) *\<^sub>R mtx
   ([ 1, -b] #
    [-1,  a] # [])"
  apply(rule sq_mtx_inv_unique, unfold scaleR_mtx2 times_mtx2)
  by (simp add: diff_divide_distrib[symmetric] one_mtx2)+

lemma invertible_mtx_chB_hOsc: "a \<noteq> b \<Longrightarrow> mtx_invertible (P a b)"
  apply(rule mtx_invertibleI[of _ "(P a b)\<^sup>-\<^sup>1"])
   apply(unfold inv_mtx_chB_hOsc scaleR_mtx2 times_mtx2 one_mtx2)
  by (subst sq_mtx_eq_iff, simp add: vector_def frac_diff_eq1)+

lemma mtx_hOsc_diagonalizable:
  fixes a b :: real
  defines "\<iota>\<^sub>1 \<equiv> (b - sqrt (b^2+4*a))/2" and "\<iota>\<^sub>2 \<equiv> (b + sqrt (b^2+4*a))/2"
  assumes "b\<^sup>2 + a * 4 > 0" and "a \<noteq> 0"
  shows "A a b = P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a) * (\<d>\<i>\<a>\<g> i. if i = 1 then \<iota>\<^sub>1 else \<iota>\<^sub>2) * (P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a))\<^sup>-\<^sup>1"
  unfolding assms apply(subst inv_mtx_chB_hOsc)
  using assms(3,4) apply(simp_all add: diag2_eq[symmetric])
  unfolding sq_mtx_times_eq sq_mtx_scaleR_eq UNIV_2 apply(subst sq_mtx_eq_iff)
  using exhaust_2 assms by (auto simp: field_simps, auto simp: field_power_simps)

lemma mtx_hOsc_solution_eq:
  fixes a b :: real
  defines "\<iota>\<^sub>1 \<equiv> (b - sqrt (b\<^sup>2+4*a))/2" and "\<iota>\<^sub>2 \<equiv> (b + sqrt (b\<^sup>2+4*a))/2"
  defines "\<Phi> t \<equiv> mtx (
   [\<iota>\<^sub>2*exp(t*\<iota>\<^sub>1) - \<iota>\<^sub>1*exp(t*\<iota>\<^sub>2),     exp(t*\<iota>\<^sub>2)-exp(t*\<iota>\<^sub>1)]#
   [a*exp(t*\<iota>\<^sub>2) - a*exp(t*\<iota>\<^sub>1), \<iota>\<^sub>2*exp(t*\<iota>\<^sub>2)-\<iota>\<^sub>1*exp(t*\<iota>\<^sub>1)]#[])"
  assumes "b\<^sup>2 + a * 4 > 0" and "a \<noteq> 0"
  shows "P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a) * (\<d>\<i>\<a>\<g> i. exp (t * (if i=1 then \<iota>\<^sub>1 else \<iota>\<^sub>2))) * (P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a))\<^sup>-\<^sup>1
  = (1/sqrt (b\<^sup>2 + a * 4)) *\<^sub>R (\<Phi> t)"
  unfolding assms apply(subst inv_mtx_chB_hOsc)
  using assms apply(simp_all add: mtx_times_scaleR_commute, subst sq_mtx_eq_iff)
  unfolding UNIV_2 sq_mtx_times_eq sq_mtx_scaleR_eq sq_mtx_uminus_eq apply(simp_all add: axis_def)
  by (auto simp: field_simps, auto simp: field_power_simps)+

lemma local_flow_mtx_hOsc:
  fixes a b
  defines "\<iota>\<^sub>1 \<equiv> (b - sqrt (b^2+4*a))/2" and "\<iota>\<^sub>2 \<equiv> (b + sqrt (b^2+4*a))/2"
  defines "\<Phi> t \<equiv> mtx (
   [\<iota>\<^sub>2*exp(t*\<iota>\<^sub>1) - \<iota>\<^sub>1*exp(t*\<iota>\<^sub>2),     exp(t*\<iota>\<^sub>2)-exp(t*\<iota>\<^sub>1)]#
   [a*exp(t*\<iota>\<^sub>2) - a*exp(t*\<iota>\<^sub>1), \<iota>\<^sub>2*exp(t*\<iota>\<^sub>2)-\<iota>\<^sub>1*exp(t*\<iota>\<^sub>1)]#[])"
  assumes "b\<^sup>2 + a * 4 > 0" and "a \<noteq> 0"
  shows "local_flow ((*\<^sub>V) (A a b)) UNIV UNIV (\<lambda>t. (*\<^sub>V) ((1/sqrt (b\<^sup>2 + a * 4)) *\<^sub>R \<Phi> t))"
  unfolding assms using local_flow_sq_mtx_linear[of "A a b"] assms
  apply(subst (asm) exp_scaleR_diagonal2[OF invertible_mtx_chB_hOsc mtx_hOsc_diagonalizable])
     apply(simp, simp, simp)
  by (subst (asm) mtx_hOsc_solution_eq) simp_all

lemma overdamped_door_arith:
  assumes "b\<^sup>2 + a * 4 > 0" and "a < 0" and "b \<le> 0" and "t \<ge> 0" and "s1 > 0"
  shows "0 \<le> ((b + sqrt (b\<^sup>2 + 4 * a)) * exp (t * (b - sqrt (b\<^sup>2 + 4 * a)) / 2) / 2 -
(b - sqrt (b\<^sup>2 + 4 * a)) * exp (t * (b + sqrt (b\<^sup>2 + 4 * a)) / 2) / 2) * s1 / sqrt (b\<^sup>2 + a * 4)"
proof(subst diff_divide_distrib[symmetric], simp)
  have f0: "s1 / (2 * sqrt (b\<^sup>2 + a * 4)) > 0"  (is "s1/?c3 > 0")
    using assms(1,5) by simp
  have f1: "(b - sqrt (b\<^sup>2 + 4 * a)) < (b + sqrt (b\<^sup>2 + 4 * a))" (is "?c2 < ?c1")
    and f2: "(b + sqrt (b\<^sup>2 + 4 * a)) < 0"
    using sqrt_ge_absD[of b "b\<^sup>2 + 4 * a"] assms by (force, linarith)
  hence f3: "exp (t * ?c2 / 2) \<le> exp (t * ?c1 / 2)" (is "exp ?t1 \<le> exp ?t2")
    unfolding exp_le_cancel_iff
    using assms(4) by (case_tac "t=0", simp_all)
  hence "?c2 * exp ?t2 \<le> ?c2 * exp ?t1"
    using f1 f2 real_mult_le_cancel_iff2[of "-?c2" "exp ?t1" "exp ?t2"] by linarith
  also have "... < ?c1 * exp ?t1"
    using f1 by auto
  also have"... \<le> ?c1 * exp ?t1"
    using f1 f2 by auto
  ultimately show "0 \<le> (?c1 * exp ?t1 - ?c2 * exp ?t2) * s1 / ?c3"
    using f0 f1 assms(5) by auto
qed

lemma overdamped_door:
  assumes "b\<^sup>2 + a * 4 > 0" and "a < 0" and "b \<le> 0" and "0 \<le> t"
  shows "PRE (\<lambda>s. s$1 = 0)
  HP (LOOP
      (\<lambda>s. {s. s$1 > 0 \<and> s$2 = 0});
      (x\<acute>=(*\<^sub>V) (A a b) & G on {0..t} UNIV @ 0)
     INV (\<lambda>s. 0 \<le> s$1))
  POST (\<lambda>s. 0 \<le> s $ 1)"
  apply(rule fbox_loopI, simp_all add: le_fun_def)
  apply(subst local_flow.fbox_g_ode_ivl[OF local_flow_mtx_hOsc[OF assms(1)]])
  using assms apply(simp_all add: le_fun_def fbox_def)
  unfolding sq_mtx_scaleR_eq UNIV_2 sq_mtx_vec_mult_eq
  by (clarsimp simp: overdamped_door_arith)

no_notation mtx_hOsc ("A")
        and mtx_chB_hOsc ("P")

subsubsection \<open> Flow of non-diagonalisable matrix. \<close>

abbreviation mtx_cnst_acc :: "3 sq_mtx" ("K")
  where "K \<equiv> mtx (
  [0,1,0] #
  [0,0,1] #
  [0,0,0] # [])"

lemma pow2_scaleR_mtx_cnst_acc: "(t *\<^sub>R K)\<^sup>2 = mtx (
  [0,0,t\<^sup>2] #
  [0,0,0] #
  [0,0,0] # [])"
  unfolding power2_eq_square apply(subst sq_mtx_eq_iff)
  unfolding sq_mtx_times_eq UNIV_3 by auto

lemma powN_scaleR_mtx_cnst_acc: "n > 2 \<Longrightarrow> (t *\<^sub>R K)^n = 0"
  apply(induct n, simp, case_tac "n \<le> 2")
   apply(subgoal_tac "n = 2", erule ssubst)
  unfolding power_Suc2 pow2_scaleR_mtx_cnst_acc sq_mtx_times_eq UNIV_3
  by (auto simp: sq_mtx_eq_iff)

lemma exp_mtx_cnst_acc_vec_mult_eq: "exp (t *\<^sub>R K) *\<^sub>V s =
  vector [s$3 * t^2/2 + s$2 * t + s$1, s$3 * t + s$2, s$3]"
  apply(simp add: sq_mtx_vec_mult_eq vector_def)
  unfolding UNIV_3 apply (simp add: exp_mtx_cnst_acc_simps fun_eq_iff)
  using exhaust_3 exp_mtx_cnst_acc_simps(7,8,9) by fastforce

lemma local_flow_mtx_cnst_acc:
  "local_flow ((*\<^sub>V) K) UNIV UNIV (\<lambda>t s. ((t *\<^sub>R K)\<^sup>2/\<^sub>R 2 + (t *\<^sub>R K) + 1) *\<^sub>V s)"
  using local_flow_sq_mtx_linear[of K] unfolding exp_mtx_cnst_acc .

lemma docking_station_arith:
  assumes "(d::real) > x" and "v > 0"
  shows "(v = v\<^sup>2 * t / (2 * d - 2 * x)) \<longleftrightarrow> (v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = d)"
proof
  assume "v = v\<^sup>2 * t / (2 * d - 2 * x)"
  hence "v * t = 2 * (d - x)"
    using assms by (simp add: eq_divide_eq power2_eq_square)
  hence "v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = 2 * (d - x) - 4 * (d - x)\<^sup>2 / (4 * (d - x)) + x"
    apply(subst power_mult_distrib[symmetric])
    by (erule ssubst, subst power_mult_distrib, simp)
  also have "... = d"
    apply(simp only: mult_divide_mult_cancel_left_if)
    using assms by (auto simp: power2_eq_square)
  finally show "v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = d" .
next
  assume "v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = d"
  hence "0 = v\<^sup>2 * t\<^sup>2 / (4 * (d - x)) + (d - x) - v * t"
    by auto
  hence "0 = (4 * (d - x)) * (v\<^sup>2 * t\<^sup>2 / (4 * (d - x)) + (d - x) - v * t)"
    by auto
  also have "... = v\<^sup>2 * t\<^sup>2 + 4 * (d - x)\<^sup>2  - (4 * (d - x)) * (v * t)"
    using assms apply(simp add: distrib_left right_diff_distrib)
    apply(subst right_diff_distrib[symmetric])+
    by (simp add: power2_eq_square)
  also have "... = (v * t - 2 * (d - x))\<^sup>2"
    by (simp only: power2_diff, auto simp: field_simps power2_diff)
  finally have "0 = (v * t - 2 * (d - x))\<^sup>2" .
  hence "v * t = 2 * (d - x)"
    by auto
  thus "v = v\<^sup>2 * t / (2 * d - 2 * x)"
    apply(subst power2_eq_square, subst mult.assoc)
    apply(erule ssubst, subst right_diff_distrib[symmetric])
    using assms by auto
qed

lemma docking_station:
  assumes "d > x\<^sub>0" and "v\<^sub>0 > 0"
  shows "PRE (\<lambda>s. s$1 = x\<^sub>0 \<and> s$2 = v\<^sub>0)
  HP ((3 ::= (\<lambda>s. -(v\<^sub>0^2/(2*(d-x\<^sub>0))))); x\<acute>=(*\<^sub>V) K & G)
  POST (\<lambda>s. s$2 = 0 \<longleftrightarrow> s$1 = d)"
  apply(clarsimp simp: le_fun_def local_flow.fbox_g_ode[OF local_flow_sq_mtx_linear[of K]])
  unfolding exp_mtx_cnst_acc_vec_mult_eq using assms by (simp add: docking_station_arith)

no_notation mtx_cnst_acc ("K")

end


(*  Title:      FOL/ex/Nat.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* Theory of the natural numbers: Peano's axioms, primitive recursion *}

theory Nat
imports FOL
begin

typedecl nat
instance nat :: "term" ..

axiomatization
  Zero :: nat  ("0") and
  Suc :: "nat => nat" and
  rec :: "[nat, 'a, [nat, 'a] => 'a] => 'a"
where
  induct: "[| P(0);  !!x. P(x) ==> P(Suc(x)) |]  ==> P(n)" and
  Suc_inject: "Suc(m)=Suc(n) ==> m=n" and
  Suc_neq_0: "Suc(m)=0 ==> R" and
  rec_0: "rec(0,a,f) = a" and
  rec_Suc: "rec(Suc(m), a, f) = f(m, rec(m,a,f))"

definition add :: "[nat, nat] => nat"  (infixl "+" 60)
  where "m + n == rec(m, n, %x y. Suc(y))"

subsection {* Proofs about the natural numbers *}

lemma Suc_n_not_n: "Suc(k) ~= k"
apply (rule_tac n = k in induct)
apply (rule notI)
apply (erule Suc_neq_0)
apply (rule notI)
apply (erule notE)
apply (erule Suc_inject)
done

lemma "(k+m)+n = k+(m+n)"
apply (rule induct)
back
back
back
back
back
back
oops

lemma add_0 [simp]: "0+n = n"
apply (unfold add_def)
apply (rule rec_0)
done

lemma add_Suc [simp]: "Suc(m)+n = Suc(m+n)"
apply (unfold add_def)
apply (rule rec_Suc)
done

lemma add_0_right: "m+0 = m"
apply (rule_tac n = m in induct)
apply simp
apply simp
done

lemma add_Suc_right: "m+Suc(n) = Suc(m+n)"
apply (rule_tac n = m in induct)
apply simp_all
done

lemma
  assumes prem: "!!n. f(Suc(n)) = Suc(f(n))"
  shows "f(i+j) = i+f(j)"
apply (rule_tac n = i in induct)
apply simp
apply (simp add: prem)
done

end


section "Bitvector based Sets of Naturals"
theory Impl_Bit_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  Native_Word.Bits_Integer
begin
  text \<open>
    Based on the Native-Word library, using bit-operations on arbitrary
    precision integers. Fast for sets of small numbers,
    direct and fast implementations of equal, union, inter, diff.

    Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are
      rather inefficient. Use MLton instead, here they are efficiently implemented.
\<close>

  type_synonym bitset = integer

  definition bs_\<alpha> :: "bitset \<Rightarrow> nat set" where "bs_\<alpha> s \<equiv> { n . bit s n}"

context includes integer.lifting begin

  definition bs_empty :: "unit \<Rightarrow> bitset" where "bs_empty \<equiv> \<lambda>_. 0"

  lemma bs_empty_correct: "bs_\<alpha> (bs_empty ()) = {}"
    unfolding bs_\<alpha>_def bs_empty_def
    apply transfer
    by auto

  definition bs_isEmpty :: "bitset \<Rightarrow> bool" where "bs_isEmpty s \<equiv> s=0"

  lemma bs_isEmpty_correct: "bs_isEmpty s \<longleftrightarrow> bs_\<alpha> s = {}"
    unfolding bs_isEmpty_def bs_\<alpha>_def
    by transfer (auto simp: bin_eq_iff)

  term set_bit
  definition bs_insert :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_insert i s \<equiv> set_bit s i True"

  lemma bs_insert_correct: "bs_\<alpha> (bs_insert i s) = insert i (bs_\<alpha> s)"
    unfolding bs_\<alpha>_def bs_insert_def
    apply transfer
    apply auto
    apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
    apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
    by (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)

  definition bs_delete :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_delete i s \<equiv> set_bit s i False"

  lemma bs_delete_correct: "bs_\<alpha> (bs_delete i s) = (bs_\<alpha> s) - {i}"
    unfolding bs_\<alpha>_def bs_delete_def
    apply transfer
    apply auto
    apply (metis bin_nth_ops(1) int_set_bit_False_conv_NAND)
    apply (metis (full_types) bin_nth_sc set_bit_int_def)
    by (metis (full_types) bin_nth_sc_gen set_bit_int_def)

  definition bs_mem :: "nat \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_mem i s \<equiv> bit s i"

  lemma bs_mem_correct: "bs_mem i s \<longleftrightarrow> i\<in>bs_\<alpha> s"
    unfolding bs_mem_def bs_\<alpha>_def by transfer auto

  definition bs_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_eq s1 s2 \<equiv> (s1=s2)"

  lemma bs_eq_correct: "bs_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 = bs_\<alpha> s2"
    unfolding bs_eq_def bs_\<alpha>_def
    including integer.lifting
    apply transfer
    apply auto
    by (metis bin_eqI mem_Collect_eq)

  definition bs_subset_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_subset_eq s1 s2 \<equiv> s1 AND NOT s2 = 0"

  lemma bs_subset_eq_correct: "bs_subset_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<subseteq> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_subset_eq_def
    by transfer (auto simp add: bit_eq_iff bin_nth_ops)

  definition bs_disjoint :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_disjoint s1 s2 \<equiv> s1 AND s2 = 0"

  lemma bs_disjoint_correct: "bs_disjoint s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<inter> bs_\<alpha> s2 = {}"
    unfolding bs_\<alpha>_def bs_disjoint_def
    by transfer (auto simp add: bit_eq_iff bin_nth_ops)

  definition bs_union :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_union s1 s2 = s1 OR s2"

  lemma bs_union_correct: "bs_\<alpha> (bs_union s1 s2) = bs_\<alpha> s1 \<union> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_union_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_inter :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_inter s1 s2 = s1 AND s2"

  lemma bs_inter_correct: "bs_\<alpha> (bs_inter s1 s2) = bs_\<alpha> s1 \<inter> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_inter_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_diff :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_diff s1 s2 = s1 AND NOT s2"

  lemma bs_diff_correct: "bs_\<alpha> (bs_diff s1 s2) = bs_\<alpha> s1 - bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_diff_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_UNIV :: "unit \<Rightarrow> bitset" where "bs_UNIV \<equiv> \<lambda>_. -1"

  lemma bs_UNIV_correct: "bs_\<alpha> (bs_UNIV ()) = UNIV"
    unfolding bs_\<alpha>_def bs_UNIV_def
    by transfer (auto)

  definition bs_complement :: "bitset \<Rightarrow> bitset" where
    "bs_complement s = NOT s"

  lemma bs_complement_correct: "bs_\<alpha> (bs_complement s) = - bs_\<alpha> s"
    unfolding bs_\<alpha>_def bs_complement_def
    by transfer (auto simp: bin_nth_ops)

end

  lemmas bs_correct[simp] =
    bs_empty_correct
    bs_isEmpty_correct
    bs_insert_correct
    bs_delete_correct
    bs_mem_correct
    bs_eq_correct
    bs_subset_eq_correct
    bs_disjoint_correct
    bs_union_correct
    bs_inter_correct
    bs_diff_correct
    bs_UNIV_correct
    bs_complement_correct

subsection \<open>Autoref Setup\<close>

definition bs_set_rel_def_internal:
  "bs_set_rel Rk \<equiv>
    if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
lemma bs_set_rel_def:
  "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
  unfolding bs_set_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "bs_set_rel" i_set]

lemma bs_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>bs_set_rel)"
  unfolding bs_set_rel_def by auto

term bs_empty

lemma [autoref_rules]: "(bs_empty (),{})\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_UNIV (),UNIV)\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

term insert
lemma [autoref_rules]: "(bs_insert,insert)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

term op_set_delete
lemma [autoref_rules]: "(bs_delete,op_set_delete)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_mem,(\<in>))\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_eq,(=))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_subset_eq,(\<subseteq>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_union,(\<union>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_inter,(\<inter>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_diff,(-))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_complement,uminus)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

export_code
    bs_empty
    bs_isEmpty
    bs_insert
    bs_delete
    bs_mem
    bs_eq
    bs_subset_eq
    bs_disjoint
    bs_union
    bs_inter
    bs_diff
    bs_UNIV
    bs_complement
 in SML

(*

    TODO: Iterator

  definition "maxbi s \<equiv> GREATEST i. s!!i"

  lemma cmp_BIT_append_conv[simp]: "i < i BIT b \<longleftrightarrow> ((i\<ge>0 \<and> b=1) \<or> i>0)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_cmp_conv[simp]: "i BIT b < i \<longleftrightarrow> ((i<0 \<and> (i=-1 \<longrightarrow> b=0)))"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_eq[simp]: fixes i :: int shows "i BIT b = i \<longleftrightarrow> (i=0 \<and> b=0) \<or> (i=-1 \<and> b=1)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma int_no_bits_eq_zero[simp]:
    fixes s::int shows "(\<forall>i. \<not>s!!i) \<longleftrightarrow> s=0"
    apply clarsimp
    by (metis bin_eqI bin_nth_code(1))

  lemma int_obtain_bit:
    fixes s::int
    assumes "s\<noteq>0"
    obtains i where "s!!i"
    by (metis assms int_no_bits_eq_zero)

  lemma int_bit_bound:
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i \<le> Bits_Integer.log2 s"
  proof (rule ccontr)
    assume "\<not>i\<le>Bits_Integer.log2 s"
    hence "i>Bits_Integer.log2 s" by simp
    hence "i - 1 \<ge> Bits_Integer.log2 s" by simp
    hence "s AND bin_mask (i - 1) = s" by (simp add: int_and_mask `s\<ge>0`)
    hence "\<not> (s!!i)"
      by clarsimp (metis Nat.diff_le_self bin_nth_mask bin_nth_ops(1) leD)
    thus False using `s!!i` ..
  qed

  lemma int_bit_bound':
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i < Bits_Integer.log2 s + 1"
    using assms int_bit_bound by smt

  lemma int_obtain_bit_pos:
    fixes s::int
    assumes "s>0"
    obtains i where "s!!i" "i < Bits_Integer.log2 s + 1"
    by (metis assms int_bit_bound' int_no_bits_eq_zero less_imp_le less_irrefl)

  lemma maxbi_set: fixes s::int shows "s>0 \<Longrightarrow> s!!maxbi s"
    unfolding maxbi_def
    apply (rule int_obtain_bit_pos, assumption)
    apply (rule GreatestI_nat, assumption)
    apply (intro allI impI)
    apply (rule int_bit_bound'[rotated], assumption)
    by auto

  lemma maxbi_max: fixes s::int shows "i>maxbi s \<Longrightarrow> \<not> s!!i"
    oops

  function get_maxbi :: "nat \<Rightarrow> int \<Rightarrow> nat" where
    "get_maxbi n s = (let
        b = 1<<n
      in
        if b\<le>s then get_maxbi (n+1) s
        else n
    )"
    by pat_completeness auto

  termination
    apply (rule "termination"[of "measure (\<lambda>(n,s). nat (s + 1 - (1<<n)))"])
    apply simp
    apply auto
    by (smt bin_mask_ge0 bin_mask_p1_conv_shift)

  partial_function (tailrec)
    bs_iterate_aux :: "nat \<Rightarrow> bitset \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where "bs_iterate_aux i s c f \<sigma> = (
    if s < 1 << i then \<sigma>
    else if \<not>c \<sigma> then \<sigma>
    else if test_bit s i then bs_iterate_aux (i+1) s c f (f i \<sigma>)
    else bs_iterate_aux (i+1) s c f \<sigma>
  )"

  definition bs_iteratei :: "bitset \<Rightarrow> (nat,'\<sigma>) set_iterator" where
    "bs_iteratei s = bs_iterate_aux 0 s"

  definition bs_set_rel_def_internal:
    "bs_set_rel Rk \<equiv>
      if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
  lemma bs_set_rel_def:
    "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
    unfolding bs_set_rel_def_internal relAPP_def by simp

  definition "bs_to_list \<equiv> it_to_list bs_iteratei"

  lemma "(1::int)<<i = 2^i"
    by (simp add: shiftl_int_def)

  lemma
    fixes s :: int
    assumes "s\<ge>0"
    shows "s < 1<<i \<longleftrightarrow> Bits_Integer.log2 s \<le> i"
    using assms
  proof (induct i arbitrary: s)
    case 0 thus ?case by auto
  next
    case (Suc i)
    note GE=`0\<le>s`
    show ?case proof
      assume "s < 1 << Suc i"

      have "s \<le> (s >> 1) BIT 1"

      hence "(s >> 1) < (1<<i)" using GE apply auto
      with Suc.hyps[of "s div 2"]

    apply auto

  lemma "distinct (bs_to_list s)"
    unfolding bs_to_list_def it_to_list_def bs_iteratei_def[abs_def]
  proof -
    {
      fix l i
      assume "distinct l"
      show "distinct (bs_iterate_aux 0 s (\<lambda>_. True) (\<lambda>x l. l @ [x]) [])"

    }

    apply auto

    lemma "set (bs_to_list s) = bs_\<alpha> s"

  lemma autoref_iam_is_iterator[autoref_ga_rules]:
    shows "is_set_to_list nat_rel bs_set_rel bs_to_list"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
    apply clarsimp
    unfolding it_to_sorted_list_def
    apply (refine_rcg refine_vcg)
    apply (simp_all add: bs_set_rel_def br_def)

  proof (clarsimp)

  definition

"iterate s c f \<sigma> \<equiv> let
    i=0;
    b=0;
    (_,_,s) = while
  in

  end"

*)

end


section \<open>Correctness of merge and \<open>are_congruent\<close>: \<close>
theory CC_Abstraction
  imports CC_Helper_Functions
begin

subsection \<open>Abstract formalisation of congruence closure\<close>

text \<open>S is the set of input equations.
The Congruence Closure is the smallest relation that includes S and is closed under reflexivity,
symmetry, transitivity, and under function application.
Source: \<open>https://drops.dagstuhl.de/opus/volltexte/2021/14253/pdf/LIPIcs-FSCD-2021-15.pdf\<close>\<close>

inductive_set Congruence_Closure :: "equation set \<Rightarrow> equation set" for S
  where
    base: "eqt \<in> S \<Longrightarrow> eqt \<in> Congruence_Closure S"
  | reflexive: "(a \<approx> a) \<in> Congruence_Closure S"
  | symmetric: "(a \<approx> b) \<in> Congruence_Closure S \<Longrightarrow> (b \<approx> a) \<in> Congruence_Closure S"
  | transitive1: "(a \<approx> b) \<in> Congruence_Closure S \<Longrightarrow> (b \<approx> c) \<in> Congruence_Closure S
\<Longrightarrow> (a \<approx> c) \<in> Congruence_Closure S"
  | transitive2: "(F a\<^sub>1 a\<^sub>2 \<approx> b) \<in> Congruence_Closure S \<Longrightarrow> (b \<approx> c) \<in> Congruence_Closure S
\<Longrightarrow> (F a\<^sub>1 a\<^sub>2 \<approx> c) \<in> Congruence_Closure S"
  | transitive3: "(F a\<^sub>1 a\<^sub>2 \<approx> a) \<in> Congruence_Closure S
\<Longrightarrow> (a\<^sub>1 \<approx> b\<^sub>1) \<in> Congruence_Closure S \<Longrightarrow> (a\<^sub>2 \<approx> b\<^sub>2) \<in> Congruence_Closure S
\<Longrightarrow> (F b\<^sub>1 b\<^sub>2 \<approx> a) \<in> Congruence_Closure S"
  | monotonic: "(F a\<^sub>1 a\<^sub>2 \<approx> a) \<in> Congruence_Closure S \<Longrightarrow> (F a\<^sub>1 a\<^sub>2 \<approx> b) \<in> Congruence_Closure S
\<Longrightarrow> (a \<approx> b) \<in> Congruence_Closure S"

declare Congruence_Closure.intros[intro]

definition CC_union :: "equation set \<Rightarrow> equation \<Rightarrow> equation set"
  where
    "CC_union CC eq' = Congruence_Closure (CC \<union> {eq'})"

lemma Congruence_Closure_union:
  "Congruence_Closure S \<subseteq> Congruence_Closure (S \<union> S')"
proof
  fix x
  show "x \<in> Congruence_Closure S \<Longrightarrow> x \<in> Congruence_Closure (S \<union> S')"
    apply(induction rule: Congruence_Closure.induct)
    by auto
qed

lemma Congruence_Closure_union':
  "Congruence_Closure S \<subseteq> Congruence_Closure (S' \<union> S)"
  by (metis Congruence_Closure_union sup_commute)

lemma Congruence_Closure_split_rule:
  assumes "k \<notin> B \<Longrightarrow> k \<in> Congruence_Closure A"
  shows "k \<in> Congruence_Closure (A \<union> B)"
  using assms Congruence_Closure_union by blast

lemma CC_union_correct:
  "CC_union (Congruence_Closure S) eq' = Congruence_Closure (S \<union> {eq'})"
proof
  show "CC_union (Congruence_Closure S) eq' \<subseteq> Congruence_Closure (S \<union> {eq'})"
  proof
    fix x
    show "x \<in> CC_union (Congruence_Closure S) eq' \<Longrightarrow> x \<in> Congruence_Closure (S \<union> {eq'})"
      unfolding CC_union_def
      apply(induction x rule: Congruence_Closure.induct)
      using base Congruence_Closure_union by blast+
  qed
next
  show "Congruence_Closure (S \<union> {eq'}) \<subseteq> CC_union (Congruence_Closure S) eq'"
  proof
    fix x
    show "x \<in> Congruence_Closure (S \<union> {eq'}) \<Longrightarrow> x \<in> CC_union (Congruence_Closure S) eq'"
      apply(induction x rule: Congruence_Closure.induct)
      unfolding CC_union_def
      by auto
  qed
qed

lemma Congruence_Closure_not_empty_F:
  "(F a b \<approx> c) \<in> Congruence_Closure A \<Longrightarrow> A \<noteq> {}"
  apply(induction "(F a b \<approx> c)" arbitrary: a b c rule: Congruence_Closure.induct)
  by auto

lemma Congruence_Closure_not_empty:
  "(a \<approx> b) \<in> Congruence_Closure A \<Longrightarrow> a \<noteq> b \<Longrightarrow> A \<noteq> {}"
  apply(induction "(a \<approx> b)" arbitrary: a b rule: Congruence_Closure.induct)
  using Congruence_Closure_not_empty_F by auto

lemma Congruence_Closure_empty_aux:
  "x \<in> Congruence_Closure A \<Longrightarrow> A = {} \<Longrightarrow> (\<exists> a . x = (a \<approx> a))"
  apply(induction x arbitrary: rule: Congruence_Closure.induct)
  by auto

lemma Congruence_Closure_empty:
  "x \<in> Congruence_Closure {} \<longleftrightarrow> (\<exists> a . x = (a \<approx> a))"
proof
  from Congruence_Closure_empty_aux show "x \<in> Congruence_Closure {} \<Longrightarrow> \<exists>a. x = (a \<approx> a)"
    by blast
  from Congruence_Closure.intros show "\<exists>a. x = (a \<approx> a) \<Longrightarrow> x \<in> Congruence_Closure {}"
    by blast
qed

lemma Congruence_Closure_imp:
  assumes "x \<in> Congruence_Closure A" "\<And> a. a \<in> A \<Longrightarrow> a \<in> Congruence_Closure B"
  shows "x \<in> Congruence_Closure B"
  using assms apply(induction x rule: Congruence_Closure.induct)
  by auto

lemma Congruence_Closure_monotonic:
  "S \<subseteq> S' \<Longrightarrow> Congruence_Closure S \<subseteq> Congruence_Closure S'"
proof
  fix x
  assume subset: "S \<subseteq> S'"
  show "x \<in> Congruence_Closure S \<Longrightarrow> x \<in> Congruence_Closure S'"
    apply(rule Congruence_Closure_imp)
    using subset by blast+
qed

text \<open>Rule to find if the congruence closure of two sets is equal\<close>
lemma Congruence_Closure_eq[case_names left right]:
  assumes "\<And> a. a \<in> A \<Longrightarrow> a \<in> Congruence_Closure B"
    "\<And> b. b \<in> B \<Longrightarrow> b \<in> Congruence_Closure A"
  shows "Congruence_Closure A = Congruence_Closure B"
proof(standard)
  show "Congruence_Closure A \<subseteq> Congruence_Closure B"
  proof
    fix x
    assume CC_A: "x \<in> Congruence_Closure A"
    show "x \<in> Congruence_Closure B"
      using CC_A Congruence_Closure_imp assms(1) by blast
  qed
next
  show "Congruence_Closure B \<subseteq> Congruence_Closure A"
  proof
    fix x
    assume CC_B: "x \<in> Congruence_Closure B"
    show "x \<in> Congruence_Closure A"
      using CC_B Congruence_Closure_imp assms(2) by blast
  qed
qed

fun valid_vars :: "equation \<Rightarrow> nat \<Rightarrow> bool"
  where
    "valid_vars (a \<approx> b) n = (a < n \<and> b < n)"
  | "valid_vars (F a b \<approx> c) n = (a < n \<and> b < n \<and> c < n)"

fun valid_vars_pending :: "pending_equation \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "valid_vars_pending (One (a \<approx> b)) l = (valid_vars (a \<approx> b) (length l))"
  | "valid_vars_pending (Two (F a\<^sub>1 a\<^sub>2 \<approx> a) (F b\<^sub>1 b\<^sub>2 \<approx> b)) l =
        (valid_vars (F a\<^sub>1 a\<^sub>2 \<approx> a) (length l) \<and> valid_vars (F b\<^sub>1 b\<^sub>2 \<approx> b) (length l)
\<and> rep_of l a\<^sub>1 = rep_of l b\<^sub>1 \<and> rep_of l a\<^sub>2 = rep_of l b\<^sub>2)"
  | "valid_vars_pending _ _ = False"

lemma valid_vars_pending_iff:
  "valid_vars_pending a l \<longleftrightarrow> (\<exists> b c . b < length l \<and> c < length l \<and> a = (One (b \<approx> c))) \<or>
(\<exists> b c d e f g . b < length l \<and> c < length l \<and> d < length l \<and> e < length l \<and> f < length l
 \<and> g < length l \<and> a = (Two (F b c \<approx> d) (F e f \<approx> g))
\<and> rep_of l b = rep_of l e \<and> rep_of l c = rep_of l f)"
  (is "?P \<longleftrightarrow> ?Q")
proof
  show "?P \<Longrightarrow> ?Q" apply(cases a)
    using valid_vars_pending.elims(2) apply fastforce
    using valid_vars_pending.elims by (metis pending_equation.distinct(1) valid_vars.simps(2))
  show "?Q \<Longrightarrow> ?P"
    apply(cases a)
    by auto
qed

lemma valid_vars_pending_cases[consumes 1, case_names One Two]:
  assumes "valid_vars_pending eq l"
  obtains a b where "eq = One (a \<approx> b)" "a < length l" "b < length l"
  | a\<^sub>1 a\<^sub>2 a b\<^sub>1 b\<^sub>2 b where "eq = Two (F a\<^sub>1 a\<^sub>2 \<approx> a) (F b\<^sub>1 b\<^sub>2 \<approx> b)"
    "a\<^sub>1 < length l" "a\<^sub>2 < length l" "a < length l" "b\<^sub>1 < length l" "b\<^sub>2 < length l" "b < length l"
    "rep_of l a\<^sub>1 = rep_of l b\<^sub>1" "rep_of l a\<^sub>2 = rep_of l b\<^sub>2"
  using assms valid_vars_pending_iff by force

abbreviation nr_vars :: "congruence_closure \<Rightarrow> nat"
  where
    "nr_vars cc \<equiv> length (cc_list cc)"

abbreviation cc_list_set :: "nat list \<Rightarrow> equation set"
  where
    "cc_list_set l \<equiv> {a \<approx> rep_of l a |a. a < length l \<and> l ! a \<noteq> a}"

abbreviation lookup_entries_set :: "congruence_closure \<Rightarrow> equation set"
  where
    "lookup_entries_set cc \<equiv> {F a' b' \<approx> rep_of (cc_list cc) c | a' b' c c\<^sub>1 c\<^sub>2 . a' < nr_vars cc
                      \<and> b' < nr_vars cc \<and> c < nr_vars cc \<and>
                      cc_list cc ! a' = a' \<and> cc_list cc ! b' = b'
                      \<and> lookup cc ! a' ! b' = Some (F c\<^sub>1 c\<^sub>2 \<approx> c)}"

definition representativeE :: "congruence_closure \<Rightarrow> equation set"
  where
    "representativeE cc = cc_list_set (cc_list cc) \<union> lookup_entries_set cc"

text \<open>Converts the list of pending equations to a set of pending equations.\<close>
fun pending_set :: "pending_equation list \<Rightarrow> equation set"
  where
    "pending_set [] = {}"
  | "pending_set (a # xs) = {left a \<approx> right a} \<union> pending_set xs"

lemma pending_set_empty_iff_pending_empty:
  "pending_set pe = {} \<longleftrightarrow> pe = []"
proof
  show "pending_set pe = {} \<Longrightarrow> pe = []"
    apply(induction pe rule: pending_set.induct)
    by (simp_all)
  show "pe = [] \<Longrightarrow> pending_set pe = {}" by simp
qed

lemma pending_set_union:
  "pending_set (xs @ ys) = pending_set xs \<union> pending_set ys"
  apply(induction xs rule: pending_set.induct)
  by simp_all

lemma pending_set_Cons:
  "pending_set (x # ys) = pending_set [x] \<union> pending_set ys"
  by (metis append.left_neutral append_Cons pending_set_union)

lemma pending_set_union':
  "a \<in> pending_set (xs @ ys) \<longleftrightarrow> a \<in> pending_set xs \<or> a \<in> pending_set ys"
  by (simp add: pending_set_union)

lemma pending_set_Constant:
  assumes "eq \<in> pending_set pe"
  obtains a b where "eq = (a \<approx> b)"
  using assms apply(induction rule: pending_set.induct)
  by auto

subsection \<open>Invariants  definitions\<close>
text \<open>As described in the paper\<close>

text \<open>For \<open>cc_list_invar\<close> we use \<open>ufa_invar\<close>\<close>

definition cc_list_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "cc_list_invar cc = ufa_invar (cc_list cc)"

text \<open>for each representative i, UseList (i) is a list of input equations \<open>f(b\<^sub>1, b\<^sub>2)=b\<close>
such that i is the representative of \<open>b\<^sub>1\<close> or of \<open>b\<^sub>2\<close> (or of both).\<close>
abbreviation use_list_valid_element
  where
    "use_list_valid_element u_i_j l i \<equiv>
    (\<exists> b\<^sub>1 b\<^sub>2 b . u_i_j = (F b\<^sub>1 b\<^sub>2 \<approx> b) \<and>
      ((i = rep_of l b\<^sub>1) \<or> i = rep_of l b\<^sub>2) \<and>
      (b\<^sub>1 < length l \<and> b\<^sub>2 < length l \<and> b < length l)
  )"

definition use_list_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "use_list_invar cc \<equiv>
(\<forall> i < nr_vars cc .
    (cc_list cc) ! i = i \<longrightarrow> (\<forall> j < length ((use_list cc) ! i) .
      use_list_valid_element ((use_list cc) ! i ! j) (cc_list cc) i
  )
)"

text \<open>for all pairs of representatives (i, j), Lookup(i, j) is some input equation
\<open>f(a\<^sub>1, a\<^sub>2)=a\<close> such that i and j are the current respective representatives of \<open>a\<^sub>1\<close> and \<open>a\<^sub>2\<close> whenever
such an equation exists. Otherwise, Lookup(i, j) is \<open>\<bottom>\<close>\<close>
abbreviation lookup_invar_correctness :: "congruence_closure \<Rightarrow> bool"
  where
    "lookup_invar_correctness cc \<equiv> (\<forall> i < nr_vars cc .
  (\<forall> j < nr_vars cc .
    (cc_list cc) ! i = i \<and> (cc_list cc) ! j = j \<longrightarrow>
    lookup_valid_element (lookup cc) (cc_list cc) i j
  )
)"

text \<open>Lookup is also a square matrix.\<close>
definition lookup_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "lookup_invar cc \<equiv> lookup_invar_correctness cc
                        \<and> quadratic_table (lookup cc)"

text \<open>This invariant is needed for the termination proof of \<open>add_edge\<close>:\<close>

definition proof_forest_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "proof_forest_invar cc \<equiv> ufa_invar (proof_forest cc)"

text \<open>The equations in pending can only be of these specific forms:\<close>

definition pending_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "pending_invar cc \<equiv> (\<forall> i < length (pending cc) .
                          valid_vars_pending ((pending cc) ! i) (cc_list cc))"

lemma pending_invar_Cons:
  "pending_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = (pe # xs), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
\<longleftrightarrow>
pending_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = xs, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
\<and> valid_vars_pending pe l"
  (is "?left \<longleftrightarrow> ?right")
proof
  show "?left \<Longrightarrow> ?right"
    unfolding pending_invar_def congruence_closure.select_convs
    by fastforce
next
  show "?right \<Longrightarrow> ?left"
    unfolding pending_invar_def congruence_closure.select_convs
    by (metis in_set_conv_nth set_ConsD)
qed

lemma pending_left_right_valid':
  assumes valid: "valid_vars_pending pe l"
  shows "right pe < length l \<and> left pe < length l"
proof(cases pe)
  case (One x1)
  with One valid obtain x11 x12 where Constants: "x1 = (x11 \<approx> x12)"
    by (metis equation.exhaust valid_vars_pending.simps(3))
  with One have "left pe = x11" by simp
  with Constants One valid show ?thesis by auto
next
  case (Two x21 x22)
  with valid obtain x211 x212 x213 x221 x222 x223
    where Function: "x21 = (F x211 x212 \<approx> x213)"  "x22 = (F x221 x222 \<approx> x223)"
    by (metis Two equation.exhaust valid_vars_pending.simps(4) valid_vars_pending.simps(5))
  then show ?thesis using Two valid by auto
qed

lemma pending_left_right_valid:
  assumes "pending_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = (pe # xs), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
  shows "right pe < length l \<and> left pe < length l"
  using assms pending_left_right_valid'
  unfolding pending_invar_def congruence_closure.select_convs
  by (metis in_set_conv_nth list.set_intros(1))

text \<open>The second invariant from the article, very important for the correctness proof.\<close>

definition correctness_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "correctness_invar cc \<equiv>
Congruence_Closure (representativeE cc \<union> pending_set (pending cc)) = Congruence_Closure (input cc)"

text \<open>The union find data structure and the proof forest have the same equivalence classes. \<close>
abbreviation pf_l_same_eq_classes :: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "pf_l_same_eq_classes pf l \<equiv> (\<forall> i < length pf . (\<forall> j < length pf . rep_of l i = rep_of l j
\<longleftrightarrow> rep_of pf i = rep_of pf j))"

definition same_eq_classes_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "same_eq_classes_invar cc \<equiv> pf_l_same_eq_classes (proof_forest cc) (cc_list cc)"

lemma same_eq_classes_invar_not_divided:
  assumes "i < length (proof_forest cc)" "j < length (proof_forest cc)" "same_eq_classes_invar cc"
  shows "rep_of (cc_list cc) i = rep_of (cc_list cc) j \<longleftrightarrow> rep_of (proof_forest cc) i = rep_of (proof_forest cc) j"
  using assms unfolding same_eq_classes_invar_def by presburger

lemma same_eq_classes_invar_divided:
  assumes "i < length pf" "j < length pf"
    "same_eq_classes_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
  shows "rep_of l i = rep_of l j \<longleftrightarrow> rep_of pf i = rep_of pf j"
  using assms unfolding same_eq_classes_invar_def congruence_closure.select_convs by blast

text \<open>The lists in the data structure all have the same length.\<close>
definition same_length_invar :: "congruence_closure \<Rightarrow> nat \<Rightarrow> bool"
  where
    "same_length_invar cc n \<equiv>
(((nr_vars cc = n \<and> length (use_list cc) = n) \<and> length (lookup cc) = n) \<and>
length (proof_forest cc) = n) \<and> length (pf_labels cc) = n"

text \<open>The following two invariants are important for the proofs about correctness_invar:\<close>
text \<open>All equations in the lookup table are also present in both relevant use_lists.\<close>

abbreviation contains_similar_equation
  where
    "contains_similar_equation cc a' c\<^sub>1 c\<^sub>2 c
\<equiv>
(\<exists> b\<^sub>1 b\<^sub>2 b.
    (F b\<^sub>1 b\<^sub>2 \<approx> b) \<in> set ((use_list cc) ! a')
      \<and> rep_of (cc_list cc) b\<^sub>1 = rep_of (cc_list cc) c\<^sub>1
      \<and> rep_of (cc_list cc) b\<^sub>2 = rep_of (cc_list cc) c\<^sub>2
      \<and> (b \<approx> c) \<in> Congruence_Closure (cc_list_set (cc_list cc) \<union> pending_set (pending cc))
  )
"

definition lookup_invar2 :: "congruence_closure \<Rightarrow> bool"
  where
    "lookup_invar2 cc  = (\<forall> a' b' c c\<^sub>1 c\<^sub>2.
a' < nr_vars cc \<longrightarrow> b' < nr_vars cc \<longrightarrow> (cc_list cc) ! a' = a' \<longrightarrow> (cc_list cc) ! b' = b'
\<longrightarrow> (lookup cc) ! a' ! b' = Some (F c\<^sub>1 c\<^sub>2 \<approx> c)
\<longrightarrow>
  contains_similar_equation cc a' c\<^sub>1 c\<^sub>2 c
 \<and>
  contains_similar_equation cc b' c\<^sub>1 c\<^sub>2 c
)"

text \<open>All equations in the use list are also in the lookup table.\<close>
definition use_list_invar2' :: "congruence_closure \<Rightarrow> equation list \<Rightarrow> bool"
  where
    "use_list_invar2' cc u_a = (\<forall> a' c\<^sub>1 c\<^sub>2 c.
a' < nr_vars cc \<longrightarrow> (cc_list cc) ! a' = a'
\<longrightarrow> (F c\<^sub>1 c\<^sub>2 \<approx> c) \<in> set ((use_list cc) ! a')
\<longrightarrow>
  (\<exists> b\<^sub>1 b\<^sub>2 b.
      (lookup_entry (lookup cc) (cc_list cc) c\<^sub>1 c\<^sub>2 = Some (F b\<^sub>1 b\<^sub>2 \<approx> b)
      \<and>
      (b \<approx> c) \<in> Congruence_Closure (cc_list_set (cc_list cc) \<union> pending_set (pending cc)))
    \<or>
      ((F b\<^sub>1 b\<^sub>2 \<approx> b) \<in> set u_a
      \<and> rep_of (cc_list cc) b\<^sub>1 = rep_of (cc_list cc) c\<^sub>1
      \<and> rep_of (cc_list cc) b\<^sub>2 = rep_of (cc_list cc) c\<^sub>2)
      \<and> (b \<approx> c) \<in> Congruence_Closure (cc_list_set (cc_list cc) \<union> pending_set (pending cc))
  )
)"

abbreviation use_list_invar2 :: "congruence_closure \<Rightarrow> bool"
  where
    "use_list_invar2 cc \<equiv> use_list_invar2' cc []"

lemma use_list_invar2_def: "use_list_invar2 cc = (\<forall> a' c\<^sub>1 c\<^sub>2 c.
a' < nr_vars cc \<longrightarrow> (cc_list cc) ! a' = a'
\<longrightarrow> (F c\<^sub>1 c\<^sub>2 \<approx> c) \<in> set ((use_list cc) ! a')
\<longrightarrow>
  (\<exists> b\<^sub>1 b\<^sub>2 b.
      (lookup_entry (lookup cc) (cc_list cc) c\<^sub>1 c\<^sub>2 = Some (F b\<^sub>1 b\<^sub>2 \<approx> b)
      \<and>
      (b \<approx> c) \<in> Congruence_Closure (cc_list_set (cc_list cc) \<union> pending_set (pending cc)))
  )
)" unfolding use_list_invar2'_def
  by simp

text \<open>Invariants needed for the correctness proof of \<open>cc_explain\<close>\<close>

text \<open>The labels of the proof forest are added from the pending list, therefore the
\<open>valid_vars_pending\<close> invariant holds for them too. Additionally, the variables in the label
of an edge correspond to the vertices connected by the edge. \<close>
abbreviation valid_labels_invar :: "pending_equation option list \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "valid_labels_invar pfl pf l \<equiv> (\<forall> n < length pf.
    (pf ! n \<noteq> n
    \<longrightarrow> (\<exists> a a\<^sub>1 a\<^sub>2 b b\<^sub>1 b\<^sub>2 . (pfl ! n = Some (One (a \<approx> b)) \<or>
          pfl ! n = Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a) (F b\<^sub>1 b\<^sub>2 \<approx> b)))
          \<and> (a = pf ! n \<and> b = n \<or> a = n \<and> b = pf ! n)
          \<and> valid_vars_pending (the (pfl ! n)) l
        )) \<and>
    (pf ! n = n \<longrightarrow> pfl ! n = None)
    )"

definition pf_labels_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "pf_labels_invar cc \<equiv> valid_labels_invar (pf_labels cc) (proof_forest cc) (cc_list cc)"

abbreviation cc_invar :: "congruence_closure \<Rightarrow> bool"
  where
    "cc_invar cc \<equiv> (((((((((cc_list_invar cc \<and> use_list_invar cc) \<and> lookup_invar cc)
        \<and> proof_forest_invar cc) \<and> correctness_invar cc) \<and> same_eq_classes_invar cc)
        \<and> same_length_invar cc (nr_vars cc)) \<and> pending_invar cc) \<and> lookup_invar2 cc)
        \<and> use_list_invar2 cc) \<and> pf_labels_invar cc"

text \<open>
(1) Prove that it works for the \<open>"mini_step"\<close>.
(2) Prove that the invariant is preserved by the two cases of \<open>propagate_loop\<close>.
\<close>
lemma propagate_step_induct[consumes 3, case_names base update_pending update_lookup]:
  assumes
    "ufa_invar l" "a < length l" "b < length l"

"P \<lparr>cc_list = ufa_union l a b,
    use_list = u[rep_of l a := []],
    lookup = t,
    pending = pe,
    proof_forest = add_edge pf a b,
    pf_labels = add_label pfl pf a eq,
    input = ip\<rparr>"

"\<And> l u t pe pf pfl ip u1.
P \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
\<Longrightarrow> lookup_Some t l u1
\<Longrightarrow> P \<lparr>cc_list = l, use_list = u, lookup = t,
            pending = link_to_lookup t l u1#pe,
            proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"

"\<And> l u t pe pf pfl ip u1 rep_b.
P \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
\<Longrightarrow> \<not>lookup_Some t l u1
\<Longrightarrow> rep_of l b = rep_b
\<Longrightarrow>
P \<lparr>cc_list = l,
            use_list = u[rep_b := u1#(u ! rep_b)],
            lookup = update_lookup t l u1,
            pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"

shows "P (propagate_step l u t pe pf pfl ip a b eq)"
proof-
  have loop: "P \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
\<Longrightarrow> rep_of l b = rep_b
\<Longrightarrow>
P (propagate_loop rep_b urest
\<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>)"
    for l u t pe pf pfl ip rep_b urest
  proof(induction rep_b urest "\<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
      arbitrary: l u t pe pf pfl ip rule: propagate_loop.induct)
    case (1 rep_b1 u11 urest1 l1 u1 t1 pe1 pf1 pfl1 ip1)
    then have *:"lookup_Some t1 l1 u11 \<Longrightarrow> P \<lparr>cc_list = l1, use_list = u1, lookup = t1, pending = link_to_lookup t1 l1 u11 # pe1, proof_forest = pf1,
             pf_labels = pfl1, input = ip1\<rparr>" using assms
      using "1.hyps"(2) "1.prems"(1) by blast
    then have **: "\<not>lookup_Some t1 l1 u11 \<Longrightarrow> P \<lparr>cc_list = l1, use_list = u1[rep_b1 := u11 # u1 ! rep_b1], lookup = update_lookup t1 l1 u11, pending = pe1,
                    proof_forest = pf1, pf_labels = pfl1, input = ip1\<rparr>" using assms
      using "1.hyps"(2) "1.prems"(1)
      by (simp add: "1.prems"(2) )
    with * 1 show ?case apply(cases "lookup_Some t1 l1 u11")
      by force+
  next
    case (2 uu)
    then show ?case
      by simp
  qed
  have "rep_of l b = rep_of (ufa_union l a b) b"
    using assms ufa_union_aux by auto
  with loop assms show ?thesis
    by force
qed

subsection \<open>Lemmata for \<open>Congruence_Closure\<close> with our \<open>congruence_closure\<close> data structure\<close>

lemma a_eq_rep_of_a_in_CC_cc_list_set:
  assumes "a < length l"
  shows
    "(a \<approx> (rep_of l a)) \<in> Congruence_Closure (cc_list_set l)"
    "((rep_of l a) \<approx> a) \<in> Congruence_Closure (cc_list_set l)"
proof-
  have *: "rep_of l a = a \<Longrightarrow> (a \<approx> (rep_of l a)) \<in> Congruence_Closure (cc_list_set l)"
    by auto
  have "rep_of l a \<noteq> a \<Longrightarrow> (a \<approx> (rep_of l a)) \<in> (cc_list_set l)"
    unfolding representativeE_def
    using assms rep_of_refl by force
  then have "rep_of l a \<noteq> a \<Longrightarrow> (a \<approx> (rep_of l a))
\<in> Congruence_Closure (cc_list_set l)"
    by auto
  with * show "(a \<approx> (rep_of l a)) \<in> Congruence_Closure (cc_list_set l)"
    by blast
  with symmetric show "((rep_of l a) \<approx> a) \<in> Congruence_Closure (cc_list_set l)"
    by simp
qed

lemma a_eq_rep_of_a_in_CC:
  assumes "a < length (cc_list cc)"
  shows
    "(a \<approx> (rep_of (cc_list cc) a)) \<in> Congruence_Closure (representativeE cc)"
    "((rep_of (cc_list cc) a) \<approx> a) \<in> Congruence_Closure (representativeE cc)"
  unfolding representativeE_def using assms Congruence_Closure_union a_eq_rep_of_a_in_CC_cc_list_set
  by blast+

lemma CC_F_rep_of_a_imp_F_a:
  assumes "(F (rep_of (cc_list cc) a) (rep_of (cc_list cc) b) \<approx> (rep_of (cc_list cc) c))
\<in> Congruence_Closure (representativeE cc)"
    "a < nr_vars cc" "b < nr_vars cc" "c < nr_vars cc"
  shows "(F a b \<approx> c) \<in> Congruence_Closure (representativeE cc)"
proof-
  from assms a_eq_rep_of_a_in_CC have
    "((rep_of (cc_list cc) a) \<approx> a) \<in> Congruence_Closure (representativeE cc)"
    "((rep_of (cc_list cc) b) \<approx> b) \<in> Congruence_Closure (representativeE cc)"
    "((rep_of (cc_list cc) c) \<approx> c) \<in> Congruence_Closure (representativeE cc) "
    by blast+
  with assms show ?thesis by blast
qed

lemma CC_rep_of_a_imp_a:
  assumes "((rep_of (cc_list cc) a) \<approx> (rep_of (cc_list cc) c))
\<in> Congruence_Closure (representativeE cc) "
    "a < nr_vars cc" "c < nr_vars cc"
  shows "(a \<approx> c) \<in> Congruence_Closure (representativeE cc)"
proof-
  from assms a_eq_rep_of_a_in_CC have
    "((rep_of (cc_list cc) a) \<approx> a) \<in> Congruence_Closure (representativeE cc)"
    "((rep_of (cc_list cc) c) \<approx> c) \<in> Congruence_Closure (representativeE cc)"
    by blast+
  with assms show ?thesis by blast
qed

lemma CC_lookup_entry_in_CC:
  assumes "lookup_invar cc"
    "(cc_list cc) ! a = a" "(cc_list cc) ! b = b" "(lookup cc) ! a ! b = Some (F c\<^sub>1 c\<^sub>2 \<approx> c)"
    "a < nr_vars cc" "b < nr_vars cc" "c < nr_vars cc"
  shows "(F c\<^sub>1 c\<^sub>2 \<approx> c) \<in> Congruence_Closure (representativeE cc)"
proof-
  from assms base have base:
    "(F a b \<approx> rep_of (cc_list cc) c) \<in> Congruence_Closure (representativeE cc)"
    unfolding representativeE_def
    by simp
  from assms  have "c\<^sub>1 < nr_vars cc" "c\<^sub>2 < nr_vars cc" "c < nr_vars cc"
    unfolding lookup_invar_def
    by (metis equation.inject(2) option.distinct(1) option.inject)+
  with assms a_eq_rep_of_a_in_CC have rep:
    "((rep_of (cc_list cc) c\<^sub>1) \<approx> c\<^sub>1) \<in> Congruence_Closure (representativeE cc)"
    "((rep_of (cc_list cc) c\<^sub>2) \<approx> c\<^sub>2) \<in> Congruence_Closure (representativeE cc)"
    "((rep_of (cc_list cc) c) \<approx> c) \<in> Congruence_Closure (representativeE cc)"
    by blast+
  from assms have a_b: "rep_of (cc_list cc) c\<^sub>1 = a" "rep_of (cc_list cc) c\<^sub>2 = b" unfolding lookup_invar_def
    by (metis equation.inject(2) option.distinct(1) option.inject)+
  have "(F c\<^sub>1 c\<^sub>2 \<approx> rep_of (cc_list cc) c) \<in> Congruence_Closure (representativeE cc)"
    using a_b(1) a_b(2) local.base rep by blast
  with assms show ?thesis using rep
    by fast
qed

lemma CC_same_rep_cc_list_set:
  assumes "rep_of l a = rep_of l b"
    "a < length l" "b < length l"
  shows "(a \<approx> b) \<in> Congruence_Closure (cc_list_set l)"
proof-
  have "(a \<approx> rep_of l a) \<in> Congruence_Closure (cc_list_set l)"
    "(rep_of l b \<approx> b) \<in> Congruence_Closure (cc_list_set l)"
     apply (simp add: a_eq_rep_of_a_in_CC_cc_list_set(1) assms(2))
    by (simp add: a_eq_rep_of_a_in_CC_cc_list_set(2) assms(3))
  then show ?thesis
    using assms(1) by auto
qed

lemma CC_same_rep:
  assumes "rep_of (cc_list cc) a = rep_of (cc_list cc) b"
    "a < nr_vars cc" "b < nr_vars cc"
  shows "(a \<approx> b) \<in> Congruence_Closure (representativeE cc)"
  using CC_same_rep_cc_list_set assms Congruence_Closure_union
  unfolding representativeE_def
  by blast

lemma pending_a_b_in_Congruence_Closure:
  assumes "valid_vars_pending eq (cc_list cc)" "a = left eq" "b = right eq"
  shows "(a \<approx> b) \<in> Congruence_Closure (representativeE cc \<union> pending_set [eq])"
  using assms(1) apply(induction rule: valid_vars_pending_cases)
  using assms base by auto

lemma pending_a_b_in_Congruence_Closure':
  assumes "a = left eq" "b = right eq"
  shows "(a \<approx> b) \<in> Congruence_Closure (representativeE cc \<union> pending_set (eq # pe))"
  using UnI1 assms by auto

subsection \<open>These functions preserve the length of the parameters.\<close>

lemma add_edge_preserves_length:
  "add_edge_dom (pf, a, b) \<Longrightarrow> length (add_edge pf a b) = length pf"
  apply(induction pf a b rule: add_edge.pinduct)
  by (simp add: add_edge.psimps)

lemma add_edge_preserves_length':
  assumes "ufa_invar pf" "a < length pf" "b < length pf" "rep_of pf a \<noteq> rep_of pf b"
  shows "length (add_edge pf a b) = length pf"
  using add_edge_domain add_edge_preserves_length assms by blast

lemma add_label_preserves_length:
  "add_label_dom (pfl, pf, a, eq) \<Longrightarrow> length (add_label pfl pf a eq) = length pfl"
  apply(induction pfl pf a eq rule: add_label.pinduct)
  by (simp add: add_label.psimps)

lemma add_label_preserves_length':
  assumes "ufa_invar pf" "a < length pf"
  shows "length (add_label pfl pf a eq) = length pfl"
  using add_label_domain add_label_preserves_length assms by blast

lemma update_lookup_preserves_length:
  shows "length (update_lookup t l eq) = length t"
  apply(cases eq)
  by auto

lemma add_edge_same_eq_classes_invar_invar:
  assumes  "pf_l_same_eq_classes pf l" "ufa_invar pf" "ufa_invar l"
    "a < length l" "b < length l"
    "rep_of l a \<noteq> rep_of l b" "length pf = length l"
  shows "pf_l_same_eq_classes (add_edge pf a b) (ufa_union l a b)"
proof(standard, standard, standard, standard)
  fix i j
  assume i_j: "i < length (add_edge pf a b)" "j < length (add_edge pf a b)"
  from assms have "add_edge_dom (pf, a, b)"
    using add_edge_domain by auto
  then have "length (add_edge pf a b) = length pf"
    by (simp add: add_edge_preserves_length)
  then show "(rep_of (ufa_union l a b) i = rep_of (ufa_union l a b) j) =
           (rep_of (add_edge pf a b) i = rep_of (add_edge pf a b) j)"
    using assms i_j rep_of_add_edge_aux ufa_union_aux by auto
qed

subsection \<open>Additional helper lemmata\<close>

lemma update_lookup_unchanged:
  assumes "rep_of l c\<^sub>1 \<noteq> a' \<or> rep_of l c\<^sub>2 \<noteq> b'"
  shows "update_lookup t l (F c\<^sub>1 c\<^sub>2 \<approx> c) ! a' ! b' = t ! a' ! b'"
  using assms unfolding update_lookup.simps
  by (metis nth_list_update_eq nth_list_update_neq nth_update_invalid)

lemma update_lookup_unchanged':
  assumes "\<not> lookup_Some t l (F d\<^sub>1 d\<^sub>2 \<approx> d)"
    "lookup_entry t l c\<^sub>1 c\<^sub>2 = Some (F b\<^sub>1 b\<^sub>2 \<approx> ba)"
  shows "lookup_entry (update_lookup t l (F d\<^sub>1 d\<^sub>2 \<approx> d)) l c\<^sub>1 c\<^sub>2 = lookup_entry t l c\<^sub>1 c\<^sub>2"
proof(cases "rep_of l c\<^sub>1 = rep_of l d\<^sub>1 \<and> rep_of l c\<^sub>2 = rep_of l d\<^sub>2")
  case True
  then have "lookup_Some t l (F c\<^sub>1 c\<^sub>2 \<approx> c)" for c
    using assms(2) by fastforce
  with True have "lookup_Some t l (F d\<^sub>1 d\<^sub>2 \<approx> c)" for c
    unfolding lookup_Some.simps
    by simp
  with assms(1) show ?thesis
    by simp
next
  case False
  then show ?thesis using update_lookup_unchanged assms
    by metis
qed

lemma lookup_step_unchanged_step:
  assumes "ufa_invar l" "a < length l" "b < length l"
    "t ! a' ! b' = Some (F c\<^sub>1 c\<^sub>2 \<approx> c)"
  shows "(lookup (propagate_step l u t pe pf pfl ip a b eq)) ! a' ! b' = t ! a' ! b'"
  using assms proof(induction rule: propagate_step_induct)
  case base
  then show ?case
    by simp
next
  case (update_pending l u t pe pf pfl ip u1)
  then show ?case
    by auto
next
  case (update_lookup l u t pe pf pfl ip u1 rep_b)
  then show ?case proof(cases u1)
    case (Constants x11 x12)
    then show ?thesis
      using update_lookup.IH update_lookup.prems by auto
  next
    case (Function x21 x22 x23)
    then show ?thesis
      by (metis congruence_closure.select_convs(3) is_none_code(2) lookup_Some.simps(1) update_lookup.IH update_lookup.hyps(1) update_lookup.prems update_lookup_unchanged)
  qed
qed

lemma use_list_invar_function:
  assumes "use_list_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "i < length l" "j < length (u ! i)" "l ! i = i"
  obtains a\<^sub>1 a\<^sub>2 a where "(u ! i) ! j = (F a\<^sub>1 a\<^sub>2 \<approx> a)"
  using assms unfolding use_list_invar_def by fastforce

lemma use_list_invar_less_n:
  assumes "use_list_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe,  proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "i < length l" "j < length (u ! i)" "l ! i = i" "(u ! i) ! j = (F a b \<approx> c)"
  shows "a < length l" "b < length l" "c < length l"
  using assms unfolding use_list_invar_def by fastforce+

lemma use_list_invar_less_n_in_set:
  assumes "use_list_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe,  proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "i < length l" "(F a b \<approx> c) \<in> set (u ! i)" "l ! i = i"
  shows "a < length l" "b < length l" "c < length l"
  using assms use_list_invar_less_n by (metis in_set_conv_nth)+

lemma use_list_invar_less_n_in_set':
  assumes "use_list_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe,  proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "ufa_invar l" "i < length l" "eq \<in> set (u ! rep_of l i)"
  obtains a\<^sub>1 a\<^sub>2 a where "eq = (F a\<^sub>1 a\<^sub>2 \<approx> a)" "a\<^sub>1 < length l" "a\<^sub>2 < length l" "a < length l"
proof-
  have "rep_of l i < length l" "l ! rep_of l i = rep_of l i"
     apply (simp add: assms(2) assms(3) rep_of_bound)
    by (simp add: assms(2) assms(3) rep_of_root)
  with assms that show ?thesis unfolding use_list_invar_def
    by (metis congruence_closure.select_convs(1,2) in_set_conv_nth)
qed

lemma use_list_invar_rep_eq_i:
  assumes "use_list_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "i < length l"  "l ! i = i" "(F a b \<approx> c) \<in> set (u ! i)"
  shows "rep_of l a = i \<or> rep_of l b = i"
proof-
  from assms(4) obtain j where "j < length (u ! i)" "u ! i ! j = (F a b \<approx> c)"
    by (metis in_set_conv_nth)
  with assms show ?thesis unfolding use_list_invar_def by fastforce
qed

lemma lookup_invar_less_n:
  assumes "lookup_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "(t ! i) ! j = Some (F f g \<approx> h)" "i < length l" "j < length l" "l ! i = i" "l ! j = j"
  shows "f < length l" "g < length l" "h < length l"
  using assms unfolding lookup_invar_def by fastforce+

lemma lookup_invar_valid:
  assumes "lookup_invar \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    "(t ! i) ! j = Some (F f g \<approx> h)" "i < length l" "j < length l" "l ! i = i" "l ! j = j"
  shows "i = rep_of l f" "j = rep_of l g"
  using assms unfolding lookup_invar_def by fastforce+

lemma longest_common_prefix_concat:
  "longest_common_prefix (a @ b) (a @ c) = a @ longest_common_prefix b c"
proof(induction "(a @ b)" "(a @ c)" arbitrary: a b rule: longest_common_prefix.induct)
  case (1 x xs y ys)
  then show ?case
    apply(cases a)
    by auto
qed auto

lemma lowest_common_ancestor_fun_upd:
  assumes "ufa_invar l" "x < length l" "y < length l"
    "l ! a = a" "rep_of l a \<noteq> rep_of l b" "rep_of l x = rep_of l y"
    "a < length l" "b < length l"
  shows "lowest_common_ancestor l x y = lowest_common_ancestor (l[a := b]) x y"
proof-
  have a_root: "a = rep_of l a"
    by (simp add: assms rep_of_refl)
  then show ?thesis
  proof(cases "rep_of l x = rep_of l a")
    case True
    then have *: "path_to_root (l[a := b]) x = path_to_root l b @ path_to_root l x"
      "path_to_root (l[a := b]) y = path_to_root l b @ path_to_root l y"
      using a_root assms path_to_root_fun_upd_root
      by metis+
    then have *: "longest_common_prefix (path_to_root (l[a := b]) x) (path_to_root (l[a := b]) y)
= path_to_root l b @
longest_common_prefix (path_to_root l x) (path_to_root l y)" unfolding *
      by (simp add: longest_common_prefix_concat)
    have "hd (path_to_root l x) = rep_of l x" "hd (path_to_root l y) = rep_of l y"
      using assms path_hd path_to_root_correct by blast+
    with assms have "(path_to_root l x) = [rep_of l x]@tl(path_to_root l x)"
      "(path_to_root l y) = [rep_of l y]@tl(path_to_root l y)"
      by (metis Cons_eq_appendI  empty_append_eq_id len_greater_imp_nonempty list.collapse path_to_root_length)+
    then have "longest_common_prefix (path_to_root l x) (path_to_root l y) =
[rep_of l x] @ longest_common_prefix (tl(path_to_root l x)) (tl(path_to_root l y)) "
      using longest_common_prefix_concat by (metis assms(6))
    then have "longest_common_prefix (path_to_root l x) (path_to_root l y) \<noteq> []"
      by simp
    then show ?thesis
      using * by fastforce
  next
    case False
    then have "path_to_root (l[a := b]) x = path_to_root l x"
      "path_to_root (l[a := b]) y = path_to_root l y"
      by (auto simp add: assms path_to_root_fun_upd' ufa_invar_fun_upd')
    then show ?thesis
      by fastforce
  qed
qed

end


subsection\<open>Natural Deduction\<close>

theory ND
imports Formulas
begin

inductive ND :: "'a formula set \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "\<turnstile>" 30) where
Ax: "F \<in> \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> F" |
NotE: "\<lbrakk>\<Gamma> \<turnstile> Not F; \<Gamma> \<turnstile> F \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> \<bottom>" |
NotI: "F \<triangleright> \<Gamma> \<turnstile> \<bottom> \<Longrightarrow> \<Gamma> \<turnstile> Not F" |
CC: "Not F\<triangleright> \<Gamma> \<turnstile> \<bottom> \<Longrightarrow> \<Gamma> \<turnstile> F" |
AndE1: "\<Gamma> \<turnstile> And F G \<Longrightarrow> \<Gamma> \<turnstile> F" |
AndE2: "\<Gamma> \<turnstile> And F G \<Longrightarrow> \<Gamma> \<turnstile> G" |
AndI: "\<lbrakk> \<Gamma> \<turnstile> F; \<Gamma> \<turnstile> G \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> And F G" |
OrI1: "\<Gamma> \<turnstile> F \<Longrightarrow> \<Gamma> \<turnstile> Or F G" |
OrI2: "\<Gamma> \<turnstile> G \<Longrightarrow> \<Gamma> \<turnstile> Or F G" |
OrE: "\<lbrakk> \<Gamma> \<turnstile> Or F G; F\<triangleright>\<Gamma> \<turnstile> H; G\<triangleright>\<Gamma> \<turnstile> H \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> H" |
ImpI: "F \<triangleright> \<Gamma> \<turnstile> G \<Longrightarrow> \<Gamma> \<turnstile> Imp F G" |
ImpE: "\<lbrakk> \<Gamma> \<turnstile> Imp F G; \<Gamma> \<turnstile> F \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> G"

(* Note that this is not a positive inductive definition because the
predicate occurs negatively in many rules:
inductive ND :: "form \<Rightarrow> bool" ("\<turnstile> _" [30] 30) where
NotE: "\<lbrakk>\<turnstile> Not F; \<turnstile> F \<rbrakk> \<Longrightarrow> \<turnstile> \<bottom>" |
NotI: "\<lbrakk>\<turnstile> F \<Longrightarrow> \<turnstile> \<bottom>\<rbrakk> \<Longrightarrow> \<turnstile> Not F" |
CC: "\<lbrakk>\<turnstile> Not F \<Longrightarrow> \<turnstile> \<bottom>\<rbrakk> \<Longrightarrow> \<turnstile> F" |
AndE1: "\<turnstile> And F G \<Longrightarrow> \<turnstile> F" |
AndE2: "\<turnstile> And F G \<Longrightarrow> \<turnstile> G" |
AndI: "\<lbrakk> \<turnstile> F; \<turnstile> G \<rbrakk> \<Longrightarrow> \<turnstile> And F G" |
OrI1: "\<turnstile> F \<Longrightarrow> \<turnstile> Or F G" |
OrI2: "\<turnstile> G \<Longrightarrow> \<turnstile> Or F G" |
OrE: "\<lbrakk> \<turnstile> Or F G; \<turnstile> F \<Longrightarrow> \<turnstile> H; \<turnstile> G \<Longrightarrow> \<turnstile> H \<rbrakk> \<Longrightarrow> \<turnstile> H" |
ImpI: "\<lbrakk>\<turnstile> F \<Longrightarrow> \<turnstile> G\<rbrakk> \<Longrightarrow> \<turnstile> Imp F G" |
ImpE: "\<lbrakk> \<turnstile> Imp F G; \<turnstile> F \<rbrakk> \<Longrightarrow> \<turnstile> G"
*)

lemma Weaken: "\<lbrakk> \<Gamma> \<turnstile> F; \<Gamma> \<subseteq> \<Gamma>' \<rbrakk> \<Longrightarrow> \<Gamma>' \<turnstile> F"
proof(induct arbitrary: \<Gamma>' rule: ND.induct)
  case (NotI F \<Gamma>) thus ?case using ND.NotI by auto
next
  case Ax thus ?case by(blast intro: ND.Ax)
next
  case NotE thus ?case by(blast intro: ND.NotE)
next
  case CC thus ?case using ND.CC by blast
next
  case AndE1 thus ?case using ND.AndE1 by metis
next
  case AndE2 thus ?case using ND.AndE2 by metis
next
  case AndI thus ?case by (simp add: ND.AndI)
next
  case OrI1 thus ?case using ND.OrI1 by blast
next
  case OrI2 thus ?case using ND.OrI2 by blast
next
  case (OrE \<Gamma> F G H) show ?case apply(insert OrE.prems)
    apply(rule ND.OrE[of \<Gamma>' F G])
      apply(rule OrE.hyps(2)[OF OrE.prems])
     apply(rule OrE.hyps(4); blast)
    apply(rule OrE.hyps(6); blast)
  done
next
  case ImpI thus ?case using ND.ImpI by blast
next
  case ImpE thus ?case using ND.ImpE by metis
qed

lemma BotE (* ex falso *): "\<Gamma> \<turnstile> \<bottom> \<Longrightarrow> \<Gamma> \<turnstile> F"
  by (meson CC subset_insertI Weaken)

lemma Not2E: "Not(Not F)\<triangleright> \<Gamma> \<turnstile> F"
  by (metis CC ND.Ax NotE insertI1 insert_commute)

lemma Not2I: "F\<triangleright>\<Gamma> \<turnstile> Not(Not F)"
  by (metis CC ND.Ax NotE insertI1 insert_commute)

lemma Not2IE: "F\<triangleright>\<Gamma> \<turnstile> G \<Longrightarrow> Not (Not F)\<triangleright> \<Gamma> \<turnstile> G"
  by (meson ImpE ImpI Not2E Weaken subset_insertI)

lemma NDtrans: "\<Gamma> \<turnstile> F \<Longrightarrow> F\<triangleright> \<Gamma> \<turnstile> G \<Longrightarrow> \<Gamma> \<turnstile> G"
  using ImpE ImpI by blast

lemma AndL_sim: "F \<triangleright> G \<triangleright> \<Gamma> \<turnstile> H \<Longrightarrow> And F G \<triangleright> \<Gamma> \<turnstile> H"
  apply(drule Weaken[where \<Gamma>' = "And F G \<triangleright> F \<triangleright> G \<triangleright> \<Gamma>"])
   apply blast
by (metis AndE1 AndE2 ND.Ax NDtrans insertI1 insert_commute)

lemma NotSwap: "Not F\<triangleright> \<Gamma> \<turnstile> G \<Longrightarrow> Not G\<triangleright> \<Gamma> \<turnstile> F"
  using CC NotE insert_commute subset_insertI Weaken by (metis Ax insertI1)
lemma AndR_sim: "\<lbrakk> Not F\<triangleright> \<Gamma> \<turnstile> H; Not G\<triangleright> \<Gamma> \<turnstile> H \<rbrakk> \<Longrightarrow> Not(And F G)\<triangleright> \<Gamma> \<turnstile> H"
  using AndI NotSwap by blast

lemma OrL_sim: "\<lbrakk> F\<triangleright> \<Gamma> \<turnstile> H; G\<triangleright>\<Gamma> \<turnstile> H \<rbrakk> \<Longrightarrow> F \<^bold>\<or> G\<triangleright> \<Gamma> \<turnstile> H"
  using Weaken[where \<Gamma>' = "F\<triangleright> Or F G\<triangleright> \<Gamma>"] Weaken[where \<Gamma>' = "G\<triangleright> Or F G\<triangleright> \<Gamma>"]
  by (meson ND.Ax OrE insertI1 insert_mono subset_insertI)

lemma OrR_sim: "\<lbrakk> \<^bold>\<not> F\<triangleright> \<^bold>\<not> G\<triangleright> \<Gamma> \<turnstile> \<bottom>\<rbrakk> \<Longrightarrow> \<^bold>\<not> (G \<^bold>\<or> F)\<triangleright> \<Gamma> \<turnstile> \<bottom>"
proof -
  assume "\<^bold>\<not> F \<triangleright> \<^bold>\<not> G \<triangleright> \<Gamma> \<turnstile> \<bottom>"
  then have "\<And>f. f \<triangleright> \<^bold>\<not> F \<triangleright> \<^bold>\<not> G \<triangleright> \<Gamma> \<turnstile> \<bottom>" by (meson Weaken subset_insertI)
  then have "\<And>f. \<^bold>\<not> G \<triangleright> \<^bold>\<not> (f \<^bold>\<or> F) \<triangleright> \<Gamma> \<turnstile> \<bottom>" by (metis NDtrans Not2E NotSwap OrI2 insert_commute)
  then show ?thesis by (meson NDtrans Not2I NotSwap OrI1)
qed

lemma ImpL_sim: "\<lbrakk> \<^bold>\<not> F\<triangleright> \<Gamma> \<turnstile> \<bottom>; G\<triangleright> \<Gamma> \<turnstile> \<bottom>\<rbrakk> \<Longrightarrow> F \<^bold>\<rightarrow> G\<triangleright> \<Gamma> \<turnstile> \<bottom>"
  by (meson CC ImpE ImpI ND.Ax Weaken insertI1 subset_insertI)

lemma ImpR_sim: "\<lbrakk> \<^bold>\<not> G\<triangleright> F\<triangleright> \<Gamma> \<turnstile> \<bottom>\<rbrakk> \<Longrightarrow> \<^bold>\<not> (F \<^bold>\<rightarrow> G)\<triangleright> \<Gamma> \<turnstile> \<bottom>"
  by (metis (full_types) ImpI NotSwap insert_commute)

lemma ND_lem: "{} \<turnstile> Not F \<^bold>\<or> F"
  apply(rule CC)
  apply(rule OrE[of _ "Not F" F])
    apply(rule OrI1)
    apply(rule NotI)
    apply(rule NotE[of _ "(\<^bold>\<not> F \<^bold>\<or> F)"]; blast intro: OrI1 OrI2 Ax)+
done

lemma ND_caseDistinction: "\<lbrakk> F\<triangleright>\<Gamma> \<turnstile> H; Not F\<triangleright>\<Gamma> \<turnstile> H \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> H"
  by (meson ND_lem OrE empty_subsetI Weaken)

lemma "\<lbrakk>\<^bold>\<not> F\<triangleright> \<Gamma> \<turnstile> H; G\<triangleright> \<Gamma> \<turnstile> H\<rbrakk> \<Longrightarrow> F \<^bold>\<rightarrow> G\<triangleright> \<Gamma> \<turnstile> H"
  apply(rule ND_caseDistinction[of F])
   apply (meson ImpE ImpI ND.intros(1) Weaken insertI1 subset_insertI)
  apply (metis Weaken insert_commute subset_insertI)
done

lemma ND_deMorganAnd: "{\<^bold>\<not> (F \<^bold>\<and> G)} \<turnstile> \<^bold>\<not> F \<^bold>\<or> \<^bold>\<not> G"
  apply(rule CC)
  apply(rule NotE[of _ "F \<^bold>\<and> G"])
   apply(simp add: Ax; fail)
  apply(rule AndI)
   apply(rule CC)
   apply(rule NotE[of _ "\<^bold>\<not> F \<^bold>\<or> \<^bold>\<not> G"])
    apply(simp add: Ax; fail)
   apply(rule OrI1)
   apply(simp add: Ax; fail)
  apply(rule CC)
   apply(rule NotE[of _ "\<^bold>\<not> F \<^bold>\<or> \<^bold>\<not> G"])
   apply(simp add: Ax; fail)
  apply(rule OrI2)
  apply(simp add: Ax; fail)
done

lemma ND_deMorganOr: "{\<^bold>\<not> (F \<^bold>\<or> G)} \<turnstile> \<^bold>\<not> F \<^bold>\<and> \<^bold>\<not> G"
  apply(rule ND_caseDistinction[of F]; rule ND_caseDistinction[of G])
     apply(rule CC; rule NotE[of _ "F \<^bold>\<or> G"]; simp add: Ax OrI2 OrI1; fail)+
  apply(rule AndI; simp add: Ax; fail)
done

lemma sim_sim: "F\<triangleright> \<Gamma> \<turnstile> H \<Longrightarrow> G\<triangleright>\<Gamma> \<turnstile> F \<Longrightarrow> G\<triangleright> \<Gamma> \<turnstile> H"
  by (meson ImpE ImpI Weaken subset_insertI)
thm sim_sim[where \<Gamma>="{}", rotated, no_vars] (* a bit easier to read? *)

lemma Top_provable[simp,intro!]: "\<Gamma> \<turnstile> \<top>" unfolding Top_def by (intro ND.ImpI ND.Ax) simp

lemma NotBot_provable[simp,intro!]: "\<Gamma> \<turnstile> \<^bold>\<not> \<bottom>" using NotI BotE Ax by blast

lemma Top_useless: "\<Gamma> \<turnstile> F \<Longrightarrow> \<Gamma> - {\<top>} \<turnstile> F"
  by (metis NDtrans Top_provable Weaken insert_Diff_single subset_insertI)

lemma AssmBigAnd: "set G \<turnstile> F \<longleftrightarrow> {} \<turnstile> (\<^bold>\<And>G \<^bold>\<rightarrow> F)"
 proof(induction G arbitrary: F)
    case Nil thus ?case by(fastforce intro: ND.ImpI elim: Weaken ImpE[OF _ NotBot_provable])
  next
    case (Cons G GS) show ?case proof
      assume "set (G # GS) \<turnstile> F"
      hence "set GS \<turnstile> G \<^bold>\<rightarrow> F" by(intro ND.ImpI) simp
      with Cons.IH have *: "{} \<turnstile> \<^bold>\<And> GS \<^bold>\<rightarrow> G \<^bold>\<rightarrow> F" ..
      hence "{G,\<^bold>\<And>GS} \<turnstile> F" proof -
        have *: "{\<^bold>\<And>GS} \<turnstile> G \<^bold>\<rightarrow> F"
          using Weaken[OF * empty_subsetI] ImpE[where \<Gamma>="{\<^bold>\<And> GS}" and F="\<^bold>\<And> GS"] by (simp add: ND.Ax)
        show "{G,\<^bold>\<And>GS} \<turnstile> F" using Weaken[OF *] ImpE[where \<Gamma>="{G,\<^bold>\<And> GS}" and F="G"] ND.Ax by (simp add: ND.Ax)
      qed
      thus "{} \<turnstile> \<^bold>\<And> (G # GS) \<^bold>\<rightarrow> F" by(intro ND.ImpI; simp add: AndL_sim)
    next
      assume "{} \<turnstile> \<^bold>\<And> (G # GS) \<^bold>\<rightarrow> F"
      hence "{G \<^bold>\<and> \<^bold>\<And>GS} \<turnstile> F" using ImpE[OF _ Ax[OF singletonI]] Weaken by fastforce
      hence "{G,\<^bold>\<And>GS} \<turnstile> F" by (meson AndI ImpE ImpI ND.intros(1) Weaken insertI1 subset_insertI)
      hence "{\<^bold>\<And>GS} \<turnstile> G \<^bold>\<rightarrow> F" using ImpI by blast
      hence "{} \<turnstile> \<^bold>\<And> GS \<^bold>\<rightarrow> G \<^bold>\<rightarrow> F" using ImpI by blast
      with Cons.IH have "set GS \<turnstile> G \<^bold>\<rightarrow> F" ..
      thus "set (G # GS) \<turnstile> F" using ImpE Weaken by (metis Ax list.set_intros(1) set_subset_Cons)
  qed
qed

end


(*  Title:      ZF/Induct/PropLog.thy
    Author:     Tobias Nipkow & Lawrence C Paulson
    Copyright   1993  University of Cambridge
*)

section \<open>Meta-theory of propositional logic\<close>

theory PropLog imports ZF begin

text \<open>
  Datatype definition of propositional logic formulae and inductive
  definition of the propositional tautologies.

  Inductive definition of propositional logic.  Soundness and
  completeness w.r.t.\ truth-tables.

  Prove: If \<open>H |= p\<close> then \<open>G |= p\<close> where \<open>G \<in>
  Fin(H)\<close>
\<close>

subsection \<open>The datatype of propositions\<close>

consts
  propn :: i

datatype propn =
    Fls
  | Var ("n \<in> nat")    ("#_" [100] 100)
  | Imp ("p \<in> propn", "q \<in> propn")    (infixr "=>" 90)

subsection \<open>The proof system\<close>

consts thms     :: "i => i"

abbreviation
  thms_syntax :: "[i,i] => o"    (infixl "|-" 50)
  where "H |- p == p \<in> thms(H)"

inductive
  domains "thms(H)" \<subseteq> "propn"
  intros
    H:  "[| p \<in> H;  p \<in> propn |] ==> H |- p"
    K:  "[| p \<in> propn;  q \<in> propn |] ==> H |- p=>q=>p"
    S:  "[| p \<in> propn;  q \<in> propn;  r \<in> propn |]
         ==> H |- (p=>q=>r) => (p=>q) => p=>r"
    DN: "p \<in> propn ==> H |- ((p=>Fls) => Fls) => p"
    MP: "[| H |- p=>q;  H |- p;  p \<in> propn;  q \<in> propn |] ==> H |- q"
  type_intros "propn.intros"

declare propn.intros [simp]

subsection \<open>The semantics\<close>

subsubsection \<open>Semantics of propositional logic.\<close>

consts
  is_true_fun :: "[i,i] => i"
primrec
  "is_true_fun(Fls, t) = 0"
  "is_true_fun(Var(v), t) = (if v \<in> t then 1 else 0)"
  "is_true_fun(p=>q, t) = (if is_true_fun(p,t) = 1 then is_true_fun(q,t) else 1)"

definition
  is_true :: "[i,i] => o"  where
  "is_true(p,t) == is_true_fun(p,t) = 1"
  \<comment> \<open>this definition is required since predicates can't be recursive\<close>

lemma is_true_Fls [simp]: "is_true(Fls,t) \<longleftrightarrow> False"
  by (simp add: is_true_def)

lemma is_true_Var [simp]: "is_true(#v,t) \<longleftrightarrow> v \<in> t"
  by (simp add: is_true_def)

lemma is_true_Imp [simp]: "is_true(p=>q,t) \<longleftrightarrow> (is_true(p,t)\<longrightarrow>is_true(q,t))"
  by (simp add: is_true_def)

subsubsection \<open>Logical consequence\<close>

text \<open>
  For every valuation, if all elements of \<open>H\<close> are true then so
  is \<open>p\<close>.
\<close>

definition
  logcon :: "[i,i] => o"    (infixl "|=" 50)  where
  "H |= p == \<forall>t. (\<forall>q \<in> H. is_true(q,t)) \<longrightarrow> is_true(p,t)"

text \<open>
  A finite set of hypotheses from \<open>t\<close> and the \<open>Var\<close>s in
  \<open>p\<close>.
\<close>

consts
  hyps :: "[i,i] => i"
primrec
  "hyps(Fls, t) = 0"
  "hyps(Var(v), t) = (if v \<in> t then {#v} else {#v=>Fls})"
  "hyps(p=>q, t) = hyps(p,t) \<union> hyps(q,t)"

subsection \<open>Proof theory of propositional logic\<close>

lemma thms_mono: "G \<subseteq> H ==> thms(G) \<subseteq> thms(H)"
  apply (unfold thms.defs)
  apply (rule lfp_mono)
    apply (rule thms.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemmas thms_in_pl = thms.dom_subset [THEN subsetD]

inductive_cases ImpE: "p=>q \<in> propn"

lemma thms_MP: "[| H |- p=>q;  H |- p |] ==> H |- q"
  \<comment> \<open>Stronger Modus Ponens rule: no typechecking!\<close>
  apply (rule thms.MP)
     apply (erule asm_rl thms_in_pl thms_in_pl [THEN ImpE])+
  done

lemma thms_I: "p \<in> propn ==> H |- p=>p"
  \<comment> \<open>Rule is called \<open>I\<close> for Identity Combinator, not for Introduction.\<close>
  apply (rule thms.S [THEN thms_MP, THEN thms_MP])
      apply (rule_tac [5] thms.K)
       apply (rule_tac [4] thms.K)
         apply simp_all
  done

subsubsection \<open>Weakening, left and right\<close>

lemma weaken_left: "[| G \<subseteq> H;  G|-p |] ==> H|-p"
  \<comment> \<open>Order of premises is convenient with \<open>THEN\<close>\<close>
  by (erule thms_mono [THEN subsetD])

lemma weaken_left_cons: "H |- p ==> cons(a,H) |- p"
  by (erule subset_consI [THEN weaken_left])

lemmas weaken_left_Un1  = Un_upper1 [THEN weaken_left]
lemmas weaken_left_Un2  = Un_upper2 [THEN weaken_left]

lemma weaken_right: "[| H |- q;  p \<in> propn |] ==> H |- p=>q"
  by (simp_all add: thms.K [THEN thms_MP] thms_in_pl)

subsubsection \<open>The deduction theorem\<close>

theorem deduction: "[| cons(p,H) |- q;  p \<in> propn |] ==>  H |- p=>q"
  apply (erule thms.induct)
      apply (blast intro: thms_I thms.H [THEN weaken_right])
     apply (blast intro: thms.K [THEN weaken_right])
    apply (blast intro: thms.S [THEN weaken_right])
   apply (blast intro: thms.DN [THEN weaken_right])
  apply (blast intro: thms.S [THEN thms_MP [THEN thms_MP]])
  done

subsubsection \<open>The cut rule\<close>

lemma cut: "[| H|-p;  cons(p,H) |- q |] ==>  H |- q"
  apply (rule deduction [THEN thms_MP])
    apply (simp_all add: thms_in_pl)
  done

lemma thms_FlsE: "[| H |- Fls; p \<in> propn |] ==> H |- p"
  apply (rule thms.DN [THEN thms_MP])
   apply (rule_tac [2] weaken_right)
    apply (simp_all add: propn.intros)
  done

lemma thms_notE: "[| H |- p=>Fls;  H |- p;  q \<in> propn |] ==> H |- q"
  by (erule thms_MP [THEN thms_FlsE])

subsubsection \<open>Soundness of the rules wrt truth-table semantics\<close>

theorem soundness: "H |- p ==> H |= p"
  apply (unfold logcon_def)
  apply (induct set: thms)
      apply auto
  done

subsection \<open>Completeness\<close>

subsubsection \<open>Towards the completeness proof\<close>

lemma Fls_Imp: "[| H |- p=>Fls; q \<in> propn |] ==> H |- p=>q"
  apply (frule thms_in_pl)
  apply (rule deduction)
   apply (rule weaken_left_cons [THEN thms_notE])
     apply (blast intro: thms.H elim: ImpE)+
  done

lemma Imp_Fls: "[| H |- p;  H |- q=>Fls |] ==> H |- (p=>q)=>Fls"
  apply (frule thms_in_pl)
  apply (frule thms_in_pl [of concl: "q=>Fls"])
  apply (rule deduction)
   apply (erule weaken_left_cons [THEN thms_MP])
   apply (rule consI1 [THEN thms.H, THEN thms_MP])
    apply (blast intro: weaken_left_cons elim: ImpE)+
  done

lemma hyps_thms_if:
    "p \<in> propn ==> hyps(p,t) |- (if is_true(p,t) then p else p=>Fls)"
  \<comment> \<open>Typical example of strengthening the induction statement.\<close>
  apply simp
  apply (induct_tac p)
    apply (simp_all add: thms_I thms.H)
  apply (safe elim!: Fls_Imp [THEN weaken_left_Un1] Fls_Imp [THEN weaken_left_Un2])
  apply (blast intro: weaken_left_Un1 weaken_left_Un2 weaken_right Imp_Fls)+
  done

lemma logcon_thms_p: "[| p \<in> propn;  0 |= p |] ==> hyps(p,t) |- p"
  \<comment> \<open>Key lemma for completeness; yields a set of assumptions satisfying \<open>p\<close>\<close>
  apply (drule hyps_thms_if)
  apply (simp add: logcon_def)
  done

text \<open>
  For proving certain theorems in our new propositional logic.
\<close>

lemmas propn_SIs = propn.intros deduction
  and propn_Is = thms_in_pl thms.H thms.H [THEN thms_MP]

text \<open>
  The excluded middle in the form of an elimination rule.
\<close>

lemma thms_excluded_middle:
    "[| p \<in> propn;  q \<in> propn |] ==> H |- (p=>q) => ((p=>Fls)=>q) => q"
  apply (rule deduction [THEN deduction])
    apply (rule thms.DN [THEN thms_MP])
     apply (best intro!: propn_SIs intro: propn_Is)+
  done

lemma thms_excluded_middle_rule:
  "[| cons(p,H) |- q;  cons(p=>Fls,H) |- q;  p \<in> propn |] ==> H |- q"
  \<comment> \<open>Hard to prove directly because it requires cuts\<close>
  apply (rule thms_excluded_middle [THEN thms_MP, THEN thms_MP])
     apply (blast intro!: propn_SIs intro: propn_Is)+
  done

subsubsection \<open>Completeness -- lemmas for reducing the set of assumptions\<close>

text \<open>
  For the case @{prop "hyps(p,t)-cons(#v,Y) |- p"} we also have @{prop
  "hyps(p,t)-{#v} \<subseteq> hyps(p, t-{v})"}.
\<close>

lemma hyps_Diff:
    "p \<in> propn ==> hyps(p, t-{v}) \<subseteq> cons(#v=>Fls, hyps(p,t)-{#v})"
  by (induct set: propn) auto

text \<open>
  For the case @{prop "hyps(p,t)-cons(#v => Fls,Y) |- p"} we also have
  @{prop "hyps(p,t)-{#v=>Fls} \<subseteq> hyps(p, cons(v,t))"}.
\<close>

lemma hyps_cons:
    "p \<in> propn ==> hyps(p, cons(v,t)) \<subseteq> cons(#v, hyps(p,t)-{#v=>Fls})"
  by (induct set: propn) auto

text \<open>Two lemmas for use with \<open>weaken_left\<close>\<close>

lemma cons_Diff_same: "B-C \<subseteq> cons(a, B-cons(a,C))"
  by blast

lemma cons_Diff_subset2: "cons(a, B-{c}) - D \<subseteq> cons(a, B-cons(c,D))"
  by blast

text \<open>
  The set @{term "hyps(p,t)"} is finite, and elements have the form
  @{term "#v"} or @{term "#v=>Fls"}; could probably prove the stronger
  @{prop "hyps(p,t) \<in> Fin(hyps(p,0) \<union> hyps(p,nat))"}.
\<close>

lemma hyps_finite: "p \<in> propn ==> hyps(p,t) \<in> Fin(\<Union>v \<in> nat. {#v, #v=>Fls})"
  by (induct set: propn) auto

lemmas Diff_weaken_left = Diff_mono [OF _ subset_refl, THEN weaken_left]

text \<open>
  Induction on the finite set of assumptions @{term "hyps(p,t0)"}.  We
  may repeatedly subtract assumptions until none are left!
\<close>

lemma completeness_0_lemma [rule_format]:
    "[| p \<in> propn;  0 |= p |] ==> \<forall>t. hyps(p,t) - hyps(p,t0) |- p"
  apply (frule hyps_finite)
  apply (erule Fin_induct)
   apply (simp add: logcon_thms_p Diff_0)
  txt \<open>inductive step\<close>
  apply safe
   txt \<open>Case @{prop "hyps(p,t)-cons(#v,Y) |- p"}\<close>
   apply (rule thms_excluded_middle_rule)
     apply (erule_tac [3] propn.intros)
    apply (blast intro: cons_Diff_same [THEN weaken_left])
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_Diff [THEN Diff_weaken_left])
  txt \<open>Case @{prop "hyps(p,t)-cons(#v => Fls,Y) |- p"}\<close>
  apply (rule thms_excluded_middle_rule)
    apply (erule_tac [3] propn.intros)
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_cons [THEN Diff_weaken_left])
  apply (blast intro: cons_Diff_same [THEN weaken_left])
  done

subsubsection \<open>Completeness theorem\<close>

lemma completeness_0: "[| p \<in> propn;  0 |= p |] ==> 0 |- p"
  \<comment> \<open>The base case for completeness\<close>
  apply (rule Diff_cancel [THEN subst])
  apply (blast intro: completeness_0_lemma)
  done

lemma logcon_Imp: "[| cons(p,H) |= q |] ==> H |= p=>q"
  \<comment> \<open>A semantic analogue of the Deduction Theorem\<close>
  by (simp add: logcon_def)

lemma completeness:
     "H \<in> Fin(propn) ==> p \<in> propn \<Longrightarrow> H |= p \<Longrightarrow> H |- p"
  apply (induct arbitrary: p set: Fin)
   apply (safe intro!: completeness_0)
  apply (rule weaken_left_cons [THEN thms_MP])
   apply (blast intro!: logcon_Imp propn.intros)
  apply (blast intro: propn_Is)
  done

theorem thms_iff: "H \<in> Fin(propn) ==> H |- p \<longleftrightarrow> H |= p \<and> p \<in> propn"
  by (blast intro: soundness completeness thms_in_pl)

end