theory MinimalHEAPLemmas
imports MinimalHEAP1
begin

text {* First we start with just one function symbol (foreground; even if with more in background).
        Next, we add some side conditiosn that are "obvious" (inferrable/knownable from context).
        Finally, we have some lemmas that don't have trivial conditions, yet QuickSpec already find them
        (without the conditions).
      *}

(*========== Map domain anti-restriction related lemmas (Zoom0) ==============*)

text {* Foreground symbol: @{text "_ -\<triangleleft> _"} *}

(******************************************************************************)
section {* These lemmas are side-condition free *}

lemma l_dom_dom_ar:
	"dom(S -\<triangleleft> f) = dom f - S"
oops

lemma l_dom_ar_accum:
	"S -\<triangleleft> (T -\<triangleleft> f) = (S \<union> T) -\<triangleleft> f"
oops

lemma l_dom_ar_empty_lhs:
  "{} -\<triangleleft> f = f"
oops

lemma l_dom_ar_empty_rhs:
  "S -\<triangleleft> empty = empty"
oops

lemma l_map_dom_ar_subset:
  "S -\<triangleleft> f \<subseteq>\<^sub>m f"
oops

lemma l_dom_ar_none:
  "{} -\<triangleleft> f = f"
oops

(******************************************************************************)
section {* These lemmas require side conditions (from known context) *}

lemma f_in_dom_ar_subsume:
  "l \<in> dom (S -\<triangleleft> f) \<Longrightarrow>  l \<in> dom f"
oops

lemma f_in_dom_ar_the_subsume:
  "l \<in> dom (S -\<triangleleft> f) \<Longrightarrow> the ((S -\<triangleleft> f) l) = the (f l)"
oops

lemma f_in_dom_ar_apply_subsume:
  "l \<in> dom (S -\<triangleleft> f) \<Longrightarrow> ((S -\<triangleleft> f) l) = (f l)"
oops

lemma f_in_dom_ar_apply_not_elem:
  "l \<notin> S \<Longrightarrow> (S -\<triangleleft> f) l = f l"
oops

lemma f_in_dom_ar_notelem:
  "l \<in> dom ({r} -\<triangleleft> f) \<Longrightarrow> l \<noteq> r"
oops

(******************************************************************************)
section {* These lemmas require some side conditions (beyond just context) *}

lemma l_dom_ar_nothing:
	"S \<inter> dom f = {} \<Longrightarrow> S -\<triangleleft> f = f"
oops

lemma l_dom_ar_everything:
  "dom f \<subseteq> S \<Longrightarrow> S -\<triangleleft> f = empty"
oops

lemma l_map_dom_ar_neq:
  "S \<subseteq> dom f \<Longrightarrow> S \<noteq> {} \<Longrightarrow> S -\<triangleleft> f \<noteq> f"
oops

(*================== Map Union Related Lemmas (Zoom1) ========================*)

text {* Foreground symbol: @{text "_ \<union>m _"}; maybe  @{text "_ -\<triangleleft> _"} *}

(******************************************************************************)
section {* These lemmas are side-condition free *}

lemma b_dagger_munion_aux:
	"dom(dom g -\<triangleleft> f) \<inter> dom g = {}"
oops

(* ++ is like haskel union for maps but prefers g for f in case of duplicates in the domain *)
lemma b_dagger_munion:
	"(f ++ g) = (dom g -\<triangleleft> f) \<union>m g"
oops

lemma l_munion_empty_rhs:
  "(f \<union>m empty) = f"
oops

lemma l_munion_empty_lhs:
  "(empty \<union>m f) = f"
oops

(******************************************************************************)
section {* These lemmas require side conditions (from known context) *}

(* from the context/definition of m_union: "dom f \<inter> dom g = {}" *)
lemma l_munion_apply:
	"dom f \<inter> dom g = {} \<Longrightarrow> (f \<union>m g) x = (if x \<in> dom g then (g x) else (f x))"
oops

lemma l_munion_dom:
	"dom f \<inter> dom g = {} \<Longrightarrow> dom(f \<union>m g) = dom f \<union> dom g"
oops

lemma l_munion_commute:
  "dom f \<inter> dom g = {} \<Longrightarrow> f \<union>m g = g \<union>m f"
oops

lemma k_finite_munion:
  "finite (dom f) \<Longrightarrow> finite(dom g) \<Longrightarrow> dom f \<inter> dom g = {} \<Longrightarrow> finite(dom(f \<union>m g))"
oops

lemma l_munion_singleton_not_empty:
  "x \<notin> dom f \<Longrightarrow> f \<union>m [x \<mapsto> y] \<noteq> empty"
oops

lemma l_munion_empty_iff:
  "dom f \<inter> dom g = {} \<Longrightarrow> (f \<union>m g = empty) \<longleftrightarrow> (f = empty \<and> g = empty)"
oops

(******************************************************************************)
section {* These lemmas require some side conditions (beyond just context) *}

(* it's the dom g \<inter> dom h = {} is the difficult one *)
lemma l_munion_assoc:
  "dom f \<inter> dom g = {} \<Longrightarrow> dom g \<inter> dom h = {} \<Longrightarrow> (f \<union>m g) \<union>m h = f \<union>m (g \<union>m h)"
oops

(* a bit of combined operators as well *)
lemma l_munion_dom_ar_singleton_subsume:
    "x \<notin> dom f \<Longrightarrow> {x} -\<triangleleft> (f \<union>m [x \<mapsto> y]) = f"
oops

lemma l_munion_dom_ar_assoc:
	"S \<subseteq> dom f \<Longrightarrow> dom f \<inter> dom g = {} \<Longrightarrow> (S -\<triangleleft> f) \<union>m g = S -\<triangleleft> (f \<union>m g)"
oops

lemma l_munion_subsume:
	"x \<in> dom f \<Longrightarrow> the(f x) = y \<Longrightarrow> f = ({x} -\<triangleleft> f) \<union>m [x \<mapsto> y]"
oops

(*================== Invariant Related Lemmas (Zoom2) ========================*)

text {* For the invariant, there are various "levels" within. Say, with just auxiliary functions
        like @{text "locs _"} and @{text "locs_of _ _"}, and those filtering conditions of the
        invariant across these and the former function symbols.

        Foreground symbol: @{text "_ \<union>m _"}; maybe  @{text "_ -\<triangleleft> _"}
      *}

(******************************************************************************)
section {* These lemmas are side-condition free *}

lemma l_nat1_map_empty:
  "nat1_map empty"
oops

lemma l_sep_empty:
  "sep empty"
oops

lemma l_disjoint_singleton:
  "Disjoint([x \<mapsto> y])"
oops

(******************************************************************************)
section {* These lemmas require side conditions (from known context) *}

lemma l_nat1_map_singleton:
  "nat1 y \<Longrightarrow> nat1_map([x \<mapsto> y])"
oops

lemma l_sep_singleton:
  "nat1 y \<Longrightarrow> sep([x \<mapsto> y])"
oops

(******************************************************************************)
section {* These lemmas require some side conditions (beyond just context) *}

lemma l_nat1_map_singleton_upd:
  "nat1 y \<Longrightarrow> x \<notin> dom f \<Longrightarrow> nat1_map f \<Longrightarrow> nat1_map(f \<union>m [x \<mapsto> y])"
oops

lemma k_Disjoint_dom_ar:
	"Disjoint f \<Longrightarrow> Disjoint (S -\<triangleleft> f)"
oops

lemma k_F1_inv_dom_ar:
   "F1_inv f \<Longrightarrow> F1_inv(S -\<triangleleft> f)"
oops

(* Weaken: separatedness subsumes dom_ar *)
lemma k_sep_dom_ar:
   "sep f \<Longrightarrow> sep (S -\<triangleleft> f)"
oops

(* example where concept generalisation is needed -- probably the most difficult one *)
(* wacky: would some "semingly useless" lemma help/hint to the concept? *)
definition
  sep0 :: "F1 \<Rightarrow> F1 \<Rightarrow> bool"
where
  "sep0 f g \<equiv> (\<forall> l \<in> dom f . l + the(f l) \<notin> dom g)"

thm sep_def sep0_def

lemma l_sep_munion:
    "dom f \<inter> dom g = {} \<Longrightarrow> sep f \<Longrightarrow> sep g \<Longrightarrow> sep0 f g \<Longrightarrow> sep0 g f \<Longrightarrow> sep(f \<union>m g)"
oops

lemma l_disjoint_munion:
  "nat1_map f \<Longrightarrow> nat1_map g \<Longrightarrow> Disjoint f \<Longrightarrow> Disjoint g \<Longrightarrow>
      dom f \<inter> dom g = {} \<Longrightarrow> disjoint (locs f) (locs g) \<Longrightarrow> sep0 f g \<Longrightarrow> sep0 g f \<Longrightarrow> Disjoint (f \<union>m g)"
oops

lemma l_disjoint_mapupd_keep_sep:
	"nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> r \<in> dom f \<Longrightarrow> nat1 s \<Longrightarrow> the(f r) > s \<Longrightarrow> (r+s) \<notin> dom f"
oops

lemma k_new1_gr_dom_ar_dagger_aux:
	"nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> r \<in> dom f \<Longrightarrow> nat1 s \<Longrightarrow> the(f r) > s \<Longrightarrow> dom ({r} -\<triangleleft> f) \<inter> dom [r + s \<mapsto> the (f r) - s] = {}"
oops

lemma k_nat1_map_dom_ar:
   "nat1_map f \<Longrightarrow> nat1_map (S -\<triangleleft> f)"
oops

lemma l_nat1_map_munion:
  "nat1_map f \<Longrightarrow> nat1_map g \<Longrightarrow> dom f \<inter> dom g = {} \<Longrightarrow> nat1_map(f \<union>m g)"
oops

lemma l_locs_singleton_iff:
  "nat1 y \<Longrightarrow> locs [x \<mapsto> y] = locs_of x y"
oops

lemma f_in_dom_locs:
  "nat1_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> x \<in> locs f"
oops

lemma l_locs_munion_iff:
  "nat1_map f \<Longrightarrow> nat1_map g \<Longrightarrow> dom f \<inter> dom g = {} \<Longrightarrow> locs(f \<union>m g) = locs f \<union> locs g"
oops

lemma f_dom_locs_of:
  "nat1_map f \<Longrightarrow> (x \<in> dom f) \<Longrightarrow> (x \<in> locs_of x (the (f x)))"
oops

lemma l_locs_of_within_locs:
  "nat1_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> locs_of x (the(f x)) \<subseteq> locs f"
oops

lemma f_dispose1_pre_not_in_dom:
  "nat1_map f \<Longrightarrow> nat1 s \<Longrightarrow> locs_of d s \<inter> locs f = {} \<Longrightarrow> d \<notin> dom f"
oops

lemma l_locs_dom_ar_iff:
  "nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> r \<in> dom f \<Longrightarrow> locs({r} -\<triangleleft> f) = locs f - locs_of r (the(f r))"
oops

lemma k_nat1_map_dom_ar_munion:
   "nat1 s \<Longrightarrow> r \<in> dom f \<Longrightarrow> the (f r) > s \<Longrightarrow> Disjoint f \<Longrightarrow> nat1_map f \<Longrightarrow> nat1_map ({r} -\<triangleleft> f \<union>m [r + s \<mapsto> the (f r) - s])"
oops

lemma k_Disjoint_dom_ar_munion:
	"r \<in> dom f \<Longrightarrow> the (f r) > s \<Longrightarrow> nat1 s \<Longrightarrow> nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> Disjoint (({r} -\<triangleleft> f) \<union>m [r + s \<mapsto> the (f r) - s])"
oops

lemma k_sep_dom_ar_munion:
   "nat1_map f \<Longrightarrow> r \<in> dom f \<Longrightarrow> the (f r) > s \<Longrightarrow> nat1 s \<Longrightarrow> sep f \<Longrightarrow> Disjoint f \<Longrightarrow> sep ({r} -\<triangleleft> f \<union>m [r + s \<mapsto> the (f r) - s])"
oops

lemma k_F1_inv_dom_munion:
   "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> r \<in> dom f \<Longrightarrow> the(f r) > s \<Longrightarrow> F1_inv({r} -\<triangleleft> f \<union>m [r + s \<mapsto> the (f r) - s])"
oops

lemma l_dispose1_sep0_above_empty_iff:
  "(dispose1_above f1 d1 s1 = empty) = sep0 [d1 \<mapsto> s1] f1"
oops

lemma l_dispose1_sep0_below_empty_iff:
  "(dispose1_below f1 d1 = empty) = sep0 f1 [d1 \<mapsto> s1]"
oops

lemma l_dispose1_below_singleton_useless:
  "l \<in> dom f \<Longrightarrow>  l+the(f l) = d \<Longrightarrow> nat1_map f \<Longrightarrow> sep f \<Longrightarrow> Disjoint f \<Longrightarrow> dispose1_below f d = [l \<mapsto> the(f l)]"
oops

(*================== Map Union Related Lemmas (Zoom1) ========================*)

(******************************************************************************)
section {* These lemmas are side-condition free *}

(******************************************************************************)
section {* These lemmas require side conditions (from known context) *}

(******************************************************************************)
section {* These lemmas require some side conditions (beyond just context) *}

lemma k_locs_of_arithIff:
	"nat1 n \<Longrightarrow> nat1 m \<Longrightarrow> (locs_of a n \<inter> locs_of b m = {}) = (a+n \<le> b \<or> b+m \<le> a)"
oops

(*
------ key message:

* theory exploration can decrease the proof effort in formal methods proofs (i.e. WD / FSB / Reify)
  by suggesting (key?) useful lemmas for involved function symbols

  -> this's despite not necessarily being over induction or complicated maths
  -> it relies on prior structural decomposition of the goal together with user guidance

* in our context (of a reasonably complex proof about a reasonably simple problem), the process did
  find lemmas used during the actual proofs.

* discuss statistics on used lemmas distribution in general and how would the process help
  (i.e. 20% are usually library lemmas; context dependant lemmas 10-20% as well)

* arguably invariant proofs are like induction step cases (???)

* we should include in the perl script (e.g. heapanalysis.pl) a counter for function symbols?
  (e.g. correlate function symbol -fore/background- with useful(ess) lemmas generated)?
  [guiding light to how much decomposition is necessary prior to using the tool]

* in the end, we are shifting/deskilling the interaction process needed [**** AI4FM MESSAGE ****]

- without "whym"-like (meta-)data, the search is unyelding/intracable
  (e.g. say something about what happened for findP)

- also dependant on the test set data generated for ensuring higher quality lemmas

-/+ tools were tailored for focusing on induction proofs (as where "interesting"-lies?)   [???]
    quickspec = not; hipspec = yes. yet, wasn't too bad to make it transferable to a inv-style proof

------ qeustions
would we find all these? [already found some]
if not, why not? [need for better "generators" / "sig"s / reasoning-techniques / increased search space / etc ??? ]

how could we also filter out the negative examples?
how would WhyM be useful on this?

first versions already found some of the (condition-free; or even conditional lemmas, without the conditon) lemmas above

------ NOTES

* context based side conditions are to be encoded in the (QuickCheck)
  arbitrary generators; their "quality" determines the success of the outcome
    [TO DO?: could overture test case generation expresions help?]

* apparently meaningless lemmas suggested by quick spec could still be useful
  to the engineer staring at the problem
  (e.g. (locs f) -\<triangleleft> f = (locs g) -\<triangleleft> g  leads to the thought that  dom f \<subseteq> locs f for this to be true!)

* before proceeding to more complext goals we need to handle function symbols per "zoom layer"
  (i.e. lemmas will be found "per zoom level" (i.e. prop-logic -> sets -> maps -> heap-op (Locs/LocsOf) -> heap-inv (Disj / Sep)
        (argument on taming the search: to tame the search)

* we need different signatures to frame where the focus (of search)
  should be (could also be informed by zoom layers?)

* test data determines the quality of the suggestions given by quick spec. we need to improve test set data
  (e.g. after generalisation of (_ -\<triangleleft> _) to sets (on LHS) we got this weird lemma: "(locs f) -\<triangleleft> (xs -\<triangleleft> f) = (locs f) -\<triangleleft> f")
      (this lemma is akin to saying locs f is maximal set on the domain of f for whatever xs; it's the case that dom f \<subset> locs f!

* by adding other map symbols (e.g. { \<mapsto> }, {}) we got more sensible lemmas, yet the question is could
  the focus be given to only the elements of interest
   -> yes with the "backgroun" signature staff.

* adding more symbols hasn't completely deteriorated the match/usefulness of lemmas found.
  Is that true in general? (under the context of FM; i.e. user guided search to a degree).
  Add then carefuly (e.g. backgrond x foreground symbols)

* fidlding with the number of operators () to some

----- things to test / check

* could we add "basic information" (i.e. known lemmas + known equivalence classes) to aid reasoning?
  (i.e. given foreground information about locs/locs_of/-\<triangleleft> what would it need to find the lemma of interest?
          e.g. locs({r} -\<triangleleft> f) = locs f - locs_of r (the(f r))

          -> quickspec not;
          -> hipspec would find "set_different"/map_application?  [hipspec generate signatures]?
          -> then the suggestion would be likely, even for this complex lemma?
          -> i.e. make use of known theories / lemmas to aid the shape of the background signature?

          -> TODO: that (use of hipspec/quickspec) would require making non-inductive things "interesting" as well.

* wacky: would it be case that what is in the foreground in zoom_n will be in the background in zoom_n+1

* precompiled (Haskell) libraries (definitions) won't affect/influence HipSpec search
  (i.e. this will/could hamper proving that suggested lemmas are true; won't prevent the suggestion)
*)

end


(*  Title:      CoW/Periodicity_Lemma.thy
    Author:     Štěpán Holub, Charles University

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

theory Periodicity_Lemma
  imports CoWBasic
begin

chapter "The Periodicity Lemma"

text\<open>The Periodicity Lemma says that if a sufficiently long word has two periods p and q,
then the period can be refined to @{term "gcd p q"}.
The consequence is equivalent to the fact that the corresponding periodic roots commute.
``Sufficiently long'' here means at least @{term "p + q - gcd p q"}.
It is also known as the Fine and Wilf theorem due to its authors \<^cite>\<open>FineWilf\<close>.\<close>

text\<open>
If we relax the requirement to @{term "p + q"}, then the claim becomes easy, and it is proved in theory @{theory Combinatorics_Words.CoWBasic} as @{term two_pers_root}: @{thm[names_long] two_pers_root[no_vars]}.
\<close>

theorem per_lemma_relaxed:
  assumes "period w p" and  "period w q" and  "p + q \<le> \<^bold>|w\<^bold>|"
  shows "(take p w)\<cdot>(take q w) = (take q w)\<cdot>(take p w)"
  using   two_pers_root[OF
      \<open>period w p\<close>[unfolded period_def[of w p]]
      \<open>period w q\<close>[unfolded period_def[of w q]], unfolded
      take_len[OF add_leD1[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]]
      take_len[OF add_leD2[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]], OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>].

text\<open>Also in terms of the numeric period:\<close>

thm two_periods

section \<open>Main claim\<close>

text\<open>We first formulate the claim of the Periodicity lemma in terms of commutation of two periodic roots.
For trivial reasons we can also drop the requirement that the roots are nonempty.
\<close>
theorem per_lemma_comm:
  assumes "w \<le>p r \<cdot> w" and "w \<le>p s \<cdot> w"
    and len: "\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|"
  shows "s \<cdot> r = r \<cdot> s"
  using assms
proof (induction "\<^bold>|s\<^bold>| + \<^bold>|s\<^bold>| + \<^bold>|r\<^bold>|" arbitrary: w r s rule: less_induct)
  case less
  consider (empty) "s = \<epsilon>" | (short)  "\<^bold>|r\<^bold>| < \<^bold>|s\<^bold>|" | (step) "s \<noteq> \<epsilon> \<and> \<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|" by force
  then show ?case
  proof (cases)
    case (empty)
    thus "s \<cdot> r = r \<cdot> s" by fastforce
  next
    case (short)
    thus "s \<cdot> r = r \<cdot> s"
      using  "less.hyps"[OF  _ \<open> w \<le>p s \<cdot> w\<close> \<open> w \<le>p r \<cdot> w\<close>
      \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close>[unfolded gcd.commute[of "\<^bold>|s\<^bold>|"] add.commute[of "\<^bold>|s\<^bold>|"]]] by fastforce
   next
     case (step)
    hence  "s \<noteq> \<epsilon>" and "\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|" by blast+
    from le_add_diff[OF gcd_le2_nat[OF \<open>s \<noteq> \<epsilon>\<close>[folded length_0_conv], of "\<^bold>|r\<^bold>|"], unfolded gcd.commute[of "\<^bold>|r\<^bold>|"]]
    have "\<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>|"
      using  \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close> order.trans by fast
    hence "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|"
      using \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close> order.trans by blast
    from pref_prod_long[OF  \<open>w \<le>p s \<cdot> w\<close> this]
    have "s \<le>p w".

    obtain w' where "s \<cdot> w' = w" and "\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|"
      using \<open>s \<noteq> \<epsilon>\<close> \<open>s \<le>p w\<close>[unfolded prefix_def]
      by force
    have "w' \<le>p w"
      using \<open>w \<le>p s \<cdot> w\<close> unfolding \<open>s \<cdot> w' = w\<close>[symmetric] pref_cancel_conv.
    from this[folded \<open>s \<cdot> w' = w\<close>]
    have "w' \<le>p s\<cdot>w'".

    have "s \<le>p r"
      using pref_prod_le[OF prefix_order.trans[OF \<open>s \<le>p w\<close> \<open>w \<le>p r \<cdot> w\<close>] \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close>].
    hence  "w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'"
      using \<open>w \<le>p r \<cdot> w\<close> \<open>s \<cdot> w' = w\<close> pref_prod_pref[OF _ \<open>w' \<le>p w\<close>, of "s\<inverse>\<^sup>>r"]
      unfolding prefix_def by fastforce

   have ind_len: "\<^bold>|s\<^bold>| + \<^bold>|s\<inverse>\<^sup>>r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|s\<inverse>\<^sup>>r\<^bold>|) \<le> \<^bold>|w'\<^bold>|"
      using \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close>[folded \<open>s \<cdot> w' = w\<close>]
      unfolding pref_gcd_lq[OF \<open>s \<le>p r\<close>] lenmorph lq_len[OF \<open>s \<le>p r\<close>] by force

    have "s \<cdot> s\<inverse>\<^sup>>r = s\<inverse>\<^sup>>r \<cdot> s"
      using "less.hyps"[OF  _ \<open>w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'\<close>  \<open>w' \<le>p s \<cdot> w'\<close> ind_len] \<open>s \<le>p r\<close> \<open>\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|\<close>
        unfolding prefix_def by force

    thus "s \<cdot> r = r \<cdot> s"
       using \<open>s \<le>p r\<close> by (fastforce simp add: prefix_def)
  qed
qed

lemma per_lemma_comm_pref:
  assumes "u \<le>p r\<^sup>@k" "u \<le>p s\<^sup>@l"
      and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
    shows "r \<cdot> s = s \<cdot> r"
  using  pref_prod_root[OF assms(2)] pref_prod_root[OF assms(1)] per_lemma_comm[OF _ _ len] by blast

text\<open>We can now prove the numeric version.\<close>

theorem per_lemma: assumes "period w p" and "period w q" and len: "p + q - gcd p q \<le> \<^bold>|w\<^bold>|"
  shows  "period w (gcd p q)"
proof-
  have takep: "w \<le>p (take p w) \<cdot> w" and takeq: "w \<le>p (take q w) \<cdot> w"
    using \<open>period w p\<close> \<open>period w q\<close> period_D3 by blast+
  have lenp: "\<^bold>|take p w\<^bold>| = p"
    using gcd_le2_nat[OF per_positive[OF \<open>period w q\<close>], of p] len take_len
    by auto
  have lenq: "\<^bold>|take q w\<^bold>| = q"
    using gcd_le1_nat[OF per_positive[OF \<open>period w p\<close>], of q] len take_len
    by simp
  obtain t where "take p w \<in> t*" and "take q w \<in> t*"
    using comm_rootE[OF per_lemma_comm[OF takeq takep, unfolded lenp lenq, OF len], of thesis] by blast
  hence "w \<le>p t\<^sup>\<omega>"
    using \<open>period w p\<close> period_def per_root_trans by blast
  have "period w \<^bold>|t\<^bold>|"
    using  root_period[OF  per_nemp[OF \<open>period w p\<close>] \<open>w \<le>p t\<^sup>\<omega>\<close>].
  have "\<^bold>|t\<^bold>| dvd (gcd p q)"
    using  common_root_len_gcd[OF \<open>take p w \<in> t*\<close> \<open>take q w \<in> t*\<close>] unfolding  lenp lenq.
  from dvd_div_mult_self[OF this]
  have "gcd p q div \<^bold>|t\<^bold>| * \<^bold>|t\<^bold>| = gcd p q".
  have "gcd p q \<noteq> 0"
    using \<open>period w p\<close> by auto
  from this[folded dvd_div_eq_0_iff[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]]
  show "period w (gcd p q)"
    using  per_mult[OF \<open>period w \<^bold>|t\<^bold>|\<close>, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]] by blast
qed

section \<open>Optimality\<close>

text\<open>@{term "FW_word"} (where FW stands for  Fine and Wilf) yields a word which show the optimality of the bound in the Periodicity lemma.
    Moreover, the obtained word has maximum possible letters (each equality of letters is forced by periods). The latter is not proved here.\<close>

term "butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))\<cdot>[gcd p q]\<cdot>(butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q))))"

\<comment> \<open>an auxiliary claim\<close>
lemma ext_per_sum: assumes "period w p" and "period w q" and  "p \<le> \<^bold>|w\<^bold>|"
  shows "period ((take p w) \<cdot> w) (p+q)"
proof-
  have nemp: "take p w \<cdot> take q w \<noteq> \<epsilon>"
    using \<open>period w p\<close> by auto
  have "take (p + q) (take p w \<cdot> w) = take p (take p w \<cdot> w) \<cdot> take q (drop p (take p w \<cdot> w))"
    using take_add by blast
  also have "... = take p w \<cdot> take q w"
    by (simp add: \<open>p \<le> \<^bold>|w\<^bold>|\<close>)
  ultimately have sum: "take (p + q) (take p w \<cdot> w) = take p w \<cdot> take q w"
    by presburger
  show ?thesis
    using assms(1) assms(2) nemp
    unfolding period_def period_root_def sum rassoc same_prefix_prefix
    using pref_prolong  by blast
qed

definition "fw_p_per p q \<equiv> butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))"
definition "fw_base p q \<equiv> fw_p_per p q \<cdot> [gcd p q]\<cdot> fw_p_per p q"

fun FW_word :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  FW_word_def: "FW_word p q =
\<comment>\<open>symmetry\<close>           (if q < p then  FW_word q p else
\<comment>\<open>artificial value\<close>   if p = 0 then \<epsilon> else
\<comment>\<open>artificial value\<close>   if p = q then \<epsilon> else
\<comment>\<open>base case\<close>          if gcd p q = q - p then fw_base p q
\<comment>\<open>step\<close>               else (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p))"

lemma FW_sym: "FW_word p q = FW_word q p"
  by (cases rule: linorder_cases[of p q], simp+)

theorem fw_word': "\<not> p dvd q \<Longrightarrow> \<not> q dvd p \<Longrightarrow>
 \<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1 \<and> period (FW_word p q) p \<and> period (FW_word p q) q \<and> \<not> period (FW_word p q) (gcd p q)"
proof (induction "p + p + q" arbitrary: p q rule: less_induct)
  case less
  have "p \<noteq> 0"
    using  \<open>\<not> q dvd p\<close> dvd_0_right[of q] by meson
  have "p \<noteq> q"
    using \<open>\<not> p dvd q\<close> by auto
  then consider "q < p" | "p < q"
    by linarith
  then show ?case
  proof (cases)
    assume "q < p"
    have less: "q + q + p < p + p + q"
      by (simp add: \<open>q < p\<close>)
    thus ?case
      using "less.hyps"[OF _ \<open>\<not> q dvd p\<close> \<open>\<not> p dvd q\<close>]
      unfolding FW_sym[of p q] gcd.commute[of p q] add.commute[of p q] by blast
  next
    let ?d = "gcd p q"
    let ?dw = "[0..<(gcd p q)]"
    let ?pd = "p div (gcd p q)"
    assume "p < q"
    thus ?thesis
    proof (cases "?d = q - p")
      assume "?d = q - p" hence "p + ?d = q" using \<open>p < q\<close> by auto
      hence "p \<noteq> q" and "\<not> q < p" using \<open>p \<noteq> 0\<close> \<open>p < q\<close> by fastforce+
      hence fw: "FW_word p q = fw_base p q"
        unfolding FW_word_def[of p q] using \<open>p \<noteq> 0\<close>  \<open>gcd p q = q - p\<close> by presburger

      have ppref: "\<^bold>|butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<^bold>| = p"
        using  \<open>p \<noteq> 0\<close> pow_len[of "?dw" "?pd"] unfolding lenmorph sing_len
        by auto
      note ppref' = this[unfolded lenmorph]
      have qpref: "\<^bold>|butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<cdot>?dw\<^bold>| = q"
        unfolding lassoc lenmorph ppref' using  \<open>p + gcd p q = q\<close> by simp
      have "butlast (?dw\<^sup>@?pd)\<cdot>[?d] \<le>p FW_word p q"
        unfolding fw fw_base_def fw_p_per_def by force
      from pref_take[OF this]
      have takep: "take p (FW_word p q) = butlast (?dw\<^sup>@?pd)\<cdot>[?d]"
        unfolding ppref.

      have "?dw \<noteq> \<epsilon>" and "\<^bold>|?dw\<^bold>| = ?d"
        using \<open>p \<noteq> 0\<close> by auto
      have "?pd \<noteq> 0"
        by (simp add: \<open>p \<noteq> 0\<close> dvd_div_eq_0_iff)
      from not0_implies_Suc[OF this]
      obtain e where "?pd = Suc e"  by blast
      have "gcd p q \<noteq> p"
        using \<open>\<not> p dvd q\<close> gcd_dvd2[of p q] by force
      hence "Suc e \<noteq> 1"
        using dvd_mult_div_cancel[OF gcd_dvd1[of p q], unfolded \<open>?pd = Suc e\<close>] by force
      hence "e \<noteq> 0" by simp

      have "[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>"
        using \<open>[0..<gcd p q] \<noteq> \<epsilon>\<close> \<open>e \<noteq> 0\<close> nonzero_pow_emp by blast
      hence but_dec: "butlast (?dw\<^sup>@?pd) = ?dw \<cdot> butlast (?dw\<^sup>@e)"
        unfolding \<open>?pd = Suc e\<close> pow_Suc butlast_append  if_not_P[OF \<open>[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>\<close>] by blast
      have but_dec_b: "butlast (?dw\<^sup>@?pd) = ?dw\<^sup>@e \<cdot> butlast ?dw"
        unfolding \<open>?pd = Suc e\<close> pow_Suc2 butlast_append if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>] by blast
      have "butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<cdot>?dw \<le>p FW_word p q"
        unfolding fw but_dec lassoc fw_base_def fw_p_per_def by blast
      note takeq = pref_take[OF this, unfolded qpref]

      have "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1"
      proof-
        have "p + q - (q - p) = p + p"
          using \<open>p + gcd p q = q\<close> by auto
        have "\<^bold>|?dw\<^bold>| = ?d"
          by auto
        have "gcd p q dvd p"
          by auto
        hence "\<^bold>|?dw\<^sup>@?pd\<^bold>| = p"
          using pow_len[of "?dw" "?pd"]
          by auto
        hence "\<^bold>|butlast (?dw\<^sup>@?pd)\<^bold>| = p - 1"
          by simp
        hence "\<^bold>|FW_word p q\<^bold>| = (p - 1) + 1 +  (p - 1)"
          unfolding fw lenmorph sing_len fw_base_def fw_p_per_def by presburger
        thus "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1"
          unfolding \<open>gcd p q = q - p\<close> \<open>p + q - (q - p) = p + p\<close>  using \<open>p \<noteq> 0\<close> by fastforce
      qed

      have "period (FW_word p q) p"
      proof-
        have "take p (FW_word p q) \<noteq> \<epsilon>"
          using \<open>p \<noteq> 0\<close>  unfolding length_0_conv[symmetric] ppref[folded takep].
        moreover have "fw_base p q \<le>p fw_p_per p q \<cdot> [gcd p q] \<cdot> fw_base p q"
          unfolding rassoc pref_cancel_conv fw_base_def fw_p_per_def by simp
        ultimately show "period (FW_word p q) p"
          unfolding period_def period_root_def takep unfolding fw rassoc fw_base_def fw_p_per_def by fast
      qed

      have "period (FW_word p q) q"
        unfolding period_def period_root_def
      proof
        show "take q (FW_word p q) \<noteq> \<epsilon>"
          unfolding length_0_conv[symmetric] qpref[folded takeq] using \<open>p \<noteq> 0\<close> \<open>p < q\<close> by linarith
      next
        show "FW_word p q \<le>p take q (FW_word p q) \<cdot> FW_word p q"
          unfolding takeq
          unfolding fw fw_base_def fw_p_per_def rassoc pref_cancel_conv but_dec but_dec_b \<open>?pd = Suc e\<close> pow_Suc2 butlast_append pow_Suc if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>]
          unfolding lassoc power_commutes[symmetric] unfolding rassoc pref_cancel_conv
          using pref_ext[OF prefixeq_butlast, of "?dw"]
          by blast
      qed

      have "\<not> period (FW_word p q) ?d"
      proof-
        have last_a: "last (take p (FW_word p q)) = ?d"
          unfolding takep nth_append_length[of "butlast (?dw \<^sup>@ ?pd)" "?d" \<epsilon>]
            last_snoc by blast
        have "?dw \<le>p FW_word p q"
          unfolding fw but_dec rassoc fw_base_def fw_p_per_def by blast
        from pref_take[OF this, unfolded \<open>\<^bold>|?dw\<^bold>| = ?d\<close>]
        have takegcd:  "take (gcd p q) (FW_word p q) = [0..<gcd p q]".
        have fw_dec_b: "FW_word p q = [0..<gcd p q]\<^sup>@e \<cdot> butlast ([0..<gcd p q]) \<cdot> [?d] \<cdot> (butlast ([0..<gcd p q]\<^sup>@(p div gcd p q)))"
          unfolding fw but_dec_b rassoc fw_base_def fw_p_per_def ..
        have gcdepref:  "[0..<gcd p q]\<^sup>@ Suc e \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q"
          unfolding takegcd pow_Suc pref_cancel_conv unfolding fw_dec_b by blast
        have "\<^bold>|[0..<gcd p q]\<^sup>@ Suc e\<^bold>| = p"
          unfolding pow_len \<open>\<^bold>|?dw\<^bold>| = ?d\<close> \<open>?pd = Suc e\<close>[symmetric] using
            dvd_div_mult_self[OF gcd_dvd1].
        from pref_take[OF gcdepref, unfolded this]
        have takegcdp:  "take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q)) = [0..<gcd p q]\<^sup>@e \<cdot> [0..<gcd p q]"
          unfolding pow_Suc2.
        have "0 < gcd p q" by (simp add: \<open>p \<noteq> 0\<close>)
        from last_upt[OF this]
        have last_b: "last (take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q))) = gcd p q - 1"
          unfolding takegcdp  last_appendR[of "[0..<gcd p q]" "[0..<gcd p q]\<^sup>@e", OF \<open>[0..<gcd p q] \<noteq> \<epsilon>\<close>].
        have "p \<le> \<^bold>|FW_word p q\<^bold>|"
          unfolding \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>gcd p q = q - p\<close> using  \<open>p < q\<close> by auto
        have "gcd p q \<noteq> gcd p q - 1"
          using \<open>gcd p q = q - p\<close> \<open>p < q\<close> by linarith
        hence "take p (FW_word p q) \<noteq> take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q))"
          unfolding last_b[symmetric] unfolding last_a[symmetric] using arg_cong[of _ _ last] by blast
        hence "\<not> FW_word p q \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q "
          using pref_share_take[OF _ \<open>p \<le> \<^bold>|FW_word p q\<^bold>|\<close>, of "take (gcd p q) (FW_word p q) \<cdot> FW_word p q"] by blast
        thus "\<not> period (FW_word p q) (gcd p q)"
          unfolding period_def period_root_def by blast
      qed

      show ?thesis
        using \<open>period (FW_word p q) p\<close> \<open>period (FW_word p q) q\<close>
          \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>\<not> period (FW_word p q) (gcd p q)\<close> by blast
    next
      let ?d' = "gcd p (q-p)"
      assume "gcd p q \<noteq> q - p"
      hence fw: "FW_word p q = (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p)"
        using FW_word_def \<open>p \<noteq> 0\<close> \<open>p \<noteq> q\<close> \<open>p < q\<close> by (meson less_Suc_eq not_less_eq)

      have divhyp1: "\<not> p dvd q - p"
        using \<open>\<not> p dvd q\<close> \<open>p < q\<close> dvd_minus_self by auto

      have divhyp2: "\<not> q - p dvd p"
      proof (rule notI)
        assume "q - p dvd p"
        have "q = p + (q - p)"
          by (simp add: \<open>p < q\<close> less_or_eq_imp_le)
        from gcd_add2[of p "q - p", folded  this, unfolded gcd_nat.absorb2[of "q - p" p, OF \<open>q - p dvd p\<close>]]
        show "False"
          using \<open>gcd p q \<noteq> q - p\<close> by blast
      qed

      have lenhyp: "p + p + (q - p) < p + p + q"
        using \<open>p < q\<close> \<open>p \<noteq> 0\<close> by linarith

\<comment> \<open>induction assumption\<close>
      have "\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1" and "period (FW_word p (q-p)) p" and "period (FW_word p (q-p)) (q-p)" and
        "\<not> period (FW_word p (q-p)) (gcd p (q-p))"
        using "less.hyps"[OF _ divhyp1 divhyp2] lenhyp
        by blast+

\<comment> \<open>auxiliary facts\<close>
      have "p + (q - p) = q"
         using divhyp1 dvd_minus_self by auto
      have "?d = ?d'"
        using  gcd_add2[of p "q-p", unfolded le_add_diff_inverse[OF less_imp_le[OF \<open>p < q\<close>]]].
      have "?d \<noteq> q"
        using  \<open>\<not> q dvd p\<close>  gcd_dvd2[of q p, unfolded gcd.commute[of q]] by force
      from this[unfolded nat_neq_iff]
      have "?d < q"
        using  gr_implies_not0 \<open>p < q\<close> nat_dvd_not_less by blast
      hence "1 \<le> q - ?d"
        by linarith
      have "?d' < q - p"
        using  gcd_le2_nat[OF per_positive[OF \<open>period (FW_word p (q - p)) (q - p)\<close>], of p]  divhyp2[unfolded  gcd_nat.absorb_iff2] nat_less_le by blast
      hence "p \<le> \<^bold>|(FW_word p (q - p))\<^bold>|"
        unfolding  \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close>  diff_diff_left discrete by linarith
      have "FW_word p (q - p) \<noteq> \<epsilon>"
        unfolding length_0_conv[symmetric] using  \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close> \<open>p \<noteq> 0\<close>[folded le_zero_eq]
        by linarith

\<comment> \<open>claim 1\<close>
      have "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1"
      proof-
        have "p + (q - p) = q" using less_imp_le[OF \<open>p < q\<close>] by fastforce
        have "\<^bold>|FW_word p q\<^bold>| = \<^bold>|take p (FW_word p (q - p))\<^bold>| + \<^bold>|FW_word p (q - p)\<^bold>|"
          using fw lenmorph[of "take p (FW_word p (q - p))" "FW_word p (q - p)"]
          by presburger
        also have "... = p + (p + (q - p) - ?d' - 1)"
          unfolding \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close>
            take_len[OF \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>] by blast
        also have "... = p + (q - ?d  - 1)"
          unfolding \<open>?d = ?d'\<close> \<open>p + (q - p) = q\<close>..
        also have "... = p + (q - ?d) - 1"
          using Nat.add_diff_assoc[OF \<open>1 \<le> q - ?d\<close>].
        also have "... = p + q - ?d - 1"
          by (simp add: \<open>?d < q\<close> less_or_eq_imp_le)
        finally show "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1"
          by presburger
      qed

\<comment> \<open>claim 2\<close>
      have "period (FW_word p q) p"
        using fw  ext_per_left[OF \<open>period (FW_word p (q-p)) p\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>]
        by presburger

\<comment> \<open>claim 3\<close>
      have "period (FW_word p q) q"
        using ext_per_sum[OF \<open>period (FW_word p (q - p)) p\<close> \<open>period (FW_word p (q - p)) (q - p)\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>, folded fw, unfolded \<open>p + (q-p) = q\<close>].

\<comment> \<open>claim 4\<close>
      have "\<not> period (FW_word p q) ?d"
        using \<open>\<not> period (FW_word p (q -p)) (gcd p (q-p))\<close>
        unfolding \<open>?d = ?d'\<close>[symmetric]
        using period_fac[of "take p (FW_word p (q - p))" "FW_word p (q - p)" \<epsilon> "?d", unfolded append_Nil2,
                          OF _ \<open>FW_word p (q - p) \<noteq> \<epsilon>\<close>, folded fw] by blast
      thus ?thesis
        using \<open>period (FW_word p q) p\<close> \<open>period (FW_word p q) q\<close> \<open>\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1\<close> by blast
    qed
  qed
qed

theorem fw_word: assumes "\<not> p dvd q" "\<not> q dvd p"
  shows "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1" and "period (FW_word p q) p" and  "period (FW_word p q) q" and "\<not> period (FW_word p q) (gcd p q)"
  using fw_word'[OF assms] by blast+

text\<open>Calculation examples\<close>

(* value "FW_word 3 7" *)
(* value "FW_word 5 7" *)
(* value "FW_word 5 13" *)
(* value "FW_word 4 6" *)
(* value "FW_word 12 18" *)

section "Other variants of the periodicity lemma"

text \<open>Periodicity lemma is one of the most frequent tools in Combinatorics on words.
   Here are some useful variants.\<close>

lemma fac_two_conjug_primroot:
  assumes facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l" and nemps: "r \<noteq> \<epsilon>" "s \<noteq> \<epsilon>" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
  shows "\<rho> r \<sim> \<rho> s"
proof -
  obtain r' s' where prefr': "u \<le>p r'\<^sup>@k" and prefs': "u \<le>p s'\<^sup>@l"
               and   conjugs: "r \<sim> r'" "s \<sim> s'"
    using facs by (elim fac_pow_pref_conjug)
  have rootr': "u \<le>p r' \<cdot> u" and roots': "u \<le>p s' \<cdot> u"
    using pref_prod_root[OF prefr'] pref_prod_root[OF prefs'].
  have nemps': "r' \<noteq> \<epsilon>" "s'\<noteq> \<epsilon>" using nemps conjugs conjug_nemp_iff by blast+
  have "\<^bold>|r'\<^bold>| + \<^bold>|s'\<^bold>| - gcd (\<^bold>|r'\<^bold>|) (\<^bold>|s'\<^bold>|) \<le> \<^bold>|u\<^bold>|" using len
    unfolding conjug_len[OF \<open>r \<sim> r'\<close>] conjug_len[OF \<open>s \<sim> s'\<close>].
  from per_lemma_comm[OF roots' rootr' this]  have "r' \<cdot> s' = s' \<cdot> r'".
  then have "\<rho> r' = \<rho> s'" using comm_primroots[OF nemps'] by force
  also have "\<rho> s \<sim> \<rho> s'" using conjug_primroot[OF \<open>s \<sim> s'\<close>].
  also have [symmetric]: "\<rho> r \<sim> \<rho> r'" using conjug_primroot[OF \<open>r \<sim> r'\<close>].
  finally show "\<rho> r \<sim> \<rho> s"..
qed

lemma fac_two_conjug_primroot':
  assumes facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l" and "u \<noteq> \<epsilon>" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
  shows "\<rho> r \<sim> \<rho> s"
proof -
  have nemps: "r \<noteq> \<epsilon>" "s \<noteq> \<epsilon>" using facs \<open>u \<noteq> \<epsilon>\<close> by auto
  show "conjugate (\<rho> r) (\<rho> s)" using fac_two_conjug_primroot[OF facs nemps len].
qed

lemma fac_two_nconj_prim_pow:
  assumes prims: "primitive r" "primitive s" and "\<not> r \<sim> s"
      and facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l"
  shows "\<^bold>|u\<^bold>| < \<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|)"
  using \<open>\<not> r \<sim> s\<close> fac_two_conjug_primroot[OF facs prim_nemp prim_nemp leI, OF prims]
  unfolding prim_self_root[OF \<open>primitive r\<close>] prim_self_root[OF \<open>primitive s\<close>]
  by (rule contrapos_np)

lemma per_lemma_pref_suf: assumes "w \<le>p p \<cdot> w" and "w \<le>s w \<cdot> q" and "p \<noteq> \<epsilon>" and "q \<noteq> \<epsilon>" and
  fw: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| - (gcd \<^bold>|p\<^bold>| \<^bold>|q\<^bold>|) \<le> \<^bold>|w\<^bold>|"
obtains r s k l m where "p = (r \<cdot> s)\<^sup>@k" and "q = (s \<cdot> r)\<^sup>@l" and "w = (r \<cdot> s)\<^sup>@m \<cdot> r" and "primitive (r\<cdot>s)"
proof-
  obtain kp where "w \<le>f p\<^sup>@kp"
    using per_root_fac[OF \<open>w \<le>p p \<cdot> w\<close> \<open>p \<noteq> \<epsilon>\<close>].
  obtain kq where "w \<le>f q\<^sup>@kq"
    using per_root_fac[reversed, OF \<open>w \<le>s w \<cdot> q\<close>] using \<open>q \<noteq> \<epsilon>\<close> by blast
  from fac_two_conjug_primroot[OF \<open>w \<le>f p\<^sup>@kp\<close> \<open>w \<le>f q\<^sup>@kq\<close> \<open>p \<noteq> \<epsilon>\<close> \<open>q \<noteq> \<epsilon>\<close> fw]
  have "\<rho> p \<sim> \<rho> q".
  have "\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|"
    using per_lemma_len_le[OF fw] \<open>q \<noteq> \<epsilon>\<close> by simp
  hence "\<^bold>|\<rho> p\<^bold>| \<le> \<^bold>|w\<^bold>|" and "\<^bold>|\<rho> q\<^bold>| \<le> \<^bold>|w\<^bold>|"
    using  conjug_len[OF \<open>\<rho> p \<sim> \<rho> q\<close>] dual_order.trans primroot_len_le[OF \<open>p \<noteq> \<epsilon>\<close>] by metis+
  hence "\<rho> q \<le>s w"
    using \<open>w \<le>s w \<cdot> q\<close>  primroot_suf[OF \<open>q \<noteq> \<epsilon>\<close>] suffix_appendI suffix_length_suffix by metis
  have "w \<le>p \<rho> p \<cdot> w"
    using per_root_primroot[OF \<open>w \<le>p p \<cdot> w\<close> \<open>p \<noteq> \<epsilon>\<close>].
  obtain r s k where "\<rho> p = r \<cdot> s" and  "w = (r \<cdot> s)\<^sup>@k \<cdot> r"
    using  per_root_eq[OF \<open>w \<le>p \<rho> p \<cdot> w\<close> primroot_nemp[OF \<open>p \<noteq> \<epsilon>\<close>]].
  have "\<^bold>|\<rho> q\<^bold>| = \<^bold>|s \<cdot> r\<^bold>|"
    using  lenarg[OF \<open>\<rho> p = r \<cdot> s\<close>] conjug_len[OF \<open>\<rho> p \<sim> \<rho> q\<close>] unfolding lenmorph by linarith
  hence "\<rho> q = s \<cdot> r"
  proof (cases "k = 0")
    assume "k = 0"
    hence "w = r"
      using \<open>w = (r \<cdot> s)\<^sup>@k \<cdot> r\<close> pow_zero by force
    hence "s = \<epsilon>"
      using \<open>\<^bold>|\<rho> p\<^bold>| \<le> \<^bold>|w\<^bold>|\<close> \<open>\<rho> p = r \<cdot> s\<close> by auto
    have "\<rho> q = r"
      using conjug_sym[OF \<open>\<rho> p \<sim> \<rho> q\<close>] suf_same_len[OF \<open>\<rho> q \<le>s w\<close> conjug_len]
      unfolding \<open>s = \<epsilon>\<close> clean_emp \<open>w = r\<close> \<open>\<rho> p = r \<cdot> s\<close> by blast
   thus "\<rho> q = s \<cdot> r"
      using \<open>s = \<epsilon>\<close> by simp
  next
    assume "k \<noteq> 0"
    hence "w = (r \<cdot> (s \<cdot> r)\<^sup>@(k-1)) \<cdot> s \<cdot> r"
      unfolding \<open>w = (r \<cdot> s)\<^sup>@k \<cdot> r\<close> by comparison
    from suf_prod_eq[OF \<open>\<rho> q \<le>s w\<close>[unfolded this] \<open>\<^bold>|\<rho> q\<^bold>| = \<^bold>|s \<cdot> r\<^bold>|\<close>]
    show "\<rho> q = s \<cdot> r".
  qed
  from that[OF _ _ \<open>w = (r \<cdot> s)\<^sup>@k \<cdot> r\<close>] \<open>\<rho> q = s \<cdot> r\<close> \<open>q \<noteq> \<epsilon>\<close> \<open>\<rho> p = r \<cdot> s\<close> \<open>p \<noteq> \<epsilon>\<close>
  show thesis
    using primroot_expE primroot_prim by metis
qed

end


(*  Title:      HOL/ex/Transfer_Debug.thy
    Author:     Ondřej Kunčar, TU München
*)
theory Transfer_Debug
imports MainRLT "HOL-Library.FSet"
begin

(*
  This file demonstrates some of the typical scenarios
  when transfer or transfer_prover does not produce expected results
  and how the user might handle such cases.
*)

(* As an example, we use finite sets. The following command recreates the environment in which
   the type of finite sets was created and allows us to do transferring on this type. *)
context
includes fset.lifting
begin

subsection \<open>1. A missing transfer rule\<close>

(* We will simulate the situation in which there is not any transfer rules for fmember. *)
declare fmember.transfer[transfer_rule del] fmember_transfer[transfer_rule del]

(* We want to prove the following theorem about |\<subseteq>| by transfer *)
lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
apply transfer
(*
   Transfer complains that it could not find a transfer rule for |\<subseteq>| with a matching transfer
   relation. An experienced user could notice that |\<in>| was transferred to |\<in>| by a
   a default reflexivity transfer rule (because there was not any genuine transfer rule for |\<in>|)
   and fBall was transferred to Ball using the transfer relation pcr_fset. Therefore transfer
   is looking for a transfer rule for |\<subseteq>| with a transfer relation that mixes (=) and pcr_fset.
   This situation might be confusing because the real problem (a missing transfer rule) propagates
   during the transferring algorithm and manifests later in an obfuscated way. Fortunately,
   we could inspect the behavior of transfer in a more interactive way to pin down the real problem.
*)
oops

lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
apply transfer_start
(* Setups 6 goals for 6 transfer rules that have to be found and the result as the 7. goal, which
   gets synthesized to the final result of transferring when we find the 6 transfer rules. *)
apply transfer_step
(* We can see that the default reflexivity transfer rule was applied and |\<in>|
  was transferred to |\<in>| \<Longrightarrow> there is no genuine transfer rule for |\<in>|. *)
oops

(* We provide a transfer rule for |\<in>|. *)

lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
apply transfer_start
apply transfer_step (* The new transfer rule was selected and |\<in>| was transferred to \<in>. *)
apply transfer_step+
apply transfer_end
by blast

(* Of course in the real life, we would use transfer instead of transfer_start, transfer_step+ and
   transfer_end. *)
lemma "(A |\<subseteq>| B) = fBall A (\<lambda>x. x |\<in>| B)"
by transfer blast

subsection \<open>2. Unwanted instantiation of a transfer relation variable\<close>

(* We want to prove the following fact. *)
lemma "finite (UNIV :: 'a::finite fset set)"
apply transfer
(* Transfer does not do anything here. *)
oops

(* Let us inspect interactively what happened. *)
lemma "finite (UNIV :: 'a::finite fset set)"
apply transfer_start
apply transfer_step
(*
   Here we can realize that not an expected transfer rule was chosen.
   We stumbled upon a limitation of Transfer: the tool used the rule Lifting_Set.UNIV_transfer,
   which transfers UNIV to UNIV and assumes that the transfer relation has to be bi-total.
   The problem is that at this point the transfer relation is not known (it is represented by
   a schematic variable ?R) and therefore in order to discharge the assumption "bi_total ?R", ?R is
   instantiated to (=.) If the relation had been known (we wish pcr_fset (=), which is not bi-total),
   the assumption bi_total pcr_fset (=) could not have been discharged and the tool would have
   backtracked and chosen Lifting.right_total_UNIV_transfer, which assumes only right-totalness
   (and pcr_fset is right-total).
*)
back back (* We can force the tool to backtrack and choose the desired transfer rule. *)
apply transfer_step
apply transfer_end
by auto

(* Of course, to use "back" in proofs is not a desired style. But we can prioritize
   the rule Lifting.right_total_UNIV_transfer by redeclaring it LOCALLY as a transfer rule.
 *)
lemma "finite (UNIV :: 'a::finite fset set)"
proof -
  note right_total_UNIV_transfer[transfer_rule]
  show ?thesis by transfer auto
qed

end

(* Let us close the environment of fset transferring and add the rule that we deleted. *)
lifting_forget fset.lifting (* deletes the extra added transfer rule for |\<in>| *)
declare fmember_transfer[transfer_rule] (* we want to keep parametricity of |\<in>| *)

end


(*  Title:      HOL/Isar_Examples/Drinker.thy
    Author:     Makarius
*)

section \<open>The Drinker's Principle\<close>

theory Drinker
  imports Main
begin

text \<open>
  Here is another example of classical reasoning: the Drinker's Principle says
  that for some person, if he is drunk, everybody else is drunk!

  We first prove a classical part of de-Morgan's law.
\<close>

lemma de_Morgan:
  assumes "\<not> (\<forall>x. P x)"
  shows "\<exists>x. \<not> P x"
proof (rule classical)
  assume "\<nexists>x. \<not> P x"
  have "\<forall>x. P x"
  proof
    fix x show "P x"
    proof (rule classical)
      assume "\<not> P x"
      then have "\<exists>x. \<not> P x" ..
      with \<open>\<nexists>x. \<not> P x\<close> show ?thesis by contradiction
    qed
  qed
  with \<open>\<not> (\<forall>x. P x)\<close> show ?thesis by contradiction
qed

theorem Drinker's_Principle: "\<exists>x. drunk x \<longrightarrow> (\<forall>x. drunk x)"
proof cases
  assume "\<forall>x. drunk x"
  then have "drunk a \<longrightarrow> (\<forall>x. drunk x)" for a ..
  then show ?thesis ..
next
  assume "\<not> (\<forall>x. drunk x)"
  then have "\<exists>x. \<not> drunk x" by (rule de_Morgan)
  then obtain a where "\<not> drunk a" ..
  have "drunk a \<longrightarrow> (\<forall>x. drunk x)"
  proof
    assume "drunk a"
    with \<open>\<not> drunk a\<close> show "\<forall>x. drunk x" by contradiction
  qed
  then show ?thesis ..
qed

end


section "Quantitative Hoare Logic (due to Carbonneaux)"
theory Quant_Hoare
imports Big_StepT Complex_Main "HOL-Library.Extended_Nat"
begin

abbreviation "eq a b == (And (Not (Less a b)) (Not (Less b a)))"

type_synonym lvname = string
type_synonym assn = "state \<Rightarrow> bool" (* time bound *)
type_synonym qassn = "state \<Rightarrow> enat" (* time bound *)

text \<open>The support of an assn2\<close>

abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
  ("_[_'/_]" [1000,0,0] 999)
where "s[a/x] == s(x := aval a s)"

fun emb :: "bool \<Rightarrow> enat" ("\<up>") where
   "emb False = \<infinity>"
 | "emb True = 0"

subsection "Validity of quantitative Hoare Triple"

(* this definition refines the definition of validity of normal Hoare Triple for total correctness  *)

definition hoare2_valid :: "qassn \<Rightarrow> com \<Rightarrow> qassn \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>2 {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile>\<^sub>2 {P} c {Q}  \<longleftrightarrow>  (\<forall>s.  P s < \<infinity> \<longrightarrow> (\<exists>t p. ((c,s) \<Rightarrow> p \<Down> t) \<and> P s \<ge> p + Q t))"

subsection "Hoare logic for quantiative reasoning"

inductive
  hoare2 :: "qassn \<Rightarrow> com \<Rightarrow> qassn \<Rightarrow> bool" ("\<turnstile>\<^sub>2 ({(1_)}/ (_)/ {(1_)})" 50)
where

Skip:  "\<turnstile>\<^sub>2 {%s. eSuc (P s)} SKIP {P}"  |

Assign:  "\<turnstile>\<^sub>2 {\<lambda>s. eSuc (P (s[a/x]))} x::=a { P }"  |

If: "\<lbrakk> \<turnstile>\<^sub>2 {\<lambda>s. P s + \<up>( bval b s)} c\<^sub>1 { Q};
       \<turnstile>\<^sub>2 {\<lambda>s. P s + \<up>(\<not> bval b s)} c\<^sub>2 { Q} \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>2 {\<lambda>s. eSuc (P s)} IF b THEN c\<^sub>1 ELSE c\<^sub>2 { Q }"  |

Seq: "\<lbrakk> \<turnstile>\<^sub>2 { P\<^sub>1 } c\<^sub>1 { P\<^sub>2 }; \<turnstile>\<^sub>2 {P\<^sub>2} c\<^sub>2 { P\<^sub>3 }\<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>2 {P\<^sub>1} c\<^sub>1;;c\<^sub>2 {P\<^sub>3}"  |

While:
  "\<lbrakk>   \<turnstile>\<^sub>2 { %s. I s + \<up>(bval b s) } c { %t. I t + 1 }   \<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>2 {\<lambda>s. I s + 1 } WHILE b DO c {\<lambda>s.  I s + \<up>(\<not> bval b s)  }" |

conseq: "\<lbrakk> \<turnstile>\<^sub>2 {P}c{Q} ; \<And>s. P s \<le> P' s ; \<And>s. Q' s \<le> Q s \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>2 {P'}c{ Q'}"

text \<open>derived rules\<close>

lemma Assign': "\<forall>s. P s \<ge> eSuc ( Q(s[a/x])) \<Longrightarrow> \<turnstile>\<^sub>2 {P} x ::= a {Q}"
  by (simp add: strengthen_pre[OF _ Assign])

lemma progress: "(c, s) \<Rightarrow> p \<Down> t \<Longrightarrow> p > 0"
  by (induct rule: big_step_t.induct, auto)

lemma FalseImplies: "\<turnstile>\<^sub>2 {%s. \<infinity>} c { Q}"
  apply (induction c arbitrary: Q)
  apply(auto intro: hoare2.Skip hoare2.Assign hoare2.Seq hoare2.conseq)
  subgoal apply(rule hoare2.conseq) apply(rule hoare2.If[where P="%s. \<infinity>"]) by(auto intro: hoare2.If hoare2.conseq)
  subgoal apply(rule hoare2.conseq) apply(rule hoare2.While[where I="%s. \<infinity>"]) apply(rule hoare2.conseq) by auto
  done

subsection "Soundness"

text\<open>The soundness theorem:\<close>

lemma help1: assumes " enat a + X \<le> Y"
    "enat b + Z \<le> X"
  shows "enat (a + b) + Z \<le> Y"
  using assms  by (metis ab_semigroup_add_class.add_ac(1) add_left_mono order_trans plus_enat_simps(1))

lemma help2': assumes "enat p + INV t  \<le> INV s"
    "0 < p" "INV s = enat n"
  shows "INV t < INV s"
  using assms iadd_le_enat_iff by auto

lemma help2: assumes "enat p + INV t + 1 \<le> INV s"
     "INV s = enat n"
  shows "INV t < INV s"
  using assms le_less_trans not_less_iff_gr_or_eq by fastforce

lemma Seq_sound: assumes "\<Turnstile>\<^sub>2 {P1} C1 {P2}"
    "\<Turnstile>\<^sub>2 {P2} C2 {P3}"
    shows  "\<Turnstile>\<^sub>2 {P1} C1 ;; C2 {P3}"
unfolding hoare2_valid_def
proof (safe)
  fix s
  assume ninfP1: "P1 s < \<infinity>"
  with assms(1)[unfolded hoare2_valid_def] obtain t1 p1
    where 1: "(C1, s) \<Rightarrow> p1 \<Down> t1" and q1: "enat p1 + P2 t1 \<le> P1 s" by blast
  with ninfP1 have ninfP2: "P2 t1 < \<infinity>"
    using not_le by fastforce
  with assms(2)[unfolded hoare2_valid_def] obtain t2 p2
    where 2: "(C2, t1) \<Rightarrow> p2 \<Down> t2" and q2: "enat p2 + P3 t2 \<le> P2 t1" by blast
  with ninfP2 have ninfP3: "P3 t2 < \<infinity>"
    using not_le by fastforce

  from Big_StepT.Seq[OF 1 2] have bigstep: "(C1;; C2, s) \<Rightarrow> p1 + p2 \<Down> t2" by simp
  from help1[OF q1 q2] have potential: "enat (p1 + p2) + P3 t2 \<le> P1 s" .

  show "\<exists>t p. (C1;; C2, s) \<Rightarrow> p \<Down> t \<and> enat p + P3 t \<le> P1 s "
    apply(rule exI[where x="t2"])
    apply(rule exI[where x="p1 + p2"])
    using bigstep potential by simp
qed

theorem hoare2_sound: "\<turnstile>\<^sub>2 {P}c{ Q}  \<Longrightarrow>  \<Turnstile>\<^sub>2 {P}c{ Q}"
proof(induction rule: hoare2.induct)
  case (Skip P)
  show ?case unfolding hoare2_valid_def apply(safe)
    subgoal for s apply(rule exI[where x=s]) apply(rule exI[where x="Suc 0"])
      by (auto simp: eSuc_enat_iff eSuc_enat)
    done
next
  case (Assign P a x)
  show ?case unfolding hoare2_valid_def apply(safe)
    subgoal for s apply(rule exI[where x="s[a/x]"]) apply(rule exI[where x="Suc 0"])
      by (auto simp: eSuc_enat_iff eSuc_enat)
    done
next
  case (Seq P1 C1 P2 C2 P3)
  thus ?case using Seq_sound by auto
next
  case (If P b c1 Q c2)
  show ?case  unfolding hoare2_valid_def
  proof (safe)
    fix s
    assume "eSuc (P s) < \<infinity>"
    then have i: "P s < \<infinity>"
      using enat_ord_simps(4) by fastforce
    show "\<exists>t p. (IF b THEN c1 ELSE c2, s) \<Rightarrow> p \<Down> t \<and> enat p + Q t \<le> eSuc (P s)"
    proof(cases "bval b s")
      case True
      with i have "P s + emb (bval b s) < \<infinity>" by simp
      with If(3)[unfolded hoare2_valid_def] obtain p t
        where 1: "(c1, s) \<Rightarrow> p \<Down> t" and q: "enat p + Q t \<le> P s + emb (bval b s)"  by blast
      from Big_StepT.IfTrue[OF True 1] have 2: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> p + 1 \<Down> t" by simp
      show ?thesis apply(rule exI[where x=t]) apply(rule exI[where x="p+1"])
        apply(safe) apply(fact)
        using q True apply(simp)
        by (metis eSuc_enat eSuc_ile_mono iadd_Suc)
    next
      case False
      with i have "P s + emb (~ bval b s) < \<infinity>" by simp
      with If(4)[unfolded hoare2_valid_def] obtain p t
        where 1: "(c2, s) \<Rightarrow> p \<Down> t" and q: "enat p + Q t \<le> P s + emb (~ bval b s)"  by blast
      from Big_StepT.IfFalse[OF False 1] have 2: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> p + 1 \<Down> t" by simp
      show ?thesis apply(rule exI[where x=t]) apply(rule exI[where x="p+1"])
        apply(safe) apply(fact)
        using q False apply(simp)
        by (metis eSuc_enat eSuc_ile_mono iadd_Suc)
    qed
  qed
next
  case (conseq P c Q P' Q')
  show ?case unfolding hoare2_valid_def
  proof (safe)
    fix s
    assume "P' s < \<infinity>"
    with conseq(2) have "P s < \<infinity>"
      using le_less_trans by blast
    with conseq(4)[unfolded hoare2_valid_def] obtain p t where "(c, s) \<Rightarrow> p \<Down> t" "enat p + Q t \<le> P s" by blast
    with conseq(2,3) show "\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + Q' t \<le> P' s"
      by (meson add_left_mono dual_order.trans)
  qed
next
  case (While INV b c)

  from While(2)[unfolded hoare2_valid_def]
  have WH2: "\<And>s. INV s + \<up> (bval b s) < \<infinity> \<Longrightarrow> (\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> enat p + INV t + 1 \<le> INV s + \<up> (bval b s))"
    by (simp add: add.commute add.left_commute)

  show ?case unfolding hoare2_valid_def
  proof (safe)
    fix s
    assume ninfINV: "INV s + 1 < \<infinity>"
    then have "INV s < \<infinity>"
      using enat_ord_simps(4) by fastforce
    then obtain n where i: "INV s = enat n" using not_infinity_eq
      by auto

    text \<open>In order to prove validity, we induct on the value of the Invariant, which is a finite number
          and decreases in every loop iteration. For each step we show that validity holds.\<close>
    have "INV s = enat n \<Longrightarrow> \<exists>t p. (WHILE b DO c, s) \<Rightarrow> p \<Down> t \<and> enat p + (INV t + emb (\<not> bval b t)) \<le> INV s + 1"
    proof (induct n arbitrary: s rule: less_induct)
      case (less n)
      show ?case
      proof (cases "bval b s")
        case False
        show ?thesis
          using WhileFalse[OF False] one_enat_def by fastforce
      next
        case True
        \<comment> \<open>obtain the loop body from the outer IH\<close>
        with less(2) WH2 obtain t p
          where o: "(c, s) \<Rightarrow> p \<Down> t"
            and q: "enat p + INV t + 1 \<le> INV s " by force

        \<comment> \<open>prepare premises to ...\<close>
        from q have g: "INV t < INV s"
          using help2 less(2) by metis
        then have ninfINVt: "INV t < \<infinity>" using less(2)
          using enat_ord_simps(4) by fastforce
        then obtain n' where i: "INV t = enat n'" using not_infinity_eq
          by auto
        with less(2) have ii: "n' < n"
          using g by auto
        \<comment> \<open>... obtain the tail of the While loop from the inner IH\<close>
        from i ii less(1) obtain t2 p2
          where o2: "(WHILE b DO c, t) \<Rightarrow> p2 \<Down> t2"
            and q2: "enat p2 + (INV t2 + emb (\<not> bval b t2)) \<le> INV t + 1" by blast
        have ende: "~ bval b t2"
          apply(rule ccontr) apply(simp) using q2 ninfINVt
          by (simp add: i one_enat_def)

        \<comment> \<open>combine body and tail to one loop unrolling:\<close>
        \<comment> \<open>- the Bigstep Semantic\<close>
        from WhileTrue[OF True o o2] have BigStep: "(WHILE b DO c, s) \<Rightarrow> 1 + p + p2 \<Down> t2" by simp

        \<comment> \<open>- the potentialPreservation\<close>
        from ende q2 have q2': "enat p2 + INV t2 \<le> INV t + 1" by simp

        have potentialPreservation: "enat (1 + p + p2) + (INV t2 + \<up> (\<not> bval b t2)) \<le> INV s + 1"
        proof -
          have "enat (1 + p + p2) + (INV t2 + \<up> (\<not> bval b t2))
            = enat (Suc (p + p2)) + INV t2" using ende by simp
          also have "\<dots> = enat (Suc p) + enat p2 + INV t2" by fastforce
          also have "\<dots> \<le> enat (Suc p) + INV t + 1" using q2'
            by (metis ab_semigroup_add_class.add_ac(1) add_left_mono)
          also have "\<dots> \<le> INV s + 1" using q
            by (metis (no_types, hide_lams) add.commute add_left_mono eSuc_enat iadd_Suc plus_1_eSuc(1))
          finally show "enat (1 + p + p2) + (INV t2 + \<up> (\<not> bval b t2)) \<le> INV s + 1" .
        qed

        \<comment> \<open>finally combine BigStep Semantic and TimeBound\<close>
        show ?thesis
          apply(rule exI[where x=t2])
          apply(rule exI[where x= "1 + p + p2"])
          apply(safe)
           by(fact BigStep potentialPreservation)+
       qed
     qed
    from this[OF i] show "\<exists>t p. (WHILE b DO c, s) \<Rightarrow> p \<Down> t \<and> enat p + (INV t + emb (\<not> bval b t)) \<le> INV s + 1" .
  qed
qed

subsection "Completeness"

(* the WeakestPrePotential  *)
definition wp2 :: "com \<Rightarrow> qassn \<Rightarrow> qassn" ("wp\<^sub>2") where
"wp\<^sub>2 c Q  =  (\<lambda>s. (if (\<exists>t p. (c,s) \<Rightarrow> p \<Down> t \<and> Q t < \<infinity>)  then enat (THE p. \<exists>t. (c,s) \<Rightarrow> p \<Down> t) + Q (THE t. \<exists>p. (c,s) \<Rightarrow> p \<Down> t) else \<infinity>))"

lemma wp2_alt: "wp\<^sub>2 c Q = (\<lambda>s. (if \<down>(c,s) then enat (\<down>\<^sub>t (c, s)) + Q (\<down>\<^sub>s (c, s)) else \<infinity>))"
  apply(rule ext) by(auto simp: bigstepT_the_state wp2_def split: if_split)

lemma wp2_Assign[simp]: "wp\<^sub>2 (x ::= e) Q = (\<lambda>s. eSuc (Q (s(x := aval e s))))"
by (auto intro!: ext simp: wp2_def ASSp ASSt ASSnot eSuc_enat)

lemma wp2_Seq[simp]: "wp\<^sub>2 (c\<^sub>1;;c\<^sub>2) Q = wp\<^sub>2 c\<^sub>1 (wp\<^sub>2 c\<^sub>2 Q)"
unfolding wp2_def (* what rule is doing: it uses the extensionality (ext) of functions *)
proof (rule, case_tac "\<exists>t p. (c\<^sub>1;; c\<^sub>2, s) \<Rightarrow> p \<Down> t \<and> Q t < \<infinity>", goal_cases)
  case (1 s)
  then obtain u p where ter: "(c\<^sub>1;; c\<^sub>2, s) \<Rightarrow> p \<Down> u" and Q: "Q u < \<infinity>" by blast
  then obtain t p1 p2 where i: "(c\<^sub>1 , s) \<Rightarrow> p1 \<Down> t" and ii: "(c\<^sub>2 , t) \<Rightarrow> p2 \<Down> u" and p: "p1 + p2 = p" by blast

  from bigstepT_the_state[OF i] have t: "\<down>\<^sub>s (c\<^sub>1, s) = t"
    by blast
  from bigstepT_the_state[OF ii] have t2: "\<down>\<^sub>s (c\<^sub>2, t) = u"
    by blast
  from bigstepT_the_cost[OF i] have firstcost: "\<down>\<^sub>t (c\<^sub>1, s) = p1"
    by blast
  from bigstepT_the_cost[OF ii] have secondcost: "\<down>\<^sub>t (c\<^sub>2, t) = p2"
    by blast

  have totalcost: "\<down>\<^sub>t(c\<^sub>1;; c\<^sub>2, s) = p1 + p2"
    using bigstepT_the_cost[OF ter] p by auto
  have totalstate: "\<down>\<^sub>s(c\<^sub>1;; c\<^sub>2, s) = u"
    using bigstepT_the_state[OF ter] by auto

  have c2: "\<exists>ta p. (c\<^sub>2, t) \<Rightarrow> p \<Down> ta \<and> Q ta < \<infinity>"
    apply(rule exI[where x= u])
    apply(rule exI[where x= p2]) apply safe apply fact+ done

  have C: "\<exists>t p. (c\<^sub>1, s) \<Rightarrow> p \<Down> t \<and> (if \<exists>ta p. (c\<^sub>2, t) \<Rightarrow> p \<Down> ta \<and> Q ta < \<infinity> then enat (THE p. Ex (big_step_t (c\<^sub>2, t) p)) + Q (THE ta. \<exists>p. (c\<^sub>2, t) \<Rightarrow> p \<Down> ta) else \<infinity>) < \<infinity>"
    apply(rule exI[where x=t])
    apply(rule exI[where x=p1])
    apply safe
     apply fact
    apply(simp only: c2 if_True)
    using Q bigstepT_the_state ii by auto

  show ?case
    apply(simp only: 1 if_True t t2 c2 C totalcost totalstate firstcost secondcost) by fastforce
next
  case (2 s)
  show ?case apply(simp only: 2 if_False)
    apply auto using 2
    by force
qed

lemma wp2_If[simp]:
 "wp\<^sub>2 (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = (\<lambda>s. eSuc (wp\<^sub>2 (if bval b s then c\<^sub>1 else c\<^sub>2) Q s))"
  apply (auto simp: wp2_def fun_eq_iff)
  subgoal for x t p i ta ia xa apply(simp only: IfTrue[THEN bigstepT_the_state])
    apply(simp only: IfTrue[THEN bigstepT_the_cost])
    apply(simp only: bigstepT_the_cost bigstepT_the_state)
    by (simp add: eSuc_enat)
    apply(simp only: bigstepT_the_state bigstepT_the_cost) apply force
   apply(simp only: bigstepT_the_state bigstepT_the_cost)
proof(goal_cases)
  case (1 x t p i ta ia xa)
  note f= IfFalse[THEN bigstepT_the_state, of b x c\<^sub>2 xa ta "Suc xa" c\<^sub>1, simplified, OF 1(4) 1(5)]
  note f2= IfFalse[THEN bigstepT_the_cost, of b x c\<^sub>2 xa ta "Suc xa" c\<^sub>1, simplified, OF 1(4) 1(5)]
  note g= bigstep_det[OF 1(1) 1(5)]
  show ?case
    apply(simp only: f f2) using 1 g
    by (simp add: eSuc_enat)
next
  case 2
  then
  show ?case
    apply(simp only: bigstepT_the_state bigstepT_the_cost)  apply force done
qed

lemma assumes b: "bval b s"
  shows wp2WhileTrue: " wp\<^sub>2 c (wp\<^sub>2 (WHILE b DO c) Q) s  + 1 \<le> wp\<^sub>2 (WHILE b DO c) Q s"
proof (cases "\<exists>t p. (WHILE b DO c, s) \<Rightarrow> p \<Down> t \<and> Q t < \<infinity>")
  case True
  then obtain t p where w: "(WHILE b DO c, s) \<Rightarrow> p \<Down> t" and q: "Q t < \<infinity>" by blast
  from b w obtain p1 p2 t1 where c: "(c, s) \<Rightarrow> p1 \<Down> t1" and w': "(WHILE b DO c, t1) \<Rightarrow> p2 \<Down> t" and sum: "1 + p1 + p2 = p"
    by auto
  have g: "\<exists>ta p. (WHILE b DO c, t1) \<Rightarrow> p \<Down> ta \<and> Q ta < \<infinity>"
    apply(rule exI[where x="t"])
    apply(rule exI[where x="p2"])
      apply safe apply fact+ done

  have h: "\<exists>t p. (c, s) \<Rightarrow> p \<Down> t \<and> (if \<exists>ta p. (WHILE b DO c, t) \<Rightarrow> p \<Down> ta \<and> Q ta < \<infinity> then enat (THE p. Ex (big_step_t (WHILE b DO c, t) p)) + Q (THE ta. \<exists>p. (WHILE b DO c, t) \<Rightarrow> p \<Down> ta) else \<infinity>) < \<infinity>"
    apply(rule exI[where x="t1"])
    apply(rule exI[where x="p1"])
    apply safe apply fact
    apply(simp only: g if_True) using   bigstepT_the_state bigstepT_the_cost w' q by(auto)

  have "wp\<^sub>2 c (wp\<^sub>2 (WHILE b DO c) Q) s + 1 = enat p + Q t"
    unfolding wp2_def apply(simp only: h if_True)
    apply(simp only: bigstepT_the_state[OF c] bigstepT_the_cost[OF c] g if_True bigstepT_the_state[OF w'] bigstepT_the_cost[OF w']) using sum
    by (metis One_nat_def ab_semigroup_add_class.add_ac(1) add.commute add.right_neutral eSuc_enat plus_1_eSuc(2) plus_enat_simps(1))
  also have "\<dots> = wp\<^sub>2 (WHILE b DO c) Q s"
    unfolding wp2_def apply(simp only: True if_True)
    using bigstepT_the_state bigstepT_the_cost w apply(simp) done
  finally show ?thesis by simp
next
  case False
  have "wp\<^sub>2 (WHILE b DO c) Q s = \<infinity>"
    unfolding wp2_def
    apply(simp only: False if_False) done
  then show ?thesis by auto
qed

lemma assumes b: "bval b s"
shows wp2WhileTrue': "wp\<^sub>2 c (wp\<^sub>2 (WHILE b DO c) Q) s  + 1 = wp\<^sub>2 (WHILE b DO c) Q s"
proof (cases "\<exists>p t. (WHILE b DO c, s) \<Rightarrow> p \<Down> t")
  case True
  then obtain t p where w: "(WHILE b DO c, s) \<Rightarrow> p \<Down> t"  by blast
  from b w obtain p1 p2 t1 where c: "(c, s) \<Rightarrow> p1 \<Down> t1" and w': "(WHILE b DO c, t1) \<Rightarrow> p2 \<Down> t" and sum: "1 + p1 + p2 = p"
    by auto
  then have z: "\<down> (c, s)" and z2: "\<down> (WHILE b DO c, t1)" by auto

  have "wp\<^sub>2 c (wp\<^sub>2 (WHILE b DO c) Q) s + 1 = enat p + Q t"
    unfolding wp2_alt apply(simp only: z if_True)
    apply(simp only: bigstepT_the_state[OF c] bigstepT_the_cost[OF c] z2 if_True bigstepT_the_state[OF w'] bigstepT_the_cost[OF w'])
      using sum
    by (metis One_nat_def ab_semigroup_add_class.add_ac(1) add.commute add.right_neutral eSuc_enat plus_1_eSuc(2) plus_enat_simps(1))
  also have "\<dots> = wp\<^sub>2 (WHILE b DO c) Q s"
    unfolding wp2_alt apply(simp only: True if_True)
    using bigstepT_the_state bigstepT_the_cost w apply(simp) done
  finally show ?thesis by simp
next
  case False
  have "\<not> (\<down> (WHILE b DO c, \<down>\<^sub>s(c,s)) \<and> \<down> (c, s))"
  proof (rule)
    assume P: "\<down> (WHILE b DO c, \<down>\<^sub>s (c, s)) \<and> \<down> (c, s)"
    then obtain t s' where A: "(c,s) \<Rightarrow> t \<Down> s'" by blast
    with A P have "\<down> (WHILE b DO c, s')" using bigstepT_the_state by auto
    then obtain t' s'' where B: "(WHILE b DO c,s') \<Rightarrow> t' \<Down> s''" by auto
    have "(WHILE b DO c, s) \<Rightarrow> 1+t+t' \<Down> s''" apply(rule WhileTrue) using b A B by auto
    then have "\<down> (WHILE b DO c, s)" by auto
    thus "False" using False by auto
  qed
  then have "\<not>\<down> (WHILE b DO c, \<down>\<^sub>s(c,s)) \<or> \<not>\<down> (c, s)" by simp

  then show ?thesis apply rule
    subgoal unfolding wp2_alt apply(simp only: if_False False) by auto
    subgoal unfolding wp2_alt apply(simp only: if_False False) by auto
  done
qed

lemma assumes b: "~ bval b s"
  shows wp2WhileFalse: " Q s  + 1 \<le> wp\<^sub>2 (WHILE b DO c) Q s"
proof (cases "\<exists>t p. (WHILE b DO c, s) \<Rightarrow> p \<Down> t \<and> Q t < \<infinity>")
  case True
  with b obtain t p where w: "(WHILE b DO c, s) \<Rightarrow> p \<Down> t" and "Q t < \<infinity>" by blast
  with b have c: "s=t" "p=Suc 0" by auto
  have " wp\<^sub>2 (WHILE b DO c) Q s =  Q s  + 1"
    unfolding wp2_def apply(simp only: True if_True)
    using w c bigstepT_the_cost bigstepT_the_state by(auto simp add: one_enat_def)
  then show ?thesis by auto
next
  case False
  have "wp\<^sub>2 (WHILE b DO c) Q s = \<infinity>"
    unfolding wp2_def
    apply(simp only: False if_False) done
  then show ?thesis by auto
qed

lemma wp2_is_pre: "\<turnstile>\<^sub>2 {wp\<^sub>2 c Q} c { Q}"
proof (induction c arbitrary: Q)
  case SKIP show ?case by (auto intro: hoare2.Skip)
next
  case Assign show ?case by (auto intro:hoare2.Assign)
next
  case Seq thus ?case by (auto intro:hoare2.Seq)
next
  case (If x1 c1 c2 Q) thus ?case
    apply (auto intro!: hoare2.If )
     apply(rule hoare2.conseq)
       apply(auto)
     apply(rule hoare2.conseq)
      apply(auto)
    done
next
  case (While b c)
  show ?case
    apply(rule conseq)
      apply(rule hoare2.While[where I="%s. (if bval b s then wp\<^sub>2 c (wp\<^sub>2 (WHILE b DO c) Q) s else Q s)"])
      apply(rule conseq)
        apply(rule While[of "wp\<^sub>2 (WHILE b DO c) Q"])
    using wp2While by auto
qed

lemma wp2_is_weakestprePotential1: "\<Turnstile>\<^sub>2 {P}c{Q} \<Longrightarrow> (\<forall>s. wp\<^sub>2 c Q s \<le> P s)"
apply(auto simp: hoare2_valid_def wp2_def)
proof (goal_cases)
  case (1 s t p i)
  show ?case
  proof(cases "P s < \<infinity>")
    case True
    with 1(1) obtain t p' where i: "(c, s) \<Rightarrow> p' \<Down> t" and ii: "enat p' + Q t \<le> P s"
      by auto
    show ?thesis apply(simp add: bigstepT_the_state[OF i] bigstepT_the_cost[OF i] ii) done
  qed simp
qed force

lemma wp2_is_weakestprePotential2: "(\<forall>s. wp\<^sub>2 c Q s \<le> P s) \<Longrightarrow> \<Turnstile>\<^sub>2 {P}c{Q}"
apply(auto simp: hoare2_valid_def wp2_def)
proof (goal_cases)
  case (1 s i)
  then have A: "(if \<exists>t. (\<exists>p. (c, s) \<Rightarrow> p \<Down> t) \<and> (\<exists>i. Q t = enat i) then enat (THE p. Ex (big_step_t (c, s) p)) + Q (THE t. \<exists>p. (c, s) \<Rightarrow> p \<Down> t) else \<infinity>) \<le> P s"
    by fast
  show ?case
  proof (cases "\<exists>t. (\<exists>p. (c, s) \<Rightarrow> p \<Down> t) \<and> (\<exists>i. Q t = enat i)")
    case True
    then obtain t p where i: "(c, s) \<Rightarrow> p \<Down> t" by blast
    from True A have "enat p + Q t \<le> P s" by (simp add: bigstepT_the_cost[OF i] bigstepT_the_state[OF i])
    then have "(c, s) \<Rightarrow> p \<Down> t \<and> enat p + Q t \<le> enat i" using 1(2) i by simp
    then show ?thesis by auto
  next
    case False
    with A have "P s \<ge> \<infinity>" by auto
    then show ?thesis using 1 by auto
  qed
qed

theorem wp2_is_weakestprePotential: "(\<forall>s. wp\<^sub>2 c Q s \<le> P s) \<longleftrightarrow> \<Turnstile>\<^sub>2 {P}c{Q}"
 using   wp2_is_weakestprePotential2  wp2_is_weakestprePotential1 by metis

theorem hoare2_complete: "\<Turnstile>\<^sub>2 {P}c{Q} \<Longrightarrow> \<turnstile>\<^sub>2 {P}c{ Q}"
apply(rule conseq[OF wp2_is_pre, where Q'=Q and Q=Q, simplified])
using wp2_is_weakestprePotential1 by blast

corollary hoare2_sound_complete: " \<turnstile>\<^sub>2 {P}c{Q} \<longleftrightarrow> \<Turnstile>\<^sub>2 {P}c{ Q}"
by (metis hoare2_sound hoare2_complete)

end