section "Debruijn Indicies Formulation"
theory Debruijn
  imports PolyAtoms
begin
subsection "Lift and Lower Functions"

text "these functions are required for debruijn notation
  the (liftPoly n a p) functions increment each variable greater n in polynomial p by a
  the (lowerPoly n a p) functions lower each variable greater than n by a so variables n through n+a-1 shouldn't exist
"
context includes poly_mapping.lifting begin

definition "inc_above b i x = (if x < b then x else x + i::nat)"
definition "dec_above b i x = (if x \<le> b then x else x - i::nat)"

lemma inc_above_dec_above: "x < b \<or> b + i \<le> x \<Longrightarrow> inc_above b i (dec_above b i x) = x"
  by (auto simp: inc_above_def dec_above_def)
lemma dec_above_inc_above: "dec_above b i (inc_above b i x) = x"
  by (auto simp: inc_above_def dec_above_def)

lemma inc_above_dec_above_iff: "inc_above b i (dec_above b i x) = x \<longleftrightarrow> x < b \<or> b + i \<le> x"
  by (auto simp: inc_above_def dec_above_def)

lemma inj_on_dec_above: "inj_on (dec_above b i) {x. x < b \<or> b + i \<le> x}"
  by (rule inj_on_inverseI[where g = "inc_above b i"]) (auto simp: inc_above_dec_above)

lemma finite_inc_above_ne: "finite {x. f x \<noteq> c} \<Longrightarrow> finite {x. f (inc_above b i x) \<noteq> c}"
proof -
  fix b and f::"nat\<Rightarrow>'a"
  assume f: "finite {x. f x \<noteq> c}"
  moreover
  have "finite {x. f (x + i) \<noteq> c}"
  proof -
    have "{x. f (x + i) \<noteq> c} = (+) i -` {x. f x \<noteq> c}"
      by (auto simp: ac_simps)
    also have "finite \<dots>"
      by (rule finite_vimageI) (use f in auto)
    finally show ?thesis .
  qed
  ultimately have "finite ({x. f x \<noteq> c} \<union> {x. f (x + i) \<noteq> c})"
    by auto
  from _ this show "finite {x. f (inc_above b i x) \<noteq> c}"
    by (rule finite_subset) (auto simp: inc_above_def)
qed

lemma finite_dec_above_ne: "finite {x. f x \<noteq> c} \<Longrightarrow> finite {x. f (dec_above b i x) \<noteq> c}"
proof -
  fix b and f::"nat\<Rightarrow>'a"
  assume f: "finite {x. f x \<noteq> c}"
  moreover
  have "finite {x. f (x - i) \<noteq> c}"
  proof -
    have "{x. f (x - i) \<noteq> c} \<subseteq> {0..i} \<union> ((\<lambda>x. x - i) -` {x. f x \<noteq> c} \<inter> {i<..})"
      by auto
    also have "finite \<dots>"
      apply (rule finite_UnI[OF finite_atLeastAtMost])
      by (rule finite_vimage_IntI) (use f in \<open>auto simp: inj_on_def\<close>)
    finally (finite_subset) show ?thesis .
  qed
  ultimately have "finite ({x. f x \<noteq> c} \<union> {x. f (x - i) \<noteq> c} \<union> {b})"
    by auto
  from _ this show "finite {x. f (dec_above b i x) \<noteq> c}"
    by (rule finite_subset) (auto simp: dec_above_def)
qed

lift_definition lowerPowers::"nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a::zero)"
  is "\<lambda>b i p x. if x \<in> {b..<b+i} then 0 else p (dec_above b i x)::'a"
proof -
  fix b i::nat and p::"nat \<Rightarrow> 'a"
  assume "finite {x. p x \<noteq> 0}"
  then have "finite {x. p (dec_above b i x) \<noteq> 0}"
    by (rule finite_dec_above_ne)
  from _ this show "finite {x. (if x \<in> {b..<b+i} then 0 else p (dec_above b i x)) \<noteq> 0}"
    by (rule finite_subset) auto
qed

lift_definition higherPowers::"nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a::zero)"
  is "\<lambda>b i p x. p (inc_above b i x)::'a"
  by (simp_all add: finite_inc_above_ne)

lemma higherPowers_lowerPowers: "higherPowers n i (lowerPowers n i x) = x"
  by transfer (force simp: dec_above_def inc_above_def antisym_conv2)

lemma inj_lowerPowers: "inj (lowerPowers b i)"
  using higherPowers_lowerPowers
  by (rule inj_on_inverseI)

lemma lowerPowers_higherPowers:
  "(\<And>j. n \<le> j \<Longrightarrow> j < n + i \<Longrightarrow> lookup x j = 0) \<Longrightarrow> lowerPowers n i (higherPowers n i x) = x"
  by (transfer fixing: n i) (force simp: inc_above_dec_above)

lemma inj_on_higherPowers: "inj_on (higherPowers n i) {x. \<forall>j. n \<le> j \<and> j < n + i \<longrightarrow> lookup x j = 0}"
  using lowerPowers_higherPowers
  by (rule inj_on_inverseI) auto

lemma higherPowers_eq: "lookup (higherPowers b i p) x = lookup p (inc_above b i x)"
  by (simp_all add: higherPowers.rep_eq)

lemma lowerPowers_eq: "lookup (lowerPowers b i p) x = (if b \<le> x \<and> x < b + i then 0 else lookup p (dec_above b i x))"
  by (auto simp add: lowerPowers.rep_eq)

lemma keys_higherPowers: "keys (higherPowers b i m) = dec_above b i ` (keys m \<inter> {x. x \<notin> {b..<b+i}})"
  apply safe
  subgoal for x
    apply (rule image_eqI[where x="inc_above b i x"])
     apply (auto simp: dec_above_inc_above in_keys_iff higherPowers.rep_eq)
    by (metis add_less_cancel_right inc_above_def leD)
  subgoal for x
    by (auto simp: inc_above_dec_above in_keys_iff higherPowers.rep_eq)
  done

context includes fmap.lifting begin

lift_definition lowerPowers\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> (nat, 'a) fmap \<Rightarrow> (nat, 'a::zero) fmap"
  is "\<lambda>b i p x. if x \<in> {b..<b+i} then None else p (dec_above b i x)"
proof -
  fix b i::nat and p::"nat \<Rightarrow> 'a option"
  assume "finite (dom p)"
  then have "finite {x. p x \<noteq> None}" by (simp add: dom_def)

  have "dom (\<lambda>x. p (dec_above b i x)) = {x. p (dec_above b i x) \<noteq> None}"
    by auto
  also have "finite \<dots>"
    by (rule finite_dec_above_ne) fact
  finally
  have "finite (dom (\<lambda>x. p (dec_above b i x)))" .
  from _ this
  show "finite (dom (\<lambda>x. if x \<in> {b..<b+i} then None else p (dec_above b i x)))"
    by (rule finite_subset) (auto split: if_splits)
qed

lift_definition higherPowers\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> (nat, 'a) fmap \<Rightarrow> (nat, 'a) fmap"
  is "\<lambda>b i f x. f (inc_above b i x)"
proof -
  fix b i::nat and f::"nat \<Rightarrow> 'a option"
  assume "finite (dom f)"
  then have "finite {i. f i \<noteq> None}" by (simp add: dom_def)

  have "dom (\<lambda>x. f (inc_above b i x)) = {x. f (inc_above b i x) \<noteq> None}"
    by auto
  also have "finite \<dots>"
    by (rule finite_inc_above_ne) fact
  finally show "finite (dom (\<lambda>x. f (inc_above b i x)))"
    .
qed

lemma map_of_map_key_inverse_fun_eq:
  "map_of (map (\<lambda>(k, y). (f k, y)) xs) x = map_of xs (g x)"
  if "\<And>x. x \<in> set xs \<Longrightarrow> g (f (fst x)) = fst x" "f (g x) = x"
  for f::"'a \<Rightarrow> 'b"
  using that
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  from Cons
  have IH: "map_of (map (\<lambda>a. (f (fst a), snd a)) xs) x = map_of xs (g x)"
    by (auto simp: split_beta')
  have inv_into: "g (f (fst a)) = fst a"
    by (rule Cons) simp
  show ?case
    using Cons
    by (auto simp add: split_beta' inv_into IH)
qed

lemma map_of_filter_key_in: "P x \<Longrightarrow> map_of (filter (\<lambda>(k, v). P k) xs) x = map_of xs x"
  by (induction xs) auto

lemma map_of_eq_NoneI: "x\<notin>fst`set xs \<Longrightarrow> map_of xs x = None"
  by (induction xs) auto

lemma compute_higherPowers\<^sub>f[code]: "higherPowers\<^sub>f b i (fmap_of_list xs) =
  fmap_of_list (map (\<lambda>(k, v). (if k < b then k else k - i, v)) (filter (\<lambda>(k, v). k \<notin> {b..<b+i}) xs))"
proof -
  have *: "map_of (map (\<lambda>(k, y). (if k < b then k else k - i, y)) (filter (\<lambda>(k, v).  b \<le> k \<longrightarrow> \<not> k < b + i) xs)) x =
    map_of (filter (\<lambda>(k, v).  b \<le> k \<longrightarrow> \<not> k < b + i) xs) (if x < b then x else x + i)"
    for x
    by (rule map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k + i"
          and f = "\<lambda>k. if k < b then k else k - i"]) auto
  show ?thesis
    by (auto
        simp add: * higherPowers\<^sub>f.rep_eq lowerPowers\<^sub>f.rep_eq fmlookup_of_list fmlookup_default_def
        inc_above_def
        map_of_filter_key_in
        split: option.splits
        intro!: fmap_ext)
qed

lemma compute_lowerPowers\<^sub>f[code]: "lowerPowers\<^sub>f b i (fmap_of_list xs) =
  fmap_of_list (map (\<lambda>(k, v). (if k < b then k else k + i, v)) xs)"
  apply (auto
      simp add: lowerPowers\<^sub>f.rep_eq fmlookup_of_list fmlookup_default_def
      dec_above_def
      map_of_filter_key_in
      split: option.splits
      intro!: fmap_ext)
  subgoal by (rule map_of_eq_NoneI[symmetric]) (auto split: if_splits)
  subgoal by (subst map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k - i"]) auto
  subgoal by (subst map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k - i"]) auto
  subgoal by (rule map_of_eq_NoneI[symmetric]) (auto split: if_splits)
  subgoal by (subst map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k - i"]) auto
  done

lemma compute_higherPowers[code]: "higherPowers n i (Pm_fmap xs) = Pm_fmap (higherPowers\<^sub>f n i xs)"
  by (rule poly_mapping_eqI)
    (auto simp: higherPowers\<^sub>f.rep_eq higherPowers.rep_eq fmlookup_default_def dec_above_def
      split: option.splits)

lemma compute_lowerPowers[code]: "lowerPowers n i (Pm_fmap xs) = Pm_fmap (lowerPowers\<^sub>f n i xs)"
  by (rule poly_mapping_eqI)
    (auto simp: lowerPowers\<^sub>f.rep_eq lowerPowers.rep_eq fmlookup_default_def dec_above_def
      split: option.splits)

lemma finite_nonzero_coeff: "finite {x. MPoly_Type.coeff mpoly x \<noteq> 0}"
  by transfer auto

lift_definition lowerPoly\<^sub>0::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0'a::zero) \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0 'a)" is
  "\<lambda>b i (mp::(nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>'a) mon. mp (lowerPowers b i mon)"
proof -
  fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a"
  assume "finite {x. mp x \<noteq> 0}"
  have "{x. mp (lowerPowers b i x) \<noteq> 0} = (lowerPowers b i -` {x. mp x \<noteq> 0})"
    (is "?set = ?vimage")
    by auto
  also
  from finite_vimageI[OF \<open>finite _\<close> inj_lowerPowers]
  have "finite ?vimage" .
  finally show "finite ?set" .
qed

lemma higherPowers_zero[simp]: "higherPowers b i 0 = 0"
  by transfer auto

lemma keys_lowerPoly\<^sub>0: "keys (lowerPoly\<^sub>0 b i mp) = higherPowers b i ` (keys mp \<inter> {x. \<forall>j\<in>{b..<b+i}. lookup x j = 0})"
  apply (auto )
  subgoal for x
    apply (rule image_eqI[where x="lowerPowers b i x"])
     apply (auto simp: higherPowers_lowerPowers in_keys_iff lowerPoly\<^sub>0.rep_eq lowerPowers.rep_eq)
    done
  subgoal for x
    apply (auto simp: in_keys_iff lowerPoly\<^sub>0.rep_eq)
    apply (subst (asm) lowerPowers_higherPowers)
     apply auto
    done
  done

lift_definition higherPoly\<^sub>0::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0'a::zero) \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0 'a)" is
  "\<lambda>b i (mp::(nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>'a) mon.
    if (\<exists>j\<in>{b..<b+i}. lookup mon j > 0)
    then 0
    else mp (higherPowers b i mon)"
proof -
  fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a"
  assume "finite {x. mp x \<noteq> 0}"
  have "{x. (if \<exists>j\<in>{b..<b + i}. 0 < lookup x j then 0 else mp (higherPowers b i x)) \<noteq> 0} \<subseteq>
    insert 0 (higherPowers b i -` {x. mp x \<noteq> 0} \<inter> {x. \<forall>j\<in>{b..<b+i}. lookup x j = 0})"
    (is "?set \<subseteq> ?vimage")
    by auto
  also
  from finite_vimage_IntI[OF \<open>finite _\<close> inj_on_higherPowers, of b i]
  have "finite ?vimage" by (auto simp: Ball_def)
  finally (finite_subset) show "finite ?set" .
qed

context includes fmap.lifting begin

lift_definition lowerPoly\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a::zero)fmap \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a)fmap" is
  "\<lambda>b i (mp::((nat\<Rightarrow>\<^sub>0nat)\<rightharpoonup>'a)) mon::(nat\<Rightarrow>\<^sub>0nat). mp (lowerPowers b i mon)"
proof -\<comment> \<open>TODO: this is exactly the same proof as the one for \<open>lowerPoly\<^sub>0\<close>\<close>
  fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a option"
  assume "finite (dom mp)"
  also have "dom mp = {x. mp x \<noteq> None}" by auto
  finally have "finite {x. mp x \<noteq> None}" .
  have "(dom (\<lambda>mon. mp (lowerPowers b i mon))) = {mon. mp (lowerPowers b i mon) \<noteq> None}"
    (is "?set = _")
    by (auto split: if_splits)
  also have "\<dots> = lowerPowers b i -` {x. mp x \<noteq> None}" (is "_ = ?vimage")
    by auto
  also
  from finite_vimageI[OF \<open>finite {x. mp x \<noteq> None}\<close> inj_lowerPowers]
  have "finite ?vimage" .
  finally show "finite ?set" .
qed

lift_definition higherPoly\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a::zero)fmap \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a)fmap" is
  "\<lambda>b i (mp::((nat\<Rightarrow>\<^sub>0nat)\<rightharpoonup>'a)) mon::(nat\<Rightarrow>\<^sub>0nat).
    if (\<exists>j\<in>{b..<b+i}. lookup mon j > 0)
    then None
    else mp (higherPowers b i mon)"
proof -
  fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<rightharpoonup> 'a"
  assume "finite (dom mp)"
  have "dom (\<lambda>x. (if \<exists>j\<in>{b..<b + i}. 0 < lookup x j then None else mp (higherPowers b i x))) \<subseteq>
    insert 0 (higherPowers b i -` (dom mp) \<inter> {x. \<forall>j\<in>{b..<b+i}. lookup x j = 0})"
    (is "?set \<subseteq> ?vimage")
    by (auto split: if_splits)
  also
  from finite_vimage_IntI[OF \<open>finite _\<close> inj_on_higherPowers, of b i]
  have "finite ?vimage" by (auto simp: Ball_def)
  finally (finite_subset) show "finite ?set" .
qed

lemma keys_lowerPowers: "keys (lowerPowers b i m) = inc_above b i ` (keys m)"
  apply safe
  subgoal for x
    apply (rule image_eqI[where x="dec_above b i x"])
     apply (auto simp: inc_above_dec_above in_keys_iff lowerPowers.rep_eq)
     apply (metis inc_above_dec_above not_less)
    by meson
  by (metis higherPowers.rep_eq higherPowers_lowerPowers in_keys_iff)

lemma keys_higherPoly\<^sub>0: "keys (higherPoly\<^sub>0 b i mp) = lowerPowers b i ` (keys mp)"
  apply (auto )
  subgoal for x
    apply (rule image_eqI[where x="higherPowers b i x"])
     apply (auto simp: lowerPowers_higherPowers in_keys_iff higherPoly\<^sub>0.rep_eq higherPowers.rep_eq)
     apply (metis atLeastLessThan_iff lowerPowers_higherPowers neq0_conv)
    by meson
  subgoal for x
    apply (auto simp: in_keys_iff higherPoly\<^sub>0.rep_eq)
     apply (simp add: lowerPowers_eq)
    by (simp add: higherPowers_lowerPowers)
  done

end

lemma inc_above_id[simp]: "n < m \<Longrightarrow> inc_above m i n = n" by (auto simp: inc_above_def)
lemma inc_above_Suc[simp]: "n \<ge> m \<Longrightarrow> inc_above m i n = n + i" by (auto simp: inc_above_def)

lemma compute_lowerPoly\<^sub>0[code]: "lowerPoly\<^sub>0 n i (Pm_fmap m) = Pm_fmap (lowerPoly\<^sub>f n i m)"
  by (auto simp: lowerPoly\<^sub>0.rep_eq fmlookup_default_def lowerPoly\<^sub>f.rep_eq
      split: option.splits
      intro!: poly_mapping_eqI)

lemma compute_higherPoly\<^sub>0[code]: "higherPoly\<^sub>0 n i (Pm_fmap m) = Pm_fmap (higherPoly\<^sub>f n i m)"
  by (auto simp: higherPoly\<^sub>0.rep_eq fmlookup_default_def higherPoly\<^sub>f.rep_eq
      split: option.splits
      intro!: poly_mapping_eqI)

lemma compute_lowerPoly\<^sub>f[code]: "lowerPoly\<^sub>f n i (fmap_of_list xs) =
  (fmap_of_list (map (\<lambda>(mon, c). (higherPowers n i mon, c))
    (filter (\<lambda>(mon, v). \<forall>j\<in>{n..<n+i}. lookup mon j = 0) xs)))"
  apply (rule sym)
  apply (rule fmap_ext)
  unfolding lowerPoly\<^sub>f.rep_eq fmlookup_of_list
  apply (subst map_of_map_key_inverse_fun_eq[where g="lowerPowers n i"])
  subgoal
    by (auto simp add: lowerPowers_higherPowers)
  subgoal by (auto simp add: higherPowers_lowerPowers)
  apply (auto simp: fmlookup_of_list lowerPoly\<^sub>f.rep_eq map_of_eq_None_iff map_of_filter_key_in
      fmdom'_fmap_of_list higherPowers.rep_eq lowerPowers.rep_eq dec_above_def
      intro!: fmap_ext)
  done

lemma compute_higherPoly\<^sub>f[code]: "higherPoly\<^sub>f n i (fmap_of_list xs) =
  fmap_of_list (filter (\<lambda>(mon, v). \<forall>j\<in>{n..<n+i}. lookup mon j = 0)
    (map (\<lambda>(mon, c). (lowerPowers n i mon, c)) xs))"
  apply (rule sym)
  apply (rule fmap_ext)
  unfolding higherPoly\<^sub>f.rep_eq fmlookup_of_list
  apply auto
  subgoal
    by (rule map_of_eq_NoneI) auto
  subgoal
    apply (subst map_of_filter_key_in)
    apply auto
    apply (subst map_of_map_key_inverse_fun_eq[where g="higherPowers n i"])
    subgoal
      by (auto simp add: higherPowers_lowerPowers)
    subgoal by (auto simp add: lowerPowers_higherPowers)
    apply (auto simp: fmlookup_of_list lowerPoly\<^sub>f.rep_eq map_of_eq_None_iff map_of_filter_key_in
        fmdom'_fmap_of_list higherPowers.rep_eq lowerPowers.rep_eq dec_above_def
        intro!: fmap_ext)
    done
  done

end

lift_definition lowerPoly::"nat \<Rightarrow> nat \<Rightarrow> 'a::zero mpoly \<Rightarrow> 'a mpoly" is lowerPoly\<^sub>0 .
lift_definition liftPoly::"nat \<Rightarrow> nat \<Rightarrow> 'a::zero mpoly \<Rightarrow> 'a mpoly" is higherPoly\<^sub>0 .

lemma coeff_lowerPoly: "MPoly_Type.coeff (lowerPoly b i mp) x = MPoly_Type.coeff mp (lowerPowers b i x)"
  by (transfer') (simp add: lowerPoly\<^sub>0.rep_eq lowerPowers.rep_eq)

lemma coeff_liftPoly: "MPoly_Type.coeff (liftPoly b i mp) x = (if (\<exists>j\<in>{b..<b+i}. lookup x j > 0)
    then 0
    else MPoly_Type.coeff mp (higherPowers b i x))"
  by (transfer') (simp add: higherPowers.rep_eq higherPoly\<^sub>0.rep_eq )

lemma monomials_lowerPoly: "monomials (lowerPoly b i mp) = higherPowers b i ` (monomials mp \<inter> {x. \<forall>j\<in>{b..<b + i}. lookup x j = 0}) "
  by transfer' (simp add: keys_lowerPoly\<^sub>0)

lemma monomials_liftPoly: "monomials (liftPoly b i mp) = lowerPowers b i ` (monomials mp) "
  using keys_higherPoly\<^sub>0
  by (simp add: keys_higherPoly\<^sub>0 liftPoly.rep_eq monomials.rep_eq)

value [code] "lowerPoly 1 1 (1 * Var 0 + 2 * Var 2 ^ 2 + 3 * Var 3 ^ 4::int mpoly) = (Var 0 + 2 * Var 1^2 + 3 * Var 2^4::int mpoly)"
value [code] "lowerPoly 1 3 (1 * Var 0 + 2 * Var 4 ^ 2 + 3 * Var 5 ^ 4::int mpoly) = (Var 0 + 2 * Var 1^2 + 3 * Var 2^4::int mpoly)"

value [code] "liftPoly 1 3 (1 * Var 0 + 2 * Var 4 ^ 2 + 3 * Var 5 ^ 4::int mpoly) = (Var 0 + 2 * Var 7^2 + 3 * Var 8^4::int mpoly)"

fun lowerAtom :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom" where
  "lowerAtom d amount (Eq p) = Eq(lowerPoly d amount p)"|
  "lowerAtom d amount (Less p) = Less(lowerPoly d amount p)"|
  "lowerAtom d amount (Leq p) = Leq(lowerPoly d amount p)"|
  "lowerAtom d amount (Neq p) = Neq(lowerPoly d amount p)"

lemma lookup_not_in_vars_eq_zero: "x \<in> monomials p \<Longrightarrow> i \<notin> vars p \<Longrightarrow> lookup x i = 0"
  by (meson degree_eq_iff varNotIn_degree)

lemma nth_dec_above:
  assumes "length xs = i" "length ys = j" "k \<notin> {i..<i+j}"
  shows "nth_default 0 (xs @ zs) (dec_above i j k) = (nth_default 0 (xs @ ys @ zs)) k"
  using assms dec_above_def nth_append add.commute
  by (smt add_diff_cancel_left add_le_cancel_left add_strict_increasing append_Nil2 atLeastLessThan_iff le_add_diff_inverse length_append length_greater_0_conv less_imp_le_nat not_less nth_default_append)

lemma insertion_lowerPoly:
  assumes i_notin: "vars p \<inter> {i..<i+j} = {}"
    and lprfx: "length prfx = i"
    and lxs: "length xs = j"
  shows "insertion (nth_default 0 (prfx@L)) (lowerPoly i j p) = insertion (nth_default 0 (prfx@xs@L)) p" (is "?lhs = ?rhs")
proof -
  have *: "monomials p \<inter> {x. \<forall>j\<in>{i..<i + j}. lookup x j = 0} = monomials p"
    using assms(1) by (auto intro: lookup_not_in_vars_eq_zero)
  then have "monomials p \<subseteq> {x. \<forall>k. i \<le> k \<and> k < i + j \<longrightarrow> lookup x k = 0}"
    by force
  have "?lhs = (\<Sum>m\<in>monomials (lowerPoly i j p). MPoly_Type.coeff (lowerPoly i j p) m * (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ L)) k ^ lookup m k))"
    unfolding insertion_code ..
  also have "\<dots> = (\<Sum>m\<in>monomials p.
       MPoly_Type.coeff p m * (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ xs @ L) k) ^ lookup m k))"
  proof (rule sum.reindex_cong)
    note inj_on_higherPowers[of i j]
    moreover note \<open>monomials p \<subseteq> _\<close>
    ultimately show "inj_on (higherPowers i j) (monomials p)"
      by (rule inj_on_subset)
  next
    show "monomials (lowerPoly i j p) = higherPowers i j ` monomials p"
      unfolding monomials_lowerPoly * ..
  next
    fix m
    assume m: "m \<in> monomials p"
    from m \<open>monomials p \<subseteq> _\<close> have "keys m \<subseteq> {x. x \<notin> {i..<i + j}}"
      by auto
    then have "lookup m k = 0" if "i \<le> k" "k < i + j" for k
      using that by (auto simp: in_keys_iff)
    then have "lowerPowers i j (higherPowers i j m) = m"
      by (rule lowerPowers_higherPowers)
    then have "MPoly_Type.coeff (lowerPoly i j p) (higherPowers i j m) = MPoly_Type.coeff p m"
      unfolding coeff_lowerPoly by simp
    moreover
    have "(\<Prod>k\<in>keys (higherPowers i j m). (nth_default 0 (prfx @ L)) k ^ lookup (higherPowers i j m) k) =
      (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ xs @ L)) k ^ lookup m k)"
    proof (rule prod.reindex_cong)
      show "keys (higherPowers i j m) = dec_above i j ` keys m"
        unfolding keys_higherPowers using \<open>keys m \<subseteq> _\<close> by auto
    next
      from inj_on_dec_above[of i j]
      show "inj_on (dec_above i j) (keys m)"
        by (rule inj_on_subset) (use \<open>keys m \<subseteq> _\<close> in auto)
    next
      fix k assume k: "k \<in> keys m"
      from k \<open>keys m \<subseteq> _\<close> have "k \<notin> {i..<i+j}" by auto
      from k \<open>keys m \<subseteq> _\<close>
      have "inc_above i j (dec_above i j k) = k"
        by (subst inc_above_dec_above) auto
      then have "lookup (higherPowers i j m) (dec_above i j k) = lookup m k"
        unfolding higherPowers.rep_eq by simp
      moreover have "nth_default 0 (prfx @ L) (dec_above i j k) = (nth_default 0 (prfx @ xs @ L)) k"
        apply (rule nth_dec_above)
        using assms \<open>k \<notin> _\<close>
        by auto
      ultimately
      show "((nth_default 0 (prfx @ L)) (dec_above i j k)) ^ lookup (higherPowers i j m) (dec_above i j k) = ((nth_default 0 (prfx @ xs @ L)) k) ^ lookup m k"
        by simp
    qed
    ultimately
    show "MPoly_Type.coeff (lowerPoly i j p) (higherPowers i j m) * (\<Prod>k\<in>keys (higherPowers i j m). (nth_default 0(prfx @ L)) k ^ lookup (higherPowers i j m) k) =
          MPoly_Type.coeff p m * (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ xs @ L)) k ^ lookup m k)"
      by simp
  qed
  finally show ?thesis
    unfolding insertion_code .
qed

lemma insertion_lowerPoly1:
  assumes i_notin: "i \<notin> vars p"
    and lprfx: "length prfx = i"
  shows "insertion (nth_default 0 (prfx@x#L)) p = insertion (nth_default 0 (prfx@L)) (lowerPoly i 1 p)"
  using assms nth_default_def apply simp
  by (subst insertion_lowerPoly[where xs="[x]"]) auto

lemma insertion_lowerPoly01:
  assumes i_notin: "0 \<notin> vars p"
  shows "insertion (nth_default 0 (x#L)) p = insertion (nth_default 0 L) (lowerPoly 0 1 p)"
  using insertion_lowerPoly1[OF assms, of Nil x L]
  by simp

lemma aEval_lowerAtom : "(freeIn 0 (Atom A)) \<Longrightarrow> (aEval A (x#L) = aEval (lowerAtom 0 1 A) L)"
  by (cases A) (simp_all add:insertion_lowerPoly01)

fun map_fm_binders :: "(atom \<Rightarrow> nat \<Rightarrow> atom) \<Rightarrow> atom fm \<Rightarrow> nat \<Rightarrow> atom fm" where
  "map_fm_binders f TrueF n = TrueF"|
  "map_fm_binders f FalseF n = FalseF"|
  "map_fm_binders f (Atom \<phi>) n = Atom (f \<phi> n)"|
  "map_fm_binders f (And \<phi> \<psi>) n = And (map_fm_binders f \<phi> n) (map_fm_binders f \<psi> n)"|
  "map_fm_binders f (Or \<phi> \<psi>) n = Or (map_fm_binders f \<phi> n) (map_fm_binders f \<psi> n)"|
  "map_fm_binders f (ExQ \<phi>) n = ExQ(map_fm_binders f \<phi> (n+1))"|
  "map_fm_binders f (AllQ \<phi>) n = AllQ(map_fm_binders f \<phi> (n+1))"|
  "map_fm_binders f (AllN i \<phi>) n = AllN i (map_fm_binders f \<phi> (n+i))"|
  "map_fm_binders f (ExN i \<phi>) n = ExN i (map_fm_binders f \<phi> (n+i))"|
  "map_fm_binders f (Neg \<phi>) n = Neg(map_fm_binders f \<phi> n)"

fun lowerFm :: "nat \<Rightarrow> nat \<Rightarrow> atom fm \<Rightarrow> atom fm" where
  "lowerFm d amount f = map_fm_binders (\<lambda>a. \<lambda>x. lowerAtom (d+x) amount a) f 0"

fun delete_nth :: "nat \<Rightarrow> real list \<Rightarrow> real list" where
  "delete_nth n xs = take n xs @ drop n xs"

lemma eval_lowerFm_helper :
  assumes "freeIn i F"
  assumes "length init = i"
  shows "eval (lowerFm i 1 F) (init @xs) = eval F (init@[x]@xs)"
  using assms
proof(induction F arbitrary : i init)
  case TrueF
  then show ?case by simp
next
  case FalseF
  then show ?case by simp
next
  case (Atom A)
  then show ?case apply(cases A) by (simp_all add: insertion_lowerPoly1)
next
  case (And F1 F2)
  then show ?case by auto
next
  case (Or F1 F2)
  then show ?case by auto
next
  case (Neg F)
  then show ?case by simp
next
  case (ExQ F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + 1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + 1 + x) 1 a) F y)"
    apply(induction F) by(simp_all)
  show ?case apply simp apply(rule ex_cong1)
    subgoal for xa
      using map[of 0] ExQ(1)[of "Suc i" "xa#init"] ExQ(2) ExQ(3)
      by simp
    done
next
  case (AllQ F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + 1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + 1 + x) 1 a) F y)"
    apply(induction F) by(simp_all)
  show ?case apply simp apply(rule all_cong1)
    subgoal for xa
      using map[of 0] AllQ(1)[of "Suc i" "xa#init"] AllQ(2) AllQ(3)
      by simp
    done
next
  case (ExN x1 F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + x1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + x1 + x) 1 a) F y)"
    apply(induction F) apply(simp_all add:add.commute add.left_commute)
    apply (metis add_Suc)
    apply (metis add_Suc)
    apply (metis add.assoc)
    by (metis add.assoc)
  show ?case apply simp apply(rule ex_cong1)
    subgoal for l
      using map[of 0] ExN(1)[of "i+x1" "l@init"] ExN(2) ExN(3)
      by auto
    done
next
  case (AllN x1 F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + x1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + x1 + x) 1 a) F y)"
    apply(induction F) apply(simp_all add:add.commute add.left_commute)
    apply (metis add_Suc)
    apply (metis add_Suc)
    apply (metis add.assoc)
    by (metis add.assoc)
  show ?case apply simp apply(rule all_cong1)
    subgoal for l
      using map[of 0] AllN(1)[of "i+x1" "l@init"] AllN(2) AllN(3)
      by auto
    done
qed

lemma eval_lowerFm :
  assumes h : "freeIn 0 F"
  shows " \<forall>xs. (eval (lowerFm 0 1 F) xs = eval (ExQ F) xs)"
  using eval_lowerFm_helper[OF h] by simp

fun liftAtom :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom" where
  "liftAtom d amount (Eq p) = Eq(liftPoly d amount p)"|
  "liftAtom d amount (Less p) = Less(liftPoly d amount p)"|
  "liftAtom d amount (Leq p) = Leq(liftPoly d amount p)"|
  "liftAtom d amount (Neq p) = Neq(liftPoly d amount p)"

fun liftFm :: "nat \<Rightarrow> nat \<Rightarrow> atom fm \<Rightarrow> atom fm" where
  "liftFm d amount f = map_fm_binders (\<lambda>a. \<lambda>x. liftAtom (d+x) amount a) f 0"

fun insert_into :: "real list \<Rightarrow> nat \<Rightarrow> real list \<Rightarrow> real list" where
  "insert_into xs n l = take n xs @ l @ drop n xs"

lemma higherPoly\<^sub>0_add : "higherPoly\<^sub>0 x y (p + q) = higherPoly\<^sub>0 x y p + higherPoly\<^sub>0 x y q"
  using poly_mapping_eq_iff[where a = "higherPoly\<^sub>0 x y (p + q)", where b = "higherPoly\<^sub>0 x y p + higherPoly\<^sub>0 x y q"]
    plus_poly_mapping.rep_eq[where x = "higherPoly\<^sub>0 x y (p + q)", where xa = "higherPoly\<^sub>0 x y p + higherPoly\<^sub>0 x y q"]
  apply (auto)
  by (simp add: higherPoly\<^sub>0.rep_eq lookup_add poly_mapping_eqI)

lemma liftPoly_add: "liftPoly w z (a + b) = (liftPoly w z a) + (liftPoly w z b)"
  unfolding liftPoly_def apply (auto)
proof -
  have h1: "mapping_of (a + b) = mapping_of a + mapping_of b"
    by (simp add: plus_mpoly.rep_eq)
  have h2: "MPoly (higherPoly\<^sub>0 w z (mapping_of a + mapping_of b)) =
    MPoly (higherPoly\<^sub>0 w z (mapping_of a)) + MPoly (higherPoly\<^sub>0 w z (mapping_of b))"
  proof -
    have h0a: "higherPoly\<^sub>0 w z (mapping_of a + mapping_of b) = (higherPoly\<^sub>0 w z (mapping_of a)) + (higherPoly\<^sub>0 w z (mapping_of b))"
      using higherPoly\<^sub>0_add[of w z _ _ ] by auto
    then show ?thesis
      by (simp add: plus_mpoly.abs_eq)
  qed
  show "MPoly (higherPoly\<^sub>0 w z (mapping_of (a + b))) =
    MPoly (higherPoly\<^sub>0 w z (mapping_of a)) +
    MPoly (higherPoly\<^sub>0 w z (mapping_of b))" using h1 h2 by auto
qed

lemma vars_lift_add : "vars(liftPoly a b (p+q)) \<subseteq> vars(liftPoly a b (p))\<union> vars(liftPoly a b (q))"
  using liftPoly_add[of a b p q]
  using vars_add[of "liftPoly a b p" "liftPoly a b q"]
  by auto

lemma mapping_of_lift_add : "mapping_of (liftPoly x y (a + b)) = mapping_of (liftPoly x y a) + mapping_of (liftPoly x y b)"
  unfolding liftPoly.rep_eq plus_mpoly.rep_eq
  using higherPoly\<^sub>0_add .

lemma coeff_lift_add : "MPoly_Type.coeff (liftPoly x y (a + b)) m = MPoly_Type.coeff (liftPoly x y a) m + MPoly_Type.coeff (liftPoly x y b) m"
proof-
  have "MPoly_Type.coeff (liftPoly x y (a + b)) m = MPoly_Type.coeff (liftPoly x y a + liftPoly x y b) m"
    apply( simp add : mapping_of_lift_add coeff_def  ) using lookup_add
    by (simp add: plus_mpoly.rep_eq)
  also have "... = MPoly_Type.coeff (liftPoly x y a) m + MPoly_Type.coeff (liftPoly x y b) m"
    using MPolyExtension.coeff_add[of "liftPoly x y a" "liftPoly x y b" m]  .
  finally show ?thesis
    by auto
qed

lemma lift_add : "insertion (f::nat\<Rightarrow>real)  (liftPoly 0 z (a + b)) = insertion f (liftPoly 0 z a + liftPoly 0 z b)"
  using liftPoly_add[of 0 z a b]
  by simp

lemma lower_power_zero : "lowerPowers a b 0 = 0"
  unfolding lowerPowers_def dec_above_def id_def apply auto
  unfolding Poly_Mapping.lookup_zero by auto

lemma lift_vars_monom : "vars (liftPoly i j ((MPoly_Type.monom m a)::real mpoly)) = (\<lambda>x. if x\<ge>i then x+j else x) ` vars(MPoly_Type.monom m a)"
proof(cases "a=0")
  case True
  then show ?thesis
    by (smt MPolyExtension.monom_zero add.left_neutral add_diff_cancel_right' image_empty liftPoly_add vars_monom_single_cases)
next
  case False
  have h1: "vars (liftPoly i j (MPoly_Type.monom m a)) = keys (lowerPowers i j m)"
    unfolding liftPoly_def
    unfolding keys_lowerPowers keys_higherPoly\<^sub>0 vars_def apply auto
    apply (smt imageE keys_higherPoly\<^sub>0 keys_lowerPowers lookup_eq_zero_in_keys_contradict lookup_single_not_eq mapping_of_inverse monomials.abs_eq)
    by (metis False higherPowers.rep_eq higherPowers_lowerPowers image_eqI in_keys_iff keys_higherPoly\<^sub>0 lookup_single_eq mapping_of_inverse monomials.abs_eq)
  show ?thesis
    unfolding h1  vars_monom_keys[OF False]
      keys_lowerPowers inc_above_def by auto
qed

lemma lift_clear_vars : "vars (liftPoly i j (p::real mpoly)) \<inter> {i..<i + j} = {}"
proof(induction p rule: mpoly_induct)
  case (monom m a)
  then show ?case
    unfolding lift_vars_monom by auto
next
  case (sum p1 p2 m a)
  then show ?case
    using vars_lift_add[of i j p1 p2]
    by blast
qed

lemma lift0: "(liftPoly i j 0) = 0"
  by (simp add: coeff_liftPoly mpoly_eq_iff)

lemma lower0: "(lowerPoly i j 0) = 0"
  by (simp add: coeff_all_0 coeff_lowerPoly)

lemma lower_lift_monom : "insertion f (MPoly_Type.monom m a :: real mpoly) = insertion f (lowerPoly i j (liftPoly i j (MPoly_Type.monom  m a)))"
proof (cases "a=0")
  case True
  show ?thesis unfolding True lift0 monom_zero lower0 ..
next
  case False
  have h1 :  "higherPowers i j ` ({lowerPowers i j m} \<inter> {x. \<forall>j\<in>{i..<i + j}. lookup x j = 0}) = {m}"
    apply (simp add: lowerPowers.rep_eq higherPowers.rep_eq)
    using higherPowers_lowerPowers .
  have higher_lower : "higherPowers i j (lowerPowers i j m) = m"
    using higherPowers_lowerPowers by blast
  show ?thesis using False
    unfolding insertion_code monomials_monom apply auto
    unfolding monomials_lowerPoly monomials_liftPoly apply auto
    unfolding More_MPoly_Type.coeff_monom  h1 apply auto
    unfolding coeff_lowerPoly coeff_liftPoly higherPowers_lowerPowers coeff_monom
    apply(cases "\<exists>ja\<in>{i..<i + j}. 0 < lookup (lowerPowers i j m) ja")
    apply auto
    by (simp add: lowerPowers_eq)
qed

lemma lower_lift : "insertion f (p::real mpoly) = insertion f (lowerPoly i j (liftPoly i j p))"
  unfolding insertion_code proof(induction p rule: mpoly_induct)
  case (monom m a)
  then show ?case using lower_lift_monom unfolding insertion_code monomials_lowerPoly monomials_liftPoly coeff_lowerPoly coeff_liftPoly by auto
next
  case (sum p1 p2 m a)
  have h1 : "monomials p1 \<inter> monomials p2 = {}" using sum
    by (metis Int_insert_right_if0 inf_bot_right monomials_monom)
  have h4 : "monomials (lowerPoly i j (liftPoly i j (p1 + p2))) = monomials (lowerPoly i j (liftPoly i j (p1))) \<union> monomials (lowerPoly i j (liftPoly i j (p2)))"
    using monomials_lowerPoly monomials_liftPoly monomials_add_disjoint[OF h1]
    by (simp add: monomials_liftPoly monomials_lowerPoly Int_Un_distrib2 image_Un)
  have h5 : "MPoly_Type.coeff (lowerPoly i j (liftPoly i j (p1 + p2))) = MPoly_Type.coeff (lowerPoly i j (liftPoly i j (p1))) + MPoly_Type.coeff (lowerPoly i j (liftPoly i j (p2)))"
    unfolding coeff_lowerPoly coeff_liftPoly MPolyExtension.coeff_add by auto
  show ?case
    unfolding MPolyExtension.coeff_add
    unfolding h4 h5
    unfolding monomials_add_disjoint[OF h1]
    by (smt IntE coeff_eq_zero_iff disjoint_iff_not_equal finite_monomials h1 higherPowers_lowerPowers imageE monomials_liftPoly monomials_lowerPoly plus_fun_apply sum.IH(1) sum.IH(2) sum.cong sum.union_disjoint
        )
qed
lemma lift_insertion : " \<forall>init.
       length init = (i::nat) \<longrightarrow>
       (\<forall>I xs.
           (insertion (nth_default 0 (init @ xs)) (p::real mpoly)) = (insertion ((nth_default 0) (init @ I @ xs)) (liftPoly i (length I) p)))"
proof safe
  fix init I xs
  assume "i = length (init::real list)"
  then have i_len : "length init = i" by auto
  have h: "higherPoly\<^sub>0 i (length (I::real list)) (mapping_of p) \<in> UNIV"
    by simp
  have h2 : "vars (liftPoly i (length I) p) \<inter> {i..<i + length I} = {}"
    using lift_clear_vars by auto
  show "insertion ((nth_default 0) (init @ xs)) p = insertion ((nth_default 0) (init @ I @ xs)) (liftPoly (length init) (length I) p) "
    using lower_lift insertion_lowerPoly[OF h2 i_len refl, of xs] i_len by auto
qed

lemma eval_liftFm_helper :
  assumes "length init = i"
  assumes "length I = amount"
  shows "eval F (init @xs) = eval (liftFm i amount F) (init@I@xs)"
  using assms(1)
proof(induction F arbitrary: i init)
  case (Atom x)
  then show ?case
    apply(cases x) apply simp_all using lift_insertion assms Atom.prems by force+
next
  case (ExQ F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + Suc 0)) = (map_fm_binders (\<lambda>a x. liftAtom (i + 1 + x) amount a) F y)"
    apply(induction F) by(simp_all)
  show ?case apply simp apply(rule ex_cong1)
    subgoal for x
      using map[of 0] using ExQ(1)[of "x#init" "i+1"] ExQ(2)
      by simp
    done
next
  case (AllQ F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + Suc 0)) = (map_fm_binders (\<lambda>a x. liftAtom (i + 1 + x) amount a) F y)"
    apply(induction F) by(simp_all)
  show ?case apply simp apply(rule all_cong1)
    subgoal for x
      using map[of 0] using AllQ(1)[of "x#init" "i+1"] AllQ(2)
      by simp
    done
next
  case (ExN x1 F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + x1)) = (map_fm_binders (\<lambda>a x. liftAtom (i + x1 + x) amount a) F y)"
    apply(induction F) apply(simp_all add: add.commute add.left_commute)
    apply (metis add_Suc)
    apply (metis add_Suc)
    apply (metis add.assoc)
    by (metis add.assoc)
  show ?case apply simp apply(rule ex_cong1)
    subgoal for l
      using map[of 0] ExN(1)[of "l@init" "i+x1"] ExN(2)
      by auto
    done
next
  case (AllN x1 F)
  have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + x1)) = (map_fm_binders (\<lambda>a x. liftAtom (i + x1 + x) amount a) F y)"
    apply(induction F) apply(simp_all add: add.commute add.left_commute)
    apply (metis add_Suc)
    apply (metis add_Suc)
    apply (metis add.assoc)
    by (metis add.assoc)
  show ?case apply simp apply(rule all_cong1)
    subgoal for l
      using map[of 0] AllN(1)[of "l@init" "i+x1"] AllN(2)
      by auto
    done
qed auto

lemma eval_liftFm :
  assumes "length I = amount"
  assumes "length L \<ge> d"
  shows "eval F L = eval (liftFm d amount F) (insert_into L d I)"
proof -
  define init where "init = take d L"
  then have "length init = d" using assms by simp
  then have "(eval F (init @ (drop d L)) = eval (liftFm d amount F) (init @ I @ (drop d L)))"
    using eval_liftFm_helper[of init d I amount  F "(drop d L)"] assms by auto
  then show ?thesis
    unfolding insert_into.simps assms init_def by auto
qed

lemma not_in_lift : "var\<notin>vars(p::real mpoly) \<Longrightarrow> var+z\<notin>vars(liftPoly 0 z p)"
proof(induction p rule: mpoly_induct)
  case (monom m a)
  then show ?case
    using lift_vars_monom[of 0 z m a] by auto
next
  case (sum p1 p2 m a)
  show ?case
    using sum using vars_lift_add[of 0 z p1 p2]
      vars_add[of p1 p2]
    by (metis (no_types, lifting) Set.basic_monos(7) Un_iff monomials.rep_eq vars_add_monom)
qed

lemma lift_const : "insertion f (liftPoly 0 z (Const (C::real))) = insertion f (Const C :: real mpoly)"
  apply(cases "C=0")
  unfolding insertion_code monomials_Const coeff_Const monomials_liftPoly  apply auto
  unfolding lower_power_zero[of 0 z] lookup_zero power.power_0 comm_monoid_mult_class.prod.neutral_const coeff_liftPoly coeff_Const
  unfolding higherPowers_def by auto

lemma liftPoly_sub: "liftPoly 0 z (a - b) = (liftPoly 0 z a) - (liftPoly 0 z b)"
  unfolding liftPoly_def apply (auto)
proof -
  have h1: "mapping_of (a - b) = mapping_of a - mapping_of b"
    by (simp add: minus_mpoly.rep_eq)
  have h2: "MPoly (higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b)) =
    MPoly (higherPoly\<^sub>0 0 z (mapping_of a)) - MPoly (higherPoly\<^sub>0 0 z (mapping_of b))"
  proof -
    have h0a: "higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b) = (higherPoly\<^sub>0 0 z (mapping_of a)) - (higherPoly\<^sub>0 0 z (mapping_of b))"
      using poly_mapping_eq_iff[where a = "higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b)", where b = "(higherPoly\<^sub>0 0 z (mapping_of a)) - (higherPoly\<^sub>0 0 z (mapping_of b))"]
        minus_poly_mapping.rep_eq[where x = "higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b)", where xa = "(higherPoly\<^sub>0 0 z (mapping_of a)) - (higherPoly\<^sub>0 0 z (mapping_of b))"]
      apply (auto)
      by (simp add: higherPoly\<^sub>0.rep_eq poly_mapping_eqI minus_poly_mapping.rep_eq)
    then show ?thesis
      by (simp add: minus_mpoly.abs_eq)
  qed
  show "MPoly (higherPoly\<^sub>0 0 z (mapping_of (a - b))) =
    MPoly (higherPoly\<^sub>0 0 z (mapping_of a)) -
    MPoly (higherPoly\<^sub>0 0 z (mapping_of b))" using h1 h2 by auto
qed

lemma lift_sub : "insertion (f::nat\<Rightarrow>real) (liftPoly 0 z (a - b)) = insertion f (liftPoly 0 z a - liftPoly 0 z b)"
  using liftPoly_sub[of "z" "a" "b"] by auto

lemma lift_minus :
  assumes "insertion (f::nat \<Rightarrow> real) (liftPoly 0 z (c - Const (C::real))) = 0"
  shows "insertion f (liftPoly 0 z c) = C"
proof-
  have "insertion f (liftPoly 0 z (c - Const C)) = insertion f ((liftPoly 0 z c) - (liftPoly 0 z (Const C)))"
    by (simp add: lift_sub)
  have "... = insertion f (liftPoly 0 z c) - (insertion f (liftPoly 0 z (Const C)))"
    using insertion_sub by auto
  also have "... = insertion f (liftPoly 0 z c) - C"
    using lift_const[of f z C] insertion_const by auto
  then show ?thesis
    using \<open>insertion f (liftPoly 0 z (c - Const C)) = insertion f (liftPoly 0 z c - liftPoly 0 z (Const C))\<close> assms calculation by auto
qed

end

lemma lift00 : "liftPoly 0 0 (a::real mpoly) = a"
  unfolding liftPoly_def apply auto
  unfolding higherPoly\<^sub>0_def apply auto
  unfolding higherPowers_def apply auto
  by (simp add: mapping_of_inverse)

end


(*
 * Copyright 2023, Proofcraft Pty Ltd
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory NonDetMonad_Sat
  imports
    NonDetMonad
    WPSimp
begin

section \<open>Satisfiability\<close>

text \<open>
  The dual to validity: an existential instead of a universal quantifier for the post condition.
  In refinement, it is often sufficient to know that there is one state that satisfies a condition.\<close>
definition exs_valid ::
  "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) nondet_monad \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<exists>(rv, s') \<in> fst (f s). Q rv s')"

text \<open>The above for the exception monad\<close>
definition ex_exs_validE ::
  "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'e + 'b) nondet_monad \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('e \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace> _ \<exists>\<lbrace>_\<rbrace>, \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f  \<exists>\<lbrace>\<lambda>rv. case rv of Inl e \<Rightarrow> E e | Inr v \<Rightarrow> Q v\<rbrace>"

text \<open>
  Seen as predicate transformer, @{const exs_valid} is the so-called conjugate wp in the literature,
  i.e. with
  @{term "wp f Q \<equiv> \<lambda>s. fst (f s) \<subseteq> {(rv,s). Q rv s}"} and
  @{term "cwp f Q \<equiv> not (wp f (not Q))"}, we get
  @{prop "valid P f Q = (\<forall>s. P s \<longrightarrow> wp f Q s)"} and
  @{prop "exs_valid P f Q = (\<forall>s. P s \<longrightarrow> cwp f Q s)"}.

  See also "Predicate Calculus and Program Semantics" by E. W. Dijkstra and C. S. Scholten.\<close>
experiment
begin

definition
  "wp f Q \<equiv> \<lambda>s. fst (f s) \<subseteq> {(rv,s). Q rv s}"

definition
  "cwp f Q \<equiv> not (wp f (not Q))"

lemma
  "exs_valid P f Q = (\<forall>s. P s \<longrightarrow> cwp f Q s)"
  unfolding exs_valid_def cwp_def wp_def by auto

end

subsection \<open>Set up for @{method wp}\<close>

definition exs_postcondition where
  "exs_postcondition P f \<equiv> \<lambda>a b. \<exists>(rv, s) \<in> f a b. P rv s"

lemma exs_valid_is_triple[wp_trip]:
  "exs_valid P f Q = triple_judgement P f (exs_postcondition Q (\<lambda>s f. fst (f s)))"
  by (simp add: triple_judgement_def exs_postcondition_def exs_valid_def)

subsection \<open>Rules\<close>

lemma exs_hoare_post_imp:
  "\<lbrakk>\<And>r s. Q r s \<Longrightarrow> R r s; \<lbrace>P\<rbrace> a \<exists>\<lbrace>Q\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<exists>\<lbrace>R\<rbrace>"
  unfolding exs_valid_def by blast

lemma use_exs_valid:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>; P s \<rbrakk> \<Longrightarrow> \<exists>(r, s') \<in> fst (f s). Q r s'"
  by (simp add: exs_valid_def)

lemma exs_valid_weaken_pre[wp_pre]:
  "\<lbrakk> \<lbrace>P'\<rbrace> f \<exists>\<lbrace>Q\<rbrace>; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: exs_valid_def)

lemma exs_valid_chain:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>; \<And>s. R s \<Longrightarrow> P s; \<And>r s. Q r s \<Longrightarrow> S r s \<rbrakk> \<Longrightarrow> \<lbrace>R\<rbrace> f \<exists>\<lbrace>S\<rbrace>"
  by (fastforce simp: exs_valid_def Bex_def)

lemma exs_valid_assume_pre:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>"
  by (fastforce simp: exs_valid_def)

lemma exs_valid_bind[wp_split]:
  "\<lbrakk> \<And>rv. \<lbrace>B rv\<rbrace> g rv \<exists>\<lbrace>C\<rbrace>; \<lbrace>A\<rbrace> f \<exists>\<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> f >>= (\<lambda>rv. g rv) \<exists>\<lbrace>C\<rbrace>"
  by (clarsimp simp: exs_valid_def bind_def')
     blast

lemma exs_valid_return[wp]:
  "\<lbrace>Q v\<rbrace> return v \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: exs_valid_def return_def)

lemma exs_valid_select[wp]:
  "\<lbrace>\<lambda>s. \<exists>r \<in> S. Q r s\<rbrace> select S \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: exs_valid_def select_def)

lemma exs_valid_alt[wp]:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<exists>\<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> g \<exists>\<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P or P'\<rbrace> f \<sqinter> g \<exists>\<lbrace>Q\<rbrace>"
  by (fastforce simp: exs_valid_def alternative_def)

lemma exs_valid_get[wp]:
  "\<lbrace>\<lambda>s. Q s s\<rbrace> get \<exists>\<lbrace> Q \<rbrace>"
  by (clarsimp simp: exs_valid_def get_def)

lemma exs_valid_gets[wp]:
  "\<lbrace>\<lambda>s. Q (f s) s\<rbrace> gets f \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: gets_def) wp

lemma exs_valid_put[wp]:
  "\<lbrace>Q v\<rbrace> put v \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: put_def exs_valid_def)

lemma exs_valid_fail[wp]:
  "\<lbrace>\<lambda>s. False\<rbrace> fail \<exists>\<lbrace>Q\<rbrace>"
  unfolding fail_def exs_valid_def
  by simp

lemma exs_valid_assert[wp]:
  "\<lbrace>\<lambda>s. Q () s \<and> G\<rbrace> assert G \<exists>\<lbrace>Q\<rbrace>"
  unfolding assert_def
  by (wpsimp | rule conjI)+

lemma exs_valid_state_assert[wp]:
  "\<lbrace>\<lambda>s. Q () s \<and> G s\<rbrace> state_assert G \<exists>\<lbrace>Q\<rbrace>"
  unfolding state_assert_def
  by wp

lemmas exs_valid_guard = exs_valid_state_assert

lemma exs_valid_condition[wp]:
  "\<lbrakk> \<lbrace>P\<rbrace> l \<exists>\<lbrace>Q\<rbrace>; \<lbrace>P'\<rbrace> r \<exists>\<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. (C s \<and> P s) \<or> (\<not> C s \<and> P' s)\<rbrace> condition C l r \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: condition_def exs_valid_def split: sum.splits)

lemma gets_exs_valid:
  "\<lbrace>(=) s\<rbrace> gets f \<exists>\<lbrace>\<lambda>r. (=) s\<rbrace>"
  by (rule exs_valid_gets)

lemma exs_valid_assert_opt[wp]:
  "\<lbrace>\<lambda>s. \<exists>x. G = Some x \<and> Q x s\<rbrace> assert_opt G \<exists>\<lbrace>Q\<rbrace>"
  by (clarsimp simp: assert_opt_def exs_valid_def get_def assert_def bind_def' return_def)

lemma gets_the_exs_valid[wp]:
  "\<lbrace>\<lambda>s. \<exists>x. h s = Some x \<and> Q x s\<rbrace> gets_the h \<exists>\<lbrace>Q\<rbrace>"
  by (wpsimp simp: gets_the_def)

end


(* Title: Fast_Dice_Roll.thy
   Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Arbitrary uniform distributions\<close>

theory Fast_Dice_Roll imports
  Bernoulli
  While_SPMF
begin

text \<open>This formalisation follows the ideas by J\'er\'emie Lumbroso \<^cite>\<open>"Lumbroso2013arxiv"\<close>.\<close>

lemma sample_bits_fusion:
  fixes v :: nat
  assumes "0 < v"
  shows
  "bind_pmf (pmf_of_set {..<v}) (\<lambda>c. bind_pmf (pmf_of_set UNIV) (\<lambda>b. f (2 * c + (if b then 1 else 0)))) =
   bind_pmf (pmf_of_set {..<2 * v}) f"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = bind_pmf (map_pmf (\<lambda>(c, b). (2 * c + (if b then 1 else 0))) (pair_pmf (pmf_of_set {..<v}) (pmf_of_set UNIV))) f"
    (is "_ = bind_pmf (map_pmf ?f _) _")
    by(simp add: pair_pmf_def bind_map_pmf bind_assoc_pmf bind_return_pmf)
  also have "map_pmf ?f (pair_pmf (pmf_of_set {..<v}) (pmf_of_set UNIV)) = pmf_of_set {..<2 * v}"
    (is "?l = ?r" is "map_pmf ?f ?p = _")
  proof(rule pmf_eqI)
    fix i :: nat
    have [simp]: "inj ?f" by(auto simp add: inj_on_def) arith+
    define i' where "i' \<equiv> i div 2"
    define b where "b \<equiv> odd i"
    have i: "i = ?f (i', b)" by(simp add: i'_def b_def)
    show "pmf ?l i = pmf ?r i"
      by(subst i; subst pmf_map_inj')(simp_all add: pmf_pair i'_def assms lessThan_empty_iff split: split_indicator)
  qed
  finally show ?thesis .
qed

lemma sample_bits_fusion2:
  fixes v :: nat
  assumes "0 < v"
  shows
  "bind_pmf (pmf_of_set UNIV) (\<lambda>b. bind_pmf (pmf_of_set {..<v}) (\<lambda>c. f (c + v * (if b then 1 else 0)))) =
   bind_pmf (pmf_of_set {..<2 * v}) f"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = bind_pmf (map_pmf (\<lambda>(c, b). (c + v * (if b then 1 else 0))) (pair_pmf (pmf_of_set {..<v}) (pmf_of_set UNIV))) f"
    (is "_ = bind_pmf (map_pmf ?f _) _")
    unfolding pair_pmf_def by(subst bind_commute_pmf)(simp add: bind_map_pmf bind_assoc_pmf bind_return_pmf)
  also have "map_pmf ?f (pair_pmf (pmf_of_set {..<v}) (pmf_of_set UNIV)) = pmf_of_set {..<2 * v}"
    (is "?l = ?r" is "map_pmf ?f ?p = _")
  proof(rule pmf_eqI)
    fix i :: nat
    have [simp]: "inj_on ?f ({..<v} \<times> UNIV)" by(auto simp add: inj_on_def)
    define i' where "i' \<equiv> if i \<ge> v then i - v else i"
    define b where "b \<equiv> i \<ge> v"
    have i: "i = ?f (i', b)" by(simp add: i'_def b_def)
    show "pmf ?l i = pmf ?r i"
    proof(cases "i < 2 * v")
      case True
      thus ?thesis
        by(subst i; subst pmf_map_inj)(auto simp add: pmf_pair i'_def assms lessThan_empty_iff split: split_indicator)
    next
      case False
      hence "i \<notin> set_pmf ?l" "i \<notin> set_pmf ?r"
        using assms by(auto simp add: lessThan_empty_iff split: if_split_asm)
      thus ?thesis by(simp add: set_pmf_iff del: set_map_pmf)
    qed
  qed
  finally show ?thesis .
qed

context fixes n :: nat notes [[function_internals]] begin

text \<open>
  The check for @{term "v >= n"} should be done already at the start of the loop.
  Otherwise we do not see why this algorithm should be optimal (when we start with @{term "v = n"}
  and @{term "c = n - 1"}, then it can go round a few loops before it returns something).

  We define the algorithm as a least fixpoint. To prove termination, we later show that it is
  equivalent to a while loop which samples bitstrings of a given length, which could in turn
  be implemented as a loop.  The fixpoint formulation is more elegant because we do not need to
  nest any loops.
\<close>

partial_function (spmf) fast_dice_roll :: "nat \<Rightarrow> nat \<Rightarrow> nat spmf"
where
  "fast_dice_roll v c =
  (if v \<ge> n then if c < n then return_spmf c else fast_dice_roll (v - n) (c - n)
   else do {
     b \<leftarrow> coin_spmf;
     fast_dice_roll (2 * v) (2 * c + (if b then 1 else 0)) } )"

lemma fast_dice_roll_fixp_induct [case_names adm bottom step]:
  assumes "spmf.admissible (\<lambda>fast_dice_roll. P (curry fast_dice_roll))"
  and "P (\<lambda>v c. return_pmf None)"
  and "\<And>fdr. P fdr \<Longrightarrow> P (\<lambda>v c. if v \<ge> n then if c < n then return_spmf c else fdr (v - n) (c - n)
        else bind_spmf coin_spmf (\<lambda>b. fdr (2 * v) (2 * c + (if b then 1 else 0))))"
  shows "P fast_dice_roll"
using assms by(rule fast_dice_roll.fixp_induct)

definition fast_uniform :: "nat spmf"
where "fast_uniform = fast_dice_roll 1 0"

lemma spmf_fast_dice_roll_ub:
  assumes "0 < v"
  shows "spmf (bind_pmf (pmf_of_set {..<v}) (fast_dice_roll v)) x \<le> (if x < n then 1 / n else 0)"
  (is "?lhs \<le> ?rhs")
proof -
  have "ennreal ?lhs \<le> ennreal ?rhs" using assms
  proof(induction arbitrary: v x rule: fast_dice_roll_fixp_induct)
    case adm thus ?case
      by(rule cont_intro ccpo_class.admissible_leI)+ simp_all
    case bottom thus ?case by simp
    case (step fdr)
    show ?case (is "?lhs \<le> ?rhs")
    proof(cases "n \<le> v")
      case le: True
      then have "?lhs = spmf (bind_pmf (pmf_of_set {..<v}) (\<lambda>c. if c < n then return_spmf c else fdr (v - n) (c - n))) x"
        by simp
      also have "\<dots> = (\<integral>\<^sup>+ c'. indicator (if x < n then {x} else {}) c' \<partial>measure_pmf (pmf_of_set {..<v})) +
        (\<integral>\<^sup>+ c'. indicator {n ..< v} c' * spmf (fdr (v - n) (c' - n)) x \<partial>measure_pmf (pmf_of_set {..<v}))"
        (is "?then = ?found + ?continue") using step.prems
        by(subst nn_integral_add[symmetric])(auto simp add: ennreal_pmf_bind AE_measure_pmf_iff lessThan_empty_iff split: split_indicator intro!: nn_integral_cong_AE)
      also have "?found = (if x < n then 1 else 0) / v" using step.prems le
        by(auto simp add: measure_pmf.emeasure_eq_measure measure_pmf_of_set lessThan_empty_iff Iio_Int_singleton)
      also have "?continue = (\<integral>\<^sup>+ c'. indicator {n ..< v} c' * 1 / v * spmf (fdr (v - n) (c' - n)) x \<partial>count_space UNIV)"
        using step.prems by(auto simp add: nn_integral_measure_pmf lessThan_empty_iff ennreal_mult[symmetric] intro!: nn_integral_cong split: split_indicator)
      also have "\<dots> = (if v = n then 0 else ennreal ((v - n) / v) * spmf (bind_pmf (pmf_of_set {n..<v}) (\<lambda>c'. fdr (v - n) (c' - n))) x)"
        using le step.prems
        by(subst ennreal_pmf_bind)(auto simp add: ennreal_mult[symmetric] nn_integral_measure_pmf nn_integral_0_iff_AE AE_count_space nn_integral_cmult[symmetric] split: split_indicator)
      also {
        assume *: "n < v"
        then have "pmf_of_set {n..<v} = map_pmf ((+) n) (pmf_of_set {..<v - n})"
          by(subst map_pmf_of_set_inj)(auto 4 3 simp add: inj_on_def lessThan_empty_iff intro!: arg_cong[where f=pmf_of_set] intro: rev_image_eqI[where x="_ - n"] diff_less_mono)
        also have "bind_pmf \<dots> (\<lambda>c'. fdr (v - n) (c' - n)) = bind_pmf (pmf_of_set {..<v - n}) (fdr (v - n))"
          by(simp add: bind_map_pmf)
        also have "ennreal (spmf \<dots> x) \<le> (if x < n then 1 / n else 0)"
          by(rule step.IH)(simp add: *)
        also note calculation }
      then have "\<dots> \<le> ennreal ((v - n) / v) * (if x < n then 1 / n else 0)" using le
        by(cases "v = n")(auto split del: if_split intro: divide_right_mono mult_left_mono)
      also have "\<dots> = (v - n) / v * (if x < n then 1 / n else 0)" by(simp add: ennreal_mult[symmetric])
      finally show ?thesis using le by(auto simp add: add_mono field_simps of_nat_diff ennreal_plus[symmetric] simp del: ennreal_plus)
    next
      case False
      then have "?lhs = spmf (bind_pmf (pmf_of_set {..<v}) (\<lambda>c. bind_pmf (pmf_of_set UNIV) (\<lambda>b. fdr (2 * v) (2 * c + (if b then 1 else 0))))) x"
        by(simp add: bind_spmf_spmf_of_set)
      also have "\<dots> = spmf (bind_pmf (pmf_of_set {..<2 * v}) (fdr (2 * v))) x" using step.prems
        by(simp add: sample_bits_fusion[symmetric])
      also have "\<dots> \<le> ?rhs" using step.prems by(intro step.IH) simp
      finally show ?thesis .
    qed
  qed
  thus ?thesis by simp
qed

lemma spmf_fast_uniform_ub:
  "spmf fast_uniform x \<le> (if x < n then 1 / n else 0)"
proof -
  have "{..<Suc 0} = {0}" by auto
  then show ?thesis using spmf_fast_dice_roll_ub[of 1 x]
    by(simp add: fast_uniform_def pmf_of_set_singleton bind_return_pmf split: if_split_asm)
qed

lemma fast_dice_roll_0 [simp]: "fast_dice_roll 0 c = return_pmf None"
by(induction arbitrary: c rule: fast_dice_roll_fixp_induct)(simp_all add: bind_eq_return_pmf_None)

text \<open>To prove termination, we fold all the iterations that only double into one big step\<close>

definition fdr_step :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) spmf"
where
  "fdr_step v c =
  (if v = 0 then return_pmf None
   else let x = 2 ^ (nat \<lceil>log 2 (max 1 n) - log 2 v\<rceil>) in
     map_spmf (\<lambda>bs. (x * v, x * c + bs)) (spmf_of_set {..<x}))"

lemma fdr_step_unfold:
  "fdr_step v c =
  (if v = 0 then return_pmf None
   else if n \<le> v then return_spmf (v, c)
   else do {
     b \<leftarrow> coin_spmf;
     fdr_step (2 * v) (2 * c + (if b then 1 else 0)) })"
  (is "?lhs = ?rhs" is "_ = (if _ then _ else ?else)")
proof(cases "v = 0")
  case v: False
  define x where "x \<equiv> \<lambda>v :: nat. 2 ^ (nat \<lceil>log 2 (max 1 n) - log 2 v\<rceil>) :: nat"
  have x_pos: "x v > 0" by(simp add: x_def)

  show ?thesis
  proof(cases "n \<le> v")
    case le: True
    hence "x v = 1" using v by(simp add: x_def log_le)
    moreover have "{..<1} = {0 :: nat}" by auto
    ultimately show ?thesis using le v by(simp add: fdr_step_def spmf_of_set_singleton)
  next
    case less: False
    hence even: "even (x v)" using v by(simp add: x_def)
    with x_pos have x_ge_1: "x v > 1" by(cases "x v = 1") auto
    have *: "x (2 * v) = x v div 2" using v less unfolding x_def
      apply(simp add: log_mult diff_add_eq_diff_diff_swap)
      apply(rewrite in "_ = 2 ^ \<hole> div _" le_add_diff_inverse2[symmetric, where b=1])
       apply (simp add: Suc_leI)
      apply(simp del: Suc_pred)
      done

    have "?lhs = map_spmf (\<lambda>bs. (x v * v, x v * c + bs)) (spmf_of_set {..<x v})"
      using v by(simp add: fdr_step_def x_def Let_def)
    also from even have "\<dots> = bind_pmf (pmf_of_set {..<2 * (x v div 2)}) (\<lambda>bs. return_spmf (x v * v, x v * c + bs))"
      by(simp add: map_spmf_conv_bind_spmf bind_spmf_spmf_of_set x_pos lessThan_empty_iff)
    also have "\<dots> = bind_spmf coin_spmf (\<lambda>b. bind_spmf (spmf_of_set {..<x v div 2})
      (\<lambda>c'. return_spmf (x v * v, x v * c + c' + (x v div 2) * (if b then 1 else 0))))"
      using x_ge_1
      by(simp add: sample_bits_fusion2[symmetric] bind_spmf_spmf_of_set lessThan_empty_iff add.assoc)
    also have "\<dots> = bind_spmf coin_spmf (\<lambda>b. map_spmf (\<lambda>bs. (x (2 * v) * (2 * v), x (2 * v) * (2 * c + (if b then 1 else 0)) + bs)) (spmf_of_set {..<x (2 * v)}))"
      using * even by(simp add: map_spmf_conv_bind_spmf algebra_simps)
    also have "\<dots> = ?rhs" using v less by(simp add: fdr_step_def Let_def x_def)
    finally show ?thesis .
  qed
qed(simp add: fdr_step_def)

lemma fdr_step_induct [case_names fdr_step]:
  "(\<And>v c. (\<And>b. \<lbrakk>v \<noteq> 0; v < n\<rbrakk> \<Longrightarrow> P (2 * v) (2 * c + (if b then 1 else 0))) \<Longrightarrow> P v c)
  \<Longrightarrow> P v c"
apply induction_schema
apply pat_completeness
apply(relation "Wellfounded.measure (\<lambda>(v, c). n - v)")
apply simp_all
done

partial_function (spmf) fdr_alt :: "nat \<Rightarrow> nat \<Rightarrow> nat spmf"
where
  "fdr_alt v c = do {
    (v', c') \<leftarrow> fdr_step v c;
    if c' < n then return_spmf c' else fdr_alt (v' - n) (c' - n) }"

lemma fast_dice_roll_alt: "fdr_alt = fast_dice_roll"
proof(intro ext)
  show "fdr_alt v c = fast_dice_roll v c" for v c
  proof(rule spmf.leq_antisym)
    show "ord_spmf (=) (fdr_alt v c) (fast_dice_roll v c)"
    proof(induction arbitrary: v c rule: fdr_alt.fixp_induct[case_names adm bottom step])
      case adm show ?case by simp
      case bottom show ?case by simp
      case (step fdra)
      show ?case
      proof(induction v c rule: fdr_step_induct)
        case inner: (fdr_step v c)
        show ?case
          apply(rewrite fdr_step_unfold)
          apply(rewrite fast_dice_roll.simps)
          apply(auto intro!: ord_spmf_bind_reflI simp add: Let_def inner.IH step.IH)
          done
      qed
    qed
    have "ord_spmf (=) (fast_dice_roll v c) (fdr_alt v c)"
      and "fast_dice_roll 0 c = return_pmf None"
    proof(induction arbitrary: v c rule: fast_dice_roll_fixp_induct)
      case adm thus ?case by simp
      case bottom case 1 thus ?case by simp
      case bottom case 2 thus ?case by simp
      case (step fdr) case 1 show ?case
        apply(rewrite fdr_alt.simps)
        apply(rewrite fdr_step_unfold)
        apply(clarsimp simp add: Let_def)
        apply(auto intro!: ord_spmf_bind_reflI simp add: fdr_alt.simps[symmetric] step.IH rel_pmf_return_pmf2 set_pmf_bind_spmf o_def set_pmf_spmf_of_set split: if_split_asm)
        done
      case step case 2 from step.IH show ?case by(simp add: Let_def bind_eq_return_pmf_None)
    qed
    then show "ord_spmf (=) (fast_dice_roll v c) (fdr_alt v c)" by -
  qed
qed

lemma lossless_fdr_step [simp]: "lossless_spmf (fdr_step v c) \<longleftrightarrow> v > 0"
by(simp add: fdr_step_def Let_def lessThan_empty_iff)

lemma lossless_fast_dice_roll:
  assumes "c < v" "v \<le> n"
  shows "lossless_spmf (fast_dice_roll v c)"
proof(cases "v < n")
  case True
  let ?I = "\<lambda>(v, c). c < v \<and> n \<le> v \<and> v < 2 * n"
  let ?f = "\<lambda>(v, c). if n \<le> c then n + c - v + 1 else 0"
  have invar: "?I (v', c')" if step: "(v', c') \<in> set_spmf (fdr_step (v - n) (c - n))"
    and I: "c < v" "n \<le> v" "v < 2 * n" and c: "n \<le> c" for v' c' v c
  proof(clarsimp; safe)
    define x where "x = nat \<lceil>log 2 (max 1 n) - log 2 (v - n)\<rceil>"
    have **: "-1 < log 2 (real n / real (v - n))" by(rule less_le_trans[where y=0])(use I c in \<open>auto\<close>)

    from I c step obtain bs where v': "v' = 2 ^ x * (v - n)"
      and c': "c' = 2 ^ x * (c - n) + bs"
      and bs: "bs < 2 ^ x"
      unfolding fdr_step_def x_def[symmetric] by(auto simp add: Let_def)
    have "2 ^ x * (c - n) + bs < 2 ^ x * (c - n + 1)" unfolding distrib_left using bs
      by(intro add_strict_left_mono) simp
    also have "\<dots> \<le> 2 ^ x * (v - n)" using I c by(intro mult_left_mono) auto
    finally show "c' < v'" using c' v' by simp

    have "v' = 2 powr x * (v - n)" by(simp add: powr_realpow v')
    also have "\<dots> < 2 powr (log 2 (max 1 n) - log 2 (v - n) + 1) * (v - n)"
      using ** I c by(intro mult_strict_right_mono)(auto simp add: x_def log_divide)
    also have "\<dots> \<le> 2 * n" unfolding powr_add using I c
      by(simp add: log_divide[symmetric] max_def)
    finally show "v' < 2 * n" using c' by(simp del: of_nat_add)

    have "log 2 (n / (v - n)) \<le> x" using I c ** by(auto simp add: x_def log_divide max_def)
    hence "2 powr log 2 (n / (v - n)) \<le> 2 powr x" by(rule powr_mono) simp
    also have "2 powr log 2 (n / (v - n)) = n / (v - n)" using I c by(simp)
    finally have "n \<le> real (2 ^ x * (v - n))" using I c by(simp add: field_simps powr_realpow)
    then show "n \<le> v'" by(simp add: v' del: of_nat_mult)
  qed

  have loop: "lossless_spmf (loop_spmf.while (\<lambda>(v, c). n \<le> c) (\<lambda>(v, c). fdr_step (v - n) (c - n)) (v, c))"
    if "c < 2 * n" and "n \<le> v" and "c < v" and "v < 2 * n"
    for v c
  proof(rule termination_variant_invar; clarify?)
    fix v c
    assume I: "?I (v, c)" and c: "n \<le> c"
    show "?f (v, c) \<le> n" using I c by auto

    define x where "x = nat \<lceil>log 2 (max 1 n) - log 2 (v - n)\<rceil>"
    define p :: real where "p \<equiv> 1 / (2 * n)"

    from I c have n: "0 < n" and v: "n < v" by auto
    from I c v n have x_pos: "x > 0" by(auto simp add: x_def max_def)

    have **: "-1 < log 2 (real n / real (v - n))" by(rule less_le_trans[where y=0])(use I c in \<open>auto\<close>)
    then have "x \<le> log 2 (real n) + 1" using v n
      by(auto simp add: x_def log_divide[symmetric] max_def field_simps intro: order_trans[OF of_int_ceiling_le_add_one])
    hence "2 powr x \<le> 2 powr \<dots>" by(rule powr_mono) simp
    hence "p \<le> 1 / 2 ^ x" unfolding powr_add using n
      by(subst (asm) powr_realpow, simp)(subst (asm) powr_log_cancel; simp_all add: p_def field_simps)
    also
    let ?X = "{c'. n \<le> 2 ^ x * (c - n) + c' \<longrightarrow> n + (2 ^ x * (c - n) + c') - 2 ^ x * (v - n) < n + c - v}"
    have "n + c * 2 ^ x - v * 2 ^ x < c + n - v" using I c
    proof(cases "n + c * 2 ^ x \<ge> v * 2 ^ x")
      case True
      have "(int c - v) * 2 ^ x < (int c - v) * 1"
        using x_pos I c by(intro mult_strict_left_mono_neg) simp_all
      then have "int n + c * 2 ^ x - v * 2 ^ x < c + int n - v" by(simp add: algebra_simps)
      also have "\<dots> = int (c + n - v)" using I c by auto
      also have "int n + c * 2 ^ x - v * 2 ^ x = int (n + c * 2 ^ x - v * 2 ^ x)"
        using True that by(simp add: of_nat_diff)
      finally show ?thesis by simp
    qed auto
    then have "{..<2 ^ x} \<inter> ?X \<noteq> {}" using that n v
      by(auto simp add: disjoint_eq_subset_Compl Collect_neg_eq[symmetric] lessThan_subset_Collect algebra_simps intro: exI[where x=0])
    then have "0 < card ({..<2 ^ x} \<inter> ?X)" by(simp add: card_gt_0_iff)
    hence "1 / 2 ^ x \<le> \<dots> / 2 ^ x" by(simp add: field_simps)
    finally show "p \<le> spmf (map_spmf (\<lambda>s'. ?f s' < ?f (v, c)) (fdr_step (v - n) (c - n))) True"
      using I c unfolding fdr_step_def x_def[symmetric]
      by(clarsimp simp add: Let_def spmf.map_comp o_def spmf_map measure_spmf_of_set vimage_def p_def)

    show "lossless_spmf (fdr_step (v - n) (c - n))" using I c by simp
    show "?I (v', c')" if step: "(v', c') \<in> set_spmf (fdr_step (v - n) (c - n))" for v' c'
      using that by(rule invar)(use I c in auto)
  next
    show "(0 :: real) < 1 / (2 * n)" using that by(simp)
    show "?I (v, c)" using that by simp
  qed
  show ?thesis using assms True
    by(auto simp add: fast_dice_roll_alt[symmetric] fast_dice_roll_alt_conv_while intro!: loop dest: invar[of _ _ "n + v" "n + c", simplified])
next
  case False
  with assms have "v = n" by simp
  thus ?thesis using assms by(subst fast_dice_roll.simps) simp
qed

lemma fast_dice_roll_n0:
  assumes "n = 0"
  shows "fast_dice_roll v c = return_pmf None"
  by(induction arbitrary: v c rule: fast_dice_roll_fixp_induct)(simp_all add: assms)

lemma lossless_fast_uniform [simp]: "lossless_spmf fast_uniform \<longleftrightarrow> n > 0"
proof(cases "n = 0")
  case True
  then show ?thesis using fast_dice_roll_n0 unfolding fast_uniform_def by(simp)
next
  case False
  then show ?thesis by(simp add: fast_uniform_def lossless_fast_dice_roll)
qed

lemma spmf_fast_uniform: "spmf fast_uniform x = (if x < n then 1 / n else 0)"
proof(cases "n > 0")
  case n: True
  show ?thesis using spmf_fast_uniform_ub
  proof(rule spmf_ub_tight)
    have "(\<Sum>\<^sup>+ x. ennreal (if x < n then 1 / n else 0)) = (\<Sum>\<^sup>+ x\<in>{..<n}. 1 / n)"
      by(auto simp add: nn_integral_count_space_indicator simp del: nn_integral_const intro: nn_integral_cong)
    also have "\<dots> = 1" using n by(simp add: field_simps ennreal_of_nat_eq_real_of_nat ennreal_mult[symmetric])
    also have "\<dots> = weight_spmf fast_uniform" using lossless_fast_uniform n unfolding lossless_spmf_def by simp
    finally show "(\<Sum>\<^sup>+ x. ennreal (if x < n then 1 / n else 0)) = \<dots>" .
  qed
next
  case False
  with fast_dice_roll_n0[of 1 0] show ?thesis unfolding fast_uniform_def by(simp)
qed

end

lemma fast_uniform_conv_uniform: "fast_uniform n = spmf_of_set {..<n}"
by(rule spmf_eqI)(simp add: spmf_fast_uniform spmf_of_set)

end


(*<*)
theory AdvancedInd imports Main begin
(*>*)

text\<open>\noindent
Now that we have learned about rules and logic, we take another look at the
finer points of induction.  We consider two questions: what to do if the
proposition to be proved is not directly amenable to induction
(\S\ref{sec:ind-var-in-prems}), and how to utilize (\S\ref{sec:complete-ind})
and even derive (\S\ref{sec:derive-ind}) new induction schemas. We conclude
with an extended example of induction (\S\ref{sec:CTL-revisited}).
\<close>

subsection\<open>Massaging the Proposition\<close>

text\<open>\label{sec:ind-var-in-prems}
Often we have assumed that the theorem to be proved is already in a form
that is amenable to induction, but sometimes it isn't.
Here is an example.
Since \<^term>\<open>hd\<close> and \<^term>\<open>last\<close> return the first and last element of a
non-empty list, this lemma looks easy to prove:
\<close>

lemma "xs \<noteq> [] \<Longrightarrow> hd(rev xs) = last xs"
apply(induct_tac xs)

txt\<open>\noindent
But induction produces the warning
\begin{quote}\tt
Induction variable occurs also among premises!
\end{quote}
and leads to the base case
@{subgoals[display,indent=0,goals_limit=1]}
Simplification reduces the base case to this:
\begin{isabelle}
\ 1.\ xs\ {\isasymnoteq}\ []\ {\isasymLongrightarrow}\ hd\ []\ =\ last\ []
\end{isabelle}
We cannot prove this equality because we do not know what \<^term>\<open>hd\<close> and
\<^term>\<open>last\<close> return when applied to \<^term>\<open>[]\<close>.

We should not have ignored the warning. Because the induction
formula is only the conclusion, induction does not affect the occurrence of \<^term>\<open>xs\<close> in the premises.
Thus the case that should have been trivial
becomes unprovable. Fortunately, the solution is easy:\footnote{A similar
heuristic applies to rule inductions; see \S\ref{sec:rtc}.}
\begin{quote}
\emph{Pull all occurrences of the induction variable into the conclusion
using \<open>\<longrightarrow>\<close>.}
\end{quote}
Thus we should state the lemma as an ordinary
implication~(\<open>\<longrightarrow>\<close>), letting
\attrdx{rule_format} (\S\ref{sec:forward}) convert the
result to the usual \<open>\<Longrightarrow>\<close> form:
\<close>
(*<*)oops(*>*)
lemma hd_rev [rule_format]: "xs \<noteq> [] \<longrightarrow> hd(rev xs) = last xs"
(*<*)
apply(induct_tac xs)
(*>*)

txt\<open>\noindent
This time, induction leaves us with a trivial base case:
@{subgoals[display,indent=0,goals_limit=1]}
And \<open>auto\<close> completes the proof.

If there are multiple premises $A@1$, \dots, $A@n$ containing the
induction variable, you should turn the conclusion $C$ into
\[ A@1 \longrightarrow \cdots A@n \longrightarrow C. \]
Additionally, you may also have to universally quantify some other variables,
which can yield a fairly complex conclusion.  However, \<open>rule_format\<close>
can remove any number of occurrences of \<open>\<forall>\<close> and
\<open>\<longrightarrow>\<close>.

\index{induction!on a term}%
A second reason why your proposition may not be amenable to induction is that
you want to induct on a complex term, rather than a variable. In
general, induction on a term~$t$ requires rephrasing the conclusion~$C$
as
\begin{equation}\label{eqn:ind-over-term}
\forall y@1 \dots y@n.~ x = t \longrightarrow C.
\end{equation}
where $y@1 \dots y@n$ are the free variables in $t$ and $x$ is a new variable.
Now you can perform induction on~$x$. An example appears in
\S\ref{sec:complete-ind} below.

The very same problem may occur in connection with rule induction. Remember
that it requires a premise of the form $(x@1,\dots,x@k) \in R$, where $R$ is
some inductively defined set and the $x@i$ are variables.  If instead we have
a premise $t \in R$, where $t$ is not just an $n$-tuple of variables, we
replace it with $(x@1,\dots,x@k) \in R$, and rephrase the conclusion $C$ as
\[ \forall y@1 \dots y@n.~ (x@1,\dots,x@k) = t \longrightarrow C. \]
For an example see \S\ref{sec:CTL-revisited} below.

Of course, all premises that share free variables with $t$ need to be pulled into
the conclusion as well, under the \<open>\<forall>\<close>, again using \<open>\<longrightarrow>\<close> as shown above.

Readers who are puzzled by the form of statement
(\ref{eqn:ind-over-term}) above should remember that the
transformation is only performed to permit induction. Once induction
has been applied, the statement can be transformed back into something quite
intuitive. For example, applying wellfounded induction on $x$ (w.r.t.\
$\prec$) to (\ref{eqn:ind-over-term}) and transforming the result a
little leads to the goal
\[ \bigwedge\overline{y}.\
   \forall \overline{z}.\ t\,\overline{z} \prec t\,\overline{y}\ \longrightarrow\ C\,\overline{z}
    \ \Longrightarrow\ C\,\overline{y} \]
where $\overline{y}$ stands for $y@1 \dots y@n$ and the dependence of $t$ and
$C$ on the free variables of $t$ has been made explicit.
Unfortunately, this induction schema cannot be expressed as a
single theorem because it depends on the number of free variables in $t$ ---
the notation $\overline{y}$ is merely an informal device.
\<close>
(*<*)by auto(*>*)

subsection\<open>Beyond Structural and Recursion Induction\<close>

text\<open>\label{sec:complete-ind}
So far, inductive proofs were by structural induction for
primitive recursive functions and recursion induction for total recursive
functions. But sometimes structural induction is awkward and there is no
recursive function that could furnish a more appropriate
induction schema. In such cases a general-purpose induction schema can
be helpful. We show how to apply such induction schemas by an example.

Structural induction on \<^typ>\<open>nat\<close> is
usually known as mathematical induction. There is also \textbf{complete}
\index{induction!complete}%
induction, where you prove $P(n)$ under the assumption that $P(m)$
holds for all $m<n$. In Isabelle, this is the theorem \tdx{nat_less_induct}:
@{thm[display]"nat_less_induct"[no_vars]}
As an application, we prove a property of the following
function:
\<close>

axiomatization f :: "nat \<Rightarrow> nat"
  where f_ax: "f(f(n)) < f(Suc(n))" for n :: nat

text\<open>
\begin{warn}
We discourage the use of axioms because of the danger of
inconsistencies.  Axiom \<open>f_ax\<close> does
not introduce an inconsistency because, for example, the identity function
satisfies it.  Axioms can be useful in exploratory developments, say when
you assume some well-known theorems so that you can quickly demonstrate some
point about methodology.  If your example turns into a substantial proof
development, you should replace axioms by theorems.
\end{warn}\noindent
The axiom for \<^term>\<open>f\<close> implies \<^prop>\<open>n <= f n\<close>, which can
be proved by induction on \mbox{\<^term>\<open>f n\<close>}. Following the recipe outlined
above, we have to phrase the proposition as follows to allow induction:
\<close>

lemma f_incr_lem: "\<forall>i. k = f i \<longrightarrow> i \<le> f i"

txt\<open>\noindent
To perform induction on \<^term>\<open>k\<close> using @{thm[source]nat_less_induct}, we use
the same general induction method as for recursion induction (see
\S\ref{sec:fun-induction}):
\<close>

apply(induct_tac k rule: nat_less_induct)

txt\<open>\noindent
We get the following proof state:
@{subgoals[display,indent=0,margin=65]}
After stripping the \<open>\<forall>i\<close>, the proof continues with a case
distinction on \<^term>\<open>i\<close>. The case \<^prop>\<open>i = (0::nat)\<close> is trivial and we focus on
the other case:
\<close>

apply(rule allI)
apply(case_tac i)
 apply(simp)
txt\<open>
@{subgoals[display,indent=0]}
\<close>
by(blast intro!: f_ax Suc_leI intro: le_less_trans)

text\<open>\noindent
If you find the last step puzzling, here are the two lemmas it employs:
\begin{isabelle}
@{thm Suc_leI[no_vars]}
\rulename{Suc_leI}\isanewline
@{thm le_less_trans[no_vars]}
\rulename{le_less_trans}
\end{isabelle}
%
The proof goes like this (writing \<^term>\<open>j\<close> instead of \<^typ>\<open>nat\<close>).
Since \<^prop>\<open>i = Suc j\<close> it suffices to show
\hbox{\<^prop>\<open>j < f(Suc j)\<close>},
by @{thm[source]Suc_leI}\@.  This is
proved as follows. From @{thm[source]f_ax} we have \<^prop>\<open>f (f j) < f (Suc j)\<close>
(1) which implies \<^prop>\<open>f j <= f (f j)\<close> by the induction hypothesis.
Using (1) once more we obtain \<^prop>\<open>f j < f(Suc j)\<close> (2) by the transitivity
rule @{thm[source]le_less_trans}.
Using the induction hypothesis once more we obtain \<^prop>\<open>j <= f j\<close>
which, together with (2) yields \<^prop>\<open>j < f (Suc j)\<close> (again by
@{thm[source]le_less_trans}).

This last step shows both the power and the danger of automatic proofs.  They
will usually not tell you how the proof goes, because it can be hard to
translate the internal proof into a human-readable format.  Automatic
proofs are easy to write but hard to read and understand.

The desired result, \<^prop>\<open>i <= f i\<close>, follows from @{thm[source]f_incr_lem}:
\<close>

lemmas f_incr = f_incr_lem[rule_format, OF refl]

text\<open>\noindent
The final @{thm[source]refl} gets rid of the premise \<open>?k = f ?i\<close>.
We could have included this derivation in the original statement of the lemma:
\<close>

lemma f_incr[rule_format, OF refl]: "\<forall>i. k = f i \<longrightarrow> i \<le> f i"
(*<*)oops(*>*)

text\<open>
\begin{exercise}
From the axiom and lemma for \<^term>\<open>f\<close>, show that \<^term>\<open>f\<close> is the
identity function.
\end{exercise}

Method \methdx{induct_tac} can be applied with any rule $r$
whose conclusion is of the form ${?}P~?x@1 \dots ?x@n$, in which case the
format is
\begin{quote}
\isacommand{apply}\<open>(induct_tac\<close> $y@1 \dots y@n$ \<open>rule:\<close> $r$\<open>)\<close>
\end{quote}
where $y@1, \dots, y@n$ are variables in the conclusion of the first subgoal.

A further useful induction rule is @{thm[source]length_induct},
induction on the length of a list\indexbold{*length_induct}
@{thm[display]length_induct[no_vars]}
which is a special case of @{thm[source]measure_induct}
@{thm[display]measure_induct[no_vars]}
where \<^term>\<open>f\<close> may be any function into type \<^typ>\<open>nat\<close>.
\<close>

subsection\<open>Derivation of New Induction Schemas\<close>

text\<open>\label{sec:derive-ind}
\index{induction!deriving new schemas}%
Induction schemas are ordinary theorems and you can derive new ones
whenever you wish.  This section shows you how, using the example
of @{thm[source]nat_less_induct}. Assume we only have structural induction
available for \<^typ>\<open>nat\<close> and want to derive complete induction.  We
must generalize the statement as shown:
\<close>

lemma induct_lem: "(\<And>n::nat. \<forall>m<n. P m \<Longrightarrow> P n) \<Longrightarrow> \<forall>m<n. P m"
apply(induct_tac n)

txt\<open>\noindent
The base case is vacuously true. For the induction step (\<^prop>\<open>m <
Suc n\<close>) we distinguish two cases: case \<^prop>\<open>m < n\<close> is true by induction
hypothesis and case \<^prop>\<open>m = n\<close> follows from the assumption, again using
the induction hypothesis:
\<close>
 apply(blast)
by(blast elim: less_SucE)

text\<open>\noindent
The elimination rule @{thm[source]less_SucE} expresses the case distinction:
@{thm[display]"less_SucE"[no_vars]}

Now it is straightforward to derive the original version of
@{thm[source]nat_less_induct} by manipulating the conclusion of the above
lemma: instantiate \<^term>\<open>n\<close> by \<^term>\<open>Suc n\<close> and \<^term>\<open>m\<close> by \<^term>\<open>n\<close>
and remove the trivial condition \<^prop>\<open>n < Suc n\<close>. Fortunately, this
happens automatically when we add the lemma as a new premise to the
desired goal:
\<close>

theorem nat_less_induct: "(\<And>n::nat. \<forall>m<n. P m \<Longrightarrow> P n) \<Longrightarrow> P n"
by(insert induct_lem, blast)

text\<open>
HOL already provides the mother of
all inductions, well-founded induction (see \S\ref{sec:Well-founded}).  For
example theorem @{thm[source]nat_less_induct} is
a special case of @{thm[source]wf_induct} where \<^term>\<open>r\<close> is \<open><\<close> on
\<^typ>\<open>nat\<close>. The details can be found in theory \isa{Wellfounded_Recursion}.
\<close>
(*<*)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.*)
  theory TIP_list_weird_concat_map_bind
imports "../../Test_Base"
begin

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

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

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

(*fun did not finish the proof*)
function weirdconcat :: "('a list) list => 'a list" where
"weirdconcat (nil2) = nil2"
| "weirdconcat (cons2 (nil2) xss) = weirdconcat xss"
| "weirdconcat (cons2 (cons2 z2 xs) xss) =
     cons2 z2 (weirdconcat (cons2 xs xss))"
by pat_completeness auto

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y2 xs) = cons2 (f y2) (map f xs)"

theorem property0 :
  "((weirdconcat (map f xs)) = (y xs f))"
  oops

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_nat_acc_alt_mul_assoc
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((accaltmul x (accaltmul y z)) = (accaltmul (accaltmul x y) z))"
  oops

end