(*  Title:      CoW_Lyndon.Lyndon
    Author:     Štěpán Holub, Charles University
    Author:     Štěpán Starosta, CTU in Prague

Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
*)
theory Lyndon
  imports Combinatorics_Words.CoWBasic
begin

chapter "Lyndon words"

text\<open>A Lyndon word is a non-empty word that is lexicographically
strictly smaller than any other word in its conjugacy class, i.e., than any its rotations.
They are named after R. Lyndon who introduced them in \<^cite>\<open>Lyndon54\<close> as ``standard'' sequences.

We present elementary results on Lyndon words, mostly covered by results in \<^cite>\<open>\<open>Chapter 5\<close> in Lo83\<close> and \<^cite>\<open>Duval80 and Duval83\<close>.

This definition assumes a linear order on letters given by the context.
\<close>

section "Definition and elementary properties"

subsection "Underlying order"

lemma (in linorder) lexordp_mid_pref: "ord_class.lexordp u v \<Longrightarrow> ord_class.lexordp v (u\<cdot>s) \<Longrightarrow>
   u \<le>p v"
  by (induct rule: lexordp_induct, simp_all)

lemma (in linorder) lexordp_ext: "ord_class.lexordp u v \<Longrightarrow>  \<not> u \<le>p v \<Longrightarrow>
  ord_class.lexordp (u\<cdot>w) (v\<cdot>z)"
  by (induct rule: lexordp_induct, simp_all)

lemmas [code] = lexordp_simps

context linorder
begin

abbreviation Lyndon_less :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "<lex" 50)
  where "Lyndon_less xs ys \<equiv> ord_class.lexordp xs ys"

abbreviation Lyndon_le :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "\<le>lex" 50)
  where "Lyndon_le xs ys \<equiv> ord_class.lexordp_eq xs ys"

interpretation rlex: linorder "(\<le>lex)" "(<lex)"
  using lexordp_linorder.

interpretation dual_rlex: linorder "\<lambda> x y. y \<le>lex x" "\<lambda> x y. y <lex x"
  using rlex.dual_linorder.

lemma sorted_dual_rev_iff: "dual_rlex.sorted ws \<longleftrightarrow> rlex.sorted (rev ws)"
  unfolding rlex.sorted_rev_iff_nth_mono dual_rlex.sorted_iff_nth_mono by blast

text \<open>Several useful lemmas that are formulated for relations, interpreted for the default linear order.\<close>

lemmas lexord_suf_linorder = lexord_sufE[of _ _ _ _ "{(x, y). x < y}", folded lexordp_conv_lexord]
  and lexord_append_leftI_linorder = lexord_append_leftI[of  _ _  "{(x, y). x < y}" _, folded lexordp_conv_lexord]
  and lexord_app_right_linorder = lexord_sufI[of  _ _  "{(x, y). x < y}" _, folded lexordp_conv_lexord]
  and lexord_take_index_conv_linorder = lexord_take_index_conv[of  _ _  "{(x, y). x < y}", folded lexordp_conv_lexord]
  and mismatch_lexord_linorder = mismatch_lexord[of  _ _  "{(x, y). x < y}", folded lexordp_conv_lexord]
  and lexord_cancel_right_linorder = lexord_cancel_right[of _ _ _ _ "{(a,b). a < b}", folded lexordp_conv_lexord]

subsection "Lyndon word definition"

fun Lyndon :: "'a list \<Rightarrow> bool"
  where "Lyndon w = (w \<noteq> \<epsilon> \<and> (\<forall>n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w))"

lemma LyndonD: "Lyndon w \<Longrightarrow> 0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> w <lex rotate n w"
  unfolding Lyndon.simps by blast

lemma LyndonD_nemp: "Lyndon w \<Longrightarrow> w \<noteq> \<epsilon>"
  unfolding Lyndon.simps by blast

lemma LyndonI: "w \<noteq> \<epsilon> \<Longrightarrow> \<forall> n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w \<Longrightarrow>  Lyndon w"
  unfolding  Lyndon.simps by blast

lemma Lyndon_sing: "Lyndon [a]"
  unfolding Lyndon.simps by auto

lemma Lyndon_prim: assumes "Lyndon w"
  shows "primitive w"
proof-
  have "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> rotate n w \<noteq> w" for n
    using LyndonD[OF \<open>Lyndon w\<close>, of n] rlex.less_irrefl[of w] by argo
  from no_rotate_prim[OF LyndonD_nemp[OF \<open>Lyndon w\<close>]] this
  show ?thesis by blast
qed

lemma Lyndon_conj_greater: "Lyndon (u\<cdot>v) \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> u\<cdot>v <lex v\<cdot>u"
  using LyndonD[of "u\<cdot>v" "\<^bold>|u\<^bold>|", unfolded rotate_append[of u v]]
  by force

subsection "Code equations for Lyndon words"

primrec Lyndon_rec :: "'a list \<Rightarrow> nat \<Rightarrow> bool" where
    "Lyndon_rec w 0 = True" |
    "Lyndon_rec w (Suc n) = (if w <lex rotate (Suc n) w then Lyndon_rec w n else False)"

lemma Lyndon_rec_all: assumes "Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)"
  shows "n < \<^bold>|a#w\<^bold>| \<Longrightarrow> 0 < n \<Longrightarrow> Lyndon_rec (a#w) n"
proof(induction n rule: strict_inc_induct)
  case (base i)
  then show ?case
    using assms by auto
next
  case (step i)
  then show ?case
    by (meson Lyndon_rec.simps(2) zero_less_Suc)
qed

lemma Lyndon_Lyndon_rec: assumes "Lyndon w"
  shows "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> Lyndon_rec w n"
proof(induction n, simp)
  case (Suc n)
  have "w <lex rotate (Suc n) w"
    using LyndonD Suc.prems(2) assms by blast
  then show ?case
    using Suc.IH[OF _ Suc_lessD[OF \<open>Suc n < \<^bold>|w\<^bold>|\<close>], folded neq0_conv] Lyndon_rec.simps(1)[of w]
    unfolding Lyndon_rec.simps(2)
    by metis
qed

lemma Lyndon_code [code]:
    "Lyndon Nil = False"
    "Lyndon (a # w) = Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)"
proof-
  show "Lyndon Nil = False" by simp
  have "a # w \<noteq> \<epsilon>"
    by simp
  have ax: "0 < n \<Longrightarrow> Lyndon_rec (a#w) n \<Longrightarrow> (a#w) <lex rotate n (a#w)" for n
    using Lyndon_rec.simps(2)[of "a#w"] gr0_implies_Suc[of n] by metis
  have bx: "Lyndon_rec (a # w) (\<^bold>|w\<^bold>|) = (\<forall>n. n < \<^bold>|a#w\<^bold>| \<and> 0 < n \<longrightarrow> Lyndon_rec (a#w) n)"
  proof(cases "w = \<epsilon>", simp)
    assume "w \<noteq> \<epsilon>"
    from this[folded length_greater_0_conv]
    show ?thesis
      using Lyndon_rec_all[of a w] length_Cons[of a w] lessI[of "\<^bold>|w\<^bold>|"]
      by fastforce
  qed
  show "Lyndon (a # w) = Lyndon_rec (a # w) \<^bold>|w\<^bold>|"
    unfolding bx Lyndon.simps
    using ax  LyndonI[OF \<open>a # w \<noteq> \<epsilon>\<close>]Lyndon_Lyndon_rec by blast
qed

subsection "Properties of Lyndon words"

subsubsection "Lyndon words are unbordered"

theorem Lyndon_unbordered: assumes "Lyndon w" shows "\<not> bordered w"
proof
  assume "bordered w"
  from bordered_dec[OF this]
  obtain u v where "u\<cdot>v\<cdot>u = w" and "u \<noteq> \<epsilon>".
  hence "v \<cdot> u \<noteq> \<epsilon>" and "u \<cdot> v \<noteq> \<epsilon>" by blast+
  note lyn = \<open>Lyndon w\<close>[folded  \<open>u\<cdot>v\<cdot>u = w\<close>]
  have "u\<cdot>v\<cdot>u <lex v\<cdot>u\<cdot>u"
    using Lyndon_conj_greater[of u "v\<cdot>u", OF lyn \<open>u \<noteq> \<epsilon>\<close> \<open>v \<cdot> u \<noteq> \<epsilon>\<close>, unfolded rassoc].
  from this[unfolded lassoc]
  have "u \<cdot> v \<noteq> v \<cdot> u"
    by force
  from lexord_suf_linorder[OF _ this, of u u]
  have "u\<cdot>v <lex v\<cdot>u"
    using  \<open>u\<cdot>v\<cdot>u <lex v\<cdot>u\<cdot>u\<close>  by simp
  from lexord_append_leftI_linorder[of  "u\<cdot>v" "v\<cdot>u", unfolded lassoc, OF this, unfolded rassoc]
  have "u\<cdot>u\<cdot>v <lex u\<cdot>v\<cdot>u".
  from this Lyndon_conj_greater[of "u\<cdot>v" u, unfolded rassoc, OF lyn \<open>u \<cdot> v \<noteq> \<epsilon>\<close>  \<open>u \<noteq> \<epsilon>\<close>]
  show False
    by simp
qed

subsubsection "Each conjugacy class contains a Lyndon word"

lemma conjug_Lyndon_ex: assumes "primitive w"
  obtains n where "Lyndon (rotate n w)"
proof-
  have "w \<noteq> \<epsilon>"
    using  prim_nemp[OF \<open>primitive w\<close>].

  let ?ConClass = "{rotate n w | n. 0 \<le> n \<and> n < \<^bold>|w\<^bold>|}"

  have "?ConClass \<noteq> {}"
    using \<open>w \<noteq> \<epsilon>\<close> by blast
  have "w \<in> ?ConClass"
    using \<open>w \<noteq> \<epsilon>\<close> id_apply[of w, folded rotate0]
    by force
  have "finite ?ConClass"
    by simp
  have all_rot: "rotate m w \<in> ?ConClass" for m
    using rotate_conv_mod[of _ w] mod_less_divisor[of "\<^bold>|w\<^bold>|"] \<open>w \<noteq> \<epsilon>\<close>
    by blast

  obtain w' n where "w' \<in> ?ConClass" and all_b: "\<forall> b \<in> ?ConClass. b \<le>lex w' \<longrightarrow> w' = b" and w': "w' = rotate n w"
    using rlex.finite_has_minimal[OF \<open>finite ?ConClass\<close> \<open>?ConClass \<noteq> {}\<close>] by auto

  have "rotate n w <lex rotate na (rotate n w)" if  "0 < na" and "na < \<^bold>|w\<^bold>|" for na
  proof-
    from prim_no_rotate[OF assms[unfolded prim_rotate_conv[of w n]], of na] \<open>na < \<^bold>|w\<^bold>|\<close> \<open>0 < na\<close>
    have "rotate na (rotate n w) \<noteq> rotate n w" by force
    hence "\<not> rotate na (rotate n w) \<le>lex rotate n w"
      using all_b[rule_format, OF all_rot[of "na + n", folded rotate_rotate[of na n w]]] unfolding w'
      by auto
    from rlex.not_le_imp_less[OF this]
    show "rotate n w <lex rotate na (rotate n w)".
  qed
  hence "Lyndon (rotate n w)"
    using \<open>w \<noteq> \<epsilon>\<close> by auto
  from that[OF this] show thesis.
qed

lemma conjug_Lyndon_ex': assumes "primitive w"
  obtains v where "w \<sim> v" and "Lyndon v"
  unfolding conjug_rotate_iff
  using conjug_Lyndon_ex[OF \<open>primitive w\<close>]
  by metis

section "Characterization by suffixes"

lemma Lyndon_suf_less: assumes "Lyndon w" "s \<le>ns w" "s \<noteq> w"
  shows "w <lex s"
proof-
  define p where "p = take \<^bold>|s\<^bold>| w"
  have "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|"
    using nsD[OF \<open>s \<le>ns w\<close>]
    by (simp add: suffix_length_le)
  have "p \<le>p w" and "\<^bold>|p\<^bold>|  = \<^bold>|s\<^bold>|"
    unfolding p_def
    using take_is_prefix \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|\<close> take_len by blast+
  hence "p \<noteq> s"
    using Lyndon_unbordered[OF \<open>Lyndon w\<close>] \<open>s \<le>ns w\<close> \<open>s \<noteq> w\<close> assms
    by auto
  define p' s' where "p' = drop \<^bold>|s\<^bold>| w" and "s' = take \<^bold>|p'\<^bold>| w"
  have "p \<cdot> p' = w"
    unfolding p'_def p_def s'_def by simp
  have "s' \<cdot> s = w"
    unfolding p'_def p_def s'_def
     using suf_len[OF nsD[OF \<open>s \<le>ns w\<close>]] nsD[OF \<open>s \<le>ns w\<close>]
     length_drop suffix_take by metis
  have "\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|"
    using s'_def \<open>p\<cdot>p' = w\<close> by auto
  have "w <lex s\<cdot>s'"
    using Lyndon_conj_greater[of s' s, unfolded \<open>s' \<cdot> s = w\<close>, OF \<open>Lyndon w\<close>] \<open>p \<noteq> s\<close>
    unfolding \<open>s' \<cdot> s = w\<close> p_def using \<open>s' \<cdot> s = w\<close> assms(3) by fastforce
  from lexord_suf_linorder[OF _ \<open>p \<noteq> s\<close> \<open>\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\<close> \<open>\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|\<close>, OF this[folded \<open>p \<cdot> p' = w\<close>]]
  have "p <lex s".
  from lexord_app_right_linorder[OF this, of p' \<epsilon>, unfolded \<open>p \<cdot> p' = w\<close>]  \<open>\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\<close>
  show "w <lex s"
    by simp
qed

(* TODO try using also elsewhere *)
lemma Lyndon_pref_suf_less:  assumes "Lyndon w" "p \<le>p w" "s \<le>ns w" "s \<noteq> w"
  shows "p <lex s"
proof(cases "p = w", simp add: Lyndon_suf_less[OF assms(1) assms(3) assms(4)])
  assume "p \<noteq> w"
  show "p <lex s"
  proof(rule rlex.less_trans)
    show "p <lex w"
      using \<open>p \<noteq> w\<close> assms(2) lexordp_append_rightI
      by (fastforce simp add: prefix_def)
    show "w <lex s"
      using Lyndon_suf_less assms(1) assms(3) assms(4) by blast
  qed
qed

lemma suf_less_Lyndon: assumes "w \<noteq> \<epsilon>" and "\<forall>s. (s \<le>ns w \<longrightarrow> s \<noteq> w \<longrightarrow> w <lex s)"
  shows "Lyndon w"
proof (cases "primitive w")
  assume "\<not> primitive w"
  obtain q k where "q \<noteq> \<epsilon>" "1 < k" "q\<^sup>@k=w" "w\<noteq>q" \<comment> \<open>the exact match of @{thm non_prim} fastens the proof considerably\<close>
    using non_prim[OF \<open>\<not> primitive w\<close> \<open>w \<noteq> \<epsilon>\<close>] by blast
  hence "q \<le>ns w"
    unfolding nonempty_suffix_def pow_eq_if_list[of q k] pow_comm[symmetric]
    using sufI[of "q \<^sup>@ (k - 1)" q w]
    by presburger

  have "q <p w"
    using \<open>1 < k\<close>  \<open>q \<^sup>@ k = w\<close>
    unfolding pow_eq_if_list[of q k] pow_eq_if_list[of q "k-1"]
    using \<open>w \<noteq> \<epsilon>\<close>  by auto
  from lexordp_append_rightI[of "q\<inverse>\<^sup>>w" q,
      unfolded lq_pref[OF sprefD1[OF this]], OF lq_spref[OF this]]
  have "q <lex w".
  thus  "Lyndon w"
    unfolding Lyndon.simps using \<open>q \<le>ns w\<close> \<open>w \<noteq> \<epsilon>\<close> assms(2) rlex.order.strict_trans by blast
next
  assume "primitive w"
  have "w <lex rotate l w" if assms_l: "0 < l" "l < \<^bold>|w\<^bold>|" for l
  proof-
    have "take l w \<le>np w" and "\<^bold>|take l w\<^bold>| = l"
      using assms_l take_is_prefix  \<open>l < \<^bold>|w\<^bold>|\<close> by auto
    have "drop l w \<le>ns w"
      using \<open>l < \<^bold>|w\<^bold>|\<close> suffix_drop by auto
    have "drop l w \<noteq> w"
      using append_take_drop_id[of l w] npD'[OF \<open>take l w \<le>np w\<close>] by force
    have "drop l w \<cdot> take l w = rotate l w"
      using rotate_append[of "take l w" "drop l w", symmetric, unfolded \<open>\<^bold>|take l w\<^bold>| = l\<close>,
          unfolded append_take_drop_id].

    have "w <lex drop l w"
      using \<open>drop l w \<le>ns w\<close> \<open>drop l w \<noteq> w\<close> assms(2) by blast
    from lexord_app_right_linorder[OF this suffix_length_le[OF conjunct2[OF \<open>drop l w \<le>ns w\<close>[unfolded nonempty_suffix_def]]], of \<epsilon> "take l w", unfolded  append.right_neutral]
    have "w <lex drop l w \<cdot> take l w".
    thus "w <lex rotate l w"
      by (simp add: \<open>drop l w \<cdot> take l w = rotate l w\<close>)
  qed
  thus "Lyndon w"
    by (simp add: \<open>w \<noteq> \<epsilon>\<close> local.LyndonI)
qed

corollary Lyndon_suf_char: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon w \<longleftrightarrow> (\<forall>s. s \<le>ns w \<longrightarrow> s \<noteq> w \<longrightarrow> w <lex s)"
  using Lyndon_suf_less suf_less_Lyndon by blast

lemma Lyndon_suf_le: "Lyndon w \<Longrightarrow> s \<le>ns w \<Longrightarrow> w \<le>lex s"
  using Lyndon_suf_less rlex.not_less rlex.order.asym by blast

section "Unbordered prefix of a Lyndon word is Lyndon"

lemma unbordered_pref_Lyndon: "Lyndon (u\<cdot>v) \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> \<not> bordered u \<Longrightarrow> Lyndon u"
  unfolding Lyndon_suf_char
proof(standard+)
  fix s
  assume "Lyndon (u \<cdot> v)" and  "u \<noteq> \<epsilon>" and "\<not> bordered u" and "s \<le>ns u" and "s \<noteq> u"
    hence "u \<cdot> v <lex s \<cdot> v"
      using  Lyndon_suf_less[OF \<open>Lyndon (u \<cdot> v)\<close>, of "s \<cdot> v"] by auto
    have "\<not> s \<le>p u"
      using \<open>\<not> bordered u\<close> \<open>s \<le>ns u\<close> \<open>s \<noteq> u\<close> by auto
    moreover have "\<not> u \<le>p s"
      using suf_pref_eq[OF nsD[OF\<open>s \<le>ns u\<close>]] \<open>s \<noteq> u\<close> by blast
    ultimately show "u <lex s"
      using lexord_cancel_right_linorder[OF \<open>u \<cdot> v <lex s \<cdot> v\<close>] by blast
qed

section "Concatenation of Lyndon words"

theorem Lyndon_concat: assumes  "Lyndon u" and "Lyndon v" and "u <lex v"
  shows "Lyndon (u\<cdot>v)"
proof-
  have "u\<cdot>v <lex v"
  proof(cases "u \<le>p v")
    assume "u \<le>p v"
    obtain z where "u\<cdot>z = v" and "z \<le>ns v"
      using  lq_pref[OF \<open>u \<le>p v\<close>] nsI' rlex.less_imp_neq[OF \<open>u <lex v\<close>] self_append_conv by metis
    from Lyndon_suf_less[OF \<open>Lyndon v\<close> this(2), THEN lexord_append_leftI_linorder, of u]
      LyndonD_nemp[OF \<open>Lyndon u\<close>] this(1)
    show ?thesis
      by blast
  next
    assume "\<not> u \<le>p v"
    then show ?thesis
      using local.lexordp_linear[of v "u\<cdot>v"]
        local.lexordp_mid_pref[OF \<open>u <lex v\<close>,of v]
        prefixI[of v u v]
      by argo
  qed

  { fix z
    assume "z \<le>ns (u\<cdot>v)" "z \<noteq> u\<cdot>v"
    have "u\<cdot>v <lex z"
    proof(cases "z \<le>ns v")
      assume "z \<le>ns v"
      from Lyndon_suf_less[OF \<open>Lyndon v\<close> this]
      have "z \<noteq> v \<Longrightarrow> v <lex z"
        by blast
      thus "u\<cdot>v <lex z"
        using \<open>u \<cdot> v <lex v\<close> rlex.less_trans
        by fast
    next
      assume "\<not> z \<le>ns v"
      then obtain z' where "z' \<le>ns u" "z' \<noteq> u" "z'\<cdot>v = z"
        using \<open>z \<le>ns u \<cdot> v\<close> \<open>z \<noteq> u \<cdot> v\<close> suffix_append[of z u v]
        unfolding nonempty_suffix_def
        by force
      from Lyndon_suf_less[OF \<open>Lyndon u\<close> this(1) this(2)]
      have "u <lex z'".
      thus "u\<cdot>v <lex z"
        using  \<open>z' \<le>ns u\<close> lexord_app_right_linorder[of u z' v v] suffix_length_le[of z' u]
        unfolding nonempty_suffix_def \<open>z' \<cdot> v = z\<close>
        by blast
    qed
  }
  thus ?thesis
    using suf_nemp[OF LyndonD_nemp[OF \<open>Lyndon v\<close>], of u, THEN suf_less_Lyndon]
    by blast
qed

section "Longest Lyndon suffix"

fun longest_Lyndon_suffix:: "'a list \<Rightarrow> 'a list" ("LynSuf") where
  "longest_Lyndon_suffix \<epsilon> = \<epsilon>" |
  "longest_Lyndon_suffix (a#w) = (if Lyndon (a#w) then a#w else longest_Lyndon_suffix w)"

lemma longest_Lyndon_suf_ext: "\<not> Lyndon (a # w) \<Longrightarrow> LynSuf w = LynSuf (a # w)"
  using longest_Lyndon_suffix.simps(2) by presburger

lemma longest_Lyndon_suf_suf: "w \<noteq> \<epsilon> \<Longrightarrow> LynSuf w \<le>s w"
proof(induction w rule: longest_Lyndon_suffix.induct)
  case 1
  then show ?case by simp
next
  case (2 a w)
  show ?case
  proof(cases "Lyndon (a#w)")
    case True
    then show ?thesis by auto
  next
    case False
    from "2.IH"[OF this, unfolded longest_Lyndon_suf_ext[OF this], THEN suffix_ConsI, of a]
      Lyndon_sing False
    show ?thesis by blast
  qed
qed

lemma longest_Lyndon_suf_max:
  "v \<le>s w  \<Longrightarrow> Lyndon v \<Longrightarrow> v \<le>s (LynSuf w)"
proof(induction w arbitrary: v rule: longest_Lyndon_suffix.induct)
  case 1
  then show ?case
    using longest_Lyndon_suffix.simps(1) by presburger
next
  case (2 a w)
  show ?case
  proof(cases "Lyndon (a#w)")
    case True
    then show ?thesis
      using "2.prems"(1) longest_Lyndon_suffix.simps(2) by presburger
  next
    case False
    have "v \<noteq> a # w"
      using "2.prems"(2) False by blast
    from "2.IH"[OF False _ "2.prems"(2), unfolded longest_Lyndon_suf_ext[OF False]]
       "2.prems"(1)[unfolded suffix_Cons] this
    show ?thesis by fast
  qed
qed

lemma longest_Lyndon_suf_Lyndon_id: assumes "Lyndon w"
  shows "LynSuf w = w"
proof(cases "w = \<epsilon>", simp)
  case False
  from longest_Lyndon_suf_suf[OF this]
    suffix_order.order_refl[THEN longest_Lyndon_suf_max[OF _ assms]]
    suffix_order.antisym
  show ?thesis by blast
qed

lemma longest_Lyndon_suf_longest: "w \<noteq> \<epsilon> \<Longrightarrow> v' \<le>s w \<Longrightarrow> Lyndon v' \<Longrightarrow> \<^bold>|v'\<^bold>| \<le> \<^bold>|(LynSuf w)\<^bold>|"
  using longest_Lyndon_suf_max suffix_length_le by blast

lemma longest_Lyndon_suf_sing: "LynSuf [a] = [a]"
  using Lyndon_sing longest_Lyndon_suf_Lyndon_id by blast

lemma longest_Lyndon_suf_Lyndon: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon (LynSuf w)"
proof(induction w rule: longest_Lyndon_suffix.induct, blast)
  case (2 a w)
  show ?case
  proof(cases "Lyndon (a#w)")
    case True
    then show ?thesis
      using longest_Lyndon_suf_Lyndon_id by presburger
  next
    case False
    from "2.IH"[OF this, unfolded longest_Lyndon_suf_ext[OF this]] Lyndon_sing
    show ?thesis by fastforce
  qed
qed

lemma longest_Lyndon_suf_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> LynSuf w \<noteq> \<epsilon>"
  using longest_Lyndon_suf_Lyndon[THEN LyndonD_nemp].

lemma longest_Lyndon_sufI:
  assumes "q \<le>s w" and "Lyndon q" and all_s: "(\<forall> s. (s \<le>s w \<and> Lyndon s) \<longrightarrow> s \<le>s q)"
  shows "LynSuf w = q"
proof(cases "w = \<epsilon>")
  case True
  then show ?thesis
    using assms(1) longest_Lyndon_suffix.simps(1) suffix_bot.extremum_uniqueI by blast
next
  case False
  from all_s longest_Lyndon_suf_Lyndon[OF this] longest_Lyndon_suf_max[OF assms(1) assms(2)]
    longest_Lyndon_suf_suf[OF this] suffix_order.eq_iff
  show ?thesis by blast
qed

corollary longest_Lyndon_sufI':
  assumes "q \<le>s w" and "Lyndon q" and all_s: "\<forall> s. (s \<le>s w \<and> Lyndon s) \<longrightarrow> \<^bold>|s\<^bold>| \<le> \<^bold>|q\<^bold>|"
  shows "LynSuf w = q"
  using longest_Lyndon_sufI[OF \<open>q \<le>s w\<close> \<open>Lyndon q\<close>] suf_ruler_le all_s \<open>q \<le>s w\<close> by blast

text\<open>The next lemma is fabricated to suit the upcoming definition of longest Lyndon factorization.\<close>

lemma longest_Lyndon_suf_shorter: assumes "w \<noteq> \<epsilon>"
  shows "\<^bold>|w\<^sup><\<inverse>(LynSuf w)\<^bold>| < \<^bold>|w\<^bold>|"
  using nemp_len[OF longest_Lyndon_suf_nemp[OF \<open>w \<noteq> \<epsilon>\<close>]] arg_cong[OF rq_suf[OF longest_Lyndon_suf_suf[OF \<open>w \<noteq> \<epsilon>\<close>]], of length]
  unfolding lenmorph by linarith

section "Lyndon factorizations"

function Lyndon_fac::"'a list  \<Rightarrow> 'a list list" ("LynFac")
  where "Lyndon_fac w  = (if w \<noteq> \<epsilon> then ((Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) \<cdot> [LynSuf w]) else \<epsilon>)"
  using longest_Lyndon_suffix.cases by blast+
termination
proof(relation "measure length", simp)
  show "\<And>w. w \<noteq> \<epsilon> \<Longrightarrow> (w\<^sup><\<inverse>LynSuf w, w) \<in> measure length"
    unfolding measure_def inv_image_def using longest_Lyndon_suf_shorter by blast
qed

text\<open>The factorization @{term "Lyndon_fac w"} obtained by taking always the longest Lyndon suffix is well defined,
and called ``Lyndon factorization (of $w$)''.\<close>

lemma Lyndon_fac_simp: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon_fac w =  Lyndon_fac (w\<^sup><\<inverse>LynSuf w) \<cdot> (LynSuf w # \<epsilon>)"
  using Lyndon_fac.simps[of w] by meson

lemma Lyndon_fac_emp: "Lyndon_fac \<epsilon> = \<epsilon>"
  by simp

text\<open>Note that the Lyndon factorization of a Lyndon word is trivial.\<close>

lemma Lyndon_fac_longest_Lyndon_id: "Lyndon w \<Longrightarrow> Lyndon_fac w = [w]"
  by (simp add: longest_Lyndon_suf_Lyndon_id)

text\<open>Lyndon factorization is composed of Lyndon words ...\<close>

lemma Lyndon_fac_set: "z \<in> set (Lyndon_fac w) \<Longrightarrow> Lyndon z"
proof(induction w rule:  Lyndon_fac.induct)
  case (1 w)
  then show "Lyndon z"
  proof (cases "w = \<epsilon>")
    assume "w \<noteq> \<epsilon>"
    have "Lyndon_fac w  = (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) \<cdot> [LynSuf w]"
      using Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>].
    from set_ConsD[OF "1.prems"(1)[unfolded rotate1.simps(2)[of "LynSuf w" "Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )", folded this, symmetric], unfolded set_rotate1]]
    have "z = LynSuf w \<or> z \<in> set (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) ))".
    thus "Lyndon z"
      using "1.IH"[OF \<open>w \<noteq> \<epsilon>\<close>] longest_Lyndon_suf_Lyndon[OF \<open>w \<noteq> \<epsilon>\<close>]
      by blast
  next
    assume "w = \<epsilon>"
    thus "Lyndon z"
      using "1.prems"
      unfolding Lyndon_fac_emp[folded \<open>w = \<epsilon>\<close>] list.set(1) empty_iff
      by blast
  qed
qed

text\<open>...and it indeed is a factorization of the argument.\<close>

lemma Lyndon_fac_longest_dec: "concat (Lyndon_fac w) = w"
proof(induction w rule: Lyndon_fac.induct)
  case (1 w)
  thus "concat (LynFac w) = w"
  proof (cases "w = \<epsilon>", simp)
  assume "w \<noteq> \<epsilon>"
    have eq: "concat (Lyndon_fac w) = concat ( (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) ) \<cdot> concat ([LynSuf w])"
      unfolding Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>] concat_morph..
    from this[unfolded "1.IH"[OF \<open>w \<noteq> \<epsilon>\<close>] concat_sing' rq_suf[OF longest_Lyndon_suf_suf[OF \<open>w \<noteq> \<epsilon>\<close>]]]
    show ?case.
  qed
qed

text\<open>The following lemma makes explicit the inductive character of the definition of @{term Lyndon_fac}.\<close>

lemma Lyndon_fac_longest_pref: "us \<le>p Lyndon_fac w \<Longrightarrow> Lyndon_fac (concat us) = us"
proof(induction w arbitrary: us rule:  Lyndon_fac.induct)
  case (1 w)
  thus "LynFac (concat us) = us"
  proof (cases "w = \<epsilon>", simp)
    assume "w \<noteq> \<epsilon>"
    have step: "Lyndon_fac w = (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w))) \<cdot> [LynSuf w]"
      using Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>].

    consider (neq) "us \<noteq> Lyndon_fac w" | (eq) "us = Lyndon_fac w"
      using "1.prems" le_neq_implies_less by blast
    then show "LynFac (concat us) = us"
    proof(cases)
      case neq
      hence "us \<le>p Lyndon_fac (w\<^sup><\<inverse>LynSuf w)"
        using "1.prems" last_no_split[of us "Lyndon_fac (w\<^sup><\<inverse>LynSuf w)" "LynSuf w"]
        unfolding step[symmetric] by blast
      thus "LynFac (concat us) = us"
        using "1.IH" \<open>w \<noteq> \<epsilon>\<close> by blast
    next
      case eq
      show "LynFac (concat us) = us"
        using Lyndon_fac_longest_dec[of w, folded eq] eq by simp
    qed
  qed
qed

text\<open>We give name to an important predicate: monotone (nonincreasing) list of Lyndon words.\<close>

definition Lyndon_mono :: "'a list list \<Rightarrow>  bool" where
  "Lyndon_mono ws \<longleftrightarrow> (\<forall> u \<in> set ws. Lyndon u) \<and> (rlex.sorted (rev ws))"

lemma Lyndon_mono_set: "Lyndon_mono ws \<Longrightarrow> u \<in> set ws \<Longrightarrow> Lyndon u"
  unfolding Lyndon_mono_def by blast

lemma Lyndon_mono_sorted: "Lyndon_mono ws \<Longrightarrow> rlex.sorted (rev ws)"
  unfolding Lyndon_mono_def by blast

lemma Lyndon_mono_nth: "Lyndon_mono ws \<Longrightarrow> i \<le> j \<Longrightarrow> j < \<^bold>|ws\<^bold>| \<Longrightarrow> ws!j \<le>lex ws!i"
  unfolding Lyndon_mono_def using  rlex.sorted_rev_nth_mono by blast

lemma Lyndon_mono_empty[simp]: "Lyndon_mono \<epsilon>"
  unfolding Lyndon_mono_def by auto

lemma Lyndon_mono_sing: "Lyndon u \<Longrightarrow> Lyndon_mono [u]"
  unfolding Lyndon_mono_def by auto

lemma Lyndon_mono_fac_Lyndon_mono:
  assumes "ps \<le>f ws" and "Lyndon_mono ws" shows "Lyndon_mono ps"
unfolding Lyndon_mono_def
proof
  show "\<forall>x \<in> (set ps). Lyndon x"
    using \<open>Lyndon_mono ws\<close>[unfolded Lyndon_mono_def] set_mono_sublist[OF \<open>ps \<le>f ws\<close>] by blast
  show "linorder.sorted (\<le>lex) (rev ps)"
    using rlex.sorted_append \<open>Lyndon_mono ws\<close>[unfolded Lyndon_mono_def] \<open>ps \<le>f ws\<close>[unfolded sublist_def] by fastforce
qed

text\<open>Lyndon factorization is monotone!
Altogether, we have shown that the Lyndon factorization is a monotone factorization
into Lyndon words.\<close>

theorem fac_Lyndon_mono: "Lyndon_mono (Lyndon_fac w)"
proof (induct "Lyndon_fac w" arbitrary: w rule: rev_induct, simp)
  case (snoc x xs)
  have "Lyndon x"
    using Lyndon_fac_set[of x, unfolded in_set_conv_decomp, of w, folded snoc.hyps(2)] by fast
  have "concat (xs \<cdot> [x]) = w"
    using Lyndon_fac_longest_dec[of w, folded snoc.hyps(2)] by auto
  then show "Lyndon_mono (LynFac w)"
  proof (cases "xs = \<epsilon>")
    assume "xs = \<epsilon>"
    show "Lyndon_mono (LynFac w)"
      unfolding Lyndon_mono_def \<open>xs \<cdot> [x] = LynFac w\<close>[symmetric] \<open>xs = \<epsilon>\<close> append.left_neutral
                rlex.sorted1[of x]
      using \<open>Lyndon x\<close> by force
  next
    assume "xs \<noteq> \<epsilon>"
    have "concat (xs \<cdot> [x]) \<noteq> \<epsilon>" and "w \<noteq> \<epsilon>"
      using Lyndon_fac_longest_dec snoc.hyps(2) by auto
    have "x = LynSuf w" and "xs = LynFac (w\<^sup><\<inverse>LynSuf w )"
      using Lyndon_fac.simps[of w, folded snoc.hyps(2)] \<open>w \<noteq> \<epsilon>\<close>
        Lyndon_fac_longest_dec append1_eq_conv[of xs x "LynFac (w\<^sup><\<inverse>LynSuf w )" "LynSuf w"] by presburger+
    from Lyndon_mono_sorted[OF snoc.hyps(1)[OF \<open>xs = LynFac (w\<^sup><\<inverse>LynSuf w )\<close>], folded this]
    have "dual_rlex.sorted  xs"
      unfolding sorted_dual_rev_iff.
    have "Lyndon (last xs)"
      using Lyndon_fac_set[of "last xs" "w\<^sup><\<inverse>LynSuf w", folded \<open>xs = LynFac (w\<^sup><\<inverse>LynSuf w)\<close>, OF last_in_set[OF \<open>xs \<noteq> \<epsilon>\<close>]].
    have "x \<le>lex last xs"
    proof(rule ccontr)
      assume "\<not> x \<le>lex last xs" hence "last xs <lex x" by auto
      from Lyndon_concat[OF  \<open>Lyndon (last xs)\<close> \<open>Lyndon x\<close> this]
      have "Lyndon ((last xs) \<cdot> x)".
      have "(last xs) \<cdot> x \<le>s concat (xs \<cdot> [x])"
        using \<open>xs \<noteq> \<epsilon>\<close> concat_last_suf by auto
      from longest_Lyndon_suf_longest[OF \<open>concat (xs \<cdot> [x]) \<noteq> \<epsilon>\<close>  this \<open>Lyndon ((last xs) \<cdot> x)\<close>,
          unfolded \<open>concat (xs \<cdot> [x]) = w\<close>, folded \<open>x = LynSuf w\<close>]
      show False
        using \<open>Lyndon (last xs)\<close> by simp
    qed
    have "dual_rlex.sorted (butlast xs \<cdot> [last xs])"
      by (simp add: \<open>linorder.sorted (\<lambda>x y. y \<le>lex x) xs\<close> \<open>xs \<noteq> \<epsilon>\<close>)
    from this \<open>x \<le>lex last xs\<close>
    have "dual_rlex.sorted (butlast xs \<cdot> [last xs,x])"
      using dual_rlex.sorted_append by auto
    from this[unfolded hd_word[of "last xs" "[x]"] lassoc append_butlast_last_id[OF \<open>xs \<noteq> \<epsilon>\<close>]]
    have "rlex.sorted (rev (LynFac w))"
      unfolding  \<open>xs \<cdot> [x] = LynFac w\<close>[symmetric] sorted_dual_rev_iff[symmetric].
    thus "Lyndon_mono (LynFac w)"
      unfolding Lyndon_mono_def using Lyndon_fac_set by blast
  qed
qed

text\<open>Now we want to show the converse: any monotone factorization into Lyndon words is the Lyndon factorization\<close>

text\<open>The last element in the Lyndon factorization is the smallest suffix.\<close>

lemma Lyndon_mono_last_smallest: "Lyndon_mono ws \<Longrightarrow>s \<le>ns (concat ws) \<Longrightarrow> last ws \<le>lex s"
proof(induct ws arbitrary: s rule: rev_induct, fastforce)
  case (snoc a ws)
  have "ws\<cdot>[a] \<noteq> \<epsilon>"
    by blast
  have "last (ws\<cdot>[a]) = a"
    by simp
  from last_in_set[OF \<open>ws\<cdot>[a] \<noteq> \<epsilon>\<close>, unfolded this] \<open>Lyndon_mono (ws \<cdot> [a])\<close>[unfolded Lyndon_mono_def]
  have "Lyndon a"
    by blast
  show ?case
  proof(cases "s \<le>ns a")
    case True
    from Lyndon_suf_le[OF \<open>Lyndon a\<close>] this
    show ?thesis
      by simp
  next
    case False
    hence "ws \<noteq> \<epsilon>"
      using snoc.prems(2) by force
    obtain s' where "s = s'\<cdot>a"
      using False snoc.prems(2)[unfolded concat_append[of ws "[a]", unfolded concat_sing']] suffix_append[of s "concat ws" a]
      unfolding nonempty_suffix_def
      by blast
    hence "s' \<le>ns concat ws"
      using False snoc.prems(2) by fastforce
    have "Lyndon_mono ws"
      using \<open>Lyndon_mono (ws\<cdot>[a])\<close> Lyndon_mono_fac_Lyndon_mono
      by blast
    from snoc.hyps[OF this \<open>s' \<le>ns concat ws\<close>]
    have "last ws \<le>lex s'"
      by auto
    hence "last ws \<le>lex s'\<cdot>a"
      using local.lexordp_eq_trans ord.lexordp_eq_pref by blast
    have "a \<le>lex last ws"
      using \<open>Lyndon_mono (ws\<cdot>[a])\<close>
      unfolding Lyndon_mono_def
      by (simp add: \<open>ws \<noteq> \<epsilon>\<close> last_ConsL)
    from dual_rlex.order_trans[OF \<open>last ws \<le>lex s' \<cdot> a\<close> this, folded \<open>s = s' \<cdot> a\<close>]
    show ?thesis
      unfolding \<open>last (ws\<cdot>[a]) = a\<close>
      by blast
  qed
qed

text\<open>A monotone list, if seen as a factorization,
must end with the longest suffix\<close>

lemma Lyndon_mono_last_longest: assumes "ws \<noteq> \<epsilon>" and "Lyndon_mono ws"
  shows "LynSuf (concat ws) = last ws"
proof-
  have "Lyndon (last ws)"
    using Lyndon_mono_set assms(1) assms(2) last_in_set by blast
  hence "last ws \<noteq> \<epsilon>"
    using LyndonD_nemp by blast
  hence "last ws \<le>ns LynSuf (concat ws)"
    using longest_Lyndon_suf_max[OF  concat_last_suf[OF assms(1)] \<open>Lyndon (last ws)\<close>]
    unfolding nonempty_suffix_def
    by blast

  have "concat ws \<noteq> \<epsilon>"
    using Lyndon.simps assms(2)[unfolded Lyndon_mono_def] set_nemp_concat_nemp[OF assms(1)]
    by blast
  from longest_Lyndon_suf_nemp[OF this] longest_Lyndon_suf_suf[OF this]
  have "LynSuf (concat ws) \<le>ns concat ws"
    unfolding nonempty_suffix_def
    by simp

  show ?thesis
    using Lyndon_mono_last_smallest[OF \<open>Lyndon_mono ws\<close> \<open>LynSuf (concat ws) \<le>ns concat ws\<close>]
      Lyndon_suf_le[OF longest_Lyndon_suf_Lyndon[OF \<open>concat ws \<noteq> \<epsilon>\<close>], OF \<open>last ws \<le>ns LynSuf (concat ws)\<close>]
      eq_iff
    by simp
qed

text\<open>Therefore, by construction,
any monotone list is the Lyndon factorization of its concatenation\<close>

lemma Lyndon_mono_fac:
  "Lyndon_mono ws \<Longrightarrow> ws = Lyndon_fac (concat ws)"
proof (induct ws rule: rev_induct, simp)
  case (snoc x xs)
  have "Lyndon_mono xs"
    using \<open>Lyndon_mono (xs \<cdot> [x])\<close>
    unfolding Lyndon_mono_def
    by simp
  from snoc.hyps[OF this]
  have "xs = LynFac (concat xs)".
  have "x = LynSuf (concat (xs \<cdot> [x]))"
    using Lyndon_mono_last_longest[OF _ \<open>Lyndon_mono (xs \<cdot> [x])\<close>, unfolded last_snoc] by simp
  have "concat (xs \<cdot> [x])\<^sup><\<inverse>x = concat xs"
    by simp
  have "concat (xs \<cdot> [x]) \<noteq> \<epsilon>"
    using Lyndon_mono_set snoc.prems by auto
  from this
  show ?case
    using Lyndon_fac.simps[of "concat (xs \<cdot> [x])", folded \<open>x = LynSuf (concat (xs \<cdot> [x]))\<close>,
        unfolded \<open>concat (xs \<cdot> [x])\<^sup><\<inverse>x = concat xs\<close>, folded \<open>xs = LynFac (concat xs)\<close>]
    by presburger
qed

text\<open>This implies that the Lyndon factorization can be characterized
in two equivalent ways: as the (unique) monotone factorization (into Lyndon words) or as
the "suffix greedy" factorization (into Lyndon words).
\<close>

corollary Lyndon_mono_fac_iff: "Lyndon_mono ws \<longleftrightarrow> ws = LynFac (concat ws)"
  using Lyndon_mono_fac fac_Lyndon_mono[of "concat ws"] by fastforce

corollary Lyndon_mono_unique: assumes "Lyndon_mono ws" and "Lyndon_mono zs" and "concat ws = concat zs"
  shows "ws = zs"
  using Lyndon_mono_fac[OF \<open>Lyndon_mono ws\<close>] Lyndon_mono_fac[OF \<open>Lyndon_mono zs\<close>]
  unfolding \<open>concat ws = concat zs\<close>  by simp

subsection "Standard factorization"

lemma Lyndon_std: assumes "Lyndon w" "1 < \<^bold>|w\<^bold>|"
  obtains l m where "w = l\<cdot>m" and "Lyndon l" and "Lyndon m" and "l <lex m"
proof-
  have "w \<noteq> \<epsilon>" "tl w \<noteq> \<epsilon>"
    using \<open>1 < \<^bold>|w\<^bold>|\<close> long_list_tl by auto
  define m where  "m = LynSuf (tl w)"
  hence "Lyndon m"
    using \<open>tl w \<noteq> \<epsilon>\<close> local.longest_Lyndon_suf_Lyndon by blast
  have "m \<le>s w"
    unfolding m_def
    using suffix_order.trans[OF longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] suffix_tl[of w]].
  moreover have "m \<noteq> w"
    unfolding m_def using  hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>] longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] same_suffix_nil
    not_Cons_self2 by metis
  ultimately obtain l where "w = l\<cdot>m" and "l \<noteq> \<epsilon>"
   by (auto simp add: suf_def)

  have "Lyndon l"
  proof (rule unbordered_pref_Lyndon[OF \<open>Lyndon w\<close>[unfolded \<open>w = l\<cdot>m\<close>] \<open>l \<noteq> \<epsilon>\<close>], rule)
    assume "bordered l"
    from unbordered_border[OF this, unfolded border_def]
    obtain s where "s \<noteq> \<epsilon>" and "s \<noteq> l" and "s \<le>p l" and "s \<le>s l" and "\<not> bordered s"
      by blast
    have "Lyndon s"
      using unbordered_pref_Lyndon[OF _ \<open>s \<noteq> \<epsilon>\<close> \<open>\<not> bordered s\<close>, of "s\<inverse>\<^sup>>l\<cdot>m", unfolded lassoc lq_pref[OF \<open>s \<le>p l\<close>]]
      \<open>Lyndon w\<close>[unfolded \<open>w = l \<cdot> m\<close>] by blast
    have "s <lex m"
      using Lyndon_pref_suf_less[OF \<open>Lyndon w\<close> _ nsI[OF LyndonD_nemp[OF \<open>Lyndon m\<close>] \<open>m \<le>s w\<close>]
         \<open>m \<noteq> w\<close>, of s] Lyndon.elims(2)[OF \<open>Lyndon m\<close>]
         \<open>s \<le>p l\<close> prefix_append[of s l m, folded \<open>w = l \<cdot> m\<close>]
      by presburger
    from Lyndon_concat[OF \<open>Lyndon s\<close> \<open>Lyndon m\<close> this]
    have "Lyndon (s\<cdot>m)".
    moreover have "s\<cdot>m \<le>s tl w"
      unfolding \<open>w = l \<cdot> m\<close> using \<open>s \<noteq> l\<close> \<open>s \<le>s l\<close> list.collapse[OF \<open>w \<noteq> \<epsilon>\<close>, unfolded \<open>w = l \<cdot> m\<close>]
      by (auto simp add: suf_def)
    ultimately show False
      using m_def \<open>s \<noteq> \<epsilon>\<close> longest_Lyndon_suf_max same_suffix_nil by blast
  qed

  have "l <lex m"
    using Lyndon_pref_suf_less[OF \<open>Lyndon w\<close> prefI[OF \<open>w = l \<cdot> m\<close>[symmetric]]
        nsI[OF longest_Lyndon_suf_nemp[OF \<open>tl w \<noteq> \<epsilon>\<close>, folded  m_def] \<open>m \<le>s w\<close>] \<open>m \<noteq> w\<close>].
  from that[OF \<open>w = l \<cdot> m\<close> \<open>Lyndon l\<close>  \<open>Lyndon m\<close> this]
  show thesis.
qed

corollary Lyndon_std_iff:
  "Lyndon w \<longleftrightarrow> (\<^bold>|w\<^bold>| = 1 \<or> (\<exists> l m. w = l\<cdot>m \<and> Lyndon l \<and> Lyndon m \<and> l <lex m))"
  (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  show ?R
    using Lyndon_std[OF \<open>Lyndon w\<close>]
      nemp_le_len[OF LyndonD_nemp[OF \<open>Lyndon w\<close>], unfolded le_eq_less_or_eq]
    by metis
next
  assume ?R
  thus ?L
  proof(rule disjE, fastforce)
    show \<open>\<exists>l m. w = l \<cdot> m \<and> Lyndon l \<and> Lyndon m \<and> l <lex m \<Longrightarrow> Lyndon w\<close>
      using Lyndon_concat by blast
  qed
qed

end  \<comment> \<open>end context linorder\<close>

end


theory Tacticals imports Main begin

text{*REPEAT*}
lemma "\<lbrakk>P\<longrightarrow>Q; Q\<longrightarrow>R; R\<longrightarrow>S; P\<rbrakk> \<Longrightarrow> S"
apply (drule mp, assumption)
apply (drule mp, assumption)
apply (drule mp, assumption)
apply (assumption)
done

lemma "\<lbrakk>P\<longrightarrow>Q; Q\<longrightarrow>R; R\<longrightarrow>S; P\<rbrakk> \<Longrightarrow> S"
by (drule mp, assumption)+

text{*ORELSE with REPEAT*}
lemma "\<lbrakk>Q\<longrightarrow>R; P\<longrightarrow>Q; x<5\<longrightarrow>P;  Suc x < 5\<rbrakk> \<Longrightarrow> R"
by (drule mp, (assumption|arith))+

text{*exercise: what's going on here?*}
lemma "\<lbrakk>P\<and>Q\<longrightarrow>R; P\<longrightarrow>Q; P\<rbrakk> \<Longrightarrow> R"
by (drule mp, (intro conjI)?, assumption+)+

text{*defer and prefer*}

lemma "hard \<and> (P \<or> ~P) \<and> (Q\<longrightarrow>Q)"
apply (intro conjI)   --{* @{subgoals[display,indent=0,margin=65]} *}
defer 1   --{* @{subgoals[display,indent=0,margin=65]} *}
apply blast+   --{* @{subgoals[display,indent=0,margin=65]} *}
oops

lemma "ok1 \<and> ok2 \<and> doubtful"
apply (intro conjI)   --{* @{subgoals[display,indent=0,margin=65]} *}
prefer 3   --{* @{subgoals[display,indent=0,margin=65]} *}
oops

lemma "bigsubgoal1 \<and> bigsubgoal2 \<and> bigsubgoal3 \<and> bigsubgoal4 \<and> bigsubgoal5 \<and> bigsubgoal6"
apply (intro conjI)   --{* @{subgoals[display,indent=0,margin=65]} *}
txt{* @{subgoals[display,indent=0,margin=65]}
A total of 6 subgoals...
*}
oops

(*needed??*)

lemma "(P\<or>Q) \<and> (R\<or>S) \<Longrightarrow> PP"
apply (elim conjE disjE)
oops

lemma "((P\<or>Q) \<and> R) \<and> (Q \<and> (P\<or>S)) \<Longrightarrow> PP"
apply (elim conjE)
oops

lemma "((P\<or>Q) \<and> R) \<and> (Q \<and> (P\<or>S)) \<Longrightarrow> PP"
apply (erule conjE)+
oops

end


theory Concrete_Semantics_7_Ex
  imports Main "~~/src/HOL/IMP/Com" "HOL-IMP.Big_Step" "HOL-IMP.Small_Step"
begin

(* Exercise 7.1. *)

fun assigned :: "com \<Rightarrow> vname set" where
"assigned SKIP = {}" |
"assigned (v ::= va) = {v}"|
"assigned (v;; va) = assigned v \<union> assigned va " |
"assigned (IF v THEN va ELSE vb) = assigned va \<union> assigned vb" |
"assigned (WHILE v DO va) = assigned va"

lemma "\<lbrakk>(c, s) \<Rightarrow> t; x \<notin> assigned c\<rbrakk> \<Longrightarrow> s x = t x"
proof(induction rule:big_step_induct)
  case (Skip s)
  then show ?case
    by simp
next
  case (Assign x a s)
  then show ?case
    by simp
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case
    by simp
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then show ?case by simp
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then show ?case by simp
next
  case (WhileFalse b s c)
  then show ?case by simp
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case by simp
qed

(* Exercise 7.2. *)
fun skip :: "com \<Rightarrow> bool" where
"skip SKIP = True" |
"skip (v ::= va) = False" |
"skip (v;; va) = (skip v \<and> skip va)" |
"skip (IF v THEN va ELSE vb) = (skip va \<and> skip vb)" |
"skip (WHILE v DO va) = False"

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
proof(induction c)
case SKIP
  then show ?case
    by simp
next
  case (Assign x1 x2)
  then show ?case by simp
next
  case (Seq c1 c2)
  then show ?case
    by fastforce
next
  case (If x1 c1 c2)
  then show ?case
    by (meson Big_Step.IfE big_step.IfFalse big_step.IfTrue skip.simps(4))
next
  case (While x1 c)
  then show ?case
    by simp
qed

(* Exercise 7.3. *)
fun deskip :: "com \<Rightarrow> com" where
"deskip SKIP = SKIP" |
(* b is aexp so not to do deskip*)
"deskip (a ::= b) = a ::= b" |
"deskip (a;; b) = (if deskip a = SKIP then deskip b else
  (if deskip b = SKIP then deskip a
    else deskip a;; deskip b))" |
"deskip (IF a THEN b ELSE c) = IF a THEN deskip b ELSE deskip c" |
"deskip (WHILE a DO b) = WHILE a DO deskip b"

value "deskip (SKIP;; WHILE b DO (x ::= a;; SKIP))"

lemma "deskip c \<sim> c"
proof(induction c)
case SKIP
  then show ?case by simp
next
  case (Assign x1 x2)
  then show ?case by simp
next
  case (Seq c1 c2)
  then have "(c1 ;; c2) \<sim> (deskip c1;; deskip c2)"
    by blast
  moreover have " deskip (c1;; c2) \<sim> (deskip c1;; deskip c2)"
    by auto
(* deskip (c1;; c2) \sim (deskip c1;; deskip c2) \sim (c1;; c2) *)
  ultimately show ?case by auto
next
  case (If x1 c1 c2)
  then show ?case
    by auto
next
  case (While x1 c)

  then show ?case
    using sim_while_cong by auto
qed

inductive astep :: "aexp * state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"(V x , s) \<leadsto>  N (s x )" |
"(Plus (N i) (N j ), s) \<leadsto> N (i + j )" |
"(x2, s) \<leadsto> a2 \<Longrightarrow> (Plus x1 x2, s) \<leadsto> Plus x1 a2" |
"(x1, s) \<leadsto> a1 \<Longrightarrow> (Plus x1 (N j), s) \<leadsto> Plus a1 (N j)"

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep.induct[split_format(complete)])
  fix x s
  show "aval (V x) s = aval (N (s x)) s"
    by simp

  fix i j s
  show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s"
    by simp

  fix x2 s a2 x1
  assume "aval x2 s = aval a2 s"
  then show "aval (Plus x1 x2) s = aval (Plus x1 a2) s"
    by simp

  fix x1 s a1 j
  assume "aval x1 s = aval a1 s"
  then show "aval (Plus x1 (N j)) s = aval (Plus a1 (N j)) s"
    by simp
qed

lemma "IF And b1 b2 THEN c1 ELSE c2 \<sim>
IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"(is "?left \<sim> ?right")
proof -
  have "(?left,s) \<Rightarrow> t \<Longrightarrow> (?right, s) \<Rightarrow> t"  for s t
  proof -
    assume "(?left, s) \<Rightarrow> t"
    show "(?right, s) \<Rightarrow> t"
      using IfTrue \<open>(IF And b1 b2 THEN c1 ELSE c2, s) \<Rightarrow> t\<close> by fastforce
  qed
  moreover have "(?right, s) \<Rightarrow> t \<Longrightarrow> (?left,s) \<Rightarrow> t"  for s t
  proof -
    assume "(?right, s) \<Rightarrow> t"
    show "(?left, s) \<Rightarrow> t"
      using \<open>(IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2, s) \<Rightarrow> t\<close> by auto
  qed
  ultimately show ?thesis
    by blast
qed

(* obviously false*)

(*
  then show False by (induction rule: big_step_induct)
Failed to finish proof\<^here>:
goal (3 subgoals):
 1. \<And>s. False
 2. \<And>x a s. False
 3. \<And>b s c. \<not> bval b s \<Longrightarrow> False

  then show False by (induction "WHILE (Bc True) DO WHILE (Bc False) DO SKIP" s s rule: big_step_induct)
Failed to finish proof\<^here>:
goal (1 subgoal):
 1. \<And>s. \<not> bval (Bc True) s \<Longrightarrow> False
 *)
lemma "\<not> (\<forall> b1 b2 c. WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c)"(is "\<not> ?p")
proof
  assume assm: ?p
  have 1: "WHILE And (Bc True) (Bc False) DO SKIP \<sim> WHILE (Bc True) DO WHILE (Bc False) DO SKIP"
    using assm by simp
  have 2: "(WHILE And (Bc True) (Bc False) DO SKIP, s) \<Rightarrow> s" by auto
  have 3: "(WHILE (Bc True) DO WHILE (Bc False) DO SKIP, s) \<Rightarrow> s"
    using "2" assm by auto
  then show False
    by (induction "WHILE (Bc True) DO WHILE (Bc False) DO SKIP" s s rule: big_step_induct, simp)
qed

lemma temination_of_while: "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> \<not> bval b t"
  apply(induction "WHILE b DO c" s t rule: big_step_induct )
   apply simp
  by simp

(*
It is easy to show there is a proof of left to right.
However, it is difficult to construct proof.
The following method is failed to calculate:
    assume assm: "(?left, s) \<Rightarrow> t"
    then show "(?left;;?q, s) \<Rightarrow> t"
      by (induction "WHILE Or b1 b2 DO c" s t rule: big_step_induct)
.
*)
lemma "WHILE Not (And (Not b1) (Not b2)) DO c \<sim> WHILE Not (And (Not b1) (Not b2)) DO c;; WHILE b1 DO c"(is "?left \<sim> ?left;;?q")
proof -
  have "(?left,s) \<Rightarrow> t \<Longrightarrow> (?left;;?q, s) \<Rightarrow> t"  for s t
  proof -
    assume assm: "(?left, s) \<Rightarrow> t"
    show "(?left;;?q, s) \<Rightarrow> t"
      using Seq WhileFalse assm temination_of_while by fastforce
  qed
  moreover have "(?left;;?q, s) \<Rightarrow> t \<Longrightarrow> (?left,s) \<Rightarrow> t"  for s t
  proof -
    assume "(?left;;?q, s) \<Rightarrow> t"
    show "(?left, s) \<Rightarrow> t"
      by (metis SeqE \<open>(WHILE bexp.Not (And (bexp.Not b1) (bexp.Not b2)) DO c;; WHILE b1 DO c, s) \<Rightarrow> t\<close> big_step_determ calculation)
  qed
  ultimately show ?thesis
    by blast
qed

(* Exercise 7.6. *)
definition Do :: "com \<Rightarrow> bexp \<Rightarrow> com" ("DO _ WHILE _"  [0, 61] 61) where
"DO c WHILE b = c ;; WHILE b DO c"

fun dewhile :: "com \<Rightarrow> com" where
"dewhile SKIP = SKIP" |
(* b is aexp so not to do deskip*)
"dewhile (a ::= b) = a ::= b" |
"dewhile (a;; b) = (dewhile a;; dewhile b)" |
"dewhile (IF a THEN b ELSE c) = IF a THEN dewhile b ELSE dewhile c" |
"dewhile (WHILE a DO b) = IF a THEN (DO dewhile b WHILE a) ELSE SKIP "

lemma "dewhile c \<sim> c"(is "?left \<sim> ?right")
proof (induction c)
  case SKIP
then show ?case
  by simp
next
  case (Assign x1 x2)
  then show ?case
    by simp
next
  case (Seq c1 c2)
  then show ?case
    by auto
next
  case (If x1 c1 c2)
  then show ?case
    by auto
next
  case (While x1 c)
  then show ?case
    using Do_def sim_while_cong while_unfold by auto
qed

(* Exercise 7.7. *)

lemma assumes "C 0 = c;; d"
  and "\<forall>n. (C n, S n) \<rightarrow> (C (Suc n), S (Suc n))"
  shows "(\<forall> n.  \<exists>c1 c2.
      C n = c1;; d \<and>
      C (Suc n) = c2;; d \<and> (c1, S n) \<rightarrow> (c2, S (Suc n))) \<or>
      (\<exists> k. C k = SKIP;; d)"(is "(?P) \<or> ?Q")
proof cases
  assume "?Q"
  then show ?thesis
    by simp
next
  assume "\<not> ?Q"
  {fix i
    have "\<exists>c1 c2.
        C i = c1;; d \<and>
        C (Suc i) = c2;; d \<and>
        (c1, S i) \<rightarrow> (c2, S (Suc i))"
    proof (induction i)
      case 0
      then show ?case
        by (metis Pair_inject Small_Step.SeqE \<open>\<nexists>k. C k = SKIP;; d\<close> assms(1) assms(2))
    next
      case (Suc i)
      then show ?case
        by (metis Pair_inject Small_Step.SeqE \<open>\<nexists>k. C k = SKIP;; d\<close> assms(2))
    qed}
    then have ?P
      by auto
  then show ?thesis by simp
qed

(*

  assume "\<not> ?P"
  then obtain n where
    "\<forall> c1 c2. C n \<noteq> c1;; d \<or>
    C (Suc n) \<noteq> c2;; d \<or>
    \<not> ((c1, S n) \<rightarrow> (c2, S (Suc n)))"
    by auto

To show ?thesis, I want the case
- "c2 = SKIP" and
- "C (Suc n) = c2;; d"
, so, it is needed to show that
- "C n \<noteq> c1;; d"
? ? ? ?
CRAZY.
REMIND.
*)

end


(*  Title:      HOL/MicroJava/BV/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Products as semilattices.
*)

section \<open> Products as Semilattices \<close>

theory Product
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a \<times> 'b) ord"
where
  "le r\<^sub>A r\<^sub>B = (\<lambda>(a\<^sub>1,b\<^sub>1) (a\<^sub>2,b\<^sub>2). a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 \<and> b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"

definition sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a \<times> 'b) ebinop"
where
  "sup f g = (\<lambda>(a\<^sub>1,b\<^sub>1)(a\<^sub>2,b\<^sub>2). Err.sup Pair (a\<^sub>1 \<squnion>\<^sub>f a\<^sub>2) (b\<^sub>1 \<squnion>\<^sub>g b\<^sub>2))"

definition esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a \<times> 'b ) esl"
where
  "esl = (\<lambda>(A,r\<^sub>A,f\<^sub>A) (B,r\<^sub>B,f\<^sub>B). (A \<times> B, le r\<^sub>A r\<^sub>B, sup f\<^sub>A f\<^sub>B))"

abbreviation
  lesubprod :: "'a \<times> 'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool"
    ("(_ /\<sqsubseteq>'(_,_') _)" [50, 0, 0, 51] 50) where
  "p \<sqsubseteq>(rA,rB) q == p \<sqsubseteq>\<^bsub>Product.le rA rB\<^esub> q"

(*<*)
notation
  lesubprod  ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
(*>*)

lemma unfold_lesub_prod: "x \<sqsubseteq>(r\<^sub>A,r\<^sub>B) y = le r\<^sub>A r\<^sub>B x y"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_prod_Pair_conv [iff]: "((a\<^sub>1,b\<^sub>1) \<sqsubseteq>(r\<^sub>A,r\<^sub>B) (a\<^sub>2,b\<^sub>2)) = (a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"
(*<*) by (simp add: lesub_def le_def) (*>*)

lemma less_prod_Pair_conv:
  "((a\<^sub>1,b\<^sub>1) \<sqsubset>\<^bsub>Product.le r\<^sub>A r\<^sub>B\<^esub> (a\<^sub>2,b\<^sub>2)) =
  (a\<^sub>1 \<sqsubset>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2 | a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubset>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"
(*<*)
apply (unfold lesssub_def)
apply simp
apply blast
done
(*>*)

lemma order_le_prod [iff]: "order(Product.le r\<^sub>A r\<^sub>B) = (order r\<^sub>A & order r\<^sub>B)"
(*<*)
apply (unfold order_def)
apply simp
apply safe
apply blast+
done
(*>*)

lemma acc_le_prodI [intro!]:
  "\<lbrakk> acc r\<^sub>A; acc r\<^sub>B \<rbrakk> \<Longrightarrow> acc(Product.le r\<^sub>A r\<^sub>B)"
(*<*)
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
(*>*)

lemma unfold_plussub_lift2: "e\<^sub>1 \<squnion>\<^bsub>lift2 f\<^esub> e\<^sub>2 = lift2 f e\<^sub>1 e\<^sub>2"
(*<*) by (simp add: plussub_def) (*>*)

lemma plus_eq_Err_conv [simp]:
  assumes "x\<in>A"  "y\<in>A"  "semilat(err A, Err.le r, lift2 f)"
  shows "(x \<squnion>\<^sub>f y = Err) = (\<not>(\<exists>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z))"
(*<*)
proof -
  have plus_le_conv2:
    "\<And>r f z. \<lbrakk> z \<in> err A; semilat (err A, r, f); OK x \<in> err A; OK y \<in> err A;
                 OK x \<squnion>\<^sub>f OK y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> OK x \<sqsubseteq>\<^sub>r z \<and> OK y \<sqsubseteq>\<^sub>r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x \<squnion>\<^sub>f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z: err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def' closed_def)
  apply simp
  done
qed
(*>*)

lemma err_semilat_Product_esl:
  "\<And>L\<^sub>1 L\<^sub>2. \<lbrakk> err_semilat L\<^sub>1; err_semilat L\<^sub>2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L\<^sub>1 L\<^sub>2)"
(*<*)
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done
(*>*)

end


(*  Title:      HOL/Library/Bit.thy
    Author:     Brian Huffman
*)

section \<open>The Field of Integers mod 2\<close>

theory Bit
imports Main
begin

subsection \<open>Bits as a datatype\<close>

typedef bit = "UNIV :: bool set"
  morphisms set Bit ..

instantiation bit :: "{zero, one}"
begin

definition zero_bit_def: "0 = Bit False"

definition one_bit_def: "1 = Bit True"

instance ..

end

old_rep_datatype "0::bit" "1::bit"
proof -
  fix P :: "bit \<Rightarrow> bool"
  fix x :: bit
  assume "P 0" and "P 1"
  then have "\<forall>b. P (Bit b)"
    unfolding zero_bit_def one_bit_def
    by (simp add: all_bool_eq)
  then show "P x"
    by (induct x) simp
next
  show "(0::bit) \<noteq> (1::bit)"
    unfolding zero_bit_def one_bit_def
    by (simp add: Bit_inject)
qed

lemma Bit_set_eq [simp]: "Bit (set b) = b"
  by (fact set_inverse)

lemma set_Bit_eq [simp]: "set (Bit P) = P"
  by (rule Bit_inverse) rule

lemma bit_eq_iff: "x = y \<longleftrightarrow> (set x \<longleftrightarrow> set y)"
  by (auto simp add: set_inject)

lemma Bit_inject [simp]: "Bit P = Bit Q \<longleftrightarrow> (P \<longleftrightarrow> Q)"
  by (auto simp add: Bit_inject)

lemma set [iff]:
  "\<not> set 0"
  "set 1"
  by (simp_all add: zero_bit_def one_bit_def Bit_inverse)

lemma set_iff: "set b \<longleftrightarrow> b = 1"
  by (cases b) simp_all

lemma bit_eq_iff_set:
  "b = 0 \<longleftrightarrow> \<not> set b"
  "b = 1 \<longleftrightarrow> set b"
  by (simp_all add: bit_eq_iff)

lemma Bit [simp, code]:
  "Bit False = 0"
  "Bit True = 1"
  by (simp_all add: zero_bit_def one_bit_def)

lemma bit_not_0_iff [iff]: "x \<noteq> 0 \<longleftrightarrow> x = 1" for x :: bit
  by (simp add: bit_eq_iff)

lemma bit_not_1_iff [iff]: "x \<noteq> 1 \<longleftrightarrow> x = 0" for x :: bit
  by (simp add: bit_eq_iff)

lemma [code]:
  "HOL.equal 0 b \<longleftrightarrow> \<not> set b"
  "HOL.equal 1 b \<longleftrightarrow> set b"
  by (simp_all add: equal set_iff)

subsection \<open>Type @{typ bit} forms a field\<close>

instantiation bit :: field
begin

definition plus_bit_def: "x + y = case_bit y (case_bit 1 0 y) x"

definition times_bit_def: "x * y = case_bit 0 y x"

definition uminus_bit_def [simp]: "- x = x" for x :: bit

definition minus_bit_def [simp]: "x - y = x + y" for x y :: bit

definition inverse_bit_def [simp]: "inverse x = x" for x :: bit

definition divide_bit_def [simp]: "x div y = x * y" for x y :: bit

lemmas field_bit_defs =
  plus_bit_def times_bit_def minus_bit_def uminus_bit_def
  divide_bit_def inverse_bit_def

instance
  by standard (auto simp: field_bit_defs split: bit.split)

end

lemma bit_add_self: "x + x = 0" for x :: bit
  unfolding plus_bit_def by (simp split: bit.split)

lemma bit_mult_eq_1_iff [simp]: "x * y = 1 \<longleftrightarrow> x = 1 \<and> y = 1" for x y :: bit
  unfolding times_bit_def by (simp split: bit.split)

text \<open>Not sure whether the next two should be simp rules.\<close>

lemma bit_add_eq_0_iff: "x + y = 0 \<longleftrightarrow> x = y" for x y :: bit
  unfolding plus_bit_def by (simp split: bit.split)

lemma bit_add_eq_1_iff: "x + y = 1 \<longleftrightarrow> x \<noteq> y" for x y :: bit
  unfolding plus_bit_def by (simp split: bit.split)

subsection \<open>Numerals at type @{typ bit}\<close>

text \<open>All numerals reduce to either 0 or 1.\<close>

lemma bit_minus1 [simp]: "- 1 = (1 :: bit)"
  by (simp only: uminus_bit_def)

lemma bit_neg_numeral [simp]: "(- numeral w :: bit) = numeral w"
  by (simp only: uminus_bit_def)

lemma bit_numeral_even [simp]: "numeral (Num.Bit0 w) = (0 :: bit)"
  by (simp only: numeral_Bit0 bit_add_self)

lemma bit_numeral_odd [simp]: "numeral (Num.Bit1 w) = (1 :: bit)"
  by (simp only: numeral_Bit1 bit_add_self add_0_left)

subsection \<open>Conversion from @{typ bit}\<close>

context zero_neq_one
begin

definition of_bit :: "bit \<Rightarrow> 'a"
  where "of_bit b = case_bit 0 1 b"

lemma of_bit_eq [simp, code]:
  "of_bit 0 = 0"
  "of_bit 1 = 1"
  by (simp_all add: of_bit_def)

lemma of_bit_eq_iff: "of_bit x = of_bit y \<longleftrightarrow> x = y"
  by (cases x) (cases y; simp)+

end

lemma (in semiring_1) of_nat_of_bit_eq: "of_nat (of_bit b) = of_bit b"
  by (cases b) simp_all

lemma (in ring_1) of_int_of_bit_eq: "of_int (of_bit b) = of_bit b"
  by (cases b) simp_all

hide_const (open) set

end


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

  Auxiliary lemmas that should be merged into HOL.
*)
section \<open>Auxiliary lemmas\<close>

theory Landau_Library
imports Complex_Main
begin

subsection \<open>Filters\<close>

lemma eventually_at_top_compose:
  assumes "\<And>c. eventually (\<lambda>x. (f x:: 'a :: linorder) \<ge> c) F" "eventually P at_top"
  shows   "eventually (\<lambda>x. P (f x)) F"
  using assms filterlim_at_top filterlim_iff by blast

lemma eventually_False_at_top_linorder [simp]:
  "eventually (\<lambda>_::_::linorder. False) at_top \<longleftrightarrow> False"
  unfolding eventually_at_top_linorder by force

lemma eventually_not_equal: "eventually (\<lambda>x::'a::linordered_semidom. x \<noteq> a) at_top"
  using eventually_ge_at_top[of "a+1"] by eventually_elim (insert less_add_one[of a], auto)

lemma eventually_subst':
  "eventually (\<lambda>x. f x = g x) F \<Longrightarrow> eventually (\<lambda>x. P x (f x)) F = eventually (\<lambda>x. P x (g x)) F"
  by (rule eventually_subst, erule eventually_rev_mp) simp

lemma eventually_nat_real:
  assumes "eventually P (at_top :: real filter)"
  shows   "eventually (\<lambda>x. P (real x)) (at_top :: nat filter)"
  using assms filterlim_real_sequentially
  unfolding filterlim_def le_filter_def eventually_filtermap by auto

lemma filterlim_cong':
  assumes "filterlim f F G"
  assumes "eventually (\<lambda>x. f x = g x) G"
  shows   "filterlim g F G"
  using assms by (subst filterlim_cong[OF refl refl, of _ f]) (auto elim: eventually_mono)

lemma eventually_ln_at_top: "eventually (\<lambda>x. P (ln x :: real)) at_top = eventually P at_top"
proof
  fix P assume "eventually (\<lambda>x. P (ln x :: real)) at_top"
  then obtain x0 where x0: "\<And>x. x \<ge> x0 \<Longrightarrow> P (ln x)"
    by (subst (asm) eventually_at_top_linorder) auto
  {
    fix x assume "x \<ge> ln (max 1 x0)"
    hence "exp x \<ge> max 1 x0" by (subst (2) exp_ln[symmetric], simp, subst exp_le_cancel_iff)
    hence "exp x \<ge> x0" by simp
    from x0[OF this] have "P x" by simp
  }
  thus "eventually P at_top" by (subst eventually_at_top_linorder) blast
next
  fix P :: "real \<Rightarrow> bool" assume  "eventually P at_top"
  then obtain x0 where x0: "\<And>x. x \<ge> x0 \<Longrightarrow> P x"
    by (subst (asm) eventually_at_top_linorder) auto
  {
    fix x assume "x \<ge> exp x0"
    hence "ln x \<ge> x0" by (subst ln_exp[symmetric], subst ln_le_cancel_iff)
                         (simp_all add: less_le_trans[OF exp_gt_zero])
    from x0[OF this] have "P (ln x)" .
  }
  thus "eventually (\<lambda>x. P (ln x)) at_top"
    by (subst eventually_at_top_linorder) blast
qed

lemma filtermap_ln_at_top: "filtermap (ln :: real \<Rightarrow> real) at_top = at_top"
  by (simp add: filter_eq_iff eventually_filtermap eventually_ln_at_top)

lemma eventually_ln_not_equal: "eventually (\<lambda>x::real. ln x \<noteq> a) at_top"
  by (subst eventually_ln_at_top) (rule eventually_not_equal)

subsection \<open>Miscellaneous\<close>

lemma ln_mono: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x \<le> y \<Longrightarrow> ln (x::real) \<le> ln y"
  by (subst ln_le_cancel_iff) simp_all

lemma ln_mono_strict: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x < y \<Longrightarrow> ln (x::real) < ln y"
  by (subst ln_less_cancel_iff) simp_all

lemma prod_list_pos: "(\<And>x::_::linordered_semidom. x \<in> set xs \<Longrightarrow> x > 0) \<Longrightarrow> prod_list xs > 0"
  by (induction xs) auto

lemma (in monoid_mult) fold_plus_prod_list_rev:
  "fold times xs = times (prod_list (rev xs))"
proof
  fix x
  have "fold times xs x = prod_list (rev xs @ [x])"
    by (simp add: foldr_conv_fold prod_list.eq_foldr)
  also have "\<dots> = prod_list (rev xs) * x"
    by simp
  finally show "fold times xs x = prod_list (rev xs) * x" .
qed

subsection \<open>Real powers\<close>

lemma powr_realpow_eventually:
  assumes "filterlim f at_top F"
  shows   "eventually (\<lambda>x. f x powr (real n) = f x ^ n) F"
proof-
  from assms have "eventually (\<lambda>x. f x > 0) F" using filterlim_at_top_dense by blast
  thus ?thesis by eventually_elim (simp add: powr_realpow)
qed

lemma zero_powr [simp]: "(0::real) powr x = 0"
  unfolding powr_def by simp

lemma inverse_powr [simp]:
  assumes "(x::real) \<ge> 0"
  shows   "inverse x powr y = inverse (x powr y)"
proof (cases "x > 0")
  assume x: "x > 0"
  from x have "inverse x powr y = exp (y * ln (inverse x))" by (simp add: powr_def)
  also have "ln (inverse x) = -ln x" by (simp add: x ln_inverse)
  also have "exp (y * -ln x) = inverse (exp (y * ln x))" by (simp add: exp_minus)
  also from x have "exp (y * ln x) = x powr y" by (simp add: powr_def)
  finally show ?thesis .
qed (insert assms, simp)

lemma powr_mono':
  assumes "(x::real) > 0" "x \<le> 1" "a \<le> b"
  shows   "x powr b \<le> x powr a"
proof-
  have "inverse x powr a \<le> inverse x powr b" using assms
    by (intro powr_mono) (simp_all add: field_simps)
  hence "inverse (x powr a) \<le> inverse (x powr b)" using assms by simp
  with assms show ?thesis by (simp add: field_simps)
qed

lemma powr_less_mono':
  assumes "(x::real) > 0" "x < 1" "a < b"
  shows   "x powr b < x powr a"
proof-
  have "inverse x powr a < inverse x powr b" using assms
    by (intro powr_less_mono) (simp_all add: field_simps)
  hence "inverse (x powr a) < inverse (x powr b)" using assms by simp
  with assms show ?thesis by (simp add: field_simps)
qed

lemma powr_lower_bound: "\<lbrakk>(l::real) > 0; l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> min (l powr z) (u powr z) \<le> x powr z"
apply (cases "z \<ge> 0")
apply (rule order.trans[OF min.cobounded1 powr_mono2], simp_all) []
apply (rule order.trans[OF min.cobounded2 powr_mono2'], simp_all) []
done

lemma powr_upper_bound: "\<lbrakk>(l::real) > 0; l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> max (l powr z) (u powr z) \<ge> x powr z"
apply (cases "z \<ge> 0")
apply (rule order.trans[OF powr_mono2 max.cobounded2], simp_all) []
apply (rule order.trans[OF powr_mono2' max.cobounded1], simp_all) []
done

lemma powr_eventually_exp_ln: "eventually (\<lambda>x. (x::real) powr p = exp (p * ln x)) at_top"
  using eventually_gt_at_top[of "0::real"] unfolding powr_def by eventually_elim simp_all

lemma powr_eventually_exp_ln':
  assumes "x > 0"
  shows   "eventually (\<lambda>x. (x::real) powr p = exp (p * ln x)) (nhds x)"
proof-
  let ?A = "{(0::real)<..}"
  from assms have "eventually (\<lambda>x. x > 0) (nhds x)" unfolding eventually_nhds
    by (intro exI[of _ "{(0::real)<..}"]) simp_all
  thus ?thesis by eventually_elim (simp add: powr_def)
qed

lemma powr_at_top:
  assumes "(p::real) > 0"
  shows   "filterlim (\<lambda>x. x powr p) at_top at_top"
proof-
  have "LIM x at_top. exp (p * ln x) :> at_top"
    by (rule filterlim_compose[OF exp_at_top filterlim_tendsto_pos_mult_at_top[OF tendsto_const]])
       (simp_all add: ln_at_top assms)
  thus ?thesis by (subst filterlim_cong[OF refl refl powr_eventually_exp_ln])
qed

lemma powr_at_top_neg:
  assumes "(a::real) > 0" "a < 1"
  shows   "((\<lambda>x. a powr x) \<longlongrightarrow> 0) at_top"
proof-
  from assms have "LIM x at_top. ln (inverse a) * x :> at_top"
    by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const])
       (simp_all add: filterlim_ident field_simps)
  with assms have "LIM x at_top. ln a * x :> at_bot"
    by (subst filterlim_uminus_at_bot) (simp add: ln_inverse)
  hence "((\<lambda>x. exp (x * ln a)) \<longlongrightarrow> 0) at_top"
    by (intro filterlim_compose[OF exp_at_bot]) (simp_all add: mult.commute)
  with assms show ?thesis unfolding powr_def by simp
qed

lemma powr_at_bot:
  assumes "(a::real) > 1"
  shows   "((\<lambda>x. a powr x) \<longlongrightarrow> 0) at_bot"
proof-
  from assms have "filterlim (\<lambda>x. ln a * x) at_bot at_bot"
    by (intro filterlim_tendsto_pos_mult_at_bot[OF tendsto_const _ filterlim_ident]) auto
  hence "((\<lambda>x. exp (x * ln a)) \<longlongrightarrow> 0) at_bot"
    by (intro filterlim_compose[OF exp_at_bot]) (simp add: algebra_simps)
  thus ?thesis using assms unfolding powr_def by simp
qed

lemma powr_at_bot_neg:
  assumes "(a::real) > 0" "a < 1"
  shows   "filterlim (\<lambda>x. a powr x) at_top at_bot"
proof-
  from assms have "LIM x at_bot. ln (inverse a) * -x :> at_top"
    by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const] filterlim_uminus_at_top_at_bot)
       (simp_all add: ln_inverse)
  with assms have "LIM x at_bot. x * ln a :> at_top"
    by (subst (asm) ln_inverse) (simp_all add: mult.commute)
  hence "LIM x at_bot. exp (x * ln a) :> at_top"
    by (intro filterlim_compose[OF exp_at_top]) simp
  thus ?thesis using assms unfolding powr_def by simp
qed

lemma DERIV_powr:
  assumes "x > 0"
  shows   "((\<lambda>x. x powr p) has_real_derivative p * x powr (p - 1)) (at x)"
proof-
  have "((\<lambda>x. exp (p * ln x)) has_real_derivative
         exp (p * ln x) * (p * inverse x)) (at x)"
    unfolding powr_def by (intro DERIV_fun_exp DERIV_cmult DERIV_ln) fact
  also have "exp (p * ln x) * (p * inverse x) = p * x powr (p - 1)"
    unfolding powr_def by (simp add: field_simps exp_diff assms)
  finally show ?thesis using assms by (subst DERIV_cong_ev[OF refl powr_eventually_exp_ln' refl])
qed

end


theory LFUs
  imports "../TBA/derivative_algebra" "../conditions/conditions_complement"
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Logics of Formal Undeterminedness (LFUs)\<close>
(**The LFUs @{cite LFU} are a family of paracomplete logics featuring a 'determinedness' operator @{text "\<^bold>\<circ>"}
that can be used to recover some classical properties of negation (in particular TND).
LFUs behave in a sense dually to LFIs. Both can be semantically embedded as extensions of Boolean algebras.
Here we show how to semantically embed LFUs as derivative algebras.*)

(**(We rename (classical) meta-logical negation to avoid terminological confusion)*)
abbreviation cneg::"bool\<Rightarrow>bool" ("\<sim>_" [40]40) where "\<sim>\<phi> \<equiv> \<not>\<phi>"

(**Logical validity can be defined as truth in all worlds/points (i.e. as denoting the top element)*)
abbreviation gtrue::"\<sigma>\<Rightarrow>bool" ("[\<^bold>\<turnstile> _]") where  "[\<^bold>\<turnstile>  A] \<equiv> \<forall>w. A w"
lemma gtrue_def: "[\<^bold>\<turnstile> A] \<equiv> A \<^bold>\<approx> \<^bold>\<top>"  by (simp add: top_def)

(**As for LFIs, we focus on the local (truth-degree preserving) notion of logical consequence.*)
abbreviation conseq_local1::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_ \<^bold>\<turnstile> _]") where "[A \<^bold>\<turnstile> B] \<equiv> A \<^bold>\<preceq> B"
abbreviation conseq_local2::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_,_ \<^bold>\<turnstile> _]") where "[A\<^sub>1, A\<^sub>2 \<^bold>\<turnstile> B] \<equiv> A\<^sub>1 \<^bold>\<and> A\<^sub>2 \<^bold>\<preceq> B"
abbreviation conseq_local12::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_ \<^bold>\<turnstile> _,_]") where "[A \<^bold>\<turnstile> B\<^sub>1, B\<^sub>2] \<equiv> A \<^bold>\<preceq> B\<^sub>1 \<^bold>\<or> B\<^sub>2"
(*add more as the need arises...*)

(**For LFUs we use the interior-based negation previously defined (taking derivative as primitive). *)
definition ineg::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>")  where  "\<^bold>\<not>A \<equiv> \<I>(\<^bold>\<midarrow>A)"
declare ineg_def[conn]

(**In terms of the derivative operator the negation looks as follows:*)
lemma ineg_prop: "\<^bold>\<not>A \<^bold>\<approx> \<^bold>\<midarrow>(\<D> A) \<^bold>\<leftharpoonup> A" using Cl_der_def IB_rel Int_br_def eq_ext' pB4 conn by fastforce

(**This negation is of course paracomplete.*)
lemma "[\<^bold>\<turnstile> a \<^bold>\<or> \<^bold>\<not>a]" nitpick oops (*countermodel*)

(**We define two pairs of in/determinedness operators and show how they relate to each other.*)
abbreviation op_det::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circ>_" [57]58) where "\<^bold>\<circ>A  \<equiv> \<B>\<^sup>d A"
abbreviation op_ind::"\<sigma>\<Rightarrow>\<sigma>" ("\<bullet>_" [57]58) where "\<bullet>A  \<equiv> \<^bold>\<midarrow>\<^bold>\<circ>A"

lemma op_det_def: "\<^bold>\<circ>a \<^bold>\<approx> a \<^bold>\<or> \<^bold>\<not>a" by (simp add: compl_def diff_def dual_def ineg_def join_def pB1)
lemma Prop1: "\<^bold>\<circ>A \<^bold>\<approx> \<C>\<^sup>f\<^sup>p A" by (metis dimp_def eq_ext' fp3)
lemma Prop2: "Op A \<longleftrightarrow> \<^bold>\<circ>\<^bold>\<midarrow>A \<^bold>\<approx> \<^bold>\<top>" by (metis dual_def dual_symm pB1 pI1 top_def compl_def diff_def)
lemma Prop3: "Op A \<longleftrightarrow> \<bullet>\<^bold>\<midarrow>A \<^bold>\<approx> \<^bold>\<bottom>" by (metis Op_Bzero dual_def dual_symm)
lemma Prop4: "Cl A \<longleftrightarrow> \<^bold>\<circ>A \<^bold>\<approx> \<^bold>\<top>" by (metis Prop1 dimp_def top_def)
lemma Prop5: "Cl A \<longleftrightarrow> \<bullet>A \<^bold>\<approx> \<^bold>\<bottom>" by (simp add: Prop4 bottom_def compl_def top_def)

(**Analogously as for LFIs, LFUs provide means for recovering the principle of excluded middle.*)
lemma "[\<Gamma> \<^bold>\<turnstile> \<bullet>a, a \<^bold>\<or> \<^bold>\<not>a]" using IB_rel Int_br_def compl_def diff_def dual_def eq_ext' ineg_def join_def by fastforce
lemma "[\<Gamma>, \<^bold>\<circ>a \<^bold>\<turnstile> a \<^bold>\<or> \<^bold>\<not>a]" using dual_def pB1 unfolding conn by auto

lemma "TNDm(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "ECQ(\<^bold>\<not>)" by (simp add: ECQ_def bottom_def diff_def ineg_prop meet_def)
lemma "Der_3 \<D> \<Longrightarrow> LNC(\<^bold>\<not>)" using ineg_prop ECQ_def ID3 LNC_def dNOR_def unfolding conn by auto
lemma "\<DD> \<D> \<Longrightarrow> DNI(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> DNE(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "Der_1b \<D> \<Longrightarrow> CoPw(\<^bold>\<not>)" by (smt CoPw_def MONO_ADDIb PD1 compl_def ineg_def monI)
lemma "\<DD> \<D> \<Longrightarrow> CoP1(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> CoP2(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> CoP3(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> DM3(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "Der_1a \<D> \<Longrightarrow> DM4(\<^bold>\<not>)" unfolding Defs using ADDI_a_def ineg_prop compl_def diff_def  join_def meet_def by auto
lemma "Der_3 \<D> \<Longrightarrow> nNor(\<^bold>\<not>)" by (simp add: NOR_def ineg_prop nNor_def bottom_def compl_def diff_def top_def)
lemma "nDNor(\<^bold>\<not>)" by (simp add: bottom_def diff_def ineg_prop nDNor_def top_def)
lemma "Der_1b \<D> \<Longrightarrow> MT0(\<^bold>\<not>)" unfolding Defs by (metis (mono_tags, hide_lams) CD1b Disj_I OpCldual PD1 bottom_def compl_def ineg_def meet_def top_def)
lemma "Der_1b \<D> \<Longrightarrow> Der_3 \<D> \<Longrightarrow> MT1(\<^bold>\<not>)" unfolding Defs by (metis (full_types) NOR_def PD1 bottom_def compl_def diff_def ineg_prop top_def)
lemma "\<DD> \<D> \<Longrightarrow> MT2(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> MT3(\<^bold>\<not>)" nitpick oops (*countermodel*)

(**We show how all local contraposition variants (lCoP) can be recovered using the determinedness operator.
Observe that we can recover in the same way other (weaker) properties: CoP, MT and DNI/DNE (local \& global).*)
lemma "\<DD> \<D> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop1: "[\<^bold>\<circ>a, a \<^bold>\<rightarrow> b \<^bold>\<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop2: "[\<^bold>\<circ>a, a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile> b \<^bold>\<rightarrow> \<^bold>\<not>a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop3: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop4: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile> b \<^bold>\<rightarrow> a]" using dual_def pI1 conn by auto

(**Disjunctive syllogism (DS).*)
lemma "DS1(\<^bold>\<rightarrow>)(\<^bold>\<not>)" by (simp add: DS1_def diff_def impl_def ineg_prop join_def)
lemma "\<DD> \<D> \<Longrightarrow> DS2(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_ds2: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile> a \<^bold>\<or> b]" using pB1 dual_def conn by auto

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/Example/LFUs.thy


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


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


theory Arboles
imports Main
begin

section {* Definición del tipo de datos de árboles *}

text {* ('a arbol) es el tipo de dato de los śrboles con valores en los
  nodos. *}
datatype 'a arbol = Hoja | Nodo "'a arbol" 'a "'a arbol"

text {* El árbol
      9
     / \
   .    4
        /\
       .   .
  se define como sigue
*}
abbreviation ejArbol1 :: "int arbol"
where
  "ejArbol1 \<equiv> Nodo Hoja (9::int) (Nodo Hoja 4 Hoja)"

section {* Demostración de propiedades de árboles *}

text {* Prop.: Las hojas son distintas de los nodos. *}
lemma "Hoja \<noteq> Nodo l x r"
by simp

text {* (espejo t) es la imagen especular del árbol t. Por ejemplo,
     espejo (Nodo Hoja (9::int) (Nodo Hoja 4 Hoja))
             = Nodo (Nodo Hoja 4 Hoja) 9 Hoja
     espejo (Nodo (Nodo Hoja a Hoja) b t)
            = Nodo (espejo t) b (Nodo Hoja a Hoja)
*}
fun espejo :: "'a arbol \<Rightarrow> 'a arbol"
where
  "espejo Hoja         = Hoja"
| "espejo (Nodo i x d) = Nodo (espejo d) x (espejo i)"

value "espejo (Nodo Hoja (9::int) (Nodo Hoja 4 Hoja))"
lemma "espejo (Nodo Hoja (9::int) (Nodo Hoja 4 Hoja))
       = Nodo (Nodo Hoja 4 Hoja) 9 Hoja" by simp
value "espejo (Nodo (Nodo Hoja a Hoja) b t)"
lemma "espejo (Nodo (Nodo Hoja a Hoja) b t)
       = Nodo (espejo t) b (Nodo Hoja a Hoja)" by simp

text {* Prop.: La función espejo es idempotente. *}
lemma espejo_espejo [simp]:
  "espejo (espejo t) = t"
apply (induction t)
apply auto
done

end


header {* Example usage of the ``sturm'' method *}
(* Author: Manuel Eberl <eberlm@in.tum.de> *)
theory Sturm_Ex
imports "../Sturm"
begin

text {*
  In this section, we give a variety of statements about real polynomials that can b
  proven by the \emph{sturm} method.
*}

lemma "\<forall>x::real. x^2 + 1 \<noteq> 0" by sturm

lemma "(x::real)^2 + 1 \<noteq> 0" by sturm

lemma "(x::real) > 1 \<Longrightarrow> x^3 > 1" by sturm

lemma "\<forall>x::real. x*x \<noteq> -1" by sturm

schematic_lemma A:
  "card {x::real. -0.010831 < x \<and> x < 0.010831 \<and>
      1/120*x^5 + 1/24 * x^4 +1/6*x^3 - 49/16777216*x^2 - 17/2097152*x = 0} = ?n" by sturm

lemma "card {x::real. x^3 + x = 2*x^2 \<and> x^3 - 6*x^2 + 11*x = 6} = 1"  by sturm

lemma "mono (\<lambda>x::real. x^3)" by sturm
lemma "inj (\<lambda>x::real. x^3)" by sturm
lemma "\<forall>(x::real) y. x \<noteq> y \<longrightarrow> x^3 \<noteq> y^3" by sturm
lemma "(x::real) < y \<Longrightarrow> -(x^3) > -(y^3)" by sturm

lemma "strict_mono (\<lambda>x::real. x^7/7 - 14/5*x^5 + 3*x^4 + 49/3*x^3 - 42*x^2 + 36*x - 13)" by sturm

lemma "\<exists>x::real. -x*x + 9 - 4 > 0" by sturm
lemma "\<exists>x::real. -x*x + 9 - 4 \<ge> 0" by sturm

schematic_lemma "card {x::real. x^3 + x = 2*x^2 \<or> x^3 - 6*x^2 + 11*x = 6} = ?n" by sturm

lemma
  "card {x::real. -0.010831 < x \<and> x < 0.010831 \<and>
     poly [:0, -17/2097152, -49/16777216, 1/6, 1/24, 1/120:] x = 0} = 3"
  by sturm

lemma "\<forall>x::real. x*x \<noteq> 0 \<or> x*x - 1 \<noteq> 2*x" by sturm
lemma "\<exists>x::real. x*x - 9 = 0 \<and> x+3 = 0" by sturm

lemma "\<bar>x - 3 :: real\<bar> < 2 \<Longrightarrow> 5 + 6*x - x^2 > 0" by sturm

lemma "(x::real)*x+1 \<noteq> 0 \<and> (x^2+1)*(x^2+2) \<noteq> 0" by sturm

text {* nonstrict inequalities *}
lemma "x^6 - 4*x^5 + 7*x^4 - 12*x^3 + 12*x^2 \<ge> (0 :: real)" by sturm
lemma "-33062500 + 30187500*x - 10743125*x^2 + 1793250*x^3 - 116475*x^4 -
            3240*x^5 + 661*x^6 - 6*x^7 - x^8 \<le> (0 :: real)" by sturm
lemma "x \<ge> -0.5 \<Longrightarrow> x \<le> 1 \<Longrightarrow> x^3 - 5*x^2 + x + 3 \<ge> (0::real)" by sturm
lemma "x \<ge> (4::real) \<Longrightarrow> x^3 \<ge> 4*x^2" by sturm
lemma "x \<ge> 40 \<Longrightarrow> x \<le> 44 \<Longrightarrow> x^2 - 84*x + 1760 \<le> (0::real)" by sturm

lemma "1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x \<ge> -2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x \<le> 2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x > -2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x < 2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x \<ge> -2 \<Longrightarrow> x \<le> 2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x > -2 \<Longrightarrow> x \<le> 2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x \<ge> -2 \<Longrightarrow> x < 2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm
lemma "x > -2 \<Longrightarrow> x < 2 \<Longrightarrow> 1296 - 3528*x^2 + 3409*x^4 - 1444*x^6 + 294*x^8 - 28*x^10 + x^12 \<ge> (0 :: real)" by sturm

lemma "\<exists>x::real. 1 - x*x > 0" by sturm
lemma "\<exists>x::real \<ge> -1. 1 - x*x > 0" by sturm
lemma "\<exists>x::real > -1. 1 - x*x > 0" by sturm
lemma "\<exists>x::real < 1. 1 - x*x > 0" by sturm
lemma "\<exists>x::real \<le> 1. 1 - x*x > 0" by sturm
lemma "\<exists>x::real. x \<ge> -1 \<and> x \<le> 1 \<and> 1 - x*x > 0" by sturm
lemma "\<exists>x::real. x > -1 \<and> x \<le> 1 \<and> 1 - x*x > 0" by sturm
lemma "\<exists>x::real. x \<ge> -1 \<and> x < 1 \<and> 1 - x*x > 0" by sturm
lemma "\<exists>x::real. x > -1 \<and> x < 1 \<and> 1 - x*x > 0" by sturm
lemma "\<exists>x::real. x \<ge> 0 \<and> x \<le> 0 \<and> 1 - x*x > 0" by sturm

text{*3 examples related to continued fraction approximants to exp: LCP*}
lemma fixes x::real
shows "-7.29347719 \<le> x \<Longrightarrow> 0 < x^5 + 30*x^4 + 420*x^3 + 3360*x^2 + 15120*x + 30240"
by sturm

lemma fixes x::real
shows "0 < x^6 + 42*x^5 + 840*x^4 + 10080*x^3 + 75600*x\<^sup>2 + 332640*x + 665280"
by sturm

schematic_lemma "card {x::real. x^7 + 56*x^6 + 1512*x^5 + 25200*x^4 + 277200*x^3 + 1995840*x^2 + 8648640*x = -17297280} = ?n"
by sturm

lemma "inj_on (\<lambda>x::real. x^2) {0..1}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {0<..1}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {0..<1}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {0<..<1}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {0..}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {0<..}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {..0}" by sturm
lemma "inj_on (\<lambda>x::real. x^2) {..<0}" by sturm
lemma "inj (\<lambda>x::real. x^3)" by sturm

end


theory max
imports Main
        "../data/Natu"
        "$HIPSTER_HOME/IsaHipster"

begin

fun max2 :: "Nat => Nat => Nat" where
  "max2 Z Z = Z"
| "max2 (Z) (S y) = S y"
| "max2 (S z) (Z) = S z"
| "max2 (S z) (S x2) = S (max2 z x2)"

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

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

lemma lemma_ab [thy_expl]: "max2 x2 Z = x2"
by (hipster_induct_schemes max2.simps)

lemma lemma_ac [thy_expl]: "max2 x1 (max2 x1 y1) = max2 x1 y1"
by (hipster_induct_schemes max2.simps)

lemma lemma_ad [thy_expl]: "max2 x2 (S x2) = S x2"
by (hipster_induct_schemes max2.simps)

lemma lemma_ae [thy_expl]: "max2 (max2 x1 y1) (S x1) = max2 y1 (S x1)"
by (hipster_induct_schemes max2.simps)

end