(* Title: Examples/SML_Relativization/Algebra/SML_Semirings.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about semirings\<close>
theory SML_Semirings
  imports SML_Groups
begin

subsection\<open>Semirings\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semiring_ow =
  ab_semigroup_add_ow U plus + semigroup_mult_ow U times
  for U :: "'ag set" and plus times +
  assumes distrib_right[simp]:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> (a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c"
  assumes distrib_left[simp]:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w c"

lemma semiring_ow: "class.semiring = semiring_ow UNIV"
  unfolding
    class.semiring_def semiring_ow_def
    class.semiring_axioms_def semiring_ow_axioms_def
    ab_semigroup_add_ow semigroup_mult_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semiring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=))
      (semiring_ow (Collect (Domainp A))) class.semiring"
  unfolding
    semiring_ow_def class.semiring_def
    semiring_ow_axioms_def class.semiring_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

subsubsection\<open>Relativization\<close>

context semiring_ow
begin

tts_context
  tts: (?'a to U)
  substituting semiring_ow_axioms
  eliminating through simp
begin

tts_lemma combine_common_factor:
  assumes "a \<in> U" and "e \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w (b *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w c) = (a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w e +\<^sub>o\<^sub>w c"
    is semiring_class.combine_common_factor.

end

end

subsection\<open>Commutative semirings\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_semiring_ow =
  ab_semigroup_add_ow U plus + ab_semigroup_mult_ow U times
  for U :: "'ag set" and plus times +
  assumes distrib:
    "\<lbrakk>a \<in> U; b \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> (a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c"
begin

sublocale semiring_ow
proof
  fix a b c :: 'ag
  assume "a \<in> U" and "b \<in> U" and "c \<in> U"
  then show "(a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c" by (simp only: distrib)
  show "a *\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w c"
  proof-
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a *\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = (b +\<^sub>o\<^sub>w c) *\<^sub>o\<^sub>w a"
      by (simp add: mult_commute)
    with \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a *\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = b *\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w c *\<^sub>o\<^sub>w a"
      by (simp only: distrib)
    with \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> show ?thesis  by (simp only: mult_commute)
  qed
qed

end

lemma comm_semiring_ow: "class.comm_semiring = comm_semiring_ow UNIV"
  unfolding
    class.comm_semiring_def comm_semiring_ow_def
    class.comm_semiring_axioms_def comm_semiring_ow_axioms_def
    ab_semigroup_add_ow ab_semigroup_mult_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_semiring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=))
      (comm_semiring_ow (Collect (Domainp A))) class.comm_semiring"
    (is "?PR (comm_semiring_ow (Collect (Domainp A))) class.comm_semiring")
  unfolding
    comm_semiring_ow_def class.comm_semiring_def
    comm_semiring_ow_axioms_def class.comm_semiring_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

subsection\<open>Semirings with zero\<close>

subsubsection\<open>Definitions and further results\<close>

locale mult_zero_ow = times_ow U times + zero_ow U zero
  for U :: "'ag set" and times zero +
  assumes mult_zero_left[simp]: "a \<in> U \<Longrightarrow> 0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
  assumes mult_zero_right[simp]: "a \<in> U \<Longrightarrow> a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = 0\<^sub>o\<^sub>w"

lemma mult_zero_ow: "class.mult_zero = mult_zero_ow UNIV"
  unfolding
    class.mult_zero_def mult_zero_ow_def mult_zero_ow_axioms_def
    times_ow_def zero_ow_def neutral_ow_def
  by simp

locale semiring_0_ow =
  semiring_ow U plus times +
  comm_monoid_add_ow U plus zero +
  mult_zero_ow U times zero
  for U :: "'ag set" and plus zero times

lemma semiring_0_ow: "class.semiring_0 = semiring_0_ow UNIV"
  unfolding
    class.semiring_0_def semiring_0_ow_def
    mult_zero_ow comm_monoid_add_ow semiring_ow
  by (auto simp: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semiring_0_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (=))
      (semiring_0_ow (Collect (Domainp A))) class.semiring_0"
    (is "?PR (semiring_0_ow (Collect (Domainp A))) class.semiring_0")
proof-
  let ?semiring_0 =
    "(
      \<lambda>plus zero times.
        class.semiring_0 plus zero times \<and>
        (\<forall>a b. a \<in> UNIV \<longrightarrow> b \<in> UNIV \<longrightarrow> times a b \<in> UNIV) \<and> zero \<in> UNIV
    )"
  have "?PR (semiring_0_ow (Collect (Domainp A))) ?semiring_0"
    unfolding
      semiring_0_ow_def  class.semiring_0_def
      mult_zero_ow_def class.mult_zero_def
      mult_zero_ow_axioms_def
      times_ow_def zero_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

end

subsection\<open>Commutative semirings with zero\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_semiring_0_ow =
  comm_semiring_ow U plus times +
  comm_monoid_add_ow U plus zero +
  mult_zero_ow U times zero
  for U :: "'ag set" and plus zero times
begin

sublocale semiring_0_ow by unfold_locales

end

lemma comm_semiring_0_ow: "class.comm_semiring_0 = comm_semiring_0_ow UNIV"
  unfolding
    class.comm_semiring_0_def comm_semiring_0_ow_def
    comm_monoid_add_ow comm_semiring_ow mult_zero_ow
  by (auto simp: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_semiring_0_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (=))
      (comm_semiring_0_ow (Collect (Domainp A))) class.comm_semiring_0"
    (is "?PR (comm_semiring_0_ow (Collect (Domainp A))) class.comm_semiring_0")
proof-
  let ?comm_semiring_0 =
    "(
      \<lambda>plus zero times.
        class.comm_semiring_0 plus zero times \<and>
        (\<forall>a b. a \<in> UNIV \<longrightarrow> b \<in> UNIV \<longrightarrow> times a b \<in> UNIV) \<and> zero \<in> UNIV
    )"
  have "?PR (comm_semiring_0_ow (Collect (Domainp A))) ?comm_semiring_0"
    unfolding
      comm_semiring_0_ow_def class.comm_semiring_0_def
      mult_zero_ow_def class.mult_zero_def
      mult_zero_ow_axioms_def
      times_ow_def zero_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

end

subsection\<open>Cancellative semirings with zero\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semiring_0_cancel_ow =
  semiring_ow U plus times + cancel_comm_monoid_add_ow U plus minus zero
  for U :: "'ag set" and plus minus zero times
begin

sublocale semiring_0_ow
proof
  fix a
  show "a \<in> U \<Longrightarrow> 0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
  proof-
    assume "a \<in> U"
    have "0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a \<in> U" by (simp add: \<open>a \<in> U\<close> times_closed')
    have "0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w"
      by (simp add: \<open>a \<in> U\<close> \<open>0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a \<in> U\<close> distrib_right[symmetric])
    then show ?thesis
      unfolding add_left_cancel[OF \<open>0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a \<in> U\<close> \<open>0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a \<in> U\<close> zero_closed]
      by assumption
  qed
  show "a \<in> U \<Longrightarrow> a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = 0\<^sub>o\<^sub>w"
  proof-
    assume "a \<in> U"
    have "a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w \<in> U" by (simp add: \<open>a \<in> U\<close> times_closed')
    have "a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w +\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w +\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w"
      by (simp add: \<open>a \<in> U\<close> \<open>a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w \<in> U\<close> distrib_left[symmetric])
    then show ?thesis
      unfolding add_left_cancel[OF \<open>a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w \<in> U\<close> \<open>a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w \<in> U\<close> zero_closed]
      by assumption
  qed
qed

end

lemma semiring_0_cancel_ow:
  "class.semiring_0_cancel = semiring_0_cancel_ow UNIV"
  unfolding
    class.semiring_0_cancel_def
    semiring_0_cancel_ow_def
    cancel_comm_monoid_add_ow semiring_ow
  by (simp add: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semiring_0_cancel_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      (=)
    ) (semiring_0_cancel_ow (Collect (Domainp A))) class.semiring_0_cancel"
  unfolding semiring_0_cancel_ow_def class.semiring_0_cancel_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end

subsection\<open>Commutative cancellative semirings with zero\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_semiring_0_cancel_ow =
  comm_semiring_ow U plus times +
  cancel_comm_monoid_add_ow U plus minus zero
  for U :: "'ag set" and plus  minus zero times
begin

sublocale semiring_0_cancel_ow by unfold_locales

sublocale comm_semiring_0_ow by unfold_locales

end

lemma comm_semiring_0_cancel_ow:
  "class.comm_semiring_0_cancel = comm_semiring_0_cancel_ow UNIV"
  unfolding
    class.comm_semiring_0_cancel_def comm_semiring_0_cancel_ow_def
    cancel_comm_monoid_add_ow comm_semiring_ow
  by (simp add: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_semiring_0_cancel_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      (=)
    )
    (comm_semiring_0_cancel_ow (Collect (Domainp A)))
    class.comm_semiring_0_cancel"
  unfolding comm_semiring_0_cancel_ow_def class.comm_semiring_0_cancel_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end

subsection\<open>Class \<^class>\<open>zero_neq_one\<close>\<close>

subsubsection\<open>Definitions and common properties\<close>

locale zero_neq_one_ow =
  zero_ow U zero + one_ow U one
  for U :: "'ag set" and one (\<open>1\<^sub>o\<^sub>w\<close>) and zero (\<open>0\<^sub>o\<^sub>w\<close>)  +
  assumes zero_neq_one[simp]: "0\<^sub>o\<^sub>w \<noteq> 1\<^sub>o\<^sub>w"

lemma zero_neq_one_ow: "class.zero_neq_one = zero_neq_one_ow UNIV"
  unfolding
    class.zero_neq_one_def zero_neq_one_ow_def
    zero_neq_one_ow_axioms_def
    one_ow_def zero_ow_def neutral_ow_def
  by simp

ud \<open>zero_neq_one.of_bool\<close> (\<open>(with _ _ : \<guillemotleft>of'_bool\<guillemotright> _)\<close> [1000, 999, 1000] 10)
ud of_bool' \<open>of_bool\<close>

ctr parametricity
  in of_bool.with_def

context zero_neq_one_ow
begin

abbreviation of_bool where "of_bool \<equiv> of_bool.with 1\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w"

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma zero_neq_one_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(A ===> A ===> (=))
      (zero_neq_one_ow (Collect (Domainp A))) class.zero_neq_one"
    (is "?PR (zero_neq_one_ow (Collect (Domainp A))) class.zero_neq_one")
proof-
  let ?zero_neq_one =
    "(\<lambda>one zero. class.zero_neq_one one zero \<and> one \<in> UNIV \<and> zero \<in> UNIV)"
  have "?PR (zero_neq_one_ow (Collect (Domainp A))) ?zero_neq_one"
    unfolding
      zero_neq_one_ow_def class.zero_neq_one_def
      zero_neq_one_ow_axioms_def
      zero_ow_def one_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

end

subsubsection\<open>Relativization\<close>

context zero_neq_one_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting zero_neq_one_ow_axioms
  eliminating through simp
begin

tts_lemma split_of_bool_asm:
  shows "P (of_bool p) = (\<not> (p \<and> \<not> P 1\<^sub>o\<^sub>w \<or> \<not> p \<and> \<not> P 0\<^sub>o\<^sub>w))"
    is zero_neq_one_class.split_of_bool_asm.

tts_lemma of_bool_eq_iff:
  shows "(of_bool p = local.of_bool q) = (p = q)"
    is zero_neq_one_class.of_bool_eq_iff.

tts_lemma split_of_bool:
  shows "P (of_bool p) = ((p \<longrightarrow> P 1\<^sub>o\<^sub>w) \<and> (\<not> p \<longrightarrow> P 0\<^sub>o\<^sub>w))"
    is zero_neq_one_class.split_of_bool.

tts_lemma one_neq_zero: "1\<^sub>o\<^sub>w \<noteq> 0\<^sub>o\<^sub>w"
  is zero_neq_one_class.one_neq_zero.

tts_lemma of_bool_eq:
  shows "of_bool False = 0\<^sub>o\<^sub>w"
    is zero_neq_one_class.of_bool_eq(1)
    and "of_bool True = 1\<^sub>o\<^sub>w"
    is zero_neq_one_class.of_bool_eq(2).

end

end

subsection\<open>Semirings with zero and one (rigs)\<close>

subsubsection\<open>Definitions and commmon properties\<close>

locale semiring_1_ow =
  zero_neq_one_ow U one zero +
  semiring_0_ow U plus zero times +
  monoid_mult_ow U one times
  for U :: "'ag set" and one times plus zero

lemma semiring_1_ow: "class.semiring_1 = semiring_1_ow UNIV"
  unfolding
    class.semiring_1_def semiring_1_ow_def
    monoid_mult_ow semiring_0_ow zero_neq_one_ow
  by (auto simp: conj_commute)

ud \<open>semiring_1.of_nat\<close> (\<open>(with _ _ _ : \<guillemotleft>of'_nat\<guillemotright> _)\<close> [1000, 999, 998, 1000] 10)
ud of_nat' \<open>of_nat\<close>

ud \<open>semiring_1.Nats\<close> (\<open>(with _ _ _ : \<nat>)\<close> [1000, 999, 998] 10)
ud Nats' \<open>Nats\<close>

ctr parametricity
  in of_nat_ow: of_nat.with_def
    and Nats_ow: Nats.with_def

context semiring_1_ow
begin

abbreviation of_nat where "of_nat \<equiv> of_nat.with 1\<^sub>o\<^sub>w (+\<^sub>o\<^sub>w) 0\<^sub>o\<^sub>w"
abbreviation Nats (\<open>\<guillemotleft>\<nat>\<guillemotright>\<close>) where "\<guillemotleft>\<nat>\<guillemotright> \<equiv> Nats.with 1\<^sub>o\<^sub>w (+\<^sub>o\<^sub>w) 0\<^sub>o\<^sub>w"
notation Nats (\<open>\<guillemotleft>\<nat>\<guillemotright>\<close>)

end

context semiring_1
begin

lemma Nat_ss_UNIV: "\<nat> \<subseteq> UNIV" by simp

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semiring_1_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(A ===> (A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (=))
      (semiring_1_ow (Collect (Domainp A))) class.semiring_1"
  unfolding semiring_1_ow_def class.semiring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end

subsubsection\<open>Relativization\<close>

context semiring_1_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semiring_1_ow_axioms and zero.not_empty
  eliminating through simp
begin

tts_lemma Nat_ss_UNIV[simp]:
  shows "\<guillemotleft>\<nat>\<guillemotright> \<subseteq> U"
    is Nat_ss_UNIV.

end

lemma Nat_closed[simp, intro]: "a \<in> \<guillemotleft>\<nat>\<guillemotright> \<Longrightarrow> a \<in> U" using Nat_ss_UNIV by blast

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semiring_1_ow_axioms and zero.not_empty
  eliminating through auto
begin

tts_lemma mult_of_nat_commute:
  assumes "y \<in> U"
  shows "of_nat x *\<^sub>o\<^sub>w y = y *\<^sub>o\<^sub>w of_nat x"
    is semiring_1_class.mult_of_nat_commute.

tts_lemma of_bool_conj: "of_bool (P \<and> Q) = of_bool P *\<^sub>o\<^sub>w of_bool Q"
  is semiring_1_class.of_bool_conj.

tts_lemma power_0_left: "0\<^sub>o\<^sub>w ^\<^sub>o\<^sub>w n = (if n = 0 then 1\<^sub>o\<^sub>w else 0\<^sub>o\<^sub>w)"
  is semiring_1_class.power_0_left.

tts_

tts_lemma of_nat_of_bool: "of_nat (with 1 0 : \<guillemotleft>of_bool\<guillemotright> P) = of_bool P"
  is semiring_1_class.of_nat_of_bool.

tts_lemma of_nat_in_Nats: "of_nat n \<in> \<guillemotleft>\<nat>\<guillemotright>"
  is semiring_1_class.of_nat_in_Nats.

tts_lemma zero_power2: "0\<^sub>o\<^sub>w ^\<^sub>o\<^sub>w 2 = 0\<^sub>o\<^sub>w"
  is semiring_1_class.zero_power2.

tts_lemma power_0_Suc: "0\<^sub>o\<^sub>w ^\<^sub>o\<^sub>w Suc n = 0\<^sub>o\<^sub>w"
  is semiring_1_class.power_0_Suc.

tts_lemma zero_power:
  assumes "0 < n"
  shows "0\<^sub>o\<^sub>w ^\<^sub>o\<^sub>w n = 0\<^sub>o\<^sub>w"
    is semiring_1_class.zero_power.

tts_lemma one_power2: "1\<^sub>o\<^sub>w ^\<^sub>o\<^sub>w 2 = 1\<^sub>o\<^sub>w"
  is semiring_1_class.one_power2.

tts_lemma of_nat_simps:
  shows "of_nat 0 = 0\<^sub>o\<^sub>w"
    is semiring_1_class.of_nat_simps(1)
    and "of_nat (Suc m) = 1\<^sub>o\<^sub>w +\<^sub>o\<^sub>w of_nat m"
    is semiring_1_class.of_nat_simps(2).

tts_lemma of_nat_mult: "of_nat (m * n) = of_nat m *\<^sub>o\<^sub>w of_nat n"
  is semiring_1_class.of_nat_mult.

tts_lemma Nats_induct:
  assumes "x \<in> \<guillemotleft>\<nat>\<guillemotright>" and "\<And>n. P (of_nat n)"
  shows "P x"
    is semiring_1_class.Nats_induct.

tts_lemma of_nat_add: "of_nat (m + n) = of_nat m +\<^sub>o\<^sub>w of_nat n"
  is semiring_1_class.of_nat_add.

tts_lemma of_nat_Suc: "of_nat (Suc m) = 1\<^sub>o\<^sub>w +\<^sub>o\<^sub>w of_nat m"
  is semiring_1_class.of_nat_Suc.

tts_lemma Nats_cases:
  assumes "x \<in> \<guillemotleft>\<nat>\<guillemotright>"
  obtains (of_nat) n where "x = of_nat n"
    given semiring_1_class.Nats_cases by auto

tts_lemma Nats_mult:
  assumes "a \<in> \<guillemotleft>\<nat>\<guillemotright>" and "b \<in> \<guillemotleft>\<nat>\<guillemotright>"
  shows "a *\<^sub>o\<^sub>w b \<in> \<guillemotleft>\<nat>\<guillemotright>"
    is semiring_1_class.Nats_mult.

tts_lemma of_nat_1: "of_nat 1 = 1\<^sub>o\<^sub>w"
  is semiring_1_class.of_nat_1.

tts_lemma of_nat_0: "of_nat 0 = 0\<^sub>o\<^sub>w"
  is semiring_1_class.of_nat_0.

tts_lemma Nats_add:
  assumes "a \<in> \<guillemotleft>\<nat>\<guillemotright>" and "b \<in> \<guillemotleft>\<nat>\<guillemotright>"
  shows "a +\<^sub>o\<^sub>w b \<in> \<guillemotleft>\<nat>\<guillemotright>"
    is semiring_1_class.Nats_add.

tts_lemma Nats_1: "1\<^sub>o\<^sub>w \<in> \<guillemotleft>\<nat>\<guillemotright>"
  is semiring_1_class.Nats_1.

tts_lemma Nats_0: "0\<^sub>o\<^sub>w \<in> \<guillemotleft>\<nat>\<guillemotright>"
  is semiring_1_class.Nats_0.

end

end

subsection\<open>Commutative rigs\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_semiring_1_ow =
  zero_neq_one_ow U one zero +
  comm_semiring_0_ow U plus zero times +
  comm_monoid_mult_ow U times one
  for U :: "'ag set" and times one plus zero
begin

sublocale semiring_1_ow by unfold_locales

end

lemma comm_semiring_1_ow: "class.comm_semiring_1 = comm_semiring_1_ow UNIV"
  unfolding
    class.comm_semiring_1_def comm_semiring_1_ow_def
    comm_monoid_mult_ow comm_semiring_0_ow zero_neq_one_ow
  by (auto simp: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_semiring_1_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> A ===> (=))
      (comm_semiring_1_ow (Collect (Domainp A))) class.comm_semiring_1"
  unfolding comm_semiring_1_ow_def class.comm_semiring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end

subsubsection\<open>Relativization\<close>

context comm_semiring_1_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_semiring_1_ow_axioms and zero.not_empty
  applying [OF times_closed' one_closed plus_closed' zero_closed]
begin

tts_lemma semiring_normalization_rules:
  shows
    "\<lbrakk>a \<in> U; m \<in> U; b \<in> U\<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w m +\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w m = (a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w m"
    "\<lbrakk>a \<in> U; m \<in> U\<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w m +\<^sub>o\<^sub>w m = (a +\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) *\<^sub>o\<^sub>w m"
    "\<lbrakk>m \<in> U; a \<in> U\<rbrakk> \<Longrightarrow> m +\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w m = (a +\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) *\<^sub>o\<^sub>w m"
    "m \<in> U \<Longrightarrow> m +\<^sub>o\<^sub>w m = (1\<^sub>o\<^sub>w +\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) *\<^sub>o\<^sub>w m"
    "a \<in> U \<Longrightarrow> 0\<^sub>o\<^sub>w +\<^sub>o\<^sub>w a = a"
    "a \<in> U \<Longrightarrow> a +\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = a"
    "\<lbrakk>a \<in> U; b \<in> U\<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b = b *\<^sub>o\<^sub>w a"
    "\<lbrakk>a \<in> U; b \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> (a +\<^sub>o\<^sub>w b) *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c"
    "a \<in> U \<Longrightarrow> 0\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
    "a \<in> U \<Longrightarrow> a *\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = 0\<^sub>o\<^sub>w"
    "a \<in> U \<Longrightarrow> 1\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a = a"
    "a \<in> U \<Longrightarrow> a *\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w = a"
    "\<lbrakk>lx \<in> U; ly \<in> U; rx \<in> U; ry \<in> U\<rbrakk> \<Longrightarrow>
      lx *\<^sub>o\<^sub>w ly *\<^sub>o\<^sub>w (rx *\<^sub>o\<^sub>w ry) = lx *\<^sub>o\<^sub>w rx *\<^sub>o\<^sub>w (ly *\<^sub>o\<^sub>w ry)"
    "\<lbrakk>lx \<in> U; ly \<in> U; rx \<in> U; ry \<in> U\<rbrakk> \<Longrightarrow>
      lx *\<^sub>o\<^sub>w ly *\<^sub>o\<^sub>w (rx *\<^sub>o\<^sub>w ry) = lx *\<^sub>o\<^sub>w (ly *\<^sub>o\<^sub>w (rx *\<^sub>o\<^sub>w ry))"
    "\<lbrakk>lx \<in> U; ly \<in> U; rx \<in> U; ry \<in> U\<rbrakk> \<Longrightarrow>
      lx *\<^sub>o\<^sub>w ly *\<^sub>o\<^sub>w (rx *\<^sub>o\<^sub>w ry) = rx *\<^sub>o\<^sub>w (lx *\<^sub>o\<^sub>w ly *\<^sub>o\<^sub>w ry)"
    "\<lbrakk>lx \<in> U; ly \<in> U; rx \<in> U\<rbrakk> \<Longrightarrow> lx *\<^sub>o\<^sub>w ly *\<^sub>o\<^sub>w rx = lx *\<^sub>o\<^sub>w rx *\<^sub>o\<^sub>w ly"
    "\<lbrakk>lx \<in> U; ly \<in> U; rx \<in> U\<rbrakk> \<Longrightarrow> lx *\<^sub>o\<^sub>w ly *\<^sub>o\<^sub>w rx = lx *\<^sub>o\<^sub>w (ly *\<^sub>o\<^sub>w rx)"
    "\<lbrakk>lx \<in> U; rx \<in> U; ry \<in> U\<rbrakk> \<Longrightarrow> lx *\<^sub>o\<^sub>w (rx *\<^sub>o\<^sub>w ry) = lx *\<^sub>o\<^sub>w rx *\<^sub>o\<^sub>w ry"
    "\<lbrakk>lx \<in> U; rx \<in> U; ry \<in> U\<rbrakk> \<Longrightarrow> lx *\<^sub>o\<^sub>w (rx *\<^sub>o\<^sub>w ry) = rx *\<^sub>o\<^sub>w (lx *\<^sub>o\<^sub>w ry)"
    "\<lbrakk>a \<in> U; b \<in> U; c \<in> U; d \<in> U\<rbrakk> \<Longrightarrow>
      a +\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w (c +\<^sub>o\<^sub>w d) = a +\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w d)"
    "\<lbrakk>a \<in> U; b \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w c = a +\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c)"
    "\<lbrakk>a \<in> U; c \<in> U; d \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w (c +\<^sub>o\<^sub>w d) = c +\<^sub>o\<^sub>w (a +\<^sub>o\<^sub>w d)"
    "\<lbrakk>a \<in> U; b \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w c = a +\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w b"
    "\<lbrakk>a \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w c = c +\<^sub>o\<^sub>w a"
    "\<lbrakk>a \<in> U; c \<in> U; d \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w (c +\<^sub>o\<^sub>w d) = a +\<^sub>o\<^sub>w c +\<^sub>o\<^sub>w d"
    "x \<in> U \<Longrightarrow> x ^\<^sub>o\<^sub>w p *\<^sub>o\<^sub>w x ^\<^sub>o\<^sub>w q = x ^\<^sub>o\<^sub>w (p + q)"
    "x \<in> U \<Longrightarrow> x *\<^sub>o\<^sub>w x ^\<^sub>o\<^sub>w q = x ^\<^sub>o\<^sub>w Suc q"
    "x \<in> U \<Longrightarrow> x ^\<^sub>o\<^sub>w q *\<^sub>o\<^sub>w x = x ^\<^sub>o\<^sub>w Suc q"
    "x \<in> U \<Longrightarrow> x *\<^sub>o\<^sub>w x = x ^\<^sub>o\<^sub>w 2"
    "\<lbrakk>x \<in> U; y \<in> U\<rbrakk> \<Longrightarrow> (x *\<^sub>o\<^sub>w y) ^\<^sub>o\<^sub>w q = x ^\<^sub>o\<^sub>w q *\<^sub>o\<^sub>w y ^\<^sub>o\<^sub>w q"
    "x \<in> U \<Longrightarrow> (x ^\<^sub>o\<^sub>w p) ^\<^sub>o\<^sub>w q = x ^\<^sub>o\<^sub>w (p * q)"
    "x \<in> U \<Longrightarrow> x ^\<^sub>o\<^sub>w 0 = 1\<^sub>o\<^sub>w"
    "x \<in> U \<Longrightarrow> x ^\<^sub>o\<^sub>w 1 = x"
    "\<lbrakk>x \<in> U; y \<in> U; z \<in> U\<rbrakk> \<Longrightarrow> x *\<^sub>o\<^sub>w (y +\<^sub>o\<^sub>w z) = x *\<^sub>o\<^sub>w y +\<^sub>o\<^sub>w x *\<^sub>o\<^sub>w z"
    "x \<in> U \<Longrightarrow> x ^\<^sub>o\<^sub>w Suc q = x *\<^sub>o\<^sub>w x ^\<^sub>o\<^sub>w q"
    "x \<in> U \<Longrightarrow> x ^\<^sub>o\<^sub>w (2 * n) = x ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w x ^\<^sub>o\<^sub>w n"
    is comm_semiring_1_class.semiring_normalization_rules.

tts_lemma le_imp_power_dvd:
  assumes "a \<in> U" and "m \<le> n"
  shows "a ^\<^sub>o\<^sub>w m \<guillemotleft>dvd\<guillemotright> a ^\<^sub>o\<^sub>w n"
    is comm_semiring_1_class.le_imp_power_dvd.

tts_lemma dvd_0_left_iff:
  assumes "a \<in> U"
  shows "(0\<^sub>o\<^sub>w \<guillemotleft>dvd\<guillemotright> a) = (a = 0\<^sub>o\<^sub>w)"
    is comm_semiring_1_class.dvd_0_left_iff.

tts_lemma dvd_power_same:
  assumes "x \<in> U" and "y \<in> U" and "x \<guillemotleft>dvd\<guillemotright> y"
  shows "x ^\<^sub>o\<^sub>w n \<guillemotleft>dvd\<guillemotright> y ^\<^sub>o\<^sub>w n"
    is comm_semiring_1_class.dvd_power_same.

tts_lemma power_le_dvd:
  assumes "a \<in> U" and "b \<in> U" and "a ^\<^sub>o\<^sub>w n \<guillemotleft>dvd\<guillemotright> b" and "m \<le> n"
  shows "a ^\<^sub>o\<^sub>w m \<guillemotleft>dvd\<guillemotright> b"
    is comm_semiring_1_class.power_le_dvd.

tts_lemma dvd_0_right:
  assumes "a \<in> U"
  shows "a \<guillemotleft>dvd\<guillemotright> 0\<^sub>o\<^sub>w"
    is comm_semiring_1_class.dvd_0_right.

tts_lemma dvd_0_left:
  assumes "a \<in> U" and "0\<^sub>o\<^sub>w \<guillemotleft>dvd\<guillemotright> a"
  shows "a = 0\<^sub>o\<^sub>w"
    is comm_semiring_1_class.dvd_0_left.

tts_lemma dvd_power:
  assumes "x \<in> U" and "0 < n \<or> x = 1\<^sub>o\<^sub>w"
  shows "x \<guillemotleft>dvd\<guillemotright> x ^\<^sub>o\<^sub>w n"
    is comm_semiring_1_class.dvd_power.

tts_lemma dvd_add:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<guillemotleft>dvd\<guillemotright> b" and "a \<guillemotleft>dvd\<guillemotright> c"
  shows "a \<guillemotleft>dvd\<guillemotright> b +\<^sub>o\<^sub>w c"
    is comm_semiring_1_class.dvd_add.

end

end

subsection\<open>Cancellative rigs\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semiring_1_cancel_ow =
  semiring_ow U plus times +
  cancel_comm_monoid_add_ow U plus minus zero +
  zero_neq_one_ow U one zero +
  monoid_mult_ow U one times
  for U :: "'ag set" and plus minus zero one times
begin

sublocale semiring_0_cancel_ow ..
sublocale semiring_1_ow ..

end

lemma semiring_1_cancel_ow:
  "class.semiring_1_cancel = semiring_1_cancel_ow UNIV"
  unfolding
    class.semiring_1_cancel_def semiring_1_cancel_ow_def
    cancel_comm_monoid_add_ow monoid_mult_ow semiring_ow zero_neq_one_ow
  by (force simp: conj_commute)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semiring_1_cancel_transfer[transfer_rule]:
  includes lifting_syntax
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> A) ===>
      A ===>
      A ===>
      (A ===> A ===> A) ===>
      (=)
    ) (semiring_1_cancel_ow (Collect (Domainp A))) class.semiring_1_cancel"
  unfolding semiring_1_cancel_ow_def class.semiring_1_cancel_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end

subsection\<open>Commutative cancellative rigs\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_semiring_1_cancel_ow =
  comm_semiring_ow U plus times +
  cancel_comm_monoid_add_ow U plus minus zero +
  zero_neq_one_ow U one zero +
  comm_monoid_mult_ow U times one
  for U :: "'ag set" and plus minus zero times one +
  assumes right_diff_distrib'[algebra_simps]:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w (b -\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w c"
begin

sublocale semiring_1_cancel_ow ..
sublocale comm_semiring_0_cancel_ow ..
sublocale comm_semiring_1_ow ..

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma comm_semiring_1_cancel_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===>
      A ===>
      (=)
    )
    (comm_semiring_1_cancel_ow (Collect (Domainp A)))
    class.comm_semiring_1_cancel"
  unfolding
    comm_semiring_1_cancel_ow_def class.comm_semiring_1_cancel_def
    comm_semiring_1_cancel_ow_axioms_def
    class.comm_semiring_1_cancel_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end

subsubsection\<open>Relativization\<close>

context comm_semiring_1_cancel_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_semiring_1_cancel_ow_axioms and zero.not_empty
  applying [OF plus_closed' minus_closed' zero_closed times_closed' one_closed]
begin

tts_lemma dvd_add_times_triv_right_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "(a \<guillemotleft>dvd\<guillemotright> b +\<^sub>o\<^sub>w c *\<^sub>o\<^sub>w a) = (a \<guillemotleft>dvd\<guillemotright> b)"
  is comm_semiring_1_cancel_class.dvd_add_times_triv_right_iff.

tts_lemma dvd_add_times_triv_left_iff:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U"
  shows "(a \<guillemotleft>dvd\<guillemotright> c *\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w b) = (a \<guillemotleft>dvd\<guillemotright> b)"
    is comm_semiring_1_cancel_class.dvd_add_times_triv_left_iff.

tts_lemma dvd_add_triv_right_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a \<guillemotleft>dvd\<guillemotright> b +\<^sub>o\<^sub>w a) = (a \<guillemotleft>dvd\<guillemotright> b)"
    is comm_semiring_1_cancel_class.dvd_add_triv_right_iff.

tts_lemma dvd_add_triv_left_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a \<guillemotleft>dvd\<guillemotright> a +\<^sub>o\<^sub>w b) = (a \<guillemotleft>dvd\<guillemotright> b)"
    is comm_semiring_1_cancel_class.dvd_add_triv_left_iff.

tts_lemma left_diff_distrib':
  assumes "b \<in> U" and "c \<in> U" and "a \<in> U"
  shows "(b -\<^sub>o\<^sub>w c) *\<^sub>o\<^sub>w a = b *\<^sub>o\<^sub>w a -\<^sub>o\<^sub>w c *\<^sub>o\<^sub>w a"
    is comm_semiring_1_cancel_class.left_diff_distrib'.

tts_lemma dvd_add_right_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<guillemotleft>dvd\<guillemotright> b"
  shows "(a \<guillemotleft>dvd\<guillemotright> b +\<^sub>o\<^sub>w c) = (a \<guillemotleft>dvd\<guillemotright> c)"
    is comm_semiring_1_cancel_class.dvd_add_right_iff.

tts_lemma dvd_add_left_iff:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U" and "a \<guillemotleft>dvd\<guillemotright> c"
  shows "(a \<guillemotleft>dvd\<guillemotright> b +\<^sub>o\<^sub>w c) = (a \<guillemotleft>dvd\<guillemotright> b)"
    is comm_semiring_1_cancel_class.dvd_add_left_iff.

end

end

text\<open>\newpage\<close>

end


theory Walks
imports "HOL-Probability.Probability" "HOL-Library.Permutation"
begin

sledgehammer_params[debug=true,timeout=600]

locale walk_list =
  fixes step :: "int list" and len::nat
  assumes "length step = len"
begin

primrec walk :: "nat \<Rightarrow> int" where
  "walk 0 = 0"
| "walk (Suc n) = walk n + step!n"

lemma  walk_as_sum:
  "walk (n+1) = (\<Sum> j \<in> {0..n}. step!j)"
by(induct n,auto)

abbreviation range :: "nat \<Rightarrow> nat" where
  "range n \<equiv> length (remdups (map (\<lambda>i. walk (nat i)) [0..(int)n]))"

lemma map_snoc:
  "map f (xs@[x]) = map f xs @ [f x]"
by(induct xs,auto)

lemma walk_member:
  assumes "m \<le> n"
  shows "walk m \<in> set (map (\<lambda>i. walk (nat i)) [0..(int)(n)])"
  using assms proof(induct n arbitrary: m)
  case 0
  then show ?case by auto
next
  case (Suc n')
  have *:"(map (\<lambda>i. walk (nat i)) [0..(int)(Suc n')]) = (map (\<lambda>i. walk (nat i)) [0..(int)(n')]) @ [walk (Suc n')]"
    using map_snoc  by (smt nat_int of_nat_0_le_iff of_nat_Suc upto_rec2)
  show ?case proof(cases "m = Suc n'")
    case True
    then show ?thesis using Suc * by auto
  next
    case False
    then show ?thesis using Suc * by auto
  qed
qed

lemma remdups_snoc:
  assumes "x \<in> set xs"
  shows "length (remdups (xs@[x])) = length (remdups xs)"
  using assms length_remdups_card_conv[of "xs@[x]"]
  by (metis length_remdups_card_conv remdups.simps(2) rotate1.simps(2) set_rotate1)

lemma
  assumes "range (n+1) = range n + 1"
  shows "\<forall>m \<le> n. walk (n+1) \<noteq> walk m"
proof(rule+)
  fix m
  assume *:"m \<le> n" and "walk (n + 1) = walk m"
  hence **: "walk (n+1) \<in> set (map (\<lambda>i. walk (nat i)) [0..(int)(n)])" using walk_member by simp
  moreover have "map (\<lambda>i. walk (nat i)) [0..(int)(n+1)] = (map (\<lambda>i. walk (nat i)) [0..(int)(n)]) @ [walk (n+1)]"
       using map_snoc  nat_int of_nat_0_le_iff of_nat_Suc upto_rec2
       by (smt of_nat_1 of_nat_add)
  ultimately have "length (remdups  (map (\<lambda>i. walk (nat i)) [0..(int)(n+1)])) = length (remdups  (map (\<lambda>i. walk (nat i)) [0..(int)(n)]))"
    using ** * remdups_snoc[OF **] by simp
  thus False using assms by simp
qed

lemma
  assumes "m \<le> n" and "walk (n+1) \<noteq> walk m"
  shows "(\<Sum> j \<in> {m..n}. step!j) \<noteq> 0"
using assms proof(cases "m=0")
  case True
  then show ?thesis using walk_as_sum assms by auto
next
  case False
  then obtain m' where *:"m=Suc m'"  using not0_implies_Suc by auto
  then have "(\<Sum> j \<in> {0..n}. step!j) - (\<Sum> j \<in> {0..m'}. step!j) =  (\<Sum> j \<in> {m..n}. step!j)"
    using False
    by (smt add_leD2 assms(1) le_add1 le_add_same_cancel1 plus_1_eq_Suc sum.atLeastLessThan_concat sum.atLeast_Suc_atMost sum.last_plus)
  then show ?thesis using walk_as_sum[of m'] walk_as_sum[of n] assms * by simp
qed

end

locale walk =
fixes step :: "nat \<Rightarrow> int"
begin

primrec walk :: "nat \<Rightarrow> int" where
  "walk 0 = 0"
| "walk (Suc n) = walk n + step n"

lemma  walk_as_sum:
  "walk (n+1) = (\<Sum> j \<in> {0..n}. step j)"
by(induct n,auto)

abbreviation range :: "nat \<Rightarrow> nat" where
  "range n \<equiv> length (remdups (map (\<lambda>i. walk (nat i)) [0..(int)n]))"

lemma map_snoc:
  "map f (xs@[x]) = map f xs @ [f x]"
by(induct xs,auto)

lemma walk_member:
  assumes "m \<le> n"
  shows "walk m \<in> set (map (\<lambda>i. walk (nat i)) [0..(int)(n)])"
  using assms proof(induct n arbitrary: m)
  case 0
  then show ?case by auto
next
  case (Suc n')
  have *:"(map (\<lambda>i. walk (nat i)) [0..(int)(Suc n')]) = (map (\<lambda>i. walk (nat i)) [0..(int)(n')]) @ [walk (Suc n')]"
    using map_snoc  by (smt nat_int of_nat_0_le_iff of_nat_Suc upto_rec2)
  show ?case proof(cases "m = Suc n'")
    case True
    then show ?thesis using Suc * by auto
  next
    case False
    then show ?thesis using Suc * by auto
  qed
qed

lemma remdups_snoc:
  assumes "x \<in> set xs"
  shows "length (remdups (xs@[x])) = length (remdups xs)"
  using assms length_remdups_card_conv[of "xs@[x]"]
  by (metis length_remdups_card_conv remdups.simps(2) rotate1.simps(2) set_rotate1)

lemma
  assumes "range (n+1) = range n + 1"
  shows "\<forall>m \<le> n. walk (n+1) \<noteq> walk m"
proof(rule+)
  fix m
  assume *:"m \<le> n" and "walk (n + 1) = walk m"
  hence **: "walk (n+1) \<in> set (map (\<lambda>i. walk (nat i)) [0..(int)(n)])" using walk_member by simp
  moreover have "map (\<lambda>i. walk (nat i)) [0..(int)(n+1)] = (map (\<lambda>i. walk (nat i)) [0..(int)(n)]) @ [walk (n+1)]"
       using map_snoc  nat_int of_nat_0_le_iff of_nat_Suc upto_rec2
       by (smt of_nat_1 of_nat_add)
  ultimately have "length (remdups  (map (\<lambda>i. walk (nat i)) [0..(int)(n+1)])) = length (remdups  (map (\<lambda>i. walk (nat i)) [0..(int)(n)]))"
    using ** * remdups_snoc[OF **] by simp
  thus False using assms by simp
qed

lemma
  assumes "m \<le> n" and "walk (n+1) \<noteq> walk m"
  shows "(\<Sum> j \<in> {m..n}. step j) \<noteq> 0"
using assms proof(cases "m=0")
  case True
  then show ?thesis using walk_as_sum assms by auto
next
  case False
  then obtain m' where *:"m=Suc m'"  using not0_implies_Suc by auto
  then have "(sum step {0..n}) - (sum step {0..m'}) =  (\<Sum> j \<in> {m..n}. step j)"
    using False
    by (smt add_leD2 assms(1) le_add1 le_add_same_cancel1 plus_1_eq_Suc sum.atLeastLessThan_concat sum.atLeast_Suc_atMost sum.last_plus)
  then show ?thesis using walk_as_sum[of m'] walk_as_sum[of n] assms * by simp
qed

end

locale walk_pmf =
  fixes step_pmf :: "nat \<Rightarrow> int pmf"
begin

abbreviation walk_pmf :: "nat \<Rightarrow> int pmf" where
   "walk_pmf n =

(*
primrec  steps1 :: "nat \<Rightarrow> int" where
 "steps1 0 = 0"
| "steps1 (Suc n) = (int)n"

value "steps1 0"

global_interpretation steps1: walk  "steps1 :: nat \<Rightarrow> int"
  defines steps1_walk = steps1.walk and steps1_range = steps1.range
  apply unfold_locales
  using steps1.simps by auto

value  "(steps1.range 0, map steps1.walk [0,1,2,3,4])"
*)


(*  Title:      Pure/Examples/Higher_Order_Logic.thy
    Author:     Makarius
*)

section \<open>Foundations of HOL\<close>

theory Higher_Order_Logic
  imports Pure
begin

text \<open>
  The following theory development illustrates the foundations of Higher-Order
  Logic. The ``HOL'' logic that is given here resembles \<^cite>\<open>"Gordon:1985:HOL"\<close> and its predecessor \<^cite>\<open>"church40"\<close>, but the order of
  axiomatizations and defined connectives has be adapted to modern
  presentations of \<open>\<lambda>\<close>-calculus and Constructive Type Theory. Thus it fits
  nicely to the underlying Natural Deduction framework of Isabelle/Pure and
  Isabelle/Isar.
\<close>

section \<open>HOL syntax within Pure\<close>

class type
default_sort type

typedecl o
instance o :: type ..
instance "fun" :: (type, type) type ..

judgment Trueprop :: "o \<Rightarrow> prop"  ("_" 5)

section \<open>Minimal logic (axiomatization)\<close>

axiomatization imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25)
  where impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B"
    and impE [dest, trans]: "A \<longrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"

axiomatization All :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10)
  where allI [intro]: "(\<And>x. P x) \<Longrightarrow> \<forall>x. P x"
    and allE [dest]: "\<forall>x. P x \<Longrightarrow> P a"

lemma atomize_imp [atomize]: "(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)"
  by standard (fact impI, fact impE)

lemma atomize_all [atomize]: "(\<And>x. P x) \<equiv> Trueprop (\<forall>x. P x)"
  by standard (fact allI, fact allE)

subsubsection \<open>Derived connectives\<close>

definition False :: o
  where "False \<equiv> \<forall>A. A"

lemma FalseE [elim]:
  assumes "False"
  shows A
proof -
  from \<open>False\<close> have "\<forall>A. A" by (simp only: False_def)
  then show A ..
qed

definition True :: o
  where "True \<equiv> False \<longrightarrow> False"

lemma TrueI [intro]: True
  unfolding True_def ..

definition not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40)
  where "not \<equiv> \<lambda>A. A \<longrightarrow> False"

lemma notI [intro]:
  assumes "A \<Longrightarrow> False"
  shows "\<not> A"
  using assms unfolding not_def ..

lemma notE [elim]:
  assumes "\<not> A" and A
  shows B
proof -
  from \<open>\<not> A\<close> have "A \<longrightarrow> False" by (simp only: not_def)
  from this and \<open>A\<close> have "False" ..
  then show B ..
qed

lemma notE': "A \<Longrightarrow> \<not> A \<Longrightarrow> B"
  by (rule notE)

lemmas contradiction = notE notE'  \<comment> \<open>proof by contradiction in any order\<close>

definition conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35)
  where "A \<and> B \<equiv> \<forall>C. (A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> C"

lemma conjI [intro]:
  assumes A and B
  shows "A \<and> B"
  unfolding conj_def
proof
  fix C
  show "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> C"
  proof
    assume "A \<longrightarrow> B \<longrightarrow> C"
    also note \<open>A\<close>
    also note \<open>B\<close>
    finally show C .
  qed
qed

lemma conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> have *: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> C" for C
    unfolding conj_def ..
  show A
  proof -
    note * [of A]
    also have "A \<longrightarrow> B \<longrightarrow> A"
    proof
      assume A
      then show "B \<longrightarrow> A" ..
    qed
    finally show ?thesis .
  qed
  show B
  proof -
    note * [of B]
    also have "A \<longrightarrow> B \<longrightarrow> B"
    proof
      show "B \<longrightarrow> B" ..
    qed
    finally show ?thesis .
  qed
qed

definition disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
  where "A \<or> B \<equiv> \<forall>C. (A \<longrightarrow> C) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> C"

lemma disjI1 [intro]:
  assumes A
  shows "A \<or> B"
  unfolding disj_def
proof
  fix C
  show "(A \<longrightarrow> C) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> C"
  proof
    assume "A \<longrightarrow> C"
    from this and \<open>A\<close> have C ..
    then show "(B \<longrightarrow> C) \<longrightarrow> C" ..
  qed
qed

lemma disjI2 [intro]:
  assumes B
  shows "A \<or> B"
  unfolding disj_def
proof
  fix C
  show "(A \<longrightarrow> C) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> C"
  proof
    show "(B \<longrightarrow> C) \<longrightarrow> C"
    proof
      assume "B \<longrightarrow> C"
      from this and \<open>B\<close> show C ..
    qed
  qed
qed

lemma disjE [elim]:
  assumes "A \<or> B"
  obtains (a) A | (b) B
proof -
  from \<open>A \<or> B\<close> have "(A \<longrightarrow> thesis) \<longrightarrow> (B \<longrightarrow> thesis) \<longrightarrow> thesis"
    unfolding disj_def ..
  also have "A \<longrightarrow> thesis"
  proof
    assume A
    then show thesis by (rule a)
  qed
  also have "B \<longrightarrow> thesis"
  proof
    assume B
    then show thesis by (rule b)
  qed
  finally show thesis .
qed

definition Ex :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
  where "\<exists>x. P x \<equiv> \<forall>C. (\<forall>x. P x \<longrightarrow> C) \<longrightarrow> C"

lemma exI [intro]: "P a \<Longrightarrow> \<exists>x. P x"
  unfolding Ex_def
proof
  fix C
  assume "P a"
  show "(\<forall>x. P x \<longrightarrow> C) \<longrightarrow> C"
  proof
    assume "\<forall>x. P x \<longrightarrow> C"
    then have "P a \<longrightarrow> C" ..
    from this and \<open>P a\<close> show C ..
  qed
qed

lemma exE [elim]:
  assumes "\<exists>x. P x"
  obtains (that) x where "P x"
proof -
  from \<open>\<exists>x. P x\<close> have "(\<forall>x. P x \<longrightarrow> thesis) \<longrightarrow> thesis"
    unfolding Ex_def ..
  also have "\<forall>x. P x \<longrightarrow> thesis"
  proof
    fix x
    show "P x \<longrightarrow> thesis"
    proof
      assume "P x"
      then show thesis by (rule that)
    qed
  qed
  finally show thesis .
qed

subsubsection \<open>Extensional equality\<close>

axiomatization equal :: "'a \<Rightarrow> 'a \<Rightarrow> o"  (infixl "=" 50)
  where refl [intro]: "x = x"
    and subst: "x = y \<Longrightarrow> P x \<Longrightarrow> P y"

abbreviation not_equal :: "'a \<Rightarrow> 'a \<Rightarrow> o"  (infixl "\<noteq>" 50)
  where "x \<noteq> y \<equiv> \<not> (x = y)"

abbreviation iff :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longleftrightarrow>" 25)
  where "A \<longleftrightarrow> B \<equiv> A = B"

axiomatization
  where ext [intro]: "(\<And>x. f x = g x) \<Longrightarrow> f = g"
    and iff [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> (B \<Longrightarrow> A) \<Longrightarrow> A \<longleftrightarrow> B"
  for f g :: "'a \<Rightarrow> 'b"

lemma sym [sym]: "y = x" if "x = y"
  using that by (rule subst) (rule refl)

lemma [trans]: "x = y \<Longrightarrow> P y \<Longrightarrow> P x"
  by (rule subst) (rule sym)

lemma [trans]: "P x \<Longrightarrow> x = y \<Longrightarrow> P y"
  by (rule subst)

lemma arg_cong: "f x = f y" if "x = y"
  using that by (rule subst) (rule refl)

lemma fun_cong: "f x = g x" if "f = g"
  using that by (rule subst) (rule refl)

lemma trans [trans]: "x = y \<Longrightarrow> y = z \<Longrightarrow> x = z"
  by (rule subst)

lemma iff1 [elim]: "A \<longleftrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"
  by (rule subst)

lemma iff2 [elim]: "A \<longleftrightarrow> B \<Longrightarrow> B \<Longrightarrow> A"
  by (rule subst) (rule sym)

subsection \<open>Cantor's Theorem\<close>

text \<open>
  Cantor's Theorem states that there is no surjection from a set to its
  powerset. The subsequent formulation uses elementary \<open>\<lambda>\<close>-calculus and
  predicate logic, with standard introduction and elimination rules.
\<close>

lemma iff_contradiction:
  assumes *: "\<not> A \<longleftrightarrow> A"
  shows C
proof (rule notE)
  show "\<not> A"
  proof
    assume A
    with * have "\<not> A" ..
    from this and \<open>A\<close> show False ..
  qed
  with * show A ..
qed

theorem Cantor: "\<not> (\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> o. \<forall>A. \<exists>x. A = f x)"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> o. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a \<Rightarrow> o" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "\<lambda>x. \<not> f x x"
  from * have "\<exists>x. ?D = f x" ..
  then obtain a where "?D = f a" ..
  then have "?D a \<longleftrightarrow> f a a" using refl by (rule subst)
  then have "\<not> f a a \<longleftrightarrow> f a a" .
  then show False by (rule iff_contradiction)
qed

subsection \<open>Characterization of Classical Logic\<close>

text \<open>
  The subsequent rules of classical reasoning are all equivalent.
\<close>

locale classical =
  assumes classical: "(\<not> A \<Longrightarrow> A) \<Longrightarrow> A"
  \<comment> \<open>predicate definition and hypothetical context\<close>
begin

lemma classical_contradiction:
  assumes "\<not> A \<Longrightarrow> False"
  shows A
proof (rule classical)
  assume "\<not> A"
  then have False by (rule assms)
  then show A ..
qed

lemma double_negation:
  assumes "\<not> \<not> A"
  shows A
proof (rule classical_contradiction)
  assume "\<not> A"
  with \<open>\<not> \<not> A\<close> show False by (rule contradiction)
qed

lemma tertium_non_datur: "A \<or> \<not> A"
proof (rule double_negation)
  show "\<not> \<not> (A \<or> \<not> A)"
  proof
    assume "\<not> (A \<or> \<not> A)"
    have "\<not> A"
    proof
      assume A then have "A \<or> \<not> A" ..
      with \<open>\<not> (A \<or> \<not> A)\<close> show False by (rule contradiction)
    qed
    then have "A \<or> \<not> A" ..
    with \<open>\<not> (A \<or> \<not> A)\<close> show False by (rule contradiction)
  qed
qed

lemma classical_cases:
  obtains A | "\<not> A"
  using tertium_non_datur
proof
  assume A
  then show thesis ..
next
  assume "\<not> A"
  then show thesis ..
qed

end

lemma classical_if_cases: classical
  if cases: "\<And>A C. (A \<Longrightarrow> C) \<Longrightarrow> (\<not> A \<Longrightarrow> C) \<Longrightarrow> C"
proof
  fix A
  assume *: "\<not> A \<Longrightarrow> A"
  show A
  proof (rule cases)
    assume A
    then show A .
  next
    assume "\<not> A"
    then show A by (rule *)
  qed
qed

section \<open>Peirce's Law\<close>

text \<open>
  Peirce's Law is another characterization of classical reasoning. Its
  statement only requires implication.
\<close>

theorem (in classical) Peirce's_Law: "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof
  assume *: "(A \<longrightarrow> B) \<longrightarrow> A"
  show A
  proof (rule classical)
    assume "\<not> A"
    have "A \<longrightarrow> B"
    proof
      assume A
      with \<open>\<not> A\<close> show B by (rule contradiction)
    qed
    with * show A ..
  qed
qed

section \<open>Hilbert's choice operator (axiomatization)\<close>

axiomatization Eps :: "('a \<Rightarrow> o) \<Rightarrow> 'a"
  where someI: "P x \<Longrightarrow> P (Eps P)"

syntax "_Eps" :: "pttrn \<Rightarrow> o \<Rightarrow> 'a"  ("(3SOME _./ _)" [0, 10] 10)
translations "SOME x. P" \<rightleftharpoons> "CONST Eps (\<lambda>x. P)"

text \<open>
  \<^medskip>
  It follows a derivation of the classical law of tertium-non-datur by
  means of Hilbert's choice operator (due to Berghofer, Beeson, Harrison,
  based on a proof by Diaconescu).
  \<^medskip>
\<close>

theorem Diaconescu: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>x. (A \<and> x) \<or> \<not> x"
  let ?Q = "\<lambda>x. (A \<and> \<not> x) \<or> x"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    have "\<not> False" ..
    then show "?P False" ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    have True ..
    then show "?Q True" ..
  qed

  from a show ?thesis
  proof
    assume "A \<and> Eps ?P"
    then have A ..
    then show ?thesis ..
  next
    assume "\<not> Eps ?P"
    from b show ?thesis
    proof
      assume "A \<and> \<not> Eps ?Q"
      then have A ..
      then show ?thesis ..
    next
      assume "Eps ?Q"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        then have "Eps ?P \<longleftrightarrow> Eps ?Q" by (rule arg_cong)
        also note \<open>Eps ?Q\<close>
        finally have "Eps ?P" .
        with \<open>\<not> Eps ?P\<close> show False by (rule contradiction)
      qed
      have "\<not> A"
      proof
        assume A
        have "?P = ?Q"
        proof (rule ext)
          show "?P x \<longleftrightarrow> ?Q x" for x
          proof
            assume "?P x"
            then show "?Q x"
            proof
              assume "\<not> x"
              with \<open>A\<close> have "A \<and> \<not> x" ..
              then show ?thesis ..
            next
              assume "A \<and> x"
              then have x ..
              then show ?thesis ..
            qed
          next
            assume "?Q x"
            then show "?P x"
            proof
              assume "A \<and> \<not> x"
              then have "\<not> x" ..
              then show ?thesis ..
            next
              assume x
              with \<open>A\<close> have "A \<and> x" ..
              then show ?thesis ..
            qed
          qed
        qed
        with neq show False by (rule contradiction)
      qed
      then show ?thesis ..
    qed
  qed
qed

text \<open>
  This means, the hypothetical predicate \<^const>\<open>classical\<close> always holds
  unconditionally (with all consequences).
\<close>

interpretation classical
proof (rule classical_if_cases)
  fix A C
  assume *: "A \<Longrightarrow> C"
    and **: "\<not> A \<Longrightarrow> C"
  from Diaconescu [of A] show C
  proof
    assume A
    then show C by (rule *)
  next
    assume "\<not> A"
    then show C by (rule **)
  qed
qed

thm classical
  classical_contradiction
  double_negation
  tertium_non_datur
  classical_cases
  Peirce's_Law

end


section {* Finite functions *}

theory Ffun
imports Map_Extra Pfun FSet_extra
begin

subsection {* Finite function type and operations *}

typedef ('a, 'b) ffun = "{f :: ('a, 'b) pfun. finite(pdom(f))}"
  morphisms pfun_of Abs_pfun
  by (rule_tac x="{}\<^sub>p" in exI, auto)

setup_lifting type_definition_ffun

lift_definition ffun_app :: "('a, 'b) ffun \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>f" [999,0] 999) is "pfun_app" .

lift_definition ffun_upd :: "('a, 'b) ffun \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) ffun" is "pfun_upd" by simp

lift_definition fdom :: "('a, 'b) ffun \<Rightarrow> 'a set" is pdom .

lift_definition fran :: "('a, 'b) ffun \<Rightarrow> 'b set" is pran .

lift_definition ffun_comp :: "('b, 'c) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'c) ffun" (infixl "\<circ>\<^sub>f" 55) is pfun_comp by auto

lift_definition ffun_member :: "'a \<times> 'b \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<in>\<^sub>f" 50) is "op \<in>\<^sub>p" .

lift_definition fdom_res :: "'a set \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" (infixl "\<lhd>\<^sub>f" 85)
is "pdom_res" by simp

lift_definition fran_res :: "('a, 'b) ffun \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) ffun" (infixl "\<rhd>\<^sub>f" 85)
is pran_res by simp

lift_definition ffun_graph :: "('a, 'b) ffun \<Rightarrow> ('a \<times> 'b) set" is pfun_graph .

lift_definition graph_ffun :: "('a \<times> 'b) set \<Rightarrow> ('a, 'b) ffun" is
  "\<lambda> R. if (finite (Domain R)) then graph_pfun R else pempty"
  by (simp add: finite_Domain)

definition pcard :: "('a, 'b) pfun \<Rightarrow> nat"
where "pcard f = card (pdom f)"

instantiation ffun :: (type, type) zero
begin
lift_definition zero_ffun :: "('a, 'b) ffun" is "0" by simp
instance ..
end

abbreviation fempty :: "('a, 'b) ffun" ("{}\<^sub>f")
where "fempty \<equiv> 0"

instantiation ffun :: (type, type) plus
begin
lift_definition plus_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is "op +" by simp
instance ..
end

instantiation ffun :: (type, type) minus
begin
lift_definition minus_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is "op -"
  by (metis finite_Diff finite_Domain pdom_graph_pfun pdom_pfun_graph_finite pfun_graph_inv pfun_graph_minus)
instance ..
end

instance ffun :: (type, type) monoid_add
  by (intro_classes, (transfer, simp add: add.assoc)+)

instantiation ffun :: (type, type) inf
begin
lift_definition inf_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" is inf
  by (meson finite_Int infinite_super pdom_inter)
instance ..
end

abbreviation ffun_inter :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun" (infixl "\<inter>\<^sub>f" 80)
where "ffun_inter \<equiv> inf"

instantiation ffun :: (type, type) order
begin
  lift_definition less_eq_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" is
  "\<lambda> f g. f \<subseteq>\<^sub>p g" .
  lift_definition less_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" is
  "\<lambda> f g. f < g" .
instance
  by (intro_classes, (transfer, auto)+)
end

abbreviation ffun_subset :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<subset>\<^sub>f" 50)
where "ffun_subset \<equiv> less"

abbreviation ffun_subset_eq :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" (infix "\<subseteq>\<^sub>f" 50)
where "ffun_subset_eq \<equiv> less_eq"

instance ffun :: (type, type) semilattice_inf
  by (intro_classes, (transfer, auto)+)

lemma ffun_subset_eq_least [simp]:
  "{}\<^sub>f \<subseteq>\<^sub>f f"
  by (transfer, auto)

syntax
  "_FfunUpd"  :: "[('a, 'b) ffun, maplets] => ('a, 'b) ffun" ("_'(_')\<^sub>f" [900,0]900)
  "_Ffun"     :: "maplets => ('a, 'b) ffun"            ("(1{_}\<^sub>f)")

translations
  "_FfunUpd m (_Maplets xy ms)"  == "_FfunUpd (_FfunUpd m xy) ms"
  "_FfunUpd m (_maplet  x y)"    == "CONST ffun_upd m x y"
  "_Ffun ms"                     => "_FfunUpd (CONST fempty) ms"
  "_Ffun (_Maplets ms1 ms2)"     <= "_FfunUpd (_Ffun ms1) ms2"
  "_Ffun ms"                     <= "_FfunUpd (CONST fempty) ms"

subsection {* Algebraic laws *}

lemma ffun_comp_assoc: "f \<circ>\<^sub>f (g \<circ>\<^sub>f h) = (f \<circ>\<^sub>f g) \<circ>\<^sub>f h"
  by (transfer, simp add: pfun_comp_assoc)

lemma pfun_override_dist_comp:
  "(f + g) \<circ>\<^sub>f h = (f \<circ>\<^sub>f h) + (g \<circ>\<^sub>f h)"
  by (transfer, simp add: pfun_override_dist_comp)

lemma ffun_minus_unit [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "f - 0 = f"
  by (transfer, simp)

lemma ffun_minus_zero [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "0 - f = 0"
  by (transfer, simp)

lemma ffun_minus_self [simp]:
  fixes f :: "('a, 'b) ffun"
  shows "f - f = 0"
  by (transfer, simp)

lemma ffun_minus_plus_commute:
  "fdom(g) \<inter> fdom(h) = {} \<Longrightarrow> (f - g) + h = (f + h) - g"
  by (transfer, simp add: pfun_minus_plus_commute)

lemma ffun_plus_minus:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> (g - f) + f = g"
  by (transfer, simp add: pfun_plus_minus)

lemma ffun_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>f f; h \<subseteq>\<^sub>f g \<rbrakk> \<Longrightarrow> (f - h = g - h) = (f = g)"
  by (transfer, simp add: pfun_minus_common_subset)

lemma ffun_minus_plus:
  "fdom(f) \<inter> fdom(g) = {} \<Longrightarrow> (f + g) - g = f"
  by (transfer, simp add: pfun_minus_plus)

subsection {* Membership, application, and update *}

lemma ffun_ext: "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>f f \<longleftrightarrow> (x, y) \<in>\<^sub>f g \<rbrakk> \<Longrightarrow> f = g"
  by (transfer, simp add: pfun_ext)

lemma ffun_member_alt_def:
  "(x, y) \<in>\<^sub>f f \<longleftrightarrow> (x \<in> fdom f \<and> f(x)\<^sub>f = y)"
  by (transfer, simp add: pfun_member_alt_def)

lemma ffun_member_plus:
  "(x, y) \<in>\<^sub>f f + g \<longleftrightarrow> ((x \<notin> fdom(g) \<and> (x, y) \<in>\<^sub>f f) \<or> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_plus)

lemma ffun_member_minus:
  "(x, y) \<in>\<^sub>f f - g \<longleftrightarrow> (x, y) \<in>\<^sub>f f \<and> (\<not> (x, y) \<in>\<^sub>f g)"
  by (transfer, simp add: pfun_member_minus)

lemma ffun_app_upd_1 [simp]: "x = y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = v"
  by (transfer, simp)

lemma ffun_app_upd_2 [simp]: "x \<noteq> y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>f)(y)\<^sub>f = f(y)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_add [simp]: "f + g(x \<mapsto> v)\<^sub>f = (f + g)(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_twice [simp]: "f(x \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v)\<^sub>f"
  by (transfer, simp)

lemma ffun_upd_comm:
  assumes "x \<noteq> y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, simp add: pfun_upd_comm)

lemma ffun_upd_comm_linorder [simp]:
  fixes x y :: "'a :: linorder"
  assumes "x < y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>f = f(x \<mapsto> v, y \<mapsto> u)\<^sub>f"
  using assms by (transfer, auto)

lemma ffun_app_minus [simp]: "x \<notin> fdom g \<Longrightarrow> (f - g)(x)\<^sub>f = f(x)\<^sub>f"
  by (transfer, auto)

lemma ffun_upd_minus [simp]:
  "x \<notin> fdom g \<Longrightarrow> (f - g)(x \<mapsto> v)\<^sub>f = (f(x \<mapsto> v)\<^sub>f - g)"
  by (transfer, auto)

lemma fdom_member_minus_iff [simp]:
  "x \<notin> fdom g \<Longrightarrow> x \<in> fdom(f - g) \<longleftrightarrow> x \<in> fdom(f)"
  by (transfer, simp)

lemma fsubseteq_ffun_upd1 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(g) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_ffun_upd2 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; x \<notin> fdom(f) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma psubseteq_pfun_upd3 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>f g; g(x)\<^sub>f = v \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>f g(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fsubseteq_dom_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fdom(f) \<subseteq> fdom(g)"
  by (transfer, auto simp add: psubseteq_dom_subset)

lemma fsubseteq_ran_subset:
  "f \<subseteq>\<^sub>f g \<Longrightarrow> fran(f) \<subseteq> fran(g)"
  by (transfer, simp add: psubseteq_ran_subset)

subsection {* Domain laws *}

lemma fdom_zero [simp]: "fdom 0 = {}"
  by (transfer, simp)

lemma fdom_plus [simp]: "fdom (f + g) = fdom f \<union> fdom g"
  by (transfer, auto)

lemma fdom_inter: "fdom (f \<inter>\<^sub>f g) \<subseteq> fdom f \<inter> fdom g"
  by (transfer, meson pdom_inter)

lemma fdom_comp [simp]: "fdom (g \<circ>\<^sub>f f) = fdom (f \<rhd>\<^sub>f fdom g)"
  by (transfer, auto)

lemma fdom_upd [simp]: "fdom (f(k \<mapsto> v)\<^sub>f) = insert k (fdom f)"
  by (transfer, simp)

lemma fdom_fdom_res [simp]: "fdom (A \<lhd>\<^sub>f f) = A \<inter> fdom(f)"
  by (transfer, auto)

lemma fdom_graph_ffun [simp]:
  "finite (Domain R) \<Longrightarrow> fdom (graph_ffun R) = Domain R"
  by (transfer, simp add: Domain_fst graph_map_dom)

subsection {* Range laws *}

lemma fran_zero [simp]: "fran 0 = {}"
  by (transfer, simp)

lemma fran_upd [simp]: "fran (f(k \<mapsto> v)\<^sub>f) = insert v (fran ((- {k}) \<lhd>\<^sub>f f))"
  by (transfer, auto)

lemma fran_fran_res [simp]: "fran (f \<rhd>\<^sub>f A) = fran(f) \<inter> A"
  by (transfer, auto)

lemma fran_comp [simp]: "fran (g \<circ>\<^sub>f f) = fran (fran f \<lhd>\<^sub>f g)"
  by (transfer, auto)

subsection {* Domain restriction laws *}

lemma fdom_res_zero [simp]: "A \<lhd>\<^sub>f {}\<^sub>f = {}\<^sub>f"
  by (transfer, auto)

lemma pdom_res_upd_in [simp]:
  "k \<in> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = (A \<lhd>\<^sub>f f)(k \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma pdom_res_upd_out [simp]:
  "k \<notin> A \<Longrightarrow> A \<lhd>\<^sub>f f(k \<mapsto> v)\<^sub>f = A \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_override [simp]: "A \<lhd>\<^sub>f (f + g) = (A \<lhd>\<^sub>f f) + (A \<lhd>\<^sub>f g)"
  by (metis fdom_res.rep_eq pdom_res_override pfun_of_inject plus_ffun.rep_eq)

lemma fdom_res_minus [simp]: "A \<lhd>\<^sub>f (f - g) = (A \<lhd>\<^sub>f f) - g"
  by (transfer, auto)

lemma fdom_res_swap: "(A \<lhd>\<^sub>f f) \<rhd>\<^sub>f B = A \<lhd>\<^sub>f (f \<rhd>\<^sub>f B)"
  by (transfer, simp add: pdom_res_swap)

lemma fdom_res_twice [simp]: "A \<lhd>\<^sub>f (B \<lhd>\<^sub>f f) = (A \<inter> B) \<lhd>\<^sub>f f"
  by (transfer, auto)

lemma fdom_res_comp [simp]: "A \<lhd>\<^sub>f (g \<circ>\<^sub>f f) =  g \<circ>\<^sub>f (A \<lhd>\<^sub>f f)"
  by (transfer, simp)

subsection {* Range restriction laws *}

lemma fran_res_zero [simp]: "{}\<^sub>f \<rhd>\<^sub>f A = {}\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_1 [simp]: "v \<in> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = (f \<rhd>\<^sub>f A)(x \<mapsto> v)\<^sub>f"
  by (transfer, auto)

lemma fran_res_upd_2 [simp]: "v \<notin> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>f \<rhd>\<^sub>f A = ((- {x}) \<lhd>\<^sub>f f) \<rhd>\<^sub>f A"
  by (transfer, auto)

lemma fran_res_override: "(f + g) \<rhd>\<^sub>f A \<subseteq>\<^sub>f (f \<rhd>\<^sub>f A) + (g \<rhd>\<^sub>f A)"
  by (transfer, simp add: pran_res_override)

subsection {* Graph laws *}

lemma ffun_graph_inv: "graph_ffun (ffun_graph f) = f"
  by (transfer, auto simp add: pfun_graph_inv finite_Domain)

lemma ffun_graph_zero: "ffun_graph 0 = {}"
  by (transfer, simp add: pfun_graph_zero)

lemma ffun_graph_minus: "ffun_graph (f - g) = ffun_graph f - ffun_graph g"
  by (transfer, simp add: pfun_graph_minus)

lemma ffun_graph_inter: "ffun_graph (f \<inter>\<^sub>f g) = ffun_graph f \<inter> ffun_graph g"
  by (transfer, simp add: pfun_graph_inter)

text {* Hide implementation details for partial functions *}

lifting_update ffun.lifting
lifting_forget ffun.lifting

end


(*
    Authors:    Maximilian Haslbeck
                René Thiemann
    License:    BSD
*)
section \<open>Representing Computation Costs as Pairs of Results and Costs\<close>
theory Cost
  imports Main
begin

type_synonym 'a cost = "'a \<times> nat"

definition cost :: "'a cost \<Rightarrow> nat" where "cost = snd"
definition result :: "'a cost \<Rightarrow> 'a" where "result = fst"

lemma cost_simps: "cost (a,c) = c" "result (a,c) = a"
  unfolding cost_def result_def by auto

lemma result_costD: assumes "result f_c = f"
  "cost f_c \<le> b"
  "f_c = (a,c)"
shows "a = f" "c \<le> b" using assms by (auto simp: cost_simps)

lemma result_costD': assumes "result f_c = f \<and> cost f_c \<le> b"
  "f_c = (a,c)"
  shows "a = f" "c \<le> b" using assms by (auto simp: cost_simps)

end


(* Title:  Arc_Walk.thy
   Author: Lars Noschinski, TU München
*)

theory Arc_Walk
imports
  Digraph
begin

section \<open>Arc Walks\<close>

text \<open>
  We represent a walk in a graph by the list of its arcs.
\<close>

type_synonym 'b awalk = "'b list"

context pre_digraph begin

text \<open>
  The list of vertices of a walk. The additional vertex
  argument is there to deal with the case of empty walks.
\<close>
primrec awalk_verts :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a list" where
    "awalk_verts u [] = [u]"
  | "awalk_verts u (e # es) = tail G e # awalk_verts (head G e) es"

abbreviation awhd :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a" where
  "awhd u p \<equiv> hd (awalk_verts u p)"

abbreviation awlast:: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a" where
  "awlast u p \<equiv> last (awalk_verts u p)"

text \<open>
  Tests whether a list of arcs is a consistent arc sequence,
  i.e. a list of arcs, where the head G node of each arc is
  the tail G node of the following arc.
\<close>
fun cas :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "cas u [] v = (u = v)" |
  "cas u (e # es) v = (tail G e = u \<and> cas (head G e) es v)"

lemma cas_simp:
  assumes "es \<noteq> []"
  shows "cas u es v \<longleftrightarrow> tail G (hd es) = u \<and> cas (head G (hd es)) (tl es) v"
using assms by (cases es) auto

definition awalk :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "awalk u p v \<equiv> u \<in> verts G \<and> set p \<subseteq> arcs G \<and> cas u p v"

(* XXX: rename to atrail? *)
definition (in pre_digraph) trail :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "trail u p v \<equiv> awalk u p v \<and> distinct p"

definition apath :: "'a \<Rightarrow>'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "apath u p v \<equiv> awalk u p v \<and> distinct (awalk_verts u p)"

end

subsection \<open>Basic Lemmas\<close>

lemma (in pre_digraph) awalk_verts_conv:
  "awalk_verts u p = (if p = [] then [u] else map (tail G) p @ [head G (last p)])"
by (induct p arbitrary: u) auto

lemma (in pre_digraph) length_awalk_verts:
  "length (awalk_verts u p) = Suc (length p)"
by (simp add: awalk_verts_conv)

lemma (in pre_digraph) awalk_verts_ne_eq:
  assumes "p \<noteq> []"
  shows "awalk_verts u p = awalk_verts v p"
using assms by (auto simp: awalk_verts_conv)

lemma (in pre_digraph) awalk_verts_non_Nil[simp]:
  "awalk_verts u p \<noteq> []"
by (simp add: awalk_verts_conv)

context wf_digraph begin

lemma
  assumes "cas u p v"
  shows awhd_if_cas: "awhd u p = u" and awlast_if_cas: "awlast u p = v"
  using assms by (induct p arbitrary: u) auto

lemma awalk_verts_in_verts:
  assumes "u \<in> verts G" "set p \<subseteq> arcs G" "v \<in> set (awalk_verts u p)"
  shows "v \<in> verts G"
  using assms by (induct p arbitrary: u) (auto intro: wellformed)

lemma
  assumes "u \<in> verts G" "set p \<subseteq> arcs G"
  shows awhd_in_verts: "awhd u p \<in> verts G"
    and awlast_in_verts: "awlast u p \<in> verts G"
using assms by (auto elim: awalk_verts_in_verts)

lemma awalk_conv:
  "awalk u p v = (set (awalk_verts u p) \<subseteq> verts G
    \<and> set p \<subseteq> arcs G
    \<and> awhd u p = u \<and> awlast u p = v \<and> cas u p v)"
unfolding awalk_def using hd_in_set[OF awalk_verts_non_Nil, of u p]
by (auto intro: awalk_verts_in_verts awhd_if_cas awlast_if_cas simp del: hd_in_set)

lemma awalkI:
  assumes "set (awalk_verts u p) \<subseteq> verts G" "set p \<subseteq> arcs G" "cas u p v"
  shows "awalk u p v"
  using assms by (auto simp: awalk_conv awhd_if_cas awlast_if_cas)

lemma awalkE[elim]:
  assumes "awalk u p v"
  obtains "set (awalk_verts u p) \<subseteq> verts G" "set p \<subseteq> arcs G" "cas u p v"
    "awhd u p = u" "awlast u p = v"
using assms by (auto simp add: awalk_conv)

lemma awalk_Nil_iff:
  "awalk u [] v \<longleftrightarrow> u = v \<and> u \<in> verts G"
unfolding awalk_def by auto

lemma trail_Nil_iff:
  "trail u [] v \<longleftrightarrow> u = v \<and> u \<in> verts G"
  by (auto simp: trail_def awalk_Nil_iff)

lemma apath_Nil_iff: "apath u [] v \<longleftrightarrow> u = v \<and> u \<in> verts G"
  by (auto simp: apath_def awalk_Nil_iff)

lemma awalk_hd_in_verts: "awalk u p v \<Longrightarrow> u \<in> verts G"
  by (cases p) auto

lemma awalk_last_in_verts: "awalk u p v \<Longrightarrow> v \<in> verts G"
  unfolding awalk_conv by auto

lemma hd_in_awalk_verts:
  "awalk u p v \<Longrightarrow> u \<in> set (awalk_verts u p)"
  "apath u p v \<Longrightarrow> u \<in> set (awalk_verts u p)"
  by (case_tac [!]p) (auto simp: apath_def)

lemma awalk_Cons_iff:
  "awalk u (e # es) w \<longleftrightarrow> e \<in> arcs G \<and> u = tail G e \<and> awalk (head G e) es w"
  by (auto simp: awalk_def)

lemma trail_Cons_iff:
  "trail u (e # es ) w \<longleftrightarrow> e \<in> arcs G \<and> u = tail G e \<and> e \<notin> set es \<and> trail (head G e) es w"
  by (auto simp: trail_def awalk_Cons_iff)

lemma apath_Cons_iff:
  "apath u (e # es) w \<longleftrightarrow> e \<in> arcs G \<and> tail G e = u \<and> apath (head G e) es w
    \<and> tail G e \<notin> set (awalk_verts (head G e) es)" (is "?L \<longleftrightarrow> ?R")
by (auto simp: apath_def awalk_Cons_iff)

lemmas awalk_simps = awalk_Nil_iff awalk_Cons_iff
lemmas trail_simps = trail_Nil_iff trail_Cons_iff
lemmas apath_simps = apath_Nil_iff apath_Cons_iff

lemma arc_implies_awalk:
  "e \<in> arcs G \<Longrightarrow> awalk (tail G e) [e] (head G e)"
by (simp add: awalk_simps)

lemma apath_nonempty_ends:
  assumes "apath u p v"
  assumes "p \<noteq> []"
  shows "u \<noteq> v"
using assms
proof (induct p arbitrary: u)
  case (Cons e es)
  then have "apath (head G e) es v" "u \<notin> set (awalk_verts (head G e) es)"
    by (auto simp: apath_Cons_iff)
  moreover then have "v \<in> set (awalk_verts (head G e) es)" by (auto simp: apath_def)
  ultimately show "u \<noteq> v" by auto
qed simp

(* replace by awalk_Cons_iff?*)
lemma awalk_ConsI:
  assumes "awalk v es w"
  assumes "e \<in> arcs G" and "arc_to_ends G e = (u,v)"
  shows "awalk u (e # es) w"
  using assms by (cases es) (auto simp: awalk_def arc_to_ends_def)

lemma (in pre_digraph) awalkI_apath:
  assumes "apath u p v" shows "awalk u p v"
using assms by (simp add: apath_def)

lemma arcE:
  assumes "arc e (u,v)"
  assumes "\<lbrakk>e \<in> arcs G; tail G e = u; head G e = v\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp: arc_def)

lemma in_arcs_imp_in_arcs_ends:
  assumes "e \<in> arcs G"
  shows "(tail G e, head G e) \<in> arcs_ends G"
using assms by (auto simp: arcs_ends_conv)

lemma set_awalk_verts_cas:
  assumes "cas u p v"
  shows "set (awalk_verts u p) = {u} \<union> set (map (tail G) p) \<union> set (map (head G) p)"
using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by simp
next
  case (Cons e es)
  then have "set (awalk_verts (head G e) es)
      = {head G e} \<union> set (map (tail G) es) \<union> set (map (head G) es)"
    by (auto simp: awalk_Cons_iff)
  with Cons.prems show ?case by auto
qed

lemma set_awalk_verts_not_Nil_cas:
  assumes "cas u p v" "p \<noteq> []"
  shows "set (awalk_verts u p) = set (map (tail G) p) \<union> set (map (head G) p)"
proof -
  have "u \<in> set (map (tail G) p)" using assms by (cases p) auto
  with assms show ?thesis  by (auto simp: set_awalk_verts_cas)
qed

lemma
  awhd_of_awalk: "awalk u p v \<Longrightarrow> awhd u p = u" and
  awlast_of_awalk: "awalk u p v \<Longrightarrow> NOMATCH (awlast u p) v \<Longrightarrow> awlast u p = v"
  unfolding NOMATCH_def by auto
lemmas awends_of_awalk[simp] = awhd_of_awalk awlast_of_awalk

lemma awalk_verts_arc1:
  assumes "e \<in> set p"
  shows "tail G e \<in> set (awalk_verts u p)"
using assms by (auto simp: awalk_verts_conv)

lemma awalk_verts_arc2:
  assumes "awalk u p v" "e \<in> set p"
  shows "head G e \<in> set (awalk_verts u p)"
using assms by (simp add: set_awalk_verts)

lemma awalk_induct_raw[case_names Base Cons(*, induct pred: awalk*)]:
  assumes "awalk u p v"
  assumes "\<And>w1. w1 \<in> verts G \<Longrightarrow> P w1 [] w1"
  assumes "\<And>w1 w2 e es. e \<in> arcs G \<Longrightarrow> arc_to_ends G e = (w1, w2)
    \<Longrightarrow> P w2 es v \<Longrightarrow> P w1 (e # es) v"
  shows "P u p v"
using assms
proof (induct p arbitrary: u v)
  case Nil then show ?case using Nil.prems by auto
next
  case (Cons e es)
  from Cons.prems(1) show ?case
    by (intro Cons) (auto intro: Cons(2-) simp: arc_to_ends_def awalk_Cons_iff)
qed

subsection \<open>Appending awalks\<close>

lemma (in pre_digraph) cas_append_iff[simp]:
  "cas u (p @ q) v \<longleftrightarrow> cas u p (awlast u p) \<and> cas (awlast u p) q v"
by (induct u p v rule: cas.induct) auto

lemma cas_ends:
  assumes "cas u p v" "cas u' p v'"
  shows "(p \<noteq> [] \<and> u = u' \<and> v = v') \<or> (p = [] \<and> u = v \<and> u' = v')"
using assms by (induct u p v arbitrary: u u' rule: cas.induct) auto

lemma awalk_ends:
  assumes "awalk u p v" "awalk u' p v'"
  shows "(p \<noteq> [] \<and> u = u' \<and> v = v') \<or> (p = [] \<and> u = v \<and> u' = v')"
using assms by (simp add: awalk_def cas_ends)

lemma awalk_ends_eqD:
  assumes "awalk u p u" "awalk v p w"
  shows "v = w"
using awalk_ends[OF assms(1,2)] by auto

lemma awalk_empty_ends:
  assumes "awalk u [] v"
  shows "u = v"
using assms by (auto simp: awalk_def)

lemma apath_ends:
 assumes "apath u p v" and "apath u' p v'"
  shows "(p \<noteq> [] \<and> u \<noteq> v \<and> u = u' \<and> v = v') \<or> (p = [] \<and> u = v \<and> u' = v')"
using assms unfolding apath_def by (metis assms(2) apath_nonempty_ends  awalk_ends)

lemma awalk_append_iff[simp]:
  "awalk u (p @ q) v \<longleftrightarrow> awalk u p (awlast u p) \<and> awalk (awlast u p) q v" (is "?L \<longleftrightarrow> ?R")
by (auto simp: awalk_def intro: awlast_in_verts)

lemma awlast_append:
  "awlast u (p @ q) = awlast (awlast u p) q"
by (simp add: awalk_verts_conv)

lemma awhd_append:
  "awhd u (p @ q) = awhd (awhd u q) p"
by (simp add: awalk_verts_conv)

declare awalkE[rule del]

lemma awalkE'[elim]:
  assumes "awalk u p v"
  obtains "set (awalk_verts u p) \<subseteq> verts G" "set p \<subseteq> arcs G" "cas u p v"
    "awhd u p = u" "awlast u p = v" "u \<in> verts G" "v \<in> verts G"
proof -
  have "u \<in> set (awalk_verts u p)" "v \<in> set (awalk_verts u p)"
    using assms by (auto simp: hd_in_awalk_verts elim: awalkE)
  then show ?thesis using assms by (auto elim: awalkE intro: that)
qed

lemma awalk_appendI:
  assumes "awalk u p v"
  assumes "awalk v q w"
  shows "awalk u (p @ q) w"
using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by auto
next
  case (Cons e es)
  from Cons.prems have ee_e: "arc_to_ends G e = (u, head G e)"
    unfolding arc_to_ends_def by auto

  have "awalk (head G e) es v"
    using ee_e Cons(2) awalk_Cons_iff by auto
  then show ?case using Cons ee_e by (auto simp: awalk_Cons_iff)
qed

lemma awalk_verts_append_cas:
  assumes "cas u (p @ q) v"
  shows "awalk_verts u (p @ q) = awalk_verts u p @ tl (awalk_verts (awlast u p) q)"
  using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by (cases q) auto
qed (auto simp: awalk_Cons_iff)

lemma awalk_verts_append:
  assumes "awalk u (p @ q) v"
  shows "awalk_verts u (p @ q) = awalk_verts u p @ tl (awalk_verts (awlast u p) q)"
  using assms by (intro awalk_verts_append_cas) blast

lemma awalk_verts_append2:
  assumes "awalk u (p @ q) v"
  shows "awalk_verts u (p @ q) = butlast (awalk_verts u p) @ awalk_verts (awlast u p) q"
 using assms by (auto simp: awalk_verts_conv)

lemma apath_append_iff:
  "apath u (p @ q) v \<longleftrightarrow> apath u p (awlast u p) \<and> apath (awlast u p) q v \<and>
    set (awalk_verts u p) \<inter> set (tl (awalk_verts (awlast u p) q)) = {}" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then have "distinct (awalk_verts (awlast u p) q)" by (auto simp: apath_def awalk_verts_append2)
  with \<open>?L\<close> show ?R by (auto simp: apath_def awalk_verts_append)
next
  assume ?R
  then show ?L by (auto simp: apath_def awalk_verts_append dest: distinct_tl)
qed

lemma (in wf_digraph) set_awalk_verts_append_cas:
  assumes "cas u p v" "cas v q w"
  shows "set (awalk_verts u (p @ q)) = set (awalk_verts u p) \<union> set (awalk_verts v q)"
proof -
  from assms have cas_pq: "cas u (p @ q) w"
    by (simp add: awlast_if_cas)
  moreover
  from assms have "v \<in> set (awalk_verts u p)"
    by (metis awalk_verts_non_Nil awlast_if_cas last_in_set)
  ultimately show ?thesis using assms
    by (auto simp: set_awalk_verts_cas)
qed

lemma (in wf_digraph) set_awalk_verts_append:
  assumes "awalk u p v" "awalk v q w"
  shows "set (awalk_verts u (p @ q)) = set (awalk_verts u p) \<union> set (awalk_verts v q)"
proof -
  from assms have "awalk u (p @ q) w" by auto
  moreover
  with assms have "v \<in> set (awalk_verts u (p @ q))"
    by (auto simp: awalk_verts_append)
  ultimately show ?thesis using assms
    by (auto simp: set_awalk_verts)
qed

lemma cas_takeI:
  assumes "cas u p v" "awlast u (take n p) = v'"
  shows "cas u (take n p) v'"
proof -
  from assms have "cas u (take n p @ drop n p) v" by simp
  with assms show ?thesis unfolding cas_append_iff by simp
qed

lemma cas_dropI:
  assumes "cas u p v" "awlast u (take n p) = u'"
  shows "cas u' (drop n p) v"
proof -
  from assms have "cas u (take n p @ drop n p) v" by simp
  with assms show ?thesis unfolding cas_append_iff by simp
qed

lemma awalk_verts_take_conv:
  assumes "cas u p v"
  shows "awalk_verts u (take n p) = take (Suc n) (awalk_verts u p)"
proof -
  from assms have "cas u (take n p) (awlast u (take n p))" by (auto intro: cas_takeI)
  with assms show ?thesis
    by (cases n p rule: nat.exhaust[case_product list.exhaust])
       (auto simp: awalk_verts_conv' take_map simp del: awalk_verts.simps)
qed

lemma awalk_verts_drop_conv:
  assumes "cas u p v"
  shows "awalk_verts u' (drop n p) = (if n < length p then drop n (awalk_verts u p) else [u'])"
using assms by (auto simp: awalk_verts_conv drop_map)

lemma awalk_decomp_verts:
  assumes cas: "cas u p v" and ev_decomp: "awalk_verts u p = xs @ y # ys"
  obtains q r where "cas u q y" "cas y r v" "p = q @ r" "awalk_verts u q = xs @ [y]" "awalk_verts y r = y # ys"
using assms
proof -
  define q r where "q = take (length xs) p" and "r = drop (length xs) p"
  then have p: "p = q @ r" by simp
  moreover from p have "cas u q (awlast u q)" "cas (awlast u q) r v"
    using \<open>cas u p v\<close> by auto
  moreover have "awlast u q = y"
    using q_def and assms by (auto simp: awalk_verts_take_conv)
  moreover have *: "awalk_verts u q = xs @ [awlast u q]"
    using assms q_def by (auto simp: awalk_verts_take_conv)
  moreover from * have "awalk_verts y r = y # ys"
    unfolding q_def r_def using assms by (auto simp: awalk_verts_drop_conv not_less)
  ultimately show ?thesis by (intro that) auto
qed

lemma awalk_decomp:
  assumes "awalk u p v"
  assumes "w \<in> set (awalk_verts u p)"
  shows "\<exists>q r. p = q @ r \<and> awalk u q w \<and> awalk w r v"
proof -
  from assms have "cas u p v" by auto
  moreover from assms obtain xs ys where
    "awalk_verts u p = xs @ w # ys" by (auto simp: in_set_conv_decomp)
  ultimately
  obtain q r where "cas u q w" "cas w r v" "p = q @ r" "awalk_verts u q = xs @ [w]"
    by (auto intro: awalk_decomp_verts)
  with assms show ?thesis by auto
qed

lemma awalk_not_distinct_decomp:
  assumes "awalk u p v"
  assumes "\<not> distinct (awalk_verts u p)"
  shows "\<exists>q r s. p = q @ r @ s \<and> distinct (awalk_verts u q)
    \<and> 0 < length r
    \<and> (\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v)"
proof -
  from assms
  obtain xs ys zs y where
    pv_decomp: "awalk_verts u p = xs @ y # ys @ y # zs"
    and xs_y_props: "distinct xs" "y \<notin> set xs" "y \<notin> set ys"
    using not_distinct_decomp_min_prefix by blast

  obtain q p' where "cas u q y" "p = q @ p'" "awalk_verts u q = xs @ [y]"
    and p'_props: "cas y p' v"  "awalk_verts y p' = (y # ys) @ y # zs"
    using assms pv_decomp by - (rule awalk_decomp_verts, auto)
  obtain r s where "cas y r y" "cas y s v" "p' = r @ s"
    "awalk_verts y r = y # ys @ [y]" "awalk_verts y s = y # zs"
    using p'_props by (rule awalk_decomp_verts) auto

  have "p = q @ r @ s" using \<open>p = q @ p'\<close> \<open>p' = r @ s\<close> by simp
  moreover
  have "distinct (awalk_verts u q)" using \<open>awalk_verts u q = xs @ [y]\<close> and xs_y_props  by simp
  moreover
  have "0 < length r" using \<open>awalk_verts y r = y # ys @ [y]\<close> by auto
  moreover
  from pv_decomp assms have "y \<in> verts G" by auto
  then have "awalk u q y" "awalk y r y" "awalk y s v"
    using \<open>awalk u p v\<close> \<open>cas u q y\<close> \<open>cas y r y\<close> \<open>cas y s v\<close> unfolding \<open>p = q @ r @ s\<close>
    by (auto simp: awalk_def)
  ultimately show ?thesis by blast
qed

lemma apath_decomp_disjoint:
  assumes "apath u p v"
  assumes "p = q @ r"
  assumes "x \<in> set (awalk_verts u q)" "x \<in> set (tl (awalk_verts (awlast u q) r))"
  shows False
using assms by (auto simp: apath_def awalk_verts_append)

subsection \<open>Cycles\<close>

definition closed_w :: "'b awalk \<Rightarrow> bool" where
  "closed_w p \<equiv> \<exists>u. awalk u p u \<and> 0 < length p"

text \<open>
  The definitions of cycles in textbooks vary w.r.t to the minimial length
  of a cycle.

  The definition given here matches \cite{diestel2010graph}.
  \cite{bangjensen2009digraphs} excludes loops from being cycles.
  Volkmann (Lutz Volkmann: Graphen an allen Ecken und Kanten, 2006 (?))
  places no restriction on the length in the definition, but later
  usage assumes cycles to be non-empty.
\<close>
definition (in pre_digraph) cycle :: "'b awalk \<Rightarrow> bool" where
  "cycle p \<equiv> \<exists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> p \<noteq> []"

lemma cycle_altdef:
  "cycle p \<longleftrightarrow> closed_w p \<and> (\<exists>u. distinct (tl (awalk_verts u p)))"
by (cases p) (auto simp: closed_w_def cycle_def)

lemma (in wf_digraph) distinct_tl_verts_imp_distinct:
  assumes "awalk u p v"
  assumes "distinct (tl (awalk_verts u p))"
  shows "distinct p"
proof (rule ccontr)
  assume "\<not>distinct p"
  then obtain e xs ys zs where p_decomp: "p = xs @ e # ys @ e # zs"
    by (blast dest: not_distinct_decomp_min_prefix)
  then show False
    using assms p_decomp by (auto simp: awalk_verts_append awalk_Cons_iff set_awalk_verts)
qed

lemma (in wf_digraph) distinct_verts_imp_distinct:
  assumes "awalk u p v"
  assumes "distinct (awalk_verts u p)"
  shows "distinct p"
  using assms by (blast intro: distinct_tl_verts_imp_distinct distinct_tl)

lemma (in wf_digraph) cycle_conv:
  "cycle p \<longleftrightarrow> (\<exists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> distinct p \<and> p \<noteq> [])"
  unfolding cycle_def by (auto intro: distinct_tl_verts_imp_distinct)

lemma (in loopfree_digraph) cycle_digraph_conv:
  "cycle p \<longleftrightarrow> (\<exists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> 2 \<le> length p)" (is "?L \<longleftrightarrow> ?R")
proof
  assume "cycle p"
  then obtain u where *: "awalk u p u" "distinct (tl (awalk_verts u p))" "p \<noteq> []"
    unfolding cycle_def by auto
  have "2 \<le> length p"
  proof (rule ccontr)
    assume "\<not>?thesis" with * obtain e where "p=[e]"
      by (cases p) (auto simp: not_le)
    then show False using * by (auto simp: awalk_simps dest: no_loops)
  qed
  then show ?R using * by auto
qed (auto simp: cycle_def)

lemma (in wf_digraph) closed_w_imp_cycle:
  assumes "closed_w p" shows "\<exists>p. cycle p"
  using assms
proof (induct "length p" arbitrary: p rule: less_induct)
  case less
  then obtain u where *: "awalk u p u" "p \<noteq> []" by (auto simp: closed_w_def)
  show ?thesis
  proof cases
    assume "distinct (tl (awalk_verts u p))"
    with less show ?thesis by (auto simp: closed_w_def cycle_altdef)
  next
    assume A: "\<not>distinct (tl (awalk_verts u p))"
    then obtain e es where "p = e # es" by (cases p) auto
    with A * have **: "awalk (head G e) es u" "\<not>distinct (awalk_verts (head G e) es)"
      by (auto simp: awalk_Cons_iff)
    obtain q r s where "es = q @ r @ s" "\<exists>w. awalk w r w" "closed_w r"
      using awalk_not_distinct_decomp[OF **] by (auto simp: closed_w_def)
    then have "length r < length p" using \<open>p = _\<close> by auto
    then show ?thesis using \<open>closed_w r\<close> by (rule less)
  qed
qed

subsection \<open>Reachability\<close>

lemma reachable1_awalk:
  "u \<rightarrow>\<^sup>+ v \<longleftrightarrow> (\<exists>p. awalk u p v \<and> p \<noteq> [])"
proof
  assume "u \<rightarrow>\<^sup>+ v" then show "\<exists>p. awalk u p v \<and> p \<noteq> []"
  proof (induct rule: converse_trancl_induct)
    case (base y) then obtain e where "e \<in> arcs G" "tail G e = y" "head G e = v" by auto
    with arc_implies_awalk show ?case by auto
  next
    case (step x y)
    then obtain p where "awalk y p v" "p \<noteq> []" by auto
    moreover
    from \<open>x \<rightarrow> y\<close> obtain e where "tail G e = x" "head G e = y" "e \<in> arcs G"
      by auto
    ultimately
    have "awalk x (e # p) v"
      by (auto simp: awalk_Cons_iff)
    then show ?case by auto
  qed
next
  assume "\<exists>p. awalk u p v \<and> p \<noteq> []" then obtain p where "awalk u p v" "p \<noteq> []" by auto
  thus "u \<rightarrow>\<^sup>+ v"
  proof (induct p arbitrary: u)
    case (Cons a as) then show ?case
      by (cases "as = []") (auto simp: awalk_simps trancl_into_trancl2 dest: in_arcs_imp_in_arcs_ends)
  qed simp
qed

lemma reachable_awalk:
  "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (\<exists>p. awalk u p v)"
proof cases
  assume "u = v"
  have "u \<rightarrow>\<^sup>*u \<longleftrightarrow> awalk u [] u" by (auto simp: awalk_Nil_iff reachable_in_verts)
  also have "\<dots> \<longleftrightarrow> (\<exists>p. awalk u p u)"
    by (metis awalk_Nil_iff awalk_hd_in_verts)
  finally show ?thesis using \<open>u = v\<close> by simp
next
  assume "u \<noteq> v"
  then have "u \<rightarrow>\<^sup>* v \<longleftrightarrow> u \<rightarrow>\<^sup>+ v" by auto
  also have "\<dots> \<longleftrightarrow> (\<exists>p. awalk u p v)"
    using \<open>u \<noteq> v\<close> unfolding reachable1_awalk by force
  finally show ?thesis .
qed

lemma reachable_awalkI[intro?]:
  assumes "awalk u p v"
  shows "u \<rightarrow>\<^sup>* v"
  unfolding reachable_awalk using assms by auto

lemma reachable1_awalkI:
  "awalk v p w \<Longrightarrow> p \<noteq> [] \<Longrightarrow> v \<rightarrow>\<^sup>+ w"
by (auto simp add: reachable1_awalk)

lemma reachable_arc_trans:
  assumes "u \<rightarrow>\<^sup>* v" "arc e (v,w)"
  shows "u \<rightarrow>\<^sup>* w"
proof -
  from \<open>u \<rightarrow>\<^sup>* v\<close> obtain p where "awalk u p v"
    by (auto simp: reachable_awalk)
  moreover have "awalk v [e] w"
    using \<open>arc e (v,w)\<close>
    by (auto simp: arc_def awalk_def)
  ultimately have "awalk u (p @ [e]) w"
    by (rule awalk_appendI)
  then show ?thesis ..
qed

lemma awalk_verts_reachable_from:
  assumes "awalk u p v" "w \<in> set (awalk_verts u p)" shows "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> w"
proof  -
  obtain s where "awalk u s w" using awalk_decomp[OF assms] by blast
  then show ?thesis by (metis reachable_awalk)
qed

lemma awalk_verts_reachable_to:
  assumes "awalk u p v" "w \<in> set (awalk_verts u p)" shows "w \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
proof  -
  obtain s where "awalk w s v" using awalk_decomp[OF assms] by blast
  then show ?thesis by (metis reachable_awalk)
qed

subsection \<open>Paths\<close>

lemma (in fin_digraph) length_apath_less:
  assumes "apath u p v"
  shows "length p < card (verts G)"
proof -
  have "length p < length (awalk_verts u p)" unfolding awalk_verts_conv
    by (auto simp: awalk_verts_conv)
  also have "length (awalk_verts u p) = card (set (awalk_verts u p))"
    using \<open>apath u p v\<close> by (auto simp: apath_def distinct_card)
  also have "\<dots> \<le> card (verts G)"
    using \<open>apath u p v\<close> unfolding apath_def awalk_conv
    by (auto intro: card_mono)
  finally show ?thesis .
qed

lemma (in fin_digraph) length_apath:
  assumes "apath u p v"
  shows "length p \<le> card (verts G)"
  using length_apath_less[OF assms] by auto

lemma (in fin_digraph) apaths_finite_triple:
  shows "finite {(u,p,v). apath u p v}"
proof -
  have "\<And>u p v. awalk u p v \<Longrightarrow> distinct (awalk_verts u p) \<Longrightarrow>length p \<le> card (verts G)"
    by (rule length_apath) (auto simp: apath_def)
  then have "{(u,p,v). apath u p v} \<subseteq> verts G \<times> {es. set es \<subseteq> arcs G \<and> length es \<le> card (verts G)} \<times> verts G"
    by (auto simp: apath_def)
  moreover have "finite ..."
    using finite_verts finite_arcs
    by (intro finite_cartesian_product finite_lists_length_le)
  ultimately show ?thesis by (rule finite_subset)
qed

lemma (in fin_digraph) apaths_finite:
  shows "finite {p. apath u p v}"
proof -
  have "{p. apath u p v} \<subseteq> (fst o snd) ` {(u,p,v). apath u p v}"
    by force
  with apaths_finite_triple show ?thesis  by (rule finite_surj)
qed

fun is_awalk_cyc_decomp :: "'b awalk =>
  ('b awalk \<times> 'b awalk \<times> 'b awalk) \<Rightarrow> bool" where
  "is_awalk_cyc_decomp p (q,r,s) \<longleftrightarrow> p = q @ r @ s
    \<and> (\<exists>u v w. awalk u q v \<and> awalk v r v \<and> awalk v s w)
    \<and> 0 <length r
    \<and> (\<exists>u. distinct (awalk_verts u q))"

definition awalk_cyc_decomp :: "'b awalk
    \<Rightarrow> 'b awalk \<times> 'b awalk \<times> 'b awalk" where
  "awalk_cyc_decomp p = (SOME qrs. is_awalk_cyc_decomp p qrs)"

function awalk_to_apath :: "'b awalk \<Rightarrow> 'b awalk" where
  "awalk_to_apath p = (if \<not>(\<exists>u. distinct (awalk_verts u p)) \<and> (\<exists>u v. awalk u p v)
     then (let (q,r,s) = awalk_cyc_decomp p in awalk_to_apath (q @ s))
     else p)"
by auto

lemma awalk_cyc_decomp_has_prop:
  assumes "awalk u p v" and "\<not>distinct (awalk_verts u p)"
  shows "is_awalk_cyc_decomp p (awalk_cyc_decomp p)"
proof -
  obtain q r s where *: "p = q @ r @ s \<and> distinct (awalk_verts u q)
      \<and> 0 < length r
      \<and> (\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v)"
    by (atomize_elim) (rule awalk_not_distinct_decomp[OF assms])
  then have "\<exists>x. is_awalk_cyc_decomp p x"
    by (intro exI[where x="(q,r,s)"]) auto
  then show ?thesis unfolding awalk_cyc_decomp_def ..
qed

lemma awalk_cyc_decompE:
  assumes dec: "awalk_cyc_decomp p = (q,r,s)"
  assumes p_props: "awalk u p v" "\<not>distinct (awalk_verts u p)"
  obtains "p = q @ r @ s" "distinct (awalk_verts u q)" "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" "closed_w r"
proof
  show "p = q @ r @ s" "distinct (awalk_verts u q)" "closed_w r"
    using awalk_cyc_decomp_has_prop[OF p_props] and dec
    by (auto simp: closed_w_def awalk_verts_conv)
  then have "p \<noteq> []" by (auto simp: closed_w_def)

  (* TODO: Can we find some general rules to prove the last property?*)
  obtain u' w' v' where obt_awalk: "awalk u' q w'" "awalk w' r w'" "awalk w' s v'"
    using awalk_cyc_decomp_has_prop[OF p_props] and dec by auto
  then have "awalk u' p v'"
    using \<open>p = q @ r @ s\<close> by simp
  then have "u = u'" and "v = v'" using \<open>p \<noteq> []\<close> \<open>awalk u p v\<close> by (metis awalk_ends)+
  then have "awalk u q w'" "awalk w' r w'" "awalk w' s v"
    using obt_awalk by auto
  then show "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" by auto
qed

lemma awalk_cyc_decompE':
  assumes p_props: "awalk u p v" "\<not>distinct (awalk_verts u p)"
  obtains q r s where "p = q @ r @ s" "distinct (awalk_verts u q)" "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" "closed_w r"
proof -
  obtain q r s where "awalk_cyc_decomp p = (q,r,s)"
    by (cases "awalk_cyc_decomp p") auto
  then have "p = q @ r @ s" "distinct (awalk_verts u q)" "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" "closed_w r"
    using assms by (auto elim: awalk_cyc_decompE)
  then show ?thesis ..
qed

termination awalk_to_apath
proof (relation "measure length")
  fix G p qrs rs q r s

  have X: "\<And>x y. closed_w r \<Longrightarrow> awalk x r y \<Longrightarrow> x = y"
    unfolding closed_w_def by (blast dest: awalk_ends)

  assume "\<not>(\<exists>u. distinct (awalk_verts u p)) \<and>(\<exists>u v. awalk u p v)"
    and **:"qrs = awalk_cyc_decomp p" "(q, rs) = qrs" "(r, s) = rs"
  then obtain u v where *: "awalk u p v" "\<not>distinct (awalk_verts u p)"
    by (cases p) auto
  then have "awalk_cyc_decomp p = (q,r,s)" using ** by simp
  then have "is_awalk_cyc_decomp p (q,r,s)"
    apply (rule awalk_cyc_decompE[OF _ *])
    using X[of "awlast u q"  "awlast (awlast u q) r"] *(1)
    by (auto simp: closed_w_def)
  then show "(q @ s, p) \<in> measure length"
    by (auto simp: closed_w_def)
qed simp
declare awalk_to_apath.simps[simp del]

lemma awalk_to_apath_induct[consumes 1, case_names path decomp]:
  assumes awalk: "awalk u p v"
  assumes dist: "\<And>p. awalk u p v \<Longrightarrow> distinct (awalk_verts u p) \<Longrightarrow> P p"
  assumes dec: "\<And>p q r s. \<lbrakk>awalk u p v; awalk_cyc_decomp p = (q,r,s);
    \<not>distinct (awalk_verts u p); P (q @ s)\<rbrakk> \<Longrightarrow> P p"
  shows "P p"
using awalk
proof (induct "length p" arbitrary: p rule: less_induct)
  case less
  show ?case
  proof (cases "distinct (awalk_verts u p)")
    case True then show ?thesis by (auto intro: dist less.prems)
  next
    case False
    obtain q r s where p_cdecomp: "awalk_cyc_decomp p = (q,r,s)"
      by (cases "awalk_cyc_decomp p") auto
    then have "is_awalk_cyc_decomp p (q,r,s)" "p = q @ r @ s"
      using awalk_cyc_decomp_has_prop[OF less.prems(1) False] by auto
    then have "length (q @ s) < length p" "awalk u (q @ s) v"
      using less.prems by (auto dest!: awalk_ends_eqD)
    then have "P (q @ s)" by (auto intro: less)

    with p_cdecomp False show ?thesis by (auto intro: dec less.prems)
  qed
qed

lemma step_awalk_to_apath:
  assumes awalk: "awalk u p v"
    and decomp: "awalk_cyc_decomp p = (q, r, s)"
    and dist: "\<not> distinct (awalk_verts u p)"
  shows "awalk_to_apath p = awalk_to_apath (q @ s)"
proof -
  from dist have "\<not>(\<exists>u. distinct (awalk_verts u p))"
    by (auto simp: awalk_verts_conv)
  with awalk and decomp show "awalk_to_apath p = awalk_to_apath (q @ s)"
    by (auto simp: awalk_to_apath.simps)
qed

lemma apath_awalk_to_apath:
  assumes "awalk u p v"
  shows "apath u (awalk_to_apath p) v"
using assms
proof (induct rule: awalk_to_apath_induct)
  case (path p)
  then have "awalk_to_apath p = p"
    by (auto simp: awalk_to_apath.simps)
  then show ?case using path by (auto simp: apath_def)
next
  case (decomp p q r s)
  then show ?case using step_awalk_to_apath[of _ p _ q r s] by simp
qed

lemma (in wf_digraph) awalk_to_apath_subset:
  assumes "awalk u p v"
  shows "set (awalk_to_apath p) \<subseteq> set p"
using assms
proof (induct rule: awalk_to_apath_induct)
  case (path p)
  then have "awalk_to_apath p = p"
    by (auto simp: awalk_to_apath.simps)
  then show ?case by simp
next
  case (decomp p q r s)
  have *: "\<not>(\<exists>u. distinct (awalk_verts u p)) \<and> (\<exists>u v. awalk u p v)"
    using decomp by (cases p) auto
  have "set (awalk_to_apath (q @ s)) \<subseteq> set p"
    using decomp by (auto elim!: awalk_cyc_decompE)
  then
  show ?case by (subst awalk_to_apath.simps) (simp only: * simp_thms if_True decomp Let_def prod.simps)
qed

lemma reachable_apath:
  "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (\<exists>p. apath u p v)"
  by (auto intro: awalkI_apath apath_awalk_to_apath simp: reachable_awalk)

lemma no_loops_in_apath:
  assumes "apath u p v" "a \<in> set p" shows "tail G a \<noteq> head G a"
proof -
  from \<open>a \<in> set p\<close> obtain p1 p2 where "p = p1 @ a # p2" by (auto simp: in_set_conv_decomp)
  with \<open>apath u p v\<close> have "apath (tail G a) ([a] @ p2) (v)"
    by (auto simp: apath_append_iff apath_Cons_iff apath_Nil_iff)
  then have "apath (tail G a) [a] (head G a)" by - (drule apath_append_iff[THEN iffD1], simp)
  then show ?thesis by (auto simp:  apath_Cons_iff)
qed

end

end