theory Leadsto
  imports Liveness_Subsumption Unified_PW TA_Library.CTL
begin

context Subsumption_Graph_Pre_Nodes
begin

context
  assumes finite_V: "finite {x. V x}"
begin

  (* XXX Duplication *)
lemma steps_cycle_mono:
  assumes "G'.steps (x # ws @ y # xs @ [y])" "x \<preceq> x'" "V x" "V x'"
  shows "\<exists> y' xs' ys'. y \<preceq> y' \<and> G'.steps (x' # xs' @ y' # ys' @ [y'])"
proof -
  let ?n  = "card {x. V x} + 1"
  let ?xs = "y # concat (replicate ?n (xs @ [y]))"
  from assms(1) have "G'.steps (x # ws @ [y])" "G'.steps (y # xs @ [y])"
    by (auto intro: Graph_Start_Defs.graphI_aggressive2)
  with G'.steps_replicate[of "y # xs @ [y]" ?n] have "G'.steps ?xs"
    by auto
  from steps_mono[OF \<open>G'.steps (x # ws @ [y])\<close> \<open>x \<preceq> x'\<close> \<open>V x\<close> \<open>V x'\<close>] obtain ys where
    "G'.steps (x' # ys)" "list_all2 (\<preceq>) (ws @ [y]) ys"
    by auto
  then obtain y' ws' where "G'.steps (x' # ws' @ [y'])" "y \<preceq> y'"
    unfolding list_all2_append1 list_all2_Cons1 by auto
  with \<open>G'.steps (x # ws @ [y])\<close> have "V y" "V y'"
    subgoal
      using G'_steps_V_last assms(3) by fastforce
    using G'_steps_V_last \<open>G'.steps (x' # ws' @ [y'])\<close> assms(4) by fastforce
  with steps_mono[OF \<open>G'.steps ?xs\<close> \<open>y \<preceq> y'\<close>] obtain ys where ys:
    "list_all2 (\<preceq>) (concat (replicate ?n (xs @ [y]))) ys" "G'.steps (y' # ys)"
    by auto
  let ?ys = "filter ((\<preceq>) y) ys"
  have "length ?ys \<ge> ?n"
    using list_all2_replicate_elem_filter[OF ys(1), of y]
    by auto
  have "set ?ys \<subseteq> set ys"
    by auto
  also have "\<dots> \<subseteq> {x. V x}"
    using \<open>G'.steps (y' # _)\<close> \<open>V y'\<close> by (auto simp: list_all_iff dest: G'_steps_V_all)
  finally have "\<not> distinct ?ys"
    using distinct_card[of ?ys] \<open>_ >= ?n\<close>
    by - (rule ccontr; drule distinct_length_le[OF finite_V]; simp)
  from not_distinct_decomp[OF this] obtain as y'' bs cs where "?ys = as @ [y''] @ bs @ [y''] @ cs"
    by auto
  then obtain as' bs' cs' where
    "ys = as' @ [y''] @ bs' @ [y''] @ cs'"
    apply atomize_elim
    apply simp
    apply (drule filter_eq_appendD filter_eq_ConsD filter_eq_appendD[OF sym], clarify)+
    apply clarsimp
    subgoal for as1 as2 bs1 bs2 cs'
      by (inst_existentials "as1 @ as2" "bs1 @ bs2") simp
    done
  from \<open>G'.steps (y' # _)\<close> have "G'.steps (y' # as' @ y'' # bs' @ [y''])"
    unfolding \<open>ys = _\<close> by (force intro: Graph_Start_Defs.graphI_aggressive2)
  moreover from \<open>?ys = _\<close> have "y \<preceq> y''"
  proof -
    from \<open>?ys = _\<close> have "y'' \<in> set ?ys" by auto
    then show ?thesis by auto
  qed
  ultimately show ?thesis
    using \<open>G'.steps (x' # ws' @ [y'])\<close>
    by (inst_existentials y'' "ws' @ y' # as'" bs';
        fastforce intro: Graph_Start_Defs.graphI_aggressive1
        )
qed

lemma reaches_cycle_mono:
  assumes "G'.reaches x y" "y \<rightarrow>\<^sup>+ y" "x \<preceq> x'" "V x" "V x'"
  shows "\<exists> y'. y \<preceq> y' \<and> G'.reaches x' y' \<and> y' \<rightarrow>\<^sup>+ y'"
proof -
  from assms obtain xs ys where "G'.steps (x # xs)" "y = last (x # xs)" "G'.steps (y # ys @ [y])"
    apply atomize_elim
    including reaches_steps_iff
    apply safe
    subgoal for xs xs'
      by (inst_existentials "tl xs" xs') auto
    done
  then obtain ws where "G'.steps (x # ws @ y # ys @ [y])"
    apply atomize_elim
    apply (cases xs)
     apply (inst_existentials ys)
     apply simp
      apply rotate_tac
     apply (rule G'.steps_append', assumption+, simp+)
    apply auto
     apply (inst_existentials "[] :: 'a list")
     apply (auto dest: G'.steps_append; fail)
    apply (drule G'.steps_append)
      apply assumption
     apply simp
    apply simp
    proof -
      fix a :: 'a and list :: "'a list"
      assume a1: "G'.steps (x # a # list @ ys @ [last list])"
      assume "list \<noteq> []"
      then have "butlast (a # list) @ [last list] = a # list"
        by (metis (no_types) append_butlast_last_id last_ConsR list.simps(3))
      then show "\<exists>as. G'.steps (x # as @ last list # ys @ [last list])"
        using a1 by (metis (no_types) Cons_eq_appendI append.assoc self_append_conv2)
    qed
    from steps_cycle_mono[OF this \<open>x \<preceq> x'\<close> \<open>V x\<close> \<open>V x'\<close>] guess y' xs' ys' by safe
    then have "G'.steps (x' # xs' @ [y'])" "G'.steps (y' # ys' @ [y'])"
      by (force intro: Graph_Start_Defs.graphI_aggressive2)+
    with \<open>y \<preceq> y'\<close> show ?thesis
      including reaches_steps_iff by force
  qed

end (* Finite subgraph *)

end (* Subsumption Graph Pre Nodes *)

locale Leadsto_Search_Space =
  A: Search_Space'_finite E a\<^sub>0 _ "(\<preceq>)" empty
  for E a\<^sub>0 empty and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
  +
  fixes P Q :: "'a \<Rightarrow> bool"
  assumes P_mono: "a \<preceq> a' \<Longrightarrow> \<not> empty a \<Longrightarrow> P a \<Longrightarrow> P a'"
  assumes Q_mono: "a \<preceq> a' \<Longrightarrow> \<not> empty a \<Longrightarrow> Q a \<Longrightarrow> Q a'"
  fixes succs_Q :: "'a \<Rightarrow> 'a list"
  assumes succs_Q_correct: "A.reachable a \<Longrightarrow> set (succs_Q a) = {y. E a y \<and> Q y \<and> \<not> empty y}"
begin

sublocale A': Search_Space'_finite E a\<^sub>0 "\<lambda> _. False" "(\<preceq>)" empty
  apply standard
          apply (rule A.refl A.trans A.mono A.empty_subsumes A.empty_mono A.empty_E; assumption)+
    apply assumption
   apply blast
  apply (rule A.finite_reachable)
  done

sublocale B:
  Liveness_Search_Space
  "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" a\<^sub>0 "\<lambda> _. False" "(\<preceq>)" "\<lambda> x. A.reachable x \<and> \<not> empty x"
  succs_Q
  apply standard
       apply (rule A.refl A.trans; assumption)+
  subgoal for a b a'
    by safe (drule A.mono; auto intro: Q_mono dest: A.mono A.empty_mono)
    apply blast
   apply (auto intro: A.finite_reachable; fail)
  subgoal
    apply (subst succs_Q_correct)
    unfolding Subgraph_Node_Defs.E'_def by auto
  done

context
  fixes a\<^sub>1 :: 'a
begin

interpretation B':
  Liveness_Search_Space
  "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" a\<^sub>1 "\<lambda> _. False" "(\<preceq>)" "\<lambda> x. A.reachable x \<and> \<not> empty x" succs_Q
  by standard

definition has_cycle where
  "has_cycle = B'.dfs"

end (* Second start state *)

definition leadsto :: "bool nres" where
  "leadsto = do {
    (r, passed) \<leftarrow> A'.pw_algo;
    let P = {x. x \<in> passed \<and> P x \<and> Q x};
    (r, _) \<leftarrow>
              FOREACH\<^sub>C P (\<lambda>(b,_). \<not>b) (\<lambda>v' (_,P). has_cycle v' P) (False,{});
    RETURN r
  }"

definition
  "reaches_cycle a =
    (\<exists> b. (\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y)\<^sup>*\<^sup>* a b \<and> (\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y)\<^sup>+\<^sup>+ b b)"

definition leadsto_spec where
  "leadsto_spec = SPEC (\<lambda> r. r \<longleftrightarrow> (\<exists> a. A.reachable a \<and> \<not> empty a \<and> P a \<and> Q a \<and> reaches_cycle a))"

lemma
  "leadsto \<le> leadsto_spec"
proof -
  define inv where
    "inv \<equiv> \<lambda> passed it (r, passed').
       (r \<longrightarrow> (\<exists> a. A.reachable a \<and> \<not> empty a \<and> P a \<and> Q a \<and> reaches_cycle a))
     \<and> (\<not> r \<longrightarrow>
          (\<forall> a \<in> passed - it. \<not> reaches_cycle a)
         \<and> B.liveness_compatible passed'
         \<and> passed' \<subseteq> {x. A.reachable x \<and> \<not> empty x}
       )
    "

  have [simp, intro]:
    "\<not> A'.F_reachable"
    unfolding A'.F_reachable_def by simp

  have B_reaches_empty:
    "\<not> empty b" if "\<not> empty a" "B.reaches a b" for a b
    using that(2,1)by induction auto

  interpret Subgraph_Start E a\<^sub>0 "\<lambda> a x. E a x \<and> Q x \<and> \<not> empty x"
    by standard auto

  have B_A_reaches:
    "A.reaches a b" if "B.reaches a b" for a b
    using that by (rule reaches)

  have reaches_iff: "B.reaches a x \<longleftrightarrow> B.G.G'.reaches a x"
    if "A.reachable a" "\<not> empty a" for a x
    unfolding reaches_cycle_def thm B.G.E'_def
    apply standard
    using that
      apply (rotate_tac 3)
     apply (induction rule: rtranclp.induct)
      apply blast
     apply rule
      apply assumption
     apply (subst B.G.E'_def)
    subgoal for a b c
      by (auto dest: B_reaches_empty)
    subgoal
      by (rule B.G.reaches)
    done

  have reaches1_iff: "B.reaches1 a x \<longleftrightarrow> B.G.G'.reaches1 a x"
    if "A.reachable a" "\<not> empty a" for a x
    unfolding reaches_cycle_def
    apply standard
    subgoal
      using that
        apply (rotate_tac 3)
      apply (induction rule: tranclp.induct)
       apply (rule tranclp.intros(1), auto simp: B.G.E'_def; fail)
      apply (
          rule tranclp.intros(2);
          auto 4 3 simp: B.G.E'_def dest:B_reaches_empty tranclp_into_rtranclp
          )
      done
    subgoal
      by (rule B.G.reaches1)
    done

  have reaches_cycle_iff: "reaches_cycle a \<longleftrightarrow> (\<exists>x. B.G.G'.reaches a x \<and> B.G.G'.reaches1 x x)"
    if "A.reachable a" "\<not> empty a" for a
    unfolding reaches_cycle_def
    apply (subst reaches_iff[OF that])
    using reaches1_iff B.G.G'_reaches_V that by blast

  have aux1:
    "\<not> reaches_cycle x"
    if
      "\<forall>a. A.reachable a \<and> \<not> empty a \<longrightarrow> (\<exists>x\<in>passed. a \<preceq> x)"
      "passed \<subseteq> {a. A.reachable a \<and> \<not> empty a}"
      "\<forall>x \<in> passed. P x \<and> Q x \<longrightarrow> \<not> reaches_cycle x"
      "A.reachable x" "\<not> empty x" "P x" "Q x"
    for x passed
  proof (rule ccontr, simp)
    assume "reaches_cycle x"
    from that obtain x' where "x' \<in> passed" "x \<preceq> x'"
      by auto
    with that have "P x'" "Q x'"
      by (auto intro: P_mono Q_mono)
    with \<open>x' \<in> passed\<close> that(3) have "\<not> reaches_cycle x'"
      by auto
    have "A.reachable x'" "\<not> empty x'"
      using \<open>x' \<in> passed\<close> that(2) A.empty_mono \<open>x \<preceq> x'\<close> that(5) by auto
    note reaches_cycle_iff' = reaches_cycle_iff[OF this] reaches_iff[OF this] reaches1_iff[OF this]
    from \<open>reaches_cycle x\<close> guess y unfolding reaches_cycle_def
      by safe
    interpret
      Subsumption_Graph_Pre_Nodes
        "(\<preceq>)" A.subsumes_strictly "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y"
        "\<lambda> x. A.reachable x \<and> \<not> empty x"
      by standard (rule B.mono[simplified]; assumption)
    from \<open>B.reaches x y\<close> \<open>x \<preceq> x'\<close> \<open>B.reaches1 y y\<close> reaches_cycle_mono[OF B.finite_V] obtain y' where
      "y \<preceq> y'" "B.G.G'.reaches x' y'" "B.G.G'.reaches1 y' y'"
      apply atomize_elim
      apply (subst (asm) reaches_iff[rotated 2])
        defer
        defer
        apply (subst (asm) reaches1_iff)
          defer
          defer
      using \<open>A.reachable x\<close> \<open>\<not> empty x\<close> \<open>A.reachable x'\<close> \<open>\<not> empty x'\<close> \<open>B.reaches1 y y\<close>
      by (auto simp: B.reaches1_reaches_iff2 dest!: B.G.G'_reaches_V)
    with \<open>A.reachable x'\<close> \<open>\<not> empty x'\<close> have "reaches_cycle x'"
      unfolding reaches_cycle_iff'
      by auto
    with \<open>\<not> reaches_cycle x'\<close> show False ..
  qed

  show ?thesis
    unfolding leadsto_def leadsto_spec_def
    apply (refine_rcg refine_vcg)
      subgoal for _ r passed
      apply (refine_vcg
            FOREACHc_rule'[where I = "inv {x \<in> passed. P x \<and> Q x}"]
            )

      (* Result of first reachability computation is finite *)
      subgoal
        by (auto intro: finite_subset[OF _ A.finite_reachable])

      (* Invariant holds initially *)
      subgoal
        unfolding inv_def B.liveness_compatible_def by auto

      (* Invariant is preserved *)
      subgoal for a\<^sub>1 it \<sigma> a passed'
        apply clarsimp
          subgoal premises prems
          proof -
            interpret B':
              Liveness_Search_Space
              "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" a\<^sub>1 "\<lambda> _. False" "(\<preceq>)"
              "\<lambda> x. A.reachable x \<and> \<not> empty x" succs_Q
              by standard
            from \<open>inv _ _ _\<close> have
              "B'.liveness_compatible passed'" "passed' \<subseteq> {x. A.reachable x \<and> \<not> empty x}"
              unfolding inv_def by auto
            from B'.dfs_correct[OF _ this] \<open>passed \<subseteq> _\<close> \<open>a\<^sub>1 \<in> _\<close> \<open>it \<subseteq> _\<close> have
              "B'.dfs passed' \<le> B'.dfs_spec"
              by auto
            then show ?thesis
              unfolding has_cycle_def
              apply (rule order.trans)
              unfolding B'.dfs_spec_def
              apply clarsimp
              subgoal for r passed'
                apply (cases r)
                 apply simp
                subgoal
                  unfolding inv_def
                  using \<open>passed \<subseteq> _\<close> \<open>a\<^sub>1 \<in> _\<close> \<open>it \<subseteq> _\<close>
                  apply simp
                    apply (inst_existentials a\<^sub>1)
                  by (auto 4 3 simp: reaches_cycle_iff)
                  subgoal
                    using \<open>inv _ _ _\<close> \<open>passed \<subseteq> _\<close> reaches_cycle_iff unfolding inv_def by blast
                  done
                done
            qed
            done

          (* I \<and> \<not> b \<longrightarrow> post *)
          subgoal for \<sigma> a b
            unfolding inv_def by (auto dest!: aux1)

          (* I \<and> b \<longrightarrow> post *)
          subgoal for it \<sigma> a b
            unfolding inv_def by auto
          done
        done
    qed

definition leadsto_spec_alt where
  "leadsto_spec_alt =
    SPEC (\<lambda> r.
      r \<longleftrightarrow>
      (\<exists> a. (\<lambda> x y. E x y \<and> \<not> empty y)\<^sup>*\<^sup>* a\<^sub>0 a \<and> \<not> empty a \<and> P a \<and> Q a \<and> reaches_cycle a)
    )"

lemma E_reaches_non_empty:
  "(\<lambda> x y. E x y \<and> \<not> empty y)\<^sup>*\<^sup>* a b" if "a \<rightarrow>* b" "A.reachable a" "\<not> empty b" for a b
  using that
proof induction
  case base
  then show ?case by blast
next
  case (step y z)
  from \<open>a \<rightarrow>* y\<close> \<open>A.reachable a\<close> have "A.reachable y"
    by - (rule A.reachable_reaches)
  have "\<not> empty y"
  proof (rule ccontr, simp)
    assume "empty y"
    from A.empty_E[OF \<open>A.reachable y\<close> \<open>empty y\<close> \<open>E y z\<close>] \<open>\<not> empty z\<close> show False by blast
  qed
  with step show ?case
    by (auto intro: rtranclp.intros(2))
qed

lemma leadsto_spec_leadsto_spec_alt:
  "leadsto_spec \<le> leadsto_spec_alt"
  unfolding leadsto_spec_def leadsto_spec_alt_def
  by (auto
      intro: Subgraph.intro Subgraph.reaches[rotated] E_reaches_non_empty[OF _ A.start_reachable]
      simp: A.reachable_def
     )

end (* Leadsto Search Space *)

end (* Theory *)


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2008  Slawomir Kolodynski

    This program is free software Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES LOSS OF USE, DATA, OR PROFITS OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Partitions of sets\<close>

theory Partitions_ZF imports Finite_ZF FiniteSeq_ZF

begin

text\<open>It is a common trick in proofs that we divide a set into non-overlapping
  subsets. The first case is when we split the set into
  two nonempty disjoint sets. Here this is modeled as an ordered pair of sets
  and the set of such divisions of set $X$ is called \<open>Bisections(X)\<close>.
  The second variation on this theme is a set-valued function (aren't they all
  in ZF?) whose values are nonempty and mutually disjoint.
\<close>

subsection\<open>Bisections\<close>

text\<open>This section is about dividing sets into two non-overlapping subsets.
\<close>

text\<open>The set of bisections of a given set $A$ is a set of pairs of nonempty
  subsets of $A$ that do not overlap and their union is equal to $A$.\<close>

definition
  "Bisections(X) = {p \<in> Pow(X)\<times>Pow(X).
  fst(p)\<noteq>0 \<and> snd(p)\<noteq>0 \<and> fst(p)\<inter>snd(p) = 0 \<and> fst(p)\<union>snd(p) = X}"

text\<open>Properties of bisections.\<close>

lemma bisec_props: assumes "\<langle>A,B\<rangle> \<in> Bisections(X)" shows
  "A\<noteq>0"  "B\<noteq>0" "A \<subseteq> X"  "B \<subseteq> X"  "A \<inter> B = 0"  "A \<union> B = X"  "X \<noteq> 0"
  using assms Bisections_def by auto

text\<open>Kind of inverse of \<open>bisec_props\<close>: a pair of nonempty
  disjoint sets form a bisection of their union.\<close>

lemma is_bisec:
  assumes "A\<noteq>0"  "B\<noteq>0"  "A \<inter> B = 0"
  shows "\<langle>A,B\<rangle> \<in> Bisections(A\<union>B)" using assms Bisections_def
  by auto

text\<open>Bisection of $X$ is a pair of subsets of $X$.\<close>

lemma bisec_is_pair: assumes "Q \<in> Bisections(X)"
  shows "Q = \<langle>fst(Q), snd(Q)\<rangle>"
  using assms Bisections_def by auto

text\<open>The set of bisections of the empty set is empty.\<close>

lemma bisec_empty: shows "Bisections(0) = 0"
  using Bisections_def by auto

text\<open>The next lemma shows what can we say about bisections of a set
  with another element added.\<close>

lemma bisec_add_point:
  assumes A1: "x \<notin> X" and A2: "\<langle>A,B\<rangle> \<in> Bisections(X \<union> {x})"
  shows "(A = {x} \<or> B = {x}) \<or> (\<langle>A - {x}, B - {x}\<rangle> \<in> Bisections(X))"
  proof -
    { assume "A \<noteq> {x}" and "B \<noteq> {x}"
      with A2 have "A - {x} \<noteq> 0" and "B - {x} \<noteq> 0"
	using singl_diff_empty Bisections_def
	by auto
      moreover have "(A - {x}) \<union> (B - {x}) = X"
      proof -
	have "(A - {x}) \<union> (B - {x}) = (A \<union> B) - {x}"
	  by auto
	also from assms have "(A \<union> B) - {x} = X"
	  using Bisections_def by auto
	finally show ?thesis by simp
      qed
      moreover from A2 have "(A - {x}) \<inter> (B - {x}) = 0"
	using Bisections_def by auto
      ultimately have "\<langle>A - {x}, B - {x}\<rangle> \<in> Bisections(X)"
	using Bisections_def by auto
    } thus ?thesis by auto
qed

text\<open>A continuation of the lemma \<open>bisec_add_point\<close>
  that refines the case when the pair with removed point bisects
  the original set.\<close>

lemma bisec_add_point_case3:
  assumes A1: "\<langle>A,B\<rangle> \<in> Bisections(X \<union> {x})"
  and A2: "\<langle>A - {x}, B - {x}\<rangle> \<in> Bisections(X)"
  shows
  "(\<langle>A, B - {x}\<rangle> \<in> Bisections(X) \<and> x \<in> B) \<or>
  (\<langle>A - {x}, B\<rangle> \<in> Bisections(X) \<and> x \<in> A)"
proof -
  from A1 have "x \<in> A \<union> B"
    using Bisections_def by auto
  hence "x\<in>A \<or> x\<in>B" by simp
  from A1 have "A - {x} = A \<or> B - {x} = B"
    using Bisections_def by auto
  moreover
  { assume "A - {x} = A"
    with A2 \<open>x \<in> A \<union> B\<close> have
      "\<langle>A, B - {x}\<rangle> \<in> Bisections(X) \<and> x \<in> B"
      using singl_diff_eq by simp }
  moreover
  { assume "B - {x} = B"
    with A2 \<open>x \<in> A \<union> B\<close> have
      "\<langle>A - {x}, B\<rangle> \<in> Bisections(X) \<and> x \<in> A"
      using singl_diff_eq by simp }
  ultimately show ?thesis by auto
qed

text\<open>Another lemma about bisecting a set with an added point.\<close>

lemma point_set_bisec:
  assumes A1: "x \<notin> X" and A2: "\<langle>{x}, A\<rangle> \<in> Bisections(X \<union> {x})"
  shows "A = X" and "X \<noteq> 0"
proof -
  from A2 have "A \<subseteq> X" using Bisections_def by auto
  moreover
  { fix a assume "a\<in>X"
    with A2 have "a \<in> {x} \<union> A" using Bisections_def by simp
    with A1 \<open>a\<in>X\<close> have "a \<in> A" by auto }
  ultimately show "A = X" by auto
  with A2 show "X \<noteq> 0" using Bisections_def by simp
qed

text\<open>Yet another lemma about bisecting a set with an added point,
  very similar to \<open> point_set_bisec\<close> with almost the same proof.\<close>

lemma set_point_bisec:
  assumes A1: "x \<notin> X" and A2: "\<langle>A, {x}\<rangle> \<in> Bisections(X \<union> {x})"
  shows "A = X" and "X \<noteq> 0"
proof -
  from A2 have "A \<subseteq> X" using Bisections_def by auto
  moreover
  { fix a assume "a\<in>X"
    with A2 have "a \<in> A \<union> {x}" using Bisections_def by simp
    with A1 \<open>a\<in>X\<close> have "a \<in> A" by auto }
  ultimately show "A = X" by auto
  with A2 show "X \<noteq> 0" using Bisections_def by simp
qed

text\<open>If a pair of sets bisects a finite set, then both
  elements of the pair are finite.\<close>

lemma bisect_fin:
  assumes A1: "A \<in> FinPow(X)" and A2: "Q \<in> Bisections(A)"
  shows "fst(Q) \<in> FinPow(X)" and "snd(Q) \<in> FinPow(X)"
proof -
  from A2 have "\<langle>fst(Q), snd(Q)\<rangle> \<in> Bisections(A)"
    using bisec_is_pair by simp
  then have "fst(Q) \<subseteq> A" and "snd(Q) \<subseteq> A"
    using bisec_props by auto
  with A1 show "fst(Q) \<in> FinPow(X)" and "snd(Q) \<in> FinPow(X)"
    using FinPow_def subset_Finite by auto
qed

subsection\<open>Partitions\<close>

text\<open>This sections covers the situation when we have an arbitrary number
  of sets we want to partition into.\<close>

text\<open>We define a notion of a partition as a set valued function
  such that the values for different arguments are disjoint.
  The name is derived from the fact that such
  function "partitions" the union of its arguments.
  Please let me know if you have
  a better idea for a name for such notion. We would prefer to say
 ''is a partition'', but that reserves the letter ''a'' as a keyword(?)
  which causes problems.\<close>

definition
  Partition ("_ {is partition}" [90] 91) where
  "P {is partition} \<equiv>  \<forall>x \<in> domain(P).
  P`(x) \<noteq> 0 \<and> (\<forall>y \<in> domain(P). x\<noteq>y \<longrightarrow> P`(x) \<inter> P`(y) = 0)"

text\<open>A fact about lists of mutually disjoint sets.\<close>

lemma list_partition: assumes A1: "n \<in> nat" and
  A2: "a : succ(n) \<rightarrow> X"   "a {is partition}"
  shows "(\<Union>i\<in>n. a`(i)) \<inter> a`(n) = 0"
proof -
  { assume "(\<Union>i\<in>n. a`(i)) \<inter> a`(n) \<noteq> 0"
    then have "\<exists>x. x \<in> (\<Union>i\<in>n. a`(i)) \<inter> a`(n)"
      by (rule nonempty_has_element)
    then obtain x where "x \<in> (\<Union>i\<in>n. a`(i))" and  I: "x \<in> a`(n)"
      by auto
    then obtain i where "i \<in> n" and "x \<in> a`(i)" by auto
    with A2 I have False
      using mem_imp_not_eq func1_1_L1 Partition_def
      by auto
  } thus ?thesis by auto
qed

text\<open>We can turn every injection into a partition.\<close>

lemma inj_partition:
  assumes A1: "b \<in> inj(X,Y)"
  shows
  "\<forall>x \<in> X. {\<langle>x, {b`(x)}\<rangle>. x \<in> X}`(x) = {b`(x)}" and
  "{\<langle>x, {b`(x)}\<rangle>. x \<in> X} {is partition}"
proof -
  let ?p = "{\<langle>x, {b`(x)}\<rangle>. x \<in> X}"
  { fix x assume "x \<in> X"
    from A1 have "b : X \<rightarrow> Y" using inj_def
      by simp
    with \<open>x \<in> X\<close> have "{b`(x)} \<in> Pow(Y)"
       using apply_funtype by simp
  } hence "\<forall>x \<in> X. {b`(x)} \<in> Pow(Y)" by simp
  then have "?p : X \<rightarrow> Pow(Y)" using ZF_fun_from_total
    by simp
  then have "domain(?p) = X" using func1_1_L1
    by simp
  from \<open>?p : X \<rightarrow> Pow(Y)\<close> show I: "\<forall>x \<in> X. ?p`(x) = {b`(x)}"
    using ZF_fun_from_tot_val0 by simp
  { fix x assume "x \<in> X"
    with I have "?p`(x) = {b`(x)}" by simp
    hence "?p`(x) \<noteq> 0" by simp
    moreover
    { fix t assume "t \<in> X" and "x \<noteq> t"
      with A1 \<open>x \<in> X\<close> have "b`(x) \<noteq> b`(t)" using inj_def
	by auto
      with I \<open>x\<in>X\<close> \<open>t \<in> X\<close> have "?p`(x) \<inter> ?p`(t) = 0"
	by auto }
    ultimately have
      "?p`(x) \<noteq> 0 \<and> (\<forall>t \<in> X. x\<noteq>t \<longrightarrow> ?p`(x) \<inter> ?p`(t) = 0)"
      by simp
  } with \<open>domain(?p) = X\<close> show "{\<langle>x, {b`(x)}\<rangle>. x \<in> X} {is partition}"
    using Partition_def by simp
qed

end


(*  Title:       A General Method for the Proof of Theorems on Tail-recursive Functions
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "Method rationale"

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

text \<open>
Tail-recursive function definitions are sometimes more intuitive and
straightforward than alternatives, and this alone would be enough to make them
preferable in such cases for the mere purposes of functional programming. However,
proving theorems about them with a formal proof assistant like Isabelle may be
roundabout because of the peculiar form of the resulting recursion induction
rules.

Let:

\begin{itemize}

\item
\<open>f_naive\<close> be a tail-recursive function of type
\<open>'a\<^sub>1 \<Rightarrow> ... \<Rightarrow> 'a\<^sub>n \<Rightarrow> 'b\<close>.

\item
\<open>a\<close> be an \<open>n\<close>-tuple of values of types \<open>'a\<^sub>1\<close>, ...,
\<open>'a\<^sub>n\<close> such that the computation of \<open>f_naive a\<close>, say outputting
value \<open>b\<close>, involves at least one recursive call -- which is what happens in
general for significant inputs (e.g. those complying with initial conditions for
accumulator arguments), as otherwise a non-recursive function definition would be
sufficient.

\item
\<open>a\<^sub>1\<close>, ..., \<open>a\<^sub>m\<close> be the sequence of the intermediate
\<open>n\<close>-tuples of values of types \<open>'a\<^sub>1\<close>, ..., \<open>'a\<^sub>n\<close> arising from
the computation of \<open>f_naive a\<close>.

\item
\<open>f_naive X\<^sub>1 = f_naive X'\<^sub>1\<close>, ..., \<open>f_naive X\<^sub>m = f_naive X'\<^sub>m\<close>,
\<open>f_naive X = Y\<close> be the sequence (possibly with repetitions) of the
equations involved in the computation of \<open>f_naive a\<close> -- which implies
that, putting \<open>a\<^sub>0 = a\<close>, they are satisfied for
\<open>(X\<^sub>1, X'\<^sub>1) = (a\<^sub>0, a\<^sub>1)\<close>, ..., \<open>(X\<^sub>m, X'\<^sub>m) = (a\<^sub>m\<^sub>-\<^sub>1, a\<^sub>m)\<close>,
\<open>(X, Y) = (a\<^sub>m, b)\<close>, respectively.

\end{itemize}

That being stated, suppose that theorem \<open>P (f_naive a)\<close> has to be proven.
If recursion induction is applied to such goal, for each \<open>i \<in> {1..m}\<close>,
the recursive equation \<open>f_naive X\<^sub>i = f_naive X'\<^sub>i\<close> gives rise to subgoal
\<open>P (f_naive X'\<^sub>i) \<Longrightarrow> P (f_naive X\<^sub>i)\<close>, trivially discharged by
simplification. On the contrary, the non-recursive equation
\<open>f_naive X = Y\<close> brings about the generation of subgoal
\<open>P (f_naive X)\<close>, which is intractable unless it trivially follows from
either the equation or the form of pattern \<open>X\<close>.

Indeed, in non-trivial cases such as the case studies examined in this paper, this
formula even fails to be a theorem, thus being hopeless as a goal, since it is
false for some values of its variables. The reason for this is that non-trivial
properties of the output of tail-recursive functions depend on the input as well
as on the whole recursive call pipeline leading from the input to the output, and
all of this information corresponds to missing necessary assumptions in subgoal
\<open>P (f_naive X)\<close>.

Therefore, for a non-trivial theorem \<open>P (f_naive a)\<close>, recursion induction
is rather applicable to some true conditional statement
\<open>f_inv x \<longrightarrow> P (f_naive x)\<close> complying with both of the following
requirements:

\begin{itemize}

\item
subgoal \<open>f_inv X \<longrightarrow> P (f_naive X)\<close> arising from equation
\<open>f_naive X = Y\<close> be tractable, and

\item
formula \<open>f_inv a\<close> can be shown to be true, so that theorem
\<open>P (f_naive a)\<close> can be inferred from conditional
\<open>f_inv a \<longrightarrow> P (f_naive a)\<close> by \emph{modus ponens}.

\end{itemize}

Observe that the antecedent of the conditional may not have the form
\<open>f_inv (f_naive x)\<close>. Otherwise, the latter requirement would ask for
proving formula \<open>f_inv (f_naive a)\<close>, which would be at least as hard to
prove as formula \<open>P (f_naive a)\<close> being the former a sufficient condition
for the latter. Hence, the same problem as that originating from the proof of
formula \<open>P (f_naive a)\<close> would have to be solved again, which would give
rise to a \emph{regressio ad infinitum}.

The latter requirement entails that formula \<open>f_inv a\<^sub>0\<close> holds. Moreover,
for each \<open>i \<in> {1..m}\<close>, in the proof of conditional
\<open>f_inv x \<longrightarrow> P (f_naive x)\<close> by recursion induction, the recursive equation
\<open>f_naive X\<^sub>i = f_naive X'\<^sub>i\<close> brings about the generation of subgoal
\<open>f_inv X'\<^sub>i \<longrightarrow> P (f_naive X'\<^sub>i) \<Longrightarrow> f_inv X\<^sub>i \<longrightarrow> P (f_naive X\<^sub>i)\<close>. Assuming
that formula \<open>f_inv a\<^sub>i\<^sub>-\<^sub>1\<close> holds, it turns out that the conclusion
antecedent \<open>f_inv X\<^sub>i\<close> may not be shown to be false, as \<open>n\<close>-tuple
\<open>a\<^sub>i\<^sub>-\<^sub>1\<close> matches pattern \<open>X\<^sub>i\<close>; thus, the conclusion consequent
\<open>P (f_naive X\<^sub>i)\<close> has to be proven.

In non-trivial cases, this requires that the assumption antecedent
\<open>f_inv X'\<^sub>i\<close> be derived from the conclusion antecedent \<open>f_inv X\<^sub>i\<close>
used as a further assumption, so that the assumption consequent
\<open>P (f_naive X'\<^sub>i)\<close> -- matching \<open>P (f_naive X\<^sub>i)\<close> by virtue of
equation \<open>f_naive X\<^sub>i = f_naive X'\<^sub>i\<close> -- can be proven by
\emph{modus ponens}. This in turn requires that \<open>f_inv X\<^sub>i\<close> imply
\<open>f_inv X'\<^sub>i\<close>, i.e. that \<open>f_inv x\<^sub>i\<close> imply \<open>f_inv x'\<^sub>i\<close> for any
pair of \<open>n\<close>-tuples \<open>x\<^sub>i\<close>, \<open>x'\<^sub>i\<close> matching patterns \<open>X\<^sub>i\<close>,
\<open>X'\<^sub>i\<close> with respect to the same value assignment. But such are
\<open>n\<close>-tuples \<open>a\<^sub>i\<^sub>-\<^sub>1\<close>, \<open>a\<^sub>i\<close> as they solve equation
\<open>f_naive X\<^sub>i = f_naive X'\<^sub>i\<close>, so that the supposed truth of
\<open>f_inv a\<^sub>i\<^sub>-\<^sub>1\<close> entails that of \<open>f_inv a\<^sub>i\<close>.

Hence, by induction, all of formulae \<open>f_inv a\<close>, \<open>f_inv a\<^sub>1\<close>, ...,
\<open>f_inv a\<^sub>m\<close> turn out to be true. On the other hand, the former requirement
is verified if either the antecedent \<open>f_inv X\<close> can be shown to be false,
which would entail its falsity for any \<open>n\<close>-tuple matching pattern \<open>X\<close>,
or else the consequent \<open>P (f_naive X)\<close> can be shown to be true using the
antecedent as an assumption. Since formula \<open>f_inv a\<^sub>m\<close> is true and
\<open>n\<close>-tuple \<open>a\<^sub>m\<close> matches pattern \<open>X\<close>, the case that actually
occurs is the second one.

Thus, the former requirement is equivalent to asking for an introduction rule to
be proven -- in fact, a conditional with a contradiction as antecedent may not be
used as an introduction rule -- having the form
\<open>f_inv X \<Longrightarrow> P (f_naive X)\<close>, or rather
\<open>\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_naive x)\<close> for a suitable predicate
\<open>f_form\<close> satisfied by any \<open>n\<close>-tuple matching pattern \<open>X\<close>. In
the degenerate case in which the rule can be shown to be true for
\<open>f_form = (\<lambda>x. True)\<close>, it admits to be put into the simpler equivalent
form \<open>f_inv x \<Longrightarrow> P (f_naive x)\<close>.

An even more important consequence of the previous argument is that in non-trivial
cases, the task of proving conditional \<open>f_inv x \<longrightarrow> P (f_naive x)\<close> by
recursion induction requires that \<open>f_inv X'\<^sub>i\<close> be derived from
\<open>f_inv X\<^sub>i\<close> for each recursive equation \<open>f_naive X\<^sub>i = f_naive X'\<^sub>i\<close>,
where \<open>i \<in> {1..m}\<close>.

Let:

\begin{itemize}

\item
\<open>'a\<close> be the Cartesian product of types \<open>'a\<^sub>1\<close>, ..., \<open>'a\<^sub>n\<close>.

\item
\<open>f_set\<close> be the inductive set of type \<open>'a \<Rightarrow> 'a set\<close> defined by
introduction rules \<open>x \<in> f_set x\<close>,
\<open>X\<^sub>1 \<in> f_set x \<Longrightarrow> X'\<^sub>1 \<in> f_set x\<close>, ...,
\<open>X\<^sub>m \<in> f_set x \<Longrightarrow> X'\<^sub>m \<in> f_set x\<close> -- where patterns \<open>X\<^sub>1\<close>,
\<open>X'\<^sub>1\<close>, ..., \<open>X\<^sub>m\<close>, \<open>X'\<^sub>m\<close> are now viewed as values of type
\<open>'a\<close>.

\end{itemize}

Then, the problem of discharging the above proof obligation on predicate
\<open>f_inv\<close> is at least as hard as that of proving by rule induction
introduction rule \<open>\<lbrakk>y \<in> f_set x; f_inv x\<rbrakk> \<Longrightarrow> f_inv y\<close> -- which states that
for any \<open>x\<close> such that \<open>f_inv x\<close> is true, \<open>f_inv\<close> is an
invariant over inductive set \<open>f_set x\<close>, i.e. \<open>f_inv y\<close> is true for
each \<open>y \<in> f_set x\<close>.

In fact, the application of rule induction to this goal generates subgoals
\<open>f_inv x \<Longrightarrow> f_inv x\<close>,
\<open>\<lbrakk>X\<^sub>1 \<in> f_set x; f_inv X\<^sub>1; f_inv x\<rbrakk> \<Longrightarrow> f_inv X'\<^sub>1\<close>, ...,
\<open>\<lbrakk>X\<^sub>m \<in> f_set x; f_inv X\<^sub>m; f_inv x\<rbrakk> \<Longrightarrow> f_inv X'\<^sub>m\<close>; the first is trivial,
and such would also be the other ones if rules \<open>f_inv X\<^sub>1 \<Longrightarrow> f_inv X'\<^sub>1\<close>,
..., \<open>f_inv X\<^sub>m \<Longrightarrow> f_inv X'\<^sub>m\<close> were available.

Furthermore, suppose that the above invariance property of predicate \<open>f_inv\<close>
have been proven; then, the proof of conditional
\<open>f_inv x \<longrightarrow> P (f_naive x)\<close> by recursion induction can be made unnecessary
by slightly refining the definition of function \<open>f_naive\<close>, as shown in the
continuation.

Let \<open>f_aux\<close> be the tail-recursive function of type \<open>'a \<Rightarrow> 'a\<close> whose
definition is obtained from that of \<open>f_naive\<close> by treating as fixed points
the patterns to which non-recursive equations apply as well as those to which no
equation applies, if any -- i.e. by replacing recursive equation
\<open>f_naive X\<^sub>i = f_naive X'\<^sub>i\<close> with \<open>f_aux X\<^sub>i = f_aux X'\<^sub>i\<close> for each
\<open>i \<in> {1..m}\<close> and non-recursive equation \<open>f_naive X = Y\<close> with
\<open>f_aux X = X\<close>.

Then, define function \<open>f\<close> by means of a non-recursive equation
\<open>f x = f_out (f_aux (f_in x))\<close>, where:

\begin{itemize}

\item
\<open>f_in\<close> is a function of type \<open>'a' \<Rightarrow> 'a\<close>, for a suitable type
\<open>'a'\<close>, whose range contains all the significant inputs of function
\<open>f_naive\<close>.

\item
\<open>f_out\<close> is a function of type \<open>'a \<Rightarrow> 'b\<close> mapping the outputs of
\<open>f_aux\<close> to those of \<open>f_naive\<close>, i.e. the values of type \<open>'a\<close>
matching pattern \<open>X\<close> to those of type \<open>'b\<close> matching pattern
\<open>Y\<close> with respect to the same value assignment.

\end{itemize}

The definitions of functions \<open>f_aux\<close> and \<open>f_out\<close> entail that equation
\<open>f_naive x = f_out (f_aux x)\<close> holds for any \<open>x\<close>. Particularly,
\<open>f_naive a = f_out (f_aux a)\<close>; thus, being \<open>a'\<close> an inverse image of
\<open>a\<close> under \<open>f_in\<close>, viz. \<open>a = f_in a'\<close>, it follows that
\<open>f_naive a = f a'\<close>. As a result, theorem \<open>P (f_naive a)\<close> may be
rewritten as \<open>P (f a')\<close>.

For any \<open>x\<close>, \<open>f_set x\<close> is precisely the set of the values
recursively input to function \<open>f_aux\<close> in the computation of
\<open>f_aux x\<close>, including \<open>x\<close> itself, and it can easily be ascertained
that \<open>f_aux x\<close> is such a value. In fact, the equation invoked last in the
computation of \<open>f_aux x\<close> must be a non-recursive one, so that it has the
form \<open>f_aux X = X\<close>, since all non-recursive equations in the definition
of \<open>f_aux\<close> apply to fixed points. Thus, being \<open>f_aux x\<close> the output
of the computation, the right-hand side of the equation, i.e. the pattern
\<open>X\<close> also input to function \<open>f_aux\<close> in the left-hand side, is
instantiated to value \<open>f_aux x\<close>.

Therefore, \<open>f_aux x \<in> f_set x\<close> for any \<open>x\<close>. Observe that the
argument rests on the assumption that whatever \<open>x\<close> is given, a sequence of
equations leading from \<open>x\<close> to \<open>f_aux x\<close> be actually available -- and
what is more, nothing significant could be proven on \<open>f_aux x\<close> for any
\<open>x\<close> for which its value were undefined, and then arbitrary. The trick of
making the definition of \<open>f_aux\<close> total by adding equations for the patterns
not covered in the definition of \<open>f_naive\<close>, if any, guarantees that this
assumption be satisfied.

An additional consequence of the previous argument is that
\<open>f_aux (f_aux x) = f_aux x\<close> for any \<open>x\<close>, i.e. function \<open>f_aux\<close>
is idempotent. If introduction rule \<open>\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_naive x)\<close>
is rewritten by applying equation \<open>f_naive x = f_out (f_aux x)\<close>,
instantiating free variable \<open>x\<close> to \<open>f_aux x\<close>, and then applying the
idempotence of function \<open>f_aux\<close>, the result is formula
\<open>\<lbrakk>f_inv (f_aux x); f_form (f_aux x)\<rbrakk> \<Longrightarrow> P (f_out (f_aux x))\<close>, which is
nothing but an instantiation of introduction rule
\<open>\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_out x)\<close>.

Observe that this rule is just a refinement of a rule whose proof is required for
proving conditional \<open>f_inv x \<longrightarrow> P (f_naive x)\<close> by recursion induction, so
that it does not give rise to any additional proof obligation. Moreover, it
contains neither function \<open>f_naive\<close> nor \<open>f_aux\<close>, thus its proof does
not require recursion induction with respect to the corresponding induction rules.

The instantiation of such refined introduction rule with value \<open>f_aux a\<close>
is \<open>\<lbrakk>f_inv (f_aux a); f_form (f_aux a)\<rbrakk> \<Longrightarrow> P (f_out (f_aux a))\<close>, which by
virtue of equality \<open>a = f_in a'\<close> and the definition of function \<open>f\<close>
is equivalent to formula
\<open>\<lbrakk>f_inv (f_aux a); f_form (f_aux a)\<rbrakk> \<Longrightarrow> P (f a')\<close>. Therefore, the rule is
sufficient to prove theorem \<open>P (f a')\<close> -- hence making unnecessary the
proof of conditional \<open>f_inv x \<longrightarrow> P (f_naive x)\<close> by recursion induction,
as mentioned previously -- provided the instantiated assumptions
\<open>f_inv (f_aux a)\<close>, \<open>f_form (f_aux a)\<close> can be shown to be true.

This actually is the case: the former assumption can be derived from formulae
\<open>f_aux a \<in> f_set a\<close>, \<open>f_inv a\<close> and the invariance of predicate
\<open>f_inv\<close> over \<open>f_set a\<close>, while the latter can be proven by recursion
induction, as by construction goal \<open>f_form X\<close> is trivial for any pattern
\<open>X\<close> to which some non-recursive equation in the definition of function
\<open>f_naive\<close> applies. If further non-recursive equations whose patterns do not
satisfy predicate \<open>f_form\<close> have been added to the definition of
\<open>f_aux\<close> to render it total, rule inversion can be applied to exclude that
\<open>f_aux a\<close> may match any of such patterns, again using formula
\<open>f_aux a \<in> f_set a\<close>.
\<close>

section "Method summary"

text \<open>
The general method developed so far can be schematized as follows.

Let \<open>f_naive\<close> be a tail-recursive function of type
\<open>'a\<^sub>1 \<Rightarrow> ... \<Rightarrow> 'a\<^sub>n \<Rightarrow> 'b\<close>, and \<open>P (f_naive a\<^sub>1 ... a\<^sub>n)\<close> be a
non-trivial theorem having to be proven on this function.

In order to accomplish such task, the following procedure shall be observed.

\begin{itemize}

\item
\emph{Step 1} --- Refine the definition of \<open>f_naive\<close> into that of an
auxiliary tail-recursive function \<open>f_aux\<close> of type \<open>'a \<Rightarrow> 'a\<close>, where
\<open>'a\<close> is a product or record type with types \<open>'a\<^sub>1\<close>, ..., \<open>'a\<^sub>n\<close>
as components, by treating as fixed points the patterns to which non-recursive
equations apply as well as those to which no equation applies, if any.

\item
\emph{Step 2} --- Define a function \<open>f\<close> of type \<open>'a' \<Rightarrow> 'b\<close> by means
of a non-recursive equation \<open>f x = f_out (f_aux (f_in x))\<close>, where
\<open>f_in\<close> is a function of type \<open>'a' \<Rightarrow> 'a\<close> (possibly matching the
identity function) whose range contains all the significant inputs of function
\<open>f_naive\<close>, and \<open>f_out\<close> is a function of type \<open>'a \<Rightarrow> 'b\<close>
mapping the outputs of \<open>f_aux\<close> to those of \<open>f_naive\<close>.
\\Then, denoting with \<open>a\<close> the value of type \<open>'a\<close> with components
\<open>a\<^sub>1\<close>, ..., \<open>a\<^sub>n\<close>, and with \<open>a'\<close> an inverse image of \<open>a\<close>
under function \<open>f_in\<close>, the theorem to be proven takes the equivalent form
\<open>P (f a')\<close>.

\item
\emph{Step 3} --- Let \<open>f_aux X\<^sub>1 = f_aux X'\<^sub>1\<close>, ...,
\<open>f_aux X\<^sub>m = f_aux X'\<^sub>m\<close> be the recursive equations in the definition of
function \<open>f_aux\<close>.
\\Then, define an inductive set \<open>f_set\<close> of type \<open>'a \<Rightarrow> 'a set\<close> with
introduction rules \<open>x \<in> f_set x\<close>,
\<open>X\<^sub>1 \<in> f_set x \<Longrightarrow> X'\<^sub>1 \<in> f_set x\<close>, ...,
\<open>X\<^sub>m \<in> f_set x \<Longrightarrow> X'\<^sub>m \<in> f_set x\<close>.
\\If the right-hand side of some recursive equation contains conditionals in the
form of \<open>if\<close> or \<open>case\<close> constructs, the corresponding introduction
rule can be split into as many rules as the possible mutually exclusive cases;
each of such rules shall then provide for the related case as an additional
assumption.

\item
\emph{Step 4} --- Prove lemma \<open>f_aux x \<in> f_set x\<close>; a general inference
scheme, independent of the specific function \<open>f_aux\<close>, applies to this proof.
\\First, prove lemma \<open>y \<in> f_set x \<Longrightarrow> f_set y \<subseteq> f_set x\<close>, which can easily
be done by rule induction.
\\Next, applying recursion induction to goal \<open>f_aux x \<in> f_set x\<close> and then
simplifying, a subgoal \<open>X\<^sub>i \<in> f_set X\<^sub>i\<close> arises for each non-recursive
equation \<open>f_aux X\<^sub>i = X\<^sub>i\<close>, while a subgoal
\<open>f_aux X'\<^sub>j \<in> f_set X'\<^sub>j \<Longrightarrow> f_aux X'\<^sub>j \<in> f_set X\<^sub>j\<close> arises for each recursive
equation \<open>f_aux X\<^sub>j = f_aux X'\<^sub>j\<close>.
\\The former subgoals can be proven by introduction rule \<open>x \<in> f_set x\<close>, the
latter ones as follows: rule instantiations \<open>X\<^sub>j \<in> f_set X\<^sub>j\<close> and
\<open>X\<^sub>j \<in> f_set X\<^sub>j \<Longrightarrow> X'\<^sub>j \<in> f_set X\<^sub>j\<close> imply formula \<open>X'\<^sub>j \<in> f_set X\<^sub>j\<close>;
thus \<open>f_set X'\<^sub>j \<subseteq> f_set X\<^sub>j\<close> by the aforesaid lemma; from this and subgoal
assumption \<open>f_aux X'\<^sub>j \<in> f_set X'\<^sub>j\<close>, subgoal conclusion
\<open>f_aux X'\<^sub>j \<in> f_set X\<^sub>j\<close> ensues.
\\As regards recursive equations containing conditionals, the above steps have to
be preceded by a case distinction, so as to obtain further assumptions sufficient
for splitting such conditionals.

\item
\emph{Step 5} --- Define a predicate \<open>f_inv\<close> of type \<open>'a \<Rightarrow> bool\<close> in
such a way as to meet the proof obligations prescribed by the following steps.

\item
\emph{Step 6} --- Prove lemma \<open>f_inv a\<close>.
\\In case of failure, return to step 5 so as to suitably change the definition of
predicate \<open>f_inv\<close>.

\item
\emph{Step 7} --- Prove introduction rule \<open>f_inv x \<Longrightarrow> P (f_out x)\<close>, or
rather \<open>\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_out x)\<close>, where \<open>f_form\<close> is a
suitable predicate of type \<open>'a \<Rightarrow> bool\<close> satisfied by any pattern to which
some non-recursive equation in the definition of function \<open>f_naive\<close> applies.
\\In case of failure, return to step 5 so as to suitably change the definition of
predicate \<open>f_inv\<close>.

\item
\emph{Step 8} --- In case an introduction rule of the second form has been proven
in step 7, prove lemma \<open>f_form (f_aux a)\<close> by recursion induction.
\\If the definition of function \<open>f_aux\<close> resulting from step 1 contains
additional non-recursive equations whose patterns do not satisfy predicate
\<open>f_form\<close>, rule inversion can be applied to exclude that \<open>f_aux a\<close>
may match any of such patterns, using instantiation \<open>f_aux a \<in> f_set a\<close> of
the lemma proven in step 4.

\item
\emph{Step 9} --- Prove by rule induction introduction rule
\<open>\<lbrakk>y \<in> f_set x; f_inv x\<rbrakk> \<Longrightarrow> f_inv y\<close>, which states the invariance of
predicate \<open>f_inv\<close> over inductive set \<open>f_set x\<close> for any \<open>x\<close>
satisfying \<open>f_inv\<close>.
\\In case of failure, return to step 5 so as to suitably change the definition of
predicate \<open>f_inv\<close>.
\\Observe that the order in which the proof obligations related to predicate
\<open>f_inv\<close> are distributed among steps 6 to 9 is ascending in the effort
typically required to discharge them. The reason why this strategy is advisable is
that in case one step fails, which forces to revise the definition of predicate
\<open>f_inv\<close> and then also the proofs already worked out, such proofs will be the
least demanding ones so as to minimize the effort required for their revision.

\item
\emph{Step 10} --- Prove theorem \<open>P (f a')\<close> by means of the following
inference scheme.
\\First, derive formula \<open>f_inv (f_aux a)\<close> from introduction rule
\<open>\<lbrakk>y \<in> f_set x; f_inv x\<rbrakk> \<Longrightarrow> f_inv y\<close> and formulae
\<open>f_aux a \<in> f_set a\<close>, \<open>f_inv a\<close>.
\\Then, derive formula \<open>P (f_out (f_aux a))\<close> from either introduction rule
\<open>f_inv x \<Longrightarrow> P (f_out x)\<close> or \<open>\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_out x)\<close>
and formulae \<open>f_inv (f_aux a)\<close>, \<open>f_form (f_aux a)\<close> (in the latter
case).
\\Finally, derive theorem \<open>P (f a')\<close> from formulae
\<open>P (f_out (f_aux a))\<close>, \<open>a = f_in a'\<close> and the definition of
function \<open>f\<close>.

\end{itemize}

In the continuation, the application of this method is illustrated by analyzing
two case studies drawn from an exercise comprised in Isabelle online course
material; see \cite{R5}. The salient points of definitions and proofs are
commented; for additional information see Isabelle documentation, particularly
\cite{R1}, \cite{R2}, \cite{R3}, and \cite{R4}.
\<close>

(*<*)
end
(*>*)


theory DDL imports Main             (* Christoph Benzmüller & Xavier Parent & Ali Farjami, 2018  *)

begin (* DDL: Dyadic Deontic Logic by Carmo and Jones *)
 typedecl i (*type for possible worlds*)   type_synonym \<sigma> = "(i\<Rightarrow>bool)"
 consts av::"i\<Rightarrow>\<sigma>" pv::"i\<Rightarrow>\<sigma>" ob::"\<sigma>\<Rightarrow>(\<sigma>\<Rightarrow>bool)" (*accessibility relations*) cw::i (*current world*)

 axiomatization where
  ax_3a: "\<exists>x. av(w)(x)" and ax_4a: "\<forall>x. av(w)(x) \<longrightarrow> pv(w)(x)" and ax_4b: "pv(w)(w)" and
  ax_5a: "\<not>ob(X)(\<lambda>x. False)" and
  ax_5b: "(\<forall>w. ((Y(w) \<and> X(w)) \<longleftrightarrow> (Z(w) \<and> X(w)))) \<longrightarrow> (ob(X)(Y) \<longleftrightarrow> ob(X)(Z))" and
  ax_5c: "((\<forall>Z. \<beta>(Z) \<longrightarrow> ob(X)(Z)) \<and> (\<exists>Z. \<beta>(Z))) \<longrightarrow>
      (((\<exists>y. ((\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))(y) \<and> X(y))) \<longrightarrow> ob(X)(\<lambda>w. \<forall>Z. (\<beta> Z) \<longrightarrow> (Z w))))" and
  ax_5d: "((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Y) \<and> (\<forall>w. X(w) \<longrightarrow> Z(w)))
                   \<longrightarrow> ob(Z)(\<lambda>w. (Z(w) \<and> \<not>X(w)) \<or> Y(w))" and
  ax_5e: "((\<forall>w. Y(w) \<longrightarrow> X(w)) \<and> ob(X)(Z) \<and> (\<exists>w. Y(w) \<and> Z(w))) \<longrightarrow> ob(Y)(Z)"

 abbreviation ddlneg ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>A \<equiv> \<lambda>w. \<not>A(w)"
 abbreviation ddland (infixr"\<^bold>\<and>"51) where "A\<^bold>\<and>B \<equiv> \<lambda>w. A(w)\<and>B(w)"
 abbreviation ddlor (infixr"\<^bold>\<or>"50) where "A\<^bold>\<or>B \<equiv> \<lambda>w. A(w)\<or>B(w)"
 abbreviation ddlimp (infixr"\<^bold>\<rightarrow>"49) where "A\<^bold>\<rightarrow>B \<equiv> \<lambda>w. A(w)\<longrightarrow>B(w)"
 abbreviation ddlequiv (infixr"\<^bold>\<leftrightarrow>"48) where "A\<^bold>\<leftrightarrow>B \<equiv> \<lambda>w. A(w)\<longleftrightarrow>B(w)"
 abbreviation ddlbox ("\<^bold>\<box>") where "\<^bold>\<box>A \<equiv> \<lambda>w.\<forall>v. A(v)"  (*A = (\<lambda>w. True)*)
 abbreviation ddlboxa ("\<^bold>\<box>\<^sub>a") where "\<^bold>\<box>\<^sub>aA \<equiv> \<lambda>w. (\<forall>x. av(w)(x) \<longrightarrow> A(x))"  (*in all actual worlds*)
 abbreviation ddlboxp ("\<^bold>\<box>\<^sub>p") where "\<^bold>\<box>\<^sub>pA \<equiv> \<lambda>w. (\<forall>x. pv(w)(x) \<longrightarrow> A(x))" (*in all potential worlds*)
 abbreviation ddldia ("\<^bold>\<diamond>") where "\<^bold>\<diamond>A \<equiv> \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>A)"
 abbreviation ddldiaa ("\<^bold>\<diamond>\<^sub>a") where "\<^bold>\<diamond>\<^sub>aA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>a(\<^bold>\<not>A)"
 abbreviation ddldiap ("\<^bold>\<diamond>\<^sub>p") where "\<^bold>\<diamond>\<^sub>pA \<equiv> \<^bold>\<not>\<^bold>\<box>\<^sub>p(\<^bold>\<not>A)"
 abbreviation ddlo ("\<^bold>O\<^bold>\<langle>_\<^bold>|_\<^bold>\<rangle>"[52]53) where "\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<equiv> \<lambda>w. ob(A)(B)"  (*it ought to be \<psi>, given \<phi> *)
 abbreviation ddloa ("\<^bold>O\<^sub>a") where "\<^bold>O\<^sub>aA \<equiv> \<lambda>w. ob(av(w))(A) \<and> (\<exists>x. av(w)(x) \<and> \<not>A(x))" (*actual obligation*)
 abbreviation ddlop ("\<^bold>O\<^sub>p") where "\<^bold>O\<^sub>pA \<equiv> \<lambda>w. ob(pv(w))(A) \<and> (\<exists>x. pv(w)(x) \<and> \<not>A(x))"  (*primary obligation*)
 abbreviation ddltop ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation ddlbot ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"

 abbreviation ddlvalid::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105) where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"   (*Global validity*)
 abbreviation ddlvalidcw::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>c\<^sub>w"[7]105) where "\<lfloor>A\<rfloor>\<^sub>c\<^sub>w \<equiv> A cw" (*Local validity (in cw)*)

(* A is obliagtory *)
 abbreviation obligatoryDDL::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>O\<^bold>\<langle>_\<^bold>\<rangle>")   where "\<^bold>O\<^bold>\<langle>A\<^bold>\<rangle>  \<equiv>  \<^bold>O\<^bold>\<langle>A\<^bold>|\<^bold>\<top>\<^bold>\<rangle>"

(* Consistency *)
  lemma True nitpick [satisfy] oops

(* Unimportant *)
  sledgehammer_params [max_facts=20,timeout=20] (* Sets parameters for theorem provers *)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (* ... and model finder. *)

end


(*  Title:      Tests.thy
    Author:     Klaus Weidinger, TU Muenchen
    Copyright   2020

Tests for all simprocs in Prime, Prime_Factorization, Primepow,
Squarefree2, Is_Nth_Power, Partial_Radication, Coprime and GCD2.
*)

theory Tests
  imports
    Main
    Complex_Main
    "HOL-Computational_Algebra.Primes"
    HOL.Num
    Prime
    Prime_Factorization
    Primepow
    Squarefree2
    Is_Nth_Power
    Partial_Radication
    Coprime
    GCD2
begin

lemma upt_rec_0_numeral [simp]:
  "[0..<numeral n] = 0 # [1..<numeral n]"
  by (subst upt_rec) auto

lemma upt_rec_Suc_0_numeral [simp]:
  "[Suc 0..<numeral n] = (if 1 < (numeral n :: nat) then 1 # [2..<numeral n] else [])"
  by (subst upt_rec) (simp only: One_nat_def numeral_2_eq_2)

text\<open>Prime\<close>

lemma "map prime [0] = [False]"
  by (simp del: prime_nat_numeral_eq not_prime_0)

ML\<open>Prime.simproc @{context} @{cterm "prime (0::nat)"}\<close>

lemma "map prime [1..<(100::nat)] =
    [       False, True, True, False, True, False, True, False, False,
     False, True, False, True, False, False, False, True, False, True,
     False, False, False, True, False, False, False, False, False, True,
     False, True, False, False, False, False, False, True, False, False,
     False, True, False, True, False, False, False, True, False, False,
     False, False, False, True, False, False, False, False, False, True,
     False, True, False, False, False, False, False, True, False, False,
     False, True, False, True, False, False, False, False, False, True,
     False, False, False, True, False, False, False, False, False, True,
     False, False, False, False, False, False, False, True, False, False]"
  by (simp del: prime_nat_numeral_eq not_prime_0 not_prime_1)

lemma "map prime [999980..<(1000000::nat)] =
     [False, False, False, True, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False]"
  by (simp del: prime_nat_numeral_eq not_prime_0 not_prime_1)

text\<open>Prime_Factorization\<close>

lemma "map prime_factorization [0..<(100::nat)] =
    [{#}, {#}, {#2#}, {#3#}, {#2, 2#}, {#5#}, {#2, 3#}, {#7#}, {#2, 2, 2#}, {#3, 3#},
     {#2, 5#}, {#11#}, {#2, 2, 3#}, {#13#}, {#2, 7#}, {#3, 5#}, {#2, 2, 2, 2#}, {#17#}, {#2, 3, 3#}, {#19#},
     {#2, 2, 5#}, {#3, 7#}, {#2, 11#}, {#23#}, {#2, 2, 2, 3#}, {#5, 5#}, {#2, 13#}, {#3, 3, 3#}, {#2, 2, 7#}, {#29#},
     {#2, 3, 5#}, {#31#}, {#2, 2, 2, 2, 2#}, {#3, 11#}, {#2, 17#}, {#5, 7#}, {#2, 2, 3, 3#}, {#37#}, {#2, 19#}, {#3, 13#},
     {#2, 2, 2, 5#}, {#41#}, {#2, 3, 7#}, {#43#}, {#2, 2, 11#}, {#3, 3, 5#}, {#2, 23#}, {#47#}, {#2, 2, 2, 2, 3#}, {#7, 7#},
     {#2, 5, 5#}, {#3, 17#}, {#2, 2, 13#}, {#53#}, {#2, 3, 3, 3#}, {#5, 11#}, {#2, 2, 2, 7#}, {#3, 19#}, {#2, 29#}, {#59#},
     {#2, 2, 3, 5#}, {#61#}, {#2, 31#}, {#3, 3, 7#}, {#2, 2, 2, 2, 2, 2#}, {#5, 13#}, {#2, 3, 11#}, {#67#}, {#2, 2, 17#}, {#3, 23#},
     {#2, 5, 7#}, {#71#}, {#2, 2, 2, 3, 3#}, {#73#}, {#2, 37#}, {#3, 5, 5#}, {#2, 2, 19#}, {#7, 11#}, {#2, 3, 13#}, {#79#},
     {#2, 2, 2, 2, 5#}, {#3, 3, 3, 3#}, {#2, 41#}, {#83#}, {#2, 2, 3, 7#}, {#5, 17#}, {#2, 43#}, {#3, 29#}, {#2, 2, 2, 11#}, {#89#},
     {#2, 3, 3, 5#}, {#7, 13#}, {#2, 2, 23#}, {#3, 31#}, {#2, 47#}, {#5, 19#}, {#2, 2, 2, 2, 2, 3#}, {#97#}, {#2, 7, 7#}, {#3, 3, 11#}]"
  by (simp del: prime_factorization_0 prime_factorization_1 prime_factorization_normalize
                prime_factorization_subset_iff_dvd prime_factorization_divide
                prime_factorization_gcd_factorial prime_factorization_lcm_factorial
                prime_factorization_gcd prime_factorization_lcm)

lemma "map prime_factorization [999980..<(1000000::nat)] =
    [{#2, 2, 5, 49999#}, {#3, 3, 111109#}, {#2, 79, 6329#}, {#999983#}, {#2, 2, 2, 2, 3, 83, 251#},
     {#5, 7, 28571#}, {#2, 13, 38461#}, {#3, 257, 1297#}, {#2, 2, 11, 22727#}, {#19, 52631#},
     {#2, 3, 3, 5, 41, 271#}, {#17, 59, 997#}, {#2, 2, 2, 7, 7, 2551#}, {#3, 333331#}, {#2, 23, 21739#},
     {#5, 199999#}, {#2, 2, 3, 167, 499#}, {#757, 1321#}, {#2, 31, 127, 127#}, {#3, 3, 3, 7, 11, 13, 37#}]"
  by (simp del: prime_factorization_0 prime_factorization_1 prime_factorization_normalize
                prime_factorization_subset_iff_dvd prime_factorization_divide
                prime_factorization_gcd_factorial prime_factorization_lcm_factorial
                prime_factorization_gcd prime_factorization_lcm)

text\<open>Primepow\<close>

lemma "map primepow [0..<(100::nat)] =
    [False, False, True, True, True, True, False, True, True, True,
     False, True, False, True, False, False, True, True, False, True,
     False, False, False, True, False, True, False, True, False, True,
     False, True, True, False, False, False, False, True, False, False,
     False, True, False, True, False, False, False, True, False, True,
     False, False, False, True, False, False, False, False, False, True,
     False, True, False, False, True, False, False, True, False, False,
     False, True, False, True, False, False, False, False, False, True,
     False, True, False, True, False, False, False, False, False, True,
     False, False, False, False, False, False, False, True, False, False]"
  by (simp del: zero_not_primepow one_not_primepow primepow_not_unit
                not_primepow_Suc_0_nat primepow_prime primepow_prime_power)

lemma "map primepow [999980..<(1000000::nat)] =
    [False, False, False, True, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False]"
  by (simp del: zero_not_primepow one_not_primepow primepow_not_unit
                not_primepow_Suc_0_nat primepow_prime primepow_prime_power)

text\<open>Squarefree2\<close>

lemma "map squarefree [0..<(100::nat)] =
    [False, True, True, True, False, True, True, True, False, False,
     True, True, False, True, True, True, False, True, False, True,
     False, True, True, True, False, False, True, False, False, True,
     True, True, False, True, True, True, False, True, True, True,
     False, True, True, True, False, False, True, True, False, False,
     False, True, False, True, False, True, False, True, True, True,
     False, True, True, False, False, True, True, True, False, True,
     True, True, False, True, True, False, False, True, True, True,
     False, False, True, True, False, True, True, True, False, True,
     False, True, False, True, True, True, False, True, False, False]"
  by (simp del: not_squarefree_0 squarefree_unit squarefree_1
                squarefree_minus)

lemma "map squarefree [999980..<(1000000::nat)] =
    [False, False, True, True, False, True, True, True, False, True,
     False, True, False, True, True, True, False, True, False, False]"
  by (simp del: not_squarefree_0 squarefree_unit squarefree_1
                squarefree_minus)

text\<open>Is_Nth_Power\<close>

lemma "List.bind [0..<10] (\<lambda>a. map (is_nth_power a) [0..<10]) =
    [False, True, False, False, False, False, False, False, False, False,
     True, True, True, True, True, True, True, True, True, True,
     True, True, False, False, True, False, False, False, False, True,
     True, True, False, False, False, False, False, False, True, False,
     True, True, False, False, False, False, False, False, False, False,
     True, True, False, False, False, False, False, False, False, False,
     True, True, False, False, False, False, False, False, False, False,
     True, True, False, False, False, False, False, False, False, False,
     True, True, False, False, False, False, False, False, False, False,
     True, True, False, False, False, False, False, False, False, False]"
  by (simp add: List.bind_def
           del: is_nth_power_nth_power is_zeroth_power is_first_power
                is_first_power' is_nth_power_0 is_nth_power_0_iff
                is_nth_power_1 is_nth_power_Suc_0)

lemma "List.bind [0..<10] (\<lambda>a. map (is_nth_power a) [99990..<100010]) =
    [False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     True, True, True, True, True, True, True, True, True, True,
     True, True, True, True, True, True, True, True, True, True,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     True, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False,

     False, False, False, False, False, False, False, False, False, False,
     False, False, False, False, False, False, False, False, False, False]"
  by (simp add: List.bind_def
           del: is_nth_power_nth_power is_zeroth_power is_first_power
                is_first_power' is_nth_power_0 is_nth_power_0_iff
                is_nth_power_1 is_nth_power_Suc_0)

text\<open>Partial_Radication\<close>

lemma "List.bind [0..<10] (\<lambda>a. map (root a) [0..<10]) =
     foo"
  apply (simp add: List.bind_def
              del: root_0 real_root_zero real_root_one real_root_Suc_0)

lemma "List.bind [0..<10] (\<lambda>a. map (root a) [999990..<1000000]) =
     foo"
  apply (simp add: List.bind_def
              del: root_0 real_root_zero real_root_one real_root_Suc_0)

text\<open>Coprime\<close>

lemma "List.bind [0..<10] (\<lambda>a. map (coprime a) [0..<10]) =
     [False, True, False, False, False, False, False, False, False, False,
     True, True, True, True, True, True, True, True, True, True,
     False, True, False, True, False, True, False, True, False, True,
     False, True, True, False, True, True, False, True, True, False,
     False, True, False, True, False, True, False, True, False, True,
     False, True, True, True, True, False, True, True, True, True,
     False, True, False, False, False, True, False, True, False, False,
     False, True, True, True, True, True, True, False, True, True,
     False, True, False, True, False, True, False, True, False, True,
     False, True, True, False, True, True, False, True, True, False]"
  by (simp add: List.bind_def)

lemma "List.bind [1000..<1010] (\<lambda>a. map (coprime a) [999990..<1000000]) =
     [False, True, False, True, False, False, False, True, False, True,
     True, True, False, True, True, True, True, True, True, False,
     False, True, False, False, False, True, False, True, False, False,
     True, False, True, True, True, True, True, True, True, True,
     False, True, False, True, False, True, False, True, False, True,
     False, True, True, False, True, False, False, True, True, False,
     False, True, False, True, False, True, False, True, False, True,
     True, True, True, True, True, True, True, True, True, True,
     False, True, False, False, False, True, False, True, False, False,
     True, True, True, True, True, True, True, True, True, True]"
  by (simp add: List.bind_def)

text\<open>GCD2\<close>

lemma "List.bind [0..<10] (\<lambda>a. map (gcd a) [0..<10]) =
    [0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2, 1, 2, 1, 2, 1, 2, 1, 2, 1,
     3, 1, 1, 3, 1, 1, 3, 1, 1, 3,
     4, 1, 2, 1, 4, 1, 2, 1, 4, 1,
     5, 1, 1, 1, 1, 5, 1, 1, 1, 1,
     6, 1, 2, 3, 2, 1, 6, 1, 2, 3,
     7, 1, 1, 1, 1, 1, 1, 7, 1, 1,
     8, 1, 2, 1, 4, 1, 2, 1, 8, 1,
     9, 1, 1, 3, 1, 1, 3, 1, 1, 9]"
  by (simp add: List.bind_def)

lemma "List.bind [1000..<1010] (\<lambda>a. map (gcd a) [999980..<1000000]) =
    [20, 1, 2, 1, 8, 5, 2, 1, 4, 1,
     10, 1, 8, 1, 2, 5, 4, 1, 2, 1,
     1, 1, 1, 1, 1, 7, 13, 1, 11, 1,
     1, 1, 7, 1, 1, 1, 1, 1, 1, 1001,
     2, 3, 2, 1, 6, 1, 2, 3, 2, 1,
     6, 1, 2, 3, 2, 1, 1002, 1, 2, 3,
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     1, 1003, 1, 1, 1, 1, 1, 1, 1, 1,
     4, 1, 2, 1, 1004, 1, 2, 1, 4, 1,
     2, 1, 4, 1, 2, 1, 4, 1, 2, 1,
     5, 3, 1, 1, 3, 5, 1, 3, 1, 1,
     15, 1, 1, 3, 1, 5, 3, 1, 1, 3,
     2, 1, 2, 1, 2, 1, 2, 1, 2, 1,
     2, 1, 2, 1, 2, 1, 2, 1, 2, 1,
     1, 1, 1, 1, 1, 1, 1, 1, 1, 19,
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     4, 9, 2, 1, 48, 7, 2, 3, 4, 1,
     18, 1, 56, 3, 2, 1, 12, 1, 2, 63,
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1]"
  by (simp add: List.bind_def)

end