(* Title:      A formalisation of the Cocke-Younger-Kasami algorithm
   Author:     Maksym Bortin <Maksym.Bortin@nicta.com.au>
*)

theory CYK
imports Main
begin

text \<open>The theory is structured as follows. First section deals with modelling
      of grammars, derivations, and the language semantics. Then the basic
      properties are proved. Further, CYK is abstractly specified and its
      underlying recursive relationship proved. The final section contains a
      prototypical implementation accompanied by a proof of its correctness.\<close>

section "Basic modelling"

subsection "Grammars in Chomsky normal form"

text "A grammar in Chomsky normal form is here simply modelled
      by a list of production rules (the type CNG below), each having a non-terminal
      symbol on the lhs and either two non-terminals or one terminal
      symbol on the rhs."

datatype ('n, 't) RHS = Branch 'n 'n
                      | Leaf 't

type_synonym ('n, 't) CNG = "('n \<times> ('n, 't) RHS) list"

text "Abbreviating the list append symbol for better readability"
abbreviation list_append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "\<cdot>" 65)
where "xs \<cdot> ys \<equiv> xs @ ys"

subsection "Derivation by grammars"

text\<open>A \emph{word form} (or sentential form) may be built of both non-terminal and terminal
       symbols, as opposed to a \emph{word} that contains only terminals. By the usage of disjoint
       union, non-terminals are injected into a word form by @{term "Inl"} whereas terminals --
       by @{term "Inr"}.\<close>
type_synonym ('n, 't) word_form = "('n + 't) list"
type_synonym 't word = "'t list"

text "A single step derivation relation on word forms is induced by a grammar in the standard way,
      replacing a non-terminal within a word form in accordance to the production rules."
definition DSTEP :: "('n, 't) CNG \<Rightarrow> (('n, 't) word_form \<times> ('n, 't) word_form) set"
where "DSTEP G = {(l \<cdot> [Inl N] \<cdot> r, x) | l N r rhs x. (N, rhs) \<in> set G \<and>
                                     (case rhs of
                                       Branch A B \<Rightarrow> x = l \<cdot> [Inl A, Inl B] \<cdot> r
                                     | Leaf t \<Rightarrow> x = l \<cdot> [Inr t] \<cdot> r)}"

abbreviation DSTEP'  :: "('n, 't) word_form \<Rightarrow> ('n, 't) CNG \<Rightarrow> ('n, 't) word_form \<Rightarrow> bool" ("_ -_\<rightarrow> _" [60, 61, 60] 61)
where "w -G\<rightarrow> w' \<equiv> (w, w') \<in> DSTEP G"

abbreviation DSTEP_reflc  :: "('n, 't) word_form \<Rightarrow> ('n, 't) CNG \<Rightarrow> ('n, 't) word_form \<Rightarrow> bool" ("_ -_\<rightarrow>\<^sup>= _" [60, 61, 60] 61)
where "w -G\<rightarrow>\<^sup>= w' \<equiv> (w, w') \<in> (DSTEP G)\<^sup>="

abbreviation DSTEP_transc  :: "('n, 't) word_form \<Rightarrow> ('n, 't) CNG \<Rightarrow> ('n, 't) word_form \<Rightarrow> bool" ("_ -_\<rightarrow>\<^sup>+ _" [60, 61, 60] 61)
where "w -G\<rightarrow>\<^sup>+ w' \<equiv> (w, w') \<in> (DSTEP G)\<^sup>+"

abbreviation DSTEP_rtransc  :: "('n, 't) word_form \<Rightarrow> ('n, 't) CNG \<Rightarrow> ('n, 't) word_form \<Rightarrow> bool" ("_ -_\<rightarrow>\<^sup>* _" [60, 61, 60] 61)
where "w -G\<rightarrow>\<^sup>* w' \<equiv> (w, w') \<in> (DSTEP G)\<^sup>*"

subsection "The generated language semantics"

text "The language generated by a grammar from a non-terminal symbol
      comprises all words that can be derived from the non-terminal
      in one or more steps.
      Notice that by the presented grammar modelling, languages containing
      the empty word cannot be generated. Hence in rare situations when such
      languages are required, the empty word case should be treated separately."
definition Lang :: "('n, 't) CNG \<Rightarrow> 'n \<Rightarrow> 't word set"
where "Lang G S = {w. [Inl S] -G\<rightarrow>\<^sup>+ map Inr w }"

text\<open>So, for instance, a grammar generating the language $a^nb^n$
       from the non-terminal @{term "''S''"} might look as follows.\<close>
definition "G_anbn =
[(''S'', Branch ''A'' ''T''),
 (''S'', Branch ''A'' ''B''),
 (''T'', Branch ''S'' ''B''),
 (''A'', Leaf ''a''),
 (''B'', Leaf ''b'')]"

text\<open>Now the term @{term "Lang G_anbn ''S''"} denotes the set of words of
       the form $a^nb^n$ with $n > 0$. This is intuitively clear, but not
       straight forward to show, and a lengthy proof for that is out of scope.\<close>

section "Basic properties"

lemma prod_into_DSTEP1 :
"(S, Branch A B) \<in> set G \<Longrightarrow>
 L \<cdot> [Inl S] \<cdot> R -G\<rightarrow> L \<cdot> [Inl A, Inl B] \<cdot> R"
by(simp add: DSTEP_def, rule_tac x="L" in exI, force)

lemma prod_into_DSTEP2 :
"(S, Leaf a) \<in> set G \<Longrightarrow>
 L \<cdot> [Inl S] \<cdot> R -G\<rightarrow> L \<cdot> [Inr a] \<cdot> R"
by(simp add: DSTEP_def, rule_tac x="L" in exI, force)

lemma DSTEP_D :
"s -G\<rightarrow> t \<Longrightarrow>
 \<exists>L N R rhs. s = L \<cdot> [Inl N] \<cdot> R \<and> (N, rhs) \<in> set G \<and>
 (\<forall>A B. rhs = Branch A B \<longrightarrow> t = L \<cdot> [Inl A, Inl B] \<cdot> R) \<and>
 (\<forall>x. rhs = Leaf x \<longrightarrow> t = L \<cdot> [Inr x] \<cdot> R)"
by(unfold DSTEP_def, clarsimp, simp split: RHS.split_asm, blast+)

lemma DSTEP_append :
assumes a: "s -G\<rightarrow> t"
shows "L  \<cdot>  s  \<cdot>  R -G\<rightarrow> L  \<cdot>  t  \<cdot>  R"
proof -
 from a have "\<exists>l N r rhs. s = l \<cdot> [Inl N] \<cdot> r \<and> (N, rhs) \<in> set G \<and>
                         (\<forall>A B. rhs = Branch A B \<longrightarrow> t = l \<cdot> [Inl A, Inl B] \<cdot> r) \<and>
                         (\<forall>x. rhs = Leaf x \<longrightarrow> t = l \<cdot> [Inr x] \<cdot> r)" (is "\<exists>l N r rhs. ?P l N r rhs")
 by(rule DSTEP_D)
 then obtain l N r rhs where "?P l N r rhs" by blast
 thus ?thesis
 by(simp add: DSTEP_def, rule_tac x="L \<cdot> l" in exI,
    rule_tac x=N in exI, rule_tac x="r \<cdot> R" in exI,
    simp, rule_tac x=rhs in exI, simp split: RHS.split)
qed

lemma DSTEP_star_mono :
"s -G\<rightarrow>\<^sup>* t \<Longrightarrow> length s \<le> length t"
proof(erule rtrancl_induct, simp)
 fix t u
 assume "s -G\<rightarrow>\<^sup>* t"
 assume a: "t -G\<rightarrow> u"
 assume b: "length s \<le> length t"
 show "length s \<le> length u"
 proof -
  from a have "\<exists>L N R rhs. t = L \<cdot> [Inl N] \<cdot> R \<and> (N, rhs) \<in> set G \<and>
                          (\<forall>A B. rhs = Branch A B \<longrightarrow> u = L \<cdot> [Inl A, Inl B] \<cdot> R) \<and>
                          (\<forall>x. rhs = Leaf x \<longrightarrow> u = L \<cdot> [Inr x] \<cdot> R)" (is "\<exists>L N R rhs. ?P L N R rhs")
  by(rule DSTEP_D)
  then obtain L N R rhs where "?P L N R rhs" by blast
  with b show ?thesis
  by(case_tac rhs, clarsimp+)
 qed
qed

lemma DSTEP_comp :
assumes a: "l \<cdot> r -G\<rightarrow> t"
shows "\<exists>l' r'. l -G\<rightarrow>\<^sup>= l' \<and> r -G\<rightarrow>\<^sup>= r' \<and> t = l' \<cdot> r'"
proof -
 from a have "\<exists>L N R rhs. l \<cdot> r = L \<cdot> [Inl N] \<cdot> R \<and> (N, rhs) \<in> set G \<and>
                         (\<forall>A B. rhs = Branch A B \<longrightarrow> t = L \<cdot> [Inl A, Inl B] \<cdot> R) \<and>
                        (\<forall>x. rhs = Leaf x \<longrightarrow> t = L \<cdot> [Inr x] \<cdot> R)" (is "\<exists>L N R rhs. ?T L N R rhs")
 by(rule DSTEP_D)
 then obtain L N R rhs where b: "?T L N R rhs" by blast
 hence "l \<cdot> r = L \<cdot> Inl N # R" by simp
 hence "\<exists>u. (l = L \<cdot> u \<and> u \<cdot> r = Inl N # R) \<or> (l \<cdot> u = L \<and> r = u \<cdot> Inl N # R)" by(rule append_eq_append_conv2[THEN iffD1])
 then obtain xs where c: "l = L \<cdot> xs \<and> xs \<cdot> r = Inl N # R \<or> l \<cdot> xs = L \<and> r = xs  \<cdot>  Inl N # R" (is "?C1 \<or> ?C2") by blast
 show ?thesis
 proof(cases rhs)
    case (Leaf x)
    with b have d: "t = L \<cdot> [Inr x] \<cdot> R \<and> (N, Leaf x) \<in> set G" by simp
    from c show ?thesis
    proof
     assume e: "?C1"
     show ?thesis
     proof(cases xs)
      case Nil with d and e show ?thesis
      by(clarsimp, rule_tac x=L in exI, simp add: DSTEP_def, simp split: RHS.split, blast)
     next
      case (Cons z zs) with d and e show ?thesis
      by(rule_tac x="L \<cdot> Inr x # zs" in exI, clarsimp, simp add: DSTEP_def, simp split: RHS.split, blast)
     qed
    next
     assume e: "?C2"
     show ?thesis
     proof(cases xs)
      case Nil with d and e show ?thesis
      by(rule_tac x=L in exI, clarsimp, simp add: DSTEP_def, simp split: RHS.split, blast)
     next
      case (Cons z zs) with d and e show ?thesis
      by(rule_tac x="l" in exI, clarsimp, simp add: DSTEP_def, simp split: RHS.split,
         rule_tac x="z#zs" in exI, rule_tac x=N in exI, rule_tac x=R in exI, simp, rule_tac x="Leaf x" in exI, simp)
     qed
    qed
 next
    case (Branch A B)
    with b have d: "t = L \<cdot> [Inl A, Inl B] \<cdot> R \<and> (N, Branch A B) \<in> set G" by simp
    from c show ?thesis
    proof
     assume e: "?C1"
     show ?thesis
     proof(cases xs)
      case Nil with d and e show ?thesis
      by(clarsimp, rule_tac x=L in exI, simp add: DSTEP_def, simp split: RHS.split, blast)
     next
      case (Cons z zs) with d and e show ?thesis
      by(rule_tac x="L \<cdot> [Inl A, Inl B] \<cdot> zs" in exI, clarsimp, simp add: DSTEP_def, simp split: RHS.split, blast)
     qed
    next
     assume e: "?C2"
     show ?thesis
     proof(cases xs)
      case Nil with d and e show ?thesis
      by(rule_tac x=L in exI, clarsimp, simp add: DSTEP_def, simp split: RHS.split, blast)
     next
      case (Cons z zs) with d and e show ?thesis
      by(rule_tac x="l" in exI, clarsimp, simp add: DSTEP_def, simp split: RHS.split,
         rule_tac x="z#zs" in exI, rule_tac x=N in exI, rule_tac x=R in exI, simp, rule_tac x="Branch A B" in exI, simp)
     qed
   qed
 qed
qed

theorem DSTEP_star_comp1 :
assumes A: "l \<cdot> r -G\<rightarrow>\<^sup>* t"
shows "\<exists>l' r'. l -G\<rightarrow>\<^sup>* l' \<and> r -G\<rightarrow>\<^sup>* r' \<and> t = l' \<cdot> r'"
proof -
 have "\<And>s. s -G\<rightarrow>\<^sup>* t \<Longrightarrow>
       \<forall>l r. s = l \<cdot> r \<longrightarrow> (\<exists>l' r'. l -G\<rightarrow>\<^sup>* l' \<and> r -G\<rightarrow>\<^sup>* r' \<and> t = l' \<cdot> r')" (is "\<And>s. ?P s t \<Longrightarrow> ?Q s t")
 proof(erule rtrancl_induct, force)
  fix s t u
  assume "?P s t"
  assume a: "t -G\<rightarrow> u"
  assume b: "?Q s t"
  show "?Q s u"
  proof(clarify)
   fix l r
   assume "s = l \<cdot> r"
   with b have "\<exists>l' r'. l -G\<rightarrow>\<^sup>* l' \<and> r -G\<rightarrow>\<^sup>* r' \<and> t = l' \<cdot> r'" by simp
   then obtain l' r' where c: "l -G\<rightarrow>\<^sup>* l' \<and> r -G\<rightarrow>\<^sup>* r' \<and> t = l' \<cdot> r'" by blast
   with a have "l' \<cdot> r' -G\<rightarrow> u" by simp
   hence "\<exists>l'' r''. l' -G\<rightarrow>\<^sup>=  l'' \<and> r' -G\<rightarrow>\<^sup>= r'' \<and> u = l'' \<cdot> r''" by(rule DSTEP_comp)
   then obtain l'' r'' where "l' -G\<rightarrow>\<^sup>=  l'' \<and> r' -G\<rightarrow>\<^sup>= r'' \<and> u = l'' \<cdot> r''" by blast
   hence "l' -G\<rightarrow>\<^sup>* l'' \<and> r' -G\<rightarrow>\<^sup>* r'' \<and> u = l'' \<cdot> r''" by blast
   with c show "\<exists>l' r'. l -G\<rightarrow>\<^sup>* l' \<and> r -G\<rightarrow>\<^sup>* r' \<and> u = l' \<cdot> r'"
   by(rule_tac x=l'' in exI, rule_tac x=r'' in exI, force)
  qed
 qed
with A show ?thesis by force
qed

theorem DSTEP_star_comp2 :
assumes A: "l -G\<rightarrow>\<^sup>* l'"
    and B: "r -G\<rightarrow>\<^sup>* r'"
shows "l \<cdot> r -G\<rightarrow>\<^sup>* l' \<cdot> r'"
proof -
 have "l -G\<rightarrow>\<^sup>* l' \<Longrightarrow>
       \<forall>r r'. r -G\<rightarrow>\<^sup>* r' \<longrightarrow> l \<cdot> r -G\<rightarrow>\<^sup>* l' \<cdot> r'" (is "?P l l' \<Longrightarrow> ?Q l l'")
 proof(erule rtrancl_induct)
  show "?Q l l"
  proof(clarify, erule rtrancl_induct, simp)
   fix r s t
   assume a: "s -G\<rightarrow> t"
   assume b: "l \<cdot> r -G\<rightarrow>\<^sup>* l \<cdot> s"
   show "l \<cdot> r -G\<rightarrow>\<^sup>* l \<cdot> t"
   proof -
    from a have "l \<cdot> s -G\<rightarrow> l \<cdot> t" by(drule_tac L=l and R="[]" in DSTEP_append, simp)
    with b show ?thesis by simp
   qed
  qed
 next
   fix s t
   assume a: "s -G\<rightarrow> t"
   assume b: "?Q l s"
   show "?Q l t"
   proof(clarsimp)
    fix r r'
    assume "r -G\<rightarrow>\<^sup>* r'"
    with b have c: "l \<cdot> r -G\<rightarrow>\<^sup>* s \<cdot> r'" by simp
    from a have "s \<cdot> r' -G\<rightarrow> t \<cdot> r'" by(drule_tac L="[]" and R=r' in DSTEP_append, simp)
    with c show "l \<cdot> r -G\<rightarrow>\<^sup>* t \<cdot> r'" by simp
   qed
  qed
 with A and B show ?thesis by simp
qed

lemma DSTEP_trancl_term :
assumes A: "[Inl S] -G\<rightarrow>\<^sup>+ t"
    and B: "Inr x \<in> set t"
 shows "\<exists>N. (N, Leaf x) \<in> set G"
proof -
 have "[Inl S] -G\<rightarrow>\<^sup>+ t \<Longrightarrow>
       \<forall>x. Inr x \<in> set t \<longrightarrow> (\<exists>N. (N, Leaf x) \<in> set G)" (is "?P t \<Longrightarrow> ?Q t")
 proof(erule trancl_induct)
  fix t
  assume a: "[Inl S] -G\<rightarrow> t"
  show "?Q t"
  proof -
   from a have "\<exists>rhs. (S, rhs) \<in> set G \<and>
                      (\<forall>A B. rhs = Branch A B \<longrightarrow> t = [Inl A, Inl B]) \<and>
                      (\<forall>x. rhs = Leaf x \<longrightarrow> t = [Inr x])" (is "\<exists>rhs. ?P rhs")
   by(simp add: DSTEP_def, clarsimp, simp split: RHS.split_asm, case_tac l, force, simp,
      clarsimp, simp split: RHS.split_asm, case_tac l, force, simp)
   then obtain rhs where "?P rhs" by blast
   thus ?thesis
   by(case_tac rhs, clarsimp, force)
  qed
 next
  fix s t
  assume a: "s -G\<rightarrow> t"
  assume b: "?Q s"
  show "?Q t"
  proof -
   from a have "\<exists>L N R rhs. s = L \<cdot> [Inl N] \<cdot> R \<and> (N, rhs) \<in> set G \<and>
                         (\<forall>A B. rhs = Branch A B \<longrightarrow> t = L \<cdot> [Inl A, Inl B] \<cdot> R) \<and>
                         (\<forall>x. rhs = Leaf x \<longrightarrow> t = L \<cdot> [Inr x] \<cdot> R)" (is "\<exists>L N R rhs. ?P L N R rhs")
   by(rule DSTEP_D)
   then obtain L N R rhs where "?P L N R rhs" by blast
   with b show ?thesis
   by(case_tac rhs, clarsimp, force)
  qed
 qed
 with A and B show ?thesis by simp
qed

subsection "Properties of generated languages"

lemma Lang_no_Nil :
"w \<in> Lang G S \<Longrightarrow> w \<noteq> []"
by(simp add: Lang_def, drule trancl_into_rtrancl, drule DSTEP_star_mono, force)

lemma Lang_rtrancl_eq :
"(w \<in> Lang G S) = [Inl S] -G\<rightarrow>\<^sup>* map Inr w"          (is "?L = (?p \<in> ?R\<^sup>*)")
proof(simp add: Lang_def, rule iffI, erule trancl_into_rtrancl)
 assume "?p \<in> ?R\<^sup>*"
 hence "?p \<in> (?R\<^sup>+)\<^sup>=" by(subst rtrancl_trancl_reflcl[THEN sym], assumption)
 hence "[Inl S] = map Inr w \<or> ?p \<in> ?R\<^sup>+" by force
 thus "?p \<in> ?R\<^sup>+" by(case_tac w, simp_all)
qed

lemma Lang_term :
"w \<in> Lang G S \<Longrightarrow>
 \<forall>x \<in> set w. \<exists>N. (N, Leaf x) \<in> set G"
by(clarsimp simp add: Lang_def, drule DSTEP_trancl_term,
   simp, erule imageI, assumption)

lemma Lang_eq1 :
"([x] \<in> Lang G S) = ((S, Leaf x) \<in> set G)"
proof(simp add: Lang_def, rule iffI, subst (asm) trancl_unfold_left, clarsimp)
 fix t
 assume a: "[Inl S] -G\<rightarrow> t"
 assume b: "t -G\<rightarrow>\<^sup>* [Inr x]"
 note DSTEP_star_mono[OF b, simplified]
 hence c: "length t \<le> 1" by simp
 have "\<exists>z. t = [z]"
 proof(cases t)
  assume "t = []"
  with b have d: "[] -G\<rightarrow>\<^sup>* [Inr x]" by simp
  have "\<And>s. ([], s) \<in> (DSTEP G)\<^sup>* \<Longrightarrow> s = []"
  by(erule rtrancl_induct, simp_all, drule DSTEP_D, clarsimp)
  note this[OF d]
  thus ?thesis by simp
 next
  fix z zs
  assume "t = z#zs"
  with c show ?thesis by force
 qed
 with a have "\<exists>z. (S, Leaf z) \<in> set G \<and> t = [Inr z]"
 by(clarsimp simp add: DSTEP_def, simp split: RHS.split_asm, case_tac l, simp_all)
 with b show "(S, Leaf x) \<in> set G"
 proof(clarsimp)
  fix z
  assume c: "(S, Leaf z) \<in> set G"
  assume "[Inr z] -G\<rightarrow>\<^sup>* [Inr x]"
  hence "([Inr z], [Inr x]) \<in> ((DSTEP G)\<^sup>+)\<^sup>=" by simp
  hence "[Inr z] = [Inr x] \<or> [Inr z] -G\<rightarrow>\<^sup>+ [Inr x]" by force
  hence "x = z"
  proof
   assume "[Inr z] = [Inr x]" thus ?thesis by simp
  next
   assume "[Inr z] -G\<rightarrow>\<^sup>+ [Inr x]"
   hence "\<exists>u. [Inr z] -G\<rightarrow> u \<and> u -G\<rightarrow>\<^sup>* [Inr x]" by(subst (asm) trancl_unfold_left, force)
   then obtain u where "[Inr z] -G\<rightarrow> u" by blast
   thus ?thesis by(clarsimp simp add: DSTEP_def, case_tac l, simp_all)
  qed
  with c show ?thesis by simp
 qed
next
 assume a: "(S, Leaf x) \<in> set G"
 show "[Inl S] -G\<rightarrow>\<^sup>+ [Inr x]"
 by(rule r_into_trancl, simp add: DSTEP_def, rule_tac x="[]" in exI,
    rule_tac x="S" in exI, rule_tac x="[]" in exI, simp, rule_tac x="Leaf x" in exI,
    simp add: a)
qed

theorem Lang_eq2 :
"(w \<in> Lang G S \<and> 1 < length w) =
 (\<exists>A B. (S, Branch A B) \<in> set G \<and> (\<exists>l r. w = l \<cdot> r \<and> l \<in> Lang G A \<and> r \<in> Lang G B))"
(is "?L = ?R")
proof(rule iffI, clarify, subst (asm) Lang_def, simp, subst (asm) trancl_unfold_left, clarsimp)
  have map_Inr_split : "\<And>xs. \<forall>zs w. map Inr w = xs \<cdot> zs \<longrightarrow>
                       (\<exists>u v. w = u \<cdot> v \<and> xs = map Inr u \<and> zs = map Inr v)"
  by(induct_tac xs, simp, force)
  fix t
  assume a: "Suc 0 < length w"
  assume b: "[Inl S] -G\<rightarrow> t"
  assume c: "t -G\<rightarrow>\<^sup>* map Inr w"
  from b have  "\<exists>A B. (S, Branch A B) \<in> set G \<and> t = [Inl A, Inl B]"
  proof(simp add: DSTEP_def, clarify, case_tac l, simp_all, simp split: RHS.split_asm, clarify)
   fix x
   assume "t = [Inr x]"
   with c have d: "[Inr x] -G\<rightarrow>\<^sup>* map Inr w"by simp
   have "\<And>x s. [Inr x] -G\<rightarrow>\<^sup>* s \<Longrightarrow> s = [Inr x]"
   by(erule rtrancl_induct, simp_all, drule DSTEP_D, clarsimp, case_tac L, simp_all)
   note this[OF d]
   hence "w = [x]" by(case_tac w, simp_all)
   with a show "False" by simp
  qed
  then obtain A B where d: "(S, Branch A B) \<in> set G \<and> t = [Inl A, Inl B]" by blast
  with c have e: "[Inl A] \<cdot> [Inl B] -G\<rightarrow>\<^sup>* map Inr w" by simp
  note DSTEP_star_comp1[OF e]
  then obtain l' r' where e: "[Inl A] -G\<rightarrow>\<^sup>* l' \<and> [Inl B] -G\<rightarrow>\<^sup>* r' \<and>
                              map Inr w = l'  \<cdot>  r'" by blast
  note map_Inr_split[rule_format, OF e[THEN conjunct2, THEN conjunct2]]
  then obtain u v where f: "w = u \<cdot> v \<and> l' = map Inr u \<and> r' = map Inr v" by blast
  with e have g: "[Inl A] -G\<rightarrow>\<^sup>* map Inr u \<and> [Inl B] -G\<rightarrow>\<^sup>* map Inr v" by simp
  show "?R"
  by(rule_tac x=A in exI, rule_tac x=B in exI, simp add: d,
     rule_tac x=u in exI, rule_tac x=v in exI, simp add: f,
     (subst Lang_rtrancl_eq)+, rule g)
 next
  assume "?R"
  then obtain A B l r where a: "(S, Branch A B) \<in> set G \<and> w = l \<cdot> r \<and> l \<in> Lang G A \<and> r \<in> Lang G B" by blast
  have "[Inl A] \<cdot> [Inl B] -G\<rightarrow>\<^sup>* map Inr l \<cdot> map Inr r"
  by(rule DSTEP_star_comp2, subst Lang_rtrancl_eq[THEN sym], simp add: a,
     subst Lang_rtrancl_eq[THEN sym], simp add: a)
  hence b: "[Inl A] \<cdot> [Inl B] -G\<rightarrow>\<^sup>* map Inr w" by(simp add: a)
  have c: "w \<in> Lang G S"
  by(simp add: Lang_def, subst trancl_unfold_left, rule_tac b="[Inl A] \<cdot> [Inl B]" in relcompI,
     simp add: DSTEP_def, rule_tac x="[]" in exI, rule_tac x="S" in exI, rule_tac x="[]" in exI,
     simp, rule_tac x="Branch A B" in exI, simp add:  a[THEN conjunct1], rule b)
  thus "?L"
  proof
   show "1 < length w"
   proof(simp add: a, rule ccontr, drule leI)
    assume "length l + length r \<le> Suc 0"
    hence "l = [] \<or> r = []" by(case_tac l, simp_all)
    thus "False"
    proof
     assume "l = []"
     with a have "[] \<in> Lang G A" by simp
     note Lang_no_Nil[OF this]
     thus ?thesis by simp
    next
     assume "r = []"
     with a have "[] \<in> Lang G B" by simp
     note Lang_no_Nil[OF this]
     thus ?thesis by simp
    qed
   qed
 qed
qed

section "Abstract specification of CYK"

text "A subword of a word $w$, starting at the position $i$
      (first element is at the position $0$) and having the length $j$, is defined as follows."
definition "subword w i j = take j (drop i w)"

text "Thus, to any subword of the given word $w$ CYK assigns all non-terminals
      from which this subword is derivable by the grammar $G$."
definition "CYK G w i j = {S. subword w i j \<in> Lang G S}"

subsection \<open>Properties of @{term "subword"}\<close>

lemma subword_length :
"i + j \<le> length w \<Longrightarrow> length(subword w i j) = j"
by(simp add: subword_def)

lemma subword_nth1 :
"i + j \<le> length w \<Longrightarrow> k < j \<Longrightarrow>
(subword w i j)!k = w!(i + k)"
by(simp add: subword_def)

lemma subword_nth2 :
assumes A: "i + 1 \<le> length w"
shows "subword w i 1 = [w!i]"
proof -
 note subword_length[OF A]
 hence "\<exists>x. subword w i 1 = [x]" by(case_tac "subword w i 1", simp_all)
 then obtain x where a:"subword w i 1 = [x]" by blast
 note subword_nth1[OF A, where k="(0 :: nat)", simplified]
 with a have "x = w!i" by simp
 with a show ?thesis by simp
qed

lemma subword_self :
"subword w 0 (length w) = w"
by(simp add: subword_def)

lemma take_split[rule_format] :
"\<forall>n m. n \<le> length xs \<longrightarrow> n \<le> m \<longrightarrow>
 take n xs \<cdot> take (m - n) (drop n xs) = take m xs"
by(induct_tac xs, clarsimp+, case_tac n, simp_all, case_tac m, simp_all)

lemma subword_split :
"i + j \<le> length w \<Longrightarrow> 0 < k \<Longrightarrow> k < j \<Longrightarrow>
 subword w i j = subword w i k \<cdot> subword w (i + k) (j - k)"
by(simp add: subword_def, subst take_split[where n=k, THEN sym], simp_all,
   rule_tac f="\<lambda>x. take (j - k) (drop x w)" in arg_cong, simp)

lemma subword_split2 :
assumes A: "subword w i j = l \<cdot> r"
    and B: "i + j \<le> length w"
    and C: "0 < length l"
    and D: "0 < length r"
shows "l = subword w i (length l) \<and> r = subword w (i + length l) (j - length l)"
proof -
 have a: "length(subword w i j) = j" by(rule subword_length, rule B)
 note arg_cong[where f=length, OF A]
 with a and D have b: "length l < j" by force
 with B have c: "i + length l \<le> length w" by force
 have "subword w i j = subword w i (length l) \<cdot> subword w (i + length l) (j - length l)"
  by(rule subword_split, rule B, rule C, rule b)
 with A have d: "l \<cdot> r = subword w i (length l) \<cdot> subword w (i + length l) (j - length l)" by simp
 show ?thesis
 by(rule append_eq_append_conv[THEN iffD1], subst subword_length, rule c, simp, rule d)
qed

subsection \<open>Properties of @{term "CYK"}\<close>

lemma CYK_Lang :
"(S \<in> CYK G w 0 (length w)) = (w \<in> Lang G S)"
by(simp add: CYK_def subword_self)

lemma CYK_eq1 :
"i + 1 \<le> length w \<Longrightarrow>
 CYK G w i 1 = {S. (S, Leaf (w!i)) \<in> set G}"
by(simp add: CYK_def, subst subword_nth2[simplified], assumption,
   subst Lang_eq1, rule refl)

theorem CYK_eq2 :
assumes A: "i + j \<le> length w"
    and B: "1 < j"
shows "CYK G w i j = {X | X A B k. (X, Branch A B) \<in> set G \<and> A \<in> CYK G w i k \<and> B \<in> CYK G w (i + k) (j - k) \<and> 1 \<le> k \<and> k < j}"
proof(rule set_eqI, rule iffI, simp_all add: CYK_def)
 fix X
 assume a: "subword w i j \<in> Lang G X"
 show "\<exists>A B. (X, Branch A B) \<in> set G \<and> (\<exists>k. subword w i k \<in> Lang G A \<and> subword w (i + k) (j - k) \<in> Lang G B \<and> Suc 0 \<le> k \<and> k < j)"
 proof -
  have b: "1 < length(subword w i j)" by(subst subword_length, rule A, rule B)
  note Lang_eq2[THEN iffD1, OF conjI, OF a b]
  then obtain A B l r where c: "(X, Branch A B) \<in> set G \<and> subword w i j = l \<cdot> r \<and> l \<in> Lang G A \<and> r \<in> Lang G B" by blast
  note Lang_no_Nil[OF c[THEN conjunct2, THEN conjunct2, THEN conjunct1]]
  hence d: "0 < length l" by(case_tac l, simp_all)
  note Lang_no_Nil[OF c[THEN conjunct2, THEN conjunct2, THEN conjunct2]]
  hence e: "0 < length r" by(case_tac r, simp_all)
  note subword_split2[OF c[THEN conjunct2, THEN conjunct1], OF A, OF d, OF e]
  with c show ?thesis
  proof(rule_tac x=A in exI, rule_tac x=B in exI, simp,
        rule_tac x="length l" in exI, simp)
   show "Suc 0 \<le> length l \<and> length l < j" (is "?A \<and> ?B")
   proof
    from d show "?A" by(case_tac l, simp_all)
   next
    note arg_cong[where f=length, OF c[THEN conjunct2, THEN conjunct1], THEN sym]
    also have "length(subword w i j) = j" by(rule subword_length, rule A)
    finally have "length l + length r = j" by simp
    with e show ?B by force
   qed
  qed
 qed
next
 fix X
 assume "\<exists>A B. (X, Branch A B) \<in> set G \<and> (\<exists>k. subword w i k \<in> Lang G A \<and> subword w (i + k) (j - k) \<in> Lang G B \<and> Suc 0 \<le> k \<and> k < j)"
 then obtain A B k where a: "(X, Branch A B) \<in> set G \<and> subword w i k \<in> Lang G A \<and> subword w (i + k) (j - k) \<in> Lang G B \<and> Suc 0 \<le> k \<and> k < j" by blast
 show "subword w i j \<in> Lang G X"
 proof(rule Lang_eq2[THEN iffD2, THEN conjunct1], rule_tac x=A in exI, rule_tac x=B in exI, simp add: a,
       rule_tac x="subword w i k" in exI, rule_tac x="subword w (i + k) (j - k)" in exI, simp add: a,
       rule subword_split, rule A)
  from a show "0 < k" by force
 next
  from a show "k < j" by simp
 qed
qed

section "Implementation"

text "One of the particularly interesting features of CYK implementation
is that it follows the principles of dynamic programming, constructing a
table of solutions for sub-problems in the bottom-up style reusing already
stored results."

subsection "Main cycle"

text "This is an auxiliary implementation of the membership test on lists."
fun mem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
"mem a [] = False" |
"mem a (x#xs) = (x = a \<or> mem a xs)"

lemma mem[simp] :
"mem x xs = (x \<in> set xs)"
by(induct_tac xs, simp, force)

text "The purpose of the following is to collect non-terminals that appear on the lhs of a production
      such that the first non-terminal on its rhs appears in the first of two given lists and the second
      non-terminal -- in the second list."
fun match_prods :: "('n, 't) CNG \<Rightarrow> 'n list \<Rightarrow> 'n list \<Rightarrow> 'n list"
where "match_prods [] ls rs = []" |
      "match_prods ((X, Branch A B)#ps) ls rs =
          (if mem A ls \<and> mem B rs then X # match_prods ps ls rs
           else match_prods ps ls rs)" |
      "match_prods ((X, Leaf a)#ps) ls rs = match_prods ps ls rs"

lemma match_prods :
"(X \<in> set(match_prods G ls rs)) =
 (\<exists>A \<in> set ls. \<exists>B \<in> set rs. (X, Branch A B) \<in> set G)"
by(induct_tac G, clarsimp+, rename_tac l r ps, case_tac r, force+)

text "The following function is the inner cycle of the algorithm. The parameters $i$ and $j$
      identify a subword starting at $i$ with the length $j$, whereas $k$ is used to iterate through
      its splits (which are of course subwords as well) all having the length greater $0$ but less than $j$.
      The parameter $T$ represents a table containing CYK solutions for those splits."
function inner :: "('n, 't) CNG \<Rightarrow> (nat \<times> nat \<Rightarrow> 'n list) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'n list"
where "inner G T i k j =
(if k < j then match_prods G (T(i, k)) (T(i + k, j - k)) @ inner G T i (k + 1) j
 else [])"
by pat_completeness auto
termination
by(relation "measure(\<lambda>(a, b, c, d, e). e - d)", rule wf_measure, simp)

declare inner.simps[simp del]

lemma inner :
"(X \<in> set(inner G T i k j)) =
 (\<exists>l. k \<le> l \<and> l < j \<and> X \<in> set(match_prods G (T(i, l)) (T(i + l, j - l))))"
(is "?L G T i k j = ?R G T i k j")
proof(induct_tac G T i k j rule: inner.induct)
 fix G T i k j
 assume a: "k < j \<Longrightarrow> ?L G T i (k + 1) j = ?R G T i (k + 1) j"
 show "?L G T i k j = ?R G T i k j"
 proof(case_tac "k < j")
  assume b: "k < j"
  with a have c: "?L G T i (k + 1) j = ?R G T i (k + 1) j" by simp
  show ?thesis
  proof(subst inner.simps, simp add: b, rule iffI, erule disjE, rule_tac x=k in exI, simp add: b)
   assume "X \<in> set(inner G T i (Suc k) j)"
   with c have "?R G T i (k + 1) j" by simp
   thus "?R G T i k j" by(clarsimp, rule_tac x=l in exI, simp)
  next
   assume "?R G T i k j"
   then obtain l where d: "k \<le> l \<and> l < j \<and> X \<in> set(match_prods G (T(i, l)) (T(i + l, j - l)))" by blast
   show "X \<in> set(match_prods G (T(i, k)) (T(i + k, j - k))) \<or> ?L G T i (Suc k) j"
   proof(case_tac "Suc k \<le> l", rule disjI2, subst c[simplified], rule_tac x=l in exI, simp add: d,
         rule disjI1)
    assume "\<not> Suc k \<le> l"
    with d have "l = k" by force
    with d show "X \<in> set(match_prods G (T(i, k)) (T(i + k, j - k)))" by simp
   qed
  qed
 next
  assume "\<not> k < j"
  thus ?thesis by(subst inner.simps, simp)
 qed
qed

text\<open>Now the main part of the algorithm just iterates through all subwords up to the given length $len$,
       calls @{term "inner"} on these, and stores the results in the table $T$. The length $j$ is supposed to
       be greater than $1$ -- the subwords of length $1$ will be handled in the initialisation phase below.\<close>
function main :: "('n, 't) CNG \<Rightarrow> (nat \<times> nat \<Rightarrow> 'n list) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'n list)"
where "main G T len i j = (let T' = T((i, j) := inner G T i 1 j) in
                            if i + j < len then main G T' len (i + 1) j
                            else if j < len then main G T' len 0 (j + 1)
                                 else T')"
by pat_completeness auto
termination
by(relation "inv_image (less_than <*lex*> less_than) (\<lambda>(a, b, c, d, e). (c - e, c - (d + e)))", rule wf_inv_image, rule wf_lex_prod, (rule wf_less_than)+, simp_all)

declare main.simps[simp del]

lemma main :
 assumes "1 < j"
     and "i + j \<le> length w"
     and "\<And>i' j'. j' < j \<Longrightarrow> 1 \<le> j' \<Longrightarrow> i' + j' \<le> length w \<Longrightarrow> set(T(i', j')) = CYK G w i' j'"
     and "\<And>i'. i' < i \<Longrightarrow> i' + j \<le> length w \<Longrightarrow> set(T(i', j)) = CYK G w i' j"
     and "1 \<le> j'"
     and "i' + j' \<le> length w"
 shows "set((main G T (length w) i j)(i', j')) = CYK G w i' j'"
proof -
 have "\<forall>len T' w. main G T len i j = T' \<longrightarrow> length w = len \<longrightarrow> 1 < j \<longrightarrow> i + j \<le> len \<longrightarrow>
      (\<forall>j' < j. \<forall>i'. 1 \<le> j' \<longrightarrow> i' + j' \<le> len \<longrightarrow> set(T(i', j')) = CYK G w i' j') \<longrightarrow>
      (\<forall>i' < i. i' + j \<le> len \<longrightarrow> set(T(i', j)) = CYK G w i' j) \<longrightarrow>
      (\<forall>j' \<ge> 1. \<forall>i'. i' + j' \<le> len \<longrightarrow> set(T'(i', j')) = CYK G w i' j')" (is "\<forall>len. ?P G T len i j")
 proof(rule allI, induct_tac G T len i j rule: main.induct, (drule meta_spec, drule meta_mp, rule refl)+, clarify)
  fix G T i j i' j'
  fix w :: "'a list"
  assume a: "i + j < length w \<Longrightarrow> ?P G (T((i, j) := inner G T i 1 j)) (length w) (i + 1) j"
  assume b: "\<not> i + j < length w \<Longrightarrow> j < length w \<Longrightarrow> ?P G (T((i, j) := inner G T i 1 j)) (length w) 0 (j + 1)"
  assume c: "1 < j"
  assume d: "i + j \<le> length w"
  assume e: "(1::nat) \<le> j'"
  assume f: "i' + j' \<le> length w"
  assume g: "\<forall>j' < j. \<forall>i'. 1 \<le> j' \<longrightarrow> i' + j' \<le> length w \<longrightarrow> set(T(i', j')) = CYK G w i' j'"
  assume h: "\<forall>i' < i. i' + j \<le> length w \<longrightarrow> set(T(i', j)) = CYK G w i' j"

   have inner: "set (inner G T i (Suc 0) j) = CYK G w i j"
   proof(rule set_eqI, subst inner, subst match_prods, subst CYK_eq2, rule d, rule c, simp)
    fix X
    show "(\<exists>l\<ge>Suc 0. l < j \<and> (\<exists>A \<in> set(T(i, l)). \<exists>B \<in> set(T(i + l, j - l)). (X, Branch A B) \<in> set G)) =
          (\<exists>A B. (X, Branch A B) \<in> set G \<and> (\<exists>k. A \<in> CYK G w i k \<and> B \<in> CYK G w (i + k) (j - k) \<and> Suc 0 \<le> k \<and> k < j))" (is "?L = ?R")
    proof
     assume "?L"
     thus "?R"
     proof(clarsimp, rule_tac x=A in exI, rule_tac x=B in exI, simp, rule_tac x=l in exI, simp)
      fix l A B
      assume i: "Suc 0 \<le> l"
      assume j: "l < j"
      assume k: "A \<in> set(T(i, l))"
      assume l: "B \<in> set(T(i + l, j - l))"
      note g[rule_format, where i'=i and j'=l]
      with d i j have A: "set(T(i, l)) = CYK G w i l" by force
      note g[rule_format, where i'="i + l" and j'="j - l"]
      with d i j have "set(T(i + l, j - l)) = CYK G w (i + l) (j - l)" by force
      with k l A show "A \<in> CYK G w i l \<and> B \<in> CYK G w (i + l) (j - l)" by simp
     qed
    next
     assume "?R"
     thus "?L"
     proof(clarsimp, rule_tac x=k in exI, simp)
      fix A B k
      assume i: "Suc 0 \<le> k"
      assume j: "k < j"
      assume k: "A \<in> CYK G w i k"
      assume l: "B \<in> CYK G w (i + k) (j - k)"
      assume m: "(X, Branch A B) \<in> set G"
      note g[rule_format, where i'=i and j'=k]
      with d i j have A: "CYK G w i k = set(T(i, k))" by force
      note g[rule_format, where i'="i + k" and j'="j - k"]
      with d i j have "CYK G w (i + k) (j - k) = set(T(i + k, j - k))" by force
      with k l A have "A \<in> set(T(i, k)) \<and> B \<in> set(T(i + k, j - k))" by simp
      with m show "\<exists>A \<in> set(T(i, k)). \<exists>B \<in> set(T(i + k, j - k)). (X, Branch A B) \<in> set G" by force
     qed
    qed
   qed  (* inner *)

  show "set((main G T (length w) i j)(i', j')) = CYK G w i' j'"
  proof(case_tac "i + j = length w")
   assume i: "i + j = length w"
   show ?thesis
   proof(case_tac "j < length w")
    assume j: "j < length w"
    show ?thesis
    proof(subst main.simps, simp add: Let_def i j,
          rule b[rule_format, where w=w and i'=i' and j'=j', OF _ _ refl, simplified],
          simp_all add: inner)
     from i show "\<not> i + j < length w" by simp
    next
     from c show "0 < j" by simp
    next
     from j show "Suc j \<le> length w" by simp
    next
     from e show "Suc 0 \<le> j'" by simp
    next
     from f show "i' + j' \<le> length w" by assumption
    next
     fix i'' j''
     assume k: "j'' < Suc j"
     assume l: "Suc 0 \<le> j''"
     assume m: "i'' + j'' \<le> length w"
     show "(i'' = i \<longrightarrow> j'' \<noteq> j) \<longrightarrow> set(T(i'',j'')) = CYK G w i'' j''"
     proof(case_tac "j'' = j", simp_all, clarify)
      assume n: "j'' = j"
      assume "i'' \<noteq> i"
      with i m n have "i'' < i" by simp
      with n m h show "set(T(i'', j)) = CYK G w i'' j" by simp
     next
      assume "j'' \<noteq> j"
      with k have "j'' < j" by simp
      with l m g show "set(T(i'', j'')) = CYK G w i'' j''" by simp
     qed
    qed
   next
    assume "\<not> j < length w"
    with i have j: "i = 0 \<and> j = length w" by simp
    show ?thesis
    proof(subst main.simps, simp add: Let_def j, intro conjI, clarify)
     from j and inner show "set (inner G T 0 (Suc 0) (length w)) = CYK G w 0 (length w)" by simp
    next
     show "0 < i' \<longrightarrow> set(T(i', j')) = CYK G w i' j'"
     proof
      assume "0 < i'"
      with j and f have "j' < j" by simp
      with e g f show "set(T(i', j')) = CYK G w i' j'" by simp
     qed
    next
     show "j' \<noteq> length w \<longrightarrow> set(T(i', j')) = CYK G w i' j'"
     proof
      assume "j' \<noteq> length w "
      with j and f have "j' < j" by simp
      with e g f show "set(T(i', j')) = CYK G w i' j'" by simp
     qed
    qed
   qed
  next
   assume "i + j \<noteq> length w"
   with d have i: "i + j < length w" by simp
   show ?thesis
   proof(subst main.simps, simp add: Let_def i,
         rule a[rule_format, where w=w and i'=i' and j'=j', OF i, OF refl, simplified])
    from c show "Suc 0 < j" by simp
   next
    from i show "Suc(i + j) \<le> length w" by simp
   next
    from e show "Suc 0 \<le> j'" by simp
   next
    from f show "i' + j' \<le> length w" by assumption
   next
    fix i'' j''
    assume "j'' < j"
    and "Suc 0 \<le> j''"
    and "i'' + j'' \<le> length w"
    with g show "set(T(i'', j'')) = CYK G w i'' j''" by simp
   next
    fix i'' assume j: "i'' < Suc i"
    show "set(if i'' = i then inner G T i (Suc 0) j else T(i'', j)) = CYK G w i'' j"
    proof(simp split: if_split, rule conjI, clarify, rule inner, clarify)
     assume "i'' \<noteq> i"
     with j have "i'' < i" by simp
     with d h show "set(T(i'', j)) = CYK G w i'' j" by simp
    qed
   qed
  qed
 qed
 with assms show ?thesis by force
qed

subsection "Initialisation phase"

text\<open>Similarly to @{term "match_prods"} above, here we collect non-terminals from which
       the given terminal symbol can be derived.\<close>
fun init_match :: "('n, 't) CNG \<Rightarrow> 't \<Rightarrow> 'n list"
where "init_match [] t = []" |
      "init_match ((X, Branch A B)#ps) t = init_match ps t" |
      "init_match ((X, Leaf a)#ps) t = (if a = t then X # init_match ps t
                                        else init_match ps t)"

lemma init_match :
"(X \<in> set(init_match G a)) =
 ((X, Leaf a) \<in> set G)"
by(induct_tac G a rule: init_match.induct, simp_all)

text "Representing the empty table."
definition "emptyT = (\<lambda>(i, j). [])"

text "The following function initialises the empty table for subwords of
      length $1$, i.e. each symbol occurring in the given word."
fun init' :: "('n, 't) CNG \<Rightarrow> 't list \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> 'n list"
where "init' G [] k = emptyT" |
      "init' G (t#ts) k = (init' G ts (k + 1))((k, 1) := init_match G t)"

text\<open>The next version of initialization refines @{term "init'"} in that
      it takes additional account of the cases when the given word is
      empty or contains a terminal symbol that does not have any matching
      production (that is, @{term "init_match"} is an empty list). No initial
      table is then needed as such words can immediately be rejected.\<close>
fun init :: "('n, 't) CNG \<Rightarrow> 't list \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'n list) option"
where "init G [] k = None" |
      "init G [t] k = (case (init_match G t) of
                        [] \<Rightarrow> None
                      | xs \<Rightarrow> Some(emptyT((k, 1) := xs)))" |
      "init G (t#ts) k = (case (init_match G t) of
                           [] \<Rightarrow> None
                         | xs \<Rightarrow> (case (init G ts (k + 1)) of
                                  None \<Rightarrow> None
                                | Some T \<Rightarrow> Some(T((k, 1) := xs))))"

lemma init1[rule_format] :
"\<forall>T. init G w k = Some T \<longrightarrow>
     init' G w k = T"
by(induct_tac G w k rule: init.induct, clarsimp+, simp split: list.split_asm, rule ext, clarsimp+,
   simp split: list.split_asm option.split_asm, rule ext, clarsimp, force)

lemma init2 :
"(init G w k = None) =
 (w = [] \<or> (\<exists>a \<in> set w. init_match G a = []))"
by(induct_tac G w k rule: init.induct, simp, simp split: list.split,
   simp split: list.split option.split, force)

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

definition "cyk G S w = (case init G w 0 of
                          None \<Rightarrow> False
                        | Some T \<Rightarrow> let len = length w in
                                     if len = 1 then mem S (T(0, 1))
                                     else let T' = main G T len 0 2 in
                                            mem S (T'(0, len)))"

theorem cyk :
"cyk G S w = (w \<in> Lang G S)"
proof(simp add: cyk_def split: option.split, simp_all add: Let_def,
      rule conjI, subst init2, simp, rule conjI)
 show "w = [] \<longrightarrow> [] \<notin> Lang G S" by(clarify, drule Lang_no_Nil, clarify)
next
 show "(\<exists>x\<in>set w. init_match G x = []) \<longrightarrow> w \<notin> Lang G S" by(clarify, drule Lang_term, subst (asm) init_match[THEN sym], force)
next
 show "\<forall>T. init G w 0 = Some T \<longrightarrow>
       ((length w = Suc 0 \<longrightarrow> S \<in> set(T(0, Suc 0))) \<and>
        (length w \<noteq> Suc 0 \<longrightarrow> S \<in> set(main G T (length w) 0 2 (0, length w)))) =
       (w \<in> Lang G S)" (is "\<forall>T. ?P T \<longrightarrow> ?L T = ?R")
 proof clarify
  fix T
  assume a: "?P T"
  hence b: "init' G w 0 = T" by(rule init1)
  note init2[THEN iffD2, OF disjI1]
  have c: "w \<noteq> []" by(clarify, drule init2[where G=G and k=0, THEN iffD2, OF disjI1], simp add: a)
  have "?L (init' G w 0) = ?R"
  proof(case_tac "length w = 1", simp_all)
   assume d: "length w = Suc 0"
   show "S \<in> set(init' G w 0 (0, Suc 0)) = ?R"
   by(subst init'[simplified], simp add: d, subst CYK_Lang[THEN sym], simp add: d)
  next
   assume "length w \<noteq> Suc 0"
   with c have "1 < length w" by(case_tac w, simp_all)
   hence d: "Suc(Suc 0) \<le> length w" by simp
   show "(S \<in> set(main G (init' G w 0) (length w) 0 2 (0, length w))) = (w \<in> Lang G S)"
   proof(subst main, simp_all, rule d)
    fix i' j'
    assume "j' < 2" and "Suc 0 \<le> j'"
    hence e: "j' = 1" by simp
    assume "i' + j' \<le> length w"
    with e have f: "i' + 1 \<le> length w" by simp
    have "set(init' G w 0 (i', 1)) = CYK G w i' 1" by(rule init', rule f)
    with e show "set(init' G w 0 (i', j')) = CYK G w i' j'" by simp
   next
    from d show "Suc 0 \<le> length w" by simp
   next
    show "(S \<in> CYK G w 0 (length w)) = (w \<in> Lang G S)" by(rule CYK_Lang)
   qed
  qed
  with b show "?L T = ?R" by simp
 qed
qed

value [code]
  "let G = [(0::int, Branch 1 2), (0, Branch 2 3),
            (1, Branch 2 1), (1, Leaf ''a''),
            (2, Branch 3 3), (2, Leaf ''b''),
            (3, Branch 1 2), (3, Leaf ''a'')]
  in map (cyk G 0)
     [[''b'',''a'',''a'',''b'',''a''],
      [''b'',''a'',''b'',''a'']]"

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Karatsuba's Multiplication Algorithm for Polynomials\<close>
theory Karatsuba_Multiplication
imports
  Polynomial_Interpolation.Missing_Polynomial
begin

lemma karatsuba_main_step: fixes f :: "'a :: comm_ring_1 poly"
  assumes f: "f = monom_mult n f1 + f0" and g: "g = monom_mult n g1 + g0"
  shows
    "monom_mult (n + n) (f1 * g1) + (monom_mult n (f1 * g1 - (f1 - f0) * (g1 - g0) + f0 * g0) + f0 * g0) = f * g"
  unfolding assms
  by (auto simp: field_simps mult_monom monom_mult_def)

lemma karatsuba_single_sided: fixes f :: "'a :: comm_ring_1 poly"
  assumes "f = monom_mult n f1 + f0"
  shows "monom_mult n (f1 * g) + f0 * g = f * g"
  unfolding assms by (auto simp: field_simps mult_monom monom_mult_def)

definition split_at :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
  [code del]: "split_at n xs = (take n xs, drop n xs)"

lemma split_at_code[code]:
  "split_at n [] = ([],[])"
  "split_at n (x # xs) = (if n = 0 then ([], x # xs) else case split_at (n-1) xs of (bef,aft)
    \<Rightarrow> (x # bef, aft))"
  unfolding split_at_def by (force, cases n, auto)

fun coeffs_minus :: "'a :: ab_group_add list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "coeffs_minus (x # xs) (y # ys) = ((x - y) # coeffs_minus xs ys)"
| "coeffs_minus xs [] = xs"
| "coeffs_minus [] ys = map uminus ys"

text \<open>The following constant determines at which size we will switch to the standard
   multiplication algorithm.\<close>
definition karatsuba_lower_bound where [termination_simp]: "karatsuba_lower_bound = (7 :: nat)"

fun karatsuba_main :: "'a :: comm_ring_1 list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a poly" where
  "karatsuba_main f n g m = (if n \<le> karatsuba_lower_bound \<or> m \<le> karatsuba_lower_bound then
    let ff = poly_of_list f in foldr (\<lambda>a p. smult a ff + pCons 0 p) g 0
   else let n2 = n div 2 in
   if m > n2 then (case split_at n2 f of
   (f0,f1) \<Rightarrow> case split_at n2 g of
   (g0,g1) \<Rightarrow> let
      p1 = karatsuba_main f1 (n - n2) g1 (m - n2);
      p2 = karatsuba_main (coeffs_minus f1 f0) n2 (coeffs_minus g1 g0) n2;
      p3 = karatsuba_main f0 n2 g0 n2
      in monom_mult (n2 + n2) p1 + (monom_mult n2 (p1 - p2 + p3) + p3))
    else case split_at n2 f of
    (f0,f1) \<Rightarrow> let
       p1 = karatsuba_main f1 (n - n2) g m;
       p2 = karatsuba_main f0 n2 g m
     in monom_mult n2 p1 + p2)"

declare karatsuba_main.simps[simp del]

lemma poly_of_list_split_at: assumes "split_at n f = (f0,f1)"
  shows "poly_of_list f = monom_mult n (poly_of_list f1) + poly_of_list f0"
proof -
  from assms have id: "f1 = drop n f" "f0 = take n f" unfolding split_at_def by auto
  show ?thesis unfolding id
  proof (rule poly_eqI)
    fix i
    show "coeff (poly_of_list f) i =
      coeff (monom_mult n (poly_of_list (drop n f)) + poly_of_list (take n f)) i"
      unfolding monom_mult_def coeff_monom_mult coeff_add poly_of_list_def coeff_Poly
      by (cases "n \<le> i"; cases "i \<ge> length f", auto simp: nth_default_nth nth_default_beyond)
  qed
qed

lemma coeffs_minus: "poly_of_list (coeffs_minus f1 f0) = poly_of_list f1 - poly_of_list f0"
proof (rule poly_eqI, unfold poly_of_list_def coeff_diff coeff_Poly)
  fix i
  show "nth_default 0 (coeffs_minus f1 f0) i = nth_default 0 f1 i - nth_default 0 f0 i"
  proof (induct f1 f0 arbitrary: i rule: coeffs_minus.induct)
    case (1 x xs y ys)
    thus ?case by (cases i, auto)
  next
    case (3 x xs)
    thus ?case unfolding coeffs_minus.simps
      by (subst nth_default_map_eq[of uminus 0 0], auto)
  qed auto
qed

definition karatsuba_mult_poly :: "'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "karatsuba_mult_poly f g = (let ff = coeffs f; gg = coeffs g; n = length ff; m = length gg
    in (if n \<le> karatsuba_lower_bound \<or> m \<le> karatsuba_lower_bound then if n \<le> m
    then foldr (\<lambda>a p. smult a g + pCons 0 p) ff 0
    else foldr (\<lambda>a p. smult a f + pCons 0 p) gg 0
    else if n \<le> m
    then karatsuba_main gg m ff n
    else karatsuba_main ff n gg m))"

lemma karatsuba_mult_poly: "karatsuba_mult_poly f g = f * g"
proof -
  note d = karatsuba_mult_poly_def Let_def
  let ?len = "length (coeffs f) \<le> length (coeffs g)"
  show ?thesis (is "?lhs = ?rhs")
  proof (cases "length (coeffs f) \<le> karatsuba_lower_bound \<or> length (coeffs g) \<le> karatsuba_lower_bound")
    case True note outer = this
    show ?thesis
    proof (cases ?len)
      case True
      with outer have "?lhs = foldr (\<lambda>a p. smult a g + pCons 0 p) (coeffs f) 0" unfolding d by auto
      also have "\<dots> = ?rhs" unfolding times_poly_def fold_coeffs_def by auto
      finally show ?thesis .
    next
      case False
      with outer have "?lhs = foldr (\<lambda>a p. smult a f + pCons 0 p) (coeffs g) 0" unfolding d by auto
      also have "\<dots> = g * f" unfolding times_poly_def fold_coeffs_def by auto
      also have "\<dots> = ?rhs" by simp
      finally show ?thesis .
    qed
  next
    case False note outer = this
    show ?thesis
    proof (cases ?len)
      case True
      with outer have "?lhs = karatsuba_main (coeffs g) (length (coeffs g)) (coeffs f) (length (coeffs f))"
        unfolding d by auto
      also have "\<dots> = g * f" unfolding karatsuba_main by auto
      also have "\<dots> = ?rhs" by auto
      finally show ?thesis .
    next
      case False
      with outer have "?lhs = karatsuba_main (coeffs f) (length (coeffs f)) (coeffs g) (length (coeffs g))"
        unfolding d by auto
      also have "\<dots> = ?rhs" unfolding karatsuba_main by auto
      finally show ?thesis .
    qed
  qed
qed

lemma karatsuba_mult_poly_code_unfold[code_unfold]: "(*) = karatsuba_mult_poly"
  by (intro ext, unfold karatsuba_mult_poly, auto)

text \<open>The following declaration will resolve a race-conflict between @{thm karatsuba_mult_poly_code_unfold}
  and @{thm monom_mult_unfold}.\<close>
lemmas karatsuba_monom_mult_code_unfold[code_unfold] =
  monom_mult_unfold[where f = "f :: 'a :: comm_ring_1 poly" for f, unfolded karatsuba_mult_poly_code_unfold]

end


theory exercises_4
  imports Main
begin
text \<open>Exercise 4.1\<close>
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun "set" :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node l a r) = (set l) \<union> {a} \<union> (set r)"

definition "test_tree1 = Node (Node (Node Tip 1 Tip) 2 (Node Tip 3 Tip)) (4::int) (Node Tip 5 Tip)"
fun inord :: "int tree \<Rightarrow> int list" where
"inord Tip = []" |
"inord (Node l a r) = (inord l) @ [a] @ (inord r)"
(*
fun inc :: "int list \<Rightarrow> bool" where
"inc [] = True" |
"inc [x] = True" |
"inc (x#xs) = (if x>(hd xs) then False else (inc xs))"

value "inc [(2::int), 3, 5]"
*)
fun ord :: "int tree \<Rightarrow> bool" where
"ord t = strict_sorted (inord t)"

value "ord test_tree1"

fun rightest :: "int tree \<Rightarrow> int" where
"rightest (Node _ a Tip) = a" |
"rightest (Node _ a r) = rightest r"

fun leftest :: "int tree \<Rightarrow> int" where
"leftest (Node Tip a _) = a" |
"leftest (Node l a _) = leftest l"

fun ord1 :: "int tree \<Rightarrow> bool" where
"ord1 Tip = True" |
"ord1 (Node Tip a Tip) = True" |
"ord1 (Node Tip a r) = ((ord1 r) \<and> (a < leftest r))" |
"ord1 (Node l a Tip) = ((ord1 l) \<and> (rightest l < a))" |
"ord1 (Node l a r) = ((ord1 l) \<and> (ord1 r) \<and> (rightest l < a) \<and> (a < leftest r))"

value "ord1 test_tree1"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins x Tip = Node Tip x Tip" |
"ins x (Node l a r) = (if x=a
                        then (Node l a r)
                        else if x < a
                              then Node (ins x l) a r
                              else Node l a (ins x r))"

value "ins 6 test_tree1"

lemma correctness_ins:
  "set (ins x t) = {x} \<union> set t"
  apply (induction t)
  by auto

lemma "ord1 t \<Longrightarrow> ord1 (ins i t)"
  apply (induction t arbitrary: i)
   apply auto
  sorry

text \<open>Exercise 4.2\<close>
inductive palindromes :: "'a list \<Rightarrow> bool" where
pal0: "palindromes []" |
palN: "palindromes xs \<Longrightarrow> palindromes (x # xs @ [x])"

lemma c_rev:
  "palindromes xs \<Longrightarrow> rev xs = xs"
  apply (induction rule: palindromes.induct)
  by auto

text \<open>Exercise 4.3\<close>
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma aux0:
  "r x y \<Longrightarrow> star' r x y"
  by (metis refl' step')

lemma aux1:
  "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
  apply (induction rule: star'.induct)
   apply (simp add: aux0)
  by (rule step')

lemma eq_star1:
  "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
   apply (rule refl')
  by (simp add: aux1)

lemma aux3:
  "r x y \<Longrightarrow> star r x y"
  by (simp add: refl step)

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
   apply (assumption)
  by (simp add: step)

lemma eq_star2:
  "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule: star'.induct)
   apply (rule refl)
  by (simp add: aux3 star_trans)

text \<open>Exercise 4.4\<close>
inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
it_refl: "iter r n x x" |
it_step: "r x0 x1 \<Longrightarrow> iter r n x1 xn  \<Longrightarrow> iter r (n+1) x0 xn"

lemma star_iter:
  "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
  apply (induction rule: star.induct)
   apply (metis it_refl)
  by (metis it_step)

text \<open>Exercise 4.5\<close>
datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
s_empty: "S []" |
s_1: "S s \<Longrightarrow> S (a # s @ [b])" |
s_2: "S s1 \<Longrightarrow> S s2 \<Longrightarrow> S (s1 @ s2)"

inductive T :: "alpha list => bool" where
t_empty: "T []" |
t_1: "T s1 \<Longrightarrow> T s2 \<Longrightarrow> T (s1 @ [a] @ s2 @ [b])"

lemma t_s:
  "T w \<Longrightarrow> S w"
  apply (induction rule: T.induct)
   apply (metis s_empty)
  by (simp add: s_1 s_2)

lemma balance_composite_first:
  "T (w1 @ w2) ==> T w3 ==>  T (w1 @ w2 @ [a] @ w3 @ [b])"
  apply (simp)
  apply (rule t_1[of "w1 @ w2" w3, simplified])
  by (auto)

lemma com_t:
  "T s2 \<Longrightarrow> T s1 \<Longrightarrow> T (s1 @ s2)"
  apply (induction arbitrary: s1 rule: T.induct)
   apply (simp)
  using balance_composite_first by auto

lemma s_t:
  "S w \<Longrightarrow> T w"
  apply (induction rule: S.induct)
    apply (rule t_empty)
  using t_empty t_1 apply fastforce
  by (simp add: com_t)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_TSortIsSort
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Tree = TNode "Tree" "Nat" "Tree" | TNil

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun flatten :: "Tree => Nat list => Nat list" where
"flatten (TNode q z r) y = flatten q (cons2 z (flatten r y))"
| "flatten (TNil) y = y"

fun add :: "Nat => Tree => Tree" where
"add x (TNode q z r) =
   (if le x z then TNode (add x q) z r else TNode q z (add x r))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "Nat list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "Nat list => Nat list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "((tsort xs) = (isort xs))"
  oops

end


(*<*)
theory hw09tmpl
  imports Main "HOL-Data_Structures.RBT_Set"
begin
(*>*)

text \<open>\NumHomework{Balanced Tree to RBT}{15.~6.~2018}

  A tree is balanced, if its minimum height and its height differ by at most 1.
\<close>

fun min_height :: "('a,'b) tree \<Rightarrow> nat" where
"min_height Leaf = 0" |
"min_height (Node _ l _ r) = min (min_height l) (min_height r) + 1"

definition "balanced t \<equiv> height t - min_height t \<le> 1"

text \<open>The following function paints a balanced tree to form a valid red-black tree
  with the same structure. The task of this homework is to prove this!
\<close>

fun mk_rbt :: "('a,unit) tree \<Rightarrow> 'a rbt" where
  "mk_rbt Leaf = Leaf"
| "mk_rbt (Node _ l a r) = (let
    l'=mk_rbt l;
    r'=mk_rbt r
  in
    if min_height l > min_height r then
      B (paint Red l') a r'
    else if min_height l < min_height r then
      B l' a (paint Red r')
    else
      B l' a r'
  )"

text \<open>
  \subsection*{Warmup}

  Show that the left and right subtree of a balanced tree are, again, balanced
\<close>

lemma balanced_subt: "balanced (Node c l a r) \<Longrightarrow> balanced l \<and> balanced r"
  unfolding balanced_def by auto

text \<open>Show the following alternative characterization of balanced:\<close>

lemma aux1:"height t \<ge> min_height t"
  apply(induction t)
  by auto

lemma balanced_alt:
  "balanced t \<longleftrightarrow> height t = min_height t \<or> height t = min_height t + 1"
  text \<open>Hint: Auxiliary lemma relating @{term \<open>height t\<close>} and @{term \<open>min_height t\<close>}\<close>
  unfolding balanced_def
  by (metis One_nat_def add_diff_cancel_left' aux1 cancel_comm_monoid_add_class.diff_cancel le_Suc_eq le_add_diff_inverse le_zero_eq order_refl)

text \<open>
  \subsection*{The Easy Parts}

  Show that \<open>mk_rbt\<close> does not change the inorder-traversal
\<close>
lemma mk_rbt_inorder: "inorder (mk_rbt t) = inorder t"
  apply(induction t)
   apply(auto)
  by (smt inorder.simps(2) inorder_paint)

text \<open>Show that the color of the root node is always black\<close>
lemma mk_rbt_color: "color (mk_rbt t) = Black"
  apply(induction t)
   apply(auto)
  by (smt RBT_Set.color.simps(2))

text \<open>
  \subsection*{Medium Complex Parts}

  Show that the black-height of the returned tree is the minimum height of the argument tree
\<close>

lemma mk_rbt_bheight: "balanced t \<Longrightarrow> bheight (mk_rbt t) = min_height t"
text \<open>Hint: Use Isar to have better control when to unfold with @{thm [source] balanced_alt},
  and when to use @{thm [source] balanced_subt} (e.g. to discharge the premises of the IH)
\<close>
proof(induction t)
  case Leaf
  then show ?case by auto
next
  case (Node x1 t1 x3 t2)
  note IH = Node.IH
  have "min_height t1 = min_height t2 \<or> min_height t1 < min_height t2 \<or> min_height t1 > min_height t2" (is "?C1 \<or> ?C2 \<or> ?C3")
    by auto
  moreover
  {
    assume ?C1
    have ?case using IH Node.prems \<open>?C1\<close>
      apply(cases "min_height t1")
       apply(auto)
       apply (meson balanced_subt)
      by (meson balanced_subt)
    }
    moreover
    {
      assume ?C2
      have ?case using IH Node.prems \<open>?C2\<close>
        apply(cases "min_height t1")
         apply(auto)
         apply (meson balanced_subt)
        by (metis balanced_subt min.strict_order_iff)
    }
    moreover
    {
      assume ?C3
      then have h0:"min_height (Node x1 t1 x3 t2) = min_height t2 + 1" using IH Node.prems by force
      then have h1:"min_height t2 = 0 \<Longrightarrow> bheight (paint Red (mk_rbt t1)) = 0" using IH Node.prems
        by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Suc_leI \<open>min_height t2 < min_height t1\<close> add_diff_cancel_right' aux1 balanced_def bheight_paint_Red height.simps(2) le_trans max.commute max_def mk_rbt_color)
      then have h2: "min_height t1 > min_height t2 \<Longrightarrow> min_height t1 = Suc (min_height t2)" using IH Node.prems
        by (smt Suc_eq_plus1 Suc_leI Suc_mono balanced_alt balanced_subt h0 height.simps(2) less_Suc_eq max.commute max_def not_le)
      then have h3: " min_height t1 > min_height t2 \<Longrightarrow> bheight (paint Red (mk_rbt t1)) = min_height t2" using IH Node.prems
        apply(cases "min_height t1")
         apply(auto)
        by (metis Suc_eq_plus1 add_diff_cancel_right' balanced_subt bheight_paint_Red mk_rbt_color)

      then have ?case using IH Node.prems \<open>?C3\<close>
        apply(cases "min_height t2")
        by (auto)

      }
      ultimately show ?case by blast
qed

text \<open>
  Show that the returned tree satisfies the height invariant.
\<close>

lemma mk_rbt_invh: "balanced t \<Longrightarrow> invh (mk_rbt t)"
  apply(induction t rule:mk_rbt.induct)
   apply(simp add: balanced_alt mk_rbt_color mk_rbt_inorder mk_rbt_bheight)
  apply(simp split:if_splits)
  by (smt Suc_eq_plus1 Suc_le_mono add_diff_cancel_right' antisym_conv balanced_alt balanced_subt bheight_paint_Red height.simps(2) invh.simps(2) le_Suc_eq le_simps(3) max_def min_def invh_paint min_height.simps(2) mk_rbt_bheight mk_rbt_color)

text \<open>
  \subsection*{The Hard Part (3 Bonus Points)}

  For {\bf three bonus points}, show that the returned tree satisfies the color invariant.

  Warning: This requires careful case splitting, via a clever combination of
    automation and manual proof (Isar, aux-lemmas), in order to deal with the
    multiple cases without a combinatorial explosion of the proofs.
\<close>

lemma mk_rbt_invc: "balanced t \<Longrightarrow> invc (mk_rbt t)"
proof(induction t)
case Leaf
then show ?case by auto
next
  case (Node x1 t1 x3 t2)
  note IH = Node.IH
  have "min_height t1 = min_height t2 \<or> min_height t1 < min_height t2 \<or> min_height t1 > min_height t2" (is "?C1 \<or> ?C2 \<or> ?C3")
    by auto
  moreover
  {
    assume ?C1
    have ?case using IH Node.prems \<open>?C1\<close>
      apply(cases "min_height t1")
       apply(auto)
         apply (meson balanced_subt)
        apply (meson balanced_subt)
       apply (meson balanced_subt)
      by (meson balanced_subt)
  }
  moreover
  {
    assume ?C2
    then have h0:"min_height (Node x1 t1 x3 t2) = min_height t1 + 1" using IH Node.prems by force
    then have h1: "min_height t1 < min_height t2 \<Longrightarrow> min_height t2 = Suc (min_height t1)" using IH Node.prems
      by (smt Suc_eq_plus1 Suc_leI Suc_mono balanced_alt balanced_subt h0 height.simps(2) less_Suc_eq max.commute max_def not_le)
    then have h2:"invc (paint Red (mk_rbt t2))" using IH Node.prems sorry
      then have ?case using IH Node.prems \<open>?C2\<close>
      apply(cases "min_height t1")
        apply(auto)
           apply (smt balanced_subt)
          apply (simp add: h2)
        by (meson balanced_subt)
    }

qed

(* Now you can combine everything, to show that you are, indeed, generating an RBT *)
theorem mk_rbt_is_rbt: "balanced t \<Longrightarrow> rbt (mk_rbt t)"
  using mk_rbt_invh mk_rbt_invc mk_rbt_color unfolding rbt_def by auto

text \<open>\NumHomework{Linear-Time Repainting}{15.~6.~2018}

  Write a linear-time version of \<open>mk_rbt\<close>, and show that it behaves like
  \<open>mk_rbt\<close>.

  Idea: Compute the min-height during the same recursion as you build
    the tree.

  Note: No formal complexity proof required.
\<close>

fun mk_rbt' :: "('a,unit) tree \<Rightarrow> 'a rbt \<times> nat" -- \<open>Returns the RBT and the min-height of the argument\<close>
where
  "mk_rbt' Leaf = (Leaf, 0)"
| "mk_rbt' (Node _ l a r) = (let
    (l',lx)=mk_rbt' l;
    (r',rx)=mk_rbt' r
  in
    if lx > rx then
      (B (paint Red l') a r', Suc(rx))
    else if lx < rx then
      (B l' a (paint Red r'), Suc(lx))
    else
      (B l' a r', Suc(lx))
  )"

lemma mk_rbt'_refine_aux: "mk_rbt' t = (mk_rbt t, min_height t)"
  apply(induction t)
  apply(auto)
  done

lemma mk_rbt'_refine: "fst (mk_rbt' t) = mk_rbt t"
  apply(induction t)
  by(auto simp:mk_rbt'_refine_aux)

(*<*)
end
(*>*)


theory Basic imports Main begin

lemma conj_rule: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> P \<and> (Q \<and> P)"
apply (rule conjI)
 apply assumption
apply (rule conjI)
 apply assumption
apply assumption
done

lemma disj_swap: "P | Q \<Longrightarrow> Q | P"
apply (erule disjE)
 apply (rule disjI2)
 apply assumption
apply (rule disjI1)
apply assumption
done

lemma conj_swap: "P \<and> Q \<Longrightarrow> Q \<and> P"
apply (rule conjI)
 apply (drule conjunct2)
 apply assumption
apply (drule conjunct1)
apply assumption
done

lemma imp_uncurry: "P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R"
apply (rule impI)
apply (erule conjE)
apply (drule mp)
 apply assumption
apply (drule mp)
  apply assumption
 apply assumption
done

text {*
by eliminates uses of assumption and done
*}

lemma imp_uncurry': "P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R"
apply (rule impI)
apply (erule conjE)
apply (drule mp)
 apply assumption
by (drule mp)

text {*
substitution

@{thm[display] ssubst}
\rulename{ssubst}
*}

lemma "\<lbrakk> x = f x; P(f x) \<rbrakk> \<Longrightarrow> P x"
by (erule ssubst)

text {*
also provable by simp (re-orients)
*}

text {*
the subst method

@{thm[display] mult.commute}
\rulename{mult.commute}

this would fail:
apply (simp add: mult.commute)
*}

lemma "\<lbrakk>P x y z; Suc x < y\<rbrakk> \<Longrightarrow> f z = x*y"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply (subst mult.commute)
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

(*exercise involving THEN*)
lemma "\<lbrakk>P x y z; Suc x < y\<rbrakk> \<Longrightarrow> f z = x*y"
apply (rule mult.commute [THEN ssubst])
oops

lemma "\<lbrakk>x = f x; triple (f x) (f x) x\<rbrakk> \<Longrightarrow> triple x x x"
apply (erule ssubst)
  --{* @{subgoals[display,indent=0,margin=65]} *}
back --{* @{subgoals[display,indent=0,margin=65]} *}
back --{* @{subgoals[display,indent=0,margin=65]} *}
back --{* @{subgoals[display,indent=0,margin=65]} *}
back --{* @{subgoals[display,indent=0,margin=65]} *}
apply assumption
done

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
apply (erule ssubst, assumption)
done

text{*
or better still
*}

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
by (erule ssubst)

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
apply (erule_tac P="\<lambda>u. triple u u x" in ssubst)
apply (assumption)
done

lemma "\<lbrakk> x = f x; triple (f x) (f x) x \<rbrakk> \<Longrightarrow> triple x x x"
by (erule_tac P="\<lambda>u. triple u u x" in ssubst)

text {*
negation

@{thm[display] notI}
\rulename{notI}

@{thm[display] notE}
\rulename{notE}

@{thm[display] classical}
\rulename{classical}

@{thm[display] contrapos_pp}
\rulename{contrapos_pp}

@{thm[display] contrapos_pn}
\rulename{contrapos_pn}

@{thm[display] contrapos_np}
\rulename{contrapos_np}

@{thm[display] contrapos_nn}
\rulename{contrapos_nn}
*}

lemma "\<lbrakk>\<not>(P\<longrightarrow>Q); \<not>(R\<longrightarrow>Q)\<rbrakk> \<Longrightarrow> R"
apply (erule_tac Q="R\<longrightarrow>Q" in contrapos_np)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (intro impI)
        --{* @{subgoals[display,indent=0,margin=65]} *}
by (erule notE)

text {*
@{thm[display] disjCI}
\rulename{disjCI}
*}

lemma "(P \<or> Q) \<and> R \<Longrightarrow> P \<or> Q \<and> R"
apply (intro disjCI conjI)
        --{* @{subgoals[display,indent=0,margin=65]} *}

apply (elim conjE disjE)
 apply assumption
        --{* @{subgoals[display,indent=0,margin=65]} *}

by (erule contrapos_np, rule conjI)
text{*
proof\ {\isacharparenleft}prove{\isacharparenright}{\isacharcolon}\ step\ {\isadigit{6}}\isanewline
\isanewline
goal\ {\isacharparenleft}lemma{\isacharparenright}{\isacharcolon}\isanewline
{\isacharparenleft}P\ {\isasymor}\ Q{\isacharparenright}\ {\isasymand}\ R\ {\isasymLongrightarrow}\ P\ {\isasymor}\ Q\ {\isasymand}\ R\isanewline
\ {\isadigit{1}}{\isachardot}\ {\isasymlbrakk}R{\isacharsemicolon}\ Q{\isacharsemicolon}\ {\isasymnot}\ P{\isasymrbrakk}\ {\isasymLongrightarrow}\ Q\isanewline
\ {\isadigit{2}}{\isachardot}\ {\isasymlbrakk}R{\isacharsemicolon}\ Q{\isacharsemicolon}\ {\isasymnot}\ P{\isasymrbrakk}\ {\isasymLongrightarrow}\ R
*}

text{*rule_tac, etc.*}

lemma "P&Q"
apply (rule_tac P=P and Q=Q in conjI)
oops

text{*unification failure trace *}

declare [[unify_trace_failure = true]]

lemma "P(a, f(b, g(e,a), b), a) \<Longrightarrow> P(a, f(b, g(c,a), b), a)"
txt{*
@{subgoals[display,indent=0,margin=65]}
apply assumption
Clash: e =/= c

Clash: == =/= Trueprop
*}
oops

lemma "\<forall>x y. P(x,y) --> P(y,x)"
apply auto
txt{*
@{subgoals[display,indent=0,margin=65]}
apply assumption

Clash: bound variable x (depth 1) =/= bound variable y (depth 0)

Clash: == =/= Trueprop
Clash: == =/= Trueprop
*}
oops

declare [[unify_trace_failure = false]]

text{*Quantifiers*}

text {*
@{thm[display] allI}
\rulename{allI}

@{thm[display] allE}
\rulename{allE}

@{thm[display] spec}
\rulename{spec}
*}

lemma "\<forall>x. P x \<longrightarrow> P x"
apply (rule allI)
by (rule impI)

lemma "(\<forall>x. P \<longrightarrow> Q x) \<Longrightarrow> P \<longrightarrow> (\<forall>x. Q x)"
apply (rule impI, rule allI)
apply (drule spec)
by (drule mp)

text{*rename_tac*}
lemma "x < y \<Longrightarrow> \<forall>x y. P x (f y)"
apply (intro allI)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rename_tac v w)
        --{* @{subgoals[display,indent=0,margin=65]} *}
oops

lemma "\<lbrakk>\<forall>x. P x \<longrightarrow> P (h x); P a\<rbrakk> \<Longrightarrow> P(h (h a))"
apply (frule spec)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (drule mp, assumption)
apply (drule spec)
        --{* @{subgoals[display,indent=0,margin=65]} *}
by (drule mp)

lemma "\<lbrakk>\<forall>x. P x \<longrightarrow> P (f x); P a\<rbrakk> \<Longrightarrow> P(f (f a))"
by blast

text{*
the existential quantifier*}

text {*
@{thm[display]"exI"}
\rulename{exI}

@{thm[display]"exE"}
\rulename{exE}
*}

text{*
instantiating quantifiers explicitly by rule_tac and erule_tac*}

lemma "\<lbrakk>\<forall>x. P x \<longrightarrow> P (h x); P a\<rbrakk> \<Longrightarrow> P(h (h a))"
apply (frule spec)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (drule mp, assumption)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (drule_tac x = "h a" in spec)
        --{* @{subgoals[display,indent=0,margin=65]} *}
by (drule mp)

text {*
@{thm[display]"dvd_def"}
\rulename{dvd_def}
*}

lemma mult_dvd_mono: "\<lbrakk>i dvd m; j dvd n\<rbrakk> \<Longrightarrow> i*j dvd (m*n :: nat)"
apply (simp add: dvd_def)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule exE)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule exE)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rename_tac l)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule_tac x="k*l" in exI)
        --{* @{subgoals[display,indent=0,margin=65]} *}
apply simp
done

text{*
Hilbert-epsilon theorems*}

text{*
@{thm[display] the_equality[no_vars]}
\rulename{the_equality}

@{thm[display] some_equality[no_vars]}
\rulename{some_equality}

@{thm[display] someI[no_vars]}
\rulename{someI}

@{thm[display] someI2[no_vars]}
\rulename{someI2}

@{thm[display] someI_ex[no_vars]}
\rulename{someI_ex}

needed for examples

@{thm[display] inv_def[no_vars]}
\rulename{inv_def}

@{thm[display] Least_def[no_vars]}
\rulename{Least_def}

@{thm[display] order_antisym[no_vars]}
\rulename{order_antisym}
*}

lemma "inv Suc (Suc n) = n"
by (simp add: inv_def)

text{*but we know nothing about inv Suc 0*}

theorem Least_equality:
     "\<lbrakk> P (k::nat);  \<forall>x. P x \<longrightarrow> k \<le> x \<rbrakk> \<Longrightarrow> (LEAST x. P(x)) = k"
apply (simp add: Least_def)

txt{*
@{subgoals[display,indent=0,margin=65]}
*}

apply (rule the_equality)

txt{*
@{subgoals[display,indent=0,margin=65]}

first subgoal is existence; second is uniqueness
*}
by (auto intro: order_antisym)

theorem axiom_of_choice:
     "(\<forall>x. \<exists>y. P x y) \<Longrightarrow> \<exists>f. \<forall>x. P x (f x)"
apply (rule exI, rule allI)

txt{*
@{subgoals[display,indent=0,margin=65]}

state after intro rules
*}
apply (drule spec, erule exE)

txt{*
@{subgoals[display,indent=0,margin=65]}

applying @text{someI} automatically instantiates
@{term f} to @{term "\<lambda>x. SOME y. P x y"}
*}

by (rule someI)

(*both can be done by blast, which however hasn't been introduced yet*)
lemma "[| P (k::nat);  \<forall>x. P x \<longrightarrow> k \<le> x |] ==> (LEAST x. P(x)) = k"
apply (simp add: Least_def LeastM_def)
by (blast intro: some_equality order_antisym)

theorem axiom_of_choice': "(\<forall>x. \<exists>y. P x y) \<Longrightarrow> \<exists>f. \<forall>x. P x (f x)"
apply (rule exI [of _  "\<lambda>x. SOME y. P x y"])
by (blast intro: someI)

text{*end of Epsilon section*}

lemma "(\<exists>x. P x) \<or> (\<exists>x. Q x) \<Longrightarrow> \<exists>x. P x \<or> Q x"
apply (elim exE disjE)
 apply (intro exI disjI1)
 apply assumption
apply (intro exI disjI2)
apply assumption
done

lemma "(P\<longrightarrow>Q) \<or> (Q\<longrightarrow>P)"
apply (intro disjCI impI)
apply (elim notE)
apply (intro impI)
apply assumption
done

lemma "(P\<or>Q)\<and>(P\<or>R) \<Longrightarrow> P \<or> (Q\<and>R)"
apply (intro disjCI conjI)
apply (elim conjE disjE)
apply blast
apply blast
apply blast
apply blast
(*apply elim*)
done

lemma "(\<exists>x. P \<and> Q x) \<Longrightarrow> P \<and> (\<exists>x. Q x)"
apply (erule exE)
apply (erule conjE)
apply (rule conjI)
 apply assumption
apply (rule exI)
 apply assumption
done

lemma "(\<exists>x. P x) \<and> (\<exists>x. Q x) \<Longrightarrow> \<exists>x. P x \<and> Q x"
apply (erule conjE)
apply (erule exE)
apply (erule exE)
apply (rule exI)
apply (rule conjI)
 apply assumption
oops

lemma "\<forall>y. R y y \<Longrightarrow> \<exists>x. \<forall>y. R x y"
apply (rule exI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule allI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (drule spec)
  --{* @{subgoals[display,indent=0,margin=65]} *}
oops

lemma "\<forall>x. \<exists>y. x=y"
apply (rule allI)
apply (rule exI)
apply (rule refl)
done

lemma "\<exists>x. \<forall>y. x=y"
apply (rule exI)
apply (rule allI)
oops

end