(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Material missing in the distribution\<close>

text \<open>This theory provides some definitions and lemmas which we did not find in the
  Isabelle distribution.\<close>

theory Missing_Misc
  imports
    "HOL-Library.FuncSet"
    "HOL-Combinatorics.Permutations"
begin

declare finite_image_iff [simp]

lemma inj_on_finite:
  \<open>finite (f ` A) \<longleftrightarrow> finite A\<close> if \<open>inj_on f A\<close>
  using that by (fact finite_image_iff)

text \<open>The following lemma is slightly generalized from Determinants.thy in HMA.\<close>

lemma finite_bounded_functions:
  assumes fS: "finite S"
  shows "finite T \<Longrightarrow> finite {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
proof (induct T rule: finite_induct)
  case empty
  have th: "{f. \<forall>i. f i = i} = {id}"
    by auto
  show ?case
    by (auto simp add: th)
next
  case (insert a T)
  let ?f = "\<lambda>(y,g) i. if i = a then y else g i"
  let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)})"
  have "?S = {f. (\<forall>i\<in> insert a T. f i \<in> S) \<and> (\<forall>i. i \<notin> insert a T \<longrightarrow> f i = i)}"
    apply (auto simp add: image_iff)
    apply (rule_tac x="x a" in bexI)
    apply (rule_tac x = "\<lambda>i. if i = a then i else x i" in exI)
    apply (insert insert, auto)
    done
  with finite_imageI[OF finite_cartesian_product[OF fS insert.hyps(3)], of ?f]
  show ?case
    by metis
qed

lemma finite_bounded_functions':
  assumes fS: "finite S"
  shows "finite T \<Longrightarrow> finite {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = j)}"
proof (induct T rule: finite_induct)
  case empty
  have th: "{f. \<forall>i. f i = j} = {(\<lambda> x. j)}"
    by auto
  show ?case
    by (auto simp add: th)
next
  case (insert a T)
  let ?f = "\<lambda>(y,g) i. if i = a then y else g i"
  let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = j)})"
  have "?S = {f. (\<forall>i\<in> insert a T. f i \<in> S) \<and> (\<forall>i. i \<notin> insert a T \<longrightarrow> f i = j)}"
    apply (auto simp add: image_iff)
    apply (rule_tac x="x a" in bexI)
    apply (rule_tac x = "\<lambda>i. if i = a then j else x i" in exI)
    apply (insert insert, auto)
    done
  with finite_imageI[OF finite_cartesian_product[OF fS insert.hyps(3)], of ?f]
  show ?case
    by metis
qed

lemma permutes_less [simp]:
  assumes p: "p permutes {0..<(n :: nat)}"
  shows
    "i < n \<Longrightarrow> p i < n"
    "i < n \<Longrightarrow> inv p i < n"
    "p (inv p i) = i"
    "inv p (p i) = i"
  using assms
  by (simp_all add: permutes_inverses permutes_nat_less permutes_nat_inv_less)

lemma permutes_prod:
  assumes p: "p permutes S"
  shows "(\<Prod>s\<in>S. f (p s) s) = (\<Prod>s\<in>S. f s (inv p s))"
    (is "?l = ?r")
  using assms by (fact prod.permutes_inv)

lemma permutes_sum:
  assumes p: "p permutes S"
  shows "(\<Sum>s\<in>S. f (p s) s) = (\<Sum>s\<in>S. f s (inv p s))"
    (is "?l = ?r")
  using assms by (fact sum.permutes_inv)

context
  fixes A :: "'a set"
    and B :: "'b set"
    and a_to_b :: "'a \<Rightarrow> 'b"
    and b_to_a :: "'b \<Rightarrow> 'a"
  assumes ab: "\<And> a. a \<in> A \<Longrightarrow> a_to_b a \<in> B"
    and ba: "\<And> b. b \<in> B \<Longrightarrow> b_to_a b \<in> A"
    and ab_ba: "\<And> a. a \<in> A \<Longrightarrow> b_to_a (a_to_b a) = a"
    and ba_ab: "\<And> b. b \<in> B \<Longrightarrow> a_to_b (b_to_a b) = b"
begin

qualified lemma permutes_memb: fixes p :: "'b \<Rightarrow> 'b"
  assumes p: "p permutes B"
  and a: "a \<in> A"
  defines "ip \<equiv> Hilbert_Choice.inv p"
  shows "a \<in> A" "a_to_b a \<in> B" "ip (a_to_b a) \<in> B" "p (a_to_b a) \<in> B"
    "b_to_a (p (a_to_b a)) \<in> A" "b_to_a (ip (a_to_b a)) \<in> A"
proof -
  let ?b = "a_to_b a"
  from p have ip: "ip permutes B" unfolding ip_def by (rule permutes_inv)
  note in_ip = permutes_in_image[OF ip]
  note in_p = permutes_in_image[OF p]
  show a: "a \<in> A" by fact
  show b: "?b \<in> B" by (rule ab[OF a])
  show pb: "p ?b \<in> B" unfolding in_p by (rule b)
  show ipb: "ip ?b \<in> B" unfolding in_ip by (rule b)
  show "b_to_a (p ?b) \<in> A" by (rule ba[OF pb])
  show "b_to_a (ip ?b) \<in> A" by (rule ba[OF ipb])
qed

lemma permutes_bij_main:
  "{p . p permutes A} \<supseteq> (\<lambda> p a. if a \<in> A then b_to_a (p (a_to_b a)) else a) ` {p . p permutes B}"
  (is "?A \<supseteq> ?f ` ?B")
proof
  note d = permutes_def
  let ?g = "\<lambda> q b. if b \<in> B then a_to_b (q (b_to_a b)) else b"
  let ?inv = "Hilbert_Choice.inv"
  fix p
  assume p: "p \<in> ?f ` ?B"
  then obtain q where q: "q permutes B" and p: "p = ?f q" by auto
  let ?iq = "?inv q"
  from q have iq: "?iq permutes B" by (rule permutes_inv)
  note in_iq = permutes_in_image[OF iq]
  note in_q = permutes_in_image[OF q]
  have qiB: "\<And> b. b \<in> B \<Longrightarrow> q (?iq b) = b" using q by (rule permutes_inverses)
  have iqB: "\<And> b. b \<in> B \<Longrightarrow> ?iq (q b) = b" using q by (rule permutes_inverses)
  from q[unfolded d]
  have q1: "\<And> b. b \<notin> B \<Longrightarrow> q b = b"
   and q2: "\<And> b. \<exists>!b'. q b' = b" by auto
  note memb = permutes_memb[OF q]
  show "p \<in> ?A" unfolding p d
  proof (rule, intro conjI impI allI, force)
    fix a
    show "\<exists>!a'. ?f q a' = a"
    proof (cases "a \<in> A")
      case True
      note a = memb[OF True]
      let ?a = "b_to_a (?iq (a_to_b a))"
      show ?thesis
      proof
        show "?f q ?a = a" using a by (simp add: ba_ab qiB ab_ba)
      next
        fix a'
        assume id: "?f q a' = a"
        show "a' = ?a"
        proof (cases "a' \<in> A")
          case False
          thus ?thesis using id a by auto
        next
          case True
          note a' = memb[OF this]
          from id True have "b_to_a (q (a_to_b a')) = a" by simp
          from arg_cong[OF this, of "a_to_b"] a' a
          have "q (a_to_b a') = a_to_b a" by (simp add: ba_ab)
          from arg_cong[OF this, of ?iq]
          have "a_to_b a' = ?iq (a_to_b a)" unfolding iqB[OF a'(2)] .
          from arg_cong[OF this, of b_to_a] show ?thesis unfolding ab_ba[OF True] .
        qed
      qed
    next
      case False note a = this
      show ?thesis
      proof
        show "?f q a = a" using a by simp
      next
        fix a'
        assume id: "?f q a' = a"
        show "a' = a"
        proof (cases "a' \<in> A")
          case False
          with id show ?thesis by simp
        next
          case True
          note a' = memb[OF True]
          with id False show ?thesis by auto
        qed
      qed
    qed
  qed
qed

end

lemma permutes_bij': assumes ab: "\<And> a. a \<in> A \<Longrightarrow> a_to_b a \<in> B"
    and ba: "\<And> b. b \<in> B \<Longrightarrow> b_to_a b \<in> A"
    and ab_ba: "\<And> a. a \<in> A \<Longrightarrow> b_to_a (a_to_b a) = a"
    and ba_ab: "\<And> b. b \<in> B \<Longrightarrow> a_to_b (b_to_a b) = b"
  shows "{p . p permutes A} = (\<lambda> p a. if a \<in> A then b_to_a (p (a_to_b a)) else a) ` {p . p permutes B}"
  (is "?A = ?f ` ?B")
proof -
  note one_dir = ab ba ab_ba ba_ab
  note other_dir = ba ab ba_ab ab_ba
  let ?g = "(\<lambda> p b. if b \<in> B then a_to_b (p (b_to_a b)) else b)"
  define PA where "PA = ?A"
  define f where "f = ?f"
  define g where "g = ?g"
  {
    fix p
    assume "p \<in> PA"
    hence p: "p permutes A" unfolding PA_def by simp
    from p[unfolded permutes_def] have pnA: "\<And> a. a \<notin> A \<Longrightarrow> p a = a" by auto
    have "?f (?g p) = p"
    proof (rule ext)
      fix a
      show "?f (?g p) a = p a"
      proof (cases "a \<in> A")
        case False
        thus ?thesis by (simp add: pnA)
      next
        case True note a = this
        hence "p a \<in> A" unfolding permutes_in_image[OF p] .
        thus ?thesis using a by (simp add: ab_ba ba_ab ab)
      qed
    qed
    hence "f (g p) = p" unfolding f_def g_def .
  }
  hence "f ` g ` PA = PA" by force
  hence id: "?f ` ?g ` ?A = ?A" unfolding PA_def f_def g_def .
  have "?f ` ?B \<subseteq> ?A" by (rule permutes_bij_main[OF one_dir])
  moreover have "?g ` ?A \<subseteq> ?B" by (rule permutes_bij_main[OF ba ab ba_ab ab_ba])
  hence "?f ` ?g ` ?A \<subseteq> ?f ` ?B" by auto
  hence "?A \<subseteq> ?f ` ?B" unfolding id .
  ultimately show ?thesis by blast
qed

lemma permutes_others:
  assumes p: "p permutes S" and x: "x \<notin> S" shows "p x = x"
  using p x by (rule permutes_not_in)

lemma inj_on_nat_permutes: assumes i: "inj_on f (S :: nat set)"
  and fS: "f \<in> S \<rightarrow> S"
  and fin: "finite S"
  and f: "\<And> i. i \<notin> S \<Longrightarrow> f i = i"
  shows "f permutes S"
  unfolding permutes_def
proof (intro conjI allI impI, rule f)
  fix y
  from endo_inj_surj[OF fin _ i] fS have fs: "f ` S = S" by auto
  show "\<exists>!x. f x = y"
  proof (cases "y \<in> S")
    case False
    thus ?thesis by (intro ex1I[of _ y], insert fS f, auto)
  next
    case True
    with fs obtain x where x: "x \<in> S" and fx: "f x = y" by force
    show ?thesis
    proof (rule ex1I, rule fx)
      fix x'
      assume fx': "f x' = y"
      with True f[of x'] have "x' \<in> S" by metis
      from inj_onD[OF i fx[folded fx'] x this]
      show "x' = x" by simp
    qed
  qed
qed

abbreviation (input) signof :: \<open>(nat \<Rightarrow> nat) \<Rightarrow> 'a :: ring_1\<close>
  where \<open>signof p \<equiv> of_int (sign p)\<close>

lemma signof_id:
  "signof id = 1"
  "signof (\<lambda>x. x) = 1"
  by simp_all

lemma signof_inv: "finite S \<Longrightarrow> p permutes S \<Longrightarrow> signof (inv p) = signof p"
  by (simp add: permutes_imp_permutation sign_inverse)

lemma signof_pm_one: "signof p \<in> {1, - 1}"
  by (simp add: sign_def)

lemma signof_compose:
  assumes "p permutes {0..<(n :: nat)}"
  and "q permutes {0 ..<(m :: nat)}"
  shows "signof (p o q) = signof p * signof q"
proof -
  from assms have pp: "permutation p" "permutation q"
    by (auto simp: permutation_permutes)
  then show "signof (p o q) = signof p * signof q"
    by (simp add: sign_compose)
qed

end


section {* \isaheader{List Based Sets} *}
theory Impl_List_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
begin
  (* TODO: Move *)
  lemma list_all2_refl_conv:
    "list_all2 P xs xs \<longleftrightarrow> (\<forall>x\<in>set xs. P x x)"
    by (induct xs) auto

  primrec glist_member :: "('a\<Rightarrow>'a\<Rightarrow>bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
    "glist_member eq x [] \<longleftrightarrow> False"
  | "glist_member eq x (y#ys) \<longleftrightarrow> eq x y \<or> glist_member eq x ys"

  lemma param_glist_member[param]:
    "(glist_member,glist_member)\<in>(Ra\<rightarrow>Ra\<rightarrow>Id) \<rightarrow> Ra \<rightarrow> \<langle>Ra\<rangle>list_rel \<rightarrow> Id"
    unfolding glist_member_def
    by (parametricity)

  lemma list_member_alt: "List.member = (\<lambda>l x. glist_member op = x l)"
  proof (intro ext)
    fix x l
    show "List.member l x = glist_member op = x l"
      by (induct l) (auto simp: List.member_rec)
  qed

  thm List.insert_def
  definition
    "glist_insert eq x xs = (if glist_member eq x xs then xs else x#xs)"

  lemma param_glist_insert[param]:
    "(glist_insert, glist_insert) \<in> (R\<rightarrow>R\<rightarrow>Id) \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding glist_insert_def[abs_def]
    by (parametricity)

  primrec rev_append where
    "rev_append [] ac = ac"
  | "rev_append (x#xs) ac = rev_append xs (x#ac)"

  lemma rev_append_eq: "rev_append l ac = rev l @ ac"
    by (induct l arbitrary: ac) auto

  (*
  primrec glist_delete_aux1 :: "('a\<Rightarrow>'a\<Rightarrow>bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "glist_delete_aux1 eq x [] = []"
  | "glist_delete_aux1 eq x (y#ys) = (
      if eq x y then
        ys
      else y#glist_delete_aux1 eq x ys)"

  primrec glist_delete_aux2 :: "('a\<Rightarrow>'a\<Rightarrow>_) \<Rightarrow> _" where
    "glist_delete_aux2 eq ac x [] = ac"
  | "glist_delete_aux2 eq ac x (y#ys) = (if eq x y then rev_append ys ac else
      glist_delete_aux2 eq (y#ac) x ys
    )"

  lemma glist_delete_aux2_eq1:
    "glist_delete_aux2 eq ac x l = rev (glist_delete_aux1 eq x l) @ ac"
    by (induct l arbitrary: ac) (auto simp: rev_append_eq)

  definition "glist_delete eq x l = glist_delete_aux2 eq [] x l"
  *)

  primrec glist_delete_aux :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> _" where
    "glist_delete_aux eq x [] as = as"
  | "glist_delete_aux eq x (y#ys) as = (
      if eq x y then rev_append as ys
      else glist_delete_aux eq x ys (y#as)
    )"

  definition glist_delete where
    "glist_delete eq x l \<equiv> glist_delete_aux eq x l []"

  lemma param_glist_delete[param]:
    "(glist_delete, glist_delete) \<in> (R\<rightarrow>R\<rightarrow>Id) \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding glist_delete_def[abs_def]
      glist_delete_aux_def
      rev_append_def
    by (parametricity)

  definition
    list_set_rel_internal_def: "list_set_rel R \<equiv> \<langle>R\<rangle>list_rel O br set distinct"

lemma list_rel_Range:
    "\<forall>x'\<in>set l'. x' \<in> Range R \<Longrightarrow> l' \<in> Range (\<langle>R\<rangle>list_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs') \<in> \<langle>R\<rangle> list_rel" by force
    moreover from Cons.prems obtain x where "(x,x') \<in> R" by force
    ultimately have "(x#xs, x'#xs') \<in> \<langle>R\<rangle> list_rel" by simp
    thus ?case ..
qed

  lemma list_set_rel_def: "\<langle>R\<rangle>list_set_rel = \<langle>R\<rangle>list_rel O br set distinct"
    unfolding list_set_rel_internal_def[abs_def] by (simp add: relAPP_def)

  text {* All finite sets can be represented *}
  lemma list_set_rel_range:
    "Range (\<langle>R\<rangle>list_set_rel) = { S. finite S \<and> S\<subseteq>Range R }"
      (is "?A = ?B")
  proof (intro equalityI subsetI)
    fix s' assume "s' \<in> ?A"
    then obtain l l' where A: "(l,l') \<in> \<langle>R\<rangle>list_rel" and
       B: "s' = set l'" and C: "distinct l'"
        unfolding list_set_rel_def br_def by blast
    moreover have "set l' \<subseteq> Range R"
        by (induction rule: list_rel_induct[OF A], auto)
    ultimately show "s' \<in> ?B" by simp
  next
    fix s' assume A: "s' \<in> ?B"
    then obtain l' where B: "set l' = s'" and C: "distinct l'"
        using finite_distinct_list by blast
    hence "(l',s') \<in> br set distinct" by (simp add: br_def)

    moreover from A and B have "\<forall>x\<in>set l'. x \<in> Range R" by blast
    from list_rel_Range[OF this] obtain l
        where "(l,l') \<in> \<langle>R\<rangle>list_rel" by blast

    ultimately show "s' \<in> ?A" unfolding list_set_rel_def by fast
  qed

  lemmas [autoref_rel_intf] = REL_INTFI[of list_set_rel i_set]

  lemma list_set_rel_finite[autoref_ga_rules]:
    "finite_set_rel (\<langle>R\<rangle>list_set_rel)"
    unfolding finite_set_rel_def list_set_rel_def
    by (auto simp: br_def)

  lemma list_set_rel_sv[relator_props]:
    "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>list_set_rel)"
    unfolding list_set_rel_def
    by tagged_solver

  (* TODO: Move to Misc *)
  lemma Id_comp_Id: "Id O Id = Id" by simp

  lemma glist_member_id_impl:
    "(glist_member op =, op \<in>) \<in> Id \<rightarrow> br set distinct \<rightarrow> Id"
  proof (intro fun_relI, goal_cases)
    case (1 x x' l s') thus ?case
      by (induct l arbitrary: s') (auto simp: br_def)
  qed

  lemma glist_insert_id_impl:
    "(glist_insert op =, Set.insert) \<in> Id \<rightarrow> br set distinct \<rightarrow> br set distinct"
  proof -
    have IC: "\<And>x s. insert x s = (if x\<in>s then s else insert x s)" by auto

    show ?thesis
      apply (intro fun_relI)
      apply (subst IC)
      unfolding glist_insert_def
      apply (parametricity add: glist_member_id_impl)
      apply (auto simp: br_def)
      done
  qed

  lemma glist_delete_id_impl:
    "(glist_delete op =, \<lambda>x s. s-{x})
    \<in> Id\<rightarrow>br set distinct \<rightarrow> br set distinct"
  proof (intro fun_relI)
    fix x x':: 'a and s and s' :: "'a set"
    assume XREL: "(x, x') \<in> Id" and SREL: "(s, s') \<in> br set distinct"
    from XREL have [simp]: "x'=x" by simp

    {
      fix a and a' :: "'a set"
      assume "(a,a')\<in>br set distinct" and "s' \<inter> a' = {}"
      hence "(glist_delete_aux op = x s a, s'-{x'} \<union> a')\<in>br set distinct"
        using SREL
      proof (induction s arbitrary: a s' a')
        case Nil thus ?case by (simp add: br_def)
      next
        case (Cons y s)
        show ?case proof (cases "x=y")
          case True with Cons show ?thesis
            by (auto simp add: br_def rev_append_eq)
        next
          case False
          have "glist_delete_aux op = x (y # s) a
            = glist_delete_aux op = x s (y#a)" by (simp add: False)
          also have "(\<dots>,set s - {x'} \<union> insert y a')\<in>br set distinct"
            apply (rule Cons.IH[of "y#a" "insert y a'" "set s"])
            using Cons.prems by (auto simp: br_def)
          also have "set s - {x'} \<union> insert y a' = (s' - {x'}) \<union> a'"
          proof -
            from Cons.prems have [simp]: "s' = insert y (set s)"
              by (auto simp: br_def)
            show ?thesis using False by auto
          qed
          finally show ?thesis .
        qed
      qed
    }
    from this[of "[]" "{}"]
    show "(glist_delete op = x s, s' - {x'}) \<in> br set distinct"
      unfolding glist_delete_def
      by (simp add: br_def)
  qed

  lemma list_set_autoref_empty[autoref_rules]:
    "([],{})\<in>\<langle>R\<rangle>list_set_rel"
    by (auto simp: list_set_rel_def br_def)

  lemma list_set_autoref_member[autoref_rules]:
    assumes "GEN_OP eq op= (R\<rightarrow>R\<rightarrow>Id)"
    shows "(glist_member eq,op \<in>) \<in> R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> Id"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (subst Id_comp_Id[symmetric])
    apply (rule relcompI[rotated])
    apply (rule glist_member_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_insert[autoref_rules]:
    assumes "GEN_OP eq op= (R\<rightarrow>R\<rightarrow>Id)"
    shows "(glist_insert eq,Set.insert)
      \<in> R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_insert_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_delete[autoref_rules]:
    assumes "GEN_OP eq op= (R\<rightarrow>R\<rightarrow>Id)"
    shows "(glist_delete eq,op_set_delete)
      \<in> R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_delete_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_to_list[autoref_ga_rules]:
    shows "is_set_to_sorted_list (\<lambda>_ _. True) R list_set_rel id"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
      it_to_sorted_list_def list_set_rel_def br_def
    by auto

  lemma list_set_it_simp[refine_transfer_post_simp]:
    "foldli (id l) = foldli l" by simp

  lemma glist_insert_dj_id_impl:
    "\<lbrakk> x\<notin>s; (l,s)\<in>br set distinct \<rbrakk> \<Longrightarrow> (x#l,insert x s)\<in>br set distinct"
    by (auto simp: br_def)

context begin interpretation autoref_syn .
  lemma list_set_autoref_insert_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes "SIDE_PRECOND_OPT (x'\<notin>s')"
    assumes "(x,x')\<in>R"
    assumes "(s,s')\<in>\<langle>R\<rangle>list_set_rel"
    shows "(x#s,
      (OP Set.insert ::: R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel) $ x' $ s')
      \<in> \<langle>R\<rangle>list_set_rel"
    using assms
    unfolding autoref_tag_defs
    unfolding list_set_rel_def
    apply -
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_insert_dj_id_impl)
    apply assumption
    apply assumption
    apply parametricity
    done
end

  subsection {* More Operations *}
  lemma list_set_autoref_isEmpty[autoref_rules]:
    "(is_Nil,op_set_isEmpty) \<in> \<langle>R\<rangle>list_set_rel \<rightarrow> bool_rel"
    by (auto simp: list_set_rel_def br_def split: list.split_asm)

  lemma list_set_autoref_filter[autoref_rules]:
    "(filter,op_set_filter)
      \<in> (R \<rightarrow> bool_rel) \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
  proof -
    have "(filter, op_set_filter)
      \<in> (Id \<rightarrow> bool_rel) \<rightarrow> \<langle>Id\<rangle>list_set_rel \<rightarrow> \<langle>Id\<rangle>list_set_rel"
      by (auto simp: list_set_rel_def br_def)
    note this[param_fo]
    moreover have "(filter,filter)\<in>(R \<rightarrow> bool_rel) \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
      unfolding List.filter_def
      by parametricity
    note this[param_fo]
    ultimately show ?thesis
      unfolding list_set_rel_def
      apply (intro fun_relI)
      apply (erule relcompE, simp)
      apply (rule relcompI)
      apply (rprems, assumption+)
      apply (rprems, simp+)
      done
  qed

  context begin interpretation autoref_syn .
  lemma list_set_autoref_inj_image[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes INJ: "SIDE_PRECOND_OPT (inj_on f s)"
    assumes [param]: "(fi,f)\<in>Ra\<rightarrow>Rb"
    assumes LP: "(l,s)\<in>\<langle>Ra\<rangle>list_set_rel"
    shows "(map fi l,
      (OP op ` ::: (Ra\<rightarrow>Rb) \<rightarrow> \<langle>Ra\<rangle>list_set_rel \<rightarrow> \<langle>Rb\<rangle>list_set_rel)$f$s)
      \<in> \<langle>Rb\<rangle>list_set_rel"
  proof -
    from LP obtain l' where
      [param]: "(l,l')\<in>\<langle>Ra\<rangle>list_rel" and L'S: "(l',s)\<in>br set distinct"
      unfolding list_set_rel_def by auto

    have "(map fi l, map f l')\<in>\<langle>Rb\<rangle>list_rel" by parametricity
    also from INJ L'S have "(map f l',f`s)\<in>br set distinct"
      apply (induction l' arbitrary: s)
      apply (auto simp: br_def dest: injD)
      done
    finally (relcompI) show ?thesis
      unfolding autoref_tag_defs list_set_rel_def .
  qed

  end

  lemma list_set_cart_autoref[autoref_rules]:
    fixes Rx :: "('xi \<times> 'x) set"
    fixes Ry :: "('yi \<times> 'y) set"
    shows "(\<lambda>xl yl. [ (x,y). x\<leftarrow>xl, y\<leftarrow>yl], op_set_cart)
    \<in> \<langle>Rx\<rangle>list_set_rel \<rightarrow> \<langle>Ry\<rangle>list_set_rel \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>list_set_rel"
  proof (intro fun_relI)
    fix xl xs yl ys
    assume "(xl, xs) \<in> \<langle>Rx\<rangle>list_set_rel" "(yl, ys) \<in> \<langle>Ry\<rangle>list_set_rel"
    then obtain xl' :: "'x list" and yl' :: "'y list" where
      [param]: "(xl,xl')\<in>\<langle>Rx\<rangle>list_rel" "(yl,yl')\<in>\<langle>Ry\<rangle>list_rel"
      and XLS: "(xl',xs)\<in>br set distinct" and YLS: "(yl',ys)\<in>br set distinct"
      unfolding list_set_rel_def
      by auto

    have "([ (x,y). x\<leftarrow>xl, y\<leftarrow>yl ], [ (x,y). x\<leftarrow>xl', y\<leftarrow>yl' ])
      \<in> \<langle>Rx \<times>\<^sub>r Ry\<rangle>list_rel"
      by parametricity
    also have "([ (x,y). x\<leftarrow>xl', y\<leftarrow>yl' ], xs \<times> ys) \<in> br set distinct"
      using XLS YLS
      apply (auto simp: br_def)
      apply hypsubst_thin
      apply (induction xl')
      apply simp
      apply (induction yl')
      apply simp
      apply auto []
      apply (metis (lifting) concat_map_maps distinct.simps(2)
        distinct_singleton maps_simps(2))
      done
    finally (relcompI)
    show "([ (x,y). x\<leftarrow>xl, y\<leftarrow>yl ], op_set_cart xs ys) \<in> \<langle>Rx \<times>\<^sub>r Ry\<rangle>list_set_rel"
      unfolding list_set_rel_def by simp
  qed

  subsection {* Optimizations *}
  lemma glist_delete_hd: "eq x y \<Longrightarrow> glist_delete eq x (y#s) = s"
    by (simp add: glist_delete_def)

  text {* Hack to ensure specific ordering. Note that ordering has no meaning
    abstractly *}
  definition [simp]: "LIST_SET_REV_TAG \<equiv> \<lambda>x. x"

  lemma LIST_SET_REV_TAG_autoref[autoref_rules]:
    "(rev,LIST_SET_REV_TAG) \<in> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
    unfolding list_set_rel_def
    apply (intro fun_relI)
    apply (elim relcompE)
    apply (clarsimp simp: br_def)
    apply (rule relcompI)
    apply (rule param_rev[param_fo], assumption)
    apply auto
    done

end


theory hw3
  imports
  "HOL-Library.Countable_Set"
  abbrevs "|=0" = "\<Turnstile>\<^sub>\<emptyset>" and "||=0" = "\<TTurnstile>\<^sub>\<emptyset>" and ",," = "\<^sub>\<flat>"
begin
(*1*)
datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var v = v" |
  "eval (Const e) v = e" |
  "eval (Add e f) v = (eval e v) + (eval f v)" |
  "eval (Mult e f) v = (eval e v) * (eval f v)"

value "eval (Var) 6"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp Nil v = 0" |
  "evalp (Cons x xs) v = x + v * (evalp xs v)"

value "evalp [4, 2, -1, 3] 4"
fun add_coeff :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "add_coeff Nil Nil = Nil" |
  "add_coeff Nil ys = ys" |
  "add_coeff xs Nil = xs" |
  "add_coeff (x#xs) (y#ys) = (x+y)#(add_coeff xs ys)"

value "add_coeff [4, 2, -1, 3] [2,3]"

lemma evalp_add[simp] : "evalp (add_coeff xs ys) x = (evalp xs x) + (evalp ys x)"
  apply(induction xs rule: add_coeff.induct)
     apply(auto simp add: algebra_simps)
  done

fun mult :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "mult n Nil = Nil" |
  "mult n (x#xs) = (n*x)#(mult n xs)"

lemma evalp_mul[simp] : "evalp (mult n xs) v = n * (evalp xs v)"
  apply(induction xs)
   apply(auto simp add:algebra_simps)
  done

fun mult_coeff :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "mult_coeff Nil ys = Nil" |
  "mult_coeff (x#xs) ys = add_coeff (mult x ys) (0#(mult_coeff xs ys))"

lemma evalp_mult[simp] : "evalp (mult_coeff xs ys) x = (evalp xs x) * (evalp ys x)"
  apply(induction xs)
   apply(auto simp add: algebra_simps)
  done

fun coeff :: "exp \<Rightarrow> int list" where
"coeff Var = [0,1]" |
"coeff (Const i) = [i]" |
"coeff (Add e f) = add_coeff (coeff e) (coeff f)" |
"coeff (Mult e f) = mult_coeff (coeff e) (coeff f)"

value "coeff (Add (Mult (Const 2) Var) (Mult (Const (-1)) (Mult Var Var)))"

theorem preservation : "evalp (coeff e) x = eval e x"
  apply(induction e arbitrary: x)
  using [[simp_trace]]
     apply(auto)
  done

(*2*)

abbreviation vx ("\<^bold>x") where "\<^bold>x \<equiv> Var"
abbreviation add (infixl "\<^bold>+" 65) where "a \<^bold>+ b \<equiv> Add a b"
abbreviation mul (infixl "\<^bold>\<times>" 70) where "a \<^bold>\<times> b \<equiv> Mult a b"
abbreviation num ("\<^bold>_" [1000] 1000) where "\<^bold>a \<equiv> Const a"

no_notation  power2  ("(_\<^sup>2)" [1000] 999)

primrec pow :: "exp \<Rightarrow> nat \<Rightarrow> exp" ("_\<^sup>_" [1000, 1000] 80)
  where
  "pow x 0       = \<^bold>1"
| "pow x (Suc n) = x \<^bold>\<times> (pow x n)"

value "eval( \<^bold>4 \<^bold>+ \<^bold>2\<^bold>\<times>\<^bold>x\<^sup>3 \<^bold>+ \<^bold>(-1) \<^bold>\<times> \<^bold>x\<^sup>2 \<^bold>+ \<^bold>3\<^bold>\<times>\<^bold>x\<^sup>3) 3"

(*3*)
datatype boolex = Const bool | Var nat | Neg boolex | And boolex boolex

primrec "value" :: "boolex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"value (Const b) env = b" |
"value (Var x) env = env x" |
"value (Neg b) env = (\<not> value b env)" |
"value (And b c) env = (value b env \<and> value c env)"

datatype ifex = CIF bool | VIF nat | IF ifex ifex ifex

primrec valif :: "ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"valif (CIF b) env = b" |
"valif (VIF x) env = env x" |
"valif (IF b t e) env = (if valif b env then valif t env else valif e env)"

primrec bool2if :: "boolex \<Rightarrow> ifex" where
"bool2if (Const b) = CIF b" |
"bool2if (Var x) = VIF x" |
"bool2if (Neg b) = IF (bool2if b) (CIF False) (CIF True)" |
"bool2if (And b c) = IF (bool2if b) (bool2if c) (CIF False)"

lemma "valif (bool2if b) env = value b env"
  apply(induct_tac b)
  apply(auto)
  done

(*4*)
locale Geom =
  fixes on :: "'p \<Rightarrow> 'l \<Rightarrow> bool"
  assumes line_on_two_pts: "a \<noteq> b \<Longrightarrow> \<exists>l. on a l \<and> on b l"
  and line_on_two_pts_unique:
  "\<lbrakk> a \<noteq> b; on a l; on b l; on a m; on b m \<rbrakk> \<Longrightarrow> l = m"
  and two_points_on_line: "\<exists>a b. a \<noteq> b \<and> on a l \<and> on b l"
  and three_points_not_on_line: "\<exists>a b c. a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c \<and> \<not> (\<exists>l. on a l \<and> on b l \<and> on c l)"
begin

lemma three_points_not_on_line_alt:
  "\<exists>a b c. a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c \<and> (\<forall>l. on a l \<and> on b l \<longrightarrow> \<not> on c l)"
  using three_points_not_on_line by blast

lemma exists_pt_not_on_line: "\<exists>x. \<not> on x l"
  using three_points_not_on_line_alt by auto

lemma two_lines_unique_intersect_pt:
  assumes lm: "l\<noteq>m \<and> on x l \<and> on x m \<and> on y l \<and> on y m" shows "x=y"
  using line_on_two_pts_unique lm by auto

end

end


theory Derivations
imports CFG ListTools InductRules
begin

(* leftderives and leftderives1 *)
type_synonym ('a, 'b) derivation = "(nat \<times> ('a, 'b) rule) list"

context CFG begin

lemma [simp]: "is_sentence []" by (auto simp add: is_sentence_def)

lemma [simp]: "is_word []" by (auto simp add: is_word_def)

lemma [simp]: "is_word u \<Longrightarrow> is_sentence u"
  by (induct u, auto simp add: is_word_def is_sentence_def)

definition leftderives1 :: "('a, 'b)sentence \<Rightarrow> ('a,'b) sentence \<Rightarrow> bool"
where
  "leftderives1 u v =
     (\<exists> x y N \<alpha>.
          u = x @ [N] @ y
        \<and> v = x @ \<alpha> @ y
        \<and> is_word x
        \<and> is_sentence y
        \<and> (N, \<alpha>) \<in> \<RR>)"

lemma leftderives1_implies_derives1[simp]: "leftderives1 u v \<Longrightarrow> derives1 u v"
  apply (auto simp add: leftderives1_def derives1_def)
  apply (rule_tac x="x" in exI)
  apply (rule_tac x="y" in exI)
  apply (rule_tac x="N" in exI)
  by auto

definition leftderivations1 :: "(('a, 'b) sentence \<times> ('a, 'b) sentence) set"
where
  "leftderivations1 = { (u,v) | u v. leftderives1 u v }"

lemma [simp]: "leftderivations1 \<subseteq> derivations1"
  by (auto simp add: leftderivations1_def derivations1_def)

definition leftderivations :: "(('a, 'b) sentence \<times> ('a, 'b) sentence) set"
where
  "leftderivations = leftderivations1^*"

lemma rtrancl_subset_implies: "a \<subseteq> b \<Longrightarrow> a \<subseteq> b^*" by blast

lemma leftderivations_subset_derivations[simp]: "leftderivations \<subseteq> derivations"
  apply (simp add: leftderivations_def derivations_def)
  apply (rule rtrancl_subset_rtrancl)
  apply (rule rtrancl_subset_implies)
  by simp

definition leftderives :: "('a, 'b) sentence \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "leftderives u v = ((u, v) \<in> leftderivations)"

lemma leftderives_implies_derives[simp]: "leftderives u v \<Longrightarrow> derives u v"
  apply (auto simp add: leftderives_def derives_def)
  by (rule subsetD[OF leftderivations_subset_derivations])

definition is_leftderivation :: "('a, 'b) sentence \<Rightarrow> bool"
where
  "is_leftderivation u = leftderives [\<SS>] u"

lemma leftderivation_implies_derivation[simp]:
  "is_leftderivation u \<Longrightarrow> is_derivation u"
  by (simp add: is_leftderivation_def is_derivation_def)

lemma leftderives_refl[simp]: "leftderives u u"
  by (auto simp add: leftderives_def leftderivations_def)

lemma leftderives1_implies_leftderives[simp]:"leftderives1 a b \<Longrightarrow> leftderives a b"
  by (auto simp add: leftderives_def leftderivations_def leftderivations1_def)

lemma leftderives_trans: "leftderives a b \<Longrightarrow> leftderives b c \<Longrightarrow> leftderives a c"
  by (auto simp add: leftderives_def leftderivations_def)

lemma leftderives1_eq_leftderivations1: "leftderives1 x y = ((x, y) \<in> leftderivations1)"
  by (simp add: leftderivations1_def)

lemma leftderives_induct[consumes 1, case_names Base Step]:
  assumes derives: "leftderives a b"
  assumes Pa: "P a"
  assumes induct: "\<And>y z. leftderives a y \<Longrightarrow> leftderives1 y z \<Longrightarrow> P y \<Longrightarrow> P z"
  shows "P b"
proof -
  note rtrancl_lemma = rtrancl_induct[where a = a and b = b and r = leftderivations1 and P=P]
  from derives Pa induct rtrancl_lemma show "P b"
    by (metis leftderives_def leftderivations_def leftderives1_eq_leftderivations1)
qed

end

(* Basic lemmas about derives1 and derives *)
context CFG begin

lemma derives1_implies_derives[simp]:"derives1 a b \<Longrightarrow> derives a b"
  by (auto simp add: derives_def derivations_def derivations1_def)

lemma derives_trans: "derives a b \<Longrightarrow> derives b c \<Longrightarrow> derives a c"
  by (auto simp add: derives_def derivations_def)

lemma derives1_eq_derivations1: "derives1 x y = ((x, y) \<in> derivations1)"
  by (simp add: derivations1_def)

lemma derives_induct[consumes 1, case_names Base Step]:
  assumes derives: "derives a b"
  assumes Pa: "P a"
  assumes induct: "\<And>y z. derives a y \<Longrightarrow> derives1 y z \<Longrightarrow> P y \<Longrightarrow> P z"
  shows "P b"
proof -
  note rtrancl_lemma = rtrancl_induct[where a = a and b = b and r = derivations1 and P=P]
  from derives Pa induct rtrancl_lemma show "P b"
    by (metis derives_def derivations_def derives1_eq_derivations1)
qed

end

(* Derives1 and Derivation, LDerives1 and LDerivation *)
context CFG begin

definition Derives1 :: "('a, 'b) sentence \<Rightarrow> nat \<Rightarrow> ('a, 'b) rule \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "Derives1 u i r v =
     (\<exists> x y N \<alpha>.
          u = x @ [N] @ y
        \<and> v = x @ \<alpha> @ y
        \<and> is_sentence x
        \<and> is_sentence y
        \<and> (N, \<alpha>) \<in> \<RR>
        \<and> r = (N, \<alpha>) \<and> i = length x)"

lemma Derives1_split:
  "Derives1 u i r v \<Longrightarrow> \<exists> x y. u = x @ [fst r] @ y \<and> v = x @ (snd r) @ y \<and> length x = i"
by (metis Derives1_def fst_conv snd_conv)

lemma Derives1_implies_derives1: "Derives1 u i r v \<Longrightarrow> derives1 u v"
  by (auto simp add: Derives1_def derives1_def)

lemma derives1_implies_Derives1: "derives1 u v \<Longrightarrow> \<exists> i r. Derives1 u i r v"
  by (auto simp add: Derives1_def derives1_def)

lemma Derives1_unique_dest: "Derives1 u i r v \<Longrightarrow> Derives1 u i r w \<Longrightarrow> v = w"
  by (auto simp add: Derives1_def derives1_def)

lemma Derives1_unique_src: "Derives1 u i r w \<Longrightarrow> Derives1 v i r w \<Longrightarrow> u = v"
  by (auto simp add: Derives1_def derives1_def)

fun Derivation :: "('a, 'b) sentence \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "Derivation a [] b = (a = b)"
| "Derivation a (d#D) b = (\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b)"

lemma Derivation_implies_derives: "Derivation a D b \<Longrightarrow> derives a b"
proof (induct D arbitrary: a b)
  case Nil thus ?case
    by (simp add: derives_def derivations_def)
next
  case (Cons d D)
    note ihyps = this
    from ihyps have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b" by auto
    then obtain x where "Derives1 a (fst d) (snd d) x" and xb: "Derivation x D b" by blast
    with Derives1_implies_derives1 have d1: "derives a x" by auto
    from ihyps xb have d2:"derives x b" by simp
    show "derives a b" by (rule derives_trans[OF d1 d2])
qed

lemma Derivation_Derives1: "Derivation a S y \<Longrightarrow> Derives1 y i r z \<Longrightarrow> Derivation a (S@[(i,r)]) z"
proof (induct S arbitrary: a y z i r)
  case Nil thus ?case by simp
next
  case (Cons s S) thus ?case
    by (metis Derivation.simps(2) append_Cons)
qed

lemma derives_implies_Derivation: "derives a b \<Longrightarrow> \<exists> D. Derivation a D b"
proof (induct rule: derives_induct)
  case Base
  show ?case by (rule exI[where x="[]"], simp)
next
  case (Step y z)
  note ihyps = this
  from ihyps obtain D where ay: "Derivation a D y" by blast
  from ihyps derives1_implies_Derives1 obtain i r where yz: "Derives1 y i r z" by blast
  from Derivation_Derives1[OF ay yz] show ?case by auto
qed

lemma Derives1_take: "Derives1 a i r b \<Longrightarrow> take i a = take i b"
  by (auto simp add: Derives1_def)

lemma Derives1_drop: "Derives1 a i r b \<Longrightarrow> drop (Suc i) a = drop (i + length (snd r)) b"
  by (auto simp add: Derives1_def)

lemma Derives1_bound: "Derives1 a i r b \<Longrightarrow> i < length a"
  by (auto simp add: Derives1_def)

lemma Derives1_length: "Derives1 a i r b \<Longrightarrow> length b = length a + length (snd r) - 1"
  by (auto simp add: Derives1_def)

definition leftmost :: "nat \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "leftmost i s = (i < length s \<and> is_word (take i s) \<and> is_nonterminal (s ! i))"

lemma set_take: "set (take n s) = { s ! i | i. i < n \<and> i < length s}"
proof (cases "n \<le> length s")
  case True thus ?thesis
  by (subst List.nth_image[symmetric], auto)
next
  case False thus ?thesis
    apply (subst set_conv_nth)
    by (metis less_trans linear not_le take_all)
qed

lemma list_all_take: "list_all P (take n s) = (\<forall> i. i < n \<and> i < length s \<longrightarrow> P (s ! i))"
  by (auto simp add: set_take list_all_iff)

lemma is_sentence_concat: "is_sentence (x@y) = (is_sentence x \<and> is_sentence y)"
  by (auto simp add: is_sentence_def)

lemma is_sentence_cons: "is_sentence (x#xs) = (is_symbol x \<and> is_sentence xs)"
  by (auto simp add: is_sentence_def)

lemma rule_nonterminal_type[simp]: "(N, \<alpha>) \<in> \<RR> \<Longrightarrow> is_nonterminal N"
  apply (insert validRules)
  by (auto simp add: is_nonterminal_def)

lemma rule_\<alpha>_type[simp]: "(N, \<alpha>) \<in> \<RR> \<Longrightarrow> is_sentence \<alpha>"
  apply (insert validRules)
  apply (auto simp add: is_sentence_def is_symbol_def list_all_iff is_terminal_def is_nonterminal_def split: sum.splits)
  done
lemma [simp]: "is_nonterminal N \<Longrightarrow> is_symbol N"
  by (simp add: is_symbol_def)

lemma Derives1_sentence1[elim]: "Derives1 a i r b \<Longrightarrow> is_sentence a"
  by (auto simp add: Derives1_def is_sentence_cons is_sentence_concat)

lemma Derives1_sentence2[elim]: "Derives1 a i r b \<Longrightarrow> is_sentence b"
  by (auto simp add: Derives1_def is_sentence_cons is_sentence_concat)

lemma [elim]: "Derives1 a i r b \<Longrightarrow> r \<in> \<RR>"
  using Derives1_def by auto

lemma is_sentence_symbol: "is_sentence a \<Longrightarrow> i < length a \<Longrightarrow> is_symbol (a ! i)"
  by (simp add: is_sentence_def list_all_iff)

lemma is_symbol_distinct: "is_symbol x \<Longrightarrow> is_terminal x \<noteq> is_nonterminal x"
  apply (insert disjunct_symbols)
  apply (auto simp add: is_symbol_def is_terminal_def is_nonterminal_def split: sum.splits)
  done

lemma is_terminal_nonterminal: "is_terminal x \<Longrightarrow> is_nonterminal x \<Longrightarrow> False"
  by (metis is_symbol_def is_symbol_distinct)

lemma Derives1_leftmost:
  assumes "Derives1 a i r b"
  shows "\<exists> j. leftmost j a \<and> j \<le> i"
proof -
  let ?J = "{j . j < length a \<and> is_nonterminal (a ! j)}"
  let ?M = "Min ?J"
  from assms have J1:"i \<in> ?J"
    apply (auto simp add: Derives1_def is_nonterminal_def)
    by (metis is_nonterminal_def rule_nonterminal_type)
  have J2:"finite ?J" by auto
  note J = J1 J2
  from J have M1: "?M \<in> ?J" by (rule_tac Min_in, auto)
  {
    fix j
    assume "j \<in> ?J"
    with J have "?M \<le> j" by auto
  }
  note M3 = this[OF J1]
  from assms have a_sentence: "is_sentence a" by (simp add: Derives1_sentence1)
  have is_word: "is_word (take ?M a)"
    apply (auto simp add: is_word_def list_all_take)
    proof -
      fix i
      assume i_less_M: "i < ?M"
      assume i_inbounds: "i < length a"
      show "is_terminal (a ! i)"
      proof(cases "is_terminal (a ! i)")
        case True thus ?thesis by auto
      next
        case False
        then have "is_nonterminal (a ! i)"
        using i_inbounds a_sentence is_sentence_symbol is_symbol_distinct by blast
        then have "i \<in> ?J" by (metis i_inbounds mem_Collect_eq)
        then have "?M < i" by (metis J2 Min_le i_less_M leD)
        then have "False" by (metis i_less_M less_asym')
        then show ?thesis by auto
      qed
    qed
  show ?thesis
    apply (rule_tac exI[where x="?M"])
    apply (simp add: leftmost_def)
    by (metis (mono_tags, lifting) M1 M3 is_word mem_Collect_eq)
qed

lemma Derivation_leftmost: "D \<noteq> [] \<Longrightarrow> Derivation a D b \<Longrightarrow> \<exists> i. leftmost i a"
  apply (case_tac "D")
  apply (auto)
  apply (metis Derives1_leftmost)
  done

lemma nonword_has_nonterminal:
  "is_sentence a \<Longrightarrow>  \<not> (is_word a) \<Longrightarrow> \<exists> k. k < length a \<and> is_nonterminal (a ! k)"
  apply (auto simp add: is_sentence_def list_all_iff is_word_def)
  by (metis in_set_conv_nth is_symbol_distinct)

lemma leftmost_cons_nonterminal:
  "is_nonterminal x \<Longrightarrow> leftmost 0 (x#xs)"
by (metis CFG.is_word_def CFG_axioms leftmost_def length_greater_0_conv list.distinct(1)
    list_all_simps(2) nth_Cons_0 take_Cons')

lemma leftmost_cons_terminal:
  "is_terminal x \<Longrightarrow> leftmost i (x#xs) = (i > 0 \<and> leftmost (i - 1) xs)"
  apply(auto simp add: leftmost_def)
  apply(auto simp add: take_Cons' is_terminal_nonterminal nth_Cons' not_gr0)
(* nontermination under new type *)
using Suc_diff_1 Suc_less_eq is_terminal_nonterminal is_word_def leftmost_def length_Cons
    list_all_simps(1)  nth_Cons' take_Cons' apply(auto)
   apply fastforce
  using not_le apply fastforce
  apply (smt (z3) One_nat_def list_all_simps(1))
  by (smt (z3) One_nat_def)

lemma is_nonterminal_cons_terminal:
  "is_terminal x \<Longrightarrow> k < length (x # a) \<Longrightarrow> is_nonterminal ((x # a) ! k) \<Longrightarrow>
   k > 0 \<and> k - 1 < length a \<and> is_nonterminal (a ! (k - 1))"
by (metis One_nat_def Suc_leI is_terminal_nonterminal less_diff_conv2
    list.size(4) nth_non_equal_first_eq)

lemma leftmost_exists:
  "is_sentence a \<Longrightarrow> k < length a \<Longrightarrow> is_nonterminal (a ! k) \<Longrightarrow>
   \<exists> i. leftmost i a \<and> i \<le> k"
proof (induct a arbitrary: k)
  case Nil thus ?case by auto
next
  case (Cons x a)
  show ?case
  proof(cases "is_nonterminal x")
    case True thus ?thesis
      apply(rule_tac exI[where x="0"])
      apply (simp add: leftmost_cons_nonterminal)
      done
  next
    case False
    then have x: "is_terminal x"
      by (metis Cons.prems(1) is_sentence_cons is_symbol_distinct)
    note k = is_nonterminal_cons_terminal[OF x Cons(3) Cons(4)]
    with Cons have "\<exists>i. leftmost i a \<and> i \<le> k - 1" by (metis is_sentence_cons)
    then show ?thesis
      apply (auto simp add: leftmost_cons_terminal[OF x])
      by (metis le_diff_conv2 Suc_leI add_Suc_right add_diff_cancel_right' k
          le_0_eq le_imp_less_Suc nat_le_linear)
  qed
qed

lemma nonword_leftmost_exists:
  "is_sentence a \<Longrightarrow> \<not> (is_word a) \<Longrightarrow> \<exists> i. leftmost i a"
  by (metis leftmost_exists nonword_has_nonterminal)

lemma leftmost_unaffected_Derives1: "leftmost j a \<Longrightarrow> j < i \<Longrightarrow> Derives1 a i r b \<Longrightarrow> leftmost j b"
apply (simp add: leftmost_def)
proof -
  assume a1: "j < length a \<and> is_word (take j a) \<and> is_nonterminal (a ! j)"
  assume a2: "j < i"
  assume "Derives1 a i r b"
  then have f3: "take i a = take i b"
    by (metis Derives1_take)
  have f4: "\<And>n ss ssa. take (length (take n (ss::('a, 'b)symbol list))) (ssa:: ('a, 'b) symbol list) = take (length ss) (take n ssa)"
    by (metis length_take take_take)
  have f5: "\<And>ss. take j (ss::('a, 'b) symbol list) = take i (take j ss)"
    using a2 by (metis dual_order.strict_implies_order min.absorb2 take_take)
  have f6: "length (take j a) = j"
    using a1 by (metis dual_order.strict_implies_order length_take min.absorb2)
  then have f7: "\<And>n. min j n = length (take n (take j a))"
    by (metis length_take)
  have f8: "\<And>n ss. n = length (take n (ss::('a, 'b)symbol list)) \<or> length ss < n"
    by (metis leI length_take min.absorb2)
  have f9: "\<And>ss. take j (ss:: ('a, 'b) symbol list) = take j (take i ss)"
    using f7 f6 f5 by (metis take_take)
  have f10: "\<And>ss n. length (ss::('a, 'b) symbol list) \<le> n \<or> length (take n ss) = n"
    using f8 by (metis dual_order.strict_implies_order)
  then have f11: "\<And>ss ssa. length (ss::('a, 'b)symbol list) = length (take (length ss) (ssa::('a, 'b)symbol list)) \<or> length (take (length ssa) ss) = length ssa"
    by (metis length_take min.absorb2)
  have f12: "\<And>ss ssa n. take (length (ss::('a, 'b)symbol list)) (ssa::('a, 'b)symbol list) = take n (take (length ss) ssa) \<or> length (take n ss) = n"
    using f10 by (metis min.absorb2 take_take)
  { assume "\<not> j < j"
    { assume "\<not> j < j \<and> i \<noteq> j"
      moreover
      { assume "length a \<noteq> j \<and> length (take i a) \<noteq> i"
        then have "\<exists>ss. length (take (length (take i (take (length a) (ss::('a, 'b) symbol list)))) (take j ss)) \<noteq> length (take i (take (length a) ss))"
          using f12 f11 f6 f5 f4 by metis
        then have "\<exists>ss ssa. take (length (ss::('a, 'b) symbol list)) (take j (ssa::('a, 'b) symbol list)) \<noteq> take (length ss) (take i (take (length a) ssa))"
          using f11 by metis
        then have "length b \<noteq> j"
          using f9 f4 f3 by metis }
      ultimately have "length b \<noteq> j"
        using f7 f6 f5 f3 a1 by (metis length_take) }
    then have "length b = j \<longrightarrow> j < j"
      using a2 by metis }
  then have "j < length b"
    using f9 f8 f7 f6 f4 f3 by metis
  then show "j < length b \<and> is_word (take j b) \<and> is_nonterminal (b ! j)"
    using f9 f3 a2 a1 by (metis nth_take)
qed

definition derivation_ge :: "('a, 'b) derivation \<Rightarrow> nat \<Rightarrow> bool"
where
  "derivation_ge D i = (\<forall> d \<in> set D. fst d \<ge> i)"

lemma derivation_ge_cons: "derivation_ge (d#D) i = (fst d \<ge> i \<and> derivation_ge D i)"
  by (auto simp add: derivation_ge_def)

lemma derivation_ge_append:
  "derivation_ge (D@E) i = (derivation_ge D i \<and> derivation_ge E i)"
  by (auto simp add: derivation_ge_def)

lemma leftmost_unaffected_Derivation:
  "derivation_ge D (Suc i) \<Longrightarrow> leftmost i a \<Longrightarrow> Derivation a D b \<Longrightarrow> leftmost i b"
proof (induct D arbitrary: a)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b" by simp
  then obtain x where x1: "Derives1 a (fst d) (snd d) x" and x2: "Derivation x D b" by blast
  with Cons have leftmost_x: "leftmost i x"
    apply (rule_tac leftmost_unaffected_Derives1[
           where a=a and j=i and b="x" and i="fst d" and r="snd d"])
    by (auto simp add: derivation_ge_def)
  with Cons x2 show ?case by (auto simp add: derivation_ge_def)
qed

lemma le_Derives1_take:
  assumes le: "i \<le> j"
  and D: "Derives1 a j r b"
  shows "take i a = take i b"
proof -
  note Derives1_take[where a=a and i=j and r=r and b=b]
  with le D show ?thesis by (rule_tac le_take_same[where i=i and j=j], auto)
qed

lemma Derivation_take: "derivation_ge D i \<Longrightarrow> Derivation a D b \<Longrightarrow> take i a = take i b"
proof(induct D arbitrary: a b)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b"
    by simp
  then obtain x where ax: "Derives1 a (fst d) (snd d) x" and xb: "Derivation x D b" by blast
  from derivation_ge_cons Cons(2) have d: "i \<le> fst d" and D: "derivation_ge D i" by auto
  note take_i_xb = Cons(1)[OF D xb]
  note take_i_ax = le_Derives1_take[OF d ax]
  from take_i_xb take_i_ax show ?case by auto
qed

lemma leftmost_cons_less: "i < length u \<Longrightarrow> leftmost i (u@v) = leftmost i u"
  by (auto simp add: leftmost_def nth_append)

lemma leftmost_is_nonterminal: "leftmost i u \<Longrightarrow> is_nonterminal (u ! i)"
  by (metis leftmost_def)

lemma is_word_is_terminal: "i < length u \<Longrightarrow> is_word u \<Longrightarrow> is_terminal (u ! i)"
  by (metis is_word_def list_all_length)

lemma leftmost_append:
  assumes leftmost: "leftmost i (u@v)"
  and is_word: "is_word u"
  shows "length u \<le> i"
proof (cases "i < length u")
  case False thus ?thesis by auto
next
  case True
  with leftmost have "leftmost i u" using leftmost_cons_less[OF True] by simp
  then have is_nonterminal: "is_nonterminal (u ! i)" by (rule leftmost_is_nonterminal)
  note is_terminal = is_word_is_terminal[OF True is_word]
  note is_terminal_nonterminal[OF is_terminal is_nonterminal]
  then show ?thesis by auto
qed

lemma derivation_ge_empty[simp]: "derivation_ge [] i"
by (simp add: derivation_ge_def)

lemma leftmost_notword: "leftmost i a \<Longrightarrow> j > i \<Longrightarrow> \<not> (is_word (take j a))"
by (metis is_terminal_nonterminal is_word_def leftmost_def list_all_take)

lemma leftmost_unique: "leftmost i a \<Longrightarrow> leftmost j a \<Longrightarrow> i = j"
by (metis leftmost_def leftmost_notword linorder_neqE_nat)

lemma leftmost_Derives1: "leftmost i a \<Longrightarrow> Derives1 a j r b \<Longrightarrow> i \<le> j"
by (metis Derives1_leftmost leftmost_unique)

lemma leftmost_Derives1_propagate:
  assumes leftmost: "leftmost i a"
      and Derives1: "Derives1 a j r b"
    shows "(is_word b \<and> i = j) \<or> (\<exists> k. leftmost k b \<and> i \<le> k)"
proof -
  from leftmost_Derives1[OF leftmost Derives1] have ij: "i \<le> j" by auto
  show ?thesis
  proof (cases "is_word b")
    case True show ?thesis
      by (metis Derives1 True ij le_neq_implies_less leftmost
          leftmost_unaffected_Derives1 order_refl)
  next
    case False show ?thesis
      by (metis (no_types, hide_lams) Derives1 Derives1_bound Derives1_sentence2
          Derives1_take append_take_drop_id ij le_neq_implies_less leftmost
          leftmost_append leftmost_cons_less leftmost_def length_take
          min.absorb2 nat_le_linear nonword_leftmost_exists not_le)
  qed
qed

lemma is_word_Derives1[elim]: "is_word a \<Longrightarrow> Derives1 a i r b \<Longrightarrow> False"
by (metis Derives1_leftmost is_terminal_nonterminal is_word_is_terminal leftmost_def)

lemma is_word_Derivation[elim]: "is_word a \<Longrightarrow> Derivation a D b \<Longrightarrow> D = []"
by (metis Derivation_leftmost is_terminal_nonterminal is_word_def
    leftmost_def list_all_length)

lemma leftmost_Derivation:
  "leftmost i a \<Longrightarrow> Derivation a D b \<Longrightarrow> j \<le> i \<Longrightarrow> derivation_ge D j"
proof (induct D arbitrary: a b i j)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 a (fst d) (snd d) x \<and> Derivation x D b" by auto
  then obtain x where ax:"Derives1 a (fst d) (snd d) x" and xb:"Derivation x D b" by blast
  note ji = Cons(4)
  note i_fstd = leftmost_Derives1[OF Cons(2) ax]
  note disj = leftmost_Derives1_propagate[OF Cons(2) ax]
  thus ?case
  proof(induct rule: disjCases2)
    case 1
    with xb have "D = []" by auto
    with 1 ji show ?case by (simp add: derivation_ge_def)
  next
    case 2
    then obtain k where k: "leftmost k x" and ik: "i \<le> k" by blast
    note ge = Cons(1)[OF k xb, where j=j]
    from ji ik i_fstd ge show ?case
      by (simp add: derivation_ge_cons)
  qed
qed

lemma derivation_ge_list_all: "derivation_ge D i = list_all (\<lambda> d. fst d \<ge> i) D"
by (simp add: Ball_set derivation_ge_def)

lemma split_derivation_leftmost:
  assumes "derivation_ge D i"
  and "\<not> (derivation_ge D (Suc i))"
  shows "\<exists> E F r. D = E@[(i, r)]@F \<and> derivation_ge E (Suc i)"
proof -
  from assms have "\<exists> k. k < length D \<and> fst(D ! k) \<ge> i \<and> \<not>(fst(D ! k) \<ge> Suc i)"
    by (metis derivation_ge_def in_set_conv_nth)
  then have "\<exists> k. k < length D \<and> fst(D ! k) = i" by auto
  then show ?thesis
  proof(induct rule: ex_minimal_witness)
    case (Minimal k)
      then have k_len: "k < length D" and k_i: "fst (D ! k) = i" by auto
      let ?E = "take k D"
      let ?r = "snd (D ! k)"
      let ?F = "drop (Suc k) D"
      note split = split_list_at[OF k_len]
      from k_i have D_k: "D ! k = (i, ?r)" by auto
      show ?case
        apply (rule exI[where x="?E"])
        apply (rule exI[where x="?F"])
        apply (rule exI[where x="?r"])
        apply (subst D_k[symmetric])
        apply (rule conjI)
        apply (rule split)
        by (metis (mono_tags, lifting) Minimal.hyps(2) Suc_leI assms(1)
            derivation_ge_list_all le_neq_implies_less list_all_length list_all_take)
  qed
qed

lemma Derives1_Derives1_swap:
  assumes "i < j"
  and "Derives1 a j p b"
  and "Derives1 b i q c"
  shows "\<exists> b'. Derives1 a i q b' \<and> Derives1 b' (j - 1 + length (snd q)) p c"
proof -
  from Derives1_split[OF assms(2)] obtain a1 a2 where
    a_src: "a = a1 @ [fst p] @ a2" and a_dest: "b = a1 @ snd p @ a2"
    and a1_len: "length a1 = j" by blast
  note a = this
  from a have is_sentence_a1: "is_sentence a1"
    using Derives1_sentence2 assms(2) is_sentence_concat by blast
  from a have is_sentence_a2: "is_sentence a2"
    using Derives1_sentence2 assms(2) is_sentence_concat by blast
  from a have is_symbol_fst_p:  "is_symbol (fst p)"
    by (metis Derives1_sentence1 assms(2) is_sentence_concat is_sentence_cons)
  from Derives1_split[OF assms(3)] obtain b1 b2 where
    b_src: "b = b1 @ [fst q] @ b2" and b_dest: "c = b1 @ snd q @ b2"
    and b1_len: "length b1 = i" by blast
  have a_take_j: "a1 = take j a" by (metis a1_len a_src append_eq_conv_conj)
  have b_take_i: "b1 @ [fst q] = take (Suc i) b"
    by (metis append_assoc append_eq_conv_conj b1_len b_src length_append_singleton)
  from a_take_j b_take_i  take_eq_take_append[where j=j and i="Suc i" and a=a]
  have "\<exists> u. a1 = (b1 @ [fst q]) @ u"
    by (metis le_iff_add Suc_leI a1_len a_dest append_eq_conv_conj assms(1) take_add)
  then obtain u where u1: "a1 = (b1 @ [fst q]) @ u" by blast
  then have j_i_u: "j = i + 1 + length u"
    using Suc_eq_plus1 a1_len b1_len length_append length_append_singleton by auto
  from u1 is_sentence_a1 have is_sentence_b1_u: "is_sentence b1 \<and> is_sentence u"
    using is_sentence_concat by blast
  have u2: "b2 = u @ snd p @ a2" by (metis a_dest append_assoc b_src same_append_eq u1)
  let ?b = "b1 @ (snd q) @ u @ [fst p] @ a2"
  from assms have q_dom: "q \<in> \<RR>" by auto
  have a_b': "Derives1 a i q ?b"
    apply (subst Derives1_def)
    apply (rule exI[where x="b1"])
    apply (rule exI[where x="u@[fst p]@a2"])
    apply (rule exI[where x="fst q"])
    apply (rule exI[where x="snd q"])
    apply (auto simp add: b1_len is_sentence_cons is_sentence_concat
           is_sentence_a2 is_symbol_fst_p is_sentence_b1_u a_src u1 q_dom)
    done
  from assms have p_dom: "p \<in> \<RR>" by auto
  have is_sentence_snd_q: "is_sentence (snd q)"
    using Derives1_sentence2 a_b' is_sentence_concat by blast
  have b'_c: "Derives1 ?b (j - 1 + length (snd q)) p c"
    apply (subst Derives1_def)
    apply (rule exI[where x="b1 @ (snd q) @ u"])
    apply (rule exI[where x="a2"])
    apply (rule exI[where x="fst p"])
    apply (rule exI[where x="snd p"])
    apply (auto simp add: is_sentence_concat is_sentence_b1_u is_sentence_a2 p_dom
           is_sentence_snd_q b_dest u2 b1_len j_i_u)
    done
  show ?thesis
    apply (rule exI[where x="?b"])
    apply (rule conjI)
    apply (rule a_b')
    apply (rule b'_c)
    done
qed

definition derivation_shift :: "('a, 'b) derivation \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a, 'b) derivation"
where
  "derivation_shift D left right = map (\<lambda> d. (fst d - left + right, snd d)) D"

lemma derivation_shift_empty[simp]: "derivation_shift [] left right = []"
  by (auto simp add: derivation_shift_def)

lemma derivation_shift_cons[simp]:
  "derivation_shift (d#D) left right = ((fst d - left + right, snd d)#(derivation_shift D left right))"
by (simp add: derivation_shift_def)

lemma Derivation_append: "Derivation a (D@E) c = (\<exists> b. Derivation a D b \<and> Derivation b E c)"
proof(induct D arbitrary: a c E)
  case Nil thus ?case by auto
next
  case (Cons d D) thus ?case by auto
qed

lemma Derivation_implies_append:
  "Derivation a D b \<Longrightarrow> Derivation b E c \<Longrightarrow> Derivation a (D@E) c"
using Derivation_append by blast

lemma Derivation_swap_single_end_to_front:
  "i < j \<Longrightarrow> derivation_ge D j \<Longrightarrow> Derivation a (D@[(i,r)]) b \<Longrightarrow>
   Derivation a ((i,r)#(derivation_shift D 1 (length (snd r)))) b"
proof(induct D arbitrary: a)
  case Nil thus ?case by auto
next
  case (Cons d D)
  from Cons have "\<exists> c. Derives1 a (fst d) (snd d) c \<and> Derivation c (D @ [(i, r)]) b"
    by simp
  then obtain c where ac: "Derives1 a (fst d) (snd d) c"
    and cb: "Derivation c (D @ [(i, r)]) b" by blast
  from Cons(3) have D_j: "derivation_ge D j" by (simp add: derivation_ge_cons)
  from Cons(1)[OF Cons(2) D_j cb, simplified]
  obtain x where cx: "Derives1 c i r x" and
    xb: "Derivation x (derivation_shift D 1 (length (snd r))) b" by auto
  have i_fst_d: "i < fst d" using Cons derivation_ge_cons by auto
  from Derives1_Derives1_swap[OF i_fst_d ac cx]
  obtain b' where ab': "Derives1 a i r b'" and
    b'x: "Derives1 b' (fst d - 1 + length (snd r)) (snd d) x" by blast
  show ?case using ab' b'x xb by auto
qed

lemma Derivation_swap_single_mid_to_front:
  assumes "i < j"
  and "derivation_ge D j"
  and "Derivation a (D@[(i,r)]@E) b"
  shows "Derivation a ((i,r)#((derivation_shift D 1 (length (snd r)))@E)) b"
proof -
  from assms have "\<exists> x. Derivation a (D@[(i, r)]) x \<and> Derivation x E b"
    using Derivation_append by auto
  then obtain x where ax: "Derivation a (D@[(i, r)]) x" and xb: "Derivation x E b"
    by blast
  with assms have "Derivation a ((i, r)#(derivation_shift D 1 (length (snd r)))) x"
    using Derivation_swap_single_end_to_front by blast
  then show ?thesis using Derivation_append xb by auto
qed

lemma length_derivation_shift[simp]:
  "length(derivation_shift D left right) = length D"
  by (simp add: derivation_shift_def)

definition LeftDerives1 :: "('a, 'b) sentence \<Rightarrow> nat \<Rightarrow> ('a, 'b) rule \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "LeftDerives1 u i r v = (leftmost i u \<and> Derives1 u i r v)"

lemma LeftDerives1_implies_leftderives1: "LeftDerives1 u i r v \<Longrightarrow> leftderives1 u v"

  by (smt (verit, ccfv_SIG) Derives1_def LeftDerives1_def leftderives1_def leftmost_cons_less leftmost_def leftmost_notword nonword_leftmost_exists)
(*by (metis Derives1_def LeftDerives1_def append_eq_conv_conj leftderives1_def
    leftmost_def)
  *)
lemma leftmost_Derives1_leftderives:
  "leftmost i a \<Longrightarrow> Derives1 a i r b \<Longrightarrow> leftderives b c \<Longrightarrow> leftderives a c"
using LeftDerives1_def LeftDerives1_implies_leftderives1
  leftderives1_implies_leftderives leftderives_trans by blast

theorem Derivation_implies_leftderives_gen:
  "Derivation a D (u@v) \<Longrightarrow> is_word u \<Longrightarrow> (\<exists> w.
          leftderives a (u@w) \<and>
          (v = [] \<longrightarrow> w = []) \<and>
          (\<forall> X. is_first X v \<longrightarrow> is_first X w))"
proof (induct "length D" arbitrary: D a u v)
  case 0
    then have "a = u@v" by auto
    thus ?case by (rule_tac x = v in exI, auto)
next
  case (Suc n)
    from Suc have "D \<noteq> []" by auto
    with Suc Derivation_leftmost have "\<exists> i. leftmost i a" by auto
    then obtain i where i: "leftmost i a" by blast
    show "?case"
    proof (cases "derivation_ge D (Suc i)")
      case True
        with Suc have leftmost: "leftmost i (u@v)"
          by (rule_tac leftmost_unaffected_Derivation[OF True i], auto)
        have length_u: "length u \<le> i"
          using leftmost_append[OF leftmost Suc(4)] .
        have take_Suc: "take (Suc i) a = take (Suc i) (u@v)"
          using  Derivation_take[OF True Suc(3)] .
        with length_u have is_prefix_u: "is_prefix u a"
          by (metis append_assoc append_take_drop_id dual_order.strict_implies_order
              is_prefix_def le_imp_less_Suc take_all take_append)
        have a: "u @ drop (length u) a = a"
          using is_prefix_unsplit[OF is_prefix_u] .
        from take_Suc have length_take_Suc: "length (take (Suc i) a) = Suc i"
          by (metis Suc_leI i leftmost_def length_take min.absorb2)
        have v: "v \<noteq> []"
        proof(cases "v = []")
          case False thus ?thesis by auto
        next
          case True
          with length_u have right: "length(take (Suc i) (u@v)) = length u" by simp
          note left = length_take_Suc
          from left right take_Suc have "Suc i = length u" by auto
          with length_u show ?thesis by auto
        qed
        then have "\<exists> X w. v = X#w" by (cases v, auto)
        then obtain X w where v: "v = X#w" by blast
        have is_first_X: "is_first X (drop (length u) a)"
          apply (rule_tac is_first_drop_length[where v=v and w=w and k="Suc i"])
          apply (simp_all add: take_Suc v)
          apply (metis Suc_leI i leftmost_def)
          apply (insert length_u)
          apply arith
          done
        show ?thesis
          apply (rule exI[where x="drop (length u) a"])
          by (simp add: a v is_first_cons is_first_X)
    next
      case False
      have Di: "derivation_ge D i"
      using leftmost_Derivation[OF i Suc(3), where j=i, simplified] .
      from split_derivation_leftmost[OF Di False]
      obtain E F r where D_split: "D = E @ [(i, r)] @ F"
        and E_Suc: "derivation_ge E (Suc i)" by auto
      let ?D = "(derivation_shift E 1 (length (snd r)))@F"
      from D_split
      have "Derivation a ((i,r) # ?D) (u @ v)"
        using Derivation_swap_single_mid_to_front E_Suc Suc.prems(1) lessI by blast
      then have "\<exists> y. Derives1 a i r y \<and> Derivation y ?D (u @ v)" by simp
      then obtain y where ay:"Derives1 a i r y"
        and yuv: "Derivation y ?D (u @ v)" by blast
      have length_D': "length ?D = n" using D_split Suc.hyps(2) by auto
      from Suc(1)[OF length_D'[symmetric] yuv Suc(4)]
      obtain w where "leftderives y (u @ w)" and "(v = [] \<longrightarrow> w = [])"
        and "\<forall>X. is_first X v \<longrightarrow> is_first X w" by blast
      then show ?thesis using ay i leftmost_Derives1_leftderives by blast
    qed
qed

lemma derives_implies_leftderives_gen: "derives a (u@v) \<Longrightarrow> is_word u \<Longrightarrow> (\<exists> w.
          leftderives a (u@w) \<and>
          (v = [] \<longrightarrow> w = []) \<and>
          (\<forall> X. is_first X v \<longrightarrow> is_first X w))"
using Derivation_implies_leftderives_gen derives_implies_Derivation by blast

lemma derives_implies_leftderives: "derives a b \<Longrightarrow> is_word b \<Longrightarrow> leftderives a b"
using derives_implies_leftderives_gen by force

fun LeftDerivation :: " ('a, 'b) sentence \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "LeftDerivation a [] b = (a = b)"
| "LeftDerivation a (d#D) b = (\<exists> x. LeftDerives1 a (fst d) (snd d) x \<and> LeftDerivation x D b)"

lemma LeftDerives1_implies_Derives1: "LeftDerives1 a i r b \<Longrightarrow> Derives1 a i r b"
by (metis LeftDerives1_def)

lemma LeftDerivation_implies_Derivation:
  "LeftDerivation a D b \<Longrightarrow> Derivation a D b"
proof (induct D arbitrary: a)
  case (Nil) thus ?case by simp
next
  case (Cons d D)
  thus ?case
  using CFG.LeftDerivation.simps(2) CFG_axioms Derivation.simps(2)
    LeftDerives1_implies_Derives1 by metis
qed

lemma LeftDerivation_implies_leftderives: "LeftDerivation a D b \<Longrightarrow> leftderives a b"
proof (induct D arbitrary: a b)
  case Nil thus ?case by simp
next
  case (Cons d D)
    note ihyps = this
    from ihyps have "\<exists> x. LeftDerives1 a (fst d) (snd d) x \<and> LeftDerivation x D b" by auto
    then obtain x where "LeftDerives1 a (fst d) (snd d) x" and xb: "LeftDerivation x D b" by blast
    with LeftDerives1_implies_leftderives1 have d1: "leftderives a x" by auto
    from ihyps xb have d2:"leftderives x b" by simp
    show "leftderives a b" by (rule leftderives_trans[OF d1 d2])
qed

lemma leftmost_witness[simp]: "leftmost (length x) (x@(N#y)) = (is_word x \<and> is_nonterminal N)"
  by (auto simp add: leftmost_def)

lemma leftderives1_implies_LeftDerives1:
  assumes leftderives1: "leftderives1 u v"
  shows "\<exists> i r. LeftDerives1 u i r v"
proof -
  from leftderives1 have
    "\<exists>x y N \<alpha>. u = x @ [N] @ y \<and> v = x @ \<alpha> @ y \<and> is_word x \<and> is_sentence y \<and> (N, \<alpha>) \<in> \<RR>"
    by (simp add: leftderives1_def)
  then obtain x y N \<alpha> where
    u:"u = x @ [N] @ y" and
    v:"v = x @ \<alpha> @ y" and
    x:"is_word x" and
    y:"is_sentence y" and
    r:"(N, \<alpha>) \<in> \<RR>"
    by blast
  show ?thesis
    apply (rule_tac x="length x" in exI)
    apply (rule_tac x="(N, \<alpha>)" in exI)
    apply (auto simp add: LeftDerives1_def)
    apply (simp add: leftmost_def x u rule_nonterminal_type[OF r])
    apply (simp add: Derives1_def u v)
    apply (rule_tac x=x in exI)
    apply (rule_tac x=y in exI)
    apply (auto simp add: x y r)
    done
qed

lemma LeftDerivation_LeftDerives1:
  "LeftDerivation a S y \<Longrightarrow> LeftDerives1 y i r z \<Longrightarrow> LeftDerivation a (S@[(i,r)]) z"
proof (induct S arbitrary: a y z i r)
  case Nil thus ?case by simp
next
  case (Cons s S) thus ?case
    by (metis LeftDerivation.simps(2) append_Cons)
qed

lemma leftderives_implies_LeftDerivation: "leftderives a b \<Longrightarrow> \<exists> D. LeftDerivation a D b"
proof (induct rule: leftderives_induct)
  case Base
  show ?case by (rule exI[where x="[]"], simp)
next
  case (Step y z)
  note ihyps = this
  from ihyps obtain D where ay: "LeftDerivation a D y" by blast
  from ihyps leftderives1_implies_LeftDerives1 obtain i r where yz: "LeftDerives1 y i r z" by blast
  from LeftDerivation_LeftDerives1[OF ay yz] show ?case by auto
qed

lemma LeftDerivation_append:
  "LeftDerivation a (D@E) c = (\<exists> b. LeftDerivation a D b \<and> LeftDerivation b E c)"
proof(induct D arbitrary: a c E)
  case Nil thus ?case by auto
next
  case (Cons d D) thus ?case by auto
qed

lemma LeftDerivation_implies_append:
  "LeftDerivation a D b \<Longrightarrow> LeftDerivation b E c \<Longrightarrow> LeftDerivation a (D@E) c"
using LeftDerivation_append by blast

lemma Derivation_unique_dest: "Derivation a D b \<Longrightarrow> Derivation a D c \<Longrightarrow> b = c"
  apply (induct D arbitrary: a b c)
  apply auto
  using Derives1_unique_dest by blast

lemma Derivation_unique_src: "Derivation a D c \<Longrightarrow> Derivation b D c \<Longrightarrow> a = b"
  apply (induct D arbitrary: a b c)
  apply auto
  using Derives1_unique_src by blast

lemma LeftDerives1_unique: "LeftDerives1 a i r b \<Longrightarrow> LeftDerives1 a j s b \<Longrightarrow> i = j \<and> r = s"
using Derives1_def LeftDerives1_def leftmost_unique by auto

lemma leftlang: "\<L> = { v | v. is_word v \<and> is_leftderivation v }"
by (metis (no_types, lifting) CFG.is_derivation_def CFG.is_leftderivation_def
    CFG.leftderivation_implies_derivation CFG_axioms Collect_cong
    \<L>_def derives_implies_leftderives)

lemma leftprefixlang:  "\<L>\<^sub>P = { u | u v. is_word u \<and> is_leftderivation (u@v) }"
apply (auto simp add: \<L>\<^sub>P_def)
using derives_implies_leftderives_gen is_derivation_def is_leftderivation_def apply blast
using leftderivation_implies_derivation by blast

lemma derives_implies_leftderives_cons:
  "is_word a \<Longrightarrow> derives u (a@X#b) \<Longrightarrow> \<exists> c. leftderives u  (a@X#c)"
by (metis append_Cons append_Nil derives_implies_leftderives_gen is_first_def)

lemma is_word_append[simp]: "is_word (a@b) = (is_word a \<and> is_word b)"
  by (auto simp add: is_word_def)

lemma \<L>\<^sub>P_split: "a@b \<in> \<L>\<^sub>P \<Longrightarrow> a \<in> \<L>\<^sub>P"
  by (auto simp add: \<L>\<^sub>P_def)

lemma \<L>\<^sub>P_is_word: "a \<in> \<L>\<^sub>P \<Longrightarrow> is_word a"
  by (metis (no_types, lifting) leftprefixlang mem_Collect_eq)

definition Derive :: "('a, 'b) sentence \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) sentence"
where
  "Derive a D = (THE b. Derivation a D b)"

lemma Derivation_dest_ex_unique: "Derivation a D b \<Longrightarrow> \<exists>! x. Derivation a D x"
using CFG.Derivation_unique_dest CFG_axioms by fast

lemma Derive:
  assumes ab: "Derivation a D b"
  shows "Derive a D = b"
proof -
  note the1_equality[OF Derivation_dest_ex_unique[OF ab] ab]
  thus ?thesis by (simp add: Derive_def)
qed

end

end


section \<open>Basic Lemma Library\<close>

theory Util
imports Main
begin

(* remove - is in Isabelle after 2021-1 *)
lemma tl_append_if: "tl (xs @ ys) = (if xs = [] then tl ys else tl xs @ ys)"
  by (simp)

lemma take_last_length: "\<lbrakk>take (Suc 0) (rev xs) = [last xs]\<rbrakk> \<Longrightarrow> Suc 0 \<le> length xs"
  by(induction xs) auto

lemma take_last: "xs \<noteq> [] \<Longrightarrow> take 1 (rev xs) = [last xs]"
  by(induction xs)(auto simp: take_last_length)

lemma take_hd [simp]: "xs \<noteq> [] \<Longrightarrow> take (Suc 0) xs = [hd xs]"
  by(induction xs) auto

lemma cons_tl: "x # xs = ys \<Longrightarrow> xs = tl ys"
  by auto

lemma cons_hd: "x # xs = ys \<Longrightarrow> x = hd ys"
  by auto

lemma take_hd': "ys \<noteq> [] \<Longrightarrow> take (size ys) (x # xs) = take (Suc (size xs)) ys \<Longrightarrow> hd ys = x"
  by(induction ys) auto

lemma rev_app_single: "rev xs @ [x] = rev (x # xs)"
  by auto

lemma hd_drop_1 [simp]: "xs \<noteq> [] \<Longrightarrow> hd xs # drop (Suc 0) xs = xs"
  by(induction xs) auto

lemma hd_drop [simp]: "n < length xs \<Longrightarrow> hd (drop n xs) # drop (Suc n) xs = drop n xs"
  by(induction xs)(auto simp: list.expand tl_drop)

lemma take_1: "0 < x \<and> 0 < y \<Longrightarrow> take x xs  = take y ys \<Longrightarrow> take 1 xs = take 1 ys"
  by (metis One_nat_def bot_nat_0.not_eq_extremum hd_take take_Suc take_eq_Nil)

lemma last_drop_rev: "xs \<noteq> [] \<Longrightarrow> last xs # drop 1 (rev xs) = rev xs"
  by (metis One_nat_def hd_drop_1 hd_rev rev.simps(1) rev_rev_ident)

lemma Suc_min [simp]: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> Suc (min (x - Suc 0) (y - Suc 0)) = min x y"
  by auto

lemma rev_tl_hd: "xs \<noteq> [] \<Longrightarrow> rev (tl xs) @ [hd xs] = rev xs"
  by (simp add: rev_app_single)

lemma app_rev: "as @ rev bs = cs @ rev ds \<Longrightarrow> bs @ rev as = ds @ rev cs"
  by (metis rev_append rev_rev_ident)

lemma tl_drop_2: "tl (drop n xs) = drop (Suc n) xs"
  by (simp add: drop_Suc tl_drop)

lemma Suc_sub: "Suc n = m \<Longrightarrow> n = m - 1"
  by simp

lemma length_one_hd: "length xs = 1 \<Longrightarrow> xs = [hd xs]"
  by(induction xs) auto

end


theory T170
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory T107
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T70
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T172
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end