theory Carries
  imports Bits_Digits
begin

section \<open>Carries in base-b expansions\<close>

text \<open>Some auxiliary lemmas\<close>
lemma rev_induct[consumes 1, case_names base step]:
  fixes i k :: nat
  assumes le: "i \<le> k"
    and base: "P k"
    and step: "\<And>i. i \<le> k \<Longrightarrow> P i \<Longrightarrow> P (i - 1)"
  shows "P i"
proof -
  have "\<And>i::nat. n = k-i \<Longrightarrow> i \<le> k \<Longrightarrow> P i" for n
  proof (induct n)
    case 0
    then have "i = k" by arith
    with base show "P i" by simp
  next
    case (Suc n)
    then have "n = (k - (i + 1))" by arith
    moreover have k: "i + 1 \<le> k" using Suc.prems by arith
    ultimately have "P (i + 1)" by (rule Suc.hyps)
    from step[OF k this] show ?case by simp
  qed
  with le show ?thesis by fast
qed

subsection \<open>Definition of carry received at position k\<close>
text \<open>When adding two numbers m and n, the carry is \emph{introduced}
      at position 1 but is \emph{received} at position 2. The function below
      accounts for the latter case.

\begin{center} \begin{verbatim}
        k: 6 5 4 3 2 1 0
        c:         1
   - - - - - - - - - - - -
        m:   1 0 1 0 1 0
        n:           1 1
    ----------------------
    m + n: 0 1 0 1 1 0 0
\end{verbatim} \end{center} \<close>

definition bin_carry :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bin_carry a b k = (a mod 2^k + b mod 2^k) div 2^k"

text \<open>Carry in the subtraction of two natural numbers\<close>

definition bin_narry :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bin_narry a b k = (if b mod 2^k > a mod 2^k then 1 else 0)"

text \<open>Equivalent definition\<close>
definition bin_narry2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bin_narry2 a b k = ((2^k + a mod 2^k - b mod 2^k) div 2^k + 1) mod 2"

lemma bin_narry_equiv: "bin_narry a b c = bin_narry2 a b c"
  apply (auto simp add: bin_narry_def bin_narry2_def)
  subgoal by (smt add.commute div_less dvd_0_right even_Suc le_add_diff_inverse2 less_add_eq_less
        mod_greater_zero_iff_not_dvd neq0_conv not_mod2_eq_Suc_0_eq_0 order_le_less zero_less_diff
        zero_less_numeral zero_less_power)
  subgoal by (simp add: le_div_geq less_imp_diff_less)
  done

subsection \<open>Properties of carries\<close>

lemma div_sub:
  fixes a b c :: nat
  shows "(a - b) div c = (if(a mod c < b mod c) then a div c - b div c - 1 else  a div c - b div c)"
proof-
  consider (alb) "a<b" | (ageb) "a\<ge>b" by linarith
  then show ?thesis
  proof cases
    case alb
    then show ?thesis using div_le_mono by auto
  next
    case ageb
    obtain a1 a2 where a1_def: "a1 = a div c" and a2_def: "a2 = a mod c" and a_def: "a=a1*c+a2"
      using mod_div_decomp by blast
    obtain b1 b2 where b1_def: "b1 = b div c" and b2_def: "b2 = b mod c" and b_def: "b=b1*c+b2"
      using mod_div_decomp by blast
    have a1geb1: "a1\<ge>b1" using ageb a1_def b1_def using div_le_mono by blast
    show ?thesis
    proof(cases "c=0")
      assume "c=0"
      then show ?thesis by simp
    next
      assume cneq0: "c \<noteq> 0"
      then show ?thesis
      proof(cases "a2 < b2")
        assume a2lb2: "a2 < b2"
        then show ?thesis
        proof(cases "a1=b1")
          case True
          then show ?thesis using ageb a2lb2 a_def b_def by force
        next
          assume "\<not>(a1=b1)"
          hence a1gb1: "a1>b1" using a1geb1 by auto
          have boundc: "a2+c-b2<c" using a2lb2 cneq0 by linarith
          have "a-b = (a1 - b1) * c + a2 - b2"
            using a_def b_def a1geb1 nat_diff_add_eq1[of b1 a1 c a2 b2] by auto
          also have "... = (a1 - b1-1+1) * c + a2 - b2"
            using a1gb1 Suc_diff_Suc[of b1 a1] by auto
          also have "... = (a1 - b1 - 1) * c + (a2 + c - b2)"
            using div_eq_0_iff[of b2 c] mod_div_trivial[of b c] b2_def by force
          finally have "(a-b) div c = a1 - b1 - 1 + (a2 + c - b2) div c"
            using a_def b_def cneq0 by auto
          then show ?thesis
            using boundc div_less by (simp add: a1_def a2_def b1_def b2_def)
        qed
      next
        assume a2geb2: "\<not> a2 < b2"
        then have "(a - b) div c = ((a1 - b1) * c + (a2 - b2)) div c"
          using a1geb1 a_def b_def nat_diff_add_eq1 by auto
        then show ?thesis using a2geb2 div_add1_eq[of "(a1-b1)*c" "a2-b2" c]
          by(auto simp add: b2_def a2_def a1_def b1_def less_imp_diff_less)
      qed
    qed
  qed
qed

lemma dif_digit_formula:"a \<ge> b \<longrightarrow> (a - b)\<exclamdown>k = (a\<exclamdown>k + b\<exclamdown>k + bin_narry a b k) mod 2"
proof -
  {
    presume asm: "a\<ge>b" "a mod 2 ^ k < b mod 2 ^ k"
    then have "Suc((a - b) div 2 ^ k) = a div 2 ^ k - b div 2 ^ k"
      by (smt Nat.add_diff_assoc One_nat_def Suc_pred add.commute diff_is_0_eq div_add_self1
          div_le_mono div_sub mod_add_self1 nat_le_linear neq0_conv plus_1_eq_Suc power_not_zero
          zero_neq_numeral)
    then have "(a - b) div 2 ^ k mod 2 = Suc (a div 2 ^ k mod 2 + b div 2 ^ k mod 2) mod 2"
      by (smt diff_is_0_eq even_Suc even_diff_nat even_iff_mod_2_eq_zero le_less mod_add_eq
          nat.simps(3) not_mod_2_eq_1_eq_0)
  }
  moreover
  {
    presume asm2: "\<not> a mod 2 ^ k < b mod 2 ^ k" "b \<le> a"
    then have "(a - b) div 2 ^ k mod 2 = (a div 2 ^ k mod 2 + b div 2 ^ k mod 2) mod 2"
      using div_sub[of b "2^k" a] div_le_mono even_add even_iff_mod_2_eq_zero
        le_add_diff_inverse2[of "b div 2 ^ k" "a div 2 ^ k"] mod_mod_trivial[of _ 2]
        not_less[of "a mod 2 ^ k" "b mod 2 ^ k"] not_mod_2_eq_1_eq_0 div_sub by smt

  }

  ultimately show ?thesis
    by (auto simp add: bin_narry_def nth_bit_def)
qed

lemma dif_narry_formula:
  "a\<ge>b \<longrightarrow> bin_narry a b (k + 1) = (if (a\<exclamdown>k < b\<exclamdown>k + bin_narry a b k) then 1 else 0)"
proof -
  {
    presume a1: "a mod (2 * 2 ^ k) < b mod (2 * 2 ^ k)"
    presume a2: "\<not> a div 2 ^ k mod 2 < Suc (b div 2 ^ k mod 2)"
    have f3: "2 ^ k \<noteq> (0::nat)"
      by simp
    have f4: "a div 2 ^ k mod 2 = 1"
      using a2 by (meson le_less_trans mod2_eq_if mod_greater_zero_iff_not_dvd not_less
          zero_less_Suc)
    then have "b mod (2 * 2 ^ k) = b mod 2 ^ k"
      using a2 by (metis (no_types) One_nat_def le_simps(3) mod_less_divisor mod_mult2_eq
          mult.left_neutral neq0_conv not_less semiring_normalization_rules(7))
    then have "False"
      using f4 f3 a1 by (metis One_nat_def add.commute div_add_self1 div_le_mono less_imp_le
          mod_div_trivial mod_mult2_eq mult.left_neutral not_less plus_1_eq_Suc
          semiring_normalization_rules(7) zero_less_Suc)
  }
  moreover
  {
    presume a1: "\<not> a mod 2 ^ k < b mod 2 ^ k"
    presume a2: "a mod (2 * 2 ^ k) < b mod (2 * 2 ^ k)"
    presume a3: "\<not> a div 2 ^ k mod 2 < b div 2 ^ k mod 2"
    presume a4: "b \<le> a"
    have f6: "a mod 2 ^ Suc k < b mod 2 ^ Suc k"
    using a2 by simp
    obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where f7: "b + nn a b = a" using a4 le_add_diff_inverse by auto
    have "(a div 2 ^ k - b div 2 ^ k) div 2 = a div 2 ^ k div 2 - b div 2 ^ k div 2"
    using a3 div_sub by presburger
      then have f8: "(a - b) div 2 ^ Suc k = a div 2 ^ Suc k - b div 2 ^ Suc k"
        using a1 by (metis (no_types) div_mult2_eq div_sub power_Suc power_commutes)
      have f9: "\<forall>n na. Suc (na div n) = (n + na) div n \<or> 0 = n"
        by (metis (no_types) add_Suc_right add_cancel_left_right div_add_self1 lessI
            less_Suc_eq_0_disj less_one zero_neq_one)
      then have "\<forall>n na nb. (na + nb - n) div na = Suc (nb div na) - n div na - 1 \<or>
         \<not> (na + nb) mod na < n mod na \<or> 0 = na" by (metis (no_types) div_sub)
      then have f10: "\<forall>n na nb. \<not> (nb::nat) mod na < n mod na \<or> nb div na - n div na
          = (na + nb - n) div na \<or> 0 = na"
        by (metis (no_types) diff_Suc_Suc diff_commute diff_diff_left mod_add_self1 plus_1_eq_Suc)
      have "\<forall>n. Suc n \<noteq> n" by linarith
    then have "(0::nat) = 2 ^ Suc k"
      using f10 f9 f8 f7 f6 a4 by (metis add_diff_cancel_left' add_diff_assoc)
    then have "False"
      by simp
  }

  ultimately show ?thesis
    apply (auto simp add: nth_bit_def not_less bin_narry_def)
    subgoal by (smt add_0_left add_less_cancel_left Divides.divmod_digit_0(2) le_less_trans mod_less_divisor
        mod_mult2_eq mult_zero_right nat_neq_iff not_less not_mod2_eq_Suc_0_eq_0
        semiring_normalization_rules(7) zero_less_numeral zero_less_power)
    subgoal by (smt One_nat_def add.left_neutral Divides.divmod_digit_0(1) le_less_trans less_imp_le
          mod_less_divisor mod_mult2_eq mod_mult_self1_is_0 mult_zero_right not_less
          not_mod2_eq_Suc_0_eq_0 not_one_le_zero semiring_normalization_rules(7) zero_less_numeral
          zero_less_power)
    done
qed

lemma sum_digit_formula:"(a + b)\<exclamdown>k =(a\<exclamdown>k + b\<exclamdown>k + bin_carry a b k) mod 2"
  by (simp add: bin_carry_def nth_bit_def) (metis div_add1_eq mod_add_eq)

lemma sum_carry_formula:"bin_carry a b (k + 1) =(a\<exclamdown>k + b\<exclamdown>k + bin_carry a b k) div 2"
  by (simp add: bin_carry_def nth_bit_def)
     (smt div_mult2_eq div_mult_self4 mod_mult2_eq power_not_zero semiring_normalization_rules(20)
          semiring_normalization_rules(34) semiring_normalization_rules(7) zero_neq_numeral)

lemma bin_carry_bounded:
  shows "bin_carry a b k = bin_carry a b k mod 2"
proof-
  have "a mod 2 ^ k <  2 ^k" by simp
  moreover have "b mod 2 ^ k < 2 ^ k" by simp
  ultimately have "(a mod 2 ^ k + b mod 2 ^ k) <  2 ^(Suc k)" by (simp add: mult_2 add_strict_mono)
  then have "(a mod 2 ^ k + b mod 2 ^ k) div 2^k  \<le> 1" using less_mult_imp_div_less by force
  then have "bin_carry a b k \<le> 1" using div_le_mono bin_carry_def by fastforce
  then show ?thesis by auto
qed

lemma carry_bounded: "bin_carry a b k \<le> 1"
  using bin_carry_bounded not_mod_2_eq_1_eq_0[of "bin_carry a b k"] by auto

lemma no_carry:
  "(\<forall>r< n.((nth_bit a r) + (nth_bit b r) \<le> 1)) \<Longrightarrow>
          (nth_bit (a + b) n) = (nth_bit a n + nth_bit b n) mod 2"
  (is "?P \<Longrightarrow> ?Q n")
proof (rule ccontr)
  assume p: "?P"
  assume nq: "\<not>?Q n"
  then obtain k where k1:"\<not>?Q k" and k2:"\<forall>r<k. ?Q r" by (auto dest: obtain_smallest)

  have c1: "1 = bin_carry a b k"
    using k1 sum_digit_formula bin_carry_bounded
    by auto (metis add.commute not_mod2_eq_Suc_0_eq_0 plus_nat.add_0)

  have "bin_carry a b (k-1) = 0" using sum_digit_formula
    by (metis bin_carry_bounded bin_carry_def diff_is_0_eq' diff_less div_by_1 even_add
              even_iff_mod_2_eq_zero k2 less_numeral_extra(1) mod_by_1 neq0_conv nth_bit_bounded
              power_0)

  moreover have "a \<exclamdown> (k-1) + b \<exclamdown> (k-1) < 1"
    by (smt add.right_neutral c1 calculation diff_le_self k2 leI le_add_diff_inverse2 le_less_trans
            mod_by_1 mod_if nat_less_le nq one_div_two_eq_zero one_neq_zero p sum_carry_formula)

  ultimately have "0 = bin_carry a b k" using k2 sum_carry_formula
    by auto (metis Suc_eq_plus1_left add_diff_inverse_nat less_imp_diff_less mod_0 mod_Suc
              mod_add_self1 mod_div_trivial mod_less n_not_Suc_n plus_nat.add_0)

  then show False using c1 by auto
qed

lemma no_carry_mult_equiv:"(\<forall>k. nth_bit a k * nth_bit b k = 0) \<longleftrightarrow> (\<forall>k. bin_carry a b k = 0)"
  (is "?P \<longleftrightarrow> ?Q")
proof
  assume P: ?P
  {
    fix k
    from P have "bin_carry a b k = 0"
    proof (induction k)
      case 0
      then show ?case using bin_carry_def by (simp)
    next
      case (Suc k)
      then show ?case using sum_carry_formula P
        by (metis One_nat_def Suc_eq_plus1 add.right_neutral div_less lessI
        mult_is_0 not_mod_2_eq_0_eq_1 nth_bit_def numeral_2_eq_2 zero_less_Suc)
    qed
  }
  then show ?Q by auto
next
  assume Q: ?Q
  {
    fix k
    from Q have "a \<exclamdown> k * b \<exclamdown> k = 0"
    proof (induction k)
      case 0
      then show ?case using bin_carry_def nth_bit_def
        by simp (metis add_self_div_2 not_mod2_eq_Suc_0_eq_0 power_one_right)
    next
      case (Suc k)
      then show ?case
        using nth_bit_def  sum_carry_formula
        by simp (metis One_nat_def add.right_neutral add_self_div_2 not_mod_2_eq_1_eq_0 power_Suc)+
    qed
  }
  then show ?P by auto
qed

(* NEW LEMMAS FROM DIGIT COMPARISON *)

lemma carry_digit_impl: "bin_carry a b k \<noteq> 0 \<Longrightarrow> \<exists>r<k. a \<exclamdown> r + b \<exclamdown> r = 2"
proof(rule ccontr)
  assume "\<not> (\<exists>r<k. a \<exclamdown> r + b \<exclamdown> r = 2)"
  hence bound: "\<forall>r<k. a \<exclamdown> r + b \<exclamdown> r \<le> 1" using nth_bit_def by auto
  assume bk:"bin_carry a b k \<noteq> 0"
  hence base: "bin_carry a b k = 1" using carry_bounded le_less[of "bin_carry a b k" 1] by auto
  have step: "i \<le> k \<Longrightarrow> bin_carry a b i = 1 \<Longrightarrow> bin_carry a b (i - 1) = 1" for i
    proof(rule ccontr)
      assume ik: "i \<le> k"
      assume carry: "bin_carry a b i = 1"
      assume "bin_carry a b (i- 1) \<noteq> 1"
      hence "bin_carry a b (i - 1) = 0" using bin_carry_bounded not_mod_2_eq_1_eq_0[of "bin_carry a b (i - 1)"] by auto
      then show False using ik carry bound sum_carry_formula[of a b "i-1"]
        apply simp
        by (metis Suc_eq_plus1 Suc_pred add_lessD1 bot_nat_0.not_eq_extremum carry diff_is_0_eq' div_le_mono le_eq_less_or_eq less_add_one one_div_two_eq_zero)
    qed
  have "\<forall>i\<le>k. bin_carry a b i = 1" using rev_induct[where ?P="\<lambda>c.(bin_carry a b c = 1)"] step base by blast
  moreover have "bin_carry a b 0 = 0" using bin_carry_def by simp
  ultimately show False by auto
qed

end


theory int_add_ident_left
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Zero | Succ "Nat"

datatype Z = P "Nat" | N "Nat"

fun zero :: "Z" where
"zero = P Zero"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Zero) y = y"
| "plus2 (Succ n) y = Succ (plus2 n y)"

fun minus :: "Nat => Nat => Z" where
"minus (Zero) (Zero) = P Zero"
| "minus (Zero) (Succ n) = N n"
| "minus (Succ m) (Zero) = P (Succ m)"
| "minus (Succ m) (Succ o) = minus m o"

fun plus :: "Z => Z => Z" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o) = minus m (Succ o)"
| "plus (N m2) (P n2) = minus n2 (Succ m2)"
| "plus (N m2) (N n3) = N (Succ (plus2 m2 n3))"

(*hipster zero plus2 minus plus *)

theorem x0 :
  "!! (x :: Z) . x = (plus zero x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section \<open>Integer Values\<close>
theory Int_Value
imports "~~/src/HOL/Word/Word"
begin

text \<open>We model only one fixed integer type.
  We have to assert that the result type of pointer
  difference @{text "ptrdiff_t"} fits into this integer type.\<close>

type_synonym int_width = 64
type_synonym int_val = "int_width Word.word"

text \<open>We're using signed longs in the translation to C, this are the min, and max values that it's
  possible to represent with signed longs.

  Note: We are assuming 2's complement representation here.
    This matches the @{text "intN_t"} types of C99.

\<close>

abbreviation "int_width \<equiv> len_of TYPE(int_width)"
abbreviation INT_MIN :: int where "INT_MIN \<equiv> - ((2^(int_width - 1)))"
abbreviation INT_MAX :: int where "INT_MAX \<equiv> ((2^(int_width - 1)) - 1)"

definition representable_int :: "int \<Rightarrow> bool" where
  "representable_int i \<equiv> INT_MIN \<le> i \<and> i \<le> INT_MAX"

context begin
  qualified lemma repr1: "representable_int i \<Longrightarrow> sint ((word_of_int i)::int_val) = i"
    unfolding representable_int_def
    apply (subst word_sbin.eq_norm)
    by (metis (no_types, lifting) mem_Collect_eq sints_num
      word_sbin.set_iff_norm zle_diff1_eq)

  qualified lemma repr2: "representable_int (sint (v::int_val))"
    unfolding representable_int_def using sint_range_size[of v]
    by (auto simp: word_size)

  qualified lemma repr3: "word_of_int (sint v) = v"
    by simp

end

end


(*:maxLineLen=78:*)

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

theory Classical_Logic_Completeness
  imports Classical_Logic
begin

sledgehammer_params [smt_proofs = false]

text \<open> The following presents soundness completeness of basic
       propositional logic for propositional semantics.
       A concrete algebraic data type is given for propositional
       formulae in \S\ref{subsec:classical-calculus-syntax}. Logic for these
       formulae is defined inductively.  The Tarski truth relation \<open>\<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p\<close>
       is also defined inductively, and is presented in
       \S\ref{subsec: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{subsec:propositional-embedding}. \<close>

subsection \<open> Syntax \label{subsec:classical-calculus-syntax} \<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)

subsection \<open> Propositional Calculus \<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>"

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

subsection \<open> Propositional Semantics \label{subsec:propositional-semantics}\<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 Proposition p = (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"

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+)

subsection \<open> Soundness and Completeness Proofs \label{subsec: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 Proposition p}"

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{subsec:mcs} with the semantics given in
       \S\ref{subsec:propositional-semantics}. \<close>

text \<open> All together, the technique we are using essentially follows
       Blackburn et al.'s approach @{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}
 proven in \S\ref{subsec:propositional-semantics}.  These theorems together
  give rise to 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

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

subsection \<open> Embedding Theorem For the Propositional Calculus \label{subsec:propositional-embedding} \<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)+)

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


section \<open>Relations interpreted as Directed Graphs\<close>
theory Digraph_Basic
imports
  "../Automatic_Refinement/Lib/Misc"
  "../Automatic_Refinement/Lib/Refine_Util"
  "HOL-Library.Omega_Words_Fun"
begin

text \<open>
  This theory contains some basic graph theory on directed graphs which are
  modeled as a relation between nodes.

  The theory here is very fundamental, and
  also used by non-directly graph-related applications like the theory of
  tail-recursion in the Refinement Framework. Thus, we decided to put it
  in the basic theories of the refinement framework.
\<close>

text \<open>Directed graphs are modeled as a relation on nodes\<close>
type_synonym 'v digraph = "('v\<times>'v) set"

locale digraph = fixes E :: "'v digraph"

subsection \<open>Paths\<close>
text \<open>Path are modeled as list of nodes, the last node of a path is not included
  into the list. This formalization allows for nice concatenation and splitting
  of paths.\<close>
inductive path :: "'v digraph \<Rightarrow> 'v \<Rightarrow> 'v list \<Rightarrow> 'v \<Rightarrow> bool" for E where
  path0: "path E u [] u"
| path_prepend: "\<lbrakk> (u,v)\<in>E; path E v l w \<rbrakk> \<Longrightarrow> path E u (u#l) w"

lemma path1: "(u,v)\<in>E \<Longrightarrow> path E u [u] v"
  by (auto intro: path.intros)

lemma path_empty_conv[simp]:
  "path E u [] v \<longleftrightarrow> u=v"
  by (auto intro: path0 elim: path.cases)

inductive_cases path_uncons: "path E u (u'#l) w"
inductive_simps path_cons_conv: "path E u (u'#l) w"

lemma path_no_edges[simp]: "path {} u p v \<longleftrightarrow> (u=v \<and> p=[])"
  by (cases p) (auto simp: path_cons_conv)

lemma path_conc:
  assumes P1: "path E u la v"
  assumes P2: "path E v lb w"
  shows "path E u (la@lb) w"
  using P1 P2 apply induct
  by (auto intro: path.intros)

lemma path_append:
  "\<lbrakk> path E u l v; (v,w)\<in>E \<rbrakk> \<Longrightarrow> path E u (l@[v]) w"
  using path_conc[OF _ path1] .

lemma path_unconc:
  assumes "path E u (la@lb) w"
  obtains v where "path E u la v" and "path E v lb w"
  using assms
  thm path.induct
  apply (induct u "la@lb" w arbitrary: la lb rule: path.induct)
  apply (auto intro: path.intros elim!: list_Cons_eq_append_cases)
  done

lemma path_conc_conv:
  "path E u (la@lb) w \<longleftrightarrow> (\<exists>v. path E u la v \<and> path E v lb w)"
  by (auto intro: path_conc elim: path_unconc)

lemma (in -) path_append_conv: "path E u (p@[v]) w \<longleftrightarrow> (path E u p v \<and> (v,w)\<in>E)"
  by (simp add: path_cons_conv path_conc_conv)

lemmas path_simps = path_empty_conv path_cons_conv path_conc_conv

lemmas path_trans[trans] = path_prepend path_conc path_append
lemma path_from_edges: "\<lbrakk>(u,v)\<in>E; (v,w)\<in>E\<rbrakk> \<Longrightarrow> path E u [u] v"
  by (auto simp: path_simps)

lemma path_edge_cases[case_names no_use split]:
  assumes "path (insert (u,v) E) w p x"
  obtains
    "path E w p x"
  | p1 p2 where "path E w p1 u" "path (insert (u,v) E) v p2 x"
  using assms
  apply induction
  apply simp
  apply (clarsimp)
  apply (metis path_simps path_cons_conv)
  done

lemma path_edge_rev_cases[case_names no_use split]:
  assumes "path (insert (u,v) E) w p x"
  obtains
    "path E w p x"
  | p1 p2 where "path (insert (u,v) E) w p1 u" "path E v p2 x"
  using assms
  apply (induction p arbitrary: x rule: rev_induct)
  apply simp
  apply (clarsimp simp: path_cons_conv path_conc_conv)
  apply (metis path_simps path_append_conv)
  done

lemma path_mono:
  assumes S: "E\<subseteq>E'"
  assumes P: "path E u p v"
  shows "path E' u p v"
  using P
  apply induction
  apply simp
  using S
  apply (auto simp: path_cons_conv)
  done

lemma path_is_rtrancl:
  assumes "path E u l v"
  shows "(u,v)\<in>E\<^sup>*"
  using assms
  by induct auto

lemma rtrancl_is_path:
  assumes "(u,v)\<in>E\<^sup>*"
  obtains l where "path E u l v"
  using assms
  by induct (auto intro: path0 path_append)

lemma path_is_trancl:
  assumes "path E u l v"
  and "l\<noteq>[]"
  shows "(u,v)\<in>E\<^sup>+"
  using assms
  apply induct
  apply auto []
  apply (case_tac l)
  apply auto
  done

lemma trancl_is_path:
  assumes "(u,v)\<in>E\<^sup>+"
  obtains l where "l\<noteq>[]" and "path E u l v"
  using assms
  by induct (auto intro: path0 path_append)

lemma path_nth_conv: "path E u p v \<longleftrightarrow> (let p'=p@[v] in
  u=p'!0 \<and>
  (\<forall>i<length p' - 1. (p'!i,p'!Suc i)\<in>E))"
  apply (induct p arbitrary: v rule: rev_induct)
  apply (auto simp: path_conc_conv path_cons_conv nth_append)
  done

lemma path_mapI:
  assumes "path E u p v"
  shows "path (pairself f ` E) (f u) (map f p) (f v)"
  using assms
  apply induction
  apply (simp)
  apply (force simp: path_cons_conv)
  done

lemma path_restrict:
  assumes "path E u p v"
  shows "path (E \<inter> set p \<times> insert v (set (tl p))) u p v"
  using assms
proof induction
  print_cases
  case (path_prepend u v p w)
  from path_prepend.IH have "path (E \<inter> set (u#p) \<times> insert w (set p)) v p w"
    apply (rule path_mono[rotated])
    by (cases p) auto
  thus ?case using \<open>(u,v)\<in>E\<close>
    by (cases p) (auto simp add: path_cons_conv)
qed auto

lemma path_restrict_closed:
  assumes CLOSED: "E``D \<subseteq> D"
  assumes I: "v\<in>D" and P: "path E v p v'"
  shows "path (E\<inter>D\<times>D) v p v'"
  using P CLOSED I
  by induction (auto simp: path_cons_conv)

lemma path_set_induct:
  assumes "path E u p v" and "u\<in>I" and "E``I \<subseteq> I"
  shows "set p \<subseteq> I"
  using assms
  by (induction rule: path.induct) auto

lemma path_nodes_reachable: "path E u p v \<Longrightarrow> insert v (set p) \<subseteq> E\<^sup>*``{u}"
  apply (auto simp: in_set_conv_decomp path_cons_conv path_conc_conv)
  apply (auto dest!: path_is_rtrancl)
  done

lemma path_nodes_edges: "path E u p v \<Longrightarrow> set p \<subseteq> fst`E"
  by (induction rule: path.induct) auto

lemma path_tl_nodes_edges:
  assumes "path E u p v"
  shows "set (tl p) \<subseteq> fst`E \<inter> snd`E"
proof -
  from path_nodes_edges[OF assms] have "set (tl p) \<subseteq> fst`E"
    by (cases p) auto

  moreover have "set (tl p) \<subseteq> snd`E"
    using assms
    apply (cases)
    apply simp
    apply simp
    apply (erule path_set_induct[where I = "snd`E"])
    apply auto
    done
  ultimately show ?thesis
    by auto
qed

lemma path_loop_shift:
  assumes P: "path E u p u"
  assumes S: "v\<in>set p"
  obtains p' where "set p' = set p" "path E v p' v"
proof -
  from S obtain p1 p2 where [simp]: "p = p1@v#p2" by (auto simp: in_set_conv_decomp)
  from P obtain v' where A: "path E u p1 v" "(v, v') \<in> E" "path E v' p2 u"
    by (auto simp: path_simps)
  hence "path E v (v#p2@p1) v" by (auto simp: path_simps)
  thus ?thesis using that[of "v#p2@p1"] by auto
qed

lemma path_hd:
  assumes "p \<noteq> []" "path E v p w"
  shows "hd p = v"
  using assms
  by (auto simp: path_cons_conv neq_Nil_conv)

lemma path_last_is_edge:
  assumes "path E x p y"
  and "p \<noteq> []"
  shows "(last p, y) \<in> E"
  using assms
  by (auto simp: neq_Nil_rev_conv path_simps)

lemma path_member_reach_end:
  assumes P: "path E x p y"
  and v: "v \<in> set p"
  shows "(v,y) \<in> E\<^sup>+"
  using assms
  by (auto intro!: path_is_trancl simp: in_set_conv_decomp path_simps)

lemma path_tl_induct[consumes 2, case_names single step]:
  assumes P: "path E x p y"
  and NE: "x \<noteq> y"
  and S: "\<And>u. (x,u) \<in> E \<Longrightarrow> P x u"
  and ST: "\<And>u v. \<lbrakk>(x,u) \<in> E\<^sup>+; (u,v) \<in> E; P x u\<rbrakk> \<Longrightarrow> P x v"
  shows "P x y \<and> (\<forall> v \<in> set (tl p). P x v)"
proof -
  from P NE have "p \<noteq> []" by auto
  thus ?thesis using P
  proof (induction p arbitrary: y rule: rev_nonempty_induct)
    case (single u) hence "(x,y) \<in> E" by (simp add: path_cons_conv)
    with S show ?case by simp
  next
    case (snoc u us) hence "path E x us u" by (simp add: path_append_conv)
    with snoc path_is_trancl have
      "P x u" "(x,u) \<in> E\<^sup>+" "\<forall>v \<in> set (tl us). P x v"
      by simp_all
    moreover with snoc have "\<forall>v \<in> set (tl (us@[u])). P x v" by simp
    moreover from snoc have "(u,y) \<in> E" by (simp add: path_append_conv)
    ultimately show ?case by (auto intro: ST)
  qed
qed

lemma path_restrict_tl:
  "\<lbrakk> u\<notin>R; path (E \<inter> UNIV \<times> -R) u p v \<rbrakk> \<Longrightarrow> path (rel_restrict E R) u p v"
  apply (induction p arbitrary: u)
  apply (auto simp: path_simps rel_restrict_def)
  done

lemma path1_restr_conv: "path (E\<inter>UNIV \<times> -R) u (x#xs) v
  \<longleftrightarrow> (\<exists>w. w\<notin>R \<and> x=u \<and> (u,w)\<in>E \<and> path (rel_restrict E R) w xs v)"
proof -
  have 1: "rel_restrict E R \<subseteq> E \<inter> UNIV \<times> - R" by (auto simp: rel_restrict_def)

  show ?thesis
    by (auto simp: path_simps intro: path_restrict_tl path_mono[OF 1])
qed

lemma dropWhileNot_path:
  assumes "p \<noteq> []"
  and "path E w p x"
  and "v \<in> set p"
  and "dropWhile ((\<noteq>) v) p = c"
  shows "path E v c x"
  using assms
proof (induction arbitrary: w c rule: list_nonempty_induct)
  case (single p) thus ?case by (auto simp add: path_simps)
next
  case (cons p ps) hence [simp]: "w = p" by (simp add: path_cons_conv)
  show ?case
  proof (cases "p=v")
    case True with cons show ?thesis by simp
  next
    case False with cons have "c = dropWhile ((\<noteq>) v) ps" by simp
    moreover from cons.prems obtain y where "path E y ps x"
      using path_uncons by metis
    moreover from cons.prems False have "v \<in> set ps" by simp
    ultimately show ?thesis using cons.IH by metis
  qed
qed

lemma takeWhileNot_path:
  assumes "p \<noteq> []"
  and "path E w p x"
  and "v \<in> set p"
  and "takeWhile ((\<noteq>) v) p = c"
  shows "path E w c v"
  using assms
proof (induction arbitrary: w c rule: list_nonempty_induct)
  case (single p) thus ?case by (auto simp add: path_simps)
next
  case (cons p ps) hence [simp]: "w = p" by (simp add: path_cons_conv)
  show ?case
  proof (cases "p=v")
    case True with cons show ?thesis by simp
  next
    case False with cons obtain c' where
      "c' = takeWhile ((\<noteq>) v) ps" and
      [simp]: "c = p#c'"
      by simp_all
    moreover from cons.prems obtain y where
      "path E y ps x" and "(w,y) \<in> E"
      using path_uncons by metis+
    moreover from cons.prems False have "v \<in> set ps" by simp
    ultimately have "path E y c' v" using cons.IH by metis
    with \<open>(w,y) \<in> E\<close> show ?thesis by (auto simp add: path_cons_conv)
  qed
qed

subsection \<open>Infinite Paths\<close>
definition ipath :: "'q digraph \<Rightarrow> 'q word \<Rightarrow> bool"
  \<comment> \<open>Predicate for an infinite path in a digraph\<close>
  where "ipath E r \<equiv> \<forall>i. (r i, r (Suc i))\<in>E"

lemma ipath_conc_conv:
  "ipath E (u \<frown> v) \<longleftrightarrow> (\<exists>a. path E a u (v 0) \<and> ipath E v)"
  apply (auto simp: conc_def ipath_def path_nth_conv nth_append)
  apply (metis add_Suc_right diff_add_inverse not_add_less1)
  by (metis Suc_diff_Suc diff_Suc_Suc not_less_eq)

lemma ipath_iter_conv:
  assumes "p\<noteq>[]"
  shows "ipath E (p\<^sup>\<omega>) \<longleftrightarrow> (path E (hd p) p (hd p))"
proof (cases p)
  case Nil thus ?thesis using assms by simp
next
  case (Cons u p') hence PLEN: "length p > 0" by simp
  show ?thesis proof
    assume "ipath E (iter (p))"
    hence "\<forall>i. (iter (p) i, iter (p) (Suc i)) \<in> E"
      unfolding ipath_def by simp
    hence "(\<forall>i<length p. (p!i,(p@[hd p])!Suc i)\<in>E)"
      apply (simp add: assms)
      apply safe
      apply (drule_tac x=i in spec)
      apply simp
      apply (case_tac "Suc i = length p")
      apply (simp add: Cons)
      apply (simp add: nth_append)
      done
    thus "path E (hd p) p (hd p)"
      by (auto simp: path_nth_conv Cons nth_append nth_Cons')
  next
    assume "path E (hd p) p (hd p)"
    thus "ipath E (iter p)"
      apply (auto simp: path_nth_conv ipath_def assms Let_def)
      apply (drule_tac x="i mod length p" in spec)
      apply (auto simp: nth_append assms split: if_split_asm)
      apply (metis less_not_refl mod_Suc)
      by (metis PLEN diff_self_eq_0 mod_Suc nth_Cons_0 mod_less_divisor)
  qed
qed

lemma ipath_to_rtrancl:
  assumes R: "ipath E r"
  assumes I: "i1\<le>i2"
  shows "(r i1,r i2)\<in>E\<^sup>*"
  using I
proof (induction i2)
  case (Suc i2)
  show ?case proof (cases "i1=Suc i2")
    assume "i1\<noteq>Suc i2"
    with Suc have "(r i1,r i2)\<in>E\<^sup>*" by auto
    also from R have "(r i2,r (Suc i2))\<in>E" unfolding ipath_def by auto
    finally show ?thesis .
  qed simp
qed simp

lemma ipath_to_trancl:
  assumes R: "ipath E r"
  assumes I: "i1<i2"
  shows "(r i1,r i2)\<in>E\<^sup>+"
proof -
  from R have "(r i1,r (Suc i1))\<in>E"
    by (auto simp: ipath_def)
  also have "(r (Suc i1),r i2)\<in>E\<^sup>*"
    using ipath_to_rtrancl[OF R,of "Suc i1" i2] I by auto
  finally (rtrancl_into_trancl2) show ?thesis .
qed

lemma run_limit_two_connectedI:
  assumes A: "ipath E r"
  assumes B: "a \<in> limit r" "b\<in>limit r"
  shows "(a,b)\<in>E\<^sup>+"
proof -
  from B have "{a,b} \<subseteq> limit r" by simp
  with A show ?thesis
    by (metis ipath_to_trancl two_in_limit_iff)
qed

lemma ipath_subpath:
  assumes P: "ipath E r"
  assumes LE: "l\<le>u"
  shows "path E (r l) (map r [l..<u]) (r u)"
  using LE
proof (induction "u-l" arbitrary: u l)
  case (Suc n)
  note IH=Suc.hyps(1)
  from \<open>Suc n = u-l\<close> \<open>l\<le>u\<close> obtain u' where [simp]: "u=Suc u'"
    and A: "n=u'-l" "l \<le> u'"
    by (cases u) auto

  note IH[OF A]
  also from P have "(r u',r u)\<in>E"
    by (auto simp: ipath_def)
  finally show ?case using \<open>l \<le> u'\<close> by (simp add: upt_Suc_append)
qed auto

lemma ipath_restrict_eq: "ipath (E \<inter> (E\<^sup>*``{r 0} \<times> E\<^sup>*``{r 0})) r \<longleftrightarrow> ipath E r"
  unfolding ipath_def
  by (auto simp: relpow_fun_conv rtrancl_power)
lemma ipath_restrict: "ipath E r \<Longrightarrow> ipath (E \<inter> (E\<^sup>*``{r 0} \<times> E\<^sup>*``{r 0})) r"
  by (simp add: ipath_restrict_eq)

lemma ipathI[intro?]: "\<lbrakk>\<And>i. (r i, r (Suc i)) \<in> E\<rbrakk> \<Longrightarrow> ipath E r"
  unfolding ipath_def by auto

lemma ipathD: "ipath E r \<Longrightarrow> (r i, r (Suc i)) \<in> E"
  unfolding ipath_def by auto

lemma ipath_in_Domain: "ipath E r \<Longrightarrow> r i \<in> Domain E"
  unfolding ipath_def by auto

lemma ipath_in_Range: "\<lbrakk>ipath E r; i\<noteq>0\<rbrakk> \<Longrightarrow> r i \<in> Range E"
  unfolding ipath_def by (cases i) auto

lemma ipath_suffix: "ipath E r \<Longrightarrow> ipath E (suffix i r)"
  unfolding suffix_def ipath_def by auto

subsection \<open>Strongly Connected Components\<close>

text \<open>A strongly connected component is a maximal mutually connected set
  of nodes\<close>
definition is_scc :: "'q digraph \<Rightarrow> 'q set \<Rightarrow> bool"
  where "is_scc E U \<longleftrightarrow> U\<times>U\<subseteq>E\<^sup>* \<and> (\<forall>V. V\<supset>U \<longrightarrow> \<not> (V\<times>V\<subseteq>E\<^sup>*))"

lemma scc_non_empty[simp]: "\<not>is_scc E {}" unfolding is_scc_def by auto

lemma scc_non_empty'[simp]: "is_scc E U \<Longrightarrow> U\<noteq>{}" unfolding is_scc_def by auto

lemma is_scc_closed:
  assumes SCC: "is_scc E U"
  assumes MEM: "x\<in>U"
  assumes P: "(x,y)\<in>E\<^sup>*" "(y,x)\<in>E\<^sup>*"
  shows "y\<in>U"
proof -
  from SCC MEM P have "insert y U \<times> insert y U \<subseteq> E\<^sup>*"
    unfolding is_scc_def
    apply clarsimp
    apply rule
    apply clarsimp_all
    apply (erule disjE1)
    apply clarsimp
    apply (metis in_mono mem_Sigma_iff rtrancl_trans)
    apply auto []
    apply (erule disjE1)
    apply clarsimp
    apply (metis in_mono mem_Sigma_iff rtrancl_trans)
    apply auto []
    done
  with SCC show ?thesis unfolding is_scc_def by blast
qed

lemma is_scc_connected:
  assumes SCC: "is_scc E U"
  assumes MEM: "x\<in>U" "y\<in>U"
  shows "(x,y)\<in>E\<^sup>*"
  using assms unfolding is_scc_def by auto

text \<open>In the following, we play around with alternative characterizations, and
  prove them all equivalent .\<close>

text \<open>A common characterization is to define an equivalence relation
  ,,mutually connected'' on nodes, and characterize the SCCs as its
  equivalence classes:\<close>

definition mconn :: "('a\<times>'a) set \<Rightarrow> ('a \<times> 'a) set"
  \<comment> \<open>Mutually connected relation on nodes\<close>
  where "mconn E = E\<^sup>* \<inter> (E\<inverse>)\<^sup>*"

lemma mconn_pointwise:
   "mconn E = {(u,v). (u,v)\<in>E\<^sup>* \<and> (v,u)\<in>E\<^sup>*}"
  by (auto simp add: mconn_def rtrancl_converse)

text \<open>\<open>mconn\<close> is an equivalence relation:\<close>
lemma mconn_refl[simp]: "Id\<subseteq>mconn E"
  by (auto simp add: mconn_def)

lemma mconn_sym: "mconn E = (mconn E)\<inverse>"
  by (auto simp add: mconn_pointwise)

lemma mconn_trans: "mconn E O mconn E = mconn E"
  by (auto simp add: mconn_def)

lemma mconn_refl': "refl (mconn E)"
  by (auto intro: refl_onI simp: mconn_pointwise)

lemma mconn_sym': "sym (mconn E)"
  by (auto intro: symI simp: mconn_pointwise)

lemma mconn_trans': "trans (mconn E)"
  by (metis mconn_def trans_Int trans_rtrancl)

lemma mconn_equiv: "equiv UNIV (mconn E)"
  using mconn_refl' mconn_sym' mconn_trans'
  by (rule equivI)

lemma is_scc_mconn_eqclasses: "is_scc E U \<longleftrightarrow> U \<in> UNIV // mconn E"
  \<comment> \<open>The strongly connected components are the equivalence classes of the
    mutually-connected relation on nodes\<close>
proof
  assume A: "is_scc E U"
  then obtain x where "x\<in>U" unfolding is_scc_def by auto
  hence "U = mconn E `` {x}" using A
    unfolding mconn_pointwise is_scc_def
    apply clarsimp
    apply rule
    apply auto []
    apply clarsimp
    by (metis A is_scc_closed)
  thus "U \<in> UNIV // mconn E"
    by (auto simp: quotient_def)
next
  assume "U \<in> UNIV // mconn E"
  thus "is_scc E U"
    by (auto simp: is_scc_def mconn_pointwise quotient_def)
qed

(* For presentation in the paper *)
lemma "is_scc E U \<longleftrightarrow> U \<in> UNIV // (E\<^sup>* \<inter> (E\<inverse>)\<^sup>*)"
  unfolding is_scc_mconn_eqclasses mconn_def by simp

text \<open>We can also restrict the notion of "reachability" to nodes
  inside the SCC
\<close>

lemma find_outside_node:
  assumes "(u,v)\<in>E\<^sup>*"
  assumes "(u,v)\<notin>(E\<inter>U\<times>U)\<^sup>*"
  assumes "u\<in>U" "v\<in>U"
  shows "\<exists>u'. u'\<notin>U \<and> (u,u')\<in>E\<^sup>* \<and> (u',v)\<in>E\<^sup>*"
  using assms
  apply (induction)
  apply auto []
  apply clarsimp
  by (metis IntI mem_Sigma_iff rtrancl.simps)

lemma is_scc_restrict1:
  assumes SCC: "is_scc E U"
  shows "U\<times>U\<subseteq>(E\<inter>U\<times>U)\<^sup>*"
  using assms
  unfolding is_scc_def
  apply clarsimp
  apply (rule ccontr)
  apply (drule (2) find_outside_node[rotated])
  apply auto []
  by (metis is_scc_closed[OF SCC] mem_Sigma_iff rtrancl_trans subsetD)

lemma is_scc_restrict2:
  assumes SCC: "is_scc E U"
  assumes "V\<supset>U"
  shows "\<not> (V\<times>V\<subseteq>(E\<inter>V\<times>V)\<^sup>*)"
  using assms
  unfolding is_scc_def
  apply clarsimp
  using rtrancl_mono[of "E \<inter> V \<times> V" "E"]
  apply clarsimp
  apply blast
  done

lemma is_scc_restrict3:
  assumes SCC: "is_scc E U"
  shows "((E\<^sup>*``((E\<^sup>*``U) - U)) \<inter> U = {})"
  apply auto
  by (metis assms is_scc_closed is_scc_connected rtrancl_trans)

lemma is_scc_alt_restrict_path:
  "is_scc E U \<longleftrightarrow> U\<noteq>{} \<and>
    (U\<times>U \<subseteq> (E\<inter>U\<times>U)\<^sup>*) \<and> ((E\<^sup>*``((E\<^sup>*``U) - U)) \<inter> U = {})"
  apply rule
  apply (intro conjI)
  apply simp
  apply (blast dest: is_scc_restrict1)
  apply (blast dest: is_scc_restrict3)

  unfolding is_scc_def
  apply rule
  apply clarsimp
  apply (metis (full_types) Int_lower1 in_mono mem_Sigma_iff rtrancl_mono_mp)
  apply blast
  done

lemma is_scc_pointwise:
  "is_scc E U \<longleftrightarrow>
    U\<noteq>{}
  \<and> (\<forall>u\<in>U. \<forall>v\<in>U. (u,v)\<in>(E\<inter>U\<times>U)\<^sup>*)
  \<and> (\<forall>u\<in>U. \<forall>v. (v\<notin>U \<and> (u,v)\<in>E\<^sup>*) \<longrightarrow> (\<forall>u'\<in>U. (v,u')\<notin>E\<^sup>*))"
  \<comment> \<open>Alternative, pointwise characterization\<close>
  unfolding is_scc_alt_restrict_path
  by blast

lemma is_scc_unique:
  assumes SCC: "is_scc E scc" "is_scc E scc'"
  and v: "v \<in> scc" "v \<in> scc'"
  shows "scc = scc'"
proof -
  from SCC have "scc = scc' \<or> scc \<inter> scc' = {}"
    using quotient_disj[OF mconn_equiv]
    by (simp add: is_scc_mconn_eqclasses)
  with v show ?thesis by auto
qed

lemma is_scc_ex1:
  "\<exists>!scc. is_scc E scc \<and> v \<in> scc"
proof (rule ex1I, rule conjI)
  let ?scc = "mconn E `` {v}"
  have "?scc \<in> UNIV // mconn E" by (auto intro: quotientI)
  thus "is_scc E ?scc" by (simp add: is_scc_mconn_eqclasses)
  moreover show "v \<in> ?scc" by (blast intro: refl_onD[OF mconn_refl'])
  ultimately show "\<And>scc. is_scc E scc \<and> v \<in> scc \<Longrightarrow> scc = ?scc"
    by (metis is_scc_unique)
qed

lemma is_scc_ex:
  "\<exists>scc. is_scc E scc \<and> v \<in> scc"
  by (metis is_scc_ex1)

lemma is_scc_connected':
  "\<lbrakk>is_scc E scc; x \<in> scc; y \<in> scc\<rbrakk> \<Longrightarrow> (x,y)\<in>(Restr E scc)\<^sup>*"
  unfolding is_scc_pointwise
  by blast

definition scc_of :: "('v\<times>'v) set \<Rightarrow> 'v \<Rightarrow> 'v set"
  where
  "scc_of E v = (THE scc. is_scc E scc \<and> v \<in> scc)"

lemma scc_of_is_scc[simp]:
  "is_scc E (scc_of E v)"
  using is_scc_ex1[of E v]
  by (auto dest!: theI' simp: scc_of_def)

lemma node_in_scc_of_node[simp]:
  "v \<in> scc_of E v"
  using is_scc_ex1[of E v]
  by (auto dest!: theI' simp: scc_of_def)

lemma scc_of_unique:
  assumes "w \<in> scc_of E v"
  shows "scc_of E v = scc_of E w"
proof -
  have "is_scc E (scc_of E v)" by simp
  moreover note assms
  moreover have "is_scc E (scc_of E w)" by simp
  moreover have "w \<in> scc_of E w" by simp
  ultimately show ?thesis using is_scc_unique by metis
qed

end