(*  Title:       Relational Chains over Lazy Lists
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Relational Chains over Lazy Lists\<close>

theory Lazy_List_Chain
  imports "HOL-Library.BNF_Corec" Lazy_List_Liminf
begin

text \<open>
A chain is a lazy lists of elements such that all pairs of consecutive elements are related by a
given relation. A full chain is either an infinite chain or a finite chain that cannot be extended.
The inspiration for this theory is Section 4.1 (``Theorem Proving Processes'') of Bachmair and
Ganzinger's chapter.
\<close>

subsection \<open>Chains\<close>

coinductive chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> bool" for R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
	chain_singleton: "chain R (LCons x LNil)"
| chain_cons: "chain R xs \<Longrightarrow> R x (lhd xs) \<Longrightarrow> chain R (LCons x xs)"

lemma
  chain_LNil[simp]: "\<not> chain R LNil" and
  chain_not_lnull: "chain R xs \<Longrightarrow> \<not> lnull xs"
  by (auto elim: chain.cases)

lemma chain_lappend:
  assumes
    r_xs: "chain R xs" and
    r_ys: "chain R ys" and
    mid: "R (llast xs) (lhd ys)"
  shows "chain R (lappend xs ys)"
proof (cases "lfinite xs")
  case True
  then show ?thesis
    using r_xs mid
  proof (induct rule: lfinite.induct)
    case (lfinite_LConsI xs x)
    note fin = this(1) and ih = this(2) and r_xxs = this(3) and mid = this(4)
    show ?case
    proof (cases "xs = LNil")
      case True
      then show ?thesis
        using r_ys mid by simp (rule chain_cons)
    next
      case xs_nnil: False
      have r_xs: "chain R xs"
        by (metis chain.simps ltl_simps(2) r_xxs xs_nnil)
      have mid': "R (llast xs) (lhd ys)"
        by (metis llast_LCons lnull_def mid xs_nnil)
      have start: "R x (lhd (lappend xs ys))"
        by (metis (no_types) chain.simps lhd_LCons lhd_lappend chain_not_lnull ltl_simps(2) r_xxs
            xs_nnil)
      show ?thesis
        unfolding lappend_code(2) using ih[OF r_xs mid'] start by (rule chain_cons)
    qed
  qed simp
qed (simp add: r_xs lappend_inf)

lemma chain_length_pos: "chain R xs \<Longrightarrow> llength xs > 0"
  by (cases xs) simp+

lemma chain_ldropn:
  assumes "chain R xs" and "enat n < llength xs"
  shows "chain R (ldropn n xs)"
  using assms
  by (induct n arbitrary: xs, simp,
      metis chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less)

lemma chain_lnth_rel:
  assumes
    chain: "chain R xs" and
    len: "enat (Suc j) < llength xs"
  shows "R (lnth xs j) (lnth xs (Suc j))"
proof -
  define ys where "ys = ldropn j xs"
  have "llength ys > 1"
    unfolding ys_def using len
    by (metis One_nat_def funpow_swap1 ldropn_0 ldropn_def ldropn_eq_LNil ldropn_ltl not_less
        one_enat_def)
  obtain y0 y1 ys' where
    ys: "ys = LCons y0 (LCons y1 ys')"
    unfolding ys_def by (metis Suc_ile_eq ldropn_Suc_conv_ldropn len less_imp_not_less not_less)
  have "chain R ys"
    unfolding ys_def using Suc_ile_eq chain chain_ldropn len less_imp_le by blast
  then have "R y0 y1"
    unfolding ys by (auto elim: chain.cases)
  then show ?thesis
    using ys_def unfolding ys by (metis ldropn_Suc_conv_ldropn ldropn_eq_LConsD llist.inject)
qed

lemma infinite_chain_lnth_rel:
  assumes "\<not> lfinite c" and "chain r c"
  shows "r (lnth c i) (lnth c (Suc i))"
  using assms chain_lnth_rel lfinite_conv_llength_enat by force

lemma lnth_rel_chain:
  assumes
    "\<not> lnull xs" and
    "\<forall>j. enat (j + 1) < llength xs \<longrightarrow> R (lnth xs j) (lnth xs (j + 1))"
  shows "chain R xs"
  using assms
proof (coinduction arbitrary: xs rule: chain.coinduct)
  case chain
  note nnul = this(1) and nth_chain = this(2)

  show ?case
  proof (cases "lnull (ltl xs)")
    case True
    have "xs = LCons (lhd xs) LNil"
      using nnul True by (simp add: llist.expand)
    then show ?thesis
      by blast
  next
    case nnul': False
    moreover have "xs = LCons (lhd xs) (ltl xs)"
      using nnul by simp
    moreover have
      "\<forall>j. enat (j + 1) < llength (ltl xs) \<longrightarrow> R (lnth (ltl xs) j) (lnth (ltl xs) (j + 1))"
      using nnul nth_chain
      by (metis Suc_eq_plus1 ldrop_eSuc_ltl ldropn_Suc_conv_ldropn ldropn_eq_LConsD lnth_ltl)
    moreover have "R (lhd xs) (lhd (ltl xs))"
      using nnul' nnul nth_chain[rule_format, of 0, simplified]
      by (metis ldropn_0 ldropn_Suc_conv_ldropn ldropn_eq_LConsD lhd_LCons_ltl lhd_conv_lnth
          lnth_Suc_LCons ltl_simps(2))
    ultimately show ?thesis
      by blast
  qed
qed

lemma chain_lmap:
  assumes "\<forall>x y. R x y \<longrightarrow> R' (f x) (f y)" and "chain R xs"
  shows "chain R' (lmap f xs)"
  using assms
proof (coinduction arbitrary: xs)
  case chain
  then have "(\<exists>y. xs = LCons y LNil) \<or> (\<exists>ys x. xs = LCons x ys \<and> chain R ys \<and> R x (lhd ys))"
    using chain.simps[of R xs] by auto
  then show ?case
  proof
    assume "\<exists>ys x. xs = LCons x ys \<and> chain R ys \<and> R x (lhd ys)"
    then have "\<exists>ys x. lmap f xs = LCons x ys \<and>
      (\<exists>xs. ys = lmap f xs \<and> (\<forall>x y. R x y \<longrightarrow> R' (f x) (f y)) \<and> chain R xs) \<and> R' x (lhd ys)"
      using chain
      by (metis (no_types) lhd_LCons llist.distinct(1) llist.exhaust_sel llist.map_sel(1)
          lmap_eq_LNil chain_not_lnull ltl_lmap ltl_simps(2))
    then show ?thesis
      by auto
  qed auto
qed

lemma chain_mono:
  assumes "\<forall>x y. R x y \<longrightarrow> R' x y" and "chain R xs"
  shows "chain R' xs"
  using assms by (rule chain_lmap[of _ _ "\<lambda>x. x", unfolded llist.map_ident])

lemma lfinite_chain_imp_rtranclp_lhd_llast: "lfinite xs \<Longrightarrow> chain R xs \<Longrightarrow> R\<^sup>*\<^sup>* (lhd xs) (llast xs)"
proof (induct rule: lfinite.induct)
  case (lfinite_LConsI xs x)
  note fin_xs = this(1) and ih = this(2) and r_x_xs = this(3)
  show ?case
  proof (cases "xs = LNil")
    case xs_nnil: False
    then have r_xs: "chain R xs"
      using r_x_xs by (blast elim: chain.cases)
    then show ?thesis
      using ih[OF r_xs] xs_nnil r_x_xs
      by (metis chain.cases converse_rtranclp_into_rtranclp lhd_LCons llast_LCons chain_not_lnull
          ltl_simps(2))
  qed simp
qed simp

lemma tranclp_imp_exists_finite_chain_list:
  "R\<^sup>+\<^sup>+ x y \<Longrightarrow> \<exists>xs. chain R (llist_of (x # xs @ [y]))"
proof (induct rule: tranclp.induct)
  case (r_into_trancl x y)
  then have "chain R (llist_of (x # [] @ [y]))"
    by (auto intro: chain.intros)
  then show ?case
    by blast
next
  case (trancl_into_trancl x y z)
  note rstar_xy = this(1) and ih = this(2) and r_yz = this(3)

  obtain xs where
    xs: "chain R (llist_of (x # xs @ [y]))"
    using ih by blast
  define ys where
    "ys = xs @ [y]"

  have "chain R (llist_of (x # ys @ [z]))"
    unfolding ys_def using r_yz chain_lappend[OF xs chain_singleton, of z]
    by (auto simp: lappend_llist_of_LCons llast_LCons)
  then show ?case
    by blast
qed

inductive_cases chain_consE: "chain R (LCons x xs)"
inductive_cases chain_nontrivE: "chain R (LCons x (LCons y xs))"

primrec prepend where
  "prepend [] ys = ys"
| "prepend (x # xs) ys = LCons x (prepend xs ys)"

lemma lnull_prepend[simp]: "lnull (prepend xs ys) = (xs = [] \<and> lnull ys)"
  by (induct xs) auto

lemma lhd_prepend[simp]: "lhd (prepend xs ys) = (if xs \<noteq> [] then hd xs else lhd ys)"
  by (induct xs) auto

lemma lfinite_prepend[simp]: "lfinite (prepend xs ys) \<longleftrightarrow> lfinite ys"
  by (induct xs) auto

lemma llength_prepend[simp]: "llength (prepend xs ys) = length xs + llength ys"
  by (induct xs) (auto simp: enat_0 iadd_Suc eSuc_enat[symmetric])

lemma llast_prepend[simp]: "\<not> lnull ys \<Longrightarrow> llast (prepend xs ys) = llast ys"
  by (induct xs) (auto simp: llast_LCons)

lemma prepend_prepend: "prepend xs (prepend ys zs) = prepend (xs @ ys) zs"
  by (induct xs) auto

lemma chain_prepend:
  "chain R (llist_of zs) \<Longrightarrow> last zs = lhd xs \<Longrightarrow> chain R xs \<Longrightarrow> chain R (prepend zs (ltl xs))"
  by (induct zs; cases xs)
    (auto split: if_splits simp: lnull_def[symmetric] intro!: chain_cons elim!: chain_consE)

lemma lmap_prepend[simp]: "lmap f (prepend xs ys) = prepend (map f xs) (lmap f ys)"
  by (induct xs) auto

lemma lset_prepend[simp]: "lset (prepend xs ys) = set xs \<union> lset ys"
  by (induct xs) auto

lemma prepend_LCons: "prepend xs (LCons y ys) = prepend (xs @ [y]) ys"
  by (induct xs) auto

lemma lnth_prepend:
  "lnth (prepend xs ys) i = (if i < length xs then nth xs i else lnth ys (i - length xs))"
  by (induct xs arbitrary: i) (auto simp: lnth_LCons' nth_Cons')

theorem lfinite_less_induct[consumes 1, case_names less]:
  assumes fin: "lfinite xs"
    and step: "\<And>xs. lfinite xs \<Longrightarrow> (\<And>zs. llength zs < llength xs \<Longrightarrow> P zs) \<Longrightarrow> P xs"
  shows "P xs"
using fin proof (induct "the_enat (llength xs)" arbitrary: xs rule: less_induct)
  case (less xs)
  show ?case
    using less(2) by (intro step[OF less(2)] less(1))
      (auto dest!: lfinite_llength_enat simp: eSuc_enat elim!: less_enatE llength_eq_enat_lfiniteD)
qed

theorem lfinite_prepend_induct[consumes 1, case_names LNil prepend]:
  assumes "lfinite xs"
    and LNil: "P LNil"
    and prepend: "\<And>xs. lfinite xs \<Longrightarrow> (\<And>zs. (\<exists>ys. xs = prepend ys zs \<and> ys \<noteq> []) \<Longrightarrow> P zs) \<Longrightarrow> P xs"
  shows "P xs"
using assms(1) proof (induct xs rule: lfinite_less_induct)
  case (less xs)
  from less(1) show ?case
    by (cases xs)
      (force simp: LNil neq_Nil_conv dest: lfinite_llength_enat intro!: prepend[of "LCons _ _"] intro: less)+
qed

coinductive emb :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> bool" where
  "lfinite xs \<Longrightarrow> emb LNil xs"
| "emb xs ys \<Longrightarrow> emb (LCons x xs) (prepend zs (LCons x ys))"

inductive_cases emb_LConsE: "emb (LCons z zs) ys"
inductive_cases emb_LNil1E: "emb LNil ys"
inductive_cases emb_LNil2E: "emb xs LNil"

lemma emb_lfinite:
  assumes "emb xs ys"
  shows "lfinite ys \<longleftrightarrow> lfinite xs"
proof
  assume "lfinite xs"
  then show "lfinite ys" using assms
    by (induct xs arbitrary: ys rule: lfinite_induct)
      (auto simp: lnull_def neq_LNil_conv elim!: emb_LNil1E emb_LConsE)
next
  assume "lfinite ys"
  then show "lfinite xs" using assms
  proof (induction ys arbitrary: xs rule: lfinite_less_induct)
    case (less ys)
    from less.prems \<open>lfinite ys\<close> show ?case
      by (cases xs)
        (auto simp: eSuc_enat elim!: emb_LNil1E emb_LConsE less.IH[rotated] dest!: lfinite_llength_enat)
  qed
qed

inductive prepend_cong1 for X where
  prepend_cong1_base: "X xs \<Longrightarrow> prepend_cong1 X xs"
| prepend_cong1_prepend: "prepend_cong1 X ys \<Longrightarrow> prepend_cong1 X (prepend xs ys)"

lemma emb_prepend_coinduct[rotated, case_names emb]:
  assumes "(\<And>x1 x2. X x1 x2 \<Longrightarrow>
    (\<exists>xs. x1 = LNil \<and> x2 = xs \<and> lfinite xs)
     \<or> (\<exists>xs ys x zs. x1 = LCons x xs \<and> x2 = prepend zs (LCons x ys)
       \<and> (prepend_cong1 (X xs) ys \<or> emb xs ys)))" (is "\<And>x1 x2. X x1 x2 \<Longrightarrow> ?bisim x1 x2")
  shows "X x1 x2 \<Longrightarrow> emb x1 x2"
proof (erule emb.coinduct[OF prepend_cong1_base])
  fix xs zs
  assume "prepend_cong1 (X xs) zs"
  then show "?bisim xs zs"
    by (induct zs rule: prepend_cong1.induct) (erule assms, force simp: prepend_prepend)
qed

context
begin

private coinductive chain' for R where
  "chain' R (LCons x LNil)"
| "chain R (llist_of (x # zs @ [lhd xs])) \<Longrightarrow>
   chain' R xs \<Longrightarrow> chain' R (LCons x (prepend zs xs))"

private lemma chain_imp_chain': "chain R xs \<Longrightarrow> chain' R xs"
proof (coinduction arbitrary: xs rule: chain'.coinduct)
  case chain'
  then show ?case
  proof (cases rule: chain.cases)
    case (chain_cons zs z)
    then show ?thesis
      by (intro disjI2 exI[of _ z] exI[of _ "[]"] exI[of _ "zs"])
        (auto intro: chain.intros)
  qed simp
qed

private lemma chain'_imp_chain: "chain' R xs \<Longrightarrow> chain R xs"
proof (coinduction arbitrary: xs rule: chain.coinduct)
  case chain
  then show ?case
  proof (cases rule: chain'.cases)
    case (2 y zs ys)
    then show ?thesis
      by (intro disjI2 exI[of _ "prepend zs ys"] exI[of _ y])
        (force dest!: neq_Nil_conv[THEN iffD1] elim: chain.cases chain_nontrivE
          intro: chain'.intros)
  qed simp
qed

private lemma chain_chain': "chain = chain'"
  unfolding fun_eq_iff by (metis chain_imp_chain' chain'_imp_chain)

lemma chain_prepend_coinduct[case_names chain]:
  "X x \<Longrightarrow> (\<And>x. X x \<Longrightarrow>
    (\<exists>z. x = LCons z LNil) \<or>
    (\<exists>y xs zs. x = LCons y (prepend zs xs) \<and>
      (X xs \<or> chain R xs) \<and> chain R (llist_of (y # zs @ [lhd xs])))) \<Longrightarrow> chain R x"
  by (subst chain_chain', erule chain'.coinduct) (force simp: chain_chain')

end

context
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

private definition pick where
  "pick x y = (SOME xs. chain R (llist_of (x # xs @ [y])))"

private lemma pick[simp]:
  assumes "R\<^sup>+\<^sup>+ x y"
  shows "chain R (llist_of (x # pick x y @ [y]))"
  unfolding pick_def using tranclp_imp_exists_finite_chain_list[THEN someI_ex, OF assms] by auto

private friend_of_corec prepend where
  "prepend xs ys = (case xs of [] \<Rightarrow>
    (case ys of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons x xs) | x # xs' \<Rightarrow> LCons x (prepend xs' ys))"
  by (simp split: list.splits llist.splits) transfer_prover

private corec wit where
  "wit xs = (case xs of LCons x (LCons y xs) \<Rightarrow>
     LCons x (prepend (pick x y) (wit (LCons y xs))) | _ \<Rightarrow> xs)"

private lemma
  wit_LNil[simp]: "wit LNil = LNil" and
  wit_lsingleton[simp]: "wit (LCons x LNil) = LCons x LNil" and
  wit_LCons2: "wit (LCons x (LCons y xs)) =
     (LCons x (prepend (pick x y) (wit (LCons y xs))))"
  by (subst wit.code; auto)+

private lemma lnull_wit[simp]: "lnull (wit xs) \<longleftrightarrow> lnull xs"
  by (subst wit.code) (auto split: llist.splits simp: Let_def)

private lemma lhd_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow> lhd (wit xs) = lhd xs"
  by (erule chain.cases; subst wit.code) (auto split: llist.splits simp: Let_def)

private lemma LNil_eq_iff_lnull: "LNil = xs \<longleftrightarrow> lnull xs"
  by (cases xs) auto

lemma emb_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow> emb xs (wit xs)"
proof (coinduction arbitrary: xs rule: emb_prepend_coinduct)
  case (emb xs)
  then show ?case
  proof (cases rule: chain.cases)
    case (chain_cons zs z)
    then show ?thesis
      by (subst (2) wit.code)
        (auto split: llist.splits intro!: exI[of _ "[]"] exI[of _ "_ :: _ llist"]
          prepend_cong1_prepend[OF prepend_cong1_base])
  qed (auto intro!: exI[of _ LNil] exI[of _ "[]"] emb.intros)
qed

private

private lemma llast_wit[simp]:
  assumes "chain R\<^sup>+\<^sup>+ xs"
  shows "llast (wit xs) = llast xs"
proof (cases "lfinite xs")
  case True
  from this assms show ?thesis
  proof (induct rule: lfinite.induct)
    case (lfinite_LConsI xs x)
    then show ?case
      by (cases xs) (auto simp: wit_LCons2 llast_LCons elim: chain_nontrivE)
  qed auto
qed (auto simp: llast_linfinite assms)

lemma chain_tranclp_imp_exists_chain:
  "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow>
   \<exists>ys. chain R ys \<and> emb xs ys \<and> lhd ys = lhd xs \<and> llast ys = llast xs"
proof (intro exI[of _ "wit xs"] conjI, coinduction arbitrary: xs rule: chain_prepend_coinduct)
  case chain
  then show ?case
    by (subst (1 2) wit.code) (erule chain.cases; force split: llist.splits dest: pick)
qed auto

lemma emb_Ball_lset_antimono:
  assumes "emb Xs Ys"
  shows "\<forall>Y \<in> lset Ys. x \<in> Y \<Longrightarrow> \<forall>X \<in> lset Xs. x \<in> X"
  using emb_lset_mono[OF assms] by blast

lemma emb_lfinite_antimono[rotated]: "lfinite ys \<Longrightarrow> emb xs ys \<Longrightarrow> lfinite xs"
  by (induct ys arbitrary: xs rule: lfinite_prepend_induct)
    (force elim!: emb_LNil2E simp: LNil_eq_iff_lnull prepend_LCons elim: emb.cases)+

lemma emb_Liminf_llist_mono_aux:
  assumes "emb Xs Ys" and "\<not> lfinite Xs" and "\<not> lfinite Ys" and "\<forall>j\<ge>i. x \<in> lnth Ys j"
  shows "\<forall>j\<ge>i. x \<in> lnth Xs j"
using assms proof (induct i arbitrary: Xs Ys rule: less_induct)
  case (less i)
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using emb_Ball_lset_antimono[OF less(2), of x] less(5)
      unfolding Ball_def in_lset_conv_lnth simp_thms
        not_lfinite_llength[OF less(3)] not_lfinite_llength[OF less(4)] enat_ord_code subset_eq
      by blast
  next
    case [simp]: (Suc nat)
    from less(2,3) obtain xs as b bs where
      [simp]: "Xs = LCons b xs" "Ys = prepend as (LCons b bs)" and "emb xs bs"
      by (auto elim: emb.cases)
    have IH: "\<forall>k\<ge>j. x \<in> lnth xs k" if "\<forall>k\<ge>j. x \<in> lnth bs k" "j < i" for j
      using that less(1)[OF _ \<open>emb xs bs\<close>] less(3,4) by auto
    from less(5) have "\<forall>k\<ge>i - length as - 1. x \<in> lnth xs k"
      by (intro IH allI)
        (drule spec[of _ "_ + length as + 1"], auto simp: lnth_prepend lnth_LCons')
    then show ?thesis
      by (auto simp: lnth_LCons')
  qed
qed

lemma emb_Liminf_llist_infinite:
  assumes "emb Xs Ys" and "\<not> lfinite Xs"
  shows "Liminf_llist Ys \<subseteq> Liminf_llist Xs"
proof -
  from assms have "\<not> lfinite Ys"
    using emb_lfinite_antimono by blast
  with assms show ?thesis
    unfolding Liminf_llist_def by (auto simp: not_lfinite_llength dest: emb_Liminf_llist_mono_aux)
qed

lemma emb_lmap: "emb xs ys \<Longrightarrow> emb (lmap f xs) (lmap f ys)"
proof (coinduction arbitrary: xs ys rule: emb.coinduct)
  case emb
  show ?case
  proof (cases xs)
    case xs: (LCons x xs')

    obtain ysa0 and zs0 where
      ys: "ys = prepend zs0 (LCons x ysa0)" and
      emb': "emb xs' ysa0"
      using emb_LConsE[OF emb[unfolded xs]] by metis

    let ?xa = "f x"
    let ?xsa = "lmap f xs'"
    let ?zs = "map f zs0"
    let ?ysa = "lmap f ysa0"

    have "lmap f xs = LCons ?xa ?xsa"
      unfolding xs by simp
    moreover have "lmap f ys = prepend ?zs (LCons ?xa ?ysa)"
      unfolding ys by simp
    moreover have "\<exists>xsa ysa. ?xsa = lmap f xsa \<and> ?ysa = lmap f ysa \<and> emb xsa ysa"
      using emb' by blast
    ultimately show ?thesis
      by blast
  qed (simp add: emb_lfinite[OF emb])
qed

end

lemma chain_inf_llist_if_infinite_chain_function:
  assumes "\<forall>i. r (f (Suc i)) (f i)"
  shows "\<not> lfinite (inf_llist f) \<and> chain r\<inverse>\<inverse> (inf_llist f)"
  using assms by (simp add: lnth_rel_chain)

lemma infinite_chain_function_iff_infinite_chain_llist:
  "(\<exists>f. \<forall>i. r (f (Suc i)) (f i)) \<longleftrightarrow> (\<exists>c. \<not> lfinite c \<and> chain r\<inverse>\<inverse> c)"
  using chain_inf_llist_if_infinite_chain_function infinite_chain_lnth_rel by blast

lemma wfP_iff_no_infinite_down_chain_llist: "wfP r \<longleftrightarrow> (\<nexists>c. \<not> lfinite c \<and> chain r\<inverse>\<inverse> c)"
proof -
  have "wfP r \<longleftrightarrow>  wf {(x, y). r x y}"
    unfolding wfP_def by auto
  also have "\<dots> \<longleftrightarrow> (\<nexists>f. \<forall>i. (f (Suc i), f i) \<in> {(x, y). r x y})"
    using wf_iff_no_infinite_down_chain by blast
  also have "\<dots> \<longleftrightarrow> (\<nexists>f. \<forall>i. r (f (Suc i)) (f i))"
    by auto
  also have "\<dots> \<longleftrightarrow> (\<nexists>c. \<not>lfinite c \<and> chain r\<inverse>\<inverse> c)"
    using infinite_chain_function_iff_infinite_chain_llist by blast
  finally show ?thesis
    by auto
qed

subsection \<open>Full Chains\<close>

coinductive full_chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> bool" for R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
	full_chain_singleton: "(\<forall>y. \<not> R x y) \<Longrightarrow> full_chain R (LCons x LNil)"
| full_chain_cons: "full_chain R xs \<Longrightarrow> R x (lhd xs) \<Longrightarrow> full_chain R (LCons x xs)"

lemma
  full_chain_LNil[simp]: "\<not> full_chain R LNil" and
  full_chain_not_lnull: "full_chain R xs \<Longrightarrow> \<not> lnull xs"
  by (auto elim: full_chain.cases)

lemma full_chain_ldropn:
  assumes full: "full_chain R xs" and "enat n < llength xs"
  shows "full_chain R (ldropn n xs)"
  using assms
  by (induct n arbitrary: xs, simp,
      metis full_chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less)

lemma full_chain_iff_chain:
  "full_chain R xs \<longleftrightarrow> chain R xs \<and> (lfinite xs \<longrightarrow> (\<forall>y. \<not> R (llast xs) y))"
proof (intro iffI conjI impI allI; (elim conjE)?)
  assume full: "full_chain R xs"

  show chain: "chain R xs"
    using full by (coinduction arbitrary: xs) (auto elim: full_chain.cases)

  {
    fix y
    assume "lfinite xs"
    then obtain n where
      suc_n: "Suc n = llength xs"
      by (metis chain chain_length_pos lessE less_enatE lfinite_conv_llength_enat)

    have "full_chain R (ldropn n xs)"
      by (rule full_chain_ldropn[OF full]) (use suc_n Suc_ile_eq in force)
    moreover have "ldropn n xs = LCons (llast xs) LNil"
      using suc_n by (metis enat_le_plus_same(2) enat_ord_simps(2) gen_llength_def
          ldropn_Suc_conv_ldropn ldropn_all lessI llast_ldropn llast_singleton llength_code)
    ultimately show "\<not> R (llast xs) y"
      by (auto elim: full_chain.cases)
  }
next
  assume
    "chain R xs" and
    "lfinite xs \<longrightarrow> (\<forall>y. \<not> R (llast xs) y)"
  then show "full_chain R xs"
    by (coinduction arbitrary: xs) (erule chain.cases, simp, metis lfinite_LConsI llast_LCons)
qed

lemma full_chain_imp_chain: "full_chain R xs \<Longrightarrow> chain R xs"
  using full_chain_iff_chain by blast

lemma full_chain_length_pos: "full_chain R xs \<Longrightarrow> llength xs > 0"
  by (fact chain_length_pos[OF full_chain_imp_chain])

lemma full_chain_lnth_rel:
  "full_chain R xs \<Longrightarrow> enat (Suc j) < llength xs \<Longrightarrow> R (lnth xs j) (lnth xs (Suc j))"
  by (fact chain_lnth_rel[OF full_chain_imp_chain])

inductive_cases full_chain_consE: "full_chain R (LCons x xs)"
inductive_cases full_chain_nontrivE: "full_chain R (LCons x (LCons y xs))"

lemma full_chain_tranclp_imp_exists_full_chain:
  assumes full: "full_chain R\<^sup>+\<^sup>+ xs"
  shows "\<exists>ys. full_chain R ys \<and> emb xs ys \<and> lhd ys = lhd xs \<and> llast ys = llast xs"
proof -
  obtain ys where ys:
    "chain R ys" "emb xs ys" "lhd ys = lhd xs" "llast ys = llast xs"
    using full_chain_imp_chain[OF full] chain_tranclp_imp_exists_chain by blast
  have "full_chain R ys"
    using ys(1,4) emb_lfinite[OF ys(2)] full unfolding full_chain_iff_chain by auto
  then show ?thesis
    using ys(2-4) by auto
qed

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun third :: "Nat => Nat" where
"third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"

fun twoThirds :: "Nat => Nat" where
"twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
"sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
"take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "Nat => 'a list => 'a list" where
"drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
         and nstoogesort2 :: "Nat list => Nat list"
         and nstooge2sort1 :: "Nat list => Nat list" where
"nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (nstoogesort2 xs) xs"
  oops

end


(*<*)
theory Itrev
imports Main
begin
declare [[names_unique = false]]
(*>*)

section{*Induction Heuristics*}

text{*\label{sec:InductionHeuristics}
\index{induction heuristics|(}%
The purpose of this section is to illustrate some simple heuristics for
inductive proofs. The first one we have already mentioned in our initial
example:
\begin{quote}
\emph{Theorems about recursive functions are proved by induction.}
\end{quote}
In case the function has more than one argument
\begin{quote}
\emph{Do induction on argument number $i$ if the function is defined by
recursion in argument number $i$.}
\end{quote}
When we look at the proof of @{text"(xs@ys) @ zs = xs @ (ys@zs)"}
in \S\ref{sec:intro-proof} we find
\begin{itemize}
\item @{text"@"} is recursive in
the first argument
\item @{term xs}  occurs only as the first argument of
@{text"@"}
\item both @{term ys} and @{term zs} occur at least once as
the second argument of @{text"@"}
\end{itemize}
Hence it is natural to perform induction on~@{term xs}.

The key heuristic, and the main point of this section, is to
\emph{generalize the goal before induction}.
The reason is simple: if the goal is
too specific, the induction hypothesis is too weak to allow the induction
step to go through. Let us illustrate the idea with an example.

Function \cdx{rev} has quadratic worst-case running time
because it calls function @{text"@"} for each element of the list and
@{text"@"} is linear in its first argument.  A linear time version of
@{term"rev"} reqires an extra argument where the result is accumulated
gradually, using only~@{text"#"}:
*}

primrec itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev []     ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

text{*\noindent
The behaviour of \cdx{itrev} is simple: it reverses
its first argument by stacking its elements onto the second argument,
and returning that second argument when the first one becomes
empty. Note that @{term"itrev"} is tail-recursive: it can be
compiled into a loop.

Naturally, we would like to show that @{term"itrev"} does indeed reverse
its first argument provided the second one is empty:
*}

lemma "itrev xs [] = rev xs"

txt{*\noindent
There is no choice as to the induction variable, and we immediately simplify:
*}

apply(induct_tac xs, simp_all)

txt{*\noindent
Unfortunately, this attempt does not prove
the induction step:
@{subgoals[display,indent=0,margin=70]}
The induction hypothesis is too weak.  The fixed
argument,~@{term"[]"}, prevents it from rewriting the conclusion.
This example suggests a heuristic:
\begin{quote}\index{generalizing induction formulae}%
\emph{Generalize goals for induction by replacing constants by variables.}
\end{quote}
Of course one cannot do this na\"{\i}vely: @{term"itrev xs ys = rev xs"} is
just not true.  The correct generalization is
*}
(*<*)oops(*>*)
lemma "itrev xs ys = rev xs @ ys"
(*<*)apply(induct_tac xs, simp_all)(*>*)
txt{*\noindent
If @{term"ys"} is replaced by @{term"[]"}, the right-hand side simplifies to
@{term"rev xs"}, as required.

In this instance it was easy to guess the right generalization.
Other situations can require a good deal of creativity.

Although we now have two variables, only @{term"xs"} is suitable for
induction, and we repeat our proof attempt. Unfortunately, we are still
not there:
@{subgoals[display,indent=0,goals_limit=1]}
The induction hypothesis is still too weak, but this time it takes no
intuition to generalize: the problem is that @{term"ys"} is fixed throughout
the subgoal, but the induction hypothesis needs to be applied with
@{term"a # ys"} instead of @{term"ys"}. Hence we prove the theorem
for all @{term"ys"} instead of a fixed one:
*}
(*<*)oops(*>*)
lemma "\<forall>ys. itrev xs ys = rev xs @ ys"
(*<*)
by(induct_tac xs, simp_all)
(*>*)

text{*\noindent
This time induction on @{term"xs"} followed by simplification succeeds. This
leads to another heuristic for generalization:
\begin{quote}
\emph{Generalize goals for induction by universally quantifying all free
variables {\em(except the induction variable itself!)}.}
\end{quote}
This prevents trivial failures like the one above and does not affect the
validity of the goal.  However, this heuristic should not be applied blindly.
It is not always required, and the additional quantifiers can complicate
matters in some cases. The variables that should be quantified are typically
those that change in recursive calls.

A final point worth mentioning is the orientation of the equation we just
proved: the more complex notion (@{const itrev}) is on the left-hand
side, the simpler one (@{term rev}) on the right-hand side. This constitutes
another, albeit weak heuristic that is not restricted to induction:
\begin{quote}
  \emph{The right-hand side of an equation should (in some sense) be simpler
    than the left-hand side.}
\end{quote}
This heuristic is tricky to apply because it is not obvious that
@{term"rev xs @ ys"} is simpler than @{term"itrev xs ys"}. But see what
happens if you try to prove @{prop"rev xs @ ys = itrev xs ys"}!

If you have tried these heuristics and still find your
induction does not go through, and no obvious lemma suggests itself, you may
need to generalize your proposition even further. This requires insight into
the problem at hand and is beyond simple rules of thumb.
Additionally, you can read \S\ref{sec:advanced-ind}
to learn about some advanced techniques for inductive proofs.%
\index{induction heuristics|)}
*}
(*<*)
declare [[names_unique = true]]
end
(*>*)


section \<open>Bounded Continuous Functions\<close>

theory Bounded_Continuous_Function
  imports
    Topology_Euclidean_Space
    Uniform_Limit
begin

subsection \<open>Definition\<close>

definition\<^marker>\<open>tag important\<close> "bcontfun = {f. continuous_on UNIV f \<and> bounded (range f)}"

typedef (overloaded) ('a, 'b) bcontfun ("(_ \<Rightarrow>\<^sub>C /_)" [22, 21] 21) =
  "bcontfun::('a::topological_space \<Rightarrow> 'b::metric_space) set"
  morphisms apply_bcontfun Bcontfun
  by (auto intro: continuous_intros simp: bounded_def bcontfun_def)

declare [[coercion "apply_bcontfun :: ('a::topological_space \<Rightarrow>\<^sub>C'b::metric_space) \<Rightarrow> 'a \<Rightarrow> 'b"]]

setup_lifting type_definition_bcontfun

lemma continuous_on_apply_bcontfun[intro, simp]: "continuous_on T (apply_bcontfun x)"
  and bounded_apply_bcontfun[intro, simp]: "bounded (range (apply_bcontfun x))"
  using apply_bcontfun[of x]
  by (auto simp: bcontfun_def intro: continuous_on_subset)

lemma bcontfun_eqI: "(\<And>x. apply_bcontfun f x = apply_bcontfun g x) \<Longrightarrow> f = g"
  by transfer auto

lemma bcontfunE:
  assumes "f \<in> bcontfun"
  obtains g where "f = apply_bcontfun g"
  by (blast intro: apply_bcontfun_cases assms )

lemma const_bcontfun: "(\<lambda>x. b) \<in> bcontfun"
  by (auto simp: bcontfun_def image_def)

lift_definition const_bcontfun::"'b::metric_space \<Rightarrow> ('a::topological_space \<Rightarrow>\<^sub>C 'b)" is "\<lambda>c _. c"
  by (rule const_bcontfun)

(* TODO: Generalize to uniform spaces? *)
instantiation bcontfun :: (topological_space, metric_space) metric_space
begin

lift_definition\<^marker>\<open>tag important\<close> dist_bcontfun :: "'a \<Rightarrow>\<^sub>C 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>C 'b \<Rightarrow> real"
  is "\<lambda>f g. (SUP x. dist (f x) (g x))" .

definition uniformity_bcontfun :: "('a \<Rightarrow>\<^sub>C 'b \<times> 'a \<Rightarrow>\<^sub>C 'b) filter"
  where "uniformity_bcontfun = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition open_bcontfun :: "('a \<Rightarrow>\<^sub>C 'b) set \<Rightarrow> bool"
  where "open_bcontfun S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"

lemma bounded_dist_le_SUP_dist:
  "bounded (range f) \<Longrightarrow> bounded (range g) \<Longrightarrow> dist (f x) (g x) \<le> (SUP x. dist (f x) (g x))"
  by (auto intro!: cSUP_upper bounded_imp_bdd_above bounded_dist_comp)

lemma dist_bounded:
  fixes f g :: "'a \<Rightarrow>\<^sub>C 'b"
  shows "dist (f x) (g x) \<le> dist f g"
  by transfer (auto intro!: bounded_dist_le_SUP_dist simp: bcontfun_def)

lemma dist_bound:
  fixes f g :: "'a \<Rightarrow>\<^sub>C 'b"
  assumes "\<And>x. dist (f x) (g x) \<le> b"
  shows "dist f g \<le> b"
  using assms
  by transfer (auto intro!: cSUP_least)

lemma dist_fun_lt_imp_dist_val_lt:
  fixes f g :: "'a \<Rightarrow>\<^sub>C 'b"
  assumes "dist f g < e"
  shows "dist (f x) (g x) < e"
  using dist_bounded assms by (rule le_less_trans)

instance
proof
  fix f g h :: "'a \<Rightarrow>\<^sub>C 'b"
  show "dist f g = 0 \<longleftrightarrow> f = g"
  proof
    have "\<And>x. dist (f x) (g x) \<le> dist f g"
      by (rule dist_bounded)
    also assume "dist f g = 0"
    finally show "f = g"
      by (auto simp: apply_bcontfun_inject[symmetric])
  qed (auto simp: dist_bcontfun_def intro!: cSup_eq)
  show "dist f g \<le> dist f h + dist g h"
  proof (rule dist_bound)
    fix x
    have "dist (f x) (g x) \<le> dist (f x) (h x) + dist (g x) (h x)"
      by (rule dist_triangle2)
    also have "dist (f x) (h x) \<le> dist f h"
      by (rule dist_bounded)
    also have "dist (g x) (h x) \<le> dist g h"
      by (rule dist_bounded)
    finally show "dist (f x) (g x) \<le> dist f h + dist g h"
      by simp
  qed
qed (rule open_bcontfun_def uniformity_bcontfun_def)+

end

lift_definition PiC::"'a::topological_space set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow>\<^sub>C 'b::metric_space) set"
  is "\<lambda>I X. Pi I X \<inter> bcontfun"
  by auto

lemma mem_PiC_iff: "x \<in> PiC I X \<longleftrightarrow> apply_bcontfun x \<in> Pi I X"
  by transfer simp

lemmas mem_PiCD = mem_PiC_iff[THEN iffD1]
  and mem_PiCI = mem_PiC_iff[THEN iffD2]

lemma tendsto_bcontfun_uniform_limit:
  fixes f::"'i \<Rightarrow> 'a::topological_space \<Rightarrow>\<^sub>C 'b::metric_space"
  assumes "(f \<longlongrightarrow> l) F"
  shows "uniform_limit UNIV f l F"
proof (rule uniform_limitI)
  fix e::real assume "e > 0"
  from tendstoD[OF assms this] have "\<forall>\<^sub>F x in F. dist (f x) l < e" .
  then show "\<forall>\<^sub>F n in F. \<forall>x\<in>UNIV. dist ((f n) x) (l x) < e"
    by eventually_elim (auto simp: dist_fun_lt_imp_dist_val_lt)
qed

lemma uniform_limit_tendsto_bcontfun:
  fixes f::"'i \<Rightarrow> 'a::topological_space \<Rightarrow>\<^sub>C 'b::metric_space"
    and l::"'a::topological_space \<Rightarrow>\<^sub>C 'b::metric_space"
  assumes "uniform_limit UNIV f l F"
  shows "(f \<longlongrightarrow> l) F"
proof (rule tendstoI)
  fix e::real assume "e > 0"
  then have "e / 2 > 0" by simp
  from uniform_limitD[OF assms this]
  have "\<forall>\<^sub>F i in F. \<forall>x. dist (f i x) (l x) < e / 2" by simp
  then have "\<forall>\<^sub>F x in F. dist (f x) l \<le> e / 2"
    by eventually_elim (blast intro: dist_bound less_imp_le)
  then show "\<forall>\<^sub>F x in F. dist (f x) l < e"
    by eventually_elim (use \<open>0 < e\<close> in auto)
qed

lemma uniform_limit_bcontfunE:
  fixes f::"'i \<Rightarrow> 'a::topological_space \<Rightarrow>\<^sub>C 'b::metric_space"
    and l::"'a::topological_space \<Rightarrow> 'b::metric_space"
  assumes "uniform_limit UNIV f l F" "F \<noteq> bot"
  obtains l'::"'a::topological_space \<Rightarrow>\<^sub>C 'b::metric_space"
  where "l = l'" "(f \<longlongrightarrow> l') F"
  by (metis (mono_tags, lifting) always_eventually apply_bcontfun apply_bcontfun_cases assms
      bcontfun_def mem_Collect_eq uniform_limit_bounded uniform_limit_tendsto_bcontfun
      uniform_limit_theorem)

lemma closed_PiC:
  fixes I :: "'a::metric_space set"
    and X :: "'a \<Rightarrow> 'b::complete_space set"
  assumes "\<And>i. i \<in> I \<Longrightarrow> closed (X i)"
  shows "closed (PiC I X)"
  unfolding closed_sequential_limits
proof safe
  fix f l
  assume seq: "\<forall>n. f n \<in> PiC I X" and lim: "f \<longlonglongrightarrow> l"
  show "l \<in> PiC I X"
  proof (safe intro!: mem_PiCI)
    fix x assume "x \<in> I"
    then have "closed (X x)"
      using assms by simp
    moreover have "eventually (\<lambda>i. f i x \<in> X x) sequentially"
      using seq \<open>x \<in> I\<close>
      by (auto intro!: eventuallyI dest!: mem_PiCD simp: Pi_iff)
    moreover note sequentially_bot
    moreover have "(\<lambda>n. (f n) x) \<longlonglongrightarrow> l x"
      using tendsto_bcontfun_uniform_limit[OF lim]
      by (rule tendsto_uniform_limitI) simp
    ultimately show "l x \<in> X x"
      by (rule Lim_in_closed_set)
  qed
qed

subsection \<open>Complete Space\<close>

instance\<^marker>\<open>tag important\<close> bcontfun :: (metric_space, complete_space) complete_space
proof
  fix f :: "nat \<Rightarrow> ('a, 'b) bcontfun"
  assume "Cauchy f"  \<comment> \<open>Cauchy equals uniform convergence\<close>
  then obtain g where "uniform_limit UNIV f g sequentially"
    using uniformly_convergent_eq_cauchy[of "\<lambda>_. True" f]
    unfolding Cauchy_def uniform_limit_sequentially_iff
    by (metis dist_fun_lt_imp_dist_val_lt)

  from uniform_limit_bcontfunE[OF this sequentially_bot]
  obtain l' where "g = apply_bcontfun l'" "(f \<longlonglongrightarrow> l')" by metis
  then show "convergent f"
    by (intro convergentI)
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>Supremum norm for a normed vector space\<close>

instantiation\<^marker>\<open>tag unimportant\<close> bcontfun :: (topological_space, real_normed_vector) real_vector
begin

lemma uminus_cont: "f \<in> bcontfun \<Longrightarrow> (\<lambda>x. - f x) \<in> bcontfun" for f::"'a \<Rightarrow> 'b"
  by (auto simp: bcontfun_def intro!: continuous_intros)

lemma plus_cont: "f \<in> bcontfun \<Longrightarrow> g \<in> bcontfun \<Longrightarrow> (\<lambda>x. f x + g x) \<in> bcontfun" for f g::"'a \<Rightarrow> 'b"
  by (auto simp: bcontfun_def intro!: continuous_intros bounded_plus_comp)

lemma minus_cont: "f \<in> bcontfun \<Longrightarrow> g \<in> bcontfun \<Longrightarrow> (\<lambda>x. f x - g x) \<in> bcontfun" for f g::"'a \<Rightarrow> 'b"
  by (auto simp: bcontfun_def intro!: continuous_intros bounded_minus_comp)

lemma scaleR_cont: "f \<in> bcontfun \<Longrightarrow> (\<lambda>x. a *\<^sub>R f x) \<in> bcontfun" for f :: "'a \<Rightarrow> 'b"
  by (auto simp: bcontfun_def intro!: continuous_intros bounded_scaleR_comp)

lemma bcontfun_normI: "continuous_on UNIV f \<Longrightarrow> (\<And>x. norm (f x) \<le> b) \<Longrightarrow> f \<in> bcontfun"
  by (auto simp: bcontfun_def intro: boundedI)

lift_definition uminus_bcontfun::"('a \<Rightarrow>\<^sub>C 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>C 'b" is "\<lambda>f x. - f x"
  by (rule uminus_cont)

lift_definition plus_bcontfun::"('a \<Rightarrow>\<^sub>C 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>C 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>C 'b"  is "\<lambda>f g x. f x + g x"
  by (rule plus_cont)

lift_definition minus_bcontfun::"('a \<Rightarrow>\<^sub>C 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>C 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>C 'b"  is "\<lambda>f g x. f x - g x"
  by (rule minus_cont)

lift_definition zero_bcontfun::"'a \<Rightarrow>\<^sub>C 'b" is "\<lambda>_. 0"
  by (rule const_bcontfun)

lemma const_bcontfun_0_eq_0[simp]: "const_bcontfun 0 = 0"
  by transfer simp

lift_definition scaleR_bcontfun::"real \<Rightarrow> ('a \<Rightarrow>\<^sub>C 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>C 'b"  is "\<lambda>r g x. r *\<^sub>R g x"
  by (rule scaleR_cont)

lemmas [simp] =
  const_bcontfun.rep_eq
  uminus_bcontfun.rep_eq
  plus_bcontfun.rep_eq
  minus_bcontfun.rep_eq
  zero_bcontfun.rep_eq
  scaleR_bcontfun.rep_eq

instance
  by standard (auto intro!: bcontfun_eqI simp: algebra_simps)

end

lemma bounded_norm_le_SUP_norm:
  "bounded (range f) \<Longrightarrow> norm (f x) \<le> (SUP x. norm (f x))"
  by (auto intro!: cSUP_upper bounded_imp_bdd_above simp: bounded_norm_comp)

instantiation\<^marker>\<open>tag unimportant\<close> bcontfun :: (topological_space, real_normed_vector) real_normed_vector
begin

definition norm_bcontfun :: "('a, 'b) bcontfun \<Rightarrow> real"
  where "norm_bcontfun f = dist f 0"

definition "sgn (f::('a,'b) bcontfun) = f /\<^sub>R norm f"

instance
proof
  fix a :: real
  fix f g :: "('a, 'b) bcontfun"
  show "dist f g = norm (f - g)"
    unfolding norm_bcontfun_def
    by transfer (simp add: dist_norm)
  show "norm (f + g) \<le> norm f + norm g"
    unfolding norm_bcontfun_def
    by transfer
      (auto intro!: cSUP_least norm_triangle_le add_mono bounded_norm_le_SUP_norm
        simp: dist_norm bcontfun_def)
  show "norm (a *\<^sub>R f) = \<bar>a\<bar> * norm f"
    unfolding norm_bcontfun_def
    apply transfer
    by (rule trans[OF _ continuous_at_Sup_mono[symmetric]])
      (auto intro!: monoI mult_left_mono continuous_intros bounded_imp_bdd_above
        simp: bounded_norm_comp bcontfun_def image_comp)
qed (auto simp: norm_bcontfun_def sgn_bcontfun_def)

end

lemma norm_bounded:
  fixes f :: "('a::topological_space, 'b::real_normed_vector) bcontfun"
  shows "norm (apply_bcontfun f x) \<le> norm f"
  using dist_bounded[of f x 0]
  by (simp add: dist_norm)

lemma norm_bound:
  fixes f :: "('a::topological_space, 'b::real_normed_vector) bcontfun"
  assumes "\<And>x. norm (apply_bcontfun f x) \<le> b"
  shows "norm f \<le> b"
  using dist_bound[of f 0 b] assms
  by (simp add: dist_norm)

subsection\<^marker>\<open>tag unimportant\<close> \<open>(bounded) continuous extenstion\<close>

lemma continuous_on_cbox_bcontfunE:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::metric_space"
  assumes "continuous_on (cbox a b) f"
  obtains g::"'a \<Rightarrow>\<^sub>C 'b" where
    "\<And>x. x \<in> cbox a b \<Longrightarrow> g x = f x"
    "\<And>x. g x = f (clamp a b x)"
proof -
  define g where "g \<equiv> ext_cont f a b"
  have "g \<in> bcontfun"
    using assms
    by (auto intro!: continuous_on_ext_cont simp: g_def bcontfun_def)
      (auto simp: g_def ext_cont_def
        intro!: clamp_bounded compact_imp_bounded[OF compact_continuous_image] assms)
  then obtain h where h: "g = apply_bcontfun h" by (rule bcontfunE)
  then have "h x = f x" if "x \<in> cbox a b" for x
    by (auto simp: h[symmetric] g_def that)
  moreover
  have "h x = f (clamp a b x)" for x
    by (auto simp: h[symmetric] g_def ext_cont_def)
  ultimately show ?thesis ..
qed

lifting_update bcontfun.lifting
lifting_forget bcontfun.lifting

end


(*
  File:    IMO2019_Q4.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Q4\<close>
theory IMO2019_Q4
  imports "Prime_Distribution_Elementary.More_Dirichlet_Misc"
begin

text \<open>
  Find all pairs \<open>(k, n)\<close> of positive integers such that $k! = \prod_{i=0}^{n-1} (2^n - 2^i)$.
\<close>

subsection \<open>Auxiliary facts\<close>

(* TODO: Move stuff from this section? *)
lemma Sigma_insert: "Sigma (insert x A) f = (\<lambda>y. (x, y)) ` f x \<union> Sigma A f"
  by auto

lemma atLeastAtMost_nat_numeral:
  "{(m::nat)..numeral k} =
     (if m \<le> numeral k then insert (numeral k) {m..pred_numeral k} else {})"
  by (auto simp: numeral_eq_Suc)

lemma greaterThanAtMost_nat_numeral:
  "{(m::nat)<..numeral k} =
     (if m < numeral k then insert (numeral k) {m<..pred_numeral k} else {})"
  by (auto simp: numeral_eq_Suc)

lemma fact_ge_power:
  fixes c :: nat
  assumes "fact n0 \<ge> c ^ n0" "c \<le> n0 + 1"
  assumes "n \<ge> n0"
  shows   "fact n \<ge> c ^ n"
  using assms(3,1,2)
proof (induction n rule: dec_induct)
  case (step n)
  have "c * c ^ n \<le> Suc n * fact n"
    using step by (intro mult_mono) auto
  thus ?case by simp
qed auto

lemma prime_multiplicity_prime:
  fixes p q :: "'a :: factorial_semiring"
  assumes "prime p" "prime q"
  shows   "multiplicity p q = (if p = q then 1 else 0)"
  using assms by (auto simp: prime_multiplicity_other)

text \<open>
  We use Legendre's identity from the library. One could easily prove the property in question
  without the library, but it probably still saves a few lines.

  @{const legendre_aux} (related to Legendre's identity) is the multiplicity of a given prime
  in the prime factorisation of \<open>n!\<close>.
\<close>
(* TODO: Move? *)
lemma multiplicity_prime_fact:
  fixes p :: nat
  assumes "prime p"
  shows   "multiplicity p (fact n) = legendre_aux n p"
proof (cases "p \<le> n")
  case True
  have "fact n = (\<Prod>p | prime p \<and> p \<le> n. p ^ legendre_aux n p)"
    using legendre_identity'[of "real n"] by simp
  also have "multiplicity p \<dots> = (\<Sum>q | prime q \<and> q \<le> n. multiplicity p (q ^ legendre_aux n q))"
    using assms by (subst prime_elem_multiplicity_prod_distrib) auto
  also have "\<dots> = (\<Sum>q\<in>{p}. legendre_aux n q)"
    using assms \<open>p \<le> n\<close> prime_multiplicity_other[of p]
    by (intro sum.mono_neutral_cong_right)
       (auto simp: prime_elem_multiplicity_power_distrib prime_multiplicity_prime split: if_splits)
  finally show ?thesis by simp
next
  case False
  hence "multiplicity p (fact n) = 0"
    using assms by (intro not_dvd_imp_multiplicity_0) (auto simp: prime_dvd_fact_iff)
  moreover from False have "legendre_aux (real n) p = 0"
    by (intro legendre_aux_eq_0) auto
  ultimately show ?thesis by simp
qed

text \<open>
  The following are simple and trivial lower and upper bounds for @{const legendre_aux}:
\<close>
lemma legendre_aux_ge:
  assumes "prime p" "k \<ge> 1"
  shows   "legendre_aux k p \<ge> nat \<lfloor>k / p\<rfloor>"
proof (cases "k \<ge> p")
  case True
  have "(\<Sum>m\<in>{1}. nat \<lfloor>k / real p ^ m\<rfloor>) \<le> (\<Sum>m | 0 < m \<and> real p ^ m \<le> k. nat \<lfloor>k / real p ^ m\<rfloor>)"
    using True finite_sum_legendre_aux[of p] assms by (intro sum_mono2) auto
  with assms True show ?thesis by (simp add: legendre_aux_def)
next
  case False
  with assms have "k / p < 1" by (simp add: field_simps)
  hence "nat \<lfloor>k / p\<rfloor> = 0" by simp
  with False show ?thesis
    by (simp add: legendre_aux_eq_0)
qed

lemma legendre_aux_less:
  assumes "prime p" "k \<ge> 1"
  shows   "legendre_aux k p < k / (p - 1)"
proof -
  have "(\<lambda>m. (k / p) * (1 / p) ^ m) sums ((k / p) * (1 / (1 - 1 / p)))"
    using assms prime_gt_1_nat[of p] by (intro sums_mult geometric_sums) (auto simp: field_simps)
  hence sums: "(\<lambda>m. k / p ^ Suc m) sums (k / (p - 1))"
    using assms prime_gt_1_nat[of p] by (simp add: field_simps of_nat_diff)

  have "real (legendre_aux k p) = (\<Sum>m\<in>{0<..nat \<lfloor>log (real p) k\<rfloor>}. of_int \<lfloor>k / real p ^ m\<rfloor>)"
    using assms by (simp add: legendre_aux_altdef1)
  also have "\<dots> = (\<Sum>m<nat \<lfloor>log (real p) k\<rfloor>. of_int \<lfloor>k / real p ^ Suc m\<rfloor>)"
    by (intro sum.reindex_bij_witness[of _ Suc "\<lambda>i. i - 1"]) (auto simp flip: power_Suc)
  also have "\<dots> \<le> (\<Sum>m<nat \<lfloor>log (real p) k\<rfloor>. k / real p ^ Suc m)"
    by (intro sum_mono) auto
  also have "\<dots> < (\<Sum>m. k / real p ^ Suc m)"
    using sums assms prime_gt_1_nat[of p]
    by (intro sum_less_suminf) (auto simp: sums_iff intro!: divide_pos_pos)
  also have "\<dots> = k / (p - 1)"
    using sums by (simp add: sums_iff)
  finally show ?thesis
    using assms prime_gt_1_nat[of p] by (simp add: of_nat_diff)
qed

subsection \<open>Main result\<close>

text \<open>
  Now we move on to the main result: We fix two numbers \<open>n\<close> and \<open>k\<close> with the property
  in question and derive facts from that.

  The triangle number $T = n(n+1)/2$ is of particular importance here, so we introduce an
  abbreviation for it.
\<close>

context
  fixes k n :: nat and rhs T :: nat
  defines "rhs \<equiv> (\<Prod>i<n. 2 ^ n - 2 ^ i)"
  defines "T \<equiv> (n * (n - 1)) div 2"
  assumes pos: "k > 0" "n > 0"
  assumes k_n: "fact k = rhs"
begin

text \<open>
  We can rewrite the right-hand side into a more convenient form:
\<close>
lemma rhs_altdef: "rhs = 2 ^ T * (\<Prod>i=1..n. 2 ^ i - 1)"
proof -
  have "rhs = (\<Prod>i<n. 2 ^ i * (2 ^ (n - i) - 1))"
    by (simp add: rhs_def algebra_simps flip: power_add)
  also have "\<dots> = 2 ^ (\<Sum>i<n. i) * (\<Prod>i<n. 2 ^ (n - i) - 1)"
    by (simp add: prod.distrib power_sum)
  also have "(\<Sum>i<n. i) = T"
    unfolding T_def using Sum_Ico_nat[of 0 n] by (simp add: atLeast0LessThan)
  also have "(\<Prod>i<n. 2 ^ (n - i) - 1) = (\<Prod>i=1..n. 2 ^ i - 1)"
    by (rule prod.reindex_bij_witness[of _ "\<lambda>i. n - i" "\<lambda>i. n - i"]) auto
  finally show ?thesis .
qed

text \<open>
  The multiplicity of 2 in the prime factorisation of the right-hand side is precisely \<open>T\<close>.
\<close>

  have "multiplicity 2 rhs = T + multiplicity 2 (\<Prod>i=1..n. 2 ^ i - 1 :: nat)"
    using nz by (simp add: rhs_altdef prime_elem_multiplicity_mult_distrib)
  also have "multiplicity 2 (\<Prod>i=1..n. 2 ^ i - 1 :: nat) = 0"
    by (intro not_dvd_imp_multiplicity_0) (auto simp: prime_dvd_prod_iff)
  finally show ?thesis by simp
qed

text \<open>
  From Legendre's identities and the associated bounds, it can easily be seen that
  \<open>\<lfloor>k/2\<rfloor> \<le> T < k\<close>:
\<close>

lemma T_ge_half_k: "T \<ge> k div 2"
proof -
  have "k div 2 \<le> legendre_aux k 2"
    using legendre_aux_ge[of 2 k] pos by simp linarith?
  also have "\<dots> = multiplicity 2 (fact k :: nat)"
    by (simp add: multiplicity_prime_fact)
  also have "\<dots> = T" by (simp add: k_n)
  finally show "T \<ge> k div 2" .
qed

text \<open>
  It can also be seen fairly easily that the right-hand side is strictly smaller than $2^{n^2}$:
\<close>
lemma rhs_less: "rhs < 2 ^ n\<^sup>2"
proof -
  have "rhs = 2 ^ T * (\<Prod>i=1..n. 2 ^ i - 1)"
    by (simp add: rhs_altdef)
  also have "(\<Prod>i=1..n. 2 ^ i - 1 :: nat) < (\<Prod>i=1..n. 2 ^ i)"
    using pos by (intro prod_mono_strict) auto
  also have "\<dots> = (\<Prod>i=0..<n. 2 * 2 ^ i)"
    by (intro prod.reindex_bij_witness[of _ Suc "\<lambda>i. i - 1"]) (auto simp flip: power_Suc)
  also have "\<dots> = 2 ^ n * 2 ^ (\<Sum>i=0..<n. i)"
    by (simp add: power_sum prod.distrib)
  also have "(\<Sum>i=0..<n. i) = T"
    unfolding T_def by (simp add: Sum_Ico_nat)
  also have "2 ^ T * (2 ^ n * 2 ^ T :: nat) = 2 ^ (2 * T + n)"
    by (simp flip: power_add power_Suc add: algebra_simps)
  also have "2 * T + n = n ^ 2"
    by (cases "even n") (auto simp: T_def algebra_simps power2_eq_square)
  finally show "rhs < 2 ^ n\<^sup>2"
    by simp
qed

text \<open>
  It is clear that $2^{n^2} \leq 8^T$ and that $8^T < T!$ if $T$ is sufficiently big.
  In this case, `sufficiently big' means \<open>T \<ge> 20\<close> and thereby \<open>n \<ge> 7\<close>. We can therefore
  conclude that \<open>n\<close> must be less than 7.
\<close>
lemma n_less_7: "n < 7"
proof (rule ccontr)
  assume "\<not>n < 7"
  hence "n \<ge> 7" by simp
  have "T \<ge> (7 * 6) div 2"
    unfolding T_def using \<open>n \<ge> 7\<close> by (intro div_le_mono mult_mono) auto
  hence "T \<ge> 21" by simp

  from \<open>n \<ge> 7\<close> have "(n * 2) div 2 \<le> T"
    unfolding T_def by (intro div_le_mono) auto
  hence "T \<ge> n" by simp

  from \<open>T \<ge> 21\<close> have "sqrt (2 * pi * T) * (T / exp 1) ^ T \<le> fact T"
    using fact_bounds[of T] by simp
  have "fact T \<le> (fact k :: nat)"
    using k_gt_T by (intro fact_mono) (auto simp: T_def)
  also have "\<dots> = rhs" by fact
  also have "rhs < 2 ^ n\<^sup>2" by (rule rhs_less)
  also have "n\<^sup>2 = 2 * T + n"
    by (cases "even n") (auto simp: T_def algebra_simps power2_eq_square)
  also have "\<dots> \<le> 3 * T"
    using \<open>T \<ge> n\<close> by (simp add: T_def)
  also have "2 ^ (3 * T) = (8 ^ T :: nat)"
    by (simp add: power_mult)
  finally have "fact T < (8 ^ T :: nat)"
    by simp
  moreover have "fact T \<ge> (8 ^ T :: nat)"
    by (rule fact_ge_power[of _ 20]) (use \<open>T \<ge> 21\<close> in \<open>auto simp: fact_numeral\<close>)
  ultimately show False by simp
qed

text \<open>
  We now only have 6 values for \<open>n\<close> to check. Together with the bounds that we obtained on \<open>k\<close>,
  this only leaves a few combinations of \<open>n\<close> and \<open>k\<close> to check, and we do precisely that
  and find that \<open>n = k = 1\<close> and \<open>n = 2, k = 3\<close> are the only possible combinations.
\<close>
lemma n_k_in_set: "(n, k) \<in> {(1, 1), (2, 3)}"
proof -
  define T' where "T' = (\<lambda>n :: nat. n * (n - 1) div 2)"
  define A :: "(nat \<times> nat) set" where "A = (SIGMA n:{1..6}. {T' n<..2 * T' n + 1})"
  define P where "P = (\<lambda>(n, k). fact k = (\<Prod>i<n. 2 ^ n - 2 ^ i :: nat))"
  have [simp]: "{0<..Suc 0} = {1}" by auto
  have "(n, k) \<in> Set.filter P A"
    using k_n pos T_ge_half_k k_gt_T n_less_7
    by (auto simp: A_def T'_def T_def Set.filter_def P_def rhs_def)
  also have "Set.filter P A = {(1, 1), (2, 3)}"
    by (simp add: P_def Set_filter_insert A_def atMost_nat_numeral atMost_Suc T'_def Sigma_insert
          greaterThanAtMost_nat_numeral atLeastAtMost_nat_numeral lessThan_nat_numeral fact_numeral
             cong: if_weak_cong)
  finally show ?thesis .
qed

end

text \<open>
  Using this, deriving the final result is now trivial:
\<close>
theorem "{(n, k). n > 0 \<and> k > 0 \<and> fact k = (\<Prod>i<n. 2 ^ n - 2 ^ i :: nat)} = {(1, 1), (2, 3)}"
  (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs" using n_k_in_set by blast
  show "?rhs \<subseteq> ?lhs" by (auto simp: fact_numeral lessThan_nat_numeral)
qed

end