section \<open>Piecewise Continous Functions\<close>
theory Piecewise_Continuous
  imports
    Laplace_Transform_Library
begin

subsection \<open>at within filters\<close>

lemma at_within_self_singleton[simp]: "at i within {i} = bot"
  by (auto intro!: antisym filter_leI simp: eventually_at_filter)

lemma at_within_t1_space_avoid:
  "(at x within X - {i}) = (at x within X)" if "x \<noteq> i" for x i::"'a::t1_space"
proof (safe intro!: antisym filter_leI)
  fix P
  assume "eventually P (at x within X - {i})"
  moreover have "eventually (\<lambda>x. x \<noteq> i) (nhds x)"
    by (rule t1_space_nhds) fact
  ultimately
  show "eventually P (at x within X)"
    unfolding eventually_at_filter
    by eventually_elim auto
qed (simp add: eventually_mono order.order_iff_strict eventually_at_filter)

lemma at_within_t1_space_avoid_finite:
  "(at x within X - I) = (at x within X)" if "finite I" "x \<notin> I" for x::"'a::t1_space"
  using that
proof (induction I)
  case (insert i I)
  then show ?case
    by auto (metis Diff_insert at_within_t1_space_avoid)
qed simp

lemma at_within_interior:
  "NO_MATCH (UNIV::'a set) (S::'a::topological_space set) \<Longrightarrow> x \<in> interior S \<Longrightarrow> at x within S = at x"
  by (rule at_within_interior)

subsection \<open>intervals\<close>

lemma Compl_Icc: "- {a .. b} = {..<a} \<union> {b<..}" for a b::"'a::linorder"
  by auto

lemma interior_Icc[simp]: "interior {a..b} = {a<..<b}"
  for a b::"'a::{linorder_topology, dense_order, no_bot, no_top}"
    \<comment> \<open>TODO: is \<open>no_bot\<close> and \<open>no_top\<close> really required?\<close>
  by (auto simp add: Compl_Icc interior_closure)

lemma closure_finite[simp]: "closure X = X" if "finite X" for X::"'a::t1_space set"
  using that
  by (induction X) (simp_all add: closure_insert)

definition piecewise_continuous_on :: "'a::linorder_topology \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) \<Rightarrow> bool"
where "piecewise_continuous_on a b I f \<longleftrightarrow>
  (continuous_on ({a .. b} - I) f \<and> finite I \<and>
    (\<forall>i\<in>I. (i \<in> {a<..b} \<longrightarrow> (\<exists>l. (f \<longlongrightarrow> l) (at_left i))) \<and>
      (i \<in> {a..<b} \<longrightarrow> (\<exists>u. (f \<longlongrightarrow> u) (at_right i)))))"

lemma piecewise_continuous_on_subset:
  "piecewise_continuous_on a b I f \<Longrightarrow> {c .. d} \<subseteq> {a .. b} \<Longrightarrow> piecewise_continuous_on c d I f"
  by (force simp add: piecewise_continuous_on_def intro: continuous_on_subset)

lemma piecewise_continuous_onE:
  assumes "piecewise_continuous_on a b I f"
  obtains l u
  where "finite I"
      and "continuous_on ({a..b} - I) f"
      and "(\<And>i. i \<in> I \<Longrightarrow> a < i \<Longrightarrow> i \<le> b \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i))"
      and "(\<And>i. i \<in> I \<Longrightarrow> a \<le> i \<Longrightarrow> i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i))"
  using assms
  by (auto simp: piecewise_continuous_on_def Ball_def) metis

lemma piecewise_continuous_onI:
  assumes "finite I" "continuous_on ({a..b} - I) f"
    and "(\<And>i. i \<in> I \<Longrightarrow> a < i \<Longrightarrow> i \<le> b \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i))"
    and "(\<And>i. i \<in> I \<Longrightarrow> a \<le> i \<Longrightarrow> i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i))"
  shows "piecewise_continuous_on a b I f"
  using assms
  by (force simp: piecewise_continuous_on_def)

lemma piecewise_continuous_onI':
  fixes a b::"'a::{linorder_topology, dense_order, no_bot, no_top}"
  assumes "finite I" "\<And>x. a < x \<Longrightarrow> x < b \<Longrightarrow> isCont f x"
    and "a \<notin> I \<Longrightarrow> continuous (at_right a) f"
    and "b \<notin> I \<Longrightarrow> continuous (at_left b) f"
    and "(\<And>i. i \<in> I \<Longrightarrow> a < i \<Longrightarrow> i \<le> b \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i))"
    and "(\<And>i. i \<in> I \<Longrightarrow> a \<le> i \<Longrightarrow> i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i))"
  shows "piecewise_continuous_on a b I f"
proof (rule piecewise_continuous_onI)
  have "x \<notin> I \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> (f \<longlongrightarrow> f x) (at x within {a..b})" for x
    using assms(2)[of x] assms(3,4)
    by (cases "a = x"; cases "b = x"; cases "x \<in> {a<..<b}")
      (auto simp: at_within_Icc_at_left at_within_Icc_at_right isCont_def
        continuous_within filterlim_at_split at_within_interior)
  then show "continuous_on ({a .. b} - I) f"
    by (auto simp: continuous_on_def \<open>finite I\<close> at_within_t1_space_avoid_finite)
qed fact+

lemma piecewise_continuous_onE':
  fixes a b::"'a::{linorder_topology, dense_order, no_bot, no_top}"
  assumes "piecewise_continuous_on a b I f"
  obtains l u
  where "finite I"
      and "\<And>x. a < x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> isCont f x"
      and "(\<And>x. a < x \<Longrightarrow> x \<le> b \<Longrightarrow> (f \<longlongrightarrow> l x) (at_left x))"
      and "(\<And>x. a \<le> x \<Longrightarrow> x < b \<Longrightarrow> (f \<longlongrightarrow> u x) (at_right x))"
      and "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<notin> I \<Longrightarrow> f x = l x"
      and "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<notin> I \<Longrightarrow> f x = u x"
proof -
  from piecewise_continuous_onE[OF assms] obtain l u
    where "finite I"
      and continuous: "continuous_on ({a..b} - I) f"
      and left: "(\<And>i. i \<in> I \<Longrightarrow> a < i \<Longrightarrow> i \<le> b \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i))"
      and right: "(\<And>i. i \<in> I \<Longrightarrow> a \<le> i \<Longrightarrow> i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i))"
    by metis
  define l' where "l' x = (if x \<in> I then l x else f x)" for x
  define u' where "u' x = (if x \<in> I then u x else f x)" for x
  note \<open>finite I\<close>
  moreover from continuous
  have "a < x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> isCont f x" for x
    by (rule continuous_on_interior) (auto simp: interior_diff \<open>finite I\<close>)
  moreover
  from continuous have "a < x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<notin> I \<Longrightarrow> (f \<longlongrightarrow> f x) (at_left x)" for x
    by (cases "x = b")
     (auto simp: continuous_on_def at_within_t1_space_avoid_finite \<open>finite I\<close>
        at_within_Icc_at_left at_within_interior filterlim_at_split
        dest!: bspec[where x=x])
  then have "a < x \<Longrightarrow> x \<le> b \<Longrightarrow> (f \<longlongrightarrow> l' x) (at_left x)" for x
    by (auto simp: l'_def left)
  moreover
  from continuous have "a \<le> x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> (f \<longlongrightarrow> f x) (at_right x)" for x
    by (cases "x = a")
     (auto simp: continuous_on_def at_within_t1_space_avoid_finite \<open>finite I\<close>
        at_within_Icc_at_right at_within_interior filterlim_at_split
        dest!: bspec[where x=x])
  then have "a \<le> x \<Longrightarrow> x < b \<Longrightarrow> (f \<longlongrightarrow> u' x) (at_right x)" for x
    by (auto simp: u'_def right)
  moreover have "a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<notin> I \<Longrightarrow> f x = l' x" for x by (auto simp: l'_def)
  moreover have "a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<notin> I \<Longrightarrow> f x = u' x" for x by (auto simp: u'_def)
  ultimately show ?thesis ..
qed

lemma tendsto_avoid_at_within:
  "(f \<longlongrightarrow> l) (at x within X)"
  if "(f \<longlongrightarrow> l) (at x within X - {x})"
  using that
  by (auto simp: eventually_at_filter dest!: topological_tendstoD intro!: topological_tendstoI)

lemma tendsto_within_subset_eventuallyI:
  "(f \<longlongrightarrow> fx) (at x within X)"
  if g: "(g \<longlongrightarrow> gy) (at y within Y)"
    and ev: "\<forall>\<^sub>F x in (at y within Y). f x = g x"
    and xy: "x = y"
    and fxgy: "fx = gy"
    and XY: "X - {x} \<subseteq> Y"
  apply (rule tendsto_avoid_at_within)
  apply (rule tendsto_within_subset[where S = "Y"])
  unfolding xy
   apply (subst tendsto_cong[OF ev ])
   apply (rule g[folded fxgy])
  apply (rule XY[unfolded xy])
  done

lemma piecewise_continuous_on_insertE:
  assumes "piecewise_continuous_on a b (insert i I) f"
  assumes "i \<in> {a .. b}"
  obtains g h where
    "piecewise_continuous_on a i I g"
    "piecewise_continuous_on i b I h"
    "\<And>x. a \<le> x \<Longrightarrow> x < i \<Longrightarrow> g x = f x"
    "\<And>x. i < x \<Longrightarrow> x \<le> b \<Longrightarrow> h x = f x"
proof -
  from piecewise_continuous_onE[OF assms(1)] \<open>i \<in> {a .. b}\<close> obtain l u where
        finite: "finite I"
    and cf: "continuous_on ({a..b} - insert i I) f"
    and l: "(\<And>i. i \<in> I \<Longrightarrow> a < i \<Longrightarrow> i \<le> b \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i))" "i > a \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i)"
    and u: "(\<And>i. i \<in> I \<Longrightarrow> a \<le> i \<Longrightarrow> i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i))" "i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i)"
    by auto (metis (mono_tags))

  have fl: "(f(i := x) \<longlongrightarrow> l j) (at_left j)" if "j \<in> I" "a < j" "j \<le> b" for j x
    using l(1)
    apply (rule tendsto_within_subset_eventuallyI)
        apply (auto simp: eventually_at_filter that)
    apply (cases "j \<noteq> i")
    subgoal premises prems
      using t1_space_nhds[OF prems]
      by eventually_elim auto
    subgoal by simp
    done
  have fr: "(f(i := x) \<longlongrightarrow> u j) (at_right j)" if "j \<in> I" "a \<le> j" "j < b" for j x
    using u(1)
    apply (rule tendsto_within_subset_eventuallyI)
        apply (auto simp: eventually_at_filter that)
    apply (cases "j \<noteq> i")
    subgoal premises prems
      using t1_space_nhds[OF prems]
      by eventually_elim auto
    subgoal by simp
    done
  from cf have tendsto: "(f \<longlongrightarrow> f x) (at x within {a..b} - insert i I)"
    if "x \<in> {a .. b} - insert i I" for x using that
    by (auto simp: continuous_on_def)
  have "continuous_on ({a..i} - I) (f(i:=l i))"
    apply (cases "a = i")
    subgoal by (auto simp: continuous_on_def Diff_triv)
    unfolding continuous_on_def
    apply safe
    subgoal for x
      apply (cases "x = i")
      subgoal
        apply (rule tendsto_within_subset_eventuallyI)
            apply (rule l(2))
        by (auto simp: eventually_at_filter)
      subgoal
        apply (subst at_within_t1_space_avoid[symmetric], assumption)
        apply (rule tendsto_within_subset_eventuallyI[where y=x])
            apply (rule tendsto)
        using \<open>i \<in> {a .. b}\<close> by (auto simp: eventually_at_filter)
      done
    done
  then have "piecewise_continuous_on a i I (f(i:=l i))"
    using \<open>i \<in> {a .. b}\<close>
    by (auto intro!: piecewise_continuous_onI finite fl fr)

  moreover
  have "continuous_on ({i..b} - I) (f(i:=u i))"
    apply (cases "b = i")
    subgoal by (auto simp: continuous_on_def Diff_triv)
    unfolding continuous_on_def
    apply safe
    subgoal for x
      apply (cases "x = i")
      subgoal
        apply (rule tendsto_within_subset_eventuallyI)
            apply (rule u(2))
        by (auto simp: eventually_at_filter)
      subgoal
        apply (subst at_within_t1_space_avoid[symmetric], assumption)
        apply (rule tendsto_within_subset_eventuallyI[where y=x])
            apply (rule tendsto)
        using \<open>i \<in> {a .. b}\<close> by (auto simp: eventually_at_filter)
      done
    done
  then have "piecewise_continuous_on i b I (f(i:=u i))"
    using \<open>i \<in> {a .. b}\<close>
    by (auto intro!: piecewise_continuous_onI finite fl fr)
  moreover have "(f(i:=l i)) x = f x" if "a \<le> x" "x < i" for x
    using that by auto
  moreover have "(f(i:=u i)) x = f x" if "i < x" "x \<le> b" for x
    using that by auto
  ultimately show ?thesis ..
qed

lemma eventually_avoid_finite:
  "\<forall>\<^sub>F x in at y within Y. x \<notin> I" if "finite I" for y::"'a::t1_space"
  using that
proof (induction)
  case empty
  then show ?case by simp
next
  case (insert x F)
  then show ?case
    apply (auto intro!: eventually_conj)
    apply (cases "y = x")
    subgoal by (simp add: eventually_at_filter)
    subgoal by (rule tendsto_imp_eventually_ne) (rule tendsto_ident_at)
    done
qed

lemma eventually_at_left_linorder:\<comment> \<open>TODO: generalize @{thm eventually_at_left_real}\<close>
  "a > (b :: 'a :: linorder_topology) \<Longrightarrow> eventually (\<lambda>x. x \<in> {b<..<a}) (at_left a)"
  unfolding eventually_at_left
  by auto

lemma eventually_at_right_linorder:\<comment> \<open>TODO: generalize @{thm eventually_at_right_real}\<close>
  "a > (b :: 'a :: linorder_topology) \<Longrightarrow> eventually (\<lambda>x. x \<in> {b<..<a}) (at_right b)"
  unfolding eventually_at_right
  by auto

lemma piecewise_continuous_on_cong[cong]:
  "piecewise_continuous_on a b I f \<longleftrightarrow> piecewise_continuous_on c d J g"
  if "a = c"
    "b = d"
    "I = J"
    "\<And>x. c \<le> x \<Longrightarrow> x \<le> d \<Longrightarrow> x \<notin> J \<Longrightarrow> f x = g x"
  using that
  by (auto intro: piecewise_continuous_on_congI)

lemma tendsto_at_left_continuous_on_avoidI: "(f \<longlongrightarrow> g i) (at_left i)"
  if g: "continuous_on ({a..i} - I) g"
    and gf: "\<And>x. a < x \<Longrightarrow> x < i \<Longrightarrow> g x = f x"
    "i \<notin> I" "finite I" "a < i"
  for i::"'a::linorder_topology"
proof (rule Lim_transform_eventually)
  from that have "i \<in> {a .. i}" by auto
  from g have "(g \<longlongrightarrow> g i) (at i within {a..i} - I)"
    using \<open>i \<notin> I\<close> \<open>i \<in> {a .. i}\<close>
    by (auto elim!: piecewise_continuous_onE simp: continuous_on_def)
  then show "(g \<longlongrightarrow> g i) (at_left i)"
    by (metis that at_within_Icc_at_left at_within_t1_space_avoid_finite
        greaterThanLessThan_iff)
  show "\<forall>\<^sub>F x in at_left i. g x = f x"
    using eventually_at_left_linorder[OF \<open>a < i\<close>]
    by eventually_elim (auto simp: \<open>a < i\<close> gf)
qed

lemma tendsto_at_right_continuous_on_avoidI: "(f \<longlongrightarrow> g i) (at_right i)"
  if g: "continuous_on ({i..b} - I) g"
    and gf: "\<And>x. i < x \<Longrightarrow> x < b \<Longrightarrow> g x = f x"
    "i \<notin> I" "finite I" "i < b"
  for i::"'a::linorder_topology"
proof (rule Lim_transform_eventually)
  from that have "i \<in> {i .. b}" by auto
  from g have "(g \<longlongrightarrow> g i) (at i within {i..b} - I)"
    using \<open>i \<notin> I\<close> \<open>i \<in> {i .. b}\<close>
    by (auto elim!: piecewise_continuous_onE simp: continuous_on_def)
  then show "(g \<longlongrightarrow> g i) (at_right i)"
    by (metis that at_within_Icc_at_right at_within_t1_space_avoid_finite
        greaterThanLessThan_iff)
  show "\<forall>\<^sub>F x in at_right i. g x = f x"
    using eventually_at_right_linorder[OF \<open>i < b\<close>]
    by eventually_elim (auto simp: \<open>i < b\<close> gf)
qed

lemma piecewise_continuous_on_insert_leftI:
  "piecewise_continuous_on a b (insert a I) f" if "piecewise_continuous_on a b I f"
  apply (cases "a \<in> I")
  subgoal using that by (auto dest: insert_absorb)
  subgoal
    using that
    apply (rule piecewise_continuous_onE)
    subgoal for l u
      apply (rule piecewise_continuous_onI[where u="u(a:=f a)"])
         apply (auto intro: continuous_on_subset )
      apply (rule tendsto_at_right_continuous_on_avoidI, assumption)
         apply auto
      done
    done
  done

lemma piecewise_continuous_on_insert_rightI:
  "piecewise_continuous_on a b (insert b I) f" if "piecewise_continuous_on a b I f"
  apply (cases "b \<in> I")
  subgoal using that by (auto dest: insert_absorb)
  subgoal
    using that
    apply (rule piecewise_continuous_onE)
    subgoal for l u
      apply (rule piecewise_continuous_onI[where l="l(b:=f b)"])
         apply (auto intro: continuous_on_subset )
      apply (rule tendsto_at_left_continuous_on_avoidI, assumption)
         apply auto
      done
    done
  done

theorem piecewise_continuous_on_induct[consumes 1, case_names empty combine weaken]:
  assumes pc: "piecewise_continuous_on a b I f"
  assumes 1: "\<And>a b f. continuous_on {a .. b} f \<Longrightarrow> P a b {} f"
  assumes 2: "\<And>a i b I f1 f2 f. a \<le> i \<Longrightarrow> i \<le> b \<Longrightarrow> i \<notin> I \<Longrightarrow> P a i I f1 \<Longrightarrow> P i b I f2 \<Longrightarrow>
    piecewise_continuous_on a i I f1 \<Longrightarrow>
    piecewise_continuous_on i b I f2 \<Longrightarrow>
    (\<And>x. a \<le> x \<Longrightarrow> x < i \<Longrightarrow> f1 x = f x) \<Longrightarrow>
    (\<And>x. i < x \<Longrightarrow> x \<le> b \<Longrightarrow> f2 x = f x) \<Longrightarrow>
    (i > a \<Longrightarrow> (f \<longlongrightarrow> f1 i) (at_left i)) \<Longrightarrow>
    (i < b \<Longrightarrow> (f \<longlongrightarrow> f2 i) (at_right i)) \<Longrightarrow>
    P a b (insert i I) f"
  assumes 3: "\<And>a b i I f. P a b I f \<Longrightarrow> finite I \<Longrightarrow> i \<notin> I \<Longrightarrow> P a b (insert i I) f"
  shows "P a b I f"
proof -
  from pc have "finite I"
    by (auto simp: piecewise_continuous_on_def)
  then show ?thesis
    using pc
  proof (induction I arbitrary: a b f)
    case empty
    then show ?case
      by (auto simp: piecewise_continuous_on_def 1)
  next
    case (insert i I)
    show ?case
    proof (cases "i \<in> {a .. b}")
      case True
      from insert.prems[THEN piecewise_continuous_on_insertE, OF \<open>i \<in> {a .. b}\<close>]
      obtain g h
        where g: "piecewise_continuous_on a i I g"
          and h: "piecewise_continuous_on i b I h"
          and gf: "\<And>x. a \<le> x \<Longrightarrow> x < i \<Longrightarrow> g x = f x"
          and hf: "\<And>x. i < x \<Longrightarrow> x \<le> b \<Longrightarrow> h x = f x"
        by metis
      from g have pcg: "piecewise_continuous_on a i I (f(i:=g i))"
        by (rule piecewise_continuous_on_congI) (auto simp: gf)
      from h have pch: "piecewise_continuous_on i b I (f(i:=h i))"
        by (rule piecewise_continuous_on_congI) (auto simp: hf)

      have fg: "(f \<longlongrightarrow> g i) (at_left i)" if "a < i"
        apply (rule tendsto_at_left_continuous_on_avoidI[where a=a and I=I])
        using g \<open>i \<notin> I\<close> \<open>a < i\<close>
        by (auto elim!: piecewise_continuous_onE simp: gf)
      have fh: "(f \<longlongrightarrow> h i) (at_right i)" if "i < b"
        apply (rule tendsto_at_right_continuous_on_avoidI[where b=b and I=I])
        using h \<open>i \<notin> I\<close> \<open>i < b\<close>
        by (auto elim!: piecewise_continuous_onE simp: hf)
      show ?thesis
        apply (rule 2)
        using True apply force
        using True apply force
                apply (rule insert)
               apply (rule insert.IH, rule pcg)
              apply (rule insert.IH, rule pch)
             apply fact
            apply fact
        using 3
        by (auto simp: fg fh)
    next
      case False
      with insert.prems
      have "piecewise_continuous_on a b I f"
        by (auto simp: piecewise_continuous_on_def)
      from insert.IH[OF this] show ?thesis
        by (rule 3) fact+
    qed
  qed
qed

lemma continuous_on_imp_piecewise_continuous_on:
  "continuous_on {a .. b} f \<Longrightarrow> piecewise_continuous_on a b {} f"
  by (auto simp: piecewise_continuous_on_def)

lemma piecewise_continuous_on_imp_absolutely_integrable:
  fixes a b::real and f::"real \<Rightarrow> 'a::euclidean_space"
  assumes "piecewise_continuous_on a b I f"
  shows "f absolutely_integrable_on {a..b}"
  using assms
proof (induction rule: piecewise_continuous_on_induct)
  case (empty a b f)
  show ?case
    by (auto intro!: absolutely_integrable_onI integrable_continuous_interval
          continuous_intros empty)
next
  case (combine a i b I f1 f2 f)
  from combine(10)
  have "f absolutely_integrable_on {a..i}"
    by (rule absolutely_integrable_spike[where S="{i}"]) (auto simp: combine)
  moreover
  from combine(11)
  have "f absolutely_integrable_on {i..b}"
    by (rule absolutely_integrable_spike[where S="{i}"]) (auto simp: combine)
  ultimately
  show ?case
    by (rule absolutely_integrable_on_combine) fact+
qed

lemma piecewise_continuous_on_integrable:
  fixes a b::real and f::"real \<Rightarrow> 'a::euclidean_space"
  assumes "piecewise_continuous_on a b I f"
  shows "f integrable_on {a..b}"
  using piecewise_continuous_on_imp_absolutely_integrable[OF assms]
  unfolding absolutely_integrable_on_def by auto

lemma piecewise_continuous_on_comp:
  assumes p: "piecewise_continuous_on a b I f"
  assumes c: "\<And>x. isCont (\<lambda>(x, y). g x y) x"
  shows "piecewise_continuous_on a b I (\<lambda>x. g x (f x))"
proof -
  from piecewise_continuous_onE[OF p]
  obtain l u
    where I: "finite I"
      and cf: "continuous_on ({a..b} - I) f"
      and l: "(\<And>i. i \<in> I \<Longrightarrow> a < i \<Longrightarrow> i \<le> b \<Longrightarrow> (f \<longlongrightarrow> l i) (at_left i))"
      and u: "(\<And>i. i \<in> I \<Longrightarrow> a \<le> i \<Longrightarrow> i < b \<Longrightarrow> (f \<longlongrightarrow> u i) (at_right i))"
    by metis
  note \<open>finite I\<close>
  moreover
  from c have cg: "continuous_on UNIV (\<lambda>(x, y). g x y)"
    using c by (auto simp: continuous_on_def isCont_def intro: tendsto_within_subset)
  then have "continuous_on ({a..b} - I) (\<lambda>x. g x (f x))"
    by (intro continuous_on_compose2[OF cg, where f="\<lambda>x. (x, f x)", simplified])
      (auto intro!: continuous_intros cf)
  moreover
  note tendstcomp = tendsto_compose[OF c[unfolded isCont_def], where f="\<lambda>x. (x, f x)", simplified, THEN tendsto_eq_rhs]
  have "((\<lambda>x. g x (f x)) \<longlongrightarrow> g i (u i)) (at_right i)" if "i \<in> I" "a \<le> i" "i < b" for i
    by (rule tendstcomp) (auto intro!: tendsto_eq_intros u[OF \<open>i \<in> I\<close>] that)
  moreover
  have "((\<lambda>x. g x (f x)) \<longlongrightarrow> g i (l i)) (at_left i)" if "i \<in> I" "a < i" "i \<le> b" for i
    by (rule tendstcomp) (auto intro!: tendsto_eq_intros l[OF \<open>i \<in> I\<close>] that)
  ultimately show ?thesis
    by (intro piecewise_continuous_onI)
qed

lemma bounded_piecewise_continuous_image:
  "bounded (f ` {a .. b})"
  if "piecewise_continuous_on a b I f" for a b::real
  using that
proof (induction rule: piecewise_continuous_on_induct)
  case (empty a b f)
  then show ?case by (auto intro!: compact_imp_bounded compact_continuous_image)
next
  case (combine a i b I f1 f2 f)
  have "(f ` {a..b}) \<subseteq> (insert (f i) (f1 ` {a..i} \<union> f2 ` {i..b}))"
    using combine
    by (auto simp: image_iff) (metis antisym_conv atLeastAtMost_iff le_cases not_less)
  also have "bounded \<dots>"
    using combine by auto
  finally (bounded_subset[rotated]) show ?case .
qed

lemma tendsto_within_eventually:
  "(f \<longlongrightarrow> l) (at x within X)"
  if
    "(f \<longlongrightarrow> l) (at x within Y)"
    "\<forall>\<^sub>F y in at x within X. y \<in> Y"
  using _ that(1)
proof (rule tendsto_mono)
  show "at x within X \<le> at x within Y"
  proof (rule filter_leI)
    fix P
    assume "eventually P (at x within Y)"
    with that(2) show "eventually P (at x within X)"
      unfolding eventually_at_filter
      by eventually_elim auto
  qed
qed

lemma at_within_eq_bot_lemma:
  "at x within {b..c} = (if x < b \<or> b > c then bot else at x within {b..c})"
  for x b c::"'a::linorder_topology"
  by (auto intro!: not_in_closure_trivial_limitI)

lemma at_within_eq_bot_lemma2:
  "at x within {a..b} = (if x > b \<or> a > b then bot else at x within {a..b})"
  for x a b::"'a::linorder_topology"
  by (auto intro!: not_in_closure_trivial_limitI)

lemma piecewise_continuous_on_combine:
  "piecewise_continuous_on a c J f"
  if "piecewise_continuous_on a b J f" "piecewise_continuous_on b c J f"
  using that
  apply (auto elim!: piecewise_continuous_onE)
  subgoal for l u l' u'
    apply (rule piecewise_continuous_onI[where
          l="\<lambda>i. if i \<le> b then l i else l' i" and
          u="\<lambda>i. if i < b then u i else u' i"])
    subgoal by force
    subgoal
      apply (rule continuous_on_subset[where s="({a .. b} \<union> {b .. c} - J)"])
      apply (auto simp: continuous_on_def at_within_t1_space_avoid_finite)
       apply (rule Lim_Un)
      subgoal by auto
      subgoal by (subst at_within_eq_bot_lemma) auto
      apply (rule Lim_Un)
      subgoal by (subst at_within_eq_bot_lemma2) auto
      subgoal by auto
      done
    by auto
  done

lemma piecewise_continuous_on_finite_superset:
  "piecewise_continuous_on a b I f \<Longrightarrow> I \<subseteq> J \<Longrightarrow> finite J \<Longrightarrow> piecewise_continuous_on a b J f"
  for a b::"'a::{linorder_topology, dense_order, no_bot, no_top}"
  apply (auto simp add: piecewise_continuous_on_def)
    apply (rule continuous_on_subset, assumption, force)
  subgoal for i
    apply (cases "i \<in> I")
     apply (auto simp: continuous_on_def at_within_t1_space_avoid_finite)
    apply (drule bspec[where x=i])
     apply (auto simp: at_within_t1_space_avoid)
    apply (cases "i = b")
     apply (auto simp: at_within_Icc_at_left )
    apply (subst (asm) at_within_interior[where x=i])
    by (auto simp: filterlim_at_split)
  subgoal for i
    apply (cases "i \<in> I")
     apply (auto simp: continuous_on_def at_within_t1_space_avoid_finite)
    apply (drule bspec[where x=i])
     apply (auto simp: at_within_t1_space_avoid)
    apply (cases "i = a")
     apply (auto simp: at_within_Icc_at_right)
    apply (subst (asm) at_within_interior[where x=i])
    subgoal by (simp add: interior_Icc)
    by (auto simp: filterlim_at_split)
  done

lemma piecewise_continuous_on_splitI:
  "piecewise_continuous_on a c K f"
  if
    "piecewise_continuous_on a b I f"
    "piecewise_continuous_on b c J f"
    "I \<subseteq> K" "J \<subseteq> K" "finite K"
  for a b::"'a::{linorder_topology, dense_order, no_bot, no_top}"
  apply (rule piecewise_continuous_on_combine[where b=b])
  subgoal
    by (rule piecewise_continuous_on_finite_superset, fact)
    (use that in \<open>auto elim!: piecewise_continuous_onE\<close>)
  subgoal
    by (rule piecewise_continuous_on_finite_superset, fact)
    (use that in \<open>auto elim!: piecewise_continuous_onE\<close>)
  done

end


(*  Title:       Terminated coinductive list
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

section \<open>Terminated coinductive lists and their operations\<close>

theory TLList imports
  Coinductive_List
begin

text \<open>
  Terminated coinductive lists \<open>('a, 'b) tllist\<close> are the codatatype defined by the construtors
  \<open>TNil\<close> of type \<open>'b \<Rightarrow> ('a, 'b) tllist\<close> and
  \<open>TCons\<close> of type \<open>'a \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist\<close>.
\<close>

subsection \<open>Auxiliary lemmas\<close>

lemma split_fst: "R (fst p) = (\<forall>x y. p = (x, y) \<longrightarrow> R x)"
by(cases p) simp

lemma split_fst_asm: "R (fst p) \<longleftrightarrow> (\<not> (\<exists>x y. p = (x, y) \<and> \<not> R x))"
by(cases p) simp

subsection \<open>Type definition\<close>

consts terminal0 :: "'a"

codatatype (tset: 'a, 'b) tllist =
    TNil (terminal : 'b)
  | TCons (thd : 'a) (ttl : "('a, 'b) tllist")
for
  map: tmap
  rel: tllist_all2
where
  "thd (TNil _) = undefined"
| "ttl (TNil b) = TNil b"
| "terminal (TCons _ xs) = terminal0 xs"

overloading
  terminal0 == "terminal0::('a, 'b) tllist \<Rightarrow> 'b"
begin

partial_function (tailrec) terminal0
where "terminal0 xs = (if is_TNil xs then case_tllist id undefined xs else terminal0 (ttl xs))"

end

lemma terminal0_terminal [simp]: "terminal0 = terminal"
apply(rule ext)
apply(subst terminal0.simps)
apply(case_tac x)
apply(simp_all add: terminal_def)
done

lemmas terminal_TNil [code, nitpick_simp] = tllist.sel(1)

lemma terminal_TCons [simp, code, nitpick_simp]: "terminal (TCons x xs) = terminal xs"
by simp

declare tllist.sel(2) [simp del]

primcorec unfold_tllist :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('c, 'b) tllist" where
  "p a \<Longrightarrow> unfold_tllist p g1 g21 g22 a = TNil (g1 a)" |
  "_ \<Longrightarrow> unfold_tllist p g1 g21 g22 a =
     TCons (g21 a) (unfold_tllist p g1 g21 g22 (g22 a))"

declare
  unfold_tllist.ctr(1) [simp]
  tllist.corec(1) [simp]

subsection \<open>Code generator setup\<close>

text \<open>Test quickcheck setup\<close>

lemma "xs = TNil x"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "TCons x xs = TCons x xs"
quickcheck[narrowing, expect=no_counterexample]
oops

text \<open>More lemmas about generated constants\<close>

lemma is_TNil_ttl [simp]: "is_TNil xs \<Longrightarrow> is_TNil (ttl xs)"
by(cases xs) simp_all

lemma terminal_ttl [simp]: "terminal (ttl xs) = terminal xs"
by(cases xs) simp_all

lemma unfold_tllist_eq_TNil [simp]:
  "unfold_tllist IS_TNIL TNIL THD TTL a = TNil b \<longleftrightarrow> IS_TNIL a \<and> b = TNIL a"
by(auto simp add: unfold_tllist.code)

lemma TNil_eq_unfold_tllist [simp]:
  "TNil b = unfold_tllist IS_TNIL TNIL THD TTL a \<longleftrightarrow> IS_TNIL a \<and> b = TNIL a"
by(auto simp add: unfold_tllist.code)

lemma tmap_is_TNil: "is_TNil xs \<Longrightarrow> tmap f g xs = TNil (g (terminal xs))"
by(clarsimp simp add: is_TNil_def)

declare tllist.map_sel(2)[simp]

lemma ttl_tmap [simp]: "ttl (tmap f g xs) = tmap f g (ttl xs)"
by(cases xs) simp_all

lemma TNil_eq_tmap_conv:
  "TNil y = tmap f g xs \<longleftrightarrow> (\<exists>y'. xs = TNil y' \<and> g y' = y)"
by(cases xs) auto

declare tllist.set_sel(1)[simp]

lemma tset_ttl: "tset (ttl xs) \<subseteq> tset xs"
by(cases xs) auto

lemma in_tset_ttlD: "x \<in> tset (ttl xs) \<Longrightarrow> x \<in> tset xs"
using tset_ttl[of xs] by auto

theorem tllist_set_induct[consumes 1, case_names find step]:
  assumes "x \<in> tset xs" and "\<And>xs. \<not> is_TNil xs \<Longrightarrow> P (thd xs) xs"
  and "\<And>xs y. \<lbrakk>\<not> is_TNil xs; y \<in> tset (ttl xs); P y (ttl xs)\<rbrakk> \<Longrightarrow> P y xs"
  shows "P x xs"
using assms by(induct)(fastforce simp del: tllist.disc(2) iff: tllist.disc(2), auto)

theorem set2_tllist_induct[consumes 1, case_names find step]:
  assumes "x \<in> set2_tllist xs" and "\<And>xs. is_TNil xs \<Longrightarrow> P (terminal xs) xs"
  and "\<And>xs y. \<lbrakk>\<not> is_TNil xs; y \<in> set2_tllist (ttl xs); P y (ttl xs)\<rbrakk> \<Longrightarrow> P y xs"
  shows "P x xs"
using assms by(induct)(fastforce simp del: tllist.disc(1) iff: tllist.disc(1), auto)

subsection \<open>Connection with @{typ "'a llist"}\<close>

context fixes b :: 'b begin
primcorec tllist_of_llist :: "'a llist \<Rightarrow> ('a, 'b) tllist" where
  "tllist_of_llist xs = (case xs of LNil \<Rightarrow> TNil b | LCons x xs' \<Rightarrow> TCons x (tllist_of_llist xs'))"
end

primcorec llist_of_tllist :: "('a, 'b) tllist \<Rightarrow> 'a llist"
where "llist_of_tllist xs = (case xs of TNil _ \<Rightarrow> LNil | TCons x xs' \<Rightarrow> LCons x (llist_of_tllist xs'))"

simps_of_case tllist_of_llist_simps [simp, code, nitpick_simp]: tllist_of_llist.code

lemmas tllist_of_llist_LNil = tllist_of_llist_simps(1)
  and tllist_of_llist_LCons = tllist_of_llist_simps(2)

lemma terminal_tllist_of_llist_lnull [simp]:
  "lnull xs \<Longrightarrow> terminal (tllist_of_llist b xs) = b"
unfolding lnull_def by simp

declare tllist_of_llist.sel(1)[simp del]

lemma lhd_LNil: "lhd LNil = undefined"
by(simp add: lhd_def)

lemma thd_TNil: "thd (TNil b) = undefined"
by(simp add: thd_def)

lemma ttl_tllist_of_llist [simp]: "ttl (tllist_of_llist b xs) = tllist_of_llist b (ltl xs)"
by(cases xs) simp_all

lemma llist_of_tllist_eq_LNil:
  "llist_of_tllist xs = LNil \<longleftrightarrow> is_TNil xs"
using llist_of_tllist.disc_iff(1) unfolding lnull_def .

simps_of_case llist_of_tllist_simps [simp, code, nitpick_simp]: llist_of_tllist.code

lemmas llist_of_tllist_TNil = llist_of_tllist_simps(1)
  and llist_of_tllist_TCons = llist_of_tllist_simps(2)

declare llist_of_tllist.sel [simp del]

lemma lhd_llist_of_tllist [simp]: "\<not> is_TNil xs \<Longrightarrow> lhd (llist_of_tllist xs) = thd xs"
by(cases xs) simp_all

lemma ltl_llist_of_tllist [simp]:
  "ltl (llist_of_tllist xs) = llist_of_tllist (ttl xs)"
by(cases xs) simp_all

lemma tllist_of_llist_cong [cong]:
  assumes "xs = xs'" "lfinite xs' \<Longrightarrow> b = b'"
  shows "tllist_of_llist b xs = tllist_of_llist b' xs'"
proof(unfold \<open>xs = xs'\<close>)
  from assms have "lfinite xs' \<longrightarrow> b = b'" by simp
  thus "tllist_of_llist b xs' = tllist_of_llist b' xs'"
    by(coinduction arbitrary: xs') auto
qed

lemma llist_of_tllist_inverse [simp]:
  "tllist_of_llist (terminal b) (llist_of_tllist b) = b"
by(coinduction arbitrary: b) simp_all

lemma tllist_of_llist_eq [simp]: "tllist_of_llist b' xs = TNil b \<longleftrightarrow> b = b' \<and> xs = LNil"
by(cases xs) auto

lemma TNil_eq_tllist_of_llist [simp]: "TNil b = tllist_of_llist b' xs \<longleftrightarrow> b = b' \<and> xs = LNil"
by(cases xs) auto

lemma tllist_of_llist_inject [simp]:
  "tllist_of_llist b xs = tllist_of_llist c ys \<longleftrightarrow> xs = ys \<and> (lfinite ys \<longrightarrow> b = c)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof(intro iffI conjI impI)
  assume ?rhs
  thus ?lhs by(auto intro: tllist_of_llist_cong)
next
  assume ?lhs
  thus "xs = ys"
    by(coinduction arbitrary: xs ys)(auto simp add: lnull_def neq_LNil_conv)
  assume "lfinite ys"
  thus "b = c" using \<open>?lhs\<close>
    unfolding \<open>xs = ys\<close> by(induct) simp_all
qed

lemma tllist_of_llist_inverse [simp]:
  "llist_of_tllist (tllist_of_llist b xs) = xs"
by(coinduction arbitrary: xs) auto

definition cr_tllist :: "('a llist \<times> 'b) \<Rightarrow> ('a, 'b) tllist \<Rightarrow> bool"
  where "cr_tllist \<equiv> (\<lambda>(xs, b) ys. tllist_of_llist b xs = ys)"

lemma Quotient_tllist:
  "Quotient (\<lambda>(xs, a) (ys, b). xs = ys \<and> (lfinite ys \<longrightarrow> a = b))
     (\<lambda>(xs, a). tllist_of_llist a xs) (\<lambda>ys. (llist_of_tllist ys, terminal ys)) cr_tllist"
unfolding Quotient_alt_def cr_tllist_def by(auto intro: tllist_of_llist_cong)

lemma reflp_tllist: "reflp (\<lambda>(xs, a) (ys, b). xs = ys \<and> (lfinite ys \<longrightarrow> a = b))"
by(simp add: reflp_def)

setup_lifting Quotient_tllist reflp_tllist

context includes lifting_syntax
begin

lemma TNil_transfer [transfer_rule]:
  "(B ===> pcr_tllist A B) (Pair LNil) TNil"
by(force simp add: pcr_tllist_def cr_tllist_def)

lemma TCons_transfer [transfer_rule]:
  "(A ===> pcr_tllist A B ===> pcr_tllist A B) (apfst \<circ> LCons) TCons"
by(force simp add: pcr_tllist_def llist_all2_LCons1 cr_tllist_def)

lemma tmap_tllist_of_llist:
  "tmap f g (tllist_of_llist b xs) = tllist_of_llist (g b) (lmap f xs)"
by(coinduction arbitrary: xs)(auto simp add: tmap_is_TNil)

lemma tmap_transfer [transfer_rule]:
  "((=) ===> (=) ===> pcr_tllist (=) (=) ===> pcr_tllist (=) (=)) (map_prod \<circ> lmap) tmap"
by(force simp add: cr_tllist_def tllist.pcr_cr_eq tmap_tllist_of_llist)

lemma lset_llist_of_tllist [simp]:
  "lset (llist_of_tllist xs) = tset xs" (is "?lhs = ?rhs")
proof(intro set_eqI iffI)
  fix x
  assume "x \<in> ?lhs"
  thus "x \<in> ?rhs"
    by(induct "llist_of_tllist xs" arbitrary: xs rule: llist_set_induct)(auto simp: tllist.set_sel(2))
next
  fix x
  assume "x \<in> ?rhs"
  thus "x \<in> ?lhs"
  proof(induct rule: tllist_set_induct)
    case (find xs)
    thus ?case by(cases xs) auto
  next
    case step
    thus ?case
      by(auto simp add: ltl_llist_of_tllist[symmetric] simp del: ltl_llist_of_tllist dest: in_lset_ltlD)
  qed
qed

lemma tset_tllist_of_llist [simp]:
  "tset (tllist_of_llist b xs) = lset xs"
by(simp add: lset_llist_of_tllist[symmetric] del: lset_llist_of_tllist)

lemma tset_transfer [transfer_rule]:
  "(pcr_tllist (=) (=) ===> (=)) (lset \<circ> fst) tset"
by(auto simp add: cr_tllist_def tllist.pcr_cr_eq)

lemma is_TNil_transfer [transfer_rule]:
  "(pcr_tllist (=) (=) ===> (=)) (\<lambda>(xs, b). lnull xs) is_TNil"
by(auto simp add: tllist.pcr_cr_eq cr_tllist_def)

lemma thd_transfer [transfer_rule]:
  "(pcr_tllist (=) (=) ===> (=)) (lhd \<circ> fst) thd"
by(auto simp add: cr_tllist_def tllist.pcr_cr_eq)

lemma ttl_transfer [transfer_rule]:
  "(pcr_tllist A B ===> pcr_tllist A B) (apfst ltl) ttl"
by(force simp add: pcr_tllist_def cr_tllist_def intro: llist_all2_ltlI)

lemma llist_of_tllist_transfer [transfer_rule]:
  "(pcr_tllist (=) B ===> (=)) fst llist_of_tllist"
by(auto simp add: pcr_tllist_def cr_tllist_def llist.rel_eq)

lemma tllist_of_llist_transfer [transfer_rule]:
  "((=) ===> (=) ===> pcr_tllist (=) (=)) (\<lambda>b xs. (xs, b)) tllist_of_llist"
by(auto simp add: tllist.pcr_cr_eq cr_tllist_def)

lemma terminal_tllist_of_llist_lfinite [simp]:
  "lfinite xs \<Longrightarrow> terminal (tllist_of_llist b xs) = b"
by(induct rule: lfinite.induct) simp_all

lemma set2_tllist_tllist_of_llist [simp]:
  "set2_tllist (tllist_of_llist b xs) = (if lfinite xs then {b} else {})"
proof(cases "lfinite xs")
  case True
  thus ?thesis by(induct) auto
next
  case False
  { fix x
    assume "x \<in> set2_tllist (tllist_of_llist b xs)"
    hence False using False
      by(induct "tllist_of_llist b xs" arbitrary: xs rule: set2_tllist_induct) fastforce+ }
  thus ?thesis using False by auto
qed

lemma set2_tllist_transfer [transfer_rule]:
  "(pcr_tllist A B ===> rel_set B) (\<lambda>(xs, b). if lfinite xs then {b} else {}) set2_tllist"
by(auto 4 4 simp add: pcr_tllist_def cr_tllist_def dest: llist_all2_lfiniteD intro: rel_setI)

lemma tllist_all2_transfer [transfer_rule]:
  "((=) ===> (=) ===> pcr_tllist (=) (=) ===> pcr_tllist (=) (=) ===> (=))
     (\<lambda>P Q (xs, b) (ys, b'). llist_all2 P xs ys \<and> (lfinite xs \<longrightarrow> Q b b')) tllist_all2"
unfolding tllist.pcr_cr_eq
apply(rule rel_funI)+
apply(clarsimp simp add: cr_tllist_def llist_all2_def tllist_all2_def)
apply(safe elim!: GrpE)
   apply simp_all
   apply(rule_tac b="tllist_of_llist (b, ba) bb" in relcomppI)
    apply(auto intro!: GrpI simp add: tmap_tllist_of_llist)[2]
  apply(rule_tac b="tllist_of_llist (b, ba) bb" in relcomppI)
   apply(auto simp add: tmap_tllist_of_llist intro!: GrpI split: if_split_asm)[2]
 apply(rule_tac b="llist_of_tllist bb" in relcomppI)
apply(auto intro!: GrpI)
apply(transfer, auto intro: GrpI split: if_split_asm)+
done

subsection \<open>Library function definitions\<close>

text \<open>
  We lift the constants from @{typ "'a llist"} to @{typ "('a, 'b) tllist"} using the lifting package.
  This way, many results are transferred easily.
\<close>

lift_definition tappend :: "('a, 'b) tllist \<Rightarrow> ('b \<Rightarrow> ('a, 'c) tllist) \<Rightarrow> ('a, 'c) tllist"
is "\<lambda>(xs, b) f. apfst (lappend xs) (f b)"
by(auto simp add: split_def lappend_inf)

lift_definition lappendt :: "'a llist \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "apfst \<circ> lappend"
by(simp add: split_def)

lift_definition tfilter :: "'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "\<lambda>b P (xs, b'). (lfilter P xs, if lfinite xs then b' else b)"
by(simp add: split_beta)

lift_definition tconcat :: "'b \<Rightarrow> ('a llist, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "\<lambda>b (xss, b'). (lconcat xss, if lfinite xss then b' else b)"
by(simp add: split_beta)

lift_definition tnth :: "('a, 'b) tllist \<Rightarrow> nat \<Rightarrow> 'a"
is "lnth \<circ> fst" by(auto)

lift_definition tlength :: "('a, 'b) tllist \<Rightarrow> enat"
is "llength \<circ> fst" by auto

lift_definition tdropn :: "nat \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
is "apfst \<circ> ldropn" by auto

abbreviation tfinite :: "('a, 'b) tllist \<Rightarrow> bool"
where "tfinite xs \<equiv> lfinite (llist_of_tllist xs)"

subsection \<open>@{term "tfinite"}\<close>

lemma tfinite_induct [consumes 1, case_names TNil TCons]:
  assumes "tfinite xs"
  and "\<And>y. P (TNil y)"
  and "\<And>x xs. \<lbrakk>tfinite xs; P xs\<rbrakk> \<Longrightarrow> P (TCons x xs)"
  shows "P xs"
using assms
by transfer (clarsimp, erule lfinite.induct)

lemma is_TNil_tfinite [simp]: "is_TNil xs \<Longrightarrow> tfinite xs"
by transfer clarsimp

subsection \<open>The terminal element @{term "terminal"}\<close>

lemma terminal_tinfinite:
  assumes "\<not> tfinite xs"
  shows "terminal xs = undefined"
unfolding terminal0_terminal[symmetric]
using assms
apply(rule contrapos_np)
by(induct xs rule: terminal0.raw_induct[rotated 1, OF refl, consumes 1])(auto split: tllist.split_asm)

lemma terminal_tllist_of_llist:
  "terminal (tllist_of_llist y xs) = (if lfinite xs then y else undefined)"
by(simp add: terminal_tinfinite)

lemma terminal_transfer [transfer_rule]:
  "(pcr_tllist A (=) ===> (=)) (\<lambda>(xs, b). if lfinite xs then b else undefined) terminal"
by(force simp add: cr_tllist_def pcr_tllist_def terminal_tllist_of_llist dest: llist_all2_lfiniteD)

lemma terminal_tmap [simp]: "tfinite xs \<Longrightarrow> terminal (tmap f g xs) = g (terminal xs)"
by(induct rule: tfinite_induct) simp_all

subsection \<open>@{term "tmap"}\<close>

lemma TCons_eq_tmap_conv:
  "TCons y ys = tmap f g xs \<longleftrightarrow>
  (\<exists>z zs. xs = TCons z zs \<and> f z = y \<and> tmap f g zs = ys)"
by(cases xs) auto

subsection \<open>Appending two terminated lazy lists @{term "tappend" }\<close>

lemma tappend_TNil [simp, code, nitpick_simp]:
  "tappend (TNil b) f = f b"
by transfer auto

lemma tappend_TCons [simp, code, nitpick_simp]:
  "tappend (TCons a tr) f = TCons a (tappend tr f)"
by transfer(auto simp add: apfst_def map_prod_def split: prod.splits)

lemma tappend_TNil2 [simp]:
  "tappend xs TNil = xs"
by transfer auto

lemma tappend_assoc: "tappend (tappend xs f) g = tappend xs (\<lambda>b. tappend (f b) g)"
by transfer(auto simp add: split_beta lappend_assoc)

lemma tfinite_tappend: "tfinite (tappend xs f) \<longleftrightarrow> tfinite xs \<and> tfinite (f (terminal xs))"
by transfer auto

lift_definition tcast :: "('a, 'b) tllist \<Rightarrow> ('a, 'c) tllist"
is "\<lambda>(xs, a). (xs, undefined)" by clarsimp

lemma tappend_inf: "\<not> tfinite xs \<Longrightarrow> tappend xs f = tcast xs"
by(transfer)(auto simp add: apfst_def map_prod_def split_beta lappend_inf)

text \<open>@{term tappend} is the monadic bind on @{typ "('a, 'b) tllist"}\<close>

lemmas tllist_monad = tappend_TNil tappend_TNil2 tappend_assoc

subsection \<open>Appending a terminated lazy list to a lazy list @{term "lappendt"}\<close>

lemma lappendt_LNil [simp, code, nitpick_simp]: "lappendt LNil tr = tr"
by transfer auto

lemma lappendt_LCons [simp, code, nitpick_simp]:
  "lappendt (LCons x xs) tr = TCons x (lappendt xs tr)"
by transfer auto

lemma terminal_lappendt_lfinite [simp]:
  "lfinite xs \<Longrightarrow> terminal (lappendt xs ys) = terminal ys"
by transfer auto

lemma tllist_of_llist_eq_lappendt_conv:
  "tllist_of_llist a xs = lappendt ys zs \<longleftrightarrow>
  (\<exists>xs' a'. xs = lappend ys xs' \<and> zs = tllist_of_llist a' xs' \<and> (lfinite ys \<longrightarrow> a = a'))"
by transfer auto

lemma tset_lappendt_lfinite [simp]:
  "lfinite xs \<Longrightarrow> tset (lappendt xs ys) = lset xs \<union> tset ys"
by transfer auto

subsection \<open>Filtering terminated lazy lists @{term tfilter}\<close>

lemma tfilter_TNil [simp]:
  "tfilter b' P (TNil b) = TNil b"
by transfer auto

lemma tfilter_TCons [simp]:
  "tfilter b P (TCons a tr) = (if P a then TCons a (tfilter b P tr) else tfilter b P tr)"
by transfer auto

lemma is_TNil_tfilter[simp]:
  "is_TNil (tfilter y P xs) \<longleftrightarrow> (\<forall>x \<in> tset xs. \<not> P x)"
by transfer auto

lemma tfilter_empty_conv:
  "tfilter y P xs = TNil y' \<longleftrightarrow> (\<forall>x \<in> tset xs. \<not> P x) \<and> (if tfinite xs then terminal xs = y' else y = y')"
by transfer(clarsimp simp add: lfilter_eq_LNil)

lemma tfilter_eq_TConsD:
  "tfilter a P ys = TCons x xs \<Longrightarrow>
   \<exists>us vs. ys = lappendt us (TCons x vs) \<and> lfinite us \<and> (\<forall>u\<in>lset us. \<not> P u) \<and> P x \<and> xs = tfilter a P vs"
by transfer(fastforce dest: lfilter_eq_LConsD[OF sym])

text \<open>Use a version of @{term "tfilter"} for code generation that does not evaluate the first argument\<close>

definition tfilter' :: "(unit \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
where [simp, code del]: "tfilter' b = tfilter (b ())"

lemma tfilter_code [code, code_unfold]:
  "tfilter = (\<lambda>b. tfilter' (\<lambda>_. b))"
by simp

lemma tfilter'_code [code]:
  "tfilter' b' P (TNil b) = TNil b"
  "tfilter' b' P (TCons a tr) = (if P a then TCons a (tfilter' b' P tr) else tfilter' b' P tr)"
by simp_all

end

hide_const (open) tfilter'

subsection \<open>Concatenating a terminated lazy list of lazy lists @{term tconcat}\<close>

lemma tconcat_TNil [simp]: "tconcat b (TNil b') = TNil b'"
by transfer auto

lemma tconcat_TCons [simp]: "tconcat b (TCons a tr) = lappendt a (tconcat b tr)"
by transfer auto

text \<open>Use a version of @{term "tconcat"} for code generation that does not evaluate the first argument\<close>

definition tconcat' :: "(unit \<Rightarrow> 'b) \<Rightarrow> ('a llist, 'b) tllist \<Rightarrow> ('a, 'b) tllist"
where [simp, code del]: "tconcat' b = tconcat (b ())"

lemma tconcat_code [code, code_unfold]: "tconcat = (\<lambda>b. tconcat' (\<lambda>_. b))"
by simp

lemma tconcat'_code [code]:
  "tconcat' b (TNil b') = TNil b'"
  "tconcat' b (TCons a tr) = lappendt a (tconcat' b tr)"
by simp_all

hide_const (open) tconcat'

subsection \<open>@{term tllist_all2}\<close>

lemmas tllist_all2_TNil = tllist.rel_inject(1)
lemmas tllist_all2_TCons = tllist.rel_inject(2)

lemma tllist_all2_TNil1: "tllist_all2 P Q (TNil b) ts \<longleftrightarrow> (\<exists>b'. ts = TNil b' \<and> Q b b')"
by transfer auto

lemma tllist_all2_TNil2: "tllist_all2 P Q ts (TNil b') \<longleftrightarrow> (\<exists>b. ts = TNil b \<and> Q b b')"
by transfer auto

lemma tllist_all2_TCons1:
  "tllist_all2 P Q (TCons x ts) ts' \<longleftrightarrow> (\<exists>x' ts''. ts' = TCons x' ts'' \<and> P x x' \<and> tllist_all2 P Q ts ts'')"
by transfer(fastforce simp add: llist_all2_LCons1 dest: llist_all2_lfiniteD)

lemma tllist_all2_TCons2:
  "tllist_all2 P Q ts' (TCons x ts) \<longleftrightarrow> (\<exists>x' ts''. ts' = TCons x' ts'' \<and> P x' x \<and> tllist_all2 P Q ts'' ts)"
by transfer(fastforce simp add: llist_all2_LCons2 dest: llist_all2_lfiniteD)

lemma tllist_all2_coinduct [consumes 1, case_names tllist_all2, case_conclusion tllist_all2 is_TNil TNil TCons, coinduct pred: tllist_all2]:
  assumes "X xs ys"
  and "\<And>xs ys. X xs ys \<Longrightarrow>
  (is_TNil xs \<longleftrightarrow> is_TNil ys) \<and>
  (is_TNil xs \<longrightarrow> is_TNil ys \<longrightarrow> R (terminal xs) (terminal ys)) \<and>
  (\<not> is_TNil xs \<longrightarrow> \<not> is_TNil ys \<longrightarrow> P (thd xs) (thd ys) \<and> (X (ttl xs) (ttl ys) \<or> tllist_all2 P R (ttl xs) (ttl ys)))"
  shows "tllist_all2 P R xs ys"
using assms
apply(transfer fixing: P R)
apply clarsimp
apply(rule conjI)
 apply(erule llist_all2_coinduct, blast, blast)
apply (rule impI)
subgoal premises prems for X xs b ys c
proof -
  from \<open>lfinite xs\<close> \<open>X (xs, b) (ys, c)\<close>
  show "R b c"
    by(induct arbitrary: ys rule: lfinite_induct)(auto dest: prems(2))
qed
done

lemma tllist_all2_cases[consumes 1, case_names TNil TCons, cases pred]:
  assumes "tllist_all2 P Q xs ys"
  obtains (TNil) b b' where "xs = TNil b" "ys = TNil b'" "Q b b'"
  | (TCons) x xs' y ys'
    where "xs = TCons x xs'" and "ys = TCons y ys'"
    and "P x y" and "tllist_all2 P Q xs' ys'"
using assms
by(cases xs)(fastforce simp add: tllist_all2_TCons1 tllist_all2_TNil1)+

lemma tllist_all2_tmap1:
  "tllist_all2 P Q (tmap f g xs) ys \<longleftrightarrow> tllist_all2 (\<lambda>x. P (f x)) (\<lambda>x. Q (g x)) xs ys"
by(transfer)(auto simp add: llist_all2_lmap1)

lemma tllist_all2_tmap2:
  "tllist_all2 P Q xs (tmap f g ys) \<longleftrightarrow> tllist_all2 (\<lambda>x y. P x (f y)) (\<lambda>x y. Q x (g y)) xs ys"
by(transfer)(auto simp add: llist_all2_lmap2)

lemma tllist_all2_mono:
  "\<lbrakk> tllist_all2 P Q xs ys; \<And>x y. P x y \<Longrightarrow> P' x y; \<And>x y. Q x y \<Longrightarrow> Q' x y \<rbrakk>
  \<Longrightarrow> tllist_all2 P' Q' xs ys"
by transfer(auto elim!: llist_all2_mono)

lemma tllist_all2_tlengthD: "tllist_all2 P Q xs ys \<Longrightarrow> tlength xs = tlength ys"
by(transfer)(auto dest: llist_all2_llengthD)

lemma tllist_all2_tfiniteD: "tllist_all2 P Q xs ys \<Longrightarrow> tfinite xs = tfinite ys"
by(transfer)(auto dest: llist_all2_lfiniteD)

lemma tllist_all2_tfinite1_terminalD:
  "\<lbrakk> tllist_all2 P Q xs ys; tfinite xs \<rbrakk> \<Longrightarrow> Q (terminal xs) (terminal ys)"
by(frule tllist_all2_tfiniteD)(transfer, auto)

lemma tllist_all2_tfinite2_terminalD:
  "\<lbrakk> tllist_all2 P Q xs ys; tfinite ys \<rbrakk> \<Longrightarrow> Q (terminal xs) (terminal ys)"
by(metis tllist_all2_tfinite1_terminalD tllist_all2_tfiniteD)

lemma tllist_all2D_llist_all2_llist_of_tllist:
  "tllist_all2 P Q xs ys \<Longrightarrow> llist_all2 P (llist_of_tllist xs) (llist_of_tllist ys)"
by(transfer) auto

lemma tllist_all2_is_TNilD:
  "tllist_all2 P Q xs ys \<Longrightarrow> is_TNil xs \<longleftrightarrow> is_TNil ys"
by(cases xs)(auto simp add: tllist_all2_TNil1 tllist_all2_TCons1)

lemma tllist_all2_thdD:
  "\<lbrakk> tllist_all2 P Q xs ys; \<not> is_TNil xs \<or> \<not> is_TNil ys \<rbrakk> \<Longrightarrow> P (thd xs) (thd ys)"
by(cases xs)(auto simp add: tllist_all2_TNil1 tllist_all2_TCons1)

lemma tllist_all2_ttlI:
  "\<lbrakk> tllist_all2 P Q xs ys; \<not> is_TNil xs \<or> \<not> is_TNil ys \<rbrakk> \<Longrightarrow> tllist_all2 P Q (ttl xs) (ttl ys)"
by(cases xs)(auto simp add: tllist_all2_TNil1 tllist_all2_TCons1)

lemma tllist_all2_refl:
  "tllist_all2 P Q xs xs \<longleftrightarrow> (\<forall>x \<in> tset xs. P x x) \<and> (tfinite xs \<longrightarrow> Q (terminal xs) (terminal xs))"
by transfer(auto)

lemma tllist_all2_reflI:
  "\<lbrakk> \<And>x. x \<in> tset xs \<Longrightarrow> P x x; tfinite xs \<Longrightarrow> Q (terminal xs) (terminal xs) \<rbrakk>
  \<Longrightarrow> tllist_all2 P Q xs xs"
by(simp add: tllist_all2_refl)

lemma tllist_all2_conv_all_tnth:
  "tllist_all2 P Q xs ys \<longleftrightarrow>
  tlength xs = tlength ys \<and>
  (\<forall>n. enat n < tlength xs \<longrightarrow> P (tnth xs n) (tnth ys n)) \<and>
  (tfinite xs \<longrightarrow> Q (terminal xs) (terminal ys))"
by transfer(auto 4 4 simp add: llist_all2_conv_all_lnth split: if_split_asm dest: lfinite_llength_enat not_lfinite_llength)

lemma tllist_all2_tnthD:
  "\<lbrakk> tllist_all2 P Q xs ys; enat n < tlength xs \<rbrakk>
  \<Longrightarrow> P (tnth xs n) (tnth ys n)"
by(simp add: tllist_all2_conv_all_tnth)

lemma tllist_all2_tnthD2:
  "\<lbrakk> tllist_all2 P Q xs ys; enat n < tlength ys \<rbrakk>
  \<Longrightarrow> P (tnth xs n) (tnth ys n)"
by(simp add: tllist_all2_conv_all_tnth)

lemmas tllist_all2_eq = tllist.rel_eq

lemma tmap_eq_tmap_conv_tllist_all2:
  "tmap f g xs = tmap f' g' ys \<longleftrightarrow>
  tllist_all2 (\<lambda>x y. f x = f' y) (\<lambda>x y. g x = g' y) xs ys"
apply transfer
apply(clarsimp simp add: lmap_eq_lmap_conv_llist_all2)
apply(auto dest: llist_all2_lfiniteD)
done

lemma tllist_all2_trans:
  "\<lbrakk> tllist_all2 P Q xs ys; tllist_all2 P Q ys zs; transp P; transp Q \<rbrakk>
  \<Longrightarrow> tllist_all2 P Q xs zs"
by transfer(auto elim: llist_all2_trans dest: llist_all2_lfiniteD transpD)

lemma tllist_all2_tappendI:
  "\<lbrakk> tllist_all2 P Q xs ys;
     \<lbrakk> tfinite xs; tfinite ys; Q (terminal xs) (terminal ys) \<rbrakk>
     \<Longrightarrow> tllist_all2 P R (xs' (terminal xs)) (ys' (terminal ys)) \<rbrakk>
  \<Longrightarrow> tllist_all2 P R (tappend xs xs') (tappend ys ys')"
apply transfer
apply(auto 4 3 simp add: apfst_def map_prod_def lappend_inf split: prod.split_asm dest: llist_all2_lfiniteD intro: llist_all2_lappendI)
apply(frule llist_all2_lfiniteD, simp add: lappend_inf)
done

lemma llist_all2_tllist_of_llistI:
  "tllist_all2 A B xs ys \<Longrightarrow> llist_all2 A (llist_of_tllist xs) (llist_of_tllist ys)"
by(coinduction arbitrary: xs ys)(auto dest: tllist_all2_is_TNilD tllist_all2_thdD intro: tllist_all2_ttlI)

lemma tllist_all2_tllist_of_llist [simp]:
  "tllist_all2 A B (tllist_of_llist b xs) (tllist_of_llist c ys) \<longleftrightarrow>
  llist_all2 A xs ys \<and> (lfinite xs \<longrightarrow> B b c)"
by transfer auto

subsection \<open>From a terminated lazy list to a lazy list @{term llist_of_tllist}\<close>

lemma llist_of_tllist_tmap [simp]:
  "llist_of_tllist (tmap f g xs) = lmap f (llist_of_tllist xs)"
by transfer auto

lemma llist_of_tllist_tappend:
  "llist_of_tllist (tappend xs f) = lappend (llist_of_tllist xs) (llist_of_tllist (f (terminal xs)))"
by(transfer)(auto simp add: lappend_inf)

lemma llist_of_tllist_lappendt [simp]:
  "llist_of_tllist (lappendt xs tr) = lappend xs (llist_of_tllist tr)"
by transfer auto

lemma llist_of_tllist_tfilter [simp]:
  "llist_of_tllist (tfilter b P tr) = lfilter P (llist_of_tllist tr)"
by transfer auto

lemma llist_of_tllist_tconcat:
  "llist_of_tllist (tconcat b trs) = lconcat (llist_of_tllist trs)"
by transfer auto

lemma llist_of_tllist_eq_lappend_conv:
  "llist_of_tllist xs = lappend us vs \<longleftrightarrow>
  (\<exists>ys. xs = lappendt us ys \<and> vs = llist_of_tllist ys \<and> terminal xs = terminal ys)"
by transfer auto

subsection \<open>The nth element of a terminated lazy list @{term "tnth"}\<close>

lemma tnth_TNil [nitpick_simp]:
  "tnth (TNil b) n = undefined n"
by(transfer)(simp add: lnth_LNil)

lemma tnth_TCons:
  "tnth (TCons x xs) n = (case n of 0 \<Rightarrow> x | Suc n' \<Rightarrow> tnth xs n')"
by(transfer)(auto simp add: lnth_LCons split: nat.split)

lemma lnth_llist_of_tllist [simp]:
  "lnth (llist_of_tllist xs) = tnth xs"
by(transfer)(auto)

lemma tnth_tmap [simp]: "enat n < tlength xs \<Longrightarrow> tnth (tmap f g xs) n = f (tnth xs n)"
by transfer simp

subsection \<open>The length of a terminated lazy list @{term "tlength"}\<close>

lemma [simp, nitpick_simp]:
  shows tlength_TNil: "tlength (TNil b) = 0"
  and tlength_TCons: "tlength (TCons x xs) = eSuc (tlength xs)"
 apply(transfer, simp)
apply(transfer, auto)
done

lemma llength_llist_of_tllist [simp]: "llength (llist_of_tllist xs) = tlength xs"
by transfer auto

lemma tlength_tmap [simp]: "tlength (tmap f g xs) = tlength xs"
by transfer simp

definition gen_tlength :: "nat \<Rightarrow> ('a, 'b) tllist \<Rightarrow> enat"
where "gen_tlength n xs = enat n + tlength xs"

lemma gen_tlength_code [code]:
  "gen_tlength n (TNil b) = enat n"
  "gen_tlength n (TCons x xs) = gen_tlength (n + 1) xs"
by(simp_all add: gen_tlength_def iadd_Suc eSuc_enat[symmetric] iadd_Suc_right)

lemma tlength_code [code]: "tlength = gen_tlength 0"
by(simp add: gen_tlength_def fun_eq_iff zero_enat_def)

subsection \<open>@{term "tdropn"}\<close>

lemma tdropn_0 [simp, code, nitpick_simp]: "tdropn 0 xs = xs"
by transfer auto

lemma tdropn_TNil [simp, code]: "tdropn n (TNil b) = (TNil b)"
by transfer(auto)

lemma tdropn_Suc_TCons [simp, code]: "tdropn (Suc n) (TCons x xs) = tdropn n xs"
by transfer(auto)

lemma tdropn_Suc [nitpick_simp]: "tdropn (Suc n) xs = (case xs of TNil b \<Rightarrow> TNil b | TCons x xs' \<Rightarrow> tdropn n xs')"
by(cases xs) simp_all

lemma lappendt_ltake_tdropn:
  "lappendt (ltake (enat n) (llist_of_tllist xs)) (tdropn n xs) = xs"
by transfer (auto)

lemma llist_of_tllist_tdropn [simp]:
  "llist_of_tllist (tdropn n xs) = ldropn n (llist_of_tllist xs)"
by transfer auto

lemma tdropn_Suc_conv_tdropn:
  "enat n < tlength xs \<Longrightarrow> TCons (tnth xs n) (tdropn (Suc n) xs) = tdropn n xs"
by transfer(auto simp add: ldropn_Suc_conv_ldropn)

lemma tlength_tdropn [simp]: "tlength (tdropn n xs) = tlength xs - enat n"
by transfer auto

lemma tnth_tdropn [simp]: "enat (n + m) < tlength xs \<Longrightarrow> tnth (tdropn n xs) m = tnth xs (m + n)"
by transfer auto

subsection \<open>@{term "tset"}\<close>

lemma tset_induct [consumes 1, case_names find step]:
  assumes "x \<in> tset xs"
  and "\<And>xs. P (TCons x xs)"
  and "\<And>x' xs. \<lbrakk> x \<in> tset xs; x \<noteq> x'; P xs \<rbrakk> \<Longrightarrow> P (TCons x' xs)"
  shows "P xs"
using assms
by transfer(clarsimp, erule lset_induct)

lemma tset_conv_tnth: "tset xs = {tnth xs n|n . enat n < tlength xs}"
by transfer(simp add: lset_conv_lnth)

lemma in_tset_conv_tnth: "x \<in> tset xs \<longleftrightarrow> (\<exists>n. enat n < tlength xs \<and> tnth xs n = x)"
using tset_conv_tnth[of xs] by auto

subsection \<open>Setup for Lifting/Transfer\<close>

subsubsection \<open>Relator and predicator properties\<close>

abbreviation "tllist_all == pred_tllist"

subsubsection \<open>Transfer rules for the Transfer package\<close>

context includes lifting_syntax
begin

lemma set1_pre_tllist_transfer [transfer_rule]:
  "(rel_pre_tllist A B C ===> rel_set A) set1_pre_tllist set1_pre_tllist"
by(auto simp add: rel_pre_tllist_def vimage2p_def rel_fun_def set1_pre_tllist_def rel_set_def collect_def sum_set_defs prod_set_defs elim: rel_sum.cases split: sum.split_asm)

lemma set2_pre_tllist_transfer [transfer_rule]:
  "(rel_pre_tllist A B C ===> rel_set B) set2_pre_tllist set2_pre_tllist"
by(auto simp add: rel_pre_tllist_def vimage2p_def rel_fun_def set2_pre_tllist_def rel_set_def collect_def sum_set_defs prod_set_defs elim: rel_sum.cases split: sum.split_asm)

lemma set3_pre_tllist_transfer [transfer_rule]:
  "(rel_pre_tllist A B C ===> rel_set C) set3_pre_tllist set3_pre_tllist"
by(auto simp add: rel_pre_tllist_def vimage2p_def rel_fun_def set3_pre_tllist_def rel_set_def collect_def sum_set_defs prod_set_defs elim: rel_sum.cases split: sum.split_asm)

lemma TNil_transfer2 [transfer_rule]: "(B ===> tllist_all2 A B) TNil TNil"
by auto
declare TNil_transfer [transfer_rule]

lemma TCons_transfer2 [transfer_rule]:
  "(A ===> tllist_all2 A B ===> tllist_all2 A B) TCons TCons"
unfolding rel_fun_def by simp
declare TCons_transfer [transfer_rule]

lemma case_tllist_transfer [transfer_rule]:
  "((B ===> C) ===> (A ===> tllist_all2 A B ===> C) ===> tllist_all2 A B ===> C)
    case_tllist case_tllist"
unfolding rel_fun_def
by (simp add: tllist_all2_TNil1 tllist_all2_TNil2 split: tllist.split)

lemma unfold_tllist_transfer [transfer_rule]:
  "((A ===> (=)) ===> (A ===> B) ===> (A ===> C) ===> (A ===> A) ===> A ===> tllist_all2 C B) unfold_tllist unfold_tllist"
proof(rule rel_funI)+
  fix IS_TNIL1 :: "'a \<Rightarrow> bool" and IS_TNIL2
    TERMINAL1 TERMINAL2 THD1 THD2 TTL1 TTL2 x y
  assume rel: "(A ===> (=)) IS_TNIL1 IS_TNIL2" "(A ===> B) TERMINAL1 TERMINAL2"
    "(A ===> C) THD1 THD2" "(A ===> A) TTL1 TTL2"
    and "A x y"
  show "tllist_all2 C B (unfold_tllist IS_TNIL1 TERMINAL1 THD1 TTL1 x) (unfold_tllist IS_TNIL2 TERMINAL2 THD2 TTL2 y)"
    using \<open>A x y\<close>
    apply(coinduction arbitrary: x y)
    using rel by(auto 4 4 elim: rel_funE)
qed

lemma corec_tllist_transfer [transfer_rule]:
  "((A ===> (=)) ===> (A ===> B) ===> (A ===> C) ===> (A ===> (=)) ===> (A ===> tllist_all2 C B) ===> (A ===> A) ===> A ===> tllist_all2 C B) corec_tllist corec_tllist"
proof(rule rel_funI)+
  fix IS_TNIL1 MORE1 :: "'a \<Rightarrow> bool" and IS_TNIL2
    TERMINAL1 TERMINAL2 THD1 THD2 MORE2 STOP1 STOP2 TTL1 TTL2 x y
  assume rel: "(A ===> (=)) IS_TNIL1 IS_TNIL2" "(A ===> B) TERMINAL1 TERMINAL2"
    "(A ===> C) THD1 THD2" "(A ===> (=)) MORE1 MORE2"
    "(A ===> tllist_all2 C B) STOP1 STOP2" "(A ===> A) TTL1 TTL2"
    and "A x y"
  show "tllist_all2 C B (corec_tllist IS_TNIL1 TERMINAL1 THD1 MORE1 STOP1 TTL1 x) (corec_tllist IS_TNIL2 TERMINAL2 THD2 MORE2 STOP2 TTL2 y)"
    using \<open>A x y\<close>
    apply(coinduction arbitrary: x y)
    using rel by(auto 4 4 elim: rel_funE)
qed

lemma ttl_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> tllist_all2 A B) ttl ttl"
  unfolding ttl_def[abs_def] by transfer_prover
declare ttl_transfer [transfer_rule]

lemma tset_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> rel_set A) tset tset"
by (intro rel_funI rel_setI) (auto simp only: in_tset_conv_tnth tllist_all2_conv_all_tnth Bex_def)

lemma tmap_transfer2 [transfer_rule]:
  "((A ===> B) ===> (C ===> D) ===> tllist_all2 A C ===> tllist_all2 B D) tmap tmap"
by(auto simp add: rel_fun_def tllist_all2_tmap1 tllist_all2_tmap2 elim: tllist_all2_mono)
declare tmap_transfer [transfer_rule]

lemma is_TNil_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> (=)) is_TNil is_TNil"
by(auto dest: tllist_all2_is_TNilD)
declare is_TNil_transfer [transfer_rule]

lemma tappend_transfer [transfer_rule]:
  "(tllist_all2 A B ===> (B ===> tllist_all2 A C) ===> tllist_all2 A C) tappend tappend"
by(auto intro: tllist_all2_tappendI elim: rel_funE)
declare tappend.transfer [transfer_rule]

lemma lappendt_transfer [transfer_rule]:
  "(llist_all2 A ===> tllist_all2 A B ===> tllist_all2 A B) lappendt lappendt"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_lappendI)
declare lappendt.transfer [transfer_rule]

lemma llist_of_tllist_transfer2 [transfer_rule]:
  "(tllist_all2 A B ===> llist_all2 A) llist_of_tllist llist_of_tllist"
by(auto intro: llist_all2_tllist_of_llistI)
declare llist_of_tllist_transfer [transfer_rule]

lemma tllist_of_llist_transfer2 [transfer_rule]:
  "(B ===> llist_all2 A ===> tllist_all2 A B) tllist_of_llist tllist_of_llist"
by(auto intro!: rel_funI)
declare tllist_of_llist_transfer [transfer_rule]

lemma tlength_transfer [transfer_rule]:
  "(tllist_all2 A B ===> (=)) tlength tlength"
by(auto dest: tllist_all2_tlengthD)
declare tlength.transfer [transfer_rule]

lemma tdropn_transfer [transfer_rule]:
  "((=) ===> tllist_all2 A B ===> tllist_all2 A B) tdropn tdropn"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_ldropnI)
declare tdropn.transfer [transfer_rule]

lemma tfilter_transfer [transfer_rule]:
  "(B ===> (A ===> (=)) ===> tllist_all2 A B ===> tllist_all2 A B) tfilter tfilter"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_lfilterI dest: llist_all2_lfiniteD)
declare tfilter.transfer [transfer_rule]

lemma tconcat_transfer [transfer_rule]:
  "(B ===> tllist_all2 (llist_all2 A) B ===> tllist_all2 A B) tconcat tconcat"
unfolding rel_fun_def
by transfer(auto intro: llist_all2_lconcatI dest: llist_all2_lfiniteD)
declare tconcat.transfer [transfer_rule]

lemma tllist_all2_rsp:
  assumes R1: "\<forall>x y. R1 x y \<longrightarrow> (\<forall>a b. R1 a b \<longrightarrow> S x a = T y b)"
  and R2: "\<forall>x y. R2 x y \<longrightarrow> (\<forall>a b. R2 a b \<longrightarrow> S' x a = T' y b)"
  and xsys: "tllist_all2 R1 R2 xs ys"
  and xs'ys': "tllist_all2 R1 R2 xs' ys'"
  shows "tllist_all2 S S' xs xs' = tllist_all2 T T' ys ys'"
proof
  assume "tllist_all2 S S' xs xs'"
  with xsys xs'ys' show "tllist_all2 T T' ys ys'"
  proof(coinduction arbitrary: ys ys' xs xs')
    case (tllist_all2 ys ys' xs xs')
    thus ?case
      by cases (auto 4 4 simp add: tllist_all2_TCons1 tllist_all2_TCons2 tllist_all2_TNil1 tllist_all2_TNil2 dest: R1[rule_format] R2[rule_format])
  qed
next
  assume "tllist_all2 T T' ys ys'"
  with xsys xs'ys' show "tllist_all2 S S' xs xs'"
  proof(coinduction arbitrary: xs xs' ys ys')
    case (tllist_all2 xs xs' ys ys')
    thus ?case
      by cases(auto 4 4 simp add: tllist_all2_TCons1 tllist_all2_TCons2 tllist_all2_TNil1 tllist_all2_TNil2 dest: R1[rule_format] R2[rule_format])
  qed
qed

lemma tllist_all2_transfer2 [transfer_rule]:
  "((R1 ===> R1 ===> (=)) ===> (R2 ===> R2 ===> (=)) ===>
    tllist_all2 R1 R2 ===> tllist_all2 R1 R2 ===> (=)) tllist_all2 tllist_all2"
by (simp add: tllist_all2_rsp rel_fun_def)
declare tllist_all2_transfer [transfer_rule]

end

text \<open>
  Delete lifting rules for @{typ "('a, 'b) tllist"}
  because the parametricity rules take precedence over
  most of the transfer rules. They can be restored by
  including the bundle \<open>tllist.lifting\<close>.
\<close>

lifting_update tllist.lifting
lifting_forget tllist.lifting

end


theory ProofN
imports Main
        "../Naturals"
begin

(* TEST: hipster leq lez *)
(* TEST: hipster_cond lezp leq *)

(* TEST: hipster leq lezpp eqN *)
lemma eqSym [thy_expl]: "eqN x y = eqN y x" (* requires schemes AND also to take care of arbitrary inductibles *)
by hipster_induct_schemes (*
apply(induction x rule: eqN.induct)
apply(simp_all)
done*)

lemma lemma_ae_own : "lezp x3 \<Longrightarrow> leq x3 y" by hipster_induct_simp_metis (*
apply(induction x3) (* case_tac x3 *)
apply(simp_all)
done*)

(* hipster add mul *)
(* TEST: hipster leq geq  -- works perfectly
lemma lemma_a [thy_expl]: "leq x2 x2 = True" by hipster_induct_simp_metis
lemma lemma_aa [thy_expl]: "geq x2 x2 = True" by hipster_induct_simp_metis
lemma lemma_ab [thy_expl]: "geq Z x2 = leq x2 Z" by hipster_induct_simp_metis
lemma lemma_ac [thy_expl]: "leq x2 (S x2) = True" by hipster_induct_simp_metis
lemma lemma_ad [thy_expl]: "geq x2 (S x2) = False" by hipster_induct_simp_metis
lemma lemma_ae [thy_expl]: "leq (S x2) x2 = False" by hipster_induct_simp_metis
lemma lemma_af [thy_expl]: "geq (S x2) x2 = True" by hipster_induct_simp_metis
lemma lemma_ag [thy_expl]: "leq (S Z) x2 = geq x2 (S Z)" by hipster_induct_simp_metis
lemma lemma_ah [thy_expl]: "geq (S Z) x2 = leq x2 (S Z)" by hipster_induct_simp_metis *)

lemma geq2leq [thy_expl]: "geq x y = leq y x"  (* requires arbitrary care + schemes *)
apply(induction x y rule: geq.induct)
apply(simp_all add: thy_expl)
done

(* Removed for symmetry reasons
lemma unknownLG [thy_expl]: "leq (S x) y = geq y (S x)"
by (hipster_induct_schemes (*Naturals.leq.simps Naturals.geq.simps*) (*Naturals.lemma_ab*))
(*apply(induction y rule: leq.induct)
apply(simp_all add: lemma_ab)
done*)
*)
lemma unknownLG' [thy_expl]: "geq (S x) y = leq y (S x)"
by (hipster_induct_simp_metis (*Naturals.leq.simps Naturals.geq.simps Naturals.lemma_ab*))

lemma unknownLGS [thy_expl]: "geq (S x) (S y) = leq y x"
by hipster_induct_simp_metis

(*hipster add leq*)
(*hipster add geq*)
(*hipster mul leq add*)

(* TEST: hipster_cond lez leq eqN geq *)
lemma lemma_a2 [thy_expl]: "leq x2 x2 = True"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_aa2 [thy_expl]: "eqN x2 x2 = True"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_ab2 [thy_expl]: "geq x2 x2 = True"
apply (induction x2)
apply simp_all
(*by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)*)
oops

hipster leq geq

(* TODO: uncomment, for now comment some of the def-dependent ones*)
lemma lemma_ac2 [thy_expl]: "leq x2 Z = lez x2" (* NB: used to be problematic *)
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_ad2 [thy_expl]: "eqN x2 Z = lez x2"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

(* TODO: uncomment, takes long*)
lemma lemma_ae2 [thy_expl]: "geq Z x2 = lez x2" (* NB: used to be problematic *)
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_af2 [thy_expl]: "leq x2 (S x2) = True"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_ag2 [thy_expl]: "eqN x2 (S x2) = False"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

(* TODO: uncomment, they take long*)
lemma lemma_ah2 [thy_expl]: "geq x2 (S x2) = False" (* NB: used to be problematic *)
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_ai [thy_expl]: "leq (S x2) x2 = False" (* NB: used to be problematic *)
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

lemma lemma_aj [thy_expl]: "geq (S x2) x2 = True"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

(* FIXME: another missing precond? nah, just repetition
lemma lemma_ak [thy_expl]: "leq (S Z) x2 = geq x2 (S Z)"
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps) *)

(* TODO: uncomment, takes long *)
lemma lemma_al [thy_expl]: "geq (S Z) x2 = leq x2 (S Z)" (* NB: used to be problematic *)
by (hipster_induct_simp_metis Naturals.lez.simps Naturals.leq.simps Naturals.eqN.simps Naturals.geq.simps)

(* TEST: hipster_cond lezp leq *)
(* TODO: uncomment, takes long ?*)
lemma lemma_az [thy_expl]: "leq x2 Z = lezp x2"
by (hipster_induct_simp_metis Naturals.lezp.simps Naturals.leq.simps)

(* Interesting ones discovered *)
lemma lezpKer [thy_expl]: "lezp y \<and> lezp x \<Longrightarrow> x = y"
by (metis lezp.simps lezp.elims)
(* apply(case_tac y, case_tac x) >> simp_all too *) (* XXX: add elims? case_tac fallback? *)

(*hipster_cond lezpp leq*)
(* TODO: uncomment, takes long*)
lemma lemma_lezpp [thy_expl]: "lezpp x3 \<Longrightarrow> leq x3 (S y3)"
by (hipster_induct_simp_metis Naturals.lezpp.simps Naturals.leq.simps) (* NB: used to be problematic *)

(* comparison : these depend on binary leq as condition \<Longrightarrow> won't get them yet *)
lemma succKeeps : "leq m n \<Longrightarrow> leq (S m) (S n)"
by simp

(* NOTE: added to simpset, easens up next lemma ... Ensure Hipster tactics do this appropriately
    Also: should there be a "post"-first attempt rounds in case later discovered lemmas help with
      priorly non-possible ones? Does it do it already? *)
lemma succIncreasedL: "leq (S n) m \<Longrightarrow> leq n m" (* FIXME: gets stuck in a simp loop... check other lemmas *)
by hipster_induct_schemes (*
apply(induction m rule: leq.induct)
apply(simp_all)
done*)
lemma succIncreasesL : "leq m n \<Longrightarrow> leq m (S n)" by hipster_induct_schemes (*
apply(simp add: succIncreasedL)
done*)

lemma succKeepsG : "geq m n \<Longrightarrow> geq (S m) (S n)" by simp

lemma succIncreasedG: "geq n (S m) \<Longrightarrow> geq n m" (* FIXME: gets stuck in a simp loop... check other lemmas *)
by hipster_induct_schemes (*
apply(induction m rule: leq.induct)
apply(simp_all)
done*)
lemma succIncreasesG : "geq m n \<Longrightarrow> geq (S m) n" by hipster_induct_schemes (*
apply(simp add: succIncreasedG)
done*)

lemma addId: "add m Z = m" (* will go down to structural induction? *)
by hipster_induct_simp_metis (*
apply(induction m)
apply(simp_all)
done*)

lemma addIncreases: "leq n (add n m)" (* now succeeds in both *) (* oops in Hipster? *)
by hipster_induct_simp_metis (*
apply(induction n)
apply(simp_all)
done*)

lemma addIncreasesNon: "leq n (add m n)"
(*slow Hipster... doesn't prove it? *)
(* ah, with necessary one yeap *)
by (hipster_induct_simp_metis succIncreasedL) (* NOTE: will get stuck if duplicate defs are given *)
(* before:  apply(induction m)  apply(simp_all) apply(induction n)  apply(simp_all add: succIncreasedL) *)

lemma subBounded: "sub n (add n m) = Z"
by hipster_induct_simp_metis

lemma noLowerZ: "leq n Z \<Longrightarrow> n = Z" (* will fail with the rule stated *)
(* by (metis Nat.distinct(1) leq.elims(2)) *)
by hipster_induct_simp_metis (* tactic {* Tactic_Data.routine_tac @{context}*}) if lemma_az is in thy_expl*)
(*
apply(induction n)
by(simp_all) *)

(* TODO: don't we retrieve ALL existing lemmas not only thy_expl ones? it won't work without succIncreasesL ... *)
lemma subDecreases: "leq (sub n m) n" (* requires both schemes + arbitrary care *)
by (hipster_induct_schemes succIncreasesL)(*
apply(induction n m rule: sub.induct) (* TODO: add induction on several variables simultaneously: exists? does it depend on params of functions? *)
apply(simp_all add: lemma_a succIncreasesL)
done*)

lemma subHard: "leq n m \<Longrightarrow> leq (sub n m) Z"  (* seems to need the induction on both *) (* requires arbitrary care + schemes *)
by hipster_induct_schemes (*
apply(induction n m rule: leq.induct)
by (simp_all)*)

lemma subCon: "\<not> leq n m \<Longrightarrow> \<not> leq (sub n m) Z"  (* seems to need the induction on both *)  (* requires arbitrary care + schemes *)
by hipster_induct_schemes
(*apply(induction n m rule: leq.induct)
by (simp_all)*)
(* won't work: by (hipster_induct_simp_metis Naturals.sub.simps Naturals.leq.simps)*)

lemma addS2: "add n (S m) = S (add n m)"
by hipster_induct_simp_metis

lemma notLessSwap: "\<not> leq n m \<Longrightarrow> leq m n"  (* requires arbitrary care + schemes *)
by hipster_induct_schemes (*
apply(induction m rule: leq.induct)
by (simp_all)*)

lemma subId: "sub n Z = n"
(* apply(hipster_induct_schemes add.simps) *)
by hipster_induct_simp_metis

end