(*  Title:      Border Array
    File:       CoW.Border_Array
    Author:     Štěpán Holub, Charles University

Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
*)

theory Border_Array

imports
 CoWBasic

begin

subsection \<open>Auxiliary lemmas on suffix and border extension\<close>

lemma border_ConsD: assumes "b#x \<le>b a#w"
  shows "a = b" and
        "x \<noteq> \<epsilon> \<Longrightarrow> x \<le>b w" and
        border_ConsD_neq: "x \<noteq> w" and
        border_ConsD_pref: "x \<le>p w" and
        border_ConsD_suf: "x \<le>s w"
proof-
  show "a = b"
    using borderD_pref[OF assms] by force
  show "x \<noteq> w" and "x \<le>p w" and "x \<le>s w"
    using borderD_neq[OF assms, unfolded \<open>a = b\<close>]
      borderD_pref[OF assms, unfolded Cons_prefix_Cons]
      suffix_ConsD2[OF borderD_suf[OF assms]] by force+
  thus "x \<noteq> \<epsilon> \<Longrightarrow> x \<le>b w"
    unfolding border_def  by blast
qed

lemma ext_suf_Cons:
  "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>| \<Longrightarrow> u \<le>s w \<Longrightarrow> (w!i)#u \<le>s (w!i)#w"
proof-
  assume "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|" and "u \<le>s w"
  hence "u = drop (Suc i) w"
    unfolding suf_def using \<open>Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\<close> by auto
  have "i < \<^bold>|w\<^bold>|"
    using \<open>Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\<close> by auto
  from id_take_nth_drop[OF this, folded \<open>u = drop (Suc i) w\<close>]
  show "w ! i # u \<le>s w ! i # w"
    using suffix_ConsI triv_suf by metis
qed

lemma ext_suf_Cons_take_drop: assumes "take k (drop (Suc i) w) \<le>s drop (Suc i) w" and "w ! i = w ! (\<^bold>|w\<^bold>| - Suc k)"
  shows "take (Suc k) (drop i w) \<le>s drop i w"
proof (cases "(Suc k) + i < \<^bold>|w\<^bold>|", simp_all)
  assume "Suc (k + i) < \<^bold>|w\<^bold>|"

  hence "i < \<^bold>|w\<^bold>|"
    by simp

  have "Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) = \<^bold>|w\<^bold>| - Suc(i+k)"
    using Suc_diff_Suc \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close>
    by (simp add: Suc_diff_Suc)

  have "\<^bold>|take k (drop (Suc i) w)\<^bold>| = k"
    using \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close> by fastforce

  have "Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) + \<^bold>|take k (drop (Suc i) w)\<^bold>| = \<^bold>|drop (Suc i) w\<^bold>|"
    unfolding \<open>\<^bold>|take k (drop (Suc i) w)\<^bold>| = k\<close> \<open>Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) = \<^bold>|w\<^bold>| - Suc(i+k)\<close>
    using  \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close> by simp

  hence "\<^bold>|drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w)\<^bold>| = k"
    using  \<open>i < \<^bold>|w\<^bold>|\<close> by fastforce
  have "\<^bold>|w\<^bold>| - Suc i - k < \<^bold>|drop i w\<^bold>|"
    by (metis Suc_diff_Suc \<open>i < \<^bold>|w\<^bold>|\<close> diff_less_Suc length_drop)

  have "(drop i w)!(\<^bold>|w\<^bold>| - Suc i - k) = w ! i"
    using \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close> \<open>w ! i = w ! (\<^bold>|w\<^bold>| - Suc k)\<close> by auto

  have "take (Suc k) (drop i w) = w!i#take k (drop (Suc i) w)"
    using Cons_nth_drop_Suc[OF \<open>i < \<^bold>|w\<^bold>|\<close>] take_Suc_Cons[of k "w!i" "drop (Suc i) w"] by argo

  have "drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w) = drop (\<^bold>|w\<^bold>| - Suc i - k) (drop (Suc i) w)"
    by auto
  hence "drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w) = take k (drop (Suc i) w)"
    using \<open>\<^bold>|take k (drop (Suc i) w)\<^bold>| = k\<close>
      \<open>take k (drop (Suc i) w) \<le>s drop (Suc i) w\<close> suf_drop_conv length_drop by metis

  with
    id_take_nth_drop[OF \<open>\<^bold>|w\<^bold>| - Suc i - k < \<^bold>|drop i w\<^bold>|\<close>]
  show ?thesis
    unfolding \<open>(drop i w)!(\<^bold>|w\<^bold>| - Suc i - k) = w ! i\<close>
      \<open>take (Suc k) (drop i w) = w!i#take k (drop (Suc i) w)\<close>
    unfolding suf_def by auto
qed

lemma ext_border_Cons:
  "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>| \<Longrightarrow> u \<le>b w \<Longrightarrow> (w!i)#u \<le>b (w!i)#w"
  unfolding border_def using ext_suf_Cons Cons_prefix_Cons list.discI list.inject by metis

lemma border_add_Cons_len: assumes "max_borderP u w" and "v \<le>b (a#w)" shows "\<^bold>|v\<^bold>| \<le> Suc \<^bold>|u\<^bold>|"
proof-
  have "v \<noteq> \<epsilon>"
    using \<open>v \<le>b (a#w)\<close> by simp
  then obtain v' where "v = a#v'"
    using  borderD_pref[OF \<open>v \<le>b (a#w)\<close>, unfolded prefix_Cons] by blast
  show "\<^bold>|v\<^bold>| \<le> Suc \<^bold>|u\<^bold>|"
  proof (cases "v' = \<epsilon>", simp add: \<open>v = a#v'\<close>)
    assume "v' \<noteq> \<epsilon>"
    have "w \<noteq> \<epsilon>"
      using  borderedI[OF \<open>v \<le>b (a#w)\<close>] sing_not_bordered[of a] by blast
    have "v' \<le>b w"
      using border_ConsD(2)[OF \<open>v \<le>b (a#w)\<close>[unfolded \<open>v = a # v'\<close>] \<open>v' \<noteq> \<epsilon>\<close>].
    thus "\<^bold>|v\<^bold>| \<le> Suc \<^bold>|u\<^bold>|"
      unfolding \<open>v = a # v'\<close> length_Cons Suc_le_mono
      using \<open>max_borderP u w\<close>[unfolded max_borderP_def]
        prefix_length_le by blast
  qed
qed

section \<open>Computing the Border Array\<close>

text\<open>The computation is a special case of the Knuth-Morris-Pratt algorithm.\<close>

text\<open>
\<^item> KMP w arr bord pos
\<^item> w: processed word does not change; it is processed starting from the last letter
\<^item> pos: actually examined pos-th letter; that is, it is w!(pos-1)
\<^item> arr: already calculated suffix-border-array of w;
       that is, the length of array is (|w| - pos)
       and arr!(|w| - pos - bord) is the max border length of the suffix of w of length bord
\<^item> bord: length of the current max border length candidate
       to see whether it can be extended we compare: w!(pos-1) ?= w!(|w| - (Suc bord));
       (Suc bord) is the length of the max border if the comparison is succesful
\<^item>      if the comparison fails we move to the max border of the suffix of length bord;
       its max border length is stored in arr!(|w| - pos - bord)
\<^item>      if bord was 0 and the comparison failed, the word is unbordered
\<close>

fun   KMP_arr :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list"
  and KMP_bord :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  and KMP_pos :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "KMP_arr _ arr _ 0 = arr" |
    "KMP_bord _ _ bord 0 = bord" |
    "KMP_pos _ _ _ 0 = 0" |
    "KMP_arr w arr bord (Suc i) =
          (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord))
          then  (Suc bord) # arr
          else (if bord = 0
                then  0#arr
                else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord
                      then arr
                      else  undefined#arr \<comment> \<open>else: dummy termination condition\<close>
                      )
                )
          )" |
    "KMP_bord w arr bord (Suc i) =
          (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord))
          then Suc bord
          else (if bord = 0
                 then  0
                 else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord
                       then arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)
                       else  0 \<comment> \<open>else: dummy termination condition\<close>
                      )
                 )
          )" |
    "KMP_pos w arr bord (Suc i) =
          (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord))
          then i
          else (if bord = 0
                 then  i
                 else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord
                       then Suc i
                       else  i \<comment> \<open>else: dummy termination condition\<close>
                      )
                 )
          )"

function KMP :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "KMP w arr bord 0 = arr"  |
  "KMP w arr bord (Suc i) = KMP w (KMP_arr w arr bord (Suc i)) (KMP_bord w arr bord (Suc i)) (KMP_pos w arr bord (Suc i))"
  using not0_implies_Suc by (force+)
termination
  by (relation "measures [\<lambda>(_, _ , compar, pos). pos,\<lambda>(_, _ , compar, pos). compar]", simp_all)

lemma KMP_len: "\<^bold>|KMP w arr bord pos\<^bold>| = \<^bold>|arr\<^bold>| + pos"
proof (induct rule: KMP.induct[of "\<lambda> w arr bord pos. \<^bold>|KMP w arr bord pos\<^bold>| = \<^bold>|arr\<^bold>| + pos"], simp)
  case (2 w arr bord i)
  then show ?case using KMP.simps(2)[of w arr bord i] by force
qed

value[nbe] "KMP [a] [0] 0 0"

value "KMP [ 0::nat] [0] 0 0"
value "KMP [5,4::nat,5,3,5,5] [0] 0 5"
value "KMP [5,4::nat,5,3,5,5] [1,0] 1 4"
value "KMP [0,1,1,0::nat,0,0,1,1,1] [0] 0 8"
value "KMP [0::nat,1] [0] 0 1"

subsection \<open>Verification of the computation\<close>

definition KMP_valid :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "KMP_valid w arr bord pos = (\<^bold>|arr\<^bold>| + pos = \<^bold>|w\<^bold>|  \<and>
                                    \<comment> \<open>bord is the length of a border of (drop pos w), or 0\<close>
                                    pos + bord < \<^bold>|w\<^bold>| \<and>
                                    take bord (drop pos w) \<le>p (drop pos w) \<and>
                                    take bord (drop pos w) \<le>s (drop pos w) \<and>
                                    \<comment> \<open>... and no longer border can be extended\<close>
                                    (\<forall> v. v \<le>b w!(pos - 1)#(drop pos w) \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc bord) \<and>
                                    \<comment> \<open>the array gives maximal border lengths of corresponding suffixes\<close>
                                    (\<forall> k < \<^bold>|arr\<^bold>|. max_borderP (take (arr!k) (drop (pos + k) w)) (drop (pos + k) w))
                                    )"

lemma " KMP_valid w arr bord pos  \<Longrightarrow> w \<noteq> \<epsilon>"
  unfolding KMP_valid_def
  using le_antisym less_imp_le_nat less_not_refl2 take_Nil take_all_iff by metis

lemma KMP_valid_base: assumes "w \<noteq> \<epsilon>" shows "KMP_valid w [0] 0 (\<^bold>|w\<^bold>|-1)"
proof (unfold KMP_valid_def, intro conjI)
  show "\<^bold>|[0]\<^bold>| + (\<^bold>|w\<^bold>| - 1) = \<^bold>|w\<^bold>|"
    by (simp add: assms)
  show "\<^bold>|w\<^bold>| - 1 + 0 < \<^bold>|w\<^bold>|"
    using \<open>w \<noteq> \<epsilon>\<close>  by simp
  show "take 0 (drop (\<^bold>|w\<^bold>| - 1) w) \<le>p drop (\<^bold>|w\<^bold>| - 1) w"
    by simp
  show "take 0 (drop (\<^bold>|w\<^bold>| - 1) w) \<le>s drop (\<^bold>|w\<^bold>| - 1) w"
    by simp
  show "\<forall>v. v \<le>b w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc 0"
  proof (rule allI, rule impI)
     fix v assume b: "v \<le>b w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w"
    have "\<^bold>|w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w\<^bold>| = Suc (Suc 0)"
      using \<open>\<^bold>|[0]\<^bold>| + (\<^bold>|w\<^bold>| - 1) = \<^bold>|w\<^bold>|\<close> by auto
    from border_len(3)[OF b, unfolded this]
    show "\<^bold>|v\<^bold>| \<le> Suc 0"
      using border_len(3)[OF b] by simp
  qed
  have  "\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|"
    by simp
  have "butlast w \<cdot> [last w] = w"
    by (simp add: assms)
  hence last:  "drop (\<^bold>|w\<^bold>| - Suc 0) w = [last w]"
    unfolding \<open>\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|\<close> using drop_pref by metis
  show "\<forall>k<\<^bold>|[0]\<^bold>|. max_borderP (take ([0] ! k) (drop (\<^bold>|w\<^bold>| - 1 + k) w)) (drop (\<^bold>|w\<^bold>| - 1 + k) w)"
  proof (simp add: last, unfold max_borderP_def)
    have "\<forall>v. v \<le>b [last w] \<longrightarrow> v \<le>p \<epsilon>"
      by (meson borderedI sing_not_bordered)
    thus "\<epsilon> \<le>p [last w] \<and> \<epsilon> \<le>s [last w] \<and> (\<epsilon> = [last w] \<longrightarrow> [last w] = \<epsilon>) \<and> (\<forall>v. v \<le>b [last w] \<longrightarrow> v \<le>p \<epsilon>)"
      by simp
  qed
qed

lemma KMP_valid_step: assumes "KMP_valid w arr bord (Suc i)"
  shows "KMP_valid  w (KMP_arr w arr bord (Suc i)) (KMP_bord w arr bord (Suc i)) (KMP_pos w arr bord (Suc i))"
proof-
  \<comment> \<open>Consequences of the assumption\<close>
  have all_k: "\<forall>k<\<^bold>|arr\<^bold>|. max_borderP (take (arr ! k) (drop (Suc i + k) w)) (drop (Suc i + k) w)"
    using assms[unfolded KMP_valid_def] by blast
  have "\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|" and
    "Suc i + bord < \<^bold>|w\<^bold>|" and
    bord_pref: "take bord (drop (Suc i) w) \<le>p drop (Suc i) w" and
    bord_suf: "take bord (drop (Suc i) w) \<le>s drop (Suc i) w" and
    up_bord: "\<And> v. v \<le>b w!i#(drop (Suc i) w) \<Longrightarrow> \<^bold>|v\<^bold>| \<le> Suc bord" and
    all_k_neq0: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) = drop (Suc i + k) w \<longrightarrow> drop (Suc i + k) w = \<epsilon>" and
    all_k_pref: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) \<le>p drop (Suc i + k) w" and
    all_k_suf: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) \<le>s drop (Suc i + k) w" and
    all_k_v: "\<And> k v. k < \<^bold>|arr\<^bold>| \<Longrightarrow> v \<le>b drop (Suc i + k) w \<Longrightarrow> v \<le>p take (arr ! k) (drop (Suc i + k) w)"
    using assms[unfolded KMP_valid_def max_borderP_def diff_Suc_1] by blast+
  have all_k_neq: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) \<noteq> drop (Suc i + k) w"
    using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> all_k_neq0
    add.commute add_le_imp_le_left drop_all_iff le_antisym less_imp_le_nat less_not_refl2 by metis

  have "w \<noteq> \<epsilon>"
    using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
  have "Suc i < \<^bold>|w\<^bold>|"
    using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>  by simp
  have pop_i: "drop i w = (w!i)# (drop (Suc i) w)"
    by (simp add: Cons_nth_drop_Suc Suc_lessD \<open>Suc i < \<^bold>|w\<^bold>|\<close>)
  have "drop (Suc i) w \<noteq> \<epsilon>"
    using \<open>Suc i < \<^bold>|w\<^bold>|\<close> by fastforce
  have "Suc i + (\<^bold>|w\<^bold>| - Suc i - bord) = \<^bold>|w\<^bold>| - bord"
    unfolding diff_right_commute[of _ _ bord] using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>  by linarith

  show "KMP_valid  w (KMP_arr w arr bord (Suc i)) (KMP_bord w arr bord (Suc i)) (KMP_pos w arr bord (Suc i))"
  proof (cases "w ! i = w ! (\<^bold>|w\<^bold>| - Suc bord)")
    assume match: "w ! i = w ! (\<^bold>|w\<^bold>| - Suc bord)" \<comment> \<open>The current candidate is extendable\<close>
    show ?thesis
    proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_P[OF match], intro conjI)
      show "\<^bold>|Suc bord # arr\<^bold>| + i = \<^bold>|w\<^bold>|"
        using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
      show "i + Suc bord < \<^bold>|w\<^bold>|"
        using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> by auto
      show "take (Suc bord) (drop i w) \<le>p drop i w"
        using take_is_prefix by auto
      show "take (Suc bord) (drop i w) \<le>s drop i w"
        using \<open>take bord (drop (Suc i) w) \<le>s drop (Suc i) w\<close> ext_suf_Cons_take_drop match by blast
          \<comment> \<open>The new border array is correct\<close>
      show all_k_new: "\<forall>k<\<^bold>|Suc bord # arr\<^bold>|. max_borderP (take ((Suc bord # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
      proof (rule allI, rule impI)
        fix k assume "k < \<^bold>|Suc bord # arr\<^bold>|"
        show "max_borderP (take ((Suc bord # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
        proof (cases "0 < k")
          assume "0 < k" \<comment> \<open>old entries are valid:\<close>
          thus ?thesis using all_k
            by (metis Suc_less_eq \<open>k < \<^bold>|Suc bord # arr\<^bold>|\<close> add.right_neutral add_Suc_shift gr0_implies_Suc list.size(4) nth_Cons_Suc)
        next
          assume "\<not> 0 < k" hence "k = 0" by simp
          show ?thesis \<comment> \<open>the extended border is maximal:\<close>
          proof (simp add: \<open>k = 0\<close>, unfold max_borderP_def, intro conjI)
            show "take (Suc bord) (drop i w) = drop i w \<longrightarrow> drop i w = \<epsilon>"
              using \<open>i + Suc bord < \<^bold>|w\<^bold>|\<close> by fastforce
            show "take (Suc bord) (drop i w) \<le>p drop i w"
              using \<open>take (Suc bord) (drop i w) \<le>p drop i w\<close> by blast
            show "take (Suc bord) (drop i w) \<le>s drop i w" by fact
            show "\<forall>v. v \<le>b drop i w \<longrightarrow> v \<le>p take (Suc bord) (drop i w)"
            proof (rule allI, rule impI)
              fix v assume "v \<le>b drop i w"
              from borderD_pref[OF this] up_bord[OF this[unfolded pop_i]]
              (* have "v \<le>p drop i w". *)
              show "v \<le>p take (Suc bord) (drop i w)"
                 unfolding prefix_def by force
            qed
          qed
        qed
      qed
        \<comment> \<open>the extended border is the longest candidate:\<close>
      have "max_borderP (take (Suc bord) (drop i w)) (drop i w)"
        using  all_k_new[rule_format, of 0, unfolded length_Cons nth_Cons_0 add_0_right, OF zero_less_Suc].
      from border_add_Cons_len[OF this] max_borderP_D_max[OF this] max_borderP_D_neq[OF _ this]
      show "\<forall>v. v \<le>b w ! (i - 1) # drop i w \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc (Suc bord)"
        using nat_le_linear take_all take_len list.discI pop_i by metis
    qed
  next
    assume mismatch: "w ! i \<noteq> w ! (\<^bold>|w\<^bold>| - Suc bord)" \<comment> \<open>The current candidate is not extendable\<close>
    show ?thesis
    proof (cases "bord = 0")
      assume  "bord \<noteq> 0" \<comment> \<open>Recursion: try the maximal border of the current candidate...\<close>
        let ?k  =  "\<^bold>|w\<^bold>| - Suc i - bord" and
            ?w' = "drop (Suc i) w"
        have "?k < \<^bold>|arr\<^bold>|"
        using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> \<open>bord \<noteq> 0\<close> by linarith
      from all_k_neq[OF this]
      have "arr ! ?k < bord" \<comment> \<open>... which is stored in the array, and is shorter\<close>
        by (simp add: \<open>take (arr ! ?k) (drop (Suc i + ?k) w) \<noteq> drop (Suc i + ?k) w\<close> \<open>Suc i + ?k = \<^bold>|w\<^bold>| - bord\<close> \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> add_diff_inverse_nat diff_add_inverse2 gr0I less_diff_conv nat_diff_split_asm )
        let ?old_pref = "take bord ?w'" and
            ?old_suf =  "drop (\<^bold>|w\<^bold>| - bord) w" and
            ?new_pref = "take (arr ! ?k) ?w'"
      show ?thesis
      proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_not_P[OF mismatch] if_not_P[OF \<open>bord \<noteq> 0\<close>] if_P[OF \<open>arr ! ?k < bord\<close>] diff_Suc_1, intro conjI)
        show "\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|"
          using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
        show "Suc i + arr ! ?k < \<^bold>|w\<^bold>|"
          using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>arr ! ?k < bord\<close> by linarith
        show "take (arr ! ?k) (drop (Suc i) w) \<le>p drop (Suc i) w"
          using take_is_prefix by blast

        \<comment> \<open>Next goal: the new border is a suffix\<close>

        have "?old_suf \<le>s ?w'"
          by (meson \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> le_suf_drop less_diff_conv nat_less_le)
        have "\<^bold>|?old_pref\<^bold>| = bord"
          using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> take_len len_after_drop nat_less_le by blast
        also have "... = \<^bold>|?old_suf\<^bold>|"
          using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>  by simp
        ultimately have eq1: "?old_pref = ?old_suf" \<comment> \<open>bord defines a border\<close>
          using \<open>take bord (drop (Suc i) w) \<le>s drop (Suc i) w\<close> \<open>drop (\<^bold>|w\<^bold>| - bord) w \<le>s drop (Suc i) w\<close> suf_ruler_eq_len by metis

        have "\<^bold>|?new_pref\<^bold>| = arr!?k"
          using take_len \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>arr ! ?k < bord\<close> diff_diff_left by force
        have "take (arr ! ?k) ?old_suf \<le>p ?old_pref"
          using take_is_prefix \<open>?old_pref = ?old_suf\<close> by metis
        from pref_take[OF pref_trans[OF this take_is_prefix], unfolded \<open>\<^bold>|?new_pref\<^bold>| = arr!?k\<close>, symmetric]
        have "take (arr ! ?k) ?old_suf = take (arr ! ?k) ?w'"
          using take_len \<open>arr ! ?k < bord\<close> \<open>bord = \<^bold>|drop (\<^bold>|w\<^bold>| - bord) w\<^bold>|\<close> less_imp_le_nat by metis
        from all_k_suf[OF \<open>?k < \<^bold>|arr\<^bold>|\<close>, unfolded \<open>Suc i + ?k = \<^bold>|w\<^bold>| - bord\<close>] this
        have "take (arr ! ?k) ?w' \<le>s ?old_suf" by simp \<comment> \<open>The new prefix is a suffix of the old suffix\<close>

        with \<open>?old_pref \<le>s ?w'\<close>[unfolded \<open>?old_pref = ?old_suf\<close>]
        show "take (arr ! ?k) ?w' \<le>s ?w'"
          using suf_trans by blast

        \<comment> \<open>Key facts about borders of the w'\<close>
            have "?old_pref \<noteq> \<epsilon>"
              using \<open>bord \<noteq> 0\<close> \<open>\<^bold>|?old_pref\<^bold>| = bord\<close> by force
            moreover have "?old_pref \<noteq> ?w'"
              using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>
              by (intro lenarg_not, unfold length_drop \<open>\<^bold>|take bord ?w'\<^bold>| = bord\<close>, linarith)
            ultimately have "?old_pref \<le>b ?w'" \<comment> \<open>bord is the length of a border\<close>
              by (intro borderI[OF bord_pref bord_suf])

        \<comment> \<open>We want to prove that the new border is the longest candidate\<close>
           show "\<forall>v. v \<le>b w !i # ?w' \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc (arr ! ?k)"
             proof (rule allI,rule impI)
               have extendable: "w ! i # v' \<le>b w ! i # ?w' \<Longrightarrow> v' \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|v'\<^bold>| \<le> arr ! ?k" for v' \<comment> \<open>First consider a border of w', which is extendable\<close>
               proof-
                 assume "w!i # v' \<le>b w!i # ?w'" and "v' \<noteq> \<epsilon>"
                 from suf_trans[OF borderD_suf[OF \<open>w!i # v' \<le>b w ! i # ?w'\<close>, folded pop_i] suffix_drop]
                 have "w!i # v' \<le>s w".
                 from this[unfolded suf_drop_conv, THEN nth_via_drop] mismatch
                 have "\<^bold>|w!i # v'\<^bold>| \<noteq> Suc bord"
                   by force
                 with up_bord[OF \<open>w!i # v' \<le>b w ! i # ?w'\<close>]
                 have "\<^bold>|v'\<^bold>| < bord"  \<comment> \<open>It is shorter than the old candidate border\<close>
                   by simp
                 from border_ConsD(2)[OF \<open>w!i # v' \<le>b w ! i # ?w'\<close> \<open>v' \<noteq> \<epsilon>\<close>]
                 have "v' \<le>b ?w'".
                 from borders_compare[OF \<open>?old_pref \<le>b ?w'\<close> this, unfolded  \<open>\<^bold>|?old_pref\<^bold>| = bord\<close>, unfolded \<open>?old_pref = ?old_suf\<close>, OF \<open>\<^bold>|v'\<^bold>| < bord\<close>]
                 have "v' \<le>b ?old_suf". \<comment> \<open>... and therefore its border\<close>
                 from prefix_length_le[OF max_borderP_D_max[OF all_k[rule_format, OF \<open>?k < \<^bold>|arr\<^bold>|\<close>], unfolded \<open>Suc i + ?k = \<^bold>|w\<^bold>| - bord\<close>, OF this]]
                 show "\<^bold>|v'\<^bold>| \<le> arr!?k" \<comment> \<open>... and hence short\<close>
                   using len_take1[of "arr!?k", of w] by simp
               qed
            fix v assume "v \<le>b w!i # ?w'"  \<comment> \<open>Now consider a border of the extended word\<close>
            show "\<^bold>|v\<^bold>| \<le> Suc (arr ! ?k)"
            proof (cases "\<^bold>|v\<^bold>| \<le> Suc 0", simp, drule not_le_imp_less)
              assume "Suc 0 < \<^bold>|v\<^bold>|"
              from hd_tl_longE[OF this]
              obtain a v' where "v = a#v'" and "v' \<noteq> \<epsilon>"
                by blast
              with borderD_pref[OF \<open>v \<le>b w!i # ?w'\<close>, unfolded prefix_Cons]
              have "v = w!i#v'"
                by simp
              from extendable[OF \<open>v \<le>b w!i # ?w'\<close>[unfolded \<open>v = w!i#v'\<close>] \<open>v' \<noteq> \<epsilon>\<close>]
              show ?thesis
                by (simp add: \<open>v = a # v'\<close>)
          qed
        qed
        show " \<forall>k<\<^bold>|arr\<^bold>|. max_borderP (take (arr ! k) (drop (Suc i + k) w)) (drop (Suc i + k) w)"
          using all_k by blast
      qed
    next
      assume "bord = 0" \<comment> \<open>End of recursion.\<close>
      show ?thesis
      proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_not_P[OF mismatch] if_P[OF \<open>bord = 0\<close>], intro conjI)
        show "\<^bold>|0 # arr\<^bold>| + i = \<^bold>|w\<^bold>|"
          using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
        show "i + 0 < \<^bold>|w\<^bold>|"
          by (simp add: Suc_lessD \<open>Suc i < \<^bold>|w\<^bold>|\<close>)
        show "take 0 (drop i w) \<le>p drop i w"
          by simp
        show "take 0 (drop i w) \<le>s drop i w"
          using ext_suf_Cons_take_drop by simp
            \<comment> \<open>The extension is unbordered\<close>
        have "max_borderP \<epsilon> (drop i w)"
        proof(rule ccontr)
          assume "\<not> max_borderP \<epsilon> (drop i w)"
          then obtain a t where "max_borderP (a#t) (drop i w)"
            unfolding pop_i  using max_border_ex[of "w ! i # drop (Suc i) w"] neq_Nil_conv by metis
          from up_bord[OF max_borderP_border[OF this list.simps(3), unfolded pop_i], unfolded \<open>bord = 0\<close>]
          have "t = \<epsilon>" by simp
          from max_borderP_border[OF \<open>max_borderP (a#t) (drop i w)\<close>[unfolded this] list.simps(3)]
          have "[a] \<le>b drop i w".
          from borderD_pref[OF this]
          have "w!i = a"
            by (simp add: pop_i)
          moreover have "w!(\<^bold>|w\<^bold>| - 1) = a"
            using  borderD_suf[OF \<open>[a] \<le>b drop i w\<close>] nth_via_drop sing_len suf_drop_conv suf_share_take suffix_drop suffix_length_le by metis
          ultimately show False
            using mismatch[unfolded \<open>bord = 0\<close>] by simp
        qed
        thus "\<forall>v. v \<le>b w ! (i - 1) # drop i w \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc 0"
          by (metis border_add_Cons_len list.size(3))
            \<comment> \<open>The array is valid: old values from assumption, the first 0 since the extension is unbordered\<close>
        show "\<forall>k<\<^bold>|0 # arr\<^bold>|. max_borderP (take ((0 # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
        proof (rule allI, rule impI)
          fix k assume "k < \<^bold>|0 # arr\<^bold>|"
          show "max_borderP (take ((0 # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
          proof (cases "0 < k")
            assume "0 < k"
            thus ?thesis using all_k
              by (metis Suc_less_eq \<open>k < \<^bold>|0 # arr\<^bold>|\<close> add.right_neutral add_Suc_shift gr0_implies_Suc list.size(4) nth_Cons_Suc)
          next
            assume "\<not> 0 < k" hence "k = 0" by simp
            thus ?thesis
              using \<open>max_borderP \<epsilon> (drop i w)\<close> by auto
          qed
        qed
      qed
    qed
  qed
qed

lemma KMP_valid_max:  "\<forall> k. KMP_valid w arr bord pos \<longrightarrow> k < \<^bold>|w\<^bold>| \<longrightarrow> max_borderP (take ((KMP w arr bord pos)!k) (drop k w)) (drop k w)"
proof (induct
    rule: KMP.induct[of "\<lambda> w arr bord pos.
(\<forall> k. KMP_valid w arr bord pos \<longrightarrow> k < \<^bold>|w\<^bold>| \<longrightarrow> max_borderP (take ((KMP w arr bord pos)!k) (drop k w)) (drop k w))"]
      )
  case (1 w arr bord)
  then show ?case
    unfolding KMP.simps KMP_valid_def by simp
next
  case (2 w arr bord i)
  then show ?case
    unfolding KMP.simps using KMP_valid_step by blast
qed

section \<open>Border array\<close>

fun border_array :: "'a list \<Rightarrow> nat list" where
  "border_array \<epsilon> = \<epsilon>"
| "border_array (a#w) = rev (KMP (rev (a#w)) [0] 0 (\<^bold>|a#w\<^bold>|-1))"

lemma border_array_len: "\<^bold>|border_array w\<^bold>| = \<^bold>|w\<^bold>|"
  by (induct w, simp_all add: KMP_len)

theorem bord_array: assumes "Suc k \<le> \<^bold>|w\<^bold>|" shows "(border_array w)!k = \<^bold>|max_border (take (Suc k) w)\<^bold>|"
proof-
  define m where "m = \<^bold>|w\<^bold>| - Suc k"
  hence "m < \<^bold>|rev w\<^bold>|"
    by (simp add: Suc_diff_Suc assms less_eq_Suc_le)
  have "rev w \<noteq> \<epsilon>" and "k < \<^bold>|rev w\<^bold>|"
    using \<open>Suc k \<le> \<^bold>|w\<^bold>|\<close> by auto
  hence "w = hd w#tl w"
    by simp
  from arg_cong[OF border_array.simps(2)[of "hd w" "tl w", folded this], of rev, unfolded rev_rev_ident]
  have "rev (border_array w) =  (KMP (rev w) [0] 0 (\<^bold>|w\<^bold>|-1))".
  hence "max_borderP (take (rev (border_array w)!m) (drop m (rev w))) (drop m (rev w))"
    using KMP_valid_max[rule_format, OF KMP_valid_base[OF \<open>rev w \<noteq> \<epsilon>\<close>] \<open>m < \<^bold>|rev w\<^bold>|\<close>] by simp
  hence  "max_border (drop m (rev w)) = take (rev (border_array w)!m) (drop m (rev w))"
    using max_borderP_max_border by blast
  hence  "\<^bold>|max_border (drop m (rev w))\<^bold>| =  rev (border_array w)!m"
    by (metis \<open>m < \<^bold>|rev w\<^bold>|\<close> drop_all_iff leD max_border_nemp_neq nat_le_linear take_all take_len)
  thus ?thesis
    using m_def
    by (metis Suc_diff_Suc \<open>k < \<^bold>|rev w\<^bold>|\<close> \<open>m < \<^bold>|rev w\<^bold>|\<close> border_array_len diff_diff_cancel drop_rev length_rev less_imp_le_nat max_border_len_rev rev_nth)
qed

lemma max_border_comp [code]: "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w"
proof (cases "w = \<epsilon>")
  assume "w = \<epsilon>"
  thus "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w"
    using max_bord_take take_Nil by metis
next
  assume "w \<noteq> \<epsilon>"
  hence "Suc (\<^bold>|w\<^bold>| - 1) \<le> \<^bold>|w\<^bold>|" by simp
  from bord_array[OF this]
  have "(border_array w)!(\<^bold>|w\<^bold>|-1) = \<^bold>|max_border w\<^bold>|"
    by (simp add: \<open>w \<noteq> \<epsilon>\<close>)
  thus "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w"
    using max_bord_take by auto
qed

value[nbe] "primitive [a,b,a]"

value "primitive [0::nat,1,0]"

value "border_array [5,4::nat,5,3,5,5,5,4,5]"

value "primitive [5,4::nat,5,3,5,5,5,4,5]"

value "primitive [5,4::nat,5,3,5,5,5,4,5]"

value[nbe] "bordered []"

value "border_array [0::nat,1,1,0,0,0,1,1,1,1,1,0,0,0,1,1,1,0,1,1,0,0,0,1,1,1,1,1,1,0,0,0,1,1,1,0,1,1,0,0,0,1,1,1,0,1,1,0,0,0,1,1,1,0,0,1,0]"

value[nbe] "border_array \<epsilon>"

value "border_array [1,0::nat,1,0,1,1,0,0]"

value "max_border [1,0::nat,1,0,1,1,0,0,1,0,1,1,0::nat,1,0,1,1,0,0,1,0,1,1,0::nat,1,0,1,1,0,0,1,0,1,0,0,1]"

value "bordered [1,0::nat,1,0,1,1,0,1]"

value "\<^bold>|\<pi> [1::nat,0,1,0,1,1,0,1]\<^bold>|"

end


(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Models of Regular Algebra\<close>

theory Regular_Algebra_Models
  imports Regular_Algebras Kleene_Algebra.Kleene_Algebra_Models
begin

subsection \<open>Language Model of Salomaa Algebra\<close>

abbreviation w_length :: "'a list \<Rightarrow> nat" ( "|_|")
  where "|x| \<equiv> length x"

definition l_ewp :: "'a lan \<Rightarrow> bool" where
  "l_ewp X \<longleftrightarrow> {[]} \<subseteq> X"

interpretation lan_kozen: K2_algebra "(+)" "(\<cdot>)" "1 :: 'a lan" 0 "(\<subseteq>)" "(\<subset>)" "star" ..

interpretation lan_boffa: B1_algebra "(+)" "(\<cdot>)" "1 :: 'a lan" 0 "(\<subseteq>)" "(\<subset>)" "star" ..

lemma length_lang_pow_lb:
  assumes "\<forall>x\<in>X. |x| \<ge> k" "x \<in> X^n"
  shows "|x| \<ge> k*n"
using assms proof (induct n arbitrary: x)
  case 0 thus ?case by auto
next
  case (Suc n)
  note hyp = this
  thus ?case
  proof -
    have "x \<in> X\<^bsup>Suc n\<^esup> \<longleftrightarrow> (\<exists> y z. x = y@z \<and> y \<in> X \<and> z \<in> X\<^bsup>n\<^esup>)"
      by (simp add:c_prod_def times_list_def)
    also from hyp have "... \<longrightarrow> (\<exists> y z. x = y@z \<and> |y| \<ge> k \<and> |z| \<ge> k*n)"
      by auto
    also have "... \<longleftrightarrow> (\<exists> y z. x = y@z \<and> |y| \<ge> k \<and> |z| \<ge> k*n \<and> ( |x| = |y| + |z| ))"
      by force
    also have "... \<longleftrightarrow> (\<exists> y z. x = y@z \<and> |y| \<ge> k \<and> |z| \<ge> k*n \<and> ( |x| \<ge> (n + 1) * k ))"
      by (auto, metis add_mono mult.commute, force)
    finally show ?thesis
      by (metis Suc_eq_plus1 hyp(3) mult.commute)
  qed
qed

lemma l_prod_elim: "w\<in>X \<cdot> Y \<longleftrightarrow> (\<exists>u v. w = u@v \<and> u\<in>X \<and> v\<in>Y)"
  by (simp add: c_prod_def times_list_def)

lemma power_minor_var:
  assumes "\<forall>w\<in>X. k\<le>|w|"
  shows "\<forall>w\<in>X\<^bsup>Suc n\<^esup>. n*k\<le>|w|"
  using assms
  apply (auto simp add: l_prod_elim)
  using length_lang_pow_lb trans_le_add2
  by (simp add: length_lang_pow_lb trans_le_add2 mult.commute)

lemma power_lb: "(\<forall>w\<in>X. k\<le>|w| ) \<longrightarrow> (\<forall>w. w\<in>X\<^bsup>Suc n\<^esup> \<longrightarrow> n*k\<le>|w| )"
  by (metis power_minor_var)

lemma prod_lb:
  "\<lbrakk> (\<forall>w\<in>X. m \<le> length w); (\<forall>w\<in>Y. n \<le> length w) \<rbrakk> \<Longrightarrow> (\<forall>w\<in>(X\<cdot>Y). (m+n) \<le> length w)"
  by (metis l_prod_elim add_le_mono length_append)

lemma suicide_aux_l:
  "\<lbrakk> (\<forall>w\<in>Y. 0\<le>length w); (\<forall>w\<in>X\<^bsup>Suc n\<^esup>. n \<le> length w) \<rbrakk> \<Longrightarrow> (\<forall>w\<in>X\<^bsup>Suc n \<^esup>\<cdot> Y. n \<le> length w)"
  apply (auto simp: l_prod_elim)
  apply (drule_tac x="ua @ va" in bspec)
  apply (auto simp add: l_prod_elim)
done

lemma suicide_aux_r:
  "\<lbrakk> (\<forall>w\<in>Y. 0\<le>length w); (\<forall>w\<in>X\<^bsup>Suc n\<^esup>. n \<le> length w) \<rbrakk> \<Longrightarrow> (\<forall>w\<in>Y \<cdot> X\<^bsup>Suc n\<^esup>. n \<le> length w)"
  by (auto, metis (full_types) le0 plus_nat.add_0 prod_lb)

lemma word_suicide_l:
  assumes "\<not> l_ewp X" "Y \<noteq> {}"
  shows "(\<forall>w\<in>Y. \<exists>n. w\<notin>X\<^bsup>Suc n \<^esup>\<cdot> Y)"
proof -
  have  "\<forall>v\<in>Y. 0\<le>length v"
    by (metis le0)
  from assms have "\<forall>v\<in>X. 1\<le>length v"
    by (simp add: l_ewp_def, metis le_0_eq length_0_conv not_less_eq_eq)
  hence "\<forall>w\<in>Y. \<exists>n. w\<notin>X\<^bsup>Suc n \<^esup>\<cdot> Y"
    by (metis nat_mult_1_right power_lb suicide_aux_l le0 Suc_n_not_le_n)
  thus ?thesis by metis
qed

lemma word_suicide_r:
  assumes "\<not> l_ewp X" "Y \<noteq> {}"
  shows "(\<forall>w\<in>Y. \<exists>n. w\<notin>Y \<cdot> X\<^bsup>Suc n\<^esup>)"
proof -
  have  "\<forall>v\<in>Y. 0\<le>length v"
    by (metis le0)
  from assms have "\<forall>v\<in>X. 1\<le>length v"
    by (simp add: l_ewp_def, metis le_0_eq length_0_conv not_less_eq_eq)
  hence "\<forall>w\<in>Y. \<exists>n. w\<notin>Y \<cdot> X\<^bsup>Suc n \<^esup>"
    by (metis nat_mult_1_right power_lb suicide_aux_r le0 Suc_n_not_le_n)
  thus ?thesis by metis
qed

lemma word_suicide_lang_l: "\<lbrakk> \<not> l_ewp X; Y \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> n. \<not> (Y \<le> X\<^bsup>Suc n \<^esup>\<cdot> Y)"
  by (metis Set.set_eqI empty_iff in_mono word_suicide_l)

lemma word_suicide_lang_r: "\<lbrakk> \<not> l_ewp X; Y \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> n. \<not> (Y \<le> Y \<cdot> X\<^bsup>Suc n\<^esup>)"
  by (metis Set.set_eqI empty_iff in_mono word_suicide_r)

text \<open>These duality results cannot be relocated easily\<close>

context K1_algebra
begin

lemma power_dual_transfer [simp]:
  "power.power (1::'a) (\<odot>) x n = x\<^bsup>n\<^esup>"
  by (induct n, simp_all, metis opp_mult_def power_commutes)

end

lemma arden_r:
  assumes "\<not> l_ewp y" "x = x \<cdot> y + z"
  shows "x = z \<cdot> y\<^sup>\<star>"
proof (rule antisym)
  show one: "z \<cdot> y\<^sup>\<star> \<le> x"
    by (metis assms(2) join.sup_commute kleene_algebra_class.star_inductr_var order_refl)
  show "x \<le> z \<cdot> y\<^sup>\<star>"
  proof (cases "x = 0")
    show "x = 0 \<Longrightarrow> x \<le> z \<cdot> y\<^sup>\<star>"
      by simp
    assume assms': "x \<noteq> 0"
    have "\<And> n. x \<le> x \<cdot> y\<^bsup>Suc n\<^esup> + z \<cdot> y\<^sup>\<star>"
      by (metis assms(2) kleene_algebra_class.aarden_aux subsetI)
    moreover then have "\<And> w n. w \<in> x \<Longrightarrow> w \<in> x \<cdot> y\<^bsup>Suc n\<^esup> \<or> w \<in> z \<cdot> y\<^sup>\<star>"
      by (force simp: plus_set_def)
    ultimately show "x \<le> z \<cdot> y\<^sup>\<star>"
      by (metis (full_types) all_not_in_conv assms(1) subsetI word_suicide_r)
  qed
qed

text \<open>The following two facts provide counterexamples to Arden's rule if the empty word property is not considered.\<close>

lemma arden_l_counter: "\<exists> (x::'a lan) (y::'a lan) (z::'a lan). x = y \<cdot> x + z \<and> x \<noteq> y\<^sup>\<star> \<cdot> z"
proof -
  have one: "(0::'a lan) + 1 \<cdot> 1 = 1"
    by (metis ab_near_semiring_one_class.mult_onel kleene_algebra_class.dual.add_zerol)
  have two: "(1::'a lan) \<noteq> 1\<^sup>\<star> \<cdot> 0"
  proof -
    have "\<exists>x\<^sub>1. (0::'a list set) \<noteq> x\<^sub>1"
      by auto
    hence "(1::'a list set) \<noteq> 0"
      by (metis kleene_algebra_class.dual.annir kleene_algebra_class.dual.mult.right_neutral)
    thus "(1::'a list set) \<noteq> 1\<^sup>\<star> \<cdot> 0"
      by simp
  qed
  show ?thesis using one and two
    by (metis kleene_algebra_class.dual.add_zerol kleene_algebra_class.dual.add_zeror)
qed

lemma arden_r_counter: "\<exists> (x::'a lan) (y::'a lan) (z::'a lan). x = x \<cdot> y + z \<and> x \<noteq> z \<cdot> y\<^sup>\<star>"
proof -
  have one: "(0::'a lan) + 1 \<cdot> 1 = 1"
    by (metis ab_near_semiring_one_class.mult_onel kleene_algebra_class.dual.add_zerol)
  have two: "(1::'a lan) \<noteq> 0 \<cdot> 1\<^sup>\<star>"
  proof -
    have "\<exists>x\<^sub>1. (0::'a list set) \<noteq> x\<^sub>1"
      by auto
    hence "(1::'a list set) \<noteq> 0"
      by (metis kleene_algebra_class.dual.annir kleene_algebra_class.dual.mult.right_neutral)
    thus "(1::'a list set) \<noteq> 0 \<cdot> 1\<^sup>\<star>"
      by simp
  qed
  show ?thesis using one and two
    by (metis kleene_algebra_class.dual.add_zerol kleene_algebra_class.dual.add_zeror)
qed

interpretation lan_salomaa_l: Sl_algebra "(+)" "(\<cdot>)" "1 :: 'a lan" 0 "(\<subseteq>)" "(\<subset>)" "star" "l_ewp"
proof
  fix x y z :: "'a lan"
  show "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis kleene_algebra_class.dual.star2)
  show "l_ewp x = (\<exists>y. x = 1 + y \<and> \<not> l_ewp y)"
    by (simp add:l_ewp_def one_set_def one_list_def plus_set_def, metis insertCI mk_disjoint_insert)
  show "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis kleene_algebra_class.star_unfoldl_eq)
  show "\<not> l_ewp y \<Longrightarrow> x = y \<cdot> x + z \<Longrightarrow> x = y\<^sup>\<star> \<cdot> z"
    by (metis arden_l)
qed

interpretation lan_salomaa_r: Sr_algebra "(+)" "(\<cdot>)" "1 :: 'a lan" 0 "(\<subseteq>)" "(\<subset>)" "star" "l_ewp"
proof
  fix x y z :: "'a lan"
  show "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
    by (metis kleene_algebra_class.star_unfoldr_eq)
  show "\<not> l_ewp y \<Longrightarrow> x = x \<cdot> y + z \<Longrightarrow> x = z \<cdot> y\<^sup>\<star>"
    by (metis arden_r)
qed

subsection \<open>Regular Language Model of Salomaa Algebra\<close>

notation
  Atom ("\<langle>_\<rangle>") and
  Plus (infixl "+\<^sub>r" 65) and
  Times (infixl "\<cdot>\<^sub>r" 70) and
  Star ("_\<^sup>\<star>\<^sub>r" [101] 100) and
  Zero ("0\<^sub>r") and
  One ("1\<^sub>r")

fun rexp_ewp :: "'a rexp \<Rightarrow> bool" where
  "rexp_ewp 0\<^sub>r = False" |
  "rexp_ewp 1\<^sub>r = True" |
  "rexp_ewp \<langle>a\<rangle> = False" |
  "rexp_ewp (s +\<^sub>r t) = (rexp_ewp s \<or> rexp_ewp t)" |
  "rexp_ewp (s \<cdot>\<^sub>r t) = (rexp_ewp s \<and> rexp_ewp t)" |
  "rexp_ewp (s\<^sup>\<star>\<^sub>r) = True"

abbreviation "ro(s) \<equiv> (if (rexp_ewp s) then 1\<^sub>r else 0\<^sub>r)"

lift_definition r_ewp :: "'a reg_lan \<Rightarrow> bool" is "l_ewp" .

lift_definition r_lang :: "'a rexp \<Rightarrow> 'a reg_lan"  is "lang"
  by (simp)

abbreviation r_sim :: "'a rexp \<Rightarrow> 'a rexp \<Rightarrow> bool" (infix "\<sim>" 50) where
  "p \<sim> q \<equiv> r_lang p = r_lang q"

declare Rep_reg_lan [simp]
declare Rep_reg_lan_inverse [simp]
declare Abs_reg_lan_inverse [simp]

lemma rexp_ewp_l_ewp: "l_ewp (lang x) = rexp_ewp x"
proof (induct x)
  case (Star x) thus ?case
    by (simp, metis lan_salomaa_l.EWP left_near_kleene_algebra_class.star_plus_one)
qed (simp_all add:l_ewp_def zero_set_def one_set_def one_list_def plus_set_def c_prod_def times_list_def)

theorem regexp_ewp:
  defines P_def: "P(t) \<equiv> \<exists> t'. t \<sim> ro(t) +\<^sub>r t' \<and> ro(t') = 0\<^sub>r"
  shows "P t"
proof (induct t)
  show "P(0\<^sub>r)"
    by (simp add:P_def r_lang_def, rule_tac x="0\<^sub>r" in exI, simp)
next
  fix a
  show "P(\<langle>a\<rangle>)"
    by (simp add:P_def r_lang_def, rule_tac x="\<langle>a\<rangle>" in exI, simp)
next
  show "P(1\<^sub>r)"
    by (simp add:P_def r_lang_def, rule_tac x="0\<^sub>r" in exI, simp)
next
  fix t1 t2
  assume "P(t1)" "P(t2)"
  then obtain t1' t2'
    where "t1 \<sim> ro(t1) +\<^sub>r t1'" "ro(t1') = 0\<^sub>r"
          "t2 \<sim> ro(t2) +\<^sub>r t2'" "ro(t2') = 0\<^sub>r"
    by (metis assms rexp.distinct(1))
  thus "P(t1 +\<^sub>r t2)"
    apply (subst P_def, transfer)
    apply (rule_tac x="t1' +\<^sub>r t2'" in exI)
    apply clarsimp
    by (metis (no_types, lifting) add.left_commute join.sup_assoc join.sup_left_idem rexp.distinct(2))
 next
  fix t1 t2
  assume "P(t1)" "P(t2)"
  then obtain t1' t2'
    where t1: "t1 \<sim> ro(t1) +\<^sub>r t1'" "ro(t1') = 0\<^sub>r" and
          t2: "t2 \<sim> ro(t2) +\<^sub>r t2'" "ro(t2') = 0\<^sub>r"
      by (metis assms rexp.distinct(1))
  thus "P(t1 \<cdot>\<^sub>r t2)"
  proof -
    let ?t' = "ro(t1) \<cdot>\<^sub>r t2' +\<^sub>r t1' \<cdot>\<^sub>r ro(t2) +\<^sub>r t1' \<cdot>\<^sub>r t2'"
    from t1 t2 have r1: "ro(?t') = 0\<^sub>r"
      by (auto)
    from t1 t2 have "t1 \<cdot>\<^sub>r t2 \<sim> (ro(t1) +\<^sub>r t1') \<cdot>\<^sub>r (ro(t2) +\<^sub>r t2')" (is "?l \<sim> ?r")
      by (transfer, simp)
    also have "?r \<sim> ro(t1) \<cdot>\<^sub>r ro(t2) +\<^sub>r ro(t1) \<cdot>\<^sub>r t2' +\<^sub>r t1' \<cdot>\<^sub>r ro(t2) +\<^sub>r t1' \<cdot>\<^sub>r t2'" (is "?l \<sim> ?r")
      apply (transfer, unfold lang.simps)
      apply (simp only: distrib_right' semiring_class.distrib_left)
      apply (metis (hide_lams, no_types) join_semilattice_class.add_comm semiring_class.combine_common_factor)
    done
    also have "?r \<sim> ro(t1 \<cdot>\<^sub>r t2) +\<^sub>r ro(t1) \<cdot>\<^sub>r t2' +\<^sub>r t1' \<cdot>\<^sub>r ro(t2) +\<^sub>r t1' \<cdot>\<^sub>r t2'" (is "?l \<sim> ?r")
      by (transfer, simp)
    also have "?r \<sim> ro(t1 \<cdot>\<^sub>r t2) +\<^sub>r ?t'"
      apply (transfer, unfold lang.simps)
      apply (metis (mono_tags) join_semilattice_class.add_assoc')
    done
    finally show ?thesis using r1
      apply (unfold P_def)
      apply (rule_tac x="?t'" in exI, simp)
    done
  qed
next
  fix s
  assume assm:"P s"
  then obtain s' where r1: "s \<sim> ro(s) +\<^sub>r s'" "ro(s') = 0\<^sub>r"
    by (metis assms rexp.distinct(1))
  thus "P (s\<^sup>\<star>\<^sub>r)"
  proof -
    let ?t' = "s' \<cdot>\<^sub>r (s')\<^sup>\<star>\<^sub>r"
    have r2: "ro(?t') = 0\<^sub>r"
      by (metis r1(2) rexp.distinct(1) rexp_ewp.simps(5))
    from assm r1 have "(ro(s) +\<^sub>r s')\<^sup>\<star>\<^sub>r \<sim> (s')\<^sup>\<star>\<^sub>r" (is "?l \<sim> ?r")
      by (transfer, auto)
    also have "?r \<sim> 1\<^sub>r +\<^sub>r s' \<cdot>\<^sub>r (s')\<^sup>\<star>\<^sub>r" (is "?l \<sim> ?r")
      by (transfer, auto)
    also have "?r \<sim> ro(s\<^sup>\<star>\<^sub>r) +\<^sub>r ?t'"
      by (metis (full_types) rexp_ewp.simps(6))
    finally show ?thesis
      by (metis assms lang.simps(6) r1(1) r2 r_lang.abs_eq r_lang.rep_eq)
  qed
qed

instantiation reg_lan :: (type) Sr_algebra
begin

lift_definition ewp_reg_lan :: "'a reg_lan \<Rightarrow> bool" is "l_ewp" .

instance proof
  fix x :: "'a reg_lan"
  show "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis kleene_algebra_class.dual.star2)
next
  fix x :: "'a reg_lan"
  show "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
    by (metis kleene_algebra_class.star_unfoldr_eq)
next
  fix x :: "'a reg_lan"
  show "ewp x = (\<exists>y. x = 1 + y \<and> \<not> ewp y)"
  proof -
    obtain t where "r_lang t = x"
      by (transfer, auto)
    moreover obtain t' where "t \<sim> ro(t) +\<^sub>r t'" "ro(t') = 0\<^sub>r"
      by (metis regexp_ewp)
    ultimately show ?thesis
      apply (transfer, auto)
      apply (metis (full_types) lang.simps(2) rexp.distinct(1) rexp_ewp_l_ewp)
      apply (metis lan_salomaa_l.EWP)
    done
  qed
next
  fix x y z :: "'a reg_lan"
  show "\<lbrakk> \<not> ewp y; x = x \<cdot> y + z \<rbrakk> \<Longrightarrow> x = z \<cdot> y\<^sup>\<star>"
    by (transfer, metis lan_salomaa_r.Ar)
qed
end

instantiation reg_lan :: (type) Sl_algebra
begin

instance proof
  fix x :: "'a reg_lan"
  show "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis left_pre_kleene_algebra_class.star_unfoldl_eq)
next
  fix x y z :: "'a reg_lan"
  show "\<lbrakk> \<not> ewp y; x = y \<cdot> x + z \<rbrakk> \<Longrightarrow> x = y\<^sup>\<star> \<cdot> z"
    by (transfer, metis lan_salomaa_l.Al)
qed
end

instance reg_lan :: (type) S_algebra ..

theorem arden_regexp_l:
  assumes "ro(y) = 0\<^sub>r" "x \<sim> y \<cdot>\<^sub>r x +\<^sub>r z"
  shows "x \<sim> y\<^sup>\<star>\<^sub>r \<cdot>\<^sub>r z"
  using assms
  by (transfer, metis arden_l lang.simps(4) lang.simps(5) lang.simps(6) rexp.distinct(1) rexp_ewp_l_ewp)

theorem arden_regexp_r:
  assumes "ro(y) = 0\<^sub>r" "x \<sim> x \<cdot>\<^sub>r y +\<^sub>r z"
  shows "x \<sim> z \<cdot>\<^sub>r y\<^sup>\<star>\<^sub>r"
  using assms
  by transfer (metis lan_salomaa_r.Ar lang.simps(4) lang.simps(5) lang.simps(6) rexp.distinct(1) rexp_ewp_l_ewp)

end


(* Author: Dmitriy Traytel *)

header {* $\Pi$-Extended Regular Expressions *}

(*<*)
theory Pi_Regular_Exp
imports Pi_Regular_Set "~~/src/HOL/Library/List_lexord" "~~/src/HOL/Library/Code_Target_Nat"
  "../Datatype_Order_Generator/Order_Generator"
begin
(*>*)
subsection {* Syntax of regular expressions *}

datatype 'a rexp =
  Zero |
  Full |
  One |
  Atom 'a |
  Plus "('a rexp)" "('a rexp)" |
  Times "('a rexp)" "('a rexp)" |
  Star "('a rexp)" |
  Not "('a rexp)" |
  Inter "('a rexp)" "('a rexp)" |
  Pr "('a rexp)"
derive linorder rexp

text {* Lifting constructors to lists *}

fun rexp_of_list where
  "rexp_of_list OPERATION N [] = N"
| "rexp_of_list OPERATION N [x] = x"
| "rexp_of_list OPERATION N (x # xs) = OPERATION x (rexp_of_list OPERATION N xs)"

abbreviation "PLUS \<equiv> rexp_of_list Plus Zero"
abbreviation "TIMES \<equiv> rexp_of_list Times One"
abbreviation "INTERSECT \<equiv> rexp_of_list Inter Full"

lemma list_singleton_induct [case_names nil single cons]:
  assumes nil: "P []"
  assumes single: "\<And>x. P [x]"
  assumes cons: "\<And>x y xs. P (y # xs) \<Longrightarrow> P (x # (y # xs))"
  shows "P xs"
  using assms
proof (induct xs)
  case (Cons x xs) thus ?case by (cases xs) auto
qed simp

subsection {* ACI normalization *}

fun toplevel_summands :: "'a rexp \<Rightarrow> 'a rexp set" where
  "toplevel_summands (Plus r s) = toplevel_summands r \<union> toplevel_summands s"
| "toplevel_summands r = {r}"

abbreviation (input) "flatten LISTOP X \<equiv> LISTOP (sorted_list_of_set X)"

lemma toplevel_summands_nonempty[simp]:
  "toplevel_summands r \<noteq> {}"
  by (induct r) auto

lemma toplevel_summands_finite[simp]:
  "finite (toplevel_summands r)"
  by (induct r) auto

primrec ACI_norm :: "('a::linorder) rexp \<Rightarrow> 'a rexp"  ("\<guillemotleft>_\<guillemotright>") where
  "\<guillemotleft>Zero\<guillemotright> = Zero"
| "\<guillemotleft>Full\<guillemotright> = Full"
| "\<guillemotleft>One\<guillemotright> = One"
| "\<guillemotleft>Atom a\<guillemotright> = Atom a"
| "\<guillemotleft>Plus r s\<guillemotright> = flatten PLUS (toplevel_summands (Plus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>))"
| "\<guillemotleft>Times r s\<guillemotright> = Times \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
| "\<guillemotleft>Star r\<guillemotright> = Star \<guillemotleft>r\<guillemotright>"
| "\<guillemotleft>Not r\<guillemotright> = Not \<guillemotleft>r\<guillemotright>"
| "\<guillemotleft>Inter r s\<guillemotright> = Inter \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
| "\<guillemotleft>Pr r\<guillemotright> = Pr \<guillemotleft>r\<guillemotright>"

lemma Plus_toplevel_summands:
  "Plus r s \<in> toplevel_summands t \<Longrightarrow> False"
  by (induct t) auto

lemma toplevel_summands_not_Plus[simp]:
  "(\<forall>r s. x \<noteq> Plus r s) \<Longrightarrow> toplevel_summands x = {x}"
  by (induct x) auto

lemma toplevel_summands_PLUS_strong:
  "\<lbrakk>xs \<noteq> []; list_all (\<lambda>x. \<not>(\<exists>r s. x = Plus r s)) xs\<rbrakk> \<Longrightarrow> toplevel_summands (PLUS xs) = set xs"
  by (induct xs rule: list_singleton_induct) auto

lemma toplevel_summands_flatten:
  "\<lbrakk>X \<noteq> {}; finite X; \<forall>x \<in> X. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow> toplevel_summands (flatten PLUS X) = X"
  using toplevel_summands_PLUS_strong[of "sorted_list_of_set X"] sorted_list_of_set[of X]
  unfolding list_all_iff by fastforce

lemma ACI_norm_Plus:
  "\<guillemotleft>r\<guillemotright> = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
  by (induct r) auto

lemma toplevel_summands_flatten_ACI_norm_image:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r)) = ACI_norm ` toplevel_summands r"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus intro: Plus_toplevel_summands)

lemma toplevel_summands_flatten_ACI_norm_image_Union:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s)) =
    ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus[OF sym] intro: Plus_toplevel_summands)

lemma toplevel_summands_ACI_norm:
  "toplevel_summands \<guillemotleft>r\<guillemotright> = ACI_norm ` toplevel_summands r"
  by (induct r) (auto simp: toplevel_summands_flatten_ACI_norm_image_Union)

lemma ACI_norm_flatten:
  "\<guillemotleft>r\<guillemotright> = flatten PLUS (ACI_norm ` toplevel_summands r)"
  by (induct r) (auto simp: image_Un toplevel_summands_flatten_ACI_norm_image)

theorem ACI_norm_idem[simp]:
  "\<guillemotleft>\<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induct r)
  case (Plus r s)
  have "\<guillemotleft>\<guillemotleft>Plus r s\<guillemotright>\<guillemotright> = \<guillemotleft>flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)\<guillemotright>"
    (is "_ = \<guillemotleft>flatten PLUS ?U\<guillemotright>") by simp
  also have "\<dots> = flatten PLUS (ACI_norm ` toplevel_summands (flatten PLUS ?U))"
    unfolding ACI_norm_flatten ..
  also have "toplevel_summands (flatten PLUS ?U) = ?U"
    by (intro toplevel_summands_flatten) (auto intro: Plus_toplevel_summands)
  also have "flatten PLUS (ACI_norm ` ?U) = flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)"
    unfolding image_Un toplevel_summands_ACI_norm[symmetric] Plus ..
  finally show ?case by simp
qed auto

fun ACI_nPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "ACI_nPlus (Plus r1 r2) s = ACI_nPlus r1 (ACI_nPlus r2 s)"
| "ACI_nPlus r (Plus s1 s2) =
  (if r = s1 then Plus s1 s2
  else if r < s1 then Plus r (Plus s1 s2)
  else Plus s1 (ACI_nPlus r s2))"
| "ACI_nPlus r s =
  (if r = s then r
  else if r < s then Plus r s
  else Plus s r)"

fun ACI_norm_alt where
  "ACI_norm_alt Zero = Zero"
| "ACI_norm_alt Full = Full"
| "ACI_norm_alt One = One"
| "ACI_norm_alt (Atom a) = Atom a"
| "ACI_norm_alt (Plus r s) = ACI_nPlus (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Times r s) = Times (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Star r) = Star (ACI_norm_alt r)"
| "ACI_norm_alt (Not r) = Not (ACI_norm_alt r)"
| "ACI_norm_alt (Inter r s) = Inter (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Pr r) = Pr (ACI_norm_alt r)"

lemma toplevel_summands_ACI_nPlus:
  "toplevel_summands (ACI_nPlus r s) = toplevel_summands (Plus r s)"
  by (induct r s rule: ACI_nPlus.induct) auto

lemma toplevel_summands_ACI_norm_alt:
  "toplevel_summands (ACI_norm_alt r) = ACI_norm_alt ` toplevel_summands r"
  by (induct r) (auto simp: toplevel_summands_ACI_nPlus)

lemma ACI_norm_alt_Plus:
  "ACI_norm_alt r = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
  by (induct r) auto

lemma toplevel_summands_flatten_ACI_norm_alt_image:
  "toplevel_summands (flatten PLUS (ACI_norm_alt ` toplevel_summands r)) = ACI_norm_alt ` toplevel_summands r"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_alt_Plus intro: Plus_toplevel_summands)

lemma ACI_norm_ACI_norm_alt: "\<guillemotleft>ACI_norm_alt r\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induction r)
  case (Plus r s) show ?case
    by (auto simp: ACI_norm_flatten image_Un toplevel_summands_ACI_nPlus)
       (metis Plus.IH toplevel_summands_ACI_norm)
qed auto

lemma ACI_nPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow>
  ACI_nPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case
    by (cases x y rule: linorder_cases) (induct x y rule: ACI_nPlus.induct, auto)+
next
  case (cons y1 y2 ys) thus ?case by (cases x) (auto simp: sorted_Cons)
qed simp

lemma ACI_nPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>(\<exists>r s. x = Plus r s); sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  ACI_nPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1) thus ?case
    apply (auto intro!: trans[OF ACI_nPlus_singleton_PLUS] simp: insert_absorb simp del: sorted_list_of_set_insert)
      apply fastforce
     apply (metis finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1) thus ?case
    apply (simp del: sorted_list_of_set_insert)
    apply (rule trans[OF ACI_nPlus_singleton_PLUS])
         apply (auto simp del: sorted_list_of_set_insert simp add: insert_commute[of x11])
       apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
      apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
     apply (auto simp add: insert_commute[of x12])
  done
qed simp

lemma ACI_nPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2. \<not>(\<exists>r s. x = Plus r s)\<rbrakk>\<Longrightarrow>
  ACI_nPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF ACI_nPlus_PLUS]) auto

lemma ACI_nPlus_ACI_norm[simp]: "ACI_nPlus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright> = \<guillemotleft>Plus r s\<guillemotright>"
  by (auto simp: image_Un Un_assoc ACI_norm_flatten intro!: trans[OF ACI_nPlus_flatten_PLUS])
   (metis ACI_norm_Plus Plus_toplevel_summands ACI_norm_flatten)+

lemma ACI_norm_alt:
  "ACI_norm_alt r = \<guillemotleft>r\<guillemotright>"
  by (induct r) auto

declare ACI_norm_alt[symmetric, code]

subsection {* Finality *}

primrec final :: "'a rexp \<Rightarrow> bool"
where
  "final Zero = False"
| "final Full = True"
| "final One = True"
| "final (Atom _) = False"
| "final (Plus r s) = (final r \<or> final s)"
| "final (Times r s) = (final r \<and> final s)"
| "final (Star _) = True"
| "final (Not r) = (~ final r)"
| "final (Inter r1 r2) = (final r1 \<and> final r2)"
| "final (Pr r) = final r"

lemma toplevel_summands_final:
  "final s = (\<exists>r\<in>toplevel_summands s. final r)"
  by (induct s) auto

lemma final_PLUS:
  "final (PLUS xs) = (\<exists>r \<in> set xs. final r)"
  by (induct xs rule: list_singleton_induct) auto

theorem ACI_norm_final[simp]:
  "final \<guillemotleft>r\<guillemotright> = final r"
proof (induct r)
  case (Plus r1 r2) thus ?case using toplevel_summands_final by (auto simp: final_PLUS)
qed auto

subsection {* Wellformedness w.r.t. an alphabet *}

locale alphabet =
fixes \<Sigma> :: "nat \<Rightarrow> 'a set" ("\<Sigma> _")
and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
begin

primrec wf :: "nat \<Rightarrow> 'b rexp \<Rightarrow> bool"
where
"wf n Zero = True" |
"wf n Full = True" |
"wf n One = True" |
"wf n (Atom a) = (wf_atom n a)" |
"wf n (Plus r s) = (wf n r \<and> wf n s)" |
"wf n (Times r s) = (wf n r \<and> wf n s)" |
"wf n (Star r) = wf n r" |
"wf n (Not r) = wf n r" |
"wf n (Inter r s) = (wf n r \<and> wf n s)" |
"wf n (Pr r) = wf (n + 1) r"

primrec wf_word where
  "wf_word n [] = True"
| "wf_word n (w # ws) = ((w \<in> \<Sigma> n) \<and> wf_word n ws)"

lemma wf_word_snoc[simp]: "wf_word n (ws @ [w]) = ((w \<in> \<Sigma> n) \<and> wf_word n ws)"
  by (induct ws) auto

lemma wf_word_append[simp]: "wf_word n (ws @ vs) = (wf_word n ws \<and> wf_word n vs)"
  by (induct ws arbitrary: vs) auto

lemma wf_word: "wf_word n w = (w \<in> lists (\<Sigma> n))"
  by (induct w) auto

lemma wf_PLUS[simp]:
  "wf n (PLUS xs) = (\<forall>r \<in> set xs. wf n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma wf_TIMES[simp]:
  "wf n (TIMES xs) = (\<forall>r \<in> set xs. wf n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma wf_flatten_PLUS[simp]:
  "finite X \<Longrightarrow> wf n (flatten PLUS X) = (\<forall>r \<in> X. wf n r)"
  using wf_PLUS[of n "sorted_list_of_set X"] sorted_list_of_set[of X] by fastforce

theorem ACI_norm_wf[simp]:
  "wf n \<guillemotleft>r\<guillemotright> = wf n r"
proof (induct r arbitrary: n)
  case (Plus r1 r2) thus ?case
   using toplevel_summands_wf[of n "\<guillemotleft>r1\<guillemotright>"] toplevel_summands_wf[of n "\<guillemotleft>r2\<guillemotright>"] by auto
qed auto

lemma wf_INTERSECT[simp]:
  "wf n (INTERSECT xs) = (\<forall>r \<in> set xs. wf n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma wf_flatten_INTERSECT[simp]:
  "finite X \<Longrightarrow> wf n (flatten INTERSECT X) = (\<forall>r \<in> X. wf n r)"
  using wf_INTERSECT[of n "sorted_list_of_set X"] sorted_list_of_set[of X] by fastforce

end

subsection {* Language *}

locale project =
  alphabet \<Sigma> wf_atom for \<Sigma> :: "nat \<Rightarrow> 'a set" and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool" +
fixes project :: "'a \<Rightarrow> 'a"
and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
assumes project: "\<And>a. a \<in> \<Sigma> (Suc n) \<Longrightarrow> project a \<in> \<Sigma> n"
begin

primrec lang :: "nat \<Rightarrow> 'b rexp => 'a lang" where
"lang n Zero = {}" |
"lang n Full = lists (\<Sigma> n)" |
"lang n One = {[]}" |
"lang n (Atom b) = {[x] | x. lookup b x \<and> x \<in> \<Sigma> n}" |
"lang n (Plus r s) = (lang n r) \<union> (lang n s)" |
"lang n (Times r s) = conc (lang n r) (lang n s)" |
"lang n (Star r) = star (lang n r)" |
"lang n (Not r) = lists (\<Sigma> n) - lang n r" |
"lang n (Inter r s) = (lang n r \<inter> lang n s)" |
"lang n (Pr r) = map project ` lang (n + 1) r"

lemma wf_word_map_project[simp]: "wf_word (Suc n) ws \<Longrightarrow> wf_word n (map project ws)"
  by (induct ws arbitrary: n) (auto intro: project)

lemma lang_subset_lists: "wf n r \<Longrightarrow> lang n r \<subseteq> lists (\<Sigma> n)"
proof (induct r arbitrary: n)
  case Pr thus ?case by (fastforce intro!: project)
qed (auto simp: conc_subset_lists star_subset_lists)

lemma toplevel_summands_lang:
  "r \<in> toplevel_summands s \<Longrightarrow> lang n r \<subseteq> lang n s"
  by (induct s) auto

lemma toplevel_summands_lang_UN:
  "lang n s = (\<Union>r\<in>toplevel_summands s. lang n r)"
  by (induct s) auto

lemma toplevel_summands_in_lang:
  "w \<in> lang n s = (\<exists>r\<in>toplevel_summands s. w \<in> lang n r)"
  by (induct s) auto

lemma lang_PLUS[simp]:
  "lang n (PLUS xs) = (\<Union>r \<in> set xs. lang n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_TIMES[simp]:
  "lang n (TIMES xs) = foldr op @@ (map (lang n) xs) {[]}"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_flatten_PLUS:
  "finite X \<Longrightarrow> lang n (flatten PLUS X) = (\<Union>r \<in> X. lang n r)"
  using lang_PLUS[of n "sorted_list_of_set X"] sorted_list_of_set[of X] by fastforce

theorem ACI_norm_lang[simp]:
  "lang n \<guillemotleft>r\<guillemotright> = lang n r"
proof (induct r arbitrary: n)
  case (Plus r1 r2)
  moreover
  from Plus[symmetric] have "lang n (Plus r1 r2) \<subseteq> lang n \<guillemotleft>Plus r1 r2\<guillemotright>"
    using toplevel_summands_in_lang[of _ n "\<guillemotleft>r1\<guillemotright>"] toplevel_summands_in_lang[of _ n "\<guillemotleft>r2\<guillemotright>"]
    by auto
  ultimately show ?case by (fastforce dest!: toplevel_summands_lang)
qed auto

lemma lang_final: "final r = ([] \<in> lang n r)"
  using concI[of "[]" _ "[]"] by (induct r arbitrary: n) auto

lemma in_lang_INTERSECT:
  "wf_word n w \<Longrightarrow> w \<in> lang n (INTERSECT xs) = (\<forall>r \<in> set xs. w \<in> lang n r)"
  by (induct xs rule: list_singleton_induct) (auto simp: wf_word)

lemma lang_INTERSECT:
  "lang n (INTERSECT xs) = (if xs = [] then lists (\<Sigma> n) else \<Inter>r \<in> set xs. lang n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_flatten_INTERSECT[simp]:
  assumes "finite X" "X \<noteq> {}" "\<forall>r\<in>X. wf n r"
  shows "w \<in> lang n (flatten INTERSECT X) = (\<forall>r \<in> X. w \<in> lang n r)" (is "?L = ?R")
proof
  assume ?L
  thus ?R using in_lang_INTERSECT[OF bspec[OF wf_lang_wf_word[OF iffD2[OF wf_flatten_INTERSECT]]],
    OF assms(1,3) `?L`, of "sorted_list_of_set X"] assms(1)
    by auto
next
  assume ?R
  with assms show ?L by (intro iffD2[OF in_lang_INTERSECT]) (auto dest: wf_lang_wf_word)
qed

end

(*<*)
end
(*>*)


(*  Title:      HOL/Nunchaku_Examples/Record_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2015

Examples featuring Nunchaku applied to records.
*)

section {* Examples Featuring Nunchaku Applied to Records *}

theory Record_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, max_potential = 0, timeout = 240]

record point2d =
  xc :: nat
  yc :: nat

lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x, yc := y\<rparr>"
nunchaku [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x\<rparr>"
nunchaku [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y\<rparr> \<noteq> p"
nunchaku [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y\<rparr> = p"
nunchaku [expect = genuine]
oops

record point3d = point2d +
  zc :: nat

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x, yc := y, zc := z\<rparr>"
nunchaku [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x\<rparr>"
nunchaku [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>zc := z\<rparr>"
nunchaku [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> \<noteq> p"
nunchaku [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> = p"
nunchaku [expect = genuine]
oops

record point4d = point3d +
  wc :: nat

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr>"
nunchaku [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x\<rparr>"
nunchaku [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>zc := z\<rparr>"
nunchaku [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>wc := w\<rparr>"
nunchaku [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> \<noteq> p"
nunchaku [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> = p"
nunchaku [expect = genuine]
oops

end


(*  Title:      HOL/Proofs/Extraction/Greatest_Common_Divisor.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Helmut Schwichtenberg, LMU Muenchen
*)

section \<open>Greatest common divisor\<close>

theory Greatest_Common_Divisor
imports QuotRem
begin

theorem greatest_common_divisor:
  "\<And>n::nat. Suc m < n \<Longrightarrow>
    \<exists>k n1 m1. k * n1 = n \<and> k * m1 = Suc m \<and>
    (\<forall>l l1 l2. l * l1 = n \<longrightarrow> l * l2 = Suc m \<longrightarrow> l \<le> k)"
proof (induct m rule: nat_wf_ind)
  case (1 m n)
  from division obtain r q where h1: "n = Suc m * q + r" and h2: "r \<le> m"
    by iprover
  show ?case
  proof (cases r)
    case 0
    with h1 have "Suc m * q = n" by simp
    moreover have "Suc m * 1 = Suc m" by simp
    moreover have "l * l1 = n \<Longrightarrow> l * l2 = Suc m \<Longrightarrow> l \<le> Suc m" for l l1 l2
      by (cases l2) simp_all
    ultimately show ?thesis by iprover
  next
    case (Suc nat)
    with h2 have h: "nat < m" by simp
    moreover from h have "Suc nat < Suc m" by simp
    ultimately have "\<exists>k m1 r1. k * m1 = Suc m \<and> k * r1 = Suc nat \<and>
        (\<forall>l l1 l2. l * l1 = Suc m \<longrightarrow> l * l2 = Suc nat \<longrightarrow> l \<le> k)"
      by (rule 1)
    then obtain k m1 r1 where h1': "k * m1 = Suc m"
      and h2': "k * r1 = Suc nat"
      and h3': "\<And>l l1 l2. l * l1 = Suc m \<Longrightarrow> l * l2 = Suc nat \<Longrightarrow> l \<le> k"
      by iprover
    have mn: "Suc m < n" by (rule 1)
    from h1 h1' h2' Suc have "k * (m1 * q + r1) = n"
      by (simp add: add_mult_distrib2 mult.assoc [symmetric])
    moreover have "l \<le> k" if ll1n: "l * l1 = n" and ll2m: "l * l2 = Suc m" for l l1 l2
    proof -
      have "l * (l1 - l2 * q) = Suc nat"
        by (simp add: diff_mult_distrib2 h1 Suc [symmetric] mn ll1n ll2m [symmetric])
      with ll2m show "l \<le> k" by (rule h3')
    qed
    ultimately show ?thesis using h1' by iprover
  qed
qed

extract greatest_common_divisor

text \<open>
  The extracted program for computing the greatest common divisor is
  @{thm [display] greatest_common_divisor_def}
\<close>

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation prod :: (default, default) default
begin

definition "default = (default, default)"

instance ..

end

instantiation "fun" :: (type, default) default
begin

definition "default = (\<lambda>x. default)"

instance ..

end

lemma "greatest_common_divisor 7 12 = (4, 3, 2)" by eval

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Tensor\<close>

theory Tensor
imports Complex_Main
begin

typedef 'a tensor = "{t::nat list \<times> 'a list. length (snd t) = prod_list (fst t)}"
  by (simp add: Ex_list_of_length)

definition dims::"'a tensor \<Rightarrow> nat list" where
  "dims A = fst (Rep_tensor A)"

definition vec::"'a tensor \<Rightarrow> 'a list" where
  "vec A = snd (Rep_tensor A)"

definition tensor_from_vec::"nat list \<Rightarrow> 'a list \<Rightarrow> 'a tensor" where
  "tensor_from_vec d v = Abs_tensor (d,v)"

(* If the fundamental requirement holds, then the constructed tensor is valid *)
lemma
assumes "length v = prod_list d"
shows dims_tensor[simp]: "dims (tensor_from_vec d v) = d"
and   vec_tensor[simp]:  "vec (tensor_from_vec d v) = v"
by (simp add: Abs_tensor_inverse assms dims_def tensor_from_vec_def vec_def)+

(* Needed for code gen *)
lemma tensor_from_vec_simp[simp,code]: "tensor_from_vec (dims A) (vec A) = A"
 by (simp add: Rep_tensor_inverse Tensor.vec_def dims_def tensor_from_vec_def)

(** Attempted code equation for Rep_tensor *)

(* I am not sure what lemma needs to be proven in order to generate a code equation for Rep_tensor*)

lemma vec_from_tensor_simp[simp]:
  "Rep_tensor (tensor_from_vec (fst A) (snd A)) = A" sorry

(* End *)

lemma length_vec: "length (vec A) = prod_list (dims A)"
by (metis (mono_tags, lifting) Rep_tensor Tensor.vec_def dims_def mem_Collect_eq)

lemma tensor_eqI[intro]:
assumes "dims A = dims B" and "vec A = vec B"
shows "A=B"
by (metis assms tensor_from_vec_simp)

(* 3D tensor \<Rightarrow> order 3 *)
abbreviation order::"'a tensor \<Rightarrow> nat" where
  "order t == length (dims t)"

(*  *)
inductive valid_index::"nat list \<Rightarrow> nat list \<Rightarrow> bool" (infix "\<lhd>" 50) where
  Nil: "[] \<lhd> []" |
  Cons: "is \<lhd> ds \<Longrightarrow> i<d \<Longrightarrow> i#is \<lhd> d#ds"

inductive_cases valid_indexE[elim]: "is \<lhd> ds"
inductive_cases valid_index_dimsE[elim]: "is \<lhd> dims A"

lemma valid_index_length: "is \<lhd> ds \<Longrightarrow> length is = length ds"
  by (induction rule:valid_index.induct; auto)

lemma valid_index_lt: "is \<lhd> ds \<Longrightarrow> m<length ds \<Longrightarrow> is!m < ds!m"
proof (induction arbitrary:m rule:valid_index.induct)
  case Nil
  then show ?case by auto
next
  case Cons
  then show ?case by (metis gr0_conv_Suc length_Cons linorder_neqE_nat not_less_eq nth_Cons' nth_Cons_Suc)
qed

lemma valid_indexI:
assumes "length is = length ds" and "\<And>m. m<length ds \<Longrightarrow> is!m < ds!m"
shows "is \<lhd> ds"
using assms proof (induction "is" arbitrary:ds)
  case Nil
  then show ?case by (metis length_0_conv valid_index.simps)
next
  case (Cons a "is" ds)
  then obtain d ds' where "ds = d # ds'" by (metis length_Suc_conv)
  then have "is \<lhd> ds'" using Cons by (metis length_Cons less_irrefl linorder_neqE_nat not_less_eq nth_Cons_Suc)
  then show ?case using Cons.prems(2) \<open>ds = d # ds'\<close> valid_index.Cons by fastforce
qed

lemma valid_index_append:
assumes is1_valid:"is1 \<lhd> ds1" and is2_valid:"is2 \<lhd> ds2"
shows "is1 @ is2 \<lhd> ds1 @ ds2"
  apply (rule valid_indexI[of "is1 @ is2" "ds1 @ ds2"])
  unfolding nth_append
  using valid_index_lt[OF is2_valid] valid_index_lt[OF is1_valid] valid_index_length[OF is1_valid] valid_index_length[OF is2_valid] length_append
  by (auto simp add: \<open>length is1 = length ds1\<close>)

lemma valid_index_list_all2_iff: "is \<lhd> ds \<longleftrightarrow> list_all2 (<) is ds"
by (metis list_all2_conv_all_nth list_all2_nthD valid_indexI valid_index_length valid_index_lt)

definition fixed_length_sublist::"'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
"fixed_length_sublist xs l i = (take l (drop (l*i) xs))"

fun lookup_base::"nat list \<Rightarrow> 'a list \<Rightarrow> nat list \<Rightarrow> 'a" where
  lookup_base_Nil: "lookup_base [] v [] = hd v" |
  lookup_base_Cons: "lookup_base (d # ds) v (i # is) =
    lookup_base ds (fixed_length_sublist v (prod_list ds) i) is"

definition lookup::"'a tensor \<Rightarrow> nat list \<Rightarrow> 'a" where
  "lookup A = lookup_base (dims A) (vec A)"

fun tensor_vec_from_lookup::"nat list \<Rightarrow> (nat list \<Rightarrow> 'a) \<Rightarrow> 'a list" where
  tensor_vec_from_lookup_Nil: "tensor_vec_from_lookup [] e = [e []]" |
  tensor_vec_from_lookup_Cons: "tensor_vec_from_lookup (d # ds) e = concat (map (\<lambda>i. tensor_vec_from_lookup ds (\<lambda>is. e (i # is))) [0..<d])"

definition tensor_from_lookup::"nat list \<Rightarrow> (nat list \<Rightarrow> 'a) \<Rightarrow> 'a tensor" where
  "tensor_from_lookup ds e = tensor_from_vec ds (tensor_vec_from_lookup ds e)"

lemma concat_parts_leq:
assumes "a * d \<le> length v"
shows "concat (map (fixed_length_sublist v d) [0..<a]) = take (a*d) v"
using assms proof (induction a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  then have "concat (map (fixed_length_sublist v d) [0..<a]) = take (a * d) v" by auto
  then have "concat (map (fixed_length_sublist v d) [0..<Suc a]) =
        take (a * d) v @ fixed_length_sublist v d a" using fixed_length_sublist_def by auto
  then show ?case using Suc by (metis add.commute mult.commute mult_Suc take_add fixed_length_sublist_def)
qed

lemma concat_parts_eq:
assumes "a * d = length v"
shows "concat (map (fixed_length_sublist v d) [0..<a]) = v"
by (simp add: concat_parts_leq assms)

lemma tensor_lookup_base:
assumes "length v = prod_list ds"
and "\<And>is. is \<lhd> ds \<Longrightarrow> lookup_base ds v is = e is"
shows "tensor_vec_from_lookup ds e = v"
using assms proof (induction ds arbitrary:v e)
  case Nil
  then show ?case unfolding tensor_vec_from_lookup.simps
    by (metis One_nat_def Tensor.lookup_base_Nil length_0_conv length_Suc_conv list.sel(1) prod_list.Nil valid_index.Nil)
next
  case (Cons a ds)
  then have "a * prod_list ds = length v" by auto
  {
    fix i assume "i<a"
    then have "prod_list ds * (i+1) \<le> length v" using \<open>a * prod_list ds = length v\<close> using discrete mult.commute mult_le_mono1 by metis
    have "\<And>is'. is' \<lhd> ds \<Longrightarrow> e (i # is') = lookup_base ds (fixed_length_sublist v (prod_list ds) i) is'"
      using \<open>i<a\<close> by (metis Cons.prems(2) Tensor.lookup_base_Cons valid_index.simps)
    then have "tensor_vec_from_lookup ds (\<lambda>is'. e (i # is')) = fixed_length_sublist v (prod_list ds) i"
      using Cons using \<open>prod_list ds * (i + 1) \<le> length v\<close> by (simp add: Cons.IH fixed_length_sublist_def)
  }
  then show ?case unfolding tensor_vec_from_lookup_Cons lookup_base_Cons
    using   concat_parts_eq[OF \<open>a * prod_list ds = length v\<close>]
     atLeastLessThan_iff map_eq_conv set_upt Cons by (metis (no_types, lifting))
qed

lemma tensor_lookup:
assumes "\<And>is. is \<lhd> dims A \<Longrightarrow> lookup A is = e is"
shows "tensor_from_lookup (dims A) e = A"
using tensor_lookup_base lookup_def length_vec tensor_from_lookup_def by (metis assms tensor_from_vec_simp)

lemma concat_equal_length:
assumes "\<And>xs. xs\<in>set xss \<Longrightarrow> length xs = l"
shows "length (concat xss) = length xss*l"
using assms by (induction xss;auto)

lemma concat_equal_length_map:
assumes "\<And>i. i<a \<Longrightarrow> length (f i) = d"
shows "length (concat (map (\<lambda>i. f i) [0..<a])) = a*d"
using assms by (induction a;auto)

lemma concat_parts:
assumes "\<And>xs. xs\<in>set xss \<Longrightarrow> length xs = d" and "i<length xss"
shows "fixed_length_sublist (concat xss) d i = xss ! i"
using assms proof (induction xss arbitrary:i)
  case Nil
  then show ?case by simp
next
  case (Cons xs xss)
  then have "length (concat xss) = length xss * d" by (simp add: Cons.prems(1) concat_equal_length)
  show ?case
  proof (cases i)
    case 0
    then have "fixed_length_sublist (concat (xs # xss)) d i = xs"
      unfolding fixed_length_sublist_def by (simp add: Cons.prems(1))
    then show ?thesis using 0 by auto
  next
    case (Suc i')
    then have "fixed_length_sublist (concat xss) d i' = xss ! i'" using Cons by auto
    then show ?thesis unfolding fixed_length_sublist_def using Suc Cons.prems(1) by auto
  qed
qed

lemma concat_parts':
assumes "\<And>i. i<a \<Longrightarrow> length (f i) = d"
and "i<a"
shows "fixed_length_sublist (concat (map (\<lambda>i. f i) [0..<a])) d i = f i"
using assms proof (induction a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  then have "(\<And>i. i < a \<Longrightarrow> length (f i) = d)" by auto
  then have "length (concat (map f [0..<a])) = a*d" using concat_equal_length_map by auto
  show ?case
  proof (cases "i=a")
    assume "i=a"
    then have "fixed_length_sublist (concat (map f [0..<Suc a])) d i = f a"
      by (simp add: Suc.prems(1) \<open>length (concat (map f [0..<a])) = a * d\<close> fixed_length_sublist_def)
    then show ?case using \<open>i=a\<close> by auto
  next
    assume "i\<noteq>a"
    then have "fixed_length_sublist (concat (map f [0..<a])) d i = f i"
      "concat (map f [0..<Suc a]) = concat (map f [0..<a]) @ f a" using Suc by auto
    show ?case unfolding \<open>concat (map f [0..<Suc a]) = concat (map f [0..<a]) @ f a\<close>
      unfolding fixed_length_sublist_def drop_append
      using  \<open>length (concat (map f [0..<a])) = a * d\<close>  \<open>fixed_length_sublist (concat (map f [0..<a])) d i = f i\<close>
      using append_assoc append_eq_conv_conj append_take_drop_id assms(1) assms(2)  fixed_length_sublist_def
      by metis
  qed
qed

lemma length_tensor_vec_from_lookup:
"length (tensor_vec_from_lookup ds e) = prod_list ds"
by (induction ds arbitrary:e; auto simp add: concat_equal_length_map)

lemma lookup_tensor_vec:
assumes "is\<lhd>ds"
shows "lookup_base ds (tensor_vec_from_lookup ds e) is = e is"
using assms proof (induction arbitrary:e rule:valid_index.induct)
  case Nil
  then show ?case by simp
next
  case (Cons "is" ds i d e)
  then show ?case unfolding tensor_vec_from_lookup_Cons lookup_base_Cons
    by (simp add: length_tensor_vec_from_lookup concat_parts'[of d "\<lambda>i. tensor_vec_from_lookup ds (\<lambda>is. e (i # is))" "prod_list ds" i] \<open>i < d\<close>)
qed

lemma lookup_tensor_from_lookup:
assumes "is\<lhd>ds"
shows "lookup (tensor_from_lookup ds e) is = e is"
  unfolding lookup_def tensor_from_lookup_def
  by (simp add: lookup_tensor_vec assms length_tensor_vec_from_lookup)

lemma dims_tensor_from_lookup: "dims (tensor_from_lookup ds e) = ds"
  unfolding tensor_from_lookup_def
  by (simp add: length_tensor_vec_from_lookup)

lemma tensor_lookup_cong:
assumes "tensor_from_lookup ds e\<^sub>1 = tensor_from_lookup ds e\<^sub>2"
and "is\<lhd>ds"
shows "e\<^sub>1 is = e\<^sub>2 is" using assms lookup_tensor_from_lookup by metis

lemma tensor_from_lookup_eqI:
assumes "\<And>is. is\<lhd>ds \<Longrightarrow> e\<^sub>1 is = e\<^sub>2 is"
shows "tensor_from_lookup ds e\<^sub>1 = tensor_from_lookup ds e\<^sub>2"
by (metis assms lookup_tensor_vec length_tensor_vec_from_lookup tensor_lookup_base tensor_from_lookup_def)

lemma tensor_lookup_eqI:
assumes "dims A = dims B" and "\<And>is. is\<lhd>(dims A) \<Longrightarrow> lookup A is = lookup B is"
shows "A = B" by (metis assms(1) assms(2) tensor_lookup)

function L :: "constraint \<Rightarrow> tensor \<Rightarrow> real \<Rightarrow> real" where
  "L c [] \<gamma> = (1::real)"
| "L (Comp (Lequal v1 v2)) t \<gamma> = Lequal_gamma \<gamma> (select t 0 v1) (select t 0 v2)"
| "L (Comp (Nequal v1 v2)) t \<gamma> = Nequal_gamma \<gamma> (s v1) (s v2)"
| "L (Comp (Less v1 v2)) (s # ss) \<gamma> = Max_gamma_comp \<gamma> (L (Comp (Lequal v1 v2)) (s # ss) \<gamma>) (L (Comp (Nequal v1 v2)) (s # ss) \<gamma>)"
| "L (Comp (Equal v1 v2)) (s # ss) \<gamma> = Max_gamma_comp \<gamma> (L (Comp (Lequal v1 v2)) (s # ss) \<gamma>) (L (Comp (Lequal v2 v1)) (s # ss) \<gamma>)"
| "L (And c1 c2) (s # ss) \<gamma> = Max_gamma_comp \<gamma> (L c1 (s # ss) \<gamma>) (L c2 (s # ss) \<gamma>)"
| "L (Or c1 c2) (s # ss) \<gamma> = Min_gamma_comp \<gamma> (L c1 (s # ss) \<gamma>)
     (L c2 (s # ss) \<gamma>)"
| "L (Next c) (s # ss) \<gamma> = L c ss \<gamma>"
| "L (Always c) (s # ss) \<gamma> = Max_gamma_comp \<gamma> (L c (s # ss) \<gamma>) (if ss = [] then 0 else (L (Always c) ss) \<gamma>)"
| "L (Eventually c) (s # ss) \<gamma> = Min_gamma_comp \<gamma> (L c (s # ss) \<gamma>) (L (Eventually c) ss \<gamma>)"
| "L (Until c1 c2) (s # ss) \<gamma> = Min_gamma_comp \<gamma> (L c2 (s # ss) \<gamma>)
    (Max_gamma_comp \<gamma> (L c1 (s # ss) \<gamma>) (if ss = [] then 0
      else (L (Until c1 c2) ss \<gamma>)))"
| "L (Release c1 c2) (s # ss) \<gamma> = Max_gamma_comp \<gamma> (L (Eventually c1) (s # ss) \<gamma>) (Min_gamma_comp \<gamma>
      (Max_gamma_comp \<gamma> (L c1 (s # ss) \<gamma>) (L c2 (s # ss) \<gamma>))
      (Max_gamma_comp \<gamma> (L c2 (s # ss) \<gamma>) (L (Release c1 c2) ss \<gamma>)))"
  by (pat_completeness, blast+)
termination by size_change

end


theory SimpleVariantPG imports HOML MFilter BaseDefs
begin
(*Axiom's of simplified variant with A3 replaced*)
axiomatization where
 A1': "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" and
 A2': "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> ((X\<^bold>\<sqsubseteq>Y)\<^bold>\<or>(X\<Rrightarrow>Y))) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
 T2:  "\<lfloor>\<P> \<G>\<rfloor>"

(*Necessary existence of a Godlike entity*)
theorem T6:  "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" sledgehammer (*Proof found*)
proof -
 have T1: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X))\<rfloor>" by (metis A1' A2')
 have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T1 T2 by simp
 have T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis A1' A2' T2)
 thus ?thesis using T3 by blast qed

lemma True nitpick[satisfy] oops (*Consistency: model found*)

(*Modal collapse and Monotheism: not implied*)
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>)\<rfloor>" nitpick oops (*Countermodel*)
lemma MT: "\<lfloor>\<^bold>\<forall>x y.(((\<G> x)\<^bold>\<and>(\<G> y))\<^bold>\<rightarrow>(x\<^bold>=y))\<rfloor>"
          nitpick oops (*Countermodel*)
end

(*
lemma A3':  "\<lfloor>\<^bold>\<forall>\<Z>. \<P>\<o>\<s> \<Z> \<^bold>\<rightarrow> (\<^bold>\<forall>X. (X\<Sqinter>\<Z>) \<^bold>\<rightarrow> \<P> X)\<rfloor>"
  nitpick sledgehammer oops

(*Gödel's A1, A4, A5: not implied anymore*)

end

*)

(*
(*Further Tests*)
 lemma A3': "\<lfloor>\<^bold>\<forall>X Y.((\<P> X) \<^bold>\<and> (\<P> Y)) \<^bold>\<rightarrow> \<P> (\<lambda>z. X z  \<^bold>\<and> Y z)\<rfloor>" sledgehammer(A3) nitpick oops

 lemma "\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<^bold>\<rightarrow>(X\<Rrightarrow>Y)\<rfloor>" nitpick oops (*Countermodel*)
 lemma "\<lfloor>(X\<Rrightarrow>Y)\<^bold>\<rightarrow>(X\<^bold>\<sqsubseteq>Y)\<rfloor>" sledgehammer nitpick oops (*Countermodel*)
 lemma "(\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<rfloor>)\<longrightarrow>(\<lfloor>(X\<Rrightarrow>Y)\<rfloor>)" nitpick oops (*Countermodel*)
 lemma "(\<lfloor>(X\<Rrightarrow>Y)\<rfloor>)\<longrightarrow>(\<lfloor>(X\<^bold>\<sqsubseteq>Y)\<rfloor>)" nitpick oops (*Countermodel*)
*)

(*
lemma T2: "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
theorem F1: "\<lfloor>Filter \<P>\<rfloor>" sledgehammer (*Proof found*)
proof -
 have 1: "\<lfloor>\<^bold>U\<^bold>\<in>\<P> \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<P>)\<rfloor>" using A1' by auto
 have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<P>)\<rfloor>" by (metis A2')
 have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> \<psi>\<^bold>\<in>\<P>) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<P>)\<rfloor>" by (metis (no_types, lifting) A2' G_def A3)
 thus ?thesis using 1 2 3 by simp qed

theorem U1: "\<lfloor>Ultrafilter \<P>\<rfloor>" nitpick oops (*Countermodel*)
*)

(*
abbreviation a2::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (infix"\<^bold>\<in>"81) where "x\<^bold>\<in>S \<equiv> S x"
abbreviation b2::\<gamma> ("\<^bold>\<emptyset>") where "\<^bold>\<emptyset> \<equiv> \<lambda>x. \<^bold>\<bottom>"
abbreviation c2::\<gamma> ("\<^bold>U") where "\<^bold>U \<equiv> \<lambda>x. \<^bold>\<top>"
abbreviation d2::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<sigma>" ("_\<^bold>\<subseteq>_") where "\<phi>\<^bold>\<subseteq>\<psi> \<equiv> \<^bold>\<forall>x. \<phi> x \<^bold>\<rightarrow> \<psi> x"
abbreviation e2::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<gamma>" ("_\<^bold>\<sqinter>_") where "\<phi>\<^bold>\<sqinter>\<psi> \<equiv> \<lambda>x. \<phi> x \<^bold>\<and> \<psi> x"
abbreviation f2::"\<gamma>\<Rightarrow>\<gamma>" ("\<inverse>_") where "\<inverse>\<psi> \<equiv> \<lambda>x. \<^bold>\<not>(\<psi> x)"

(*Definition of modal filter*)
abbreviation g::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("Filter")
  where "Filter \<Phi> \<equiv> \<^bold>U\<^bold>\<in>\<Phi> \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<Phi>)
                     \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (\<phi>\<^bold>\<in>\<Phi> \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<Phi>)
                     \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (\<phi>\<^bold>\<in>\<Phi> \<^bold>\<and> \<psi>\<^bold>\<in>\<Phi>) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<Phi>)"

(*Definition of modal ultrafilter *)
abbreviation h::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("Ultrafilter")
  where "Ultrafilter \<Phi> \<equiv> Filter \<Phi> \<^bold>\<and> (\<^bold>\<forall>\<phi>. (\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<or> ((\<inverse>\<phi>)\<^bold>\<in>\<Phi>))"

theorem U1: "\<lfloor>Ultrafilter \<P>\<rfloor>"
proof -
 have 1: "\<lfloor>\<^bold>U\<^bold>\<in>\<P> \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<P>)\<rfloor>" using A1' by auto
 have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<P>)\<rfloor>" by (metis A2')
 have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.((\<phi>\<^bold>\<in>\<P> \<^bold>\<and> \<psi>\<^bold>\<in>\<P>) \<^bold>\<rightarrow> (\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<P>)\<rfloor>" using A3 sledgehammer [remote_satallax remote_leo2 remote_leo3]  nitpick sorry
 have 4: "\<lfloor>\<^bold>\<forall>\<phi>.(\<phi>\<^bold>\<in>\<P> \<^bold>\<or> (\<inverse>\<phi>)\<^bold>\<in>\<P>)\<rfloor>" nitpick oops
 thus ?thesis using 1 2 3 4 by simp qed

 lemma "\<lfloor>Filter \<P> \<rfloor>" sledgehammer nitpick oops (*Counterm*)
 lemma "\<lfloor>Ultrafilter \<P> \<rfloor>" sledgehammer nitpick oops (*Counterm*)

(*Filter and ultrafilter are consistent*)

 consts Godlike::\<gamma>  NeEx::\<gamma>
 axiomatization where
  1: "Godlike = \<G>" and
  2: "NeEx = \<N>\<E>" and
  3: "\<exists>e1::e. \<exists>e2::e. \<not> e1 = e2"

 lemma True nitpick[satisfy] oops
 lemma MT: "\<lfloor>\<^bold>\<forall>x y. \<G> x \<^bold>\<and> \<G> y \<^bold>\<rightarrow> x \<^bold>= y\<rfloor>" nitpick oops (*Cntm.*)
 lemma MT: "\<lfloor>\<^bold>\<forall>\<^sup>Ex y. \<G> x \<^bold>\<and> \<G> y \<^bold>\<rightarrow> x \<^bold>= y\<rfloor>" sledgehammer nitpick [format=2] oops
 lemma MT': "\<G> x w \<and> \<G> y w \<and> \<not>\<G> z w \<longrightarrow> x = y" sledgehammer nitpick [format=2] oops
 lemma MT'': "\<lfloor>\<^bold>\<forall>\<^sup>Ex y. \<G> x \<^bold>\<and> \<G> y \<^bold>\<rightarrow> (\<^bold>\<forall>P. P x \<^bold>\<rightarrow> P y)\<rfloor>" sledgehammer nitpick [format=2] oops
 lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" nitpick[timeout = 10000] nunchaku oops (*Countermodel*)
 lemma A1: "\<lfloor>\<^bold>\<forall>X.(\<^bold>\<not>(\<P> X) \<^bold>\<leftrightarrow> \<P>(\<^bold>\<rightharpoondown>X))\<rfloor>" nitpick[format=4] oops (*Countermodel*)
 lemma A4: "\<lfloor>\<^bold>\<forall>X.(\<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X))\<rfloor>" nitpick[format=4] oops (*Countermodel*)
 lemma A5: "\<lfloor>\<P> \<N>\<E>\<rfloor>" nitpick oops (*Countermodel*)
*)