section \<open>Approximate Operations on Intervals of Floating Point Numbers\<close>
theory Interval_Float
  imports
    Interval
    Float
begin

definition mid :: "float interval \<Rightarrow> float"
  where "mid i = (lower i + upper i) * Float 1 (-1)"

lemma mid_in_interval: "mid i \<in>\<^sub>i i"
  using lower_le_upper[of i]
  by (auto simp: mid_def set_of_eq powr_minus)

lemma mid_le: "lower i \<le> mid i" "mid i \<le> upper i"
  using mid_in_interval
  by (auto simp: set_of_eq)

definition centered :: "float interval \<Rightarrow> float interval"
  where "centered i = i - interval_of (mid i)"

definition "split_float_interval x = split_interval x ((lower x + upper x) * Float 1 (-1))"

lemma split_float_intervalD: "split_float_interval X = (A, B) \<Longrightarrow> set_of X \<subseteq> set_of A \<union> set_of B"
  by (auto dest!: split_intervalD simp: split_float_interval_def)

lemma split_float_interval_bounds:
  shows
    lower_split_float_interval1: "lower (fst (split_float_interval X)) = lower X"
  and lower_split_float_interval2: "lower (snd (split_float_interval X)) = mid X"
  and upper_split_float_interval1: "upper (fst (split_float_interval X)) = mid X"
  and upper_split_float_interval2: "upper (snd (split_float_interval X)) = upper X"
  using mid_le[of X]
  by (auto simp: split_float_interval_def mid_def[symmetric] min_def max_def real_of_float_eq
      lower_split_interval1 lower_split_interval2
      upper_split_interval1 upper_split_interval2)

lemmas float_round_down_le[intro] = order_trans[OF float_round_down]
  and float_round_up_ge[intro] = order_trans[OF _ float_round_up]

text \<open>TODO: many of the lemmas should move to theories Float or Approximation
  (the latter should be based on type @{type interval}.\<close>

subsection "Intervals with Floating Point Bounds"

context includes interval.lifting begin

lift_definition round_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval"
  is "\<lambda>p. \<lambda>(l, u). (float_round_down p l, float_round_up p u)"
  by (auto simp: intro!: float_round_down_le float_round_up_le)

lemma lower_round_ivl[simp]: "lower (round_interval p x) = float_round_down p (lower x)"
  by transfer auto
lemma upper_round_ivl[simp]: "upper (round_interval p x) = float_round_up p (upper x)"
  by transfer auto

lemma round_ivl_correct: "set_of A \<subseteq> set_of (round_interval prec A)"
  by (auto simp: set_of_eq float_round_down_le float_round_up_le)

lift_definition truncate_ivl :: "nat \<Rightarrow> real interval \<Rightarrow> real interval"
  is "\<lambda>p. \<lambda>(l, u). (truncate_down p l, truncate_up p u)"
  by (auto intro!: truncate_down_le truncate_up_le)

lemma lower_truncate_ivl[simp]: "lower (truncate_ivl p x) = truncate_down p (lower x)"
  by transfer auto
lemma upper_truncate_ivl[simp]: "upper (truncate_ivl p x) = truncate_up p (upper x)"
  by transfer auto

lemma truncate_ivl_correct: "set_of A \<subseteq> set_of (truncate_ivl prec A)"
  by (auto simp: set_of_eq intro!: truncate_down_le truncate_up_le)

lift_definition real_interval::"float interval \<Rightarrow> real interval"
  is "\<lambda>(l, u). (real_of_float l, real_of_float u)"
  by auto

lemma lower_real_interval[simp]: "lower (real_interval x) = lower x"
  by transfer auto
lemma upper_real_interval[simp]: "upper (real_interval x) = upper x"
  by transfer auto

definition "set_of' x = (case x of None \<Rightarrow> UNIV | Some i \<Rightarrow> set_of (real_interval i))"

lemma real_interval_min_interval[simp]:
  "real_interval (min_interval a b) = min_interval (real_interval a) (real_interval b)"
  by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_min)

lemma real_interval_max_interval[simp]:
  "real_interval (max_interval a b) = max_interval (real_interval a) (real_interval b)"
  by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max)

lemma in_intervalI:
  "x \<in>\<^sub>i X" if "lower X \<le> x" "x \<le> upper X"
  using that by (auto simp: set_of_eq)

abbreviation in_real_interval ("(_/ \<in>\<^sub>r _)" [51, 51] 50) where
  "x \<in>\<^sub>r X \<equiv> x \<in>\<^sub>i real_interval X"

lemma in_real_intervalI:
  "x \<in>\<^sub>r X" if "lower X \<le> x" "x \<le> upper X" for x::real and X::"float interval"
  using that
  by (intro in_intervalI) auto

subsection \<open>intros for \<open>real_interval\<close>\<close>

lemma in_round_intervalI: "x \<in>\<^sub>r A  \<Longrightarrow> x \<in>\<^sub>r (round_interval prec A)"
  by (auto simp: set_of_eq float_round_down_le float_round_up_le)

lemma zero_in_float_intervalI: "0 \<in>\<^sub>r 0"
  by (auto simp: set_of_eq)

lemma plus_in_float_intervalI: "a + b \<in>\<^sub>r A + B" if "a \<in>\<^sub>r A" "b \<in>\<^sub>r B"
  using that
  by (auto simp: set_of_eq)

lemma minus_in_float_intervalI: "a - b \<in>\<^sub>r A - B" if "a \<in>\<^sub>r A" "b \<in>\<^sub>r B"
  using that
  by (auto simp: set_of_eq)

lemma uminus_in_float_intervalI: "-a \<in>\<^sub>r -A" if "a \<in>\<^sub>r A"
  using that
  by (auto simp: set_of_eq)

lemma real_interval_times: "real_interval (A * B) = real_interval A * real_interval B"
  by (auto simp: interval_eq_iff lower_times upper_times min_def max_def)

lemma times_in_float_intervalI: "a * b \<in>\<^sub>r A * B" if "a \<in>\<^sub>r A" "b \<in>\<^sub>r B"
  using times_in_intervalI[OF that]
  by (auto simp: real_interval_times)

lemma real_interval_abs: "real_interval (abs_interval A) = abs_interval (real_interval A)"
  by (auto simp: interval_eq_iff min_def max_def)

lemma abs_in_float_intervalI: "abs a \<in>\<^sub>r abs_interval A" if "a \<in>\<^sub>r A"
  by (auto simp: set_of_abs_interval real_interval_abs intro!: imageI that)

lemma interval_of[intro,simp]: "x \<in>\<^sub>r interval_of x"
  by (auto simp: set_of_eq)

lemma split_float_interval_realD: "split_float_interval X = (A, B) \<Longrightarrow> x \<in>\<^sub>r X \<Longrightarrow> x \<in>\<^sub>r A \<or> x \<in>\<^sub>r B"
  by (auto simp: set_of_eq prod_eq_iff split_float_interval_bounds)

subsection \<open>bounds for lists\<close>

lemma lower_Interval: "lower (Interval x) = fst x"
  and upper_Interval: "upper (Interval x) = snd x"
  if "fst x \<le> snd x"
  using that
  by (auto simp: lower_def upper_def Interval_inverse split_beta')

definition all_in_i :: "'a::preorder list \<Rightarrow> 'a interval list \<Rightarrow> bool"
  (infix "(all'_in\<^sub>i)" 50)
  where "x all_in\<^sub>i I = (length x = length I \<and> (\<forall>i < length I. x ! i \<in>\<^sub>i I ! i))"

definition all_in :: "real list \<Rightarrow> float interval list \<Rightarrow> bool"
  (infix "(all'_in)" 50)
  where "x all_in I = (length x = length I \<and> (\<forall>i < length I. x ! i \<in>\<^sub>r I ! i))"

definition all_subset :: "'a::order interval list \<Rightarrow> 'a interval list \<Rightarrow> bool"
  (infix "(all'_subset)" 50)
  where "I all_subset J = (length I = length J \<and> (\<forall>i < length I. set_of (I!i) \<subseteq> set_of (J!i)))"

lemmas [simp] = all_in_def all_subset_def

lemma all_subsetD:
  assumes "I all_subset J"
  assumes "x all_in I"
  shows "x all_in J"
  using assms
  by (auto simp: set_of_eq; fastforce)

lemma round_interval_mono: "set_of (round_interval prec X) \<subseteq> set_of (round_interval prec Y)"
  if "set_of X \<subseteq> set_of Y"
  using that
  by transfer
    (auto simp: float_round_down.rep_eq float_round_up.rep_eq truncate_down_mono truncate_up_mono)

lemma Ivl_simps[simp]: "lower (Ivl a b) = min a b" "upper (Ivl a b) = b"
  subgoal by transfer simp
  subgoal by transfer simp
  done

lemma set_of_subset_iff: "set_of X \<subseteq> set_of Y \<longleftrightarrow> lower Y \<le> lower X \<and> upper X \<le> upper Y"
  for X Y::"'a::linorder interval"
  by (auto simp: set_of_eq subset_iff)

lemma set_of_subset_iff':
  "set_of a \<subseteq> set_of (b :: 'a :: linorder interval) \<longleftrightarrow> a \<le> b"
  unfolding less_eq_interval_def set_of_subset_iff ..

lemma bounds_of_interval_eq_lower_upper:
  "bounds_of_interval ivl = (lower ivl, upper ivl)" if "lower ivl \<le> upper ivl"
  using that
  by (auto simp: lower.rep_eq upper.rep_eq)

lemma real_interval_Ivl: "real_interval (Ivl a b) = Ivl a b"
  by transfer (auto simp: min_def)

lemma set_of_mul_contains_real_zero:
  "0 \<in>\<^sub>r (A * B)" if "0 \<in>\<^sub>r A \<or> 0 \<in>\<^sub>r B"
  using that set_of_mul_contains_zero[of A B]
  by (auto simp: set_of_eq)

fun subdivide_interval :: "nat \<Rightarrow> float interval \<Rightarrow> float interval list"
  where "subdivide_interval 0 I = [I]"
  | "subdivide_interval (Suc n) I = (
         let m = mid I
         in (subdivide_interval n (Ivl (lower I) m)) @ (subdivide_interval n (Ivl m (upper I)))
       )"

lemma subdivide_interval_length:
  shows "length (subdivide_interval n I) = 2^n"
  by(induction n arbitrary: I, simp_all add: Let_def)

lemma lower_le_mid: "lower x \<le> mid x" "real_of_float (lower x) \<le> mid x"
  and mid_le_upper: "mid x \<le> upper x" "real_of_float (mid x) \<le> upper x"
  unfolding mid_def
  subgoal by transfer (auto simp: powr_neg_one)
  subgoal by transfer (auto simp: powr_neg_one)
  subgoal by transfer (auto simp: powr_neg_one)
  subgoal by transfer (auto simp: powr_neg_one)
  done

lemma subdivide_interval_correct:
  "list_ex (\<lambda>i. x \<in>\<^sub>r i) (subdivide_interval n I)" if "x \<in>\<^sub>r I" for x::real
  using that
proof(induction n arbitrary: x I)
  case 0
  then show ?case by simp
next
  case (Suc n)
  from \<open>x \<in>\<^sub>r I\<close> consider "x \<in>\<^sub>r Ivl (lower I) (mid I)" | "x \<in>\<^sub>r Ivl (mid I) (upper I)"
    by (cases "x \<le> real_of_float (mid I)")
      (auto simp: set_of_eq min_def lower_le_mid mid_le_upper)
  from this[case_names lower upper] show ?case
    by cases (use Suc.IH in \<open>auto simp: Let_def\<close>)
qed

fun interval_list_union :: "'a::lattice interval list \<Rightarrow> 'a interval"
  where "interval_list_union [] = undefined"
  | "interval_list_union [I] = I"
  | "interval_list_union (I#Is) = sup I (interval_list_union Is)"

lemma interval_list_union_correct:
  assumes "S \<noteq> []"
  assumes "i < length S"
  shows "set_of (S!i) \<subseteq> set_of (interval_list_union S)"
  using assms
proof(induction S arbitrary: i)
  case (Cons a S i)
  thus ?case
  proof(cases S)
    fix b S'
    assume "S = b # S'"
    hence "S \<noteq> []"
      by simp
    show ?thesis
    proof(cases i)
      case 0
      show ?thesis
        apply(cases S)
        using interval_union_mono1
        by (auto simp add: 0)
    next
      case (Suc i_prev)
      hence "i_prev < length S"
        using Cons(3) by simp

      from Cons(1)[OF \<open>S \<noteq> []\<close> this] Cons(1)
      have "set_of ((a # S) ! i) \<subseteq> set_of (interval_list_union S)"
        by (simp add: \<open>i = Suc i_prev\<close>)
      also have "... \<subseteq> set_of (interval_list_union (a # S))"
        using \<open>S \<noteq> []\<close>
        apply(cases S)
        using interval_union_mono2
        by auto
      finally show ?thesis .
    qed
  qed simp
qed simp

lemma split_domain_correct:
  fixes x :: "real list"
  assumes "x all_in I"
  assumes split_correct: "\<And>x a I. x \<in>\<^sub>r I \<Longrightarrow> list_ex (\<lambda>i::float interval. x \<in>\<^sub>r i) (split I)"
  shows "list_ex (\<lambda>s. x all_in s) (split_domain split I)"
  using assms(1)
proof(induction I arbitrary: x)
  case (Cons I Is x)
  have "x \<noteq> []"
    using Cons(2) by auto
  obtain x' xs where x_decomp: "x = x' # xs"
    using \<open>x \<noteq> []\<close> list.exhaust by auto
  hence "x' \<in>\<^sub>r I" "xs all_in Is"
    using Cons(2)
    by auto
  show ?case
    using Cons(1)[OF \<open>xs all_in Is\<close>]
      split_correct[OF \<open>x' \<in>\<^sub>r I\<close>]
    apply (auto simp add: list_ex_iff set_of_eq)
    by (smt (verit, ccfv_SIG) One_nat_def Suc_pred \<open>x \<noteq> []\<close> le_simps(3) length_greater_0_conv length_tl linorder_not_less list.sel(3) neq0_conv nth_Cons' x_decomp)
qed simp

lift_definition(code_dt) inverse_float_interval::"nat \<Rightarrow> float interval \<Rightarrow> float interval option" is
  "\<lambda>prec (l, u). if (0 < l \<or> u < 0) then Some (float_divl prec 1 u, float_divr prec 1 l) else None"
  by (auto intro!: order_trans[OF float_divl] order_trans[OF _ float_divr]
      simp: divide_simps)

lemma inverse_float_interval_eq_Some_conv:
  defines "one \<equiv> (1::float)"
  shows
    "inverse_float_interval p X = Some R \<longleftrightarrow>
    (lower X > 0 \<or> upper X < 0) \<and>
    lower R = float_divl p one (upper X) \<and>
    upper R = float_divr p one (lower X)"
  by clarsimp (transfer fixing: one, force simp: one_def split: if_splits)

lemma inverse_float_interval:
  "inverse ` set_of (real_interval X) \<subseteq> set_of (real_interval Y)"
  if "inverse_float_interval p X = Some Y"
  using that
  apply (clarsimp simp: set_of_eq inverse_float_interval_eq_Some_conv)
  by (intro order_trans[OF float_divl] order_trans[OF _ float_divr] conjI)
    (auto simp: divide_simps)

lemma inverse_float_intervalI:
  "x \<in>\<^sub>r X \<Longrightarrow> inverse x \<in> set_of' (inverse_float_interval p X)"
  using inverse_float_interval[of p X]
  by (auto simp: set_of'_def split: option.splits)

lemma inverse_float_interval_eqI: "inverse_float_interval p X = Some IVL \<Longrightarrow> x \<in>\<^sub>r X \<Longrightarrow> inverse x \<in>\<^sub>r IVL"
  using inverse_float_intervalI[of x X p]
  by (auto simp: set_of'_def)

lemma real_interval_abs_interval[simp]:
  "real_interval (abs_interval x) = abs_interval (real_interval x)"
  by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max real_of_float_min)

lift_definition floor_float_interval::"float interval \<Rightarrow> float interval" is
  "\<lambda>(l, u). (floor_fl l, floor_fl u)"
  by (auto intro!: floor_mono simp: floor_fl.rep_eq)

lemma lower_floor_float_interval[simp]: "lower (floor_float_interval x) = floor_fl (lower x)"
  by transfer auto
lemma upper_floor_float_interval[simp]: "upper (floor_float_interval x) = floor_fl (upper x)"
  by transfer auto

lemma floor_float_intervalI: "\<lfloor>x\<rfloor> \<in>\<^sub>r floor_float_interval X" if "x \<in>\<^sub>r X"
  using that by (auto simp: set_of_eq floor_fl_def floor_mono)

end

subsection \<open>constants for code generation\<close>

definition lowerF::"float interval \<Rightarrow> float" where "lowerF = lower"
definition upperF::"float interval \<Rightarrow> float" where "upperF = upper"

end


section \<open>Deciding Equivalence of Extended Regular Expressions\<close>

theory Equivalence_Checking2
imports Regular_Exp2 "HOL-Library.While_Combinator"
begin

subsection \<open>Term ordering\<close>

fun le_rexp :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> bool"
where
  "le_rexp Zero _ = True"
| "le_rexp _ Zero = False"
| "le_rexp One _ = True"
| "le_rexp _ One = False"
| "le_rexp (Atom a) (Atom b) = (a <= b)"
| "le_rexp (Atom _) _ = True"
| "le_rexp _ (Atom _) = False"
| "le_rexp (Star r) (Star s) = le_rexp r s"
| "le_rexp (Star _) _ = True"
| "le_rexp _ (Star _) = False"
| "le_rexp (Not r) (Not s) = le_rexp r s"
| "le_rexp (Not _) _ = True"
| "le_rexp _ (Not _) = False"
| "le_rexp (Plus r r') (Plus s s') =
    (if r = s then le_rexp r' s' else le_rexp r s)"
| "le_rexp (Plus _ _) _ = True"
| "le_rexp _ (Plus _ _) = False"
| "le_rexp (Times r r') (Times s s') =
    (if r = s then le_rexp r' s' else le_rexp r s)"
| "le_rexp (Times _ _) _ = True"
| "le_rexp _ (Times _ _) = False"
| "le_rexp (Inter r r') (Inter s s') =
    (if r = s then le_rexp r' s' else le_rexp r s)"

subsection \<open>Normalizing operations\<close>

text \<open>associativity, commutativity, idempotence, zero\<close>

fun nPlus :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nPlus Zero r = r"
| "nPlus r Zero = r"
| "nPlus (Plus r s) t = nPlus r (nPlus s t)"
| "nPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if le_rexp r s then Plus r (Plus s t)
     else Plus s (nPlus r t))"
| "nPlus r s =
     (if r = s then r
      else if le_rexp r s then Plus r s
      else Plus s r)"

lemma lang_nPlus[simp]: "lang S (nPlus r s) = lang S (Plus r s)"
by (induct r s rule: nPlus.induct) auto

text \<open>associativity, zero, one\<close>

fun nTimes :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nTimes Zero _ = Zero"
| "nTimes _ Zero = Zero"
| "nTimes One r = r"
| "nTimes r One = r"
| "nTimes (Times r s) t = Times r (nTimes s t)"
| "nTimes r s = Times r s"

lemma lang_nTimes[simp]: "lang S (nTimes r s) = lang S (Times r s)"
by (induct r s rule: nTimes.induct) (auto simp: conc_assoc)

text \<open>more optimisations:\<close>

fun nInter :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nInter Zero _ = Zero"
| "nInter _ Zero = Zero"
| "nInter r s = Inter r s"

lemma lang_nInter[simp]: "lang S (nInter r s) = lang S (Inter r s)"
by (induct r s rule: nInter.induct) (auto)

primrec norm :: "nat rexp \<Rightarrow> nat rexp"
where
  "norm Zero = Zero"
| "norm One = One"
| "norm (Atom a) = Atom a"
| "norm (Plus r s) = nPlus (norm r) (norm s)"
| "norm (Times r s) = nTimes (norm r) (norm s)"
| "norm (Star r) = Star (norm r)"
| "norm (Not r) = Not (norm r)"
| "norm (Inter r1 r2) = nInter (norm r1) (norm r2)"

lemma lang_norm[simp]: "lang S (norm r) = lang S r"
by (induct r) auto

subsection \<open>Derivative\<close>

primrec nderiv :: "nat \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nderiv _ Zero = Zero"
| "nderiv _ One = Zero"
| "nderiv a (Atom b) = (if a = b then One else Zero)"
| "nderiv a (Plus r s) = nPlus (nderiv a r) (nderiv a s)"
| "nderiv a (Times r s) =
    (let r's = nTimes (nderiv a r) s
     in if nullable r then nPlus r's (nderiv a s) else r's)"
| "nderiv a (Star r) = nTimes (nderiv a r) (Star r)"
| "nderiv a (Not r) = Not (nderiv a r)"
| "nderiv a (Inter r1 r2) = nInter (nderiv a r1) (nderiv a r2)"

lemma lang_nderiv: "a:S \<Longrightarrow> lang S (nderiv a r) = Deriv a (lang S r)"
by (induct r) (auto simp: Let_def nullable_iff[where S=S])

lemma atoms_nPlus[simp]: "atoms (nPlus r s) = atoms r \<union> atoms s"
by (induct r s rule: nPlus.induct) auto

lemma atoms_nTimes: "atoms (nTimes r s) \<subseteq> atoms r \<union> atoms s"
by (induct r s rule: nTimes.induct) auto

lemma atoms_nInter: "atoms (nInter r s) \<subseteq> atoms r \<union> atoms s"
by (induct r s rule: nInter.induct) auto

lemma atoms_norm: "atoms (norm r) \<subseteq> atoms r"
by (induct r) (auto dest!:subsetD[OF atoms_nTimes]subsetD[OF atoms_nInter])

lemma atoms_nderiv: "atoms (nderiv a r) \<subseteq> atoms r"
by (induct r) (auto simp: Let_def dest!:subsetD[OF atoms_nTimes]subsetD[OF atoms_nInter])

subsection \<open>Bisimulation between languages and regular expressions\<close>

context
fixes S :: "'a set"
begin

coinductive bisimilar :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> bool" where
"K \<subseteq> lists S \<Longrightarrow> L \<subseteq> lists S
 \<Longrightarrow> ([] \<in> K \<longleftrightarrow> [] \<in> L)
 \<Longrightarrow> (\<And>x. x:S \<Longrightarrow> bisimilar (Deriv x K) (Deriv x L))
 \<Longrightarrow> bisimilar K L"

lemma equal_if_bisimilar:
assumes "K \<subseteq> lists S" "L \<subseteq> lists S" "bisimilar K L" shows "K = L"
proof (rule set_eqI)
  fix w
  from assms show "w \<in> K \<longleftrightarrow> w \<in> L"
  proof (induction w arbitrary: K L)
    case Nil thus ?case by (auto elim: bisimilar.cases)
  next
    case (Cons a w K L)
    show ?case
    proof cases
      assume "a : S"
      with \<open>bisimilar K L\<close> have "bisimilar (Deriv a K) (Deriv a L)"
        by (auto elim: bisimilar.cases)
      then have "w \<in> Deriv a K \<longleftrightarrow> w \<in> Deriv a L"
        by (metis Cons.IH bisimilar.cases)
      thus ?case by (auto simp: Deriv_def)
    next
      assume "a \<notin> S"
      thus ?case using Cons.prems by auto
    qed
  qed
qed

lemma language_coinduct:
fixes R (infixl "\<sim>" 50)
assumes "\<And>K L. K \<sim> L \<Longrightarrow> K \<subseteq> lists S \<and> L \<subseteq> lists S"
assumes "K \<sim> L"
assumes "\<And>K L. K \<sim> L \<Longrightarrow> ([] \<in> K \<longleftrightarrow> [] \<in> L)"
assumes "\<And>K L x. K \<sim> L \<Longrightarrow> x : S \<Longrightarrow> Deriv x K \<sim> Deriv x L"
shows "K = L"
apply (rule equal_if_bisimilar)
apply (metis assms(1) assms(2))
apply (metis assms(1) assms(2))
apply (rule bisimilar.coinduct[of R, OF \<open>K \<sim> L\<close>])
apply (auto simp: assms)
done

end

type_synonym rexp_pair = "nat rexp * nat rexp"
type_synonym rexp_pairs = "rexp_pair list"

definition is_bisimulation :: "nat list \<Rightarrow> rexp_pairs \<Rightarrow> bool"
where
"is_bisimulation as ps =
  (\<forall>(r,s)\<in> set ps. (atoms r \<union> atoms s \<subseteq> set as) \<and> (nullable r \<longleftrightarrow> nullable s) \<and>
    (\<forall>a\<in>set as. (nderiv a r, nderiv a s) \<in> set ps))"

lemma bisim_lang_eq:
assumes bisim: "is_bisimulation as ps"
assumes "(r, s) \<in> set ps"
shows "lang (set as) r = lang (set as) s"
proof -
  let ?R = "\<lambda>K L. (\<exists>(r,s)\<in>set ps. K = lang (set as) r \<and> L = lang (set as) s)"
  show ?thesis
  proof (rule language_coinduct[where R="?R" and S = "set as"])
    from \<open>(r, s) \<in> set ps\<close> show "?R (lang (set as) r) (lang (set as) s)"
      by auto
  next
    fix K L assume "?R K L"
    then obtain r s where rs: "(r, s) \<in> set ps"
      and KL: "K = lang (set as) r" "L = lang (set as) s" by auto
    with bisim have "nullable r \<longleftrightarrow> nullable s"
      by (auto simp: is_bisimulation_def)
    thus "[] \<in> K \<longleftrightarrow> [] \<in> L" by (auto simp: nullable_iff[where S="set as"] KL)
  txt\<open>next case, but shared context\<close>
    from bisim rs KL lang_subset_lists[of _ "set as"]
    show "K \<subseteq> lists (set as) \<and> L \<subseteq> lists (set as)"
      unfolding is_bisimulation_def by blast
  txt\<open>next case, but shared context\<close>
    fix a assume "a \<in> set as"
    with rs bisim
    have "(nderiv a r, nderiv a s) \<in> set ps"
      by (auto simp: is_bisimulation_def)
    thus "?R (Deriv a K) (Deriv a L)" using \<open>a \<in> set as\<close>
      by (force simp: KL lang_nderiv)
  qed
qed

subsection \<open>Closure computation\<close>

fun test :: "rexp_pairs * rexp_pairs \<Rightarrow> bool"
where "test (ws, ps) = (case ws of [] \<Rightarrow>  False | (p,q)#_ \<Rightarrow> nullable p = nullable q)"

fun step :: "nat list \<Rightarrow> rexp_pairs * rexp_pairs \<Rightarrow> rexp_pairs * rexp_pairs"
where "step as (ws,ps) =
    (let
      (r, s) = hd ws;
      ps' = (r, s) # ps;
      succs = map (\<lambda>a. (nderiv a r, nderiv a s)) as;
      new = filter (\<lambda>p. p \<notin> set ps' \<union> set ws) succs
    in (new @ tl ws, ps'))"

definition closure ::
  "nat list \<Rightarrow> rexp_pairs * rexp_pairs
   \<Rightarrow> (rexp_pairs * rexp_pairs) option" where
"closure as = while_option test (step as)"

definition pre_bisim :: "nat list \<Rightarrow> nat rexp \<Rightarrow> nat rexp \<Rightarrow>
 rexp_pairs * rexp_pairs \<Rightarrow> bool"
where
"pre_bisim as r s = (\<lambda>(ws,ps).
 ((r, s) \<in> set ws \<union> set ps) \<and>
 (\<forall>(r,s)\<in> set ws \<union> set ps. atoms r \<union> atoms s \<subseteq> set as) \<and>
 (\<forall>(r,s)\<in> set ps. (nullable r \<longleftrightarrow> nullable s) \<and>
   (\<forall>a\<in>set as. (nderiv a r, nderiv a s) \<in> set ps \<union> set ws)))"

subsection \<open>The overall procedure\<close>

primrec add_atoms :: "nat rexp \<Rightarrow> nat list \<Rightarrow> nat list"
where
  "add_atoms Zero = id"
| "add_atoms One = id"
| "add_atoms (Atom a) = List.insert a"
| "add_atoms (Plus r s) = add_atoms s o add_atoms r"
| "add_atoms (Times r s) = add_atoms s o add_atoms r"
| "add_atoms (Not r) = add_atoms r"
| "add_atoms (Inter r s) = add_atoms s o add_atoms r"
| "add_atoms (Star r) = add_atoms r"

lemma set_add_atoms: "set (add_atoms r as) = atoms r \<union> set as"
by (induct r arbitrary: as) auto

definition check_eqv :: "nat list \<Rightarrow> nat rexp \<Rightarrow> nat rexp \<Rightarrow> bool"
where
"check_eqv as r s \<longleftrightarrow> set(add_atoms r (add_atoms s [])) \<subseteq> set as \<and>
  (case closure as ([(norm r, norm s)], []) of
     Some([],_) \<Rightarrow> True | _ \<Rightarrow> False)"

lemma "check_eqv [0] (Plus One (Times (Atom 0) (Star(Atom 0)))) (Star(Atom 0))"
by eval

lemma "check_eqv [0,1] (Not(Atom 0))
  (Plus One (Times (Plus (Atom 1) (Times (Atom 0) (Plus (Atom 0) (Atom 1))))
                   (Star(Plus (Atom 0) (Atom 1)))))"
by eval

lemma "check_eqv [0] (Atom 0) (Inter (Star (Atom 0)) (Atom 0))"
by eval

end


theory Chapter12_2
imports "~~/src/HOL/IMP/Hoare_Examples"
begin

text{*
\section*{Chapter 12}

\setcounter{exercise}{1}

\exercise
Define @{text bsubst} and prove the Substitution Lemma:
*}

fun bsubst :: "bexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> bexp" where
(* your definition/proof here *)

lemma bsubstitution: "bval (bsubst b a x) s = bval b (s[a/x])"
(* your definition/proof here *)

text{*
This may require a similar definition and proof for @{typ aexp}.
\endexercise

\exercise
Define a command @{text cmax} that stores the maximum of the values of the IMP variables
@{text "x"} and @{text "y"} in the IMP variable @{text "z"} and prove that
@{text cmax} satisfies its specification:
*}

abbreviation cmax :: com where
(* your definition/proof here *)

lemma "\<turnstile> {\<lambda>s. True} cmax {\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')}"
(* your definition/proof here *)

text{*
Function @{const max} is the predefined maximum function.
Proofs about @{const max} are often automatic when simplifying with @{thm[source] max_def}.
\endexercise

\exercise\label{exe:Hoare:sumeq}
Define an equality operation for arithmetic expressions
*}

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text{* such that *}

lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text{* Prove the following variant of the summation command correct: *}

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''y'' ::= N 0;;
     WHILE Not(Eq (V ''x'') (N 0))
     DO (''y'' ::= Plus (V ''y'') (V ''x'');;
           ''x'' ::= Plus (V ''x'') (N (-1)))
     {\<lambda>s. s ''y'' = sum i}"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Prove that the following command computes @{prop"y - x"} if @{prop"(0::nat) \<le> x"}:
*}

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
     WHILE Less (N 0) (V ''x'')
     DO (''x'' ::= Plus (V ''x'') (N (-1));; ''y'' ::= Plus (V ''y'') (N (-1)))
     {\<lambda>t. t ''y'' = y - x}"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:Hoare:mult}
Define and verify a command @{text cmult} that stores the product of
@{text "x"} and @{text "y"} in @{text "z"} assuming @{prop"(0::int)\<le>y"}:
*}

abbreviation cmult :: com where
(* your definition/proof here *)

lemma
  "\<turnstile> {\<lambda>s.  s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} cmult {\<lambda>t. t ''z'' = x*y}"
(* your definition/proof here *)

text{*
You may have to simplify with @{thm[source] algebra_simps} to deal with ``@{text"*"}''.
\endexercise

\exercise\label{exe:Hoare:sqrt}
The following command computes an integer approximation @{text r} of the square root
of @{text "i \<ge> 0"}, i.e.\ @{text"r\<^sup>2 \<le> i < (r+1)\<^sup>2"}. Prove
*}

lemma
  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''r'' ::= N 0;; ''r2'' ::= N 1;;
     WHILE (Not (Less (V ''x'') (V ''r2'')))
     DO (''r'' ::= Plus (V ''r'') (N 1);;
            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
(* your definition/proof here *)

text{*
Figure out how @{text r2} is related to @{text r} before
formulating the invariant.
The proof may require simplification with @{thm[source] algebra_simps}
and @{thm[source] power2_eq_square}.
\endexercise

\exercise
Prove by induction:
*}

lemma "\<turnstile> {P} c {\<lambda>s. True}"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:fwdassign}
Design and prove correct a forward assignment rule of the form
\ \mbox{@{text"\<turnstile> {P} x ::= a {?}"}} \
where @{text"?"} is some suitable postcondition that depends on @{text P},
@{text x} and @{text a}. Hint: @{text"?"} may need @{text"\<exists>"}.
*}

lemma "\<turnstile> {P} x ::= a {Questionmark}"
(* your definition/proof here *)
text{*
(In case you wonder if your @{text Questionmark} is strong enough: see Exercise~\ref{exe:sp})
\endexercise
*}
end


(*  Title:       DualCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter DualCategory

theory DualCategory
imports Category
begin

  text\<open>
    The locale defined here constructs the dual (opposite) of a category.
    The arrows of the dual category are directly identified with the arrows of
    the given category and simplification rules are introduced that automatically
    eliminate notions defined for the dual category in favor of the corresponding
    notions on the original category.  This makes it easy to use the dual of
    a category in the same context as the category itself, without having to
    worry about whether an arrow belongs to the category or its dual.
\<close>

  locale dual_category =
    C: category C
  for C :: "'a comp"     (infixr "\<cdot>" 55)
  begin

    definition comp      (infixr "\<cdot>\<^sup>o\<^sup>p" 55)
    where "g \<cdot>\<^sup>o\<^sup>p f \<equiv> f \<cdot> g"

    lemma comp_char [simp]:
    shows "g \<cdot>\<^sup>o\<^sup>p f = f \<cdot> g"
      using comp_def by auto

    interpretation partial_magma comp
      apply unfold_locales using comp_def C.ex_un_null by metis

    notation in_hom ("\<guillemotleft>_ : _ \<leftarrow> _\<guillemotright>")

    lemma null_char [simp]:
    shows "null = C.null"
      by (metis C.comp_null(2) comp_null(2) comp_def)

    lemma ide_char [simp]:
    shows "ide a \<longleftrightarrow> C.ide a"
      unfolding ide_def C.ide_def by auto

    lemma domains_char:
    shows "domains f = C.codomains f"
      using C.codomains_def domains_def ide_char by auto

    lemma codomains_char:
    shows "codomains f = C.domains f"
      using C.domains_def codomains_def ide_char by auto

    interpretation category comp
      using C.has_domain_iff_arr C.has_codomain_iff_arr domains_char codomains_char null_char
            comp_def C.match_4 C.ext arr_def C.comp_assoc
      apply (unfold_locales, auto)
      using C.match_2 by metis

    lemma is_category:
    shows "category comp" ..

  end

  sublocale dual_category \<subseteq> category comp
    using is_category by auto

  context dual_category
  begin

    lemma dom_char [simp]:
    shows "dom f = C.cod f"
      by (simp add: C.cod_def dom_def domains_char)

    lemma cod_char [simp]:
    shows "cod f = C.dom f"
      by (simp add: C.dom_def cod_def codomains_char)

    lemma arr_char [simp]:
    shows "arr f \<longleftrightarrow> C.arr f"
      using C.has_codomain_iff_arr has_domain_iff_arr domains_char by auto

    lemma hom_char [simp]:
    shows "in_hom f b a \<longleftrightarrow> C.in_hom f a b"
      by force

    lemma seq_char [simp]:
    shows "seq g f = C.seq f g"
      by simp

  end

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Evaluation of Functions\<close>
theory SFunctions_Base
  imports
    SBinary_Relations_Right_Unique
    SBinary_Relations_Left_Total
begin

definition "eval f x \<equiv> THE y. \<langle>x, y\<rangle> \<in> f"

bundle hotg_eval_syntax begin notation eval ("(_`_)" [999, 1000] 999) end
bundle no_hotg_eval_syntax begin no_notation eval ("(_`_)" [999, 1000] 999) end
unbundle hotg_eval_syntax

lemma eval_eqI:
  assumes "set_right_unique_on P f"
  and "P x"
  and "\<langle>x, y\<rangle> \<in> f"
  shows "f`x = y"
  using assms unfolding eval_def by (auto dest: set_right_unique_onD)

lemma eval_eqI':
  assumes "set_right_unique_on {x} f"
  and "\<langle>x, y\<rangle> \<in> f"
  shows "f`x = y"
  using assms by (auto intro: eval_eqI)

lemma pair_eval_mem_if_ex1_pair_mem:
  assumes "\<exists>!y. \<langle>x, y\<rangle> \<in> f"
  shows "\<langle>x, f`x\<rangle> \<in> f"
  using assms unfolding eval_def by (rule theI')

lemma pair_eval_mem_if_mem_dom_if_set_right_unique_on:
  assumes "set_right_unique_on {x} f"
  and "x \<in> dom f"
  shows "\<langle>x, f`x\<rangle> \<in> f"
  using assms
  by (intro pair_eval_mem_if_ex1_pair_mem) (auto dest: set_right_unique_onD)

lemma eval_singleton_eq [simp]: "{\<langle>x, y\<rangle>}`x = y"
  by (rule eval_eqI) auto

lemma eval_repl_eq [iff]: "x \<in> A \<Longrightarrow> {\<langle>a, f a\<rangle> | a \<in> A}`x = f x"
  by (auto intro: eval_eqI)

lemma extend_eval_eq [simp]: "x \<notin> dom f \<Longrightarrow> (extend x y f)`x = y"
  by (auto intro!: eval_eqI' set_right_unique_onI)

lemma extend_eval_eq' [simp]:
  "x \<noteq> y \<Longrightarrow> (extend y z f)`x = f`x"
  unfolding extend_def eval_def by (auto iff: mem_insert_iff)

lemma bin_union_eval_eq_left_eval [simp]:
  "x \<notin> dom g \<Longrightarrow> (f \<union> g)`x = f`x"
  unfolding eval_def by (cases "\<exists>y. \<langle>x, y\<rangle> \<in> g") auto

lemma bin_union_eval_eq_right_eval [simp]:
  "x \<notin> dom f \<Longrightarrow> (f \<union> g)`x = g`x"
  unfolding eval_def by (cases "\<exists>y. \<langle>x, y\<rangle> \<in> f") auto

lemma restriction_eval_eq [simp]:
  assumes "P x"
  shows "(f\<restriction>\<^bsub>P\<^esub>)`x = f`x"
  using assms unfolding eval_def set_restrict_left_pred_def by auto

lemma glue_eval_eqI:
  assumes "\<And>f f'. f \<in> F \<Longrightarrow> f' \<in> F \<Longrightarrow> set_right_unique_on {x} (glue {f, f'})"
  and "f \<in> F"
  and "x \<in> dom f"
  shows "(glue F)`x = f`x"
proof (rule eval_eqI[where ?P="mem_of {x}"], fold set_right_unique_on_set_def)
  from assms(1) show "set_right_unique_on {x} (glue F)"
    by (auto intro: set_right_unique_on_glueI)
  from assms(1)[OF assms(2) assms(2)] have "set_right_unique_on {x} f" by auto
  with assms(3) have "\<langle>x, f`x\<rangle> \<in> f"
    by (intro pair_eval_mem_if_mem_dom_if_set_right_unique_on)
  with assms(2) show "\<langle>x, f`x\<rangle> \<in> (glue F)" by auto
qed simp

subsubsection \<open>Dependent Functions\<close>

definition "dep_functions A B \<equiv>
  {f \<in> powerset (\<Sum>x \<in> A. B x) | set_left_total_on A f \<and> set_right_unique_on A f}"

abbreviation "functions A B \<equiv> dep_functions A (\<lambda>_. B)"

bundle hotg_functions_syntax
begin
syntax
  "_set_functions_telescope" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<rightarrow>s" 55)
end
bundle no_hotg_functions_syntax
begin
no_syntax
  "_set_functions_telescope" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<rightarrow>s" 55)
end
unbundle hotg_functions_syntax

translations
  "(x y \<in> A) \<rightarrow>s B" \<rightharpoonup> "(x \<in> A)(y \<in> A) \<rightarrow>s B"
  "(x \<in> A) args \<rightarrow>s B" \<rightharpoonup> "(x \<in> A) \<rightarrow>s args \<rightarrow>s B"
  "(x \<in> A) \<rightarrow>s B" \<rightleftharpoons> "CONST dep_functions A (\<lambda>x. B)"
  "A \<rightarrow>s B" \<rightleftharpoons> "CONST functions A B"

lemma mem_dep_functionsI [intro]:
  assumes "f \<subseteq> (\<Sum>x \<in> A. (B x))"
  and "set_left_total_on A f"
  and "set_right_unique_on A f"
  shows "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  using assms unfolding dep_functions_def by auto

lemma mem_dep_functionsE [elim]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  obtains "f \<subseteq> \<Sum>x \<in> A. (B x)" "set_left_total_on A f" "set_right_unique_on A f"
  using assms unfolding dep_functions_def by blast

lemma dep_functions_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x \<in> A' \<Longrightarrow> B x = B' x\<rbrakk> \<Longrightarrow> (x \<in> A) \<rightarrow>s (B x) = (x \<in> A') \<rightarrow>s (B' x)"
  unfolding dep_functions_def by simp

lemma mem_functions_if_mem_dep_functions:
  "f \<in> (x \<in> A) \<rightarrow>s (B x) \<Longrightarrow> f \<in> (A \<rightarrow>s (\<Union>x \<in> A. B x))"
  unfolding dep_functions_def by auto

lemma dom_eq_if_mem_dep_functions [simp]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  shows "dom f = A"
  using assms by (elim mem_dep_functionsE, intro eq_if_subset_if_subset) auto

lemma rng_subset_if_mem_dep_functions [simp]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  shows "rng f \<subseteq> (\<Union>x \<in> A. B x)"
proof -
  from assms have "f \<subseteq> \<Sum>x \<in> A. (B x)" by (elim mem_dep_functionsE)
  then have "rng f \<subseteq> rng (\<Sum>x \<in> A. (B x))" by blast
  also have "... \<subseteq> (\<Union>x \<in> A. B x)" by simp
  finally show ?thesis .
qed

lemma fst_snd_eq_pair_if_mem_dep_function [simp]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "p \<in> f"
  shows "\<langle>fst p, snd p\<rangle> = p"
  using assms by (auto elim!: mem_dep_functionsE)

lemma pair_eval_mem_if_mem_if_mem_dep_functions [elim]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "x \<in> A"
  shows "\<langle>x, f`x\<rangle> \<in> f"
proof -
  from assms have "x \<in> dom f" by simp
  then show ?thesis using assms
    by (elim mem_dep_functionsE mem_domE, intro pair_eval_mem_if_ex1_pair_mem)
    (auto dest: set_right_unique_onD)
qed

lemma pair_mem_iff_eval_eq_if_mem_dom_dep_function:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "x \<in> A"
  shows "\<langle>x, y\<rangle> \<in> f \<longleftrightarrow> f`x = y"
proof
  assume "\<langle>x, y\<rangle> \<in> f"
  moreover have "\<langle>x, f`x\<rangle> \<in> f" using assms by auto
  ultimately show "f`x = y" using assms
    by (auto dest: set_right_unique_onD)
qed (insert assms, auto)

lemma fst_mem_if_mem_dep_function:
  "\<lbrakk>f \<in> (x \<in> A) \<rightarrow>s (B x); p \<in> f\<rbrakk> \<Longrightarrow> fst p \<in> A"
  by (auto elim!: mem_dep_functionsE)

lemma snd_mem_if_mem_dep_function:
  "\<lbrakk>f \<in> (x \<in> A) \<rightarrow>s (B x); p \<in> f\<rbrakk> \<Longrightarrow> snd p \<in> B (fst p)"
  by (auto elim!: mem_dep_functionsE)

lemma mem_dom_if_pair_mem_dep_function:
  "\<lbrakk>f \<in> (x \<in> A) \<rightarrow>s (B x); \<langle>x, y\<rangle> \<in> f\<rbrakk> \<Longrightarrow> x \<in> A"
  using fst_mem_if_mem_dep_function[where ?p="\<langle>x, y\<rangle>"] by auto

lemma mem_codom_if_pair_mem_dep_function:
  "\<lbrakk>f \<in> (x \<in> A) \<rightarrow>s (B x); \<langle>x, y\<rangle> \<in> f\<rbrakk> \<Longrightarrow> y \<in> B x"
  using snd_mem_if_mem_dep_function[where ?p="\<langle>x, y\<rangle>"] by auto

lemma eval_mem_if_mem_if_mem_dep_functions [elim]:
  "\<lbrakk>f \<in> (x \<in> A) \<rightarrow>s (B x); x \<in> A\<rbrakk> \<Longrightarrow> f`x \<in> B x"
  using mem_codom_if_pair_mem_dep_function
  by (blast dest: pair_eval_mem_if_mem_if_mem_dep_functions)

lemma eval_eq_if_pair_mem_dep_function [simp]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "\<langle>x, y\<rangle> \<in> f"
  shows "f`x = y"
  using assms fst_mem_if_mem_dep_function[OF assms]
    by (auto iff: pair_mem_iff_eval_eq_if_mem_dom_dep_function)

lemma mem_dom_dep_functionE:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "x \<in> A"
  obtains y where "f`x = y" "y \<in> B x"
  using assms eval_mem_if_mem_if_mem_dep_functions by auto

lemma mem_dep_functionE [elim]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "p \<in> f"
  obtains x y where "p = \<langle>x, y\<rangle>" "x \<in> A" "y \<in> B x" "f`x = y"
proof -
  assume hyp: "\<And>x y. p = \<langle>x, y\<rangle> \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> f`x = y \<Longrightarrow> thesis"
  obtain x y where [simp]: "p = \<langle>x, y\<rangle>" using assms
    by (auto elim!: mem_dep_functionsE)
  show thesis
  proof (intro hyp[of x y])
    from fst_mem_if_mem_dep_function[OF assms] show "x \<in> A" by simp
    from snd_mem_if_mem_dep_function[OF assms] show "y \<in> B x" by simp
    from assms show "f`x = y" by auto
  qed fact
qed

lemma repl_eval_eq_dep_function [simp]:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  shows "{\<langle>x, f`x\<rangle> | x \<in> A} = f"
  using assms by (intro eqI) auto

text \<open>Note: functions are not contravariant on their domain.\<close>
lemma mem_dep_functions_covariant_codom:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "\<And>x. x \<in> A \<Longrightarrow> f`x \<in> B x \<Longrightarrow> f`x \<in> B' x"
  shows "f \<in> (x \<in> A) \<rightarrow>s (B' x)"
  by (rule mem_dep_functionsE[OF assms(1)], intro mem_dep_functionsI)
    (insert assms, auto)

corollary mem_dep_functions_covariant_codom_subset:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> B' x"
  shows "f \<in> (x \<in> A) \<rightarrow>s (B' x)"
  using assms(2) by (intro mem_dep_functions_covariant_codom[OF assms(1)]) auto

lemma eq_if_mem_if_mem_agree_if_mem_dep_functions:
  assumes mem_dep_functions: "\<And>f. f \<in> F \<Longrightarrow> \<exists>B. f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "agree A F"
  and "f \<in> F"
  and "g \<in> F"
  shows "f = g"
  using assms
proof -
  have "\<And>f. f \<in> F \<Longrightarrow> \<exists>B. f \<subseteq> \<Sum>x \<in> A. (B x)" by (blast dest: mem_dep_functions)
  with assms show ?thesis by (intro eq_if_subset_dep_pairs_if_agree)
qed

lemma subset_if_agree_if_mem_dep_functions:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "f \<in> F"
  and "agree A F"
  and "g \<in> F"
  shows "f \<subseteq> g"
  using assms
  by (elim mem_dep_functionsE subset_if_agree_if_subset_dep_pairs) auto

lemma agree_if_eval_eq_if_mem_dep_functions:
  assumes mem_dep_functions: "\<And>f. f \<in> F \<Longrightarrow> \<exists>B. f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "\<And>f g x. f \<in> F \<Longrightarrow> g \<in> F \<Longrightarrow> x \<in> A \<Longrightarrow> f`x = g`x"
  shows "agree A F"
proof (subst agree_set_iff_agree, rule agreeI)
  fix x y f g assume hyps: "f \<in> F" "g \<in> F" "x \<in> A" and "\<langle>x, y\<rangle> \<in> f"
  then have "y = f`x" using assms(1) by auto
  also have "... = g`x" by (fact assms(2)[OF hyps])
  finally have y_eq: "y = g`x" .
  from assms(1)[OF \<open>g \<in> F\<close>] obtain B where "g \<in> (x \<in> A) \<rightarrow>s (B x)" by blast
  with y_eq pair_mem_iff_eval_eq_if_mem_dom_dep_function \<open>x \<in> A\<close>
    show "\<langle>x, y\<rangle> \<in> g" by blast
qed

lemma eq_if_agree_if_mem_dep_functions:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)" "g \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "agree A {f, g}"
  shows "f = g"
  using assms
  by (intro eq_if_mem_if_mem_agree_if_mem_dep_functions[of "{f, g}"]) auto

lemma dep_functions_ext:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)" "g \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "\<And>x. x \<in> A \<Longrightarrow> f`x = g`x"
  shows "f = g"
  using assms
  by (intro eq_if_agree_if_mem_dep_functions)
    (auto intro:
      agree_if_eval_eq_if_mem_dep_functions[unfolded agree_set_iff_agree])

lemma dep_functions_eval_eqI:
  assumes "f \<in> (x \<in> A) \<rightarrow>s (B x)" "g \<in> (x \<in> A') \<rightarrow>s (B' x)"
  and "f \<subseteq> g"
  and "x \<in> A \<inter> A'"
  shows "f`x = g`x"
proof -
  from assms have "\<langle>x, f`x\<rangle> \<in> g" and "\<langle>x, g`x\<rangle> \<in> g" by auto
  then show ?thesis using assms by auto
qed

lemma dep_functions_eq_if_subset:
  assumes f_mem: "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and g_mem: "g \<in> (x \<in> A) \<rightarrow>s (B' x)"
  and "f \<subseteq> g"
  shows "f = g"
proof (rule eqI)
  fix p assume "p \<in> g"
  with g_mem obtain x y where [simp]: "p = \<langle>x, y\<rangle>" "g`x = y" "x \<in> A" by auto
  with assms have [simp]: "f`x = g`x" by (intro dep_functions_eval_eqI) auto
  show "p \<in> f" using f_mem
    by (auto iff: pair_mem_iff_eval_eq_if_mem_dom_dep_function)
qed (insert assms, auto)

lemma ex_dom_mem_dep_functions_iff:
  "(\<exists>A. f \<in> (x \<in> A) \<rightarrow>s (B x)) \<longleftrightarrow> f \<in> (x \<in> dom f) \<rightarrow>s (B x)"
  by auto

lemma mem_dep_functions_empty_dom_iff_eq_empty [iff]:
  "(f \<in> (x \<in> {}) \<rightarrow>s (B x)) \<longleftrightarrow> f = {}"
  by auto

lemma empty_mem_dep_functions: "{} \<in> (x \<in> {}) \<rightarrow>s (B x)" by simp

lemma eq_singleton_if_mem_functions_singleton [simp]:
  "f \<in> {a} \<rightarrow>s {b} \<Longrightarrow> f = {\<langle>a, b\<rangle>}"
  by auto

lemma singleton_mem_functionsI [intro]: "y \<in> B \<Longrightarrow> {\<langle>x, y\<rangle>} \<in> {x} \<rightarrow>s B"
  by auto

lemma mem_dep_functions_collectI:
  assumes f_mem: "f \<in> (x \<in> A) \<rightarrow>s (B x)"
  and "\<And>x. x \<in> A \<Longrightarrow> P x (f`x)"
  shows "f \<in> (x \<in> A) \<rightarrow>s {y \<in> B x | P x y}"
  by (rule mem_dep_functions_covariant_codom) (insert assms, auto)

lemma mem_dep_functions_collectD:
  assumes "f \<in> (x \<in> A) \<rightarrow>s {y \<in> B x | P x y}"
  shows "f \<in> (x \<in> A) \<rightarrow>s (B x)" and "\<And>x. x \<in> A \<Longrightarrow> P x (f`x)"
proof -
  from assms show "f \<in> (x \<in> A) \<rightarrow>s (B x)"
    by (rule mem_dep_functions_covariant_codom_subset) auto
  fix x assume "x \<in> A"
  with assms show "P x (f`x)"
    by (auto dest: pair_eval_mem_if_mem_if_mem_dep_functions)
qed

end


(*
  File:     Comparison_Sort_Lower_Bound.thy
  Author:   Manuel Eberl <manuel@pruvisto.org>

  Proof of the lower-bound on worst-case comparisons in a comparison-based sorting algorithm.
*)
section \<open>Lower bound on costs of comparison-based sorting\<close>
theory Comparison_Sort_Lower_Bound
  imports
    Complex_Main
    Linorder_Relations
    Stirling_Formula.Stirling_Formula
    "Landau_Symbols.Landau_More"
begin

subsection \<open>Abstract description of sorting algorithms\<close>

text \<open>
  We have chosen to model a sorting algorithm in the following way: A sorting algorithm takes a
  list with distinct elements and a linear ordering on these elements, and it returns a list
  with the same elements that is sorted w.\,r.\,t.\ the given ordering.

  The use of an explicit ordering means that the algorithm must look at the ordering, i.\,e.\
  it has to use pair-wise comparison of elements, since all the information that is relevant
  for producing the correct sorting is in the ordering; the elements themselves are irrelevant.

  Furthermore, we record the number of comparisons that the algorithm makes by not giving it the
  relation explicitly, but in the form of a comparison oracle that may be queried.

  A sorting algorithm (or `sorter') for a fixed input list (but for arbitrary orderings) can then
  be written as a recursive datatype that is either the result (the sorted list) or a comparison
  query consisting of two elements and a continuation that maps the result of the comparison
  to the remaining computation.
\<close>

datatype 'a sorter = Return "'a list" | Query 'a 'a "bool \<Rightarrow> 'a sorter"

text \<open>
  Cormen~\emph{et\ al.}~\<^cite>\<open>"cormen"\<close>\ use a similar `decision tree' model where an sorting
  algorithm for lists of fixed size $n$ is modelled as a binary tree where each node is a
  comparison of two elements. They also demand that every leaf in the tree be reachable in
  order to avoid `dead' subtrees (if the algorithm makes redundant comparisons, there may be
  branches that can never be taken). Then, the worst-case number of comparisons made is simply
  the height of the tree.

  We chose a subtly different model that does not have this restriction on the algorithm but
  instead uses a more semantic way of counting the worst-case number of comparisons: We simply
  use the maximum number of comparisons that occurs for any of the (finitely many) inputs.

  We therefore first define a function that counts the number of queries for a specific
  ordering and then a function that counts the number of queries in the worst case (ranging
  over a given set of allowed orderings; typically, this will be the set of all linear orders
  on the list).
\<close>
primrec count_queries :: "('a \<times> 'a) set \<Rightarrow> 'a sorter \<Rightarrow> nat" where
  "count_queries _ (Return _)    = 0"
| "count_queries R (Query a b f) = Suc (count_queries R (f ((a, b) \<in> R)))"

definition count_wc_queries :: "('a \<times> 'a) set set \<Rightarrow> 'a sorter \<Rightarrow> nat" where
  "count_wc_queries Rs sorter = (if Rs = {} then 0 else Max ((\<lambda>R. count_queries R sorter) ` Rs))"

lemma count_wc_queries_empty [simp]: "count_wc_queries {} sorter = 0"
  by (simp add: count_wc_queries_def)

lemma count_wc_queries_aux:
  assumes "\<And>R. R \<in> Rs \<Longrightarrow> sorter = sorter' R" "Rs \<subseteq> Rs'" "finite Rs'"
  shows   "count_wc_queries Rs sorter \<le> Max ((\<lambda>R. count_queries R (sorter' R)) ` Rs')"
proof (cases "Rs = {}")
  case False
  hence "count_wc_queries Rs sorter = Max ((\<lambda>R. count_queries R sorter) ` Rs)"
    by (simp add: count_wc_queries_def)
  also have "(\<lambda>R. count_queries R sorter) ` Rs = (\<lambda>R. count_queries R (sorter' R)) ` Rs"
    by (intro image_cong refl) (simp_all add: assms)
  also have "Max \<dots> \<le> Max ((\<lambda>R. count_queries R (sorter' R)) ` Rs')" using False
    by (intro Max_mono assms image_mono finite_imageI) auto
  finally show ?thesis .
qed simp_all

primrec eval_sorter :: "('a \<times> 'a) set \<Rightarrow> 'a sorter \<Rightarrow> 'a list" where
  "eval_sorter _ (Return ys)   = ys"
| "eval_sorter R (Query a b f) = eval_sorter R (f ((a,b) \<in> R))"

text \<open>
  We now get an obvious bound on the maximum number of different results that a given sorter
  can produce.
\<close>
lemma card_range_eval_sorter:
  assumes "finite Rs"
  shows   "card ((\<lambda>R. eval_sorter R e) ` Rs) \<le> 2 ^ count_wc_queries Rs e"
using assms
proof (induction e arbitrary: Rs)
  case (Return xs Rs)
  have *: "(\<lambda>R. eval_sorter R (Return xs)) ` Rs = (if Rs = {} then {} else {xs})" by auto
  show ?case by (subst *) auto
next
  case (Query a b f Rs)
  have "f True \<in> range f" "f False \<in> range f" by simp_all
  note IH = this [THEN Query.IH]
  let ?Rs1 = "{R\<in>Rs. (a, b) \<in> R}" and ?Rs2 = "{R\<in>Rs. (a, b) \<notin> R}"
  let ?A = "(\<lambda>R. eval_sorter R (f True)) ` ?Rs1" and ?B = "(\<lambda>R. eval_sorter R (f False)) ` ?Rs2"
  from Query.prems have fin: "finite ?Rs1" "finite ?Rs2" by simp_all

  have *: "(\<lambda>R. eval_sorter R (Query a b f)) ` Rs \<subseteq> ?A \<union> ?B"
  proof (intro subsetI, elim imageE, goal_cases)
    case (1 xs R)
    thus ?case by (cases "(a,b) \<in> R") auto
  qed

  show ?case
  proof (cases "Rs = {}")
    case False
    have "card ((\<lambda>R. eval_sorter R (Query a b f)) ` Rs) \<le> card (?A \<union> ?B)"
      by (intro card_mono finite_UnI finite_imageI fin *)
    also have "\<dots> \<le> card ?A + card ?B" by (rule card_Un_le)
    also have "\<dots> \<le> 2 ^ count_wc_queries ?Rs1 (f True) + 2 ^ count_wc_queries ?Rs2 (f False)"
      by (intro add_mono IH fin)
    also have "count_wc_queries ?Rs1 (f True) \<le> Max ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs)"
      by (intro count_wc_queries_aux Query.prems) auto
    also have "count_wc_queries ?Rs2 (f False) \<le> Max ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs)"
      by (intro count_wc_queries_aux Query.prems) auto
    also have "2 ^ \<dots> + 2 ^ \<dots> = (2 ^ Suc \<dots> :: nat)" by simp
    also have "Suc (Max ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs)) =
                 Max (Suc ` ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs))" using False
      by (intro mono_Max_commute finite_imageI Query.prems) (auto simp: incseq_def)
    also have "Suc ` ((\<lambda>R. count_queries R (f ((a,b)\<in>R))) ` Rs) =
                 (\<lambda>R. Suc (count_queries R (f ((a,b)\<in>R)))) ` Rs" by (simp add: image_image)
    also have "Max \<dots> = count_wc_queries Rs (Query a b f)" using False
      by (auto simp add: count_wc_queries_def)
    finally show ?thesis by - simp_all
  qed simp_all
qed

text \<open>
  The following predicate describes what constitutes a valid sorting result for a given
  ordering and a given input list. Note that when the ordering is linear, the result is
  actually unique.
\<close>
definition is_sorting :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "is_sorting R xs ys \<longleftrightarrow> (mset xs = mset ys) \<and> sorted_wrt R ys"

subsection \<open>Lower bounds on number of comparisons\<close>

text \<open>
  For a list of $n$ distinct elements, there are $n!$ linear orderings on $n$ elements,
  each of which leads to a different result after sorting the original list.
  Since a sorter can produce at most $2^k$ different results with $k$ comparisons, we get
  the bound $2^k \geq n!$:
\<close>
theorem
  fixes sorter :: "'a sorter" and xs :: "'a list"
  assumes distinct: "distinct xs"
  assumes sorter: "\<And>R. linorder_on (set xs) R \<Longrightarrow> is_sorting R xs (eval_sorter R sorter)"
  defines "Rs \<equiv> {R. linorder_on (set xs) R}"
  shows   two_power_count_queries_ge: "fact (length xs) \<le> (2 ^ count_wc_queries Rs sorter :: nat)"
    and   count_queries_ge:           "log 2 (fact (length xs)) \<le> real (count_wc_queries Rs sorter)"
proof -
  have "Rs \<subseteq> Pow (set xs \<times> set xs)" by (auto simp: Rs_def linorder_on_def refl_on_def)
  hence fin: "finite Rs" by (rule finite_subset) simp_all
  from assms have "fact (length xs) = card (permutations_of_set (set xs))"
    by (simp add: distinct_card)
  also have "permutations_of_set (set xs) \<subseteq> (\<lambda>R. eval_sorter R sorter) ` Rs"
  proof (rule subsetI, goal_cases)
    case (1 ys)
    define R where "R = linorder_of_list ys"
    define zs where "zs = eval_sorter R sorter"
    from 1 and distinct have mset_ys: "mset ys = mset xs"
      by (auto simp: set_eq_iff_mset_eq_distinct permutations_of_set_def)
    from 1 have *: "linorder_on (set xs) R" unfolding R_def using linorder_linorder_of_list[of ys]
      by (simp add: permutations_of_set_def)
    from sorter[OF this] have "mset xs = mset zs" "sorted_wrt R zs"
      by (simp_all add: is_sorting_def zs_def)
    moreover from 1 have "sorted_wrt R ys" unfolding R_def
      by (intro sorted_wrt_linorder_of_list) (simp_all add: permutations_of_set_def)
    ultimately have "zs = ys"
      by (intro sorted_wrt_linorder_unique[OF *]) (simp_all add: mset_ys)
    moreover from * have "R \<in> Rs" by (simp add: Rs_def)
    ultimately show ?case unfolding zs_def by blast
  qed
  hence "card (permutations_of_set (set xs)) \<le> card ((\<lambda>R. eval_sorter R sorter) ` Rs)"
    by (intro card_mono finite_imageI fin)
  also from fin have "\<dots> \<le> 2 ^ count_wc_queries Rs sorter" by (rule card_range_eval_sorter)
  finally show *: "fact (length xs) \<le> (2 ^ count_wc_queries Rs sorter :: nat)" .

  have "ln (fact (length xs)) = ln (real (fact (length xs)))" by simp
  also have "\<dots> \<le> ln (real (2 ^ count_wc_queries Rs sorter))"
  proof (subst ln_le_cancel_iff)
    show "real (fact (length xs)) \<le> real (2 ^ count_wc_queries Rs sorter)"
      by (subst of_nat_le_iff) (rule *)
  qed simp_all
  also have "\<dots> = real (count_wc_queries Rs sorter) * ln 2" by (simp add: ln_realpow)
  finally have "real (count_wc_queries Rs sorter) \<ge> ln (fact (length xs)) / ln 2"
    by (simp add: field_simps)
  also have "ln (fact (length xs)) / ln 2 = log 2 (fact (length xs))" by (simp add: log_def)
  finally show **: "log 2 (fact (length xs)) \<le> real (count_wc_queries Rs sorter)" .
qed

(* TODO: Good example for automation. Also, move. *)
lemma ln_fact_bigo: "(\<lambda>n. ln (fact n) - (ln (2 * pi * n) / 2 + n * ln n - n)) \<in> O(\<lambda>n. 1 / n)"
  and asymp_equiv_ln_fact [asymp_equiv_intros]: "(\<lambda>n. ln (fact n)) \<sim>[at_top] (\<lambda>n. n * ln n)"
proof -
  include asymp_equiv_notation
  define f where "f = (\<lambda>n. ln (2 * pi * real n) / 2 + real n * ln (real n) - real n)"
  have "eventually (\<lambda>n. ln (fact n) - f n \<in> {0..1/(12*real n)}) at_top"
    using eventually_gt_at_top[of "1::nat"]
  proof eventually_elim
    case (elim n)
    with ln_fact_bounds[of n] show ?case by (simp add: f_def)
  qed
  hence "eventually (\<lambda>n. norm (ln (fact n) - f n) \<le> (1/12) * norm (1 / real n)) at_top"
    using eventually_gt_at_top[of "0::nat"] by eventually_elim (simp_all add: field_simps)
  thus "(\<lambda>n. ln (fact n) - f n) \<in> O(\<lambda>n. 1 / real n)"
    using bigoI[of "\<lambda>n. ln (fact n) - f n" "1/12" "\<lambda>n. 1 / real n"] by simp
  also have "(\<lambda>n. 1 / real n) \<in> o(f)" unfolding f_def by (intro smallo_real_nat_transfer) simp
  finally have "(\<lambda>n. f n + (ln (fact n) - f n)) \<sim> f"
    by (subst asymp_equiv_add_right) simp_all
  hence "(\<lambda>n. ln (fact n)) \<sim> f" by simp
  also have "f \<sim> (\<lambda>n. n * ln n + (ln (2*pi*n)/2 - n))" by (simp add: f_def algebra_simps)
  also have "\<dots> \<sim> (\<lambda>n. n * ln n)" by (subst asymp_equiv_add_right) auto
  finally show "(\<lambda>n. ln (fact n)) \<sim> (\<lambda>n. n * ln n)" .
qed

text \<open>
  This leads to the following well-known Big-Omega bound on the number of comparisons
  that a general sorting algorithm has to make:
\<close>
corollary count_queries_bigomega:
  fixes sorter :: "nat \<Rightarrow> nat sorter"
  assumes sorter: "\<And>n R. linorder_on {..<n} R \<Longrightarrow>
                         is_sorting R [0..<n] (eval_sorter R (sorter n))"
  defines "Rs \<equiv> \<lambda>n. {R. linorder_on {..<n} R}"
  shows   "(\<lambda>n. count_wc_queries (Rs n) (sorter n)) \<in> \<Omega>(\<lambda>n. n * ln n)"
proof -
  have "(\<lambda>n. n * ln n) \<in> \<Theta>(\<lambda>n. ln (fact n))"
    by (subst bigtheta_sym) (intro asymp_equiv_imp_bigtheta asymp_equiv_intros)
  also have "(\<lambda>n. ln (fact n)) \<in> \<Theta>(\<lambda>n. log 2 (fact n))" by (simp add: log_def)
  also have "(\<lambda>n. log 2 (fact n)) \<in> O(\<lambda>n. count_wc_queries (Rs n) (sorter n))"
  proof (intro bigoI[where c = 1] always_eventually allI, goal_cases)
    case (1 n)
    have "norm (log 2 (fact n)) = log 2 (fact (length [0..<n]))" by simp
    also from sorter[of n] have "\<dots> \<le> real (count_wc_queries (Rs n) (sorter n))"
      using count_queries_ge[of "[0..<n]" "sorter n"] by (auto simp: Rs_def atLeast0LessThan)
    also have "\<dots> = 1 * norm \<dots>" by simp
    finally show ?case by simp
  qed
  finally show ?thesis by (simp add: bigomega_iff_bigo)
qed

end


section \<open>Cancelation of words of generators and their inverses\<close>

theory Cancelation
imports
  "HOL-Proofs-Lambda.Commutation"
begin

text \<open>
This theory defines cancelation via relations. The one-step relation @{term
"cancels_to_1 a b"} describes that @{term b} is obtained from @{term a} by removing
exactly one pair of generators, while @{term cancels_to} is the reflexive
transitive hull of that relation. Due to confluence, this relation has a normal
form, allowing for the definition of @{term normalize}.
\<close>

subsection \<open>Auxiliary results\<close>

text \<open>Some lemmas that would be useful in a more general setting are
collected beforehand.\<close>

subsubsection \<open>Auxiliary results about relations\<close>

text \<open>
These were helpfully provided by Andreas Lochbihler.
\<close>

theorem lconfluent_confluent:
  "\<lbrakk> wfP (R^--1); \<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow> \<exists>d. R^** b d \<and> R^** c d  \<rbrakk> \<Longrightarrow> confluent R"
by(auto simp add: diamond_def commute_def square_def intro: newman)

lemma confluentD:
  "\<lbrakk> confluent R; R^** a b; R^** a c  \<rbrakk> \<Longrightarrow> \<exists>d. R^** b d \<and> R^** c d"
by(auto simp add: commute_def diamond_def square_def)

lemma tranclp_DomainP: "R^++ a b \<Longrightarrow> Domainp R a"
by(auto elim: converse_tranclpE)

lemma confluent_unique_normal_form:
  "\<lbrakk> confluent R; R^** a b; R^** a c; \<not> Domainp R b; \<not> Domainp R c  \<rbrakk> \<Longrightarrow> b = c"
by(fastforce dest!: confluentD[of R a b c] dest: tranclp_DomainP rtranclpD[where a=b] rtranclpD[where a=c])

subsection \<open>Definition of the @{term "canceling"} relation\<close>

type_synonym 'a "g_i" = "(bool \<times> 'a)" (* A generator or its inverse *)
type_synonym 'a "word_g_i" = "'a g_i list" (* A word in the generators or their inverses *)

text \<open>
These type aliases encode the notion of a ``generator or its inverse''
(@{typ "'a g_i"}) and the notion of a ``word in generators and their inverses''
(@{typ "'a word_g_i"}), which form the building blocks of Free Groups.
\<close>

definition canceling :: "'a g_i \<Rightarrow> 'a g_i \<Rightarrow> bool"
 where "canceling a b = ((snd a = snd b) \<and> (fst a \<noteq> fst b))"

subsubsection \<open>Simple results about canceling\<close>

text \<open>
A generators cancels with its inverse, either way. The relation is symmetic.
\<close>

lemma cancel_cancel: "\<lbrakk> canceling a b; canceling b c \<rbrakk> \<Longrightarrow> a = c"
by (auto intro: prod_eqI simp add:canceling_def)

lemma cancel_sym: "canceling a b \<Longrightarrow> canceling b a"
by (simp add:canceling_def)

lemma cancel_sym_neg: "\<not>canceling a b \<Longrightarrow> \<not>canceling b a"
by (rule classical, simp add:canceling_def)

subsection \<open>Definition of the @{term "cancels_to"} relation\<close>

text \<open>
First, we define the function that removes the @{term i}th and \<open>(i+1)\<close>st
element from a word of generators, together with basic properties.
\<close>

definition cancel_at :: "nat \<Rightarrow> 'a word_g_i \<Rightarrow> 'a word_g_i"
where "cancel_at i l = take i l @ drop (2+i) l"

lemma cancel_at_length[simp]:
  "1+i < length l \<Longrightarrow> length (cancel_at i l) = length l - 2"
by(auto simp add: cancel_at_def)

lemma cancel_at_nth1[simp]:
  "\<lbrakk> n < i; 1+i < length l  \<rbrakk> \<Longrightarrow> (cancel_at i l) ! n = l ! n"
by(auto simp add: cancel_at_def nth_append)

lemma cancel_at_nth2[simp]:
  assumes "n \<ge> i" and "n < length l - 2"
  shows "(cancel_at i l) ! n = l ! (n + 2)"
proof-
  from \<open>n \<ge> i\<close> and \<open>n < length l - 2\<close>
  have "i = min (length l) i"
    by auto
  with \<open>n \<ge> i\<close> and \<open>n < length l - 2\<close>
  show "(cancel_at i l) ! n = l ! (n + 2)"
    by(auto simp add: cancel_at_def nth_append nth_via_drop)
qed

text \<open>
Then we can define the relation @{term "cancels_to_1_at i a b"} which specifies
that @{term b} can be obtained by @{term a} by canceling the @{term i}th and
\<open>(i+1)\<close>st position.

Based on that, we existentially quantify over the position \<open>i\<close> to obtain
the relation \<open>cancels_to_1\<close>, of which \<open>cancels_to\<close> is the
reflexive and transitive closure.

A word is \<open>canceled\<close> if it can not be canceled any futher.
\<close>

definition cancels_to_1_at ::  "nat \<Rightarrow> 'a word_g_i \<Rightarrow> 'a word_g_i \<Rightarrow> bool"
where  "cancels_to_1_at i l1 l2 = (0\<le>i \<and> (1+i) < length l1
                              \<and> canceling (l1 ! i) (l1 ! (1+i))
                              \<and> (l2 = cancel_at i l1))"

definition cancels_to_1 :: "'a word_g_i \<Rightarrow> 'a word_g_i \<Rightarrow> bool"
where "cancels_to_1 l1 l2 = (\<exists>i. cancels_to_1_at i l1 l2)"

definition cancels_to  :: "'a word_g_i \<Rightarrow> 'a word_g_i \<Rightarrow> bool"
where "cancels_to = cancels_to_1^**"

lemma cancels_to_trans [trans]:
  "\<lbrakk> cancels_to a b; cancels_to b c \<rbrakk> \<Longrightarrow> cancels_to a c"
by (auto simp add:cancels_to_def)

definition canceled :: "'a word_g_i \<Rightarrow> bool"
 where "canceled l = (\<not> Domainp cancels_to_1 l)"

(* Alternative view on cancelation, sometimes easier to work with *)
lemma cancels_to_1_unfold:
  assumes "cancels_to_1 x y"
  obtains xs1 x1 x2 xs2
  where "x = xs1 @ x1 # x2 # xs2"
    and "y = xs1 @ xs2"
    and "canceling x1 x2"
proof-
  assume a: "(\<And>xs1 x1 x2 xs2. \<lbrakk>x = xs1 @ x1 # x2 # xs2; y = xs1 @ xs2; canceling x1 x2\<rbrakk> \<Longrightarrow> thesis)"
  from \<open>cancels_to_1 x y\<close>
  obtain i where "cancels_to_1_at i x y"
    unfolding cancels_to_1_def by auto
  hence "canceling (x ! i) (x ! Suc i)"
    and "y = (take i x) @ (drop (Suc (Suc i)) x)"
    and "x = (take i x) @ x ! i # x ! Suc i # (drop (Suc (Suc i)) x)"
    unfolding cancel_at_def and cancels_to_1_at_def by (auto simp add: Cons_nth_drop_Suc)
  with a show thesis by blast
qed

(* And the reverse direction *)
lemma cancels_to_1_fold:
  "canceling x1 x2 \<Longrightarrow> cancels_to_1 (xs1 @ x1 # x2 # xs2) (xs1 @ xs2)"
unfolding cancels_to_1_def and cancels_to_1_at_def and cancel_at_def
by (rule_tac x="length xs1" in exI, auto simp add:nth_append)

subsubsection \<open>Existence of the normal form\<close>

text \<open>
One of two steps to show that we have a normal form is the following lemma,
guaranteeing that by canceling, we always end up at a fully canceled word.
\<close>

lemma canceling_terminates: "wfP (cancels_to_1^--1)"
proof-
  have "wf (measure length)" by auto
  moreover
  have "{(x, y). cancels_to_1 y x} \<subseteq> measure length"
    by (auto simp add: cancels_to_1_def cancel_at_def cancels_to_1_at_def)
  ultimately
  have "wf {(x, y). cancels_to_1 y x}"
    by(rule wf_subset)
  thus ?thesis by (simp add:wfP_def)
qed

text \<open>
The next two lemmas prepare for the proof of confluence. It does not matter in
which order we cancel, we can obtain the same result.
\<close>

lemma canceling_neighbor:
  assumes "cancels_to_1_at i l a" and "cancels_to_1_at (Suc i) l b"
  shows "a = b"
proof-
  from \<open>cancels_to_1_at i l a\<close>
    have "canceling (l ! i) (l ! Suc i)" and "i < length l"
    by (auto simp add: cancels_to_1_at_def)

  from \<open>cancels_to_1_at (Suc i) l b\<close>
    have "canceling (l ! Suc i) (l ! Suc (Suc i))" and "Suc (Suc i) < length l"
    by (auto simp add: cancels_to_1_at_def)

  from \<open>canceling (l ! i) (l ! Suc i)\<close> and \<open>canceling (l ! Suc i) (l ! Suc (Suc i))\<close>
    have "l ! i = l ! Suc (Suc i)" by (rule cancel_cancel)

  from \<open>cancels_to_1_at (Suc i) l b\<close>
    have "b = take (Suc i) l @ drop (Suc (Suc (Suc i))) l"
    by (simp add: cancels_to_1_at_def cancel_at_def)
  also from \<open>i < length l\<close>
  have "\<dots> = take i l @ [l ! i] @ drop (Suc (Suc (Suc i))) l"
    by(auto simp add: take_Suc_conv_app_nth)
  also from \<open>l ! i = l ! Suc (Suc i)\<close>
  have "\<dots> = take i l @ [l ! Suc (Suc i)] @ drop (Suc (Suc (Suc i))) l"
    by simp
  also from \<open>Suc (Suc i) < length l\<close>
  have "\<dots> = take i l @ drop (Suc (Suc i)) l"
    by (simp add: Cons_nth_drop_Suc)
  also from \<open>cancels_to_1_at i l a\<close> have "\<dots> = a"
    by (simp add: cancels_to_1_at_def cancel_at_def)
  finally show "a = b" by(rule sym)
qed

lemma canceling_indep:
  assumes "cancels_to_1_at i l a" and "cancels_to_1_at j l b" and "j > Suc i"
  obtains c where "cancels_to_1_at (j - 2) a c" and "cancels_to_1_at i b c"
proof(atomize_elim)
  from \<open>cancels_to_1_at i l a\<close>
    have "Suc i < length l"
     and "canceling (l ! i) (l ! Suc i)"
     and "a = cancel_at i l"
     and "length a = length l - 2"
     and "min (length l) i = i"
    by (auto simp add:cancels_to_1_at_def)
  from \<open>cancels_to_1_at j l b\<close>
    have "Suc j < length l"
     and "canceling (l ! j) (l ! Suc j)"
     and "b = cancel_at j l"
     and "length b = length l - 2"
    by (auto simp add:cancels_to_1_at_def)

  let ?c = "cancel_at (j - 2) a"
  from \<open>j > Suc i\<close>
  have "Suc (Suc (j - 2)) = j"
    and "Suc (Suc (Suc j - 2)) = Suc j"
    by auto
  with \<open>min (length l) i = i\<close> and \<open>j > Suc i\<close> and \<open>Suc j < length l\<close>
  have "(l ! j) = (cancel_at i l ! (j - 2))"
    and "(l ! (Suc j)) = (cancel_at i l ! Suc (j - 2))"
    by(auto simp add:cancel_at_def simp add:nth_append)

  with \<open>cancels_to_1_at i l a\<close>
    and \<open>cancels_to_1_at j l b\<close>
  have "canceling (a ! (j - 2)) (a ! Suc (j - 2))"
    by(auto simp add:cancels_to_1_at_def)

  with \<open>j > Suc i\<close> and \<open>Suc j < length l\<close> and \<open>length a = length l - 2\<close>
  have "cancels_to_1_at (j - 2) a ?c" by (auto simp add: cancels_to_1_at_def)

  from \<open>length b = length l - 2\<close> and \<open>j > Suc i\<close> and \<open>Suc j < length l\<close>
  have "Suc i < length b" by auto

  moreover from \<open>b = cancel_at j l\<close> and \<open>j > Suc i\<close> and \<open>Suc i < length l\<close>
  have "(b ! i) = (l ! i)" and "(b ! Suc i) = (l ! Suc i)"
    by (auto simp add:cancel_at_def nth_append)
  with \<open>canceling (l ! i) (l ! Suc i)\<close>
  have "canceling (b ! i) (b ! Suc i)" by simp

  moreover from \<open>j > Suc i\<close> and \<open>Suc j < length l\<close>
  have "min i j = i"
    and "min (j - 2) i = i"
    and "min (length l) j = j"
    and "min (length l) i = i"
    and "Suc (Suc (j - 2)) = j"
    by auto
  with \<open>a = cancel_at i l\<close> and \<open>b = cancel_at j l\<close> and \<open>Suc (Suc (j - 2)) = j\<close>
  have "cancel_at (j - 2) a = cancel_at i b"
    by (auto simp add:cancel_at_def take_drop)

  ultimately have "cancels_to_1_at i b (cancel_at (j - 2) a)"
    by (auto simp add:cancels_to_1_at_def)

  with \<open>cancels_to_1_at (j - 2) a ?c\<close>
  show "\<exists>c. cancels_to_1_at (j - 2) a c \<and> cancels_to_1_at i b c" by blast
qed

text \<open>This is the confluence lemma\<close>
lemma confluent_cancels_to_1: "confluent cancels_to_1"
proof(rule lconfluent_confluent)
  show "wfP cancels_to_1\<inverse>\<inverse>" by (rule canceling_terminates)
next
  fix a b c
  assume "cancels_to_1 a b"
  then obtain i where "cancels_to_1_at i a b"
    by(simp add: cancels_to_1_def)(erule exE)
  assume "cancels_to_1 a c"
  then obtain j where "cancels_to_1_at j a c"
    by(simp add: cancels_to_1_def)(erule exE)

  show "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d"
  proof (cases "i=j")
    assume "i=j"
    from \<open>cancels_to_1_at i a b\<close>
      have "b = cancel_at i a" by (simp add:cancels_to_1_at_def)
    moreover from \<open>i=j\<close>
      have "\<dots> = cancel_at j a" by (clarify)
    moreover from \<open>cancels_to_1_at j a c\<close>
      have "\<dots> = c" by (simp add:cancels_to_1_at_def)
    ultimately have "b = c" by (simp)
    hence "cancels_to_1\<^sup>*\<^sup>* b b"
      and "cancels_to_1\<^sup>*\<^sup>* c b" by auto
    thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by blast
  next
    assume "i \<noteq> j"
    show ?thesis
    proof (cases "j = Suc i")
      assume "j = Suc i"
        with \<open>cancels_to_1_at i a b\<close> and \<open>cancels_to_1_at j a c\<close>
        have "b = c" by (auto elim: canceling_neighbor)
      hence "cancels_to_1\<^sup>*\<^sup>* b b"
        and "cancels_to_1\<^sup>*\<^sup>* c b" by auto
      thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by blast
    next
      assume "j \<noteq> Suc i"
      show ?thesis
      proof (cases "i = Suc j")
        assume "i = Suc j"
          with \<open>cancels_to_1_at i a b\<close> and \<open>cancels_to_1_at j a c\<close>
          have "c = b" by (auto elim: canceling_neighbor)
        hence "cancels_to_1\<^sup>*\<^sup>* b b"
          and "cancels_to_1\<^sup>*\<^sup>* c b" by auto
        thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by blast
      next
        assume "i \<noteq> Suc j"
        show ?thesis
        proof (cases "i < j")
          assume "i < j"
            with \<open>j \<noteq> Suc i\<close> have "Suc i < j" by auto
          with \<open>cancels_to_1_at i a b\<close> and \<open>cancels_to_1_at j a c\<close>
          obtain d where "cancels_to_1_at (j - 2) b d" and "cancels_to_1_at i c d"
            by(erule canceling_indep)
          hence "cancels_to_1 b d" and "cancels_to_1 c d"
            by (auto simp add:cancels_to_1_def)
          thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by (auto)
        next
          assume "\<not> i < j"
          with \<open>j \<noteq> Suc i\<close> and \<open>i \<noteq> j\<close> and \<open>i \<noteq> Suc j\<close> have "Suc j < i" by auto
          with \<open>cancels_to_1_at i a b\<close> and \<open>cancels_to_1_at j a c\<close>
          obtain d where "cancels_to_1_at (i - 2) c d" and "cancels_to_1_at j b d"
            by -(erule canceling_indep)
          hence "cancels_to_1 b d" and "cancels_to_1 c d"
            by (auto simp add:cancels_to_1_def)
          thus "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" by (auto)
        qed
      qed
    qed
  qed
qed

text \<open>
And finally, we show that there exists a unique normal form for each word.
\<close>

(*
lemma inv_rtrcl: "R^**^--1 = R^--1^**" (* Did I overlook this in the standard libs? *)
by (auto simp add:fun_eq_iff intro: dest:rtranclp_converseD intro:rtranclp_converseI)
*)
lemma norm_form_uniq:
  assumes "cancels_to a b"
      and "cancels_to a c"
      and "canceled b"
      and "canceled c"
  shows "b = c"
proof-
  have "confluent cancels_to_1" by (rule confluent_cancels_to_1)
  moreover
  from \<open>cancels_to a b\<close> have "cancels_to_1^** a b" by (simp add: cancels_to_def)
  moreover
  from \<open>cancels_to a c\<close> have "cancels_to_1^** a c" by (simp add: cancels_to_def)
  moreover
  from \<open>canceled b\<close> have "\<not> Domainp cancels_to_1 b" by (simp add: canceled_def)
  moreover
  from \<open>canceled c\<close> have "\<not> Domainp cancels_to_1 c" by (simp add: canceled_def)
  ultimately
  show "b = c"
    by (rule confluent_unique_normal_form)
qed

subsubsection \<open>Some properties of cancelation\<close>

text \<open>
Distributivity rules of cancelation and \<open>append\<close>.
\<close>

lemma cancel_to_1_append:
  assumes "cancels_to_1 a b"
  shows "cancels_to_1 (l@a@l') (l@b@l')"
proof-
  from \<open>cancels_to_1 a b\<close> obtain i where "cancels_to_1_at i a b"
    by(simp add: cancels_to_1_def)(erule exE)
  hence "cancels_to_1_at (length l + i) (l@a@l') (l@b@l')"
    by (auto simp add:cancels_to_1_at_def nth_append cancel_at_def)
  thus "cancels_to_1 (l@a@l') (l@b@l')"
    by (auto simp add: cancels_to_1_def)
qed

lemma cancel_to_append:
  assumes "cancels_to a b"
  shows "cancels_to (l@a@l') (l@b@l')"
using assms
unfolding cancels_to_def
proof(induct)
  case base show ?case by (simp add:cancels_to_def)
next
  case (step b c)
  from \<open>cancels_to_1 b c\<close>
  have "cancels_to_1 (l @ b @ l') (l @ c @ l')" by (rule cancel_to_1_append)
  with \<open>cancels_to_1^** (l @ a @ l') (l @ b @ l')\<close> show ?case
    by (auto simp add:cancels_to_def)
qed

lemma cancels_to_append2:
  assumes "cancels_to a a'"
      and "cancels_to b b'"
  shows "cancels_to (a@b) (a'@b')"
using \<open>cancels_to a a'\<close>
unfolding cancels_to_def
proof(induct)
  case base
  from \<open>cancels_to b b'\<close> have "cancels_to (a@b@[]) (a@b'@[])"
    by (rule cancel_to_append)
  thus ?case unfolding cancels_to_def by simp
next
  case (step ba c)
  from \<open>cancels_to_1 ba c\<close> have "cancels_to_1 ([]@ba@b') ([]@c@b')"
    by(rule cancel_to_1_append)
  with \<open>cancels_to_1^** (a @ b) (ba @ b')\<close>
  show ?case unfolding cancels_to_def by simp
qed

text \<open>
The empty list is canceled, a one letter word is canceled and a word is
trivially cancled from itself.
\<close>

lemma empty_canceled[simp]: "canceled []"
by(auto simp add: canceled_def cancels_to_1_def cancels_to_1_at_def)

lemma singleton_canceled[simp]: "canceled [a]"
by(auto simp add: canceled_def cancels_to_1_def cancels_to_1_at_def)

lemma cons_canceled:
  assumes "canceled (a#x)"
  shows   "canceled x"
proof(rule ccontr)
  assume "\<not> canceled x"
  hence "Domainp cancels_to_1 x" by (simp add:canceled_def)
  then obtain x' where "cancels_to_1 x x'" by auto
  then obtain xs1 x1 x2 xs2
    where x: "x = xs1 @ x1 # x2 # xs2"
    and   "canceling x1 x2" by (rule cancels_to_1_unfold)
  hence "cancels_to_1 ((a#xs1) @ x1 # x2 # xs2) ( (a#xs1) @ xs2)"
    by (auto intro:cancels_to_1_fold simp del:append_Cons)
  with x
  have "cancels_to_1 (a#x) (a#xs1 @ xs2)"
    by simp
  hence "\<not> canceled (a#x)" by (auto simp add:canceled_def)
  thus False using \<open>canceled (a#x)\<close> by contradiction
qed

lemma cancels_to_self[simp]: "cancels_to l l"
by (simp add:cancels_to_def)

subsection \<open>Definition of normalization\<close>

text \<open>
Using the THE construct, we can define the normalization function
\<open>normalize\<close> as the unique fully cancled word that the argument cancels
to.
\<close>

definition normalize :: "'a word_g_i \<Rightarrow> 'a word_g_i"
where "normalize l = (THE l'. cancels_to l l' \<and> canceled l')"

text \<open>
Some obvious properties of the normalize function, and other useful lemmas.
\<close>

lemma
  shows normalized_canceled[simp]: "canceled (normalize l)"
  and   normalized_cancels_to[simp]: "cancels_to l (normalize l)"
proof-
  let ?Q = "{l'. cancels_to_1^** l l'}"
  have "l \<in> ?Q" by (auto) hence "\<exists>x. x \<in> ?Q" by (rule exI)

  have "wfP cancels_to_1^--1"
    by (rule canceling_terminates)
  hence "\<forall>Q. (\<exists>x. x \<in> Q) \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. cancels_to_1 z y \<longrightarrow> y \<notin> Q)"
    by (simp add:wfP_eq_minimal)
  hence "(\<exists>x. x \<in> ?Q) \<longrightarrow> (\<exists>z\<in>?Q. \<forall>y. cancels_to_1 z y \<longrightarrow> y \<notin> ?Q)"
    by (erule_tac x="?Q" in allE)
  then obtain l' where "l' \<in> ?Q" and minimal: "\<And>y. cancels_to_1 l' y \<Longrightarrow> y \<notin> ?Q"
    by auto

  from \<open>l' \<in> ?Q\<close> have "cancels_to l l'" by (auto simp add: cancels_to_def)

  have "canceled l'"
  proof(rule ccontr)
    assume "\<not> canceled l'" hence "Domainp cancels_to_1 l'" by (simp add: canceled_def)
    then obtain y where "cancels_to_1 l' y" by auto
    with \<open>cancels_to l l'\<close> have "cancels_to l y" by (auto simp add: cancels_to_def)
    from \<open>cancels_to_1 l' y\<close> have "y \<notin> ?Q" by(rule minimal)
    hence "\<not> cancels_to_1^** l y" by auto
    hence "\<not> cancels_to l y" by (simp add: cancels_to_def)
    with \<open>cancels_to l y\<close> show False by contradiction
  qed

  from \<open>cancels_to l l'\<close> and \<open>canceled l'\<close>
  have "cancels_to l l' \<and> canceled l'" by simp
  hence "cancels_to l (normalize l) \<and> canceled (normalize l)"
    unfolding normalize_def
  proof (rule theI)
    fix l'a
    assume "cancels_to l l'a \<and> canceled l'a"
    thus "l'a = l'" using \<open>cancels_to l l' \<and> canceled l'\<close> by (auto elim:norm_form_uniq)
  qed
  thus "canceled (normalize l)" and "cancels_to l (normalize l)" by auto
qed

lemma normalize_discover:
  assumes "canceled l'"
      and "cancels_to l l'"
  shows "normalize l = l'"
proof-
  from \<open>canceled l'\<close> and \<open>cancels_to l l'\<close>
  have "cancels_to l l' \<and> canceled l'" by auto
  thus ?thesis unfolding normalize_def by (auto elim:norm_form_uniq)
qed

text \<open>Words, related by cancelation, have the same normal form.\<close>

lemma normalize_canceled[simp]:
  assumes "cancels_to l l'"
  shows   "normalize l = normalize l'"
proof(rule normalize_discover)
  show "canceled (normalize l')" by (rule normalized_canceled)
next
  have "cancels_to l' (normalize l')" by (rule normalized_cancels_to)
  with \<open>cancels_to l l'\<close>
  show "cancels_to l (normalize l')" by (rule cancels_to_trans)
qed

text \<open>Normalization is idempotent.\<close>

lemma normalize_idemp[simp]:
  assumes "canceled l"
  shows "normalize l = l"
using assms
by(rule normalize_discover)(rule cancels_to_self)

text \<open>
This lemma lifts the distributivity results from above to the normalize
function.
\<close>

lemma normalize_append_cancel_to:
  assumes "cancels_to l1 l1'"
  and     "cancels_to l2 l2'"
  shows "normalize (l1 @ l2) = normalize (l1' @ l2')"
proof(rule normalize_discover)
  show "canceled (normalize (l1' @ l2'))" by (rule normalized_canceled)
next
  from \<open>cancels_to l1 l1'\<close> and \<open>cancels_to l2 l2'\<close>
  have "cancels_to (l1 @ l2) (l1' @ l2')" by (rule cancels_to_append2)
  also
  have "cancels_to (l1' @ l2') (normalize (l1' @ l2'))" by (rule normalized_cancels_to)
  finally
  show "cancels_to (l1 @ l2) (normalize (l1' @ l2'))".
qed

subsection \<open>Normalization preserves generators\<close>

text \<open>
Somewhat obvious, but still required to formalize Free Groups, is the fact that
canceling a word of generators of a specific set (and their inverses) results
in a word in generators from that set.
\<close>

lemma cancels_to_1_preserves_generators:
  assumes "cancels_to_1 l l'"
      and "l \<in> lists (UNIV \<times> gens)"
  shows "l' \<in> lists (UNIV \<times> gens)"
proof-
  from assms obtain i where "l' = cancel_at i l"
    unfolding cancels_to_1_def and cancels_to_1_at_def by auto
  hence "l' = take i l @ drop (2 + i) l" unfolding cancel_at_def .
  hence "set l' = set (take i l @ drop (2 + i) l)" by simp
  moreover
  have "\<dots> = set (take i l @ drop (2 + i) l)" by auto
  moreover
  have "\<dots> \<subseteq> set (take i l) \<union> set (drop (2 + i) l)" by auto
  moreover
  have "\<dots> \<subseteq> set l" by (auto dest: in_set_takeD in_set_dropD)
  ultimately
  have "set l' \<subseteq> set l" by simp
  thus ?thesis using assms(2) by auto
qed

lemma cancels_to_preserves_generators:
  assumes "cancels_to l l'"
      and "l \<in> lists (UNIV \<times> gens)"
  shows "l' \<in> lists (UNIV \<times> gens)"
using assms unfolding cancels_to_def by (induct, auto dest:cancels_to_1_preserves_generators)

lemma normalize_preserves_generators:
  assumes "l \<in> lists (UNIV \<times> gens)"
    shows "normalize l \<in> lists (UNIV \<times> gens)"
proof-
  have "cancels_to l (normalize l)" by simp
  thus ?thesis using assms by(rule cancels_to_preserves_generators)
qed

text \<open>
Two simplification lemmas about lists.
\<close>

lemma empty_in_lists[simp]:
  "[] \<in> lists A" by auto

lemma lists_empty[simp]: "lists {} = {[]}"
  by auto

subsection \<open>Normalization and renaming generators\<close>

text \<open>
Renaming the generators, i.e. mapping them through an injective function, commutes
with normalization. Similarly, replacing generators by their inverses and
vica-versa commutes with normalization. Both operations are similar enough to be
handled at once here.
\<close>

lemma rename_gens_cancel_at: "cancel_at i (map f l) = map f (cancel_at i l)"
unfolding "cancel_at_def" by (auto simp add:take_map drop_map)

lemma rename_gens_cancels_to_1:
  assumes "inj f"
      and "cancels_to_1 l l'"
    shows "cancels_to_1 (map (map_prod f g) l) (map (map_prod f g) l')"
proof-
  from \<open>cancels_to_1 l l'\<close>
  obtain ls1 l1 l2 ls2
    where "l = ls1 @ l1 # l2 # ls2"
      and "l' = ls1 @ ls2"
      and "canceling l1 l2"
  by (rule cancels_to_1_unfold)

  from \<open>canceling l1 l2\<close>
  have "fst l1 \<noteq> fst l2" and "snd l1 = snd l2"
    unfolding canceling_def by auto
  from \<open>fst l1 \<noteq> fst l2\<close> and \<open>inj f\<close>
  have "f (fst l1) \<noteq> f (fst l2)" by(auto dest!:inj_on_contraD)
  hence "fst (map_prod f g l1) \<noteq> fst (map_prod f g l2)" by auto
  moreover
  from \<open>snd l1 = snd l2\<close>
  have "snd (map_prod f g l1) = snd (map_prod f g l2)" by auto
  ultimately
  have "canceling (map_prod f g (l1)) (map_prod f g (l2))"
    unfolding canceling_def by auto
  hence "cancels_to_1 (map (map_prod f g) ls1 @ map_prod f g l1 # map_prod f g l2 # map (map_prod f g) ls2) (map (map_prod f g) ls1 @ map (map_prod f g) ls2)"
   by(rule cancels_to_1_fold)
  with \<open>l = ls1 @ l1 # l2 # ls2\<close> and \<open>l' = ls1 @ ls2\<close>
  show "cancels_to_1 (map (map_prod f g) l) (map (map_prod f g) l')"
   by simp
qed

lemma rename_gens_cancels_to:
  assumes "inj f"
      and "cancels_to l l'"
    shows "cancels_to (map (map_prod f g) l) (map (map_prod f g) l')"
using \<open>cancels_to l l'\<close>
unfolding cancels_to_def
proof(induct rule:rtranclp_induct)
  case (step x z)
    from \<open>cancels_to_1 x z\<close> and \<open>inj f\<close>
    have "cancels_to_1 (map (map_prod f g) x) (map (map_prod f g) z)"
      by -(rule rename_gens_cancels_to_1)
    with \<open>cancels_to_1^** (map (map_prod f g) l) (map (map_prod f g) x)\<close>
    show "cancels_to_1^** (map (map_prod f g) l) (map (map_prod f g) z)" by auto
qed(auto)

lemma rename_gens_canceled:
  assumes "inj_on g (snd`set l)"
      and "canceled l"
  shows "canceled (map (map_prod f g) l)"
unfolding canceled_def
proof
  (* This statement is needed explicitly later in this proof *)
  have different_images: "\<And> f a b. f a \<noteq> f b \<Longrightarrow> a \<noteq> b" by auto

  assume "Domainp cancels_to_1 (map (map_prod f g) l)"
  then obtain l' where "cancels_to_1 (map (map_prod f g) l) l'" by auto
  then obtain i where "Suc i < length l"
    and "canceling (map (map_prod f g) l ! i) (map (map_prod f g) l ! Suc i)"
    by(auto simp add:cancels_to_1_def cancels_to_1_at_def)
  hence "f (fst (l ! i)) \<noteq> f (fst (l ! Suc i))"
    and "g (snd (l ! i)) = g (snd (l ! Suc i))"
    by(auto simp add:canceling_def)
  from \<open>f (fst (l ! i)) \<noteq> f (fst (l ! Suc i))\<close>
  have "fst (l ! i) \<noteq> fst (l ! Suc i)" by -(erule different_images)
  moreover
  from \<open>Suc i < length l\<close>
  have "snd (l ! i) \<in> snd ` set l" and "snd (l ! Suc i) \<in> snd ` set l" by auto
  with \<open>g (snd (l ! i)) = g (snd (l ! Suc i))\<close>
  have "snd (l ! i) = snd (l ! Suc i)"
    using \<open>inj_on g (image snd (set l))\<close>
    by (auto dest: inj_onD)
  ultimately
  have "canceling (l ! i) (l ! Suc i)" unfolding canceling_def by simp
  with \<open>Suc i < length l\<close>
  have "cancels_to_1_at i l (cancel_at i l)"
    unfolding cancels_to_1_at_def by auto
  hence "cancels_to_1 l (cancel_at i l)"
    unfolding cancels_to_1_def by auto
  hence "\<not>canceled l"
    unfolding canceled_def by auto
  with \<open>canceled l\<close> show False by contradiction
qed

lemma rename_gens_normalize:
  assumes "inj f"
  and "inj_on g (snd ` set l)"
  shows "normalize (map (map_prod f g) l) = map (map_prod f g) (normalize l)"
proof(rule normalize_discover)
  from \<open>inj_on g (image snd (set l))\<close>
  have "inj_on g (image snd (set (normalize l)))"
  proof (rule subset_inj_on)

    have UNIV_snd: "\<And>A. A \<subseteq> UNIV \<times> snd ` A"
      proof fix A and x::"'c\<times>'d" assume "x\<in>A"
        hence "(fst x,snd x)\<in> (UNIV \<times> snd ` A)"
          by -(rule, auto)
        thus "x\<in> (UNIV \<times> snd ` A)" by simp
      qed

    have "l \<in> lists (set l)" by auto
    hence "l \<in> lists (UNIV \<times> snd ` set l)"
      by (rule subsetD[OF lists_mono[OF UNIV_snd], of l "set l"])
    hence "normalize l \<in> lists (UNIV \<times> snd ` set l)"
      by (rule normalize_preserves_generators[of _ "snd ` set l"])
    thus "snd ` set (normalize l) \<subseteq> snd ` set l"
      by (auto simp add: lists_eq_set)
   qed
  thus "canceled (map (map_prod f g) (normalize l))" by(rule rename_gens_canceled,simp)
next
  from \<open>inj f\<close>
  show "cancels_to (map (map_prod f g) l) (map (map_prod f g) (normalize l))"
    by (rule rename_gens_cancels_to, simp)
qed

end