subsection \<open>Theorems on lists\<close>

theory List_Theorems
  imports Main
begin

(* Returns the last n elements of list x *)
definition lastn :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where "lastn n x = drop ((length x) - n) x"
(* Returns true iff [a,b] is a sequence in list x. *)
definition is_sub_seq :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool"
where "is_sub_seq a b x \<equiv> \<exists> n . Suc n < length x \<and> x!n = a \<and> x!(Suc n) = b"
(* Return, given a set of lists, the set with all prefixes of all the lists *)
definition prefixes :: "'a list set \<Rightarrow> 'a list set"
where "prefixes s \<equiv> {x . \<exists> n y . n > 0 \<and> y \<in> s \<and> take n y = x}"

lemma drop_one[simp]:
  shows "drop (Suc 0) x = tl x" by(induct x,auto)
lemma length_ge_one:
  shows "x \<noteq> [] \<longrightarrow> length x \<ge> 1" by(induct x,auto)
lemma take_but_one[simp]:
  shows "x \<noteq> [] \<longrightarrow> lastn ((length x) - 1) x = tl x" unfolding lastn_def
  using length_ge_one[where x=x] by auto
lemma Suc_m_minus_n[simp]:
  shows "m \<ge> n \<longrightarrow> Suc m - n = Suc (m - n)" by auto
lemma lastn_one_less:
 shows "n > 0 \<and> n \<le> length x \<and> lastn n x = (a#y) \<longrightarrow> lastn (n - 1) x = y" unfolding lastn_def
 using drop_Suc[where n="length x - n" and xs=x] drop_tl[where n="length x - n" and xs=x]
 by(auto)
lemma list_sub_implies_member:
  shows "\<forall> a x . set (a#x) \<subseteq> Z \<longrightarrow> a \<in> Z" by auto
lemma subset_smaller_list:
  shows "\<forall> a x . set (a#x) \<subseteq> Z \<longrightarrow> set x \<subseteq> Z" by auto
lemma second_elt_is_hd_tl:
  shows "tl x = (a # x') \<longrightarrow> a = x ! 1"
  by (cases x,auto)
lemma length_ge_2_implies_tl_not_empty:
  shows "length x \<ge> 2 \<longrightarrow> tl x \<noteq> []"
  by (cases x,auto)
lemma length_lt_2_implies_tl_empty:
  shows "length x < 2 \<longrightarrow> tl x = []"
  by (cases x,auto)
lemma first_second_is_sub_seq:
  shows "length x \<ge> 2 \<Longrightarrow> is_sub_seq (hd x) (x!1) x"
proof-
  assume "length x \<ge> 2"
  hence 1: "(Suc 0) < length x" by auto
  hence "x!0 = hd x" by(cases x,auto)
  from this 1 show "is_sub_seq (hd x) (x!1) x" unfolding is_sub_seq_def by auto
qed
lemma hd_drop_is_nth:
  shows "n < length x \<Longrightarrow> hd (drop n x) = x!n"
proof(induct x arbitrary: n)
case Nil
  thus ?case by simp
next
case (Cons a x)
{
  have "hd (drop n (a # x)) = (a # x) ! n"
  proof(cases n)
  case 0
    thus ?thesis by simp
  next
  case (Suc m)
    from Suc Cons show ?thesis by auto
  qed
}
thus ?case by auto
qed

lemma def_of_hd:
  shows "y = a # x \<longrightarrow> hd y = a" by simp
lemma def_of_tl:
  shows "y = a # x \<longrightarrow> tl y = x" by simp
lemma drop_yields_results_implies_nbound:
  shows "drop n x \<noteq> [] \<longrightarrow> n < length x"
by(induct x,auto)
lemma consecutive_is_sub_seq:
  shows "a # (b # x) = lastn n y \<Longrightarrow> is_sub_seq a b y"
proof-
  assume 1: "a # (b # x) = lastn n y"
  from 1 drop_Suc[where n="(length y) - n" and xs="y"]
       drop_tl[where n="(length y) - n" and xs="y"]
       def_of_tl[where y="lastn n y" and a=a and x ="b#x"]
       drop_yields_results_implies_nbound[where n="Suc (length y - n)" and x=y]
    have 3: "Suc (length y - n) < length y" unfolding lastn_def by auto
  from 3 1 hd_drop_is_nth[where n="(length y) - n" and x=y] def_of_hd[where y="drop (length y - n) y" and x="b#x" and a=a]
    have 4: "y!(length y - n) = a"  unfolding lastn_def by auto
  from 3 1 hd_drop_is_nth[where n="Suc ((length y) - n)" and x=y] def_of_hd[where y="drop (Suc (length y - n)) y" and x="x" and a=b]
       drop_Suc[where n="(length y) - n" and xs="y"]
       drop_tl[where n="(length y) - n" and xs="y"]
       def_of_tl[where y="lastn n y" and a=a and x ="b#x"]
    have 5: "y!Suc (length y - n) = b" unfolding lastn_def by auto
  from 3 4 5 show ?thesis
    unfolding is_sub_seq_def by auto
qed

lemma sub_seq_in_prefixes:
  assumes "\<exists>y \<in> prefixes X. is_sub_seq a a' y"
  shows "\<exists>y \<in> X. is_sub_seq a a' y"
proof-
  from assms obtain y where y: "y \<in> prefixes X \<and> is_sub_seq a a' y" by auto
  then obtain n x where x: "n > 0 \<and> x \<in> X \<and> take n x = y"
    unfolding prefixes_def by auto
  from y obtain i where sub_seq_index: "Suc i < length y \<and> y ! i = a \<and> y ! Suc i = a'"
    unfolding is_sub_seq_def by auto
  from sub_seq_index x have "is_sub_seq a a' x"
    unfolding is_sub_seq_def using nth_take by auto
  from this x show ?thesis by metis
qed

lemma set_tl_is_subset:
shows "set (tl x) \<subseteq> set x" by(induct x,auto)
lemma x_is_hd_snd_tl:
shows "length x \<ge> 2 \<longrightarrow> x = (hd x) # x!1 # tl(tl x)"
proof(induct x)
case Nil
  show ?case by auto
case (Cons a xs)
  show ?case by(induct xs,auto)
qed

lemma tl_x_not_x:
shows "x \<noteq> [] \<longrightarrow> tl x \<noteq> x" by(induct x,auto)
lemma tl_hd_x_not_tl_x:
shows "x \<noteq> [] \<and> hd x \<noteq> [] \<longrightarrow> tl (hd x) # tl x \<noteq> x" using tl_x_not_x by(induct x,simp,auto)

end


theory NDTable
imports Words Dags
begin

text {*
  The following rule was already deactivated in theory Words, but it
  creeps back in when combining theories.
*}

declare upt_Suc [simp del]

section {* Non-deterministic transition tables *}

subsection {* Definition *}

text {*
  Non-deterministic transition tables underly non-deterministic
  $\omega$-automata. They are parameterized by two sorts
  that represent the sort of states and the input alphabet.
  Transition tables are defined by the set of their initial states
  and their transition relation, formalized here as a function
  that maps a source state and input letter to the set of
  potential successor states. Different classes of non-deterministic
  automata can simply be represented as (record) extensions of this
  basic table structure.

  Observe in particular that the set of automaton states is not
  represented explicitly (but see definition of function
  @{text states} below). The main reason for this design
  decision is that otherwise one would require a well-formedness
  predicate that states that initial states and target states
  of transitions belong to the set of states. Most theorems
  would then require an extra hypothesis stating that the
  automata are well-formed.
*}

record ('q,'a) ndtable =
  initial   :: "'q set"     -- "set of initial states"
  trans     :: "'q \<Rightarrow> 'a \<Rightarrow> 'q set"

text {*
  A deterministic table contains at most one initial state
  and has at most one successor state per source state and
  alphabet letter. Observe that the definitions and theorems
  in this section are all defined for @{text ndtable_scheme}
  so that they apply to all future extensions of
  non-deterministic tables.
*}

definition
  det_table :: "('q,'a,'b) ndtable_scheme \<Rightarrow> bool"
  where "det_table tbl \<equiv>
         atmost_one (initial tbl) \<and>
         (\<forall>q a. atmost_one (trans tbl q a))"

lemma det_table_initial:
  "\<lbrakk> det_table tbl; q \<in> initial tbl; r \<in> initial tbl \<rbrakk> \<Longrightarrow> q=r"
by (auto simp add: det_table_def)

lemma det_table_trans:
  "\<lbrakk> det_table tbl; r \<in> trans tbl q a; r' \<in> trans tbl q a \<rbrakk> \<Longrightarrow> r'=r"
by (fastsimp simp add: det_table_def)

text {*
  The following function can be used to approximate the set of
  states of a transition table as the union of the initial
  states and the targets of the transition relation. For
  concrete tables, the transition relation should be defined
  such that elements of the state type that are not automaton
  states are assigned the empty set of successors.
*}

definition
  states_of :: "('q,'a,'b) ndtable_scheme \<Rightarrow> 'q set"
  where "states_of tbl = (initial tbl) \<union> (\<Union> q a. trans tbl q a)"

lemma initial_states_of [elim]:
  assumes "q \<in> initial tbl"
  shows "q \<in> states_of tbl"
using assms by (simp add: states_of_def)

lemma trans_states_of [elim]:
  assumes "q' \<in> trans tbl q a"
  shows "q' \<in> states_of tbl"
using assms by (auto simp add: states_of_def)

subsection {* Execution fragments, executions, and runs *}

text {*
  A run of a table over a word is an infinite sequence of
  states such that the first state is initial and all states
  are related by the transition relation, for the corresponding
  input letter. We also define (finite and infinite) executions
  starting from arbitrary states.
*}

definition
  -- "finite executions (from arbitrary state)"
  nd_exec_fragment :: "[('q,'a,'b) ndtable_scheme, 'a list, 'q list] \<Rightarrow> bool"
  where
   "nd_exec_fragment tbl inp run \<equiv>
    length run = Suc (length inp) \<and>
    (\<forall>n < length inp. run!(Suc n) \<in> trans tbl (run!n) (inp!n))"

definition
  -- "infinite executions (from arbitrary state)"
  nd_execution :: "[('q,'a,'b) ndtable_scheme, 'a word, 'q word] \<Rightarrow> bool"
  where
   "nd_execution tbl inp run \<equiv>
    \<forall>n. run (Suc n) \<in> trans tbl (run n) (inp n)"

definition
  -- "infinite runs (from initial state)"
  nd_run :: "[('q,'a,'b) ndtable_scheme, 'a word, 'q word] \<Rightarrow> bool"
  where
    "nd_run tbl inp run \<equiv>
    nd_execution tbl inp run \<and> run 0 \<in> initial tbl"

lemma [intro]:
  "\<lbrakk> length run = Suc (length inp);
     \<And>n. n < length inp \<Longrightarrow> run!(Suc n) \<in> trans tbl (run!n) (inp!n)
   \<rbrakk> \<Longrightarrow> nd_exec_fragment tbl inp run"
by (simp add: nd_exec_fragment_def)

lemma nd_exec_fragment_length [elim]:
  "nd_exec_fragment tbl inp run \<Longrightarrow> length run = Suc (length inp)"
by (simp add: nd_exec_fragment_def)

lemma nd_exec_fragment_inp_less_run [elim]:
  "nd_exec_fragment tbl inp run \<Longrightarrow> length inp < length run"
by (simp add: nd_exec_fragment_def)

lemma nd_exec_fragment_nempty [elim]:
  "nd_exec_fragment tbl inp [] \<Longrightarrow> R"
by (simp add: nd_exec_fragment_def)

lemma nd_exec_fragment_succ [elim]:
  "\<lbrakk> nd_exec_fragment tbl inp run; n < length inp \<rbrakk>
   \<Longrightarrow> run!(Suc n) \<in> trans tbl (run!n) (inp!n)"
by (simp add: nd_exec_fragment_def)

lemma [intro]:
  "\<lbrakk> \<And>n. run (Suc n) \<in> trans tbl (run n) (inp n) \<rbrakk>
   \<Longrightarrow> nd_execution tbl inp run"
by (simp add: nd_execution_def)

lemma nd_execution_succ [elim_format,elim]:
  "nd_execution tbl inp run
   \<Longrightarrow> run (Suc n) \<in> trans tbl (run n) (inp n)"
by (simp add: nd_execution_def)

lemma [intro]:
  "\<lbrakk> run 0 \<in> initial tbl; nd_execution tbl inp run \<rbrakk>
   \<Longrightarrow> nd_run tbl inp run"
by (simp add: nd_run_def)

lemma nd_run_initial [elim_format,elim]:
  "nd_run tbl inp run \<Longrightarrow> run 0 \<in> initial tbl"
by (simp add: nd_run_def)

lemma nd_run_trans [elim_format,elim]:
  "nd_run tbl inp run \<Longrightarrow> run (Suc n) \<in> trans tbl (run n) (inp n)"
by (simp add: nd_run_def nd_execution_def)

lemma nd_run_execution [elim]:
  "nd_run tbl inp run \<Longrightarrow> nd_execution tbl inp run"
by (simp add: nd_run_def)

text {*
  Finite and infinite executions remain within the state set of
  the transition table.
*}

lemma nd_exec_fragment_states [elim]:
  assumes "nd_exec_fragment tbl inp run"
  and "run!0 \<in> states_of tbl"
  and "k < length run"
  shows "run!k \<in> states_of tbl"
using assms by (cases k) (auto simp add: nd_exec_fragment_def)

lemma nd_execution_states [elim]:
  assumes "nd_execution tbl inp run"
  and "run 0 \<in> states_of tbl"
  shows "run k \<in> states_of tbl"
using assms by (cases k) auto

lemma nd_run_states [elim]:
  assumes "nd_run tbl inp run"
  shows "run k \<in> states_of tbl"
using assms by (cases k) auto

text {*
  A deterministic table admits at most one execution (fragment)
  for a given input.
*}

theorem det_exec_fragment_unique:
  assumes det: "det_table tbl"
  and runa: "nd_exec_fragment tbl inp runa"
  and runb: "nd_exec_fragment tbl inp runb"
  and start: "runb!0 = runa!0"
  shows "runb = runa"
proof (rule nth_equalityI)
  from runa runb show "length runb = length runa"
    by (simp add: nd_exec_fragment_length)
next
  show "\<forall>i. i < length runb \<longrightarrow> runb ! i = runa ! i"
  proof
    fix n
    show "n < length runb \<longrightarrow> runb!n = runa!n" (is "?P n")
    proof (induct n)
      from start show "?P 0" by simp
    next
      fix k
      assume ih: "?P k"
      show "?P (Suc k)"
      proof
	assume k: "Suc k < length runb"
	with ih have eqk: "runb!k = runa!k" by simp
	from k runb have kinp: "k < length inp"
	  by (simp add: nd_exec_fragment_length)
	from runa kinp
	have a: "runa!(Suc k) \<in> trans tbl (runa!k) (inp!k)" ..
	from runb kinp
	have "runb!(Suc k) \<in> trans tbl (runb!k) (inp!k)" ..
	with eqk
	have b: "runb!(Suc k) \<in> trans tbl (runa!k) (inp!k)" by simp
	from det a b show "runb!(Suc k) = runa!(Suc k)"
	  by (rule det_table_trans)
      qed
    qed
  qed
qed

theorem det_execution_unique:
  assumes det: "det_table tbl"
  and runa: "nd_execution tbl inp runa"
  and runb: "nd_execution tbl inp runb"
  and start: "runb 0 = runa 0"
  shows "runb = runa"
proof
  fix n
  show "runb n = runa n"
  proof (induct n)
    from start show "runb 0 = runa 0" .
  next
    fix k
    assume ih: "runb k = runa k"
    from runa have a: "runa (Suc k) \<in> trans tbl (runa k) (inp k)" ..
    from runb have "runb (Suc k) \<in> trans tbl (runb k) (inp k)" ..
    with ih have b: "runb (Suc k) \<in> trans tbl (runa k) (inp k)" by simp
    from det a b show "runb (Suc k) = runa (Suc k)"
      by (rule det_table_trans)
  qed
qed

theorem det_table_run_unique:
  assumes det: "det_table tbl"
  and runa: "nd_run tbl inp runa"
  and runb: "nd_run tbl inp runb"
  shows "runa = runb"
using det
proof (rule det_execution_unique)
  from runa show "nd_execution tbl inp runa" ..
next
  from runb show "nd_execution tbl inp runb" ..
next
  from runa have "runa 0 \<in> initial tbl" ..
  moreover
  from runb have "runb 0 \<in> initial tbl" ..
  moreover note det
  ultimately show "runa 0 = runb 0"
    by (simp add: det_table_initial)
qed

text {*
  Non-empty subsequences of an execution (fragment)
  are executions (or execution fragments).
*}

lemma nd_exec_frag_take:
  assumes run: "nd_exec_fragment tbl inp run"
  shows "nd_exec_fragment tbl (take k inp) (take (Suc k) run)"
    (is "nd_exec_fragment tbl ?tinp ?trun")
proof
  from run have "length run = Suc (length inp)"
    by (simp add: nd_exec_fragment_length)
  thus "length ?trun = Suc (length ?tinp)"
    by simp
next
  fix n
  assume n: "n < length ?tinp"
  with run have sucn: "Suc n < length ?trun"
    by (simp add: nd_exec_fragment_length)
  from n sucn run
  show "?trun ! (Suc n) \<in> trans tbl (?trun!n) (?tinp!n)"
    by auto
qed

lemma nd_exec_frag_drop:
  assumes run: "nd_exec_fragment tbl inp run"
  and k: "k \<le> length inp"
  shows "nd_exec_fragment tbl (drop k inp) (drop k run)"
    (is "nd_exec_fragment tbl ?dinp ?drun")
proof
  from run have "length run = Suc (length inp)"
    by (simp add: nd_exec_fragment_length)
  with k show "length ?drun = Suc (length ?dinp)"
    by (simp add: Suc_diff_le)
next
  fix n
  assume n: "n < length ?dinp"
  with k have kn: "k+n < length inp"
    by simp
  from n run k have "Suc n < length ?drun"
    by (simp add: nd_exec_fragment_length Suc_diff_le)
  hence sucn: "k+Suc n < length run"
    by simp
  from kn sucn run
  show "?drun!(Suc n) \<in> trans tbl (?drun!n) (?dinp!n)"
    by auto
qed

lemma nd_execution_suffix:
  "nd_execution tbl inp run
   \<Longrightarrow> nd_execution tbl (suffix k inp) (suffix k run)"
by (rule, auto)

lemma nd_execution_sub:
  assumes run: "nd_execution tbl inp run"
  and nempty: "k \<le> m"
  shows "nd_exec_fragment tbl (map inp [k ..< m]) (map run [k ..< Suc m])"
    (is "nd_exec_fragment tbl ?sinp ?srun")
proof
  from nempty show "length ?srun = Suc (length ?sinp)"
    by (simp add: upt_Suc)
next
  fix n
  assume n: "n < length ?sinp"
  hence "k+n < m"
    by simp
  with n have inpn: "?sinp!n = inp (k+n)"
    by simp
  from n nempty have ksucn: "k + Suc n < Suc m"
    by simp
  hence runn: "?srun!n = run (k+n)"
    by (intro nth_map_upt, arith)
  from ksucn have "?srun!(Suc n) = run (k + Suc n)"
    by (intro nth_map_upt, arith)
  also from run
  have "\<dots> \<in> trans tbl (run (k+n)) (inp (k+n))"
    by auto
  also from inpn runn
  have "\<dots> = trans tbl (?srun!n) (?sinp!n)"
    by simp
  finally show "?srun!(Suc n) \<in> trans tbl (?srun!n) (?sinp!n)" .
qed

text {*
  Execution fragments can be concatenated to produce longer
  fragments.
*}

lemma exec_frag_append:
  assumes runa: "nd_exec_fragment tbl inpa runa"
  and runb: "nd_exec_fragment tbl inpb runb"
  and eq: "runa!(length inpa) = runb!0"
  shows "nd_exec_fragment tbl (inpa @ inpb) (runa @ (drop 1 runb))"
    (is "nd_exec_fragment tbl ?linp ?lrun")
proof
  from runa runb
  show "length ?lrun = Suc (length ?linp)"
    by (simp add: nd_exec_fragment_length)
next
  fix n
  assume n: "n < length ?linp"
  {
    assume left: "n < length inpa"
    with runa have suc: "Suc n < length runa"
      by (simp add: nd_exec_fragment_length)
    hence "?lrun ! (Suc n) = runa ! (Suc n)"
      by (simp add: nth_append)
    also from runa left
    have "\<dots> \<in> trans tbl (runa!n) (inpa!n)" ..
    also from suc left
    have "\<dots> = trans tbl (?lrun!n) (?linp!n)"
      by (simp add: nth_append)
    finally
    have "?lrun ! (Suc n) \<in> trans tbl (?lrun ! n) (?linp ! n)" .
  }
  moreover
  {
    assume middle: "length inpa = n"
    with n have lb: "0 < length inpb"
      by simp
    from middle runa have suc: "length runa = Suc n"
      by (simp add: nd_exec_fragment_length)
    with runb have "?lrun ! (Suc n) = runb ! 1"
      by (simp add: nth_append nd_exec_fragment_length)
    also from runb lb
    have "\<dots> \<in> trans tbl (runb!0) (inpb!0)"
      by (simp add: nd_exec_fragment_succ)
    also from eq middle suc
    have "\<dots> = trans tbl (?lrun!n) (?linp!n)"
      by (simp add: nth_append)
    finally
    have "?lrun ! (Suc n) \<in> trans tbl (?lrun ! n) (?linp ! n)" .
  }
  moreover
  {
    assume right: "length inpa < n"
    with n
    have lb: "n - length inpa < length inpb"
         (is "n - ?la < ?lb")
      by simp
    with runb
    have nla: "n - ?la \<le> length runb"
      by (simp add: nd_exec_fragment_length)
    from right
    have sucn: "Suc (n - Suc ?la) = n - ?la"
      by arith
    from lb runa runb right
    have "?lrun ! (Suc n) = runb ! (Suc (n - ?la))"
      by (simp add: nth_append nd_exec_fragment_length)
    also from runb lb
    have "\<dots> \<in> trans tbl (runb!(n - ?la)) (inpb!(n - ?la))" ..
    also from right sucn nla runa
    have "\<dots> = trans tbl (?lrun!n) (?linp!n)"
      by (simp add: nth_append nd_exec_fragment_length)
    finally
    have "?lrun ! (Suc n) \<in> trans tbl (?lrun ! n) (?linp ! n)" .
  }
  ultimately
  show "?lrun ! (Suc n) \<in> trans tbl (?lrun ! n) (?linp ! n)"
    by arith
qed

lemma exec_conc:
  assumes runa: "nd_exec_fragment tbl inpa runa"
  and runb: "nd_execution tbl inpb runb"
  and eq: "runa!(length inpa) = runb 0"
  shows "nd_execution tbl (inpa \<frown> inpb) (runa \<frown> (suffix 1 runb))"
    (is "nd_execution tbl ?linp ?lrun")
proof
  fix n
  {
    assume left: "n < length inpa"
    with runa have suc: "Suc n < length runa"
      by (simp add: nd_exec_fragment_length)
    hence "?lrun (Suc n) = runa ! (Suc n)"
      by (simp add: conc_def)
    also from runa left
    have "\<dots> \<in> trans tbl (runa!n) (inpa!n)" ..
    also from suc left
    have "\<dots> = trans tbl (?lrun n) (?linp n)"
      by (simp add: conc_def)
    finally
    have "?lrun (Suc n) \<in> trans tbl (?lrun n) (?linp n)" .
  }
  moreover
  {
    assume middle: "length inpa = n"
    from middle runa have suc: "length runa = Suc n"
      by (simp add: nd_exec_fragment_length)
    hence "?lrun (Suc n) = runb 1"
      by (simp add: conc_def)
    also from runb
    have "\<dots> \<in> trans tbl (runb 0) (inpb 0)"
      by auto
    also from eq middle suc
    have "\<dots> = trans tbl (?lrun n) (?linp n)"
      by (simp add: conc_def)
    finally
    have "?lrun (Suc n) \<in> trans tbl (?lrun n) (?linp n)" .
  }
  moreover
  {
    assume right: "length inpa < n"
    let ?la = "length inpa"
    from right
    have sucn: "Suc (n - Suc ?la) = n - ?la"
      by (arith)
    from runa right
    have "?lrun (Suc n) = runb (Suc (n - ?la))"
      by (simp add: conc_def nd_exec_fragment_length)
    also from runb
    have "\<dots> \<in> trans tbl (runb (n - ?la)) (inpb (n - ?la))" ..
    also from right sucn runa
    have "\<dots> = trans tbl (?lrun n) (?linp n)"
      by (simp add: conc_def nd_exec_fragment_length)
    finally
    have "?lrun (Suc n) \<in> trans tbl (?lrun n) (?linp n)" .
  }
  ultimately
  show "?lrun (Suc n) \<in> trans tbl (?lrun n) (?linp n)"
    by arith
qed

text {*
  From a finite and non-empty loop through the table,
  an infinite execution can be obtained by $\omega$-iteration.
  This is useful to prove the non-emptiness of languages
  defined by $\omega$-automata from the existence of suitable
  finite executions.
*}

theorem loop_execution:
  assumes run: "nd_exec_fragment tbl inp run"
  and loop: "run!(length inp) = run!0"
  and nempty: "0 < length inp"
  shows "nd_execution tbl inp\<^sup>\<omega> (take (length inp) run)\<^sup>\<omega>"
    (is "nd_execution tbl ?linp ?lrun")
proof
  -- "some preparatory calculation"
  let ?l = "length inp"
  from nempty obtain k where k: "?l = Suc k"
    by (auto simp add: gr0_conv_Suc)
  from run
  have "length (take ?l run) = ?l"
    by (simp add: nd_exec_fragment_length)
  with run nempty
  have ridx: "\<And>i. ?lrun i = run ! (i mod ?l)"
    by (simp add: nd_exec_fragment_length)
  from nempty
  have iidx: "\<And>i. ?linp i = inp ! (i mod ?l)"
    by simp
  -- "now for the main proof"
  fix n
  show "?lrun (Suc n) \<in> trans tbl (?lrun n) (?linp n)"
  proof (cases "Suc (n mod ?l) = ?l")
    case True
    with ridx have "?lrun (Suc n) = run!0"
      by (simp add: mod_Suc)
    also from loop k have "\<dots> = run ! (Suc k)"
      by simp
    also from run k
    have "\<dots> \<in> trans tbl (run!k) (inp!k)"
      by auto
    also from ridx iidx k True
    have "\<dots> = trans tbl (?lrun n) (?linp n)"
      by (simp add: mod_Suc)
    finally show ?thesis .
  next
    case False
    with ridx have "?lrun (Suc n) = run ! (Suc (n mod ?l))"
      by (simp add: mod_Suc)
    also from run k
    have "\<dots> \<in> trans tbl (run ! (n mod ?l)) (inp ! (n mod ?l))"
      by auto
    also from iidx ridx False
    have "\<dots> = trans tbl (?lrun n) (?linp n)"
      by (simp add: mod_Suc)
    finally show ?thesis .
  qed
qed

text {*
  We define one- and multi-step accessibility between automaton
  states and prove some obvious lemmas.
*}

definition
  one_step :: "('q,'a,'b) ndtable_scheme \<Rightarrow> ('q \<times> 'q) set"
  where "one_step tbl \<equiv> { (q,q') . \<exists>a. q' \<in> trans tbl q a }"

syntax
  "_acc_one"  :: "['q, ('q,'a,'b) ndtable_scheme, 'q] \<Rightarrow> bool"
                                             ("_ - _ -> _" [65,65,65] 100)
  "_acc_star" :: "['q, ('q,'a,'b) ndtable_scheme, 'q] \<Rightarrow> bool"
                                             ("_ - _ ->^* _" [65,65,65] 100)
  "_acc_plus" :: "['q, ('q,'a,'b) ndtable_scheme, 'q] \<Rightarrow> bool"
                                             ("_ - _ ->^+ _" [65,65,65] 100)
syntax (xsymbols)
  "_acc_one"  :: "['q, ('q,'a,'b) ndtable_scheme, 'q] \<Rightarrow> bool"
                                             ("_ - _ \<rightarrow> _" [65,65,65] 100)
  "_acc_star" :: "['q, ('q,'a,'b) ndtable_scheme, 'q] \<Rightarrow> bool"
                                             ("_ - _ \<rightarrow>\<^sup>* _" [65,65,65] 100)
  "_acc_plus" :: "['q, ('q,'a,'b) ndtable_scheme, 'q] \<Rightarrow> bool"
                                             ("_ - _ \<rightarrow>\<^sup>+ _" [65,65,65] 100)
translations
  "q - tbl \<rightarrow> q'" \<rightleftharpoons> "(q,q') \<in> (CONST one_step tbl)"
  "q - tbl \<rightarrow>\<^sup>* q'" \<rightleftharpoons> "(q,q') \<in> (CONST one_step tbl)\<^sup>*"
  "q - tbl \<rightarrow>\<^sup>+ q'" \<rightleftharpoons> "(q,q') \<in> (CONST one_step tbl)\<^sup>+"

lemma exec_acc_star:
  assumes run: "nd_exec_fragment tbl inp run"   (is "?exe inp run")
  shows "(run!0) - tbl \<rightarrow>\<^sup>* (run ! length inp)"  (is "?acc inp run")
proof -
  have "\<forall>run. ?exe inp run \<longrightarrow> ?acc inp run"
  proof (induct inp)
    show "\<forall>run. ?exe [] run \<longrightarrow> ?acc [] run" by auto
  next
    fix a inp
    assume ih: "\<forall>run. ?exe inp run \<longrightarrow> ?acc inp run"
    show "\<forall>run. ?exe (a # inp) run \<longrightarrow> ?acc (a # inp) run"
    proof (clarify)
      fix run
      assume r: "nd_exec_fragment tbl (a # inp) run"
      -- {* first show that $run!1$ is accessible from $run!0$ *}
      from r have "(run!0) - tbl \<rightarrow> (run!1)"
	by (auto simp add: one_step_def)
      -- {* now use the induction hypothesis to show accessibility for the tail *}
      moreover
      from r have "nd_exec_fragment tbl (drop 1 (a # inp)) (drop 1 run)"
	by (rule nd_exec_frag_drop, simp)
      hence "nd_exec_fragment tbl inp (drop 1 run)" by simp
      with ih have "((drop 1 run)!0) - tbl \<rightarrow>\<^sup>* ((drop 1 run)!(length inp))"
	by blast
      with r have "(run!1) - tbl \<rightarrow>\<^sup>* (run ! length(a # inp))"
	by (simp add: nd_exec_fragment_length)
      ultimately
      show "run!0 - tbl \<rightarrow>\<^sup>* (run ! length (a # inp))"
	by (rule converse_rtrancl_into_rtrancl)
    qed
  qed
  with run show ?thesis by blast
qed

lemma acc_star_exec:
  assumes acc: "q - tbl \<rightarrow>\<^sup>* q'"  (is "?acc q q'")
  shows "\<exists>inp run. nd_exec_fragment tbl inp run
                   \<and> run!0 = q \<and> run!(length inp) = q'"
        (is "\<exists>inp run. ?exec inp run q q'")
using acc
proof (induct)
  have "?exec [] [q] q q" by auto
  thus "\<exists>inp run. ?exec inp run q q" by blast
next
  fix q' q''
  assume q'': "q' - tbl \<rightarrow> q''"
    and  ih:  "\<exists>inp run. ?exec inp run q q'"
  from q'' obtain a where "q'' \<in> trans tbl q' a"
    by (auto simp add: one_step_def)
  hence a_run: "nd_exec_fragment tbl [a] [q',q'']" by auto
  from ih obtain inp run where run: "?exec inp run q q'"
    by blast
  from run a_run
  have "nd_exec_fragment tbl (inp @ [a]) (run @ [q''])"
    by (auto dest: exec_frag_append)
  moreover
  from run have "(run @ [q'']) ! 0 = q"
    by (auto simp add: nth_append)
  moreover
  from run have "length run = Suc (length inp)"
    by (auto simp add: nd_exec_fragment_length)
  with run have "(run @ [q'']) ! (Suc (length inp)) = q''"
    by (simp add: nth_append)
  ultimately
  have "?exec (inp @ [a]) (run @ [q'']) q q''" by simp
  thus "\<exists>inp run. ?exec inp run q q''" by blast
qed

text {*
  Therefore, multi-step accessibility of a state by another one
  is equivalent to the existence of an input word and a
  finite execution linking the two states.
*}

theorem acc_star_iff_exec:
  "q - tbl \<rightarrow>\<^sup>* q'
   = (\<exists>inp run. nd_exec_fragment tbl inp run
                 \<and> run!0 = q \<and> run!(length inp) = q')"
by (blast intro: acc_star_exec exec_acc_star)

text {*
  As a corollary, establish reachability from infinite executions.
*}

lemma nd_execution_acc_star:
  assumes exe: "nd_execution tbl inp run"
  and leq: "i \<le> j"
  shows "(run i) - tbl \<rightarrow>\<^sup>* (run j)"
proof -
  let ?w = "map inp [i ..< j]" and ?rw = "map run [i ..< Suc j]"
  from exe leq have "nd_exec_fragment tbl ?w ?rw"
    by (rule nd_execution_sub)
  hence "(?rw ! 0) - tbl \<rightarrow>\<^sup>* (?rw ! length ?w)"
    by (rule exec_acc_star)
  moreover
  from leq have "?rw ! 0 = run i"
    by simp
  moreover
  from leq have "j-i < length [i ..< Suc j]"
    by simp
  with leq have "?rw ! (length ?w) = run j"
    by simp
  ultimately
  show ?thesis by simp
qed

text {*
  Multi-step reachability remains within state set.
*}

lemma acc_star_states:
  assumes acc: "q - tbl \<rightarrow>\<^sup>* q'" and q: "q \<in> states_of tbl"
  shows "q' \<in> states_of tbl"
using acc q proof (auto simp add: acc_star_iff_exec)
  fix inp run
  assume init: "run!0 \<in> states_of tbl" and exec: "nd_exec_fragment tbl inp run"
  from exec have "length inp < length run" ..
  with init exec show "run!(length inp) \<in> states_of tbl"
    by auto
qed

text {*
  Similar lemmas for the transitive closure.
*}

lemma acc_plus_exec:
  assumes acc: "q - tbl \<rightarrow>\<^sup>+ q'"
  shows "\<exists>inp run. nd_exec_fragment tbl inp run
                 \<and> run!0 = q \<and> run!(length inp) = q' \<and> 0 < length inp"
        (is "\<exists>inp run. ?exe inp run")
proof -
  from acc obtain q''
    where q: "q - tbl \<rightarrow> q''" and q': "q'' - tbl \<rightarrow>\<^sup>* q'"
    by (auto dest: tranclD)
  from q obtain a where "q'' \<in> trans tbl q a"
    by (auto simp add: one_step_def)
  hence a: "nd_exec_fragment tbl [a] [q,q'']" by auto
  from q' obtain inp run
    where run: "nd_exec_fragment tbl inp run"
      and run0: "run!0 = q''" and runn: "run!(length inp) = q'"
    by (blast dest: acc_star_exec)
  from a run run0
  have "nd_exec_fragment tbl ([a] @ inp) ([q,q''] @ (drop 1 run))"
    by (auto dest: exec_frag_append)
  moreover
  from run have "0 < length run"
    by (simp add: nd_exec_fragment_length)
  hence lrun: "length (q'' # (drop (Suc 0) run)) = length run"
    (is "length ?lhs = length ?rhs")
    by simp
  hence "q'' # (drop (Suc 0) run) = run"
  proof (rule nth_equalityI, clarify)
    fix i
    assume i: "i < length ?lhs"
    show "?lhs ! i = ?rhs ! i"
    proof (cases i)
      case 0
      with run0 show ?thesis by simp
    next
      fix n
      assume n: "i = Suc n"
      with i lrun show ?thesis by simp
    qed
  qed
  moreover note runn
  ultimately
  have "?exe (a # inp) (q # run)"
    by simp
  thus ?thesis by blast
qed

lemma exec_acc_plus:
  assumes run: "nd_exec_fragment tbl inp run"
  and len: "0 < length inp"
  shows "(run!0) - tbl \<rightarrow>\<^sup>+ (run ! length inp)"
proof -
  from len obtain k where k: "length inp = Suc k"
    by (auto simp add: gr0_conv_Suc)
  with run have fst: "(run!0) - tbl \<rightarrow> (run!1)"
    by (auto simp add: nd_exec_fragment_def one_step_def)
  from run k
  have "nd_exec_fragment tbl (drop 1 inp) (drop 1 run)"
    (is "nd_exec_fragment tbl ?dinp ?drun")
    by (auto elim: nd_exec_frag_drop)
  hence "(?drun!0) - tbl \<rightarrow>\<^sup>* (?drun ! length ?dinp)"
    by (rule exec_acc_star)
  with run k
  have "(run!1) - tbl \<rightarrow>\<^sup>* (run ! length inp)"
    by (simp add: nd_exec_fragment_length)
  with fst show ?thesis
    by (rule rtrancl_into_trancl2)
qed

theorem acc_plus_iff_exec:
  "q - tbl \<rightarrow>\<^sup>+ q'
   = (\<exists>inp run. nd_exec_fragment tbl inp run
                 \<and> run!0 = q \<and> run!(length inp) = q' \<and> 0 < length inp)"
by (blast intro: acc_plus_exec exec_acc_plus)

lemma nd_execution_acc_plus:
  assumes exe: "nd_execution tbl inp run"
  and lt: "i < j"
  shows "(run i) - tbl \<rightarrow>\<^sup>+ (run j)"
proof -
  let ?w = "map inp [i ..< j]" and ?rw = "map run [i ..< Suc j]"
  from lt have lenw: "0 < length ?w"
    by simp
  from exe lt have "nd_exec_fragment tbl ?w ?rw"
    by (auto elim: nd_execution_sub)
  with lenw have "(?rw ! 0) - tbl \<rightarrow>\<^sup>+ (?rw ! length ?w)"
    by (blast intro: exec_acc_plus)
  moreover
  from lt have "?rw ! 0 = run i"
    by simp
  moreover
  from lt have "j-i < length [i ..< Suc j]"
    by simp
  with lt have "?rw ! (length ?w) = run j"
    by simp
  ultimately
  show ?thesis by simp
qed

lemma acc_plus_states:
  assumes acc: "q - tbl \<rightarrow>\<^sup>+ q'" and q: "q \<in> states_of tbl"
  shows "q' \<in> states_of tbl"
using acc q proof (auto simp add: acc_plus_iff_exec)
  fix inp run
  assume init: "run!0 \<in> states_of tbl" and exec: "nd_exec_fragment tbl inp run"
  from exec have "length inp < length run" ..
  with init exec show "run!(length inp) \<in> states_of tbl"
    by auto
qed

subsection {* Run dags of transition tables *}

text {*
  The run dag for a transition table and an input word is an infinite
  dag over the automaton states as follows: the roots of the dag are
  the initial states, and the successors of a node $q$ at level $l$
  are the possible automaton successor states for $q$ and the
  $l$-th letter of the input word.
*}

definition
run_dag :: " [('q,'a,'b) ndtable_scheme, 'a word] \<Rightarrow> 'q dag"
 where
  "run_dag tbl inp \<equiv>
   \<lparr> roots = initial tbl,
     succs = \<lambda>(q,l). trans tbl q (inp l)
   \<rparr>"

text {*
  The paths in the dag for an automaton and an input word
  correspond precisely to the runs of the automaton over that input.
*}

theorem path_iff_run:
  "(run \<in> paths (run_dag tbl inp)) = nd_run tbl inp run"
by (auto simp add: paths_def paths_from_def run_dag_def)

lemma reachable_exec_fragment:
  assumes pos': "pos' \<in> reachable (run_dag tbl inp) pos"
  shows "\<exists>run. nd_exec_fragment tbl (map inp [snd pos ..< snd pos']) run
               \<and> hd run = fst pos \<and> run ! (snd pos' - snd pos) = fst pos'"
    (is "\<exists>run. ?exec run pos pos'")
using pos'
proof (induct)
  have "?exec [fst pos] pos pos" by auto
  thus "\<exists>run. ?exec run pos pos" ..
next
  fix nd pos''
  assume nd: "nd \<in> succs (run_dag tbl inp) pos''"
    and pos'': "pos'' \<in> reachable (run_dag tbl inp) pos"
    and ih: "\<exists>run. ?exec run pos pos''"
  from ih obtain run where run: "?exec run pos pos''" ..
  from pos'' have sndpos: "snd pos \<le> snd pos''"
    by (rule reachable_level)
  hence Sucsndpos: "Suc (snd pos'' - snd pos) = Suc (snd pos'') - snd pos"
    by arith
  let ?inp = "map inp [snd pos ..< snd pos'']"
  let ?inp' = "map inp [snd pos ..< Suc(snd pos'')]"
  have "?exec (run @ [nd]) pos (nd, Suc(snd pos''))"
  proof auto
    show "nd_exec_fragment tbl ?inp' (run @ [nd])"
    proof
      from run show "length (run @ [nd]) = Suc (length ?inp')"
	by (auto simp add: nd_exec_fragment_def Sucsndpos)
    next
      fix n
      assume n: "n < length ?inp'"
      show "(run @ [nd]) ! (Suc n) \<in> trans tbl ((run @ [nd])!n) (?inp' ! n)"
      proof (cases "n < length ?inp")
	case True
	with run sndpos show ?thesis
	  by (auto simp add: nd_exec_fragment_def nth_append upt_Suc_append)
      next
	case False
	with n sndpos have n': "n = snd pos'' - snd pos"
	  by simp
	with nd run sndpos show ?thesis
	  by (auto simp add: nd_exec_fragment_def run_dag_def
			     nth_append upt_Suc_append)
      qed
    qed
  next
    from run have "run \<noteq> []" by auto
    with run show "hd (run @ [nd]) = fst pos" by auto
  next
    from run show "(run @ [nd]) ! (Suc (snd pos'') - snd pos) = nd"
      by (auto simp add: nd_exec_fragment_def nth_append Sucsndpos)
  qed
  thus "\<exists>run. ?exec run pos (nd, Suc(snd pos''))" ..
qed

text {*
  Reachability is closed under positions corresponding to automaton
  states. Slices of the run dag are subsets of automaton states.
*}

lemma reachable_states_of [elim]:
  assumes pos': "pos' \<in> reachable (run_dag tbl inp) pos"
  and pos: "fst pos \<in> states_of tbl"
  shows "fst pos' \<in> states_of tbl"
using assms by (induct) (auto simp add: run_dag_def)

lemma reachable_states_of' [elim]:
  assumes q': "(q',lvl') \<in> reachable (run_dag tbl inp) (q,lvl)"
  and q: "q \<in> states_of tbl"
  shows "q' \<in> states_of tbl"
proof -
  from q have "fst (q,lvl) \<in> states_of tbl" by simp
  with q' have "fst (q',lvl') \<in> states_of tbl" by (rule reachable_states_of)
  thus ?thesis by simp
qed

lemma roots_states_of:
  "roots (run_dag tbl inp) \<subseteq> states_of tbl"
by (auto simp add: run_dag_def)

lemmas roots_states_ofE [elim] = roots_states_of[THEN subsetD]

lemma rch_positions_states_of [elim]:
  assumes pos: "pos \<in> rch_positions (run_dag tbl inp)"
  shows "fst pos \<in> states_of tbl"
using pos
proof
  fix rt
  assume rt: "rt \<in> roots (run_dag tbl inp)"
  and prt: "pos \<in> reachable (run_dag tbl inp) (rt, 0)"
  from rt have "fst (rt, 0) \<in> states_of tbl" by auto
  with prt show "fst pos \<in> states_of tbl" ..
qed

lemma rch_positions_states_of' [elim]:
  assumes q: "(q,lvl) \<in> rch_positions (run_dag tbl inp)"
  shows "q \<in> states_of tbl"
proof -
  from q have "fst (q,lvl) \<in> states_of tbl" ..
  thus ?thesis by simp
qed

lemma slice_states_of:
  "slice (run_dag tbl inp) n \<subseteq> states_of tbl"
by (auto simp add: slice_def)

lemmas slice_states_ofE [elim] = slice_states_of[THEN subsetD]

subsection {* Finite-state transition tables *}

text {*
  A table is finite-state iff its set of states, as defined by the
  @{text states_of} function, is finite. Observe that this function
  in general computes an approximation (superset) of the precise set
  of states. We have to pay this price for not including the precise
  set of states as a record component.

  We also study a somewhat weaker notion that only requires any run
  dag of the automaton to be of bounded width. That is, for any given
  input and at any given position of the input we can determine the
  automaton state at that position up to a bounded degree of
  uncertainty, although the automaton might still have infinitely
  many states overall. It turns out that many automaton constructions
  remain applicable under this weaker hypothesis.
*}

(*** OLD DEFINITIONS, TOO WEAK FOR COMPLEMENT
constdefs
  finite_state :: "('q,'a,'b) ndtable_scheme \<Rightarrow> bool"
  "finite_state tbl \<equiv>
   \<forall>inp run. nd_run tbl inp run \<longrightarrow> finite (range run)"

constdefs
  finite_state :: "('q,'a,'b) ndtable_scheme \<Rightarrow> bool"
  "finite_state tbl \<equiv> \<forall>inp. finite (fst ` (rch_positions (run_dag tbl inp)))"
***)

definition
  finite_state where (* :: "('q,'a,'b) ndtable_scheme \<Rightarrow> bool" *)
  "finite_state tbl \<equiv> finite (states_of tbl)"

definition
  bounded_nondet where (* :: "[('q,'a,'b) ndtable_scheme, nat] \<Rightarrow> bool" *)
  "bounded_nondet tbl n \<equiv>
   \<forall>inp lvl. finite (slice (run_dag tbl inp) lvl) \<and>
             card (slice (run_dag tbl inp) lvl) \<le> (n::nat)"

text {*
  In particular, the set of states that occur in any run of
  a finite-state automaton is finite.
*}

lemma finite_state_run:
  assumes fin: "finite_state tbl" and run: "nd_run tbl inp run"
  shows "finite (range run)"
proof (rule finite_subset)
  from run show "range run \<subseteq> states_of tbl"
    by auto
next
  from fin show "finite (states_of tbl)"
    by (unfold finite_state_def)
qed

lemma finite_state_finite_slice:
  assumes fin: "finite_state tbl"
  shows "finite (slice (run_dag tbl inp) l)"
proof (rule finite_subset)
  show "slice (run_dag tbl inp) l \<subseteq> states_of tbl"
    by (rule slice_states_of)
next
  from fin show "finite (states_of tbl)"
    by (unfold finite_state_def)
qed

lemma finite_state_card_slice:
  assumes fin: "finite_state tbl"
  shows "card (slice (run_dag tbl inp) lvl) \<le> card (states_of tbl)"
proof (rule card_mono)
  from fin show "finite (states_of tbl)"
    by (unfold finite_state_def)
next
  show "slice (run_dag tbl inp) lvl \<subseteq> states_of tbl"
    by (rule slice_states_of)
qed

lemma finite_state_bounded_nondet:
  assumes fin: "finite_state tbl"
  shows "bounded_nondet tbl (card (states_of tbl))"
using assms by (auto simp add: bounded_nondet_def finite_state_finite_slice finite_state_card_slice)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Order on Sets\<close>
theory Order_Set
  imports
    HOL_Basics.Functions_Monotone
    HOL.Orderings
    Subset
begin

unbundle no_HOL_ascii_syntax

instantiation set :: order
begin

definition le_set_def: "less_eq_set \<equiv> (\<subseteq>)"
definition lt_set_def: "less_set \<equiv> (\<subset>)"

lemma le_set_eq_subset [simp]: "(\<le>) = (\<subseteq>)" unfolding le_set_def by simp
lemma lt_set_eq_ssubset [simp]: "(<) = (\<subset>)" unfolding lt_set_def by simp

instance by (standard) auto

end

lemma mono_mem_of: "mono mem_of"
  by (intro monoI) auto

lemma le_boolD': "P \<le> Q \<Longrightarrow> P \<Longrightarrow> Q" by (rule le_boolE)

lemma le_boolD'': "P \<Longrightarrow> P \<le> Q \<Longrightarrow> Q" by (rule le_boolE)

end


theory prop_49
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun insert2 :: "Nat => Nat list => Nat list" where
  "insert2 x (Nil2) = Cons2 x (Nil2)"
  | "insert2 x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"
  fun isort :: "Nat list => Nat list" where
  "isort (Nil2) = Nil2"
  | "isort (Cons2 y xs) = insert2 y (isort xs)"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  (*hipster le insert2 isort equal2 elem *)

lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)
(*
hipster elem isort insert2 le equal2*)

(*hipster elem isort insert2 le equal2*)
lemma lemma_ac [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_ad [thy_expl]: "equal2 x2 Z = le x2 Z"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_ae [thy_expl]: "elem x26 (insert2 x26 y26) = True"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_af [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_ag [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_ah [thy_expl]: "elem (S x26) (insert2 x26 y26) = elem (S x26) y26"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_ai [thy_expl]: "insert2 Z (isort x3) = isort (insert2 Z x3)"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_aj [thy_expl]: "elem (S x4) (insert2 Z y4) = elem (S x4) y4"
by (hipster_induct_schemes elem.simps isort.simps insert2.simps le.simps equal2.simps)

lemma lemma_ak [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_al [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_am [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

(*hipster_cond le*)
lemma lemma_an [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ao [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ap [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma le_trans [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)

(*lemma nole []: "\<not> le r s \<Longrightarrow> le s r"
by (hipster_induct_schemes le.simps Nat.exhaust)*)

lemma lemma_aq [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ar [thy_expl]: "insert2 x (insert2 y z) = insert2 y (insert2 x z)"
oops (*by (hipster_induct_schemes sorted.simps isort.simps insert2.simps le.simps)*)

lemma lemma_as [thy_expl]: "isort (insert2 x y) = insert2 x (isort y)"
oops (*by (hipster_induct_schemes sorted.simps isort.simps insert2.simps le.simps)*)

lemma lemma_at [thy_expl]: "isort (isort x19) = isort x19"
oops
(*hipster_cond elem isort equal2 le*)
lemma lemma_au [thy_expl]: "elem x17 z17 \<Longrightarrow> elem x17 (insert2 y17 z17) = True"
by (hipster_induct_schemes elem.simps isort.simps equal2.simps le.simps)

lemma lemma_av [thy_expl]: "elem y35 z35 \<Longrightarrow> elem x35 (insert2 y35 z35) = elem x35 z35"
by (hipster_induct_schemes elem.simps isort.simps equal2.simps le.simps)

lemma lemma_aw [thy_expl]: "elem x21 y21 \<Longrightarrow> elem x21 (isort y21) = True"
by (hipster_induct_schemes elem.simps isort.simps equal2.simps le.simps)

(*hipster_cond le  equal2 isort elem insert2*)
lemma lemma_ax [thy_expl]: "le y26 x26 \<Longrightarrow> elem (S x26) (insert2 y26 z26) = elem (S x26) z26"
by (hipster_induct_schemes le.simps equal2.simps isort.simps elem.simps insert2.simps)

lemma missing  : "elem x (insert2 y z) = elem x (Cons2 y z)"
by (hipster_induct_schemes elem.simps isort.simps equal2.simps le.simps)

lemma unknown [thy_expl]: "elem x (isort y) = elem x y"
by (hipster_induct_schemes missing le.simps equal2.simps isort.simps elem.simps insert2.simps)

  theorem x0 :
    "(elem x (isort y)) ==> (elem x y)"
    by (hipster_induct_schemes sorted.simps isort.simps insert2.simps le.simps equal2.simps Nat.exhaust)

end


(*  Title:       An Efficient Generalization of Counting Sort for Large, possibly Infinite Key Ranges
    Author:      Pasquale Noce
                 Software Engineer at HID Global, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at hidglobal dot com
*)

section "Proof of algorithm's stability"

theory Stability
  imports Sorting
begin

text \<open>
\null

In this section, it is formally proven that GCsort is \emph{stable}, viz. that the sublist of the
output of function @{const gcsort} built by picking out the objects having a given key matches the
sublist of the input objects' list built in the same way.

Here below, steps 5, 6, and 7 of the proof method are accomplished. Particularly, @{text stab_inv}
is the predicate that will be shown to be invariant over inductive set @{const gcsort_set}.

\null
\<close>

fun stab_inv :: "('b \<Rightarrow> 'a list) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> nat \<times> nat list \<times> 'a list \<Rightarrow>
  bool" where
"stab_inv f key (u, ns, xs) = (\<forall>k. [x\<leftarrow>xs. key x = k] = f k)"

lemma gcsort_stab_input:
 "stab_inv (\<lambda>k. [x\<leftarrow>xs. key x = k]) key (0, [length xs], xs)"
by simp

lemma gcsort_stab_intro:
 "stab_inv f key t \<Longrightarrow> [x\<leftarrow>gcsort_out t. key x = k] = f k"
by (cases t, simp add: gcsort_out_def)

text \<open>
\null

In what follows, step 9 of the proof method is accomplished.

First, lemma @{text fill_offs_enum_stable} proves that function @{const fill}, if its input offsets'
list is computed via the composition of functions @{const offs} and @{const enum}, does not modify
the sublist of its input objects' list formed by the objects having a given key. Moreover, lemmas
@{text mini_stable} and @{text maxi_stable} prove that the extraction of the leftmost minimum and
the rightmost maximum from an objects' list through functions @{const mini} and @{const maxi} is
endowed with the same property.

These lemmas are then used to prove lemma @{text gcsort_stab_inv}, which states that the sublist of
the objects having a given key within the objects' list is still the same after any recursive round.

\null
\<close>

lemma fill_stable [rule_format]:
  assumes
    A: "index_less index key" and
    B: "index_same index key"
  shows
   "(\<forall>x \<in> set xs. key x \<in> {mi..ma}) \<longrightarrow>
    ns \<noteq> [] \<longrightarrow>
    offs_pred ns ub xs index key mi ma \<longrightarrow>
      map the [w\<leftarrow>fill xs ns index key ub mi ma. \<exists>x. w = Some x \<and> key x = k] =
        [x\<leftarrow>xs. k = key x]"
proof (induction xs arbitrary: ns, simp_all add: Let_def, rule conjI,
 (rule_tac [!] impI)+, (erule_tac [!] conjE)+, simp_all)
  fix x xs and ns :: "nat list"
  let ?i = "index key x (length ns) mi ma"
  let ?ns' = "ns[?i := Suc (ns ! ?i)]"
  let ?ws = "[w\<leftarrow>fill xs ?ns' index key ub mi ma.
    \<exists>y. w = Some y \<and> key y = key x]"
  let ?ws' = "[w\<leftarrow>(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x].
    \<exists>y. w = Some y \<and> key y = key x]"
  assume
    C: "\<forall>x \<in> set xs. mi \<le> key x \<and> key x \<le> ma" and
    D: "mi \<le> key x" and
    E: "key x \<le> ma" and
    F: "ns \<noteq> []" and
    G: "offs_pred ns ub (x # xs) index key mi ma"
  have H: "?i < length ns"
    using A and D and E and F by (simp add: index_less_def)
  assume "\<And>ns. ns \<noteq> [] \<longrightarrow> offs_pred ns ub xs index key mi ma \<longrightarrow>
    map the [w\<leftarrow>fill xs ns index key ub mi ma.
      \<exists>y. w = Some y \<and> key y = key x] =
    [y\<leftarrow>xs. key x = key y]"
  moreover have I: "offs_pred ?ns' ub xs index key mi ma"
    using G and H by (rule_tac offs_pred_cons, simp_all)
  ultimately have J: "map the ?ws = [y\<leftarrow>xs. key x = key y]"
    using F by simp
  have "ns ! ?i + offs_num (length ns) (x # xs) index key mi ma ?i \<le> ub"
    using G and H by (rule offs_pred_ub, simp add: offs_num_cons)
  hence K: "ns ! ?i < ub"
    by (simp add: offs_num_cons)
  moreover from this have
    L: "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] ! (ns ! ?i) = Some x"
    by (subst nth_list_update_eq, simp_all add: fill_length)
  ultimately have "0 < length ?ws'"
    by (simp add: length_filter_conv_card card_gt_0_iff,
     rule_tac exI [where x = "ns ! ?i"], simp add: fill_length)
  hence "\<exists>w ws. ?ws' = w # ws"
    by (rule_tac list.exhaust [of ?ws'], simp_all)
  then obtain w and ws where "?ws' = w # ws" by blast
  hence "\<exists>us vs y.
    (fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] = us @ w # vs \<and>
    (\<forall>u \<in> set us. \<forall>y. u = Some y \<longrightarrow> key y \<noteq> key x) \<and>
    w = Some y \<and> key y = key x \<and>
    ws = [w\<leftarrow>vs. \<exists>y. w = Some y \<and> key y = key x]"
    (is "\<exists>us vs y. ?P us vs y")
    by (simp add: filter_eq_Cons_iff, blast)
  then obtain us and vs and y where M: "?P us vs y" by blast
  let ?A = "{i. i < length ns \<and> 0 < offs_num (length ns) xs index key mi ma i \<and>
    ns ! i \<le> length us}"
  have "length us = ns ! ?i"
  proof (rule ccontr, erule neqE, cases "?A = {}",
   cases "0 < offs_num (length ns) xs index key mi ma 0", simp_all only: not_gr0)
    assume
      N: "length us < ns ! ?i" and
      O: "?A = {}" and
      P: "0 < offs_num (length ns) xs index key mi ma 0"
    have "length us < ns ! 0"
    proof (rule ccontr, simp add: not_less)
      assume "ns ! 0 \<le> length us"
      with F and P have "0 \<in> ?A" by simp
      with O show False by blast
    qed
    hence "length us < ?ns' ! 0"
      using F by (cases ?i, simp_all)
    hence "offs_none ?ns' ub xs index key mi ma (length us)"
      using P by (simp add: offs_none_def)
    hence "fill xs ?ns' index key ub mi ma ! (length us) = None"
      using C and F and I by (rule_tac fill_none [OF A], simp_all)
    hence "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] ! (length us) = None"
      using N by simp
    thus False
      using M by simp
  next
    assume
      N: "length us < ns ! ?i" and
      O: "?A = {}" and
      P: "offs_num (length ns) xs index key mi ma 0 = 0"
    from K and N have "length us < offs_next ?ns' ub xs index key mi ma 0"
    proof (rule_tac ccontr, simp only: not_less offs_next_def split: if_split_asm)
      assume "offs_set_next ?ns' xs index key mi ma 0 \<noteq> {}"
        (is "?B \<noteq> _")
      hence "Min ?B \<in> ?B"
        by (rule_tac Min_in, simp)
      moreover assume "?ns' ! Min ?B \<le> length us"
      hence "ns ! Min ?B \<le> length us"
        using H by (cases "Min ?B = ?i", simp_all)
      ultimately have "Min ?B \<in> ?A" by simp
      with O show False by blast
    qed
    hence "offs_none ?ns' ub xs index key mi ma (length us)"
      using P by (simp add: offs_none_def)
    hence "fill xs ?ns' index key ub mi ma ! (length us) = None"
      using C and F and I by (rule_tac fill_none [OF A], simp_all)
    hence "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] ! (length us) = None"
      using N by simp
    thus False
      using M by simp
  next
    assume N: "length us < ns ! ?i"
    assume "?A \<noteq> {}"
    hence "Max ?A \<in> ?A"
      by (rule_tac Max_in, simp)
    moreover from this have O: "Max ?A \<noteq> ?i"
      using N by (rule_tac notI, simp)
    ultimately have "index key y (length ?ns') mi ma = Max ?A"
    using C proof (rule_tac fill_index [OF A _ I, where j = "length us"], simp_all,
     rule_tac ccontr, simp only: not_less not_le offs_next_def split: if_split_asm)
      assume "ub \<le> length us"
      with N have "ub < ns ! ?i" by simp
      with K show False by simp
    next
      let ?B = "offs_set_next ?ns' xs index key mi ma (Max ?A)"
      assume "?ns' ! Min ?B \<le> length us"
      hence "ns ! Min ?B \<le> length us"
        using H by (cases "Min ?B = ?i", simp_all)
      moreover assume "?B \<noteq> {}"
      hence P: "Min ?B \<in> ?B"
        by (rule_tac Min_in, simp)
      ultimately have "Min ?B \<in> ?A" by simp
      hence "Min ?B \<le> Max ?A"
        by (rule_tac Max_ge, simp)
      thus False
        using P by simp
    next
      have "fill xs ?ns' index key ub mi ma ! length us =
        (fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] ! length us"
        using N by simp
      thus "fill xs ?ns' index key ub mi ma ! length us = Some y"
        using M by simp
    qed
    moreover have "index key y (length ?ns') mi ma = ?i"
      using B and D and E and M by (cases "y = x", simp_all add:
       index_same_def)
    ultimately show False
      using O by simp
  next
    assume N: "ns ! ?i < length us"
    hence "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] ! (ns ! ?i) =
      us ! (ns ! ?i)"
      using M by (simp add: nth_append)
    hence "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] ! (ns ! ?i) \<in> set us"
      using N by simp
    thus False
      using L and M by blast
  qed
  hence "take (ns ! ?i) ((fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x]) = us"
    using M by simp
  hence N: "take (ns ! ?i) (fill xs ?ns' index key ub mi ma) = us" by simp
  have "fill xs ?ns' index key ub mi ma =
    take (ns ! ?i) (fill xs ?ns' index key ub mi ma) @
    fill xs ?ns' index key ub mi ma ! (ns ! ?i) #
    drop (Suc (ns ! ?i)) (fill xs ?ns' index key ub mi ma)"
    (is "_ = ?ts @ _ # ?ds")
    using K by (rule_tac id_take_nth_drop, simp add: fill_length)
  moreover have "fill xs ?ns' index key ub mi ma ! (ns ! ?i) = None"
    using C and D and E and F and G by (rule_tac fill_index_none [OF A],
     simp_all)
  ultimately have O: "fill xs ?ns' index key ub mi ma = us @ None # ?ds"
    using N by simp
  have "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] =
    ?ts @ Some x # ?ds"
    using K by (rule_tac upd_conv_take_nth_drop, simp add: fill_length)
  hence "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] =
    us @ Some x # ?ds"
    using N by simp
  hence "?ws' = Some x # [w\<leftarrow>?ds. \<exists>y. w = Some y \<and> key y = key x]"
    using M by simp
  also have "\<dots> = Some x # ?ws"
    using M by (subst (2) O, simp)
  finally show "map the ?ws' = x # [y\<leftarrow>xs. key x = key y]"
    using J by simp
next
  fix x xs and ns :: "nat list"
  let ?i = "index key x (length ns) mi ma"
  let ?ns' = "ns[?i := Suc (ns ! ?i)]"
  let ?ws = "[w\<leftarrow>fill xs ?ns' index key ub mi ma. \<exists>y. w = Some y \<and> key y = k]"
  let ?ws' = "[w\<leftarrow>(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x].
    \<exists>y. w = Some y \<and> key y = k]"
  assume
    C: "\<forall>x \<in> set xs. mi \<le> key x \<and> key x \<le> ma" and
    D: "mi \<le> key x" and
    E: "key x \<le> ma" and
    F: "ns \<noteq> []" and
    G: "offs_pred ns ub (x # xs) index key mi ma" and
    H: "k \<noteq> key x"
  have I: "?i < length ns"
    using A and D and E and F by (simp add: index_less_def)
  assume "\<And>ns. ns \<noteq> [] \<longrightarrow> offs_pred ns ub xs index key mi ma \<longrightarrow>
    map the [w\<leftarrow>fill xs ns index key ub mi ma.
      \<exists>y. w = Some y \<and> key y = k] =
    [y\<leftarrow>xs. k = key y]"
  moreover have "offs_pred ?ns' ub xs index key mi ma"
    using G and I by (rule_tac offs_pred_cons, simp_all)
  ultimately have J: "map the ?ws = [y\<leftarrow>xs. k = key y]"
    using F by simp
  have "ns ! ?i + offs_num (length ns) (x # xs) index key mi ma ?i \<le> ub"
    using G and I by (rule offs_pred_ub, simp add: offs_num_cons)
  hence K: "ns ! ?i < ub"
    by (simp add: offs_num_cons)
  have "fill xs ?ns' index key ub mi ma =
    take (ns ! ?i) (fill xs ?ns' index key ub mi ma) @
    fill xs ?ns' index key ub mi ma ! (ns ! ?i) #
    drop (Suc (ns ! ?i)) (fill xs ?ns' index key ub mi ma)"
    (is "_ = ?ts @ _ # ?ds")
    using K by (rule_tac id_take_nth_drop, simp add: fill_length)
  moreover have "fill xs ?ns' index key ub mi ma ! (ns ! ?i) = None"
    using C and D and E and F and G by (rule_tac fill_index_none [OF A],
     simp_all)
  ultimately have L: "fill xs ?ns' index key ub mi ma = ?ts @ None # ?ds"
    by simp
  have "(fill xs ?ns' index key ub mi ma)[ns ! ?i := Some x] =
    ?ts @ Some x # ?ds"
    using K by (rule_tac upd_conv_take_nth_drop, simp add: fill_length)
  moreover have "?ws = [w\<leftarrow>?ts. \<exists>y. w = Some y \<and> key y = k] @
    [w\<leftarrow>?ds. \<exists>y. w = Some y \<and> key y = k]"
    by (subst L, simp)
  ultimately have "?ws' = ?ws"
    using H by simp
  thus "map the ?ws' = [y\<leftarrow>xs. k = key y]"
    using J by simp
qed

lemma fill_offs_enum_stable [rule_format]:
  assumes
    A: "index_less index key" and
    B: "index_same index key"
  shows
   "\<forall>x \<in> set xs. key x \<in> {mi..ma} \<Longrightarrow>
    0 < n \<Longrightarrow>
      [x\<leftarrow>map the (fill xs (offs (enum xs index key n mi ma) 0)
        index key (length xs) mi ma). key x = k] = [x\<leftarrow>xs. k = key x]"
  (is "_ \<Longrightarrow> _ \<Longrightarrow> [_\<leftarrow>map the ?ys. _] = _"
   is "_ \<Longrightarrow> _ \<Longrightarrow> [_\<leftarrow>map the (fill _ ?ns _ _ _ _ _). _] = _")
proof (subst fill_stable [symmetric, OF A B, of xs mi ma ?ns], simp,
 simp only: length_greater_0_conv [symmetric] offs_length enum_length,
 rule offs_enum_pred [OF A], simp, subst filter_map,
 simp add: filter_eq_nths fill_length)
  assume
    C: "\<forall>x \<in> set xs. mi \<le> key x \<and> key x \<le> ma" and
    D: "0 < n"
  have "{i. i < length xs \<and> key (the (?ys ! i)) = k} =
    {i. i < length xs \<and> (\<exists>x. ?ys ! i = Some x \<and> key x = k)}"
    (is "?A = ?B")
  proof (rule set_eqI, rule iffI, simp_all, erule_tac [!] conjE, erule_tac [2] exE,
   erule_tac [2] conjE, simp_all)
    fix i
    assume E: "i < length xs" and F: "key (the (?ys ! i)) = k"
    have "\<exists>x. ?ys ! i = Some x"
    proof (cases "?ys ! i", simp_all)
      assume "?ys ! i = None"
      moreover have "?ys ! i \<in> set ?ys"
        using E by (rule_tac nth_mem, simp add: fill_length)
      ultimately have "None \<in> set ?ys" by simp
      moreover have "count (mset ?ys) None = 0"
        using C and D by (rule_tac fill_offs_enum_count_none [OF A], simp)
      ultimately show False by simp
    qed
    then obtain x where "?ys ! i = Some x" ..
    moreover from this have "key x = k"
      using F by simp
    ultimately show "\<exists>x. ?ys ! i = Some x \<and> key x = k" by simp
  qed
  thus "map the (nths ?ys ?A) = map the (nths ?ys ?B)" by simp
qed

lemma mini_first [rule_format]:
 "xs \<noteq> [] \<longrightarrow> i < mini xs key \<longrightarrow>
    key (xs ! mini xs key) < key (xs ! i)"
by (induction xs arbitrary: i, simp_all add: Let_def, (rule impI)+,
 erule conjE, simp add: not_le nth_Cons split: nat.split)

lemma maxi_last [rule_format]:
 "xs \<noteq> [] \<longrightarrow> maxi xs key < i \<longrightarrow> i < length xs \<longrightarrow>
    key (xs ! i) < key (xs ! maxi xs key)"
by (induction xs arbitrary: i, simp_all add: Let_def, (rule impI)+,
 rule le_less_trans, rule maxi_ub, rule nth_mem, simp)

lemma nths_range:
 "nths xs A = nths xs (A \<inter> {..<length xs})"
proof (induction xs arbitrary: A, simp_all add: nths_Cons)
  fix xs :: "'a list" and A
  assume "\<And>A. nths xs A = nths xs (A \<inter> {..<length xs})"
  hence "nths xs {i. Suc i \<in> A} = nths xs ({i. Suc i \<in> A} \<inter> {..<length xs})" .
  moreover have
   "{i. Suc i \<in> A} \<inter> {..<length xs} = {i. Suc i \<in> A \<and> i < length xs}"
    by blast
  ultimately show
   "nths xs {i. Suc i \<in> A} = nths xs {i. Suc i \<in> A \<and> i < length xs}"
    by simp
qed

lemma filter_nths_diff:
  assumes
    A: "i < length xs" and
    B: "\<not> P (xs ! i)"
  shows "[x\<leftarrow>nths xs (A - {i}). P x] = [x\<leftarrow>nths xs A. P x]"
proof (cases "i \<in> A", simp_all)
  case True
  have C: "xs = take i xs @ xs ! i # drop (Suc i) xs"
    (is "_ = ?ts @ _ # ?ds")
    using A by (rule id_take_nth_drop)
  have "nths xs A = nths ?ts A @ nths (xs ! i # ?ds) {j. j + length ?ts \<in> A}"
    by (subst C, simp add: nths_append)
  moreover have D: "length ?ts = i"
    using A by simp
  ultimately have E: "nths xs A = nths ?ts (A \<inter> {..<i}) @ xs ! i #
    nths ?ds {j. Suc j + i \<in> A}"
    (is "_ = ?vs @ _ # ?ws")
    using True by (simp add: nths_Cons, subst nths_range, simp)
  have "nths xs (A - {i}) = nths ?ts (A - {i}) @
    nths (xs ! i # ?ds) {j. j + length ?ts \<in> A - {i}}"
    by (subst C, simp add: nths_append)
  moreover have "(A - {i}) \<inter> {..<i} = A \<inter> {..<i}"
    by (rule set_eqI, rule iffI, simp_all)
  ultimately have "nths xs (A - {i}) = ?vs @ ?ws"
    using D by (simp add: nths_Cons, subst nths_range, simp)
  thus ?thesis
    using B and E by simp
qed

lemma mini_stable:
  assumes
    A: "xs \<noteq> []" and
    B: "mini xs key \<in> A"
      (is "?nmi \<in> _")
  shows "[x\<leftarrow>[xs ! ?nmi] @ nths xs (A - {?nmi}). key x = k] =
    [x\<leftarrow>nths xs A. key x = k]"
    (is "[x\<leftarrow>[?xmi] @ _. _] = _")
proof (simp, rule conjI, rule_tac [!] impI, rule_tac [2] filter_nths_diff,
 rule_tac [2] mini_less, simp_all add: A)
  assume C: "key ?xmi = k"
  moreover have "?nmi < length xs"
    using A by (rule_tac mini_less, simp)
  ultimately have "0 < length [x\<leftarrow>xs. key x = k]"
    by (simp add: length_filter_conv_card card_gt_0_iff, rule_tac exI, rule_tac conjI)
  hence "\<exists>y ys. [x\<leftarrow>xs. key x = k] = y # ys"
    by (rule_tac list.exhaust [of "[x\<leftarrow>xs. key x = k]"], simp_all)
  then obtain y and ys where "[x\<leftarrow>xs. key x = k] = y # ys" by blast
  hence "\<exists>us vs. xs = us @ y # vs \<and>
    (\<forall>u \<in> set us. key u \<noteq> k) \<and> key y = k \<and> ys = [x\<leftarrow>vs. key x = k]"
    (is "\<exists>us vs. ?P us vs")
    by (simp add: filter_eq_Cons_iff)
  then obtain us and vs where D: "?P us vs" by blast
  have E: "length us = ?nmi"
  proof (rule ccontr, erule neqE)
    assume "length us < ?nmi"
    with A have "key ?xmi < key (xs ! length us)"
      by (rule mini_first)
    also have "\<dots> = k"
      using D by simp
    finally show False
      using C by simp
  next
    assume F: "?nmi < length us"
    hence "?xmi = us ! ?nmi"
      using D by (simp add: nth_append)
    hence "?xmi \<in> set us"
      using F by simp
    thus False
      using C and D by simp
  qed
  moreover have "xs ! length us = y"
    using D by simp
  ultimately have F: "?xmi = y" by simp
  have "nths xs A = nths us A @ nths (y # vs) {i. i + ?nmi \<in> A}"
    using D and E by (simp add: nths_append)
  also have "\<dots> = nths us A @ y # nths vs {i. Suc i + ?nmi \<in> A}"
    (is "_ = _ @ _ # ?ws")
    using B by (simp add: nths_Cons)
  finally have G: "[x\<leftarrow>nths xs A. key x = k] = y # [x\<leftarrow>?ws. key x = k]"
    using D by (simp add: filter_empty_conv, rule_tac ballI,
     drule_tac in_set_nthsD, simp)
  have "nths xs (A - {?nmi}) = nths us (A - {?nmi}) @
    nths (y # vs) {i. i + ?nmi \<in> A - {?nmi}}"
    using D and E by (simp add: nths_append)
  also have "\<dots> = nths us (A - {?nmi}) @ ?ws"
    by (simp add: nths_Cons)
  finally have H: "[x\<leftarrow>nths xs (A - {?nmi}). key x = k] = [x\<leftarrow>?ws. key x = k]"
    using D by (simp add: filter_empty_conv, rule_tac ballI,
     drule_tac in_set_nthsD, simp)
  show "?xmi # [x\<leftarrow>nths xs (A - {?nmi}). key x = k] =
    [x\<leftarrow>nths xs A. key x = k]"
    using F and G and H by simp
qed

lemma maxi_stable:
  assumes
    A: "xs \<noteq> []" and
    B: "maxi xs key \<in> A"
      (is "?nma \<in> _")
  shows "[x\<leftarrow>nths xs (A - {?nma}) @ [xs ! ?nma]. key x = k] =
    [x\<leftarrow>nths xs A. key x = k]"
    (is "[x\<leftarrow>_ @ [?xma]. _] = _")
proof (simp, rule conjI, rule_tac [!] impI, rule_tac [2] filter_nths_diff,
 rule_tac [2] maxi_less, simp_all add: A)
  assume C: "key ?xma = k"
  moreover have D: "?nma < length xs"
    using A by (rule_tac maxi_less, simp)
  ultimately have "0 < length [x\<leftarrow>rev xs. key x = k]"
    by (simp add: length_filter_conv_card card_gt_0_iff,
     rule_tac exI [where x = "length xs - Suc ?nma"], simp add: rev_nth)
  hence "\<exists>y ys. [x\<leftarrow>rev xs. key x = k] = y # ys"
    by (rule_tac list.exhaust [of "[x\<leftarrow>rev xs. key x = k]"], simp_all)
  then obtain y and ys where "[x\<leftarrow>rev xs. key x = k] = y # ys" by blast
  hence "\<exists>us vs. rev xs = us @ y # vs \<and>
    (\<forall>u \<in> set us. key u \<noteq> k) \<and> key y = k \<and> ys = [x\<leftarrow>vs. key x = k]"
    (is "\<exists>us vs. ?P us vs")
    by (simp add: filter_eq_Cons_iff)
  then obtain us and vs where E: "?P us vs" by blast
  hence F: "xs = rev vs @ y # rev us"
    by (simp add: rev_swap)
  have G: "length us = length xs - Suc ?nma"
  proof (rule ccontr, erule neqE)
    assume "length us < length xs - Suc ?nma"
    hence "?nma < length xs - Suc (length us)" by simp
    moreover have "length xs - Suc (length us) < length xs"
      using D by simp
    ultimately have "key (xs ! (length xs - Suc (length us))) < key ?xma"
      by (rule maxi_last [OF A])
    moreover have "length us < length xs"
      using F by simp
    ultimately have "key (rev xs ! length us) < key ?xma"
      by (simp add: rev_nth)
    moreover have "key (rev xs ! length us) = k"
      using E by simp
    ultimately show False
      using C by simp
  next
    assume H: "length xs - Suc ?nma < length us"
    hence "rev xs ! (length xs - Suc ?nma) = us ! (length xs - Suc ?nma)"
      using E by (simp add: nth_append)
    hence "rev xs ! (length xs - Suc ?nma) \<in> set us"
      using H by simp
    hence "?xma \<in> set us"
      using D by (simp add: rev_nth)
    thus False
      using C and E by simp
  qed
  moreover have "rev xs ! length us = y"
    using E by simp
  ultimately have H: "?xma = y"
    using D by (simp add: rev_nth)
  have "length xs = length us + Suc ?nma"
    using D and G by simp
  hence I: "length vs = ?nma"
    using F by simp
  hence "nths xs A = nths (rev vs) A @ nths (y # rev us) {i. i + ?nma \<in> A}"
    using F by (simp add: nths_append)
  also have "\<dots> = nths (rev vs) (A \<inter> {..<?nma}) @ y #
    nths (rev us) {i. Suc i + ?nma \<in> A}"
    (is "_ = ?ws @ _ # _")
    using B and I by (simp add: nths_Cons, subst nths_range, simp)
  finally have J: "[x\<leftarrow>nths xs A. key x = k] = [x\<leftarrow>?ws. key x = k] @ [y]"
    using E by (simp add: filter_empty_conv, rule_tac ballI,
     drule_tac in_set_nthsD, simp)
  have "nths xs (A - {?nma}) = nths (rev vs) (A - {?nma}) @
    nths (y # rev us) {i. i + ?nma \<in> A - {?nma}}"
    using F and I by (simp add: nths_append)
  hence "nths xs (A - {?nma}) = nths (rev vs) ((A - {?nma}) \<inter> {..<?nma}) @
    nths (rev us) {i. Suc i + ?nma \<in> A}"
    using I by (simp add: nths_Cons, subst nths_range, simp)
  moreover have "(A - {?nma}) \<inter> {..<?nma} = A \<inter> {..<?nma}"
    by (rule set_eqI, rule iffI, simp_all)
  ultimately have K: "[x\<leftarrow>nths xs (A - {?nma}). key x = k] =
    [x\<leftarrow>?ws. key x = k]"
    using E by (simp add: filter_empty_conv, rule_tac ballI,
     drule_tac in_set_nthsD, simp)
  show "[x\<leftarrow>nths xs (A - {?nma}). key x = k] @ [?xma] =
    [x\<leftarrow>nths xs A. key x = k]"
    using H and J and K by simp
qed

lemma round_stab_inv [rule_format]:
 "index_less index key \<longrightarrow> index_same index key \<longrightarrow> bn_inv p q t \<longrightarrow>
    add_inv n t \<longrightarrow> stab_inv f key t \<longrightarrow> stab_inv f key (round index key p q r t)"
proof (induction index key p q r t arbitrary: n f rule: round.induct,
 (rule_tac [!] impI)+, simp, simp, simp_all only: simp_thms)
  fix index p q r u ns xs n f and key :: "'a \<Rightarrow> 'b"
  let ?t = "round index key p q r (u, ns, tl xs)"
  assume
   "\<And>n f. bn_inv p q (u, ns, tl xs) \<longrightarrow> add_inv n (u, ns, tl xs) \<longrightarrow>
      stab_inv f key (u, ns, tl xs) \<longrightarrow> stab_inv f key ?t" and
   "bn_inv p q (u, Suc 0 # ns, xs)" and
   "add_inv n (u, Suc 0 # ns, xs)" and
   "stab_inv f key (u, Suc 0 # ns, xs)"
  thus "stab_inv f key (round index key p q r (u, Suc 0 # ns, xs))"
  proof (cases ?t, cases xs, simp_all add: add_suc, arith, erule_tac conjE,
   rule_tac allI, simp)
    fix k y ys xs'
    let ?f' = "f(key y := tl (f (key y)))"
    assume "\<And>n' f'. foldl (+) 0 ns = n' \<and> length ys = n' \<longrightarrow>
      (\<forall>k'. [x\<leftarrow>ys. key x = k'] = f' k') \<longrightarrow> (\<forall>k'. [x\<leftarrow>xs'. key x = k'] = f' k')"
    moreover assume "Suc (foldl (+) 0 ns) = n" and "Suc (length ys) = n"
    ultimately have "(\<forall>k'. [x\<leftarrow>ys. key x = k'] = ?f' k') \<longrightarrow>
      (\<forall>k'. [x\<leftarrow>xs'. key x = k'] = ?f' k')"
      by blast
    moreover assume A: "\<forall>k'. (if key y = k'
      then y # [x\<leftarrow>ys. key x = k'] else [x\<leftarrow>ys. key x = k']) = f k'"
    hence B: "f (key y) = y # [x\<leftarrow>ys. key x = key y]"
      by (drule_tac spec [where x = "key y"], simp)
    hence "\<forall>k'. [x\<leftarrow>ys. key x = k'] = ?f' k'"
    proof (rule_tac allI, simp, rule_tac impI)
      fix k'
      assume "k' \<noteq> key y"
      thus "[x\<leftarrow>ys. key x = k'] = f k'"
        using A by (drule_tac spec [where x = k'], simp)
    qed
    ultimately have C: "\<forall>k'. [x\<leftarrow>xs'. key x = k'] = ?f' k'" ..
    show "(key y = k \<longrightarrow> y # [x\<leftarrow>xs'. key x = k] = f k) \<and>
      (key y \<noteq> k \<longrightarrow> [x\<leftarrow>xs'. key x = k] = f k)"
    proof (rule conjI, rule_tac [!] impI)
      assume "key y = k"
      moreover have "tl (f (key y)) = [x\<leftarrow>xs'. key x = key y]"
        using C by simp
      hence "f (key y) = y # [x\<leftarrow>xs'. key x = key y]"
        using B by (subst hd_Cons_tl [symmetric], simp_all)
      ultimately show "y # [x\<leftarrow>xs'. key x = k] = f k" by simp
    next
      assume "key y \<noteq> k"
      thus "[x\<leftarrow>xs'. key x = k] = f k"
        using C by simp
    qed
  qed
next
  fix index p q r u m ns n f and key :: "'a \<Rightarrow> 'b" and xs :: "'a list"
  let ?ws = "take (Suc (Suc m)) xs"
  let ?ys = "drop (Suc (Suc m)) xs"
  let ?r = "\<lambda>m'. round_suc_suc index key ?ws m m' u"
  let ?t = "\<lambda>r' v. round index key p q r' (v, ns, ?ys)"
  assume
    A: "index_less index key" and
    B: "index_same index key"
  assume
   "\<And>ws a b c d e g h i n f.
      ws = ?ws \<Longrightarrow> a = bn_comp m p q r \<Longrightarrow> (b, c) = bn_comp m p q r \<Longrightarrow>
      d = ?r b \<Longrightarrow> (e, g) = ?r b \<Longrightarrow> (h, i) = g \<Longrightarrow>
        bn_inv p q (e, ns, ?ys) \<longrightarrow> add_inv n (e, ns, ?ys) \<longrightarrow>
          stab_inv f key (e, ns, ?ys) \<longrightarrow> stab_inv f key (?t c e)" and
   "bn_inv p q (u, Suc (Suc m) # ns, xs)" and
   "add_inv n (u, Suc (Suc m) # ns, xs)" and
   "stab_inv f key (u, Suc (Suc m) # ns, xs)"
  thus "stab_inv f key (round index key p q r (u, Suc (Suc m) # ns, xs))"
  proof (simp split: prod.split, ((rule_tac allI)+, ((rule_tac impI)+)?)+,
   (erule_tac conjE)+, subst (asm) (2) add_base_zero, simp)
    fix m' r' v ms' ws' xs' k
    let ?f = "\<lambda>k. [x\<leftarrow>?ys. key x = k]"
    let ?P = "\<lambda>f. \<forall>k. [x\<leftarrow>?ys. key x = k] = f k"
    let ?Q = "\<lambda>f. \<forall>k. [x\<leftarrow>xs'. key x = k] = f k"
    assume
      C: "?r m' = (v, ms', ws')" and
      D: "bn_comp m p q r = (m', r')" and
      E: "bn_valid m p q" and
      F: "Suc (Suc (foldl (+) 0 ns + m)) = n" and
      G: "length xs = n"
    assume "\<And>ws a b c d e g h i n' f.
      ws = ?ws \<Longrightarrow> a = (m', r') \<Longrightarrow> b = m' \<and> c = r' \<Longrightarrow>
      d = (v, ms', ws') \<Longrightarrow> e = v \<and> g = (ms', ws') \<Longrightarrow> h = ms' \<and> i = ws' \<Longrightarrow>
        foldl (+) 0 ns = n' \<and> n - Suc (Suc m) = n' \<longrightarrow> ?P f \<longrightarrow> ?Q f"
    hence "\<And>f. foldl (+) 0 ns = n - Suc (Suc m) \<longrightarrow> ?P f \<longrightarrow> ?Q f"
      by simp
    hence "\<And>f. ?P f \<longrightarrow> ?Q f"
      using F by simp
    hence "?P ?f \<longrightarrow> ?Q ?f" .
    hence "[x\<leftarrow>xs'. key x = k] = [x\<leftarrow>?ys. key x = k]" by simp
    moreover assume "\<forall>k. [x\<leftarrow>xs. key x = k] = f k"
    hence "f k = [x\<leftarrow>?ws @ ?ys. key x = k]" by simp
    ultimately have "f k = [x\<leftarrow>?ws. key x = k] @ [x\<leftarrow>xs'. key x = k]"
      by (subst (asm) filter_append, simp)
    with C [symmetric] show "[x\<leftarrow>ws'. key x = k] @ [x\<leftarrow>xs'. key x = k] = f k"
    proof (simp add: round_suc_suc_def Let_def del: filter.simps
     split: if_split_asm)
      let ?nmi = "mini ?ws key"
      let ?nma = "maxi ?ws key"
      let ?xmi = "?ws ! ?nmi"
      let ?xma = "?ws ! ?nma"
      let ?mi = "key ?xmi"
      let ?ma = "key ?xma"
      let ?k = "case m of 0 \<Rightarrow> m | Suc 0 \<Rightarrow> m | Suc (Suc i) \<Rightarrow> u + m'"
      let ?zs = "nths ?ws (- {?nmi, ?nma})"
      let ?ms = "enum ?zs index key ?k ?mi ?ma"
      have H: "length ?ws = Suc (Suc m)"
        using F and G by simp
      hence I: "?nmi \<noteq> ?nma"
        by (rule_tac mini_maxi_neq, simp)
      have "[x\<leftarrow>(([?xmi] @ map the (fill ?zs (offs ?ms 0) index key m ?mi ?ma))
        @ [?xma]). key x = k] = [x\<leftarrow>?ws. key x = k]"
      proof (cases "m = 0")
        case True
        have "?nmi < length ?ws"
          using H by (rule_tac mini_less, simp)
        hence J: "?nmi < Suc (Suc 0)"
          using True by simp
        moreover have "?nma < length ?ws"
          using H by (rule_tac maxi_less, simp)
        hence K: "?nma < Suc (Suc 0)"
          using True by simp
        ultimately have "card ({..<Suc (Suc 0)} - {?nma} - {?nmi}) = 0"
          using I by ((subst card_Diff_singleton, simp, simp)+,
           subst card_lessThan, simp)
        hence L: "{..<Suc (Suc 0)} - {?nma} - {?nmi} = {}" by simp
        have "length (fill ?zs (offs ?ms 0) index key m ?mi ?ma) = 0"
          using True by (simp add: fill_length)
        hence M: "map the (fill ?zs (offs ?ms 0) index key m ?mi ?ma) =
          nths ?ws ({..<Suc (Suc 0)} - {?nma} - {?nmi})"
          by (subst L, simp)
        show ?thesis
        proof (subst M, subst filter_append)
          show "[x\<leftarrow>[?xmi] @ nths ?ws ({..<Suc (Suc 0)} - {?nma} - {?nmi}).
            key x = k] @ [x\<leftarrow>[?xma]. key x = k] = [x\<leftarrow>?ws. key x = k]"
          proof (subst mini_stable, simp only: length_greater_0_conv
           [symmetric] H, simp add: I J, subst filter_append [symmetric])
            show "[x\<leftarrow>nths ?ws ({..<Suc (Suc 0)} - {?nma}) @ [?xma].
              key x = k] = [x\<leftarrow>?ws. key x = k]"
              by (subst maxi_stable, simp only: length_greater_0_conv
               [symmetric] H, simp add: K, simp add: True)
          qed
        qed
      next
        case False
        hence "0 < ?k"
          by (simp, drule_tac bn_comp_fst_nonzero [OF E], subst (asm) D,
           simp split: nat.split)
        hence "[x\<leftarrow>map the (fill ?zs (offs ?ms 0) index key (length ?zs) ?mi ?ma).
          key x = k] = [x\<leftarrow>?zs. k = key x]"
          by (rule_tac fill_offs_enum_stable [OF A B], simp, rule_tac conjI,
           ((rule_tac mini_lb | rule_tac maxi_ub), erule_tac in_set_nthsD)+)
        moreover have "[x\<leftarrow>?zs. k = key x] = [x\<leftarrow>?zs. key x = k]"
          by (rule filter_cong, simp, blast)
        ultimately have
          J: "[x\<leftarrow>map the (fill ?zs (offs ?ms 0) index key m ?mi ?ma).
            key x = k] = [x\<leftarrow>?zs. key x = k]"
          using H by (simp add: mini_maxi_nths)
        show ?thesis
        proof (simp only: filter_append J, subst Compl_eq_Diff_UNIV,
         subst Diff_insert, subst filter_append [symmetric])
          show "[x\<leftarrow>[?xmi] @ nths ?ws (UNIV - {?nma} - {?nmi}). key x = k]
            @ [x\<leftarrow>[?xma]. key x = k] = [x\<leftarrow>?ws. key x = k]"
          proof (subst mini_stable, simp only: length_greater_0_conv
           [symmetric] H, simp add: I, subst filter_append [symmetric])
            show "[x\<leftarrow>nths ?ws (UNIV - {?nma}) @ [?xma]. key x = k] =
              [x\<leftarrow>?ws. key x = k]"
              by (subst maxi_stable, simp only: length_greater_0_conv
               [symmetric] H, simp, subst nths_range, subst H, simp)
          qed
        qed
      qed
      thus "[x\<leftarrow>?xmi # map the (fill ?zs (offs ?ms 0) index key m ?mi ?ma) @
        [?xma]. key x = k] = [x\<leftarrow>?ws. key x = k]"
        by simp
    qed
  qed
qed

lemma gcsort_stab_inv:
  assumes
    A: "index_less index key" and
    B: "index_same index key" and
    C: "add_inv n t" and
    D: "n \<le> p"
  shows "\<lbrakk>t' \<in> gcsort_set index key p t; stab_inv f key t\<rbrakk> \<Longrightarrow>
    stab_inv f key t'"
by (erule gcsort_set.induct, simp, drule gcsort_add_inv [OF A _ C D],
 rule round_stab_inv [OF A B], simp_all del: bn_inv.simps, erule conjE,
 frule sym, erule subst, rule bn_inv_intro, insert D, simp)

text \<open>
\null

The only remaining task is to address step 10 of the proof method, which is done by proving theorem
@{text gcsort_stable}. It holds under the conditions that the objects' number is not larger than the
counters' upper bound and function @{text index} satisfies both predicates @{const index_less} and
@{const index_same}, and states that function @{const gcsort} leaves unchanged the sublist of the
objects having a given key within the input objects' list.

\null
\<close>

theorem gcsort_stable:
  assumes
    A: "index_less index key" and
    B: "index_same index key" and
    C: "length xs \<le> p"
  shows "[x\<leftarrow>gcsort index key p xs. key x = k] = [x\<leftarrow>xs. key x = k]"
proof -
  let ?t = "(0, [length xs], xs)"
  have "stab_inv (\<lambda>k. [x\<leftarrow>xs. key x = k]) key (gcsort_aux index key p ?t)"
    by (rule gcsort_stab_inv [OF A B _ C], rule gcsort_add_input,
     rule gcsort_aux_set, rule gcsort_stab_input)
  hence "[x\<leftarrow>gcsort_out (gcsort_aux index key p ?t). key x = k] =
    [x\<leftarrow>xs. key x = k]"
    by (rule gcsort_stab_intro)
  moreover have "?t = gcsort_in xs"
    by (simp add: gcsort_in_def)
  ultimately show ?thesis
    by (simp add: gcsort_def)
qed

end