(* Title:  Digraph.thy
   Author: Lars Noschinski, TU München
   Author: René Neumann
*)

theory Digraph
imports
  Main
  Rtrancl_On
  Stuff
begin

section {* Digraphs *}

record ('a,'b) pre_digraph =
  verts :: "'a set"
  arcs :: "'b set"
  tail :: "'b \<Rightarrow> 'a"
  head :: "'b \<Rightarrow> 'a"

definition arc_to_ends :: "('a,'b) pre_digraph \<Rightarrow> 'b \<Rightarrow> 'a \<times> 'a" where
  "arc_to_ends G e \<equiv> (tail G e, head G e)"

locale pre_digraph =
  fixes G :: "('a, 'b) pre_digraph" (structure)

locale wf_digraph = pre_digraph +
  assumes tail_in_verts[simp]: "e \<in> arcs G \<Longrightarrow> tail G e \<in> verts G"
  assumes head_in_verts[simp]: "e \<in> arcs G \<Longrightarrow> head G e \<in> verts G"
begin

lemma wf_digraph: "wf_digraph G" by intro_locales

lemmas wellformed = tail_in_verts head_in_verts

end

definition arcs_ends :: "('a,'b) pre_digraph \<Rightarrow> ('a \<times> 'a) set" where
  "arcs_ends G \<equiv> arc_to_ends G ` arcs G"

definition symmetric :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "symmetric G \<equiv> sym (arcs_ends G)"

text {*
  Matches "pseudo digraphs" from \cite{bangjensen2009digraphs}, except for
  allowing the null graph. For a discussion of that topic,
  see also \cite{harary1974nullgraph}.
*}
locale fin_digraph = wf_digraph +
  assumes finite_verts[simp]: "finite (verts G)"
    and finite_arcs[simp]: "finite (arcs G)"

locale loopfree_digraph = wf_digraph +
  assumes no_loops: "e \<in> arcs G \<Longrightarrow> tail G e \<noteq> head G e"

locale nomulti_digraph = wf_digraph +
  assumes no_multi_arcs: "\<And>e1 e2. \<lbrakk>e1 \<in> arcs G; e2 \<in> arcs G;
     arc_to_ends G e1 = arc_to_ends G e2\<rbrakk> \<Longrightarrow> e1 = e2"

locale sym_digraph = wf_digraph +
  assumes sym_arcs[intro]: "symmetric G"

locale digraph = fin_digraph + loopfree_digraph + nomulti_digraph

text {*
  We model graphs as symmetric digraphs. This is fine for many purposes,
  but not for all. For example, the path $a,b,a$ is considered to be a cycle
  in a digraph (and hence in a symmetric digraph), but not in an undirected
  graph.
 *}
locale pseudo_graph = fin_digraph + sym_digraph

locale graph = digraph + pseudo_graph

lemma (in wf_digraph) fin_digraphI[intro]:
  assumes "finite (verts G)"
  assumes "finite (arcs G)"
  shows "fin_digraph G"
using assms by unfold_locales

lemma (in wf_digraph) sym_digraphI[intro]:
  assumes "symmetric G"
  shows "sym_digraph G"
using assms by unfold_locales

lemma (in digraph) graphI[intro]:
  assumes "symmetric G"
  shows "graph G"
using assms by unfold_locales

definition (in wf_digraph) arc :: "'b \<Rightarrow> 'a \<times> 'a \<Rightarrow> bool" where
  "arc e uv \<equiv> e \<in> arcs G \<and> tail G e = fst uv \<and> head G e = snd uv"

lemma (in fin_digraph) fin_digraph: "fin_digraph G"
  by unfold_locales

lemma (in nomulti_digraph) nomulti_digraph: "nomulti_digraph G" by unfold_locales

lemma arcs_ends_conv: "arcs_ends G = (\<lambda>e. (tail G e, head G e)) ` arcs G"
  by (auto simp: arc_to_ends_def arcs_ends_def)

lemma symmetric_conv: "symmetric G \<longleftrightarrow> (\<forall>e1 \<in> arcs G. \<exists>e2 \<in> arcs G. tail G e1 = head G e2 \<and> head G e1 = tail G e2)"
  unfolding symmetric_def arcs_ends_conv sym_def by auto

lemma arcs_ends_symmetric:
  assumes "symmetric G"
  shows "(u,v) \<in> arcs_ends G \<Longrightarrow> (v,u) \<in> arcs_ends G"
  using assms unfolding symmetric_def sym_def by auto

lemma (in nomulti_digraph) inj_on_arc_to_ends:
  "inj_on (arc_to_ends G) (arcs G)"
  by (rule inj_onI) (rule no_multi_arcs)

subsection {* Reachability *}

abbreviation dominates :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<rightarrow>\<index> _" [100,100] 40) where
  "dominates G u v \<equiv> (u,v) \<in> arcs_ends G"

abbreviation reachable1 :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<rightarrow>\<^sup>+\<index> _" [100,100] 40) where
  "reachable1 G u v \<equiv> (u,v) \<in> (arcs_ends G)^+"

definition reachable :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<rightarrow>\<^sup>*\<index> _" [100,100] 40) where
  "reachable G u v \<equiv> (u,v) \<in> rtrancl_on (verts G) (arcs_ends G)"

lemma reachableE[elim]:
  assumes "u \<rightarrow>\<^bsub>G\<^esub> v"
  obtains e where "e \<in> arcs G" "tail G e = u" "head G e = v"
using assms by (auto simp add: arcs_ends_conv)

lemma (in loopfree_digraph) adj_not_same:
  assumes "a \<rightarrow> a" shows "False"
  using assms by (rule reachableE) (auto dest: no_loops)

lemma reachable_in_vertsE:
  assumes "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v" obtains "u \<in> verts G" "v \<in> verts G"
  using assms unfolding reachable_def by induct auto

lemma reachable_rtranclI:
  "u \<rightarrow>\<^sup>*\<^bsub>G \<^esub> v \<Longrightarrow> (u, v) \<in> (arcs_ends G)\<^sup>*"
  unfolding reachable_def by (rule rtrancl_on_rtranclI)

context wf_digraph begin

lemma adj_in_verts:
  assumes "u \<rightarrow>\<^bsub>G\<^esub> v" shows "u \<in> verts G" "v \<in> verts G"
  using assms unfolding arcs_ends_conv by auto

lemma dominatesI: assumes "arc_to_ends G a = (u,v)" "a \<in> arcs G" shows "u \<rightarrow>\<^bsub>G\<^esub> v"
  using assms by (auto simp: arcs_ends_def intro: rev_image_eqI)

lemma reachable_refl [intro!, Pure.intro!, simp]: "v \<in> verts G \<Longrightarrow> v \<rightarrow>\<^sup>* v"
  unfolding reachable_def by auto

lemma adj_reachable_trans[trans]:
  assumes "a \<rightarrow>\<^bsub>G\<^esub> b" "b \<rightarrow>\<^sup>*\<^bsub>G\<^esub> c" shows "a \<rightarrow>\<^sup>*\<^bsub>G\<^esub> c"
  using assms by (auto simp: reachable_def intro: converse_rtrancl_on_into_rtrancl_on adj_in_verts)

lemma reachable_adj_trans[trans]:
  assumes "a \<rightarrow>\<^sup>*\<^bsub>G\<^esub> b" "b \<rightarrow>\<^bsub>G\<^esub> c" shows "a \<rightarrow>\<^sup>*\<^bsub>G\<^esub> c"
  using assms by (auto simp: reachable_def intro: rtrancl_on_into_rtrancl_on adj_in_verts)

lemma reachable_adjI [intro, simp]: "u \<rightarrow> v \<Longrightarrow> u \<rightarrow>\<^sup>* v"
  by (auto intro: adj_reachable_trans adj_in_verts)

lemma reachable_trans[trans]:
  assumes "u \<rightarrow>\<^sup>*v" "v \<rightarrow>\<^sup>* w" shows "u \<rightarrow>\<^sup>* w"
  using assms unfolding reachable_def by (rule rtrancl_on_trans)

lemma reachable_induct[consumes 1, case_names base step]:
  assumes major: "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
    and cases: "u \<in> verts G \<Longrightarrow> P u"
       "\<And>x y. \<lbrakk>u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x; x \<rightarrow>\<^bsub>G\<^esub> y; P x\<rbrakk> \<Longrightarrow> P y"
  shows "P v"
  using assms unfolding reachable_def by (rule rtrancl_on_induct) auto

lemma converse_reachable_induct[consumes 1, case_names base step, induct pred: reachable]:
  assumes major: "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
    and cases: "v \<in> verts G \<Longrightarrow> P v"
       "\<And>x y. \<lbrakk>x \<rightarrow>\<^bsub>G\<^esub> y; y \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v; P y\<rbrakk> \<Longrightarrow> P x"
  shows "P u"
  using assms unfolding reachable_def by (rule converse_rtrancl_on_induct) auto

lemma (in pre_digraph) converse_reachable_cases:
  assumes "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  obtains (base) "u = v" "u \<in> verts G"
    | (step) w where "u \<rightarrow>\<^bsub>G\<^esub> w" "w \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  using assms unfolding reachable_def by (cases rule: converse_rtrancl_on_cases) auto

lemma reachable_in_verts:
  assumes "u \<rightarrow>\<^sup>* v" shows "u \<in> verts G" "v \<in> verts G"
  using assms by induct (simp_all add: adj_in_verts)

lemma reachable1_in_verts:
  assumes "u \<rightarrow>\<^sup>+ v" shows "u \<in> verts G" "v \<in> verts G"
  using assms
  by induct (simp_all add: adj_in_verts)

lemma reachable1_reachable[intro]:
  "v \<rightarrow>\<^sup>+ w \<Longrightarrow> v \<rightarrow>\<^sup>* w"
  unfolding reachable_def
  by (rule rtrancl_consistent_rtrancl_on) (simp_all add: reachable1_in_verts adj_in_verts)

lemmas reachable1_reachableE[elim] = reachable1_reachable[elim_format]

lemma reachable_neq_reachable1[intro]:
  assumes reach: "v \<rightarrow>\<^sup>* w"
  and neq: "v \<noteq> w"
  shows "v \<rightarrow>\<^sup>+ w"
proof -
  from reach have "(v,w) \<in> (arcs_ends G)^*" by (rule reachable_rtranclI)
  with neq show ?thesis by (auto dest: rtranclD)
qed

lemmas reachable_neq_reachable1E[elim] = reachable_neq_reachable1[elim_format]

lemma reachable1_reachable_trans [trans]:
  "u \<rightarrow>\<^sup>+ v \<Longrightarrow> v \<rightarrow>\<^sup>* w \<Longrightarrow> u \<rightarrow>\<^sup>+ w"
by (metis trancl_trans reachable_neq_reachable1)

lemma reachable_reachable1_trans [trans]:
  "u \<rightarrow>\<^sup>* v \<Longrightarrow> v \<rightarrow>\<^sup>+ w \<Longrightarrow> u \<rightarrow>\<^sup>+ w"
by (metis trancl_trans reachable_neq_reachable1)

lemma reachable_conv:
  "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (u,v) \<in> (arcs_ends G)^* \<inter> (verts G \<times> verts G)"
  apply (auto intro: reachable_in_verts)
  apply (induct rule: rtrancl_induct)
   apply auto
  done

lemma reachable_conv':
  assumes "u \<in> verts G"
  shows "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (u,v) \<in> (arcs_ends G)\<^sup>*" (is "?L = ?R")
proof
  assume "?R" then show "?L" using assms  by induct auto
qed (auto simp: reachable_conv)

end

lemma (in sym_digraph) symmetric_reachable':
  assumes "v \<rightarrow>\<^sup>*\<^bsub>G\<^esub> w" shows "w \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  using sym_arcs assms by (rule symmetric_reachable)

subsection {* Degrees of vertices *}

definition in_arcs :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b set" where
  "in_arcs G v \<equiv> {e \<in> arcs G. head G e = v}"

definition out_arcs :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b set" where
  "out_arcs G v \<equiv> {e \<in> arcs G. tail G e = v}"

definition in_degree :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> nat" where
  "in_degree G v \<equiv> card (in_arcs G v)"

definition out_degree :: "('a, 'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> nat" where
  "out_degree G v \<equiv> card (out_arcs G v)"

lemma (in fin_digraph) finite_in_arcs[intro]:
  "finite (in_arcs G v)"
  unfolding in_arcs_def by auto

lemma (in fin_digraph) finite_out_arcs[intro]:
  "finite (out_arcs G v)"
  unfolding out_arcs_def by auto

lemma in_in_arcs_conv[simp]:
  "e \<in> in_arcs G v \<longleftrightarrow> e \<in> arcs G \<and> head G e = v"
  unfolding in_arcs_def by auto

lemma in_out_arcs_conv[simp]:
  "e \<in> out_arcs G v \<longleftrightarrow> e \<in> arcs G \<and> tail G e = v"
  unfolding out_arcs_def by auto

lemma inout_arcs_arc_simps[simp]:
  assumes "e \<in> arcs G"
  shows "tail G e = u \<Longrightarrow> out_arcs G u \<inter> insert e E = insert e (out_arcs G u \<inter> E)"
        "tail G e \<noteq> u \<Longrightarrow> out_arcs G u \<inter> insert e E = out_arcs G u \<inter> E"
        "out_arcs G u \<inter> {} = {}" (* XXX: should be unnecessary *)
        "head G e = u \<Longrightarrow> in_arcs G u \<inter> insert e E = insert e (in_arcs G u \<inter> E)"
        "head G e \<noteq> u \<Longrightarrow> in_arcs G u \<inter> insert e E = in_arcs G u \<inter> E"
        "in_arcs G u \<inter> {} = {}" (* XXX: should be unnecessary *)
  using assms by auto

lemma in_arcs_int_arcs[simp]: "in_arcs G u \<inter> arcs G = in_arcs G u" and
      out_arcs_int_arcs[simp]: "out_arcs G u \<inter> arcs G = out_arcs G u"
  by auto

lemma in_arcs_in_arcs: "x \<in> in_arcs G u \<Longrightarrow> x \<in> arcs G"
  and out_arcs_in_arcs: "x \<in> out_arcs G u \<Longrightarrow> x \<in> arcs G"
  by (auto simp: in_arcs_def out_arcs_def)

subsection {* Graph operations *}

context pre_digraph begin

definition add_arc :: "'b \<Rightarrow>  ('a,'b) pre_digraph" where
  "add_arc a = \<lparr> verts = verts G \<union> {tail G a, head G a}, arcs = insert a (arcs G), tail = tail G, head = head G \<rparr>"

definition  del_arc :: "'b \<Rightarrow> ('a,'b) pre_digraph" where
  "del_arc a = \<lparr> verts = verts G, arcs = arcs G - {a}, tail = tail G, head = head G \<rparr>"

definition add_vert :: "'a \<Rightarrow>  ('a,'b) pre_digraph" where
  "add_vert v = \<lparr> verts = insert v (verts G), arcs = arcs G, tail = tail G, head = head G \<rparr>"

definition del_vert :: "'a \<Rightarrow>  ('a,'b) pre_digraph" where
  "del_vert v = \<lparr> verts = verts G - {v}, arcs = {a \<in> arcs G. tail G a \<noteq> v \<and> head G a \<noteq> v}, tail = tail G, head = head G \<rparr>"

lemma
  verts_add_arc: "\<lbrakk> tail G a \<in> verts G; head G a \<in> verts G \<rbrakk> \<Longrightarrow> verts (add_arc a) = verts G"  and
  verts_add_arc_conv: "verts (add_arc a) = verts G \<union> {tail G a, head G a}" and
  arcs_add_arc: "arcs (add_arc a) = insert a (arcs G)" and
  tail_add_arc: "tail (add_arc a) = tail G" and
  head_add_arc: "head (add_arc a) = head G"
  by (auto simp: add_arc_def)

lemmas add_arc_simps[simp] = verts_add_arc arcs_add_arc tail_add_arc head_add_arc

lemma
  verts_del_arc: "verts (del_arc a) = verts G"  and
  arcs_del_arc: "arcs (del_arc a) = arcs G - {a}" and
  tail_del_arc: "tail (del_arc a) = tail G" and
  head_del_arc: "head (del_arc a) = head G"
  by (auto simp: del_arc_def)

lemmas del_arc_simps[simp] = verts_del_arc arcs_del_arc tail_del_arc head_del_arc

lemma
    verts_add_vert: "verts (pre_digraph.add_vert G u) = insert u (verts G)" and
    arcs_add_vert: "arcs (pre_digraph.add_vert G u) = arcs G" and
    tail_add_vert: "tail (pre_digraph.add_vert G u) = tail G" and
    head_add_vert: "head (pre_digraph.add_vert G u) = head G"
  by (auto simp: pre_digraph.add_vert_def)

lemmas add_vert_simps = verts_add_vert arcs_add_vert tail_add_vert head_add_vert

lemma
    verts_del_vert: "verts (pre_digraph.del_vert G u) = verts G - {u}" and
    arcs_del_vert: "arcs (pre_digraph.del_vert G u) = {a \<in> arcs G. tail G a \<noteq> u \<and> head G a \<noteq> u}" and
    tail_del_vert: "tail (pre_digraph.del_vert G u) = tail G" and
    head_del_vert: "head (pre_digraph.del_vert G u) = head G" and
    ends_del_vert: "arc_to_ends (pre_digraph.del_vert G u) = arc_to_ends G"
  by (auto simp: pre_digraph.del_vert_def arc_to_ends_def)

lemmas del_vert_simps = verts_del_vert arcs_del_vert tail_del_vert head_del_vert

lemma add_add_arc_collapse[simp]: "pre_digraph.add_arc (add_arc a) a = add_arc a"
  by (auto simp: pre_digraph.add_arc_def)

lemma add_del_arc_collapse[simp]: "pre_digraph.add_arc (del_arc a) a = add_arc a"
  by (auto simp: pre_digraph.verts_add_arc_conv pre_digraph.add_arc_simps)

lemma del_add_arc_collapse[simp]:
  "\<lbrakk> tail G a \<in> verts G; head G a \<in> verts G \<rbrakk> \<Longrightarrow> pre_digraph.del_arc (add_arc a) a = del_arc a"
  by (auto simp: pre_digraph.add_arc_simps pre_digraph.del_arc_simps)

lemma del_del_arc_collapse[simp]: "pre_digraph.del_arc (del_arc a) a = del_arc a"
  by (auto simp: pre_digraph.add_arc_simps pre_digraph.del_arc_simps)

lemma add_arc_commute: "pre_digraph.add_arc (add_arc b) a = pre_digraph.add_arc (add_arc a) b"
  by (auto simp: pre_digraph.add_arc_def)

lemma del_arc_commute: "pre_digraph.del_arc (del_arc b) a = pre_digraph.del_arc (del_arc a) b"
  by (auto simp: pre_digraph.del_arc_def)

lemma del_arc_in: "a \<notin> arcs G \<Longrightarrow> del_arc a = G"
  by (rule pre_digraph.equality) (auto simp: add_arc_def)

lemma in_arcs_add_arc_iff:
  "in_arcs (add_arc a) u = (if head G a = u then insert a (in_arcs G u) else in_arcs G u)"
  by auto

lemma out_arcs_add_arc_iff:
  "out_arcs (add_arc a) u = (if tail G a = u then insert a (out_arcs G u) else out_arcs G u)"
  by auto

lemma in_arcs_del_arc_iff:
  "in_arcs (del_arc a) u = (if head G a = u then in_arcs G u - {a} else in_arcs G u)"
  by auto

lemma out_arcs_del_arc_iff:
  "out_arcs (del_arc a) u = (if tail G a = u then out_arcs G u - {a} else out_arcs G u)"
  by auto

lemma (in wf_digraph) add_arc_in: "a \<in> arcs G \<Longrightarrow> add_arc a = G"
  by (rule pre_digraph.equality) (auto simp: add_arc_def)

end

context wf_digraph begin

lemma wf_digraph_add_arc[intro]:
  "wf_digraph (add_arc a)" by unfold_locales (auto simp: verts_add_arc_conv)

lemma wf_digraph_del_arc[intro]:
  "wf_digraph (del_arc a)" by unfold_locales (auto simp: verts_add_arc_conv)

lemma wf_digraph_del_vert: "wf_digraph (del_vert u)"
  by standard (auto simp: del_vert_simps)

lemma wf_digraph_add_vert: "wf_digraph (add_vert u)"
  by standard (auto simp: add_vert_simps)

lemma del_vert_add_vert:
  assumes "u \<notin> verts G"
  shows "pre_digraph.del_vert (add_vert u) u = G"
  using assms by (intro pre_digraph.equality) (auto simp: pre_digraph.del_vert_def add_vert_def)

end

context fin_digraph begin

lemma in_degree_add_arc_iff:
  "in_degree (add_arc a) u = (if head G a = u \<and> a \<notin> arcs G then in_degree G u + 1 else in_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> in_arcs G u" by (auto simp: in_arcs_def)
  with finite_in_arcs show ?thesis
    unfolding in_degree_def by (auto simp: in_arcs_add_arc_iff intro: arg_cong[where f=card])
qed

lemma out_degree_add_arc_iff:
  "out_degree (add_arc a) u = (if tail G a = u \<and> a \<notin> arcs G then out_degree G u + 1 else out_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> out_arcs G u" by (auto simp: out_arcs_def)
  with finite_out_arcs show ?thesis
    unfolding out_degree_def by (auto simp: out_arcs_add_arc_iff intro: arg_cong[where f=card])
qed

lemma in_degree_del_arc_iff:
  "in_degree (del_arc a) u = (if head G a = u \<and> a \<in> arcs G then in_degree G u - 1 else in_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> in_arcs G u" by (auto simp: in_arcs_def)
  with finite_in_arcs show ?thesis
    unfolding in_degree_def by (auto simp: in_arcs_del_arc_iff intro: arg_cong[where f=card])
qed

lemma out_degree_del_arc_iff:
  "out_degree (del_arc a) u = (if tail G a = u \<and> a \<in> arcs G then out_degree G u - 1 else out_degree G u)"
proof -
  have "a \<notin> arcs G \<Longrightarrow> a \<notin> out_arcs G u" by (auto simp: out_arcs_def)
  with finite_out_arcs show ?thesis
    unfolding out_degree_def by (auto simp: out_arcs_del_arc_iff intro: arg_cong[where f=card])
qed

lemma fin_digraph_del_vert: "fin_digraph (del_vert u)"
  by standard (auto simp: del_vert_simps)

lemma fin_digraph_del_arc: "fin_digraph (del_arc a)"
  by standard (auto simp: del_vert_simps)

end

end


(* $Id$ *)
(*<*)
theory HEAP1Sanity
imports HEAP1
begin
(*>*)
(* ================================================================= *)
section {* Proof of some properties of interest *}
(* ================================================================= *)

text {* In this section we prove some properties about the state invariant
        and operations that should hold. These kind of properties are problem
        specific and are useful to test the usefulness of the model (i.e. it's pragmatics).
        They are quite important, since we could prove something useless that
        is feasible and sound\footnote{This has actually happened in a first version
        of the (wrong) model. That is we build the model right, but we didn't build the right model!}!
      *}

(*------------------------------------------------------------------------*)
subsection {* Invariant testing *}
(*------------------------------------------------------------------------*)

text {* First, we test the Isabelle maps are good enough for our need to represent
        VDM maps in Isabelle. It would be useful to use the Isabelle value feature
        wrapping values with predicates like the invariant or the post condition.

        Unfortunately, they are not enumerable (? TODO: Or just code not proved yet?).
        Instead, we prove that the invariant holds (and fails to hold) for certain
        values. This performs both positive and negative testing on the invariant.
        Proofs are automatic by auto.
      *}

value "[0 \<mapsto> 4, 6 \<mapsto> 11]"

definition
  F1_ex :: "F1"
where
  "F1_ex \<equiv> [0 \<mapsto> 4, 6 \<mapsto> 11]"

definition
  F1_ex_inv :: "F1 \<Rightarrow> bool"
where
  "F1_ex_inv f \<equiv> F1_inv f"

lemmas F1_ex_inv_defs = F1_ex_inv_def F1_inv_defs F1_ex_def

(*------------------------------------------------------------------------*)
subsection {* Operations properties *}
(*------------------------------------------------------------------------*)

text {* Next, we prove some useful properties that operators at level 1 must
        satisfy. Incidentally, the proof of these properties helped hightlight
        various (general) lemmas about VDM maps missing in Isabelle.
      *}

(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
subsubsection {* NEW 1 shrinks the memory  *}
(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

text {* Upon memory allocation the resulting available memory \textbf{must} shrink.
        At first we tried something hard that often happens during proof:~to prove a non-theorem (!)
        That is, to show that @{text "f1' \<subseteq>\<^sub>m f1"}, which is of course false for the greater case.
        Nonetheless, this was useful to identify key missing lemmas for VDM maps, which
        were added to our library in theory VDMMaps.

        In normal practice, it's important to use nitpick and quickcheck to try and invalidate
        our theorem by finding counter examples:~these tools are much better at spotting non-theorems
        (with complicated assumptions) than normal users.

        Our current version states that the resulting map must be different from the original
        (i.e. the allocation operation does something), and that its result leads to a subset
        of available locations (@{text "locs f1' \<subset> locs f1"}). Incidentally, @{term "locs f1"}
        is the retrieve
        function between level 0 and 1.

        Proving proper subset is divided in two cases as subset and not equal. In these proofs,
        we decided to follow some advice given by Alan Bundy:~``it is often useful [for learning/generalising]
        to have more than one proof for the same goal''. We decided to take his suggestion and produce
        such variety, and in a truly novel form rather than just an artificial ``reproving''. Leo
        proved these goals as:~i)~``head-on'', i.e.~expanding and simplifying as we went;~ii)~``planned'', i.e~having
        an idea of what we wanted to achieve at each step and convincing Isabelle (often with extra lemmas)
        along the way;~iii)~``algebraically'', i.e.~having lemmas that chisel away operators to achieve
        what Alan calls ``get rid of difficult operators''\footnote{This is a reference to trick by
        mathematicians trying to avoid complex operators. For instance, instead of proving the square
        root (e.g @{text "\<surd>2 = x"}) of something they get rid of the square root by squaring both sides (e.g. @{text "2=x\<^sup>2"}).}.

        Moreover, independently, Iain is doing proofs by trying to ``explain'' the proof
        through Isar's declarative features to unpick the problem in yet another format. We also set
        it as a task for an MSc student that was not exposed to proof before (i.e.~what we could expect
        of a well educated and motivated engineer):~she (Nataliia) is doing them on her own after discussion and
        advice from Leo. The result~\cite{NataliiaMSc2013} is a pedagogical explanation of the proof process in
        line with Naur's~\cite{NaurNineQueens} from the perspective of a non-expert, well trained engineer.
        This last interaction could be taken us an expert training an engineer to
        handle/tackle proof and collecting the effort. Both Nataliia and Leo are running the proofs
        through Andrius' Isabelle/Eclipse-PP\footnote{Our Eclipse-based proof process (PP) collection
        environment that wraps around Isabelle's kernel for ``tapping the wire'' for information. It
        can be downloaded at \url{https://github.com/andriusvelykis/proofprocess}.}~\cite{Velykis12,AndriusPhD},
        which captures the proof process by having a history log
        and encoding of attempts and features according to our MWhy models~\cite{ai4fm-shanghai}. % ,Dagstuhl??}.

        Next, our aim is to study this data and try to infer general patterns from both PP data for comparison
        and fine tuning for learning techniques to take over~\cite{Grov-12-slides,GGrov-SL,KatyaMLPG} %~\cite{Grov-BN1752}
      *}

context level1_new
begin

definition
  PO_new1_postcondition_state_changes :: "nat \<Rightarrow> bool"
where
  "PO_new1_postcondition_state_changes r \<equiv> (\<forall> f1' . new1_postcondition f1' r \<longrightarrow> f1' \<noteq> f1)"

definition
  PO_new1_postcondition_state_locs_subset :: "nat \<Rightarrow> bool"
where
  "PO_new1_postcondition_state_locs_subset r \<equiv> (\<forall> f1' . new1_postcondition f1' r \<longrightarrow> locs f1' \<subseteq> locs f1)"

definition
  PO_new1_postcondition_diff_f_locs :: "nat \<Rightarrow> bool"
where
  "PO_new1_postcondition_diff_f_locs r \<equiv> (\<forall> f1' . new1_postcondition f1' r \<longrightarrow> locs f1' \<noteq> locs f1)"

definition
  PO_new1_postcondition_shrinks_f_locs :: "nat \<Rightarrow> bool"
where
  "PO_new1_postcondition_shrinks_f_locs r \<equiv> (\<forall> f1' . new1_postcondition f1' r \<longrightarrow> locs f1' \<subset> locs f1)"

definition
  PO_new1_postcondition_f_equiv :: "nat \<Rightarrow> bool"
where
  "PO_new1_postcondition_f_equiv r \<equiv> (\<forall> f1' . new1_postcondition f1' r \<and> the(f1 r) = s1 \<longrightarrow> {r} -\<triangleleft> f1' = {r} -\<triangleleft> f1)"

end

(*------------------------------------------------------------------------*)
(* NEW1(n); DISPOSE(r, n) = Id *)

definition
  PO_new1_dispose1_identity_post :: "F1 \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "PO_new1_dispose1_identity_post f n r \<equiv> (\<forall> f' f'' . new1_post f n f' r \<and> dispose1_post f' r n f'' \<and> F1_inv f \<and> nat1 n \<longrightarrow> f = f'')"

definition
  PO_new1_dispose1_identity_pre :: "F1 \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "PO_new1_dispose1_identity_pre f n r \<equiv> (\<forall> f' . new1_pre f r \<and> new1_post f n f' r \<and> F1_inv f \<and> nat1 n \<longrightarrow> dispose1_pre f r n)"

(*<*)
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_bin_plus_assoc
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

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

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_prop_29
  imports "../../Test_Base"
begin

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

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

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

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

theorem property0 :
  "((rev (qrev y (nil2))) = y)"
  oops

end


(*  Title:       Primitive recursive function
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

section \<open>Primitive recursive functions\<close>

theory PRecFun imports CPair
begin

text \<open>
  This theory contains definition of the primitive recursive functions.
\<close>

subsection \<open>Basic definitions\<close>

primrec
  PrimRecOp :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat)"
where
  "PrimRecOp g h 0 x  = g x"
| "PrimRecOp g h (Suc y) x = h y (PrimRecOp g h y x) x"

primrec
  PrimRecOp_last :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat)"
where
  "PrimRecOp_last g h x 0  = g x"
| "PrimRecOp_last g h x (Suc y)= h x (PrimRecOp_last g h x y) y"

primrec
  PrimRecOp1 :: "nat \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)"
where
  "PrimRecOp1 a h 0 = a"
| "PrimRecOp1 a h (Suc y) = h y (PrimRecOp1 a h y)"

inductive_set
  PrimRec1 :: "(nat \<Rightarrow> nat) set" and
  PrimRec2 :: "(nat \<Rightarrow> nat \<Rightarrow> nat) set" and
  PrimRec3 :: "(nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat) set"
where
  zero: "(\<lambda> x. 0) \<in> PrimRec1"
  | suc:   "Suc \<in> PrimRec1"
  | id1_1: "(\<lambda> x. x) \<in> PrimRec1"
  | id2_1: "(\<lambda> x y. x) \<in> PrimRec2"
  | id2_2: "(\<lambda> x y. y) \<in> PrimRec2"
  | id3_1: "(\<lambda> x y z. x) \<in> PrimRec3"
  | id3_2: "(\<lambda> x y z. y) \<in> PrimRec3"
  | id3_3: "(\<lambda> x y z. z) \<in> PrimRec3"
  | comp1_1: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x)) \<in> PrimRec1"
  | comp1_2: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. f (g x y)) \<in> PrimRec2"
  | comp1_3: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. f (g x y z)) \<in> PrimRec3"
  | comp2_1: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec1; h \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x) (h x)) \<in> PrimRec1"
  | comp3_1: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec1; h \<in> PrimRec1; k \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x) (h x) (k x)) \<in> PrimRec1"
  | comp2_2: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec2; h \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. f (g x y) (h x y)) \<in> PrimRec2"
  | comp2_3: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec3; h \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. f (g x y z) (h x y z)) \<in> PrimRec3"
  | comp3_2: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec2; h \<in> PrimRec2; k \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. f (g x y) (h x y) (k x y)) \<in> PrimRec2"
  | comp3_3: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec3; h \<in> PrimRec3; k \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. f (g x y z) (h x y z) (k x y z)) \<in> PrimRec3"
  | prim_rec: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec3\<rbrakk> \<Longrightarrow> PrimRecOp g h \<in> PrimRec2"

lemmas pr_zero = PrimRec1_PrimRec2_PrimRec3.zero
lemmas pr_suc = PrimRec1_PrimRec2_PrimRec3.suc
lemmas pr_id1_1 = PrimRec1_PrimRec2_PrimRec3.id1_1
lemmas pr_id2_1 = PrimRec1_PrimRec2_PrimRec3.id2_1
lemmas pr_id2_2 = PrimRec1_PrimRec2_PrimRec3.id2_2
lemmas pr_id3_1 = PrimRec1_PrimRec2_PrimRec3.id3_1
lemmas pr_id3_2 = PrimRec1_PrimRec2_PrimRec3.id3_2
lemmas pr_id3_3 = PrimRec1_PrimRec2_PrimRec3.id3_3
lemmas pr_comp1_1 = PrimRec1_PrimRec2_PrimRec3.comp1_1
lemmas pr_comp1_2 = PrimRec1_PrimRec2_PrimRec3.comp1_2
lemmas pr_comp1_3 = PrimRec1_PrimRec2_PrimRec3.comp1_3
lemmas pr_comp2_1 = PrimRec1_PrimRec2_PrimRec3.comp2_1
lemmas pr_comp2_2 = PrimRec1_PrimRec2_PrimRec3.comp2_2
lemmas pr_comp2_3 = PrimRec1_PrimRec2_PrimRec3.comp2_3
lemmas pr_comp3_1 = PrimRec1_PrimRec2_PrimRec3.comp3_1
lemmas pr_comp3_2 = PrimRec1_PrimRec2_PrimRec3.comp3_2
lemmas pr_comp3_3 = PrimRec1_PrimRec2_PrimRec3.comp3_3
lemmas pr_rec = PrimRec1_PrimRec2_PrimRec3.prim_rec

ML_file \<open>Utils.ML\<close>

named_theorems prec

method_setup prec0 = \<open>
  Attrib.thms >> (fn ths => fn ctxt => Method.METHOD (fn facts =>
    HEADGOAL (prec0_tac ctxt (facts @ Named_Theorems.get ctxt @{named_theorems prec}))))
\<close> "apply primitive recursive functions"

lemmas [prec] = pr_zero pr_suc pr_id1_1 pr_id2_1 pr_id2_2 pr_id3_1 pr_id3_2 pr_id3_3

lemma pr_swap: "f \<in> PrimRec2 \<Longrightarrow> (\<lambda> x y. f y x) \<in> PrimRec2" by prec0

theorem pr_rec_scheme: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec3; \<forall> x. f 0 x = g x; \<forall> x y. f (Suc y) x = h y (f y x) x \<rbrakk> \<Longrightarrow> f \<in> PrimRec2"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  assume h_is_pr: "h \<in> PrimRec3"
  assume f_at_0: "\<forall> x. f 0 x = g x"
  assume f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
  from f_at_0 f_at_Suc have "\<And> x y. f y x  = PrimRecOp g h y x" by (induct_tac y, simp_all)
  then have "f = PrimRecOp g h" by (simp add: ext)
  with g_is_pr h_is_pr show ?thesis by (simp add: pr_rec)
qed

lemma op_plus_is_pr [prec]: "(\<lambda> x y. x + y) \<in> PrimRec2"
proof (rule pr_swap)
 show "(\<lambda> x y. y+x) \<in> PrimRec2"
  proof -
    have S1: "PrimRecOp (\<lambda> x. x) (\<lambda> x y z. Suc y) \<in> PrimRec2"
    proof (rule pr_rec)
      show "(\<lambda> x. x) \<in> PrimRec1" by (rule pr_id1_1)
    next
      show "(\<lambda> x y z. Suc y) \<in> PrimRec3" by prec0
    qed
    have "(\<lambda> x y. y+x) = PrimRecOp (\<lambda> x. x) (\<lambda> x y z. Suc y)" (is "_ = ?f")
    proof -
      have "\<And> x y. (?f y x = y + x)" by (induct_tac y, auto)
      thus ?thesis by (simp add: ext)
    qed
    with S1 show ?thesis by simp
  qed
qed

lemma op_mult_is_pr [prec]: "(\<lambda> x y. x*y) \<in> PrimRec2"
proof (rule pr_swap)
 show "(\<lambda> x y. y*x) \<in> PrimRec2"
  proof -
    have S1: "PrimRecOp (\<lambda> x. 0) (\<lambda> x y z. y+z) \<in> PrimRec2"
    proof (rule pr_rec)
      show "(\<lambda> x. 0) \<in> PrimRec1" by (rule pr_zero)
    next
      show "(\<lambda> x y z. y+z) \<in> PrimRec3" by prec0
    qed
    have "(\<lambda> x y. y*x) = PrimRecOp (\<lambda> x. 0) (\<lambda> x y z. y+z)" (is "_ = ?f")
    proof -
      have "\<And> x y. (?f y x = y * x)" by (induct_tac y, auto)
      thus ?thesis by (simp add: ext)
    qed
    with S1 show ?thesis by simp
  qed
qed

lemma const_is_pr: "(\<lambda> x. (n::nat)) \<in> PrimRec1"
proof (induct n)
  show "(\<lambda> x. 0) \<in> PrimRec1" by (rule pr_zero)
next
  fix n assume "(\<lambda> x. n) \<in> PrimRec1"
  then show "(\<lambda> x. Suc n) \<in> PrimRec1" by prec0
qed

lemma const_is_pr_2: "(\<lambda> x y. (n::nat)) \<in> PrimRec2"
proof (rule pr_comp1_2 [where ?f="%x.(n::nat)" and ?g="%x y. x"])
  show "(\<lambda> x. n) \<in> PrimRec1" by (rule const_is_pr)
next
  show "(\<lambda> x y. x) \<in> PrimRec2" by (rule pr_id2_1)
qed

lemma const_is_pr_3: "(\<lambda> x y z. (n::nat)) \<in> PrimRec3"
proof (rule pr_comp1_3 [where ?f="%x.(n::nat)" and ?g="%x y z. x"])
  show "(\<lambda> x. n) \<in> PrimRec1" by (rule const_is_pr)
next
  show "(\<lambda> x y z. x) \<in> PrimRec3" by (rule pr_id3_1)
qed

theorem pr_rec_last: "\<lbrakk>g \<in> PrimRec1; h \<in> PrimRec3\<rbrakk> \<Longrightarrow> PrimRecOp_last g h \<in> PrimRec2"
proof -
  assume A1: "g \<in> PrimRec1"
  assume A2: "h \<in> PrimRec3"
  let ?h1 = "\<lambda> x y z. h z y x"
  from A2 pr_id3_3 pr_id3_2 pr_id3_1 have h1_is_pr: "?h1 \<in> PrimRec3" by (rule pr_comp3_3)
  let ?f1 = "PrimRecOp g ?h1"
  from A1 h1_is_pr have f1_is_pr: "?f1 \<in> PrimRec2" by (rule pr_rec)
  let ?f = "\<lambda> x y. ?f1 y x"
  from f1_is_pr have f_is_pr: "?f \<in> PrimRec2" by (rule pr_swap)
  have "\<And> x y. ?f x y = PrimRecOp_last g h x y" by (induct_tac y, simp_all)
  then have "?f = PrimRecOp_last g h" by (simp add: ext)
  with f_is_pr show ?thesis by simp
qed

theorem pr_rec1: "h \<in> PrimRec2 \<Longrightarrow> PrimRecOp1 (a::nat) h \<in> PrimRec1"
proof -
  assume A1: "h \<in> PrimRec2"
  let ?g = "(\<lambda> x. a)"
  have g_is_pr: "?g \<in> PrimRec1" by (rule const_is_pr)
  let ?h1 = "(\<lambda> x y z. h x y)"
  from A1 have h1_is_pr: "?h1 \<in> PrimRec3" by prec0
  let ?f1 = "PrimRecOp ?g ?h1"
  from g_is_pr h1_is_pr have f1_is_pr: "?f1 \<in> PrimRec2" by (rule pr_rec)
  let ?f = "(\<lambda> x. ?f1 x 0)"
  from f1_is_pr pr_id1_1 pr_zero have f_is_pr: "?f \<in> PrimRec1" by (rule pr_comp2_1)
  have "\<And> y. ?f y = PrimRecOp1 a h y" by (induct_tac y, auto)
  then have "?f = PrimRecOp1 a h" by (simp add: ext)
  with f_is_pr show ?thesis by (auto)
qed

theorem pr_rec1_scheme: "\<lbrakk> h \<in> PrimRec2; f 0 = a; \<forall> y. f (Suc y) = h y (f y) \<rbrakk> \<Longrightarrow> f \<in> PrimRec1"
proof -
  assume h_is_pr: "h \<in> PrimRec2"
  assume f_at_0: "f 0 = a"
  assume f_at_Suc: "\<forall> y. f (Suc y) = h y (f y)"
  from f_at_0 f_at_Suc have "\<And> y. f y  = PrimRecOp1 a h y" by (induct_tac y, simp_all)
  then have "f = PrimRecOp1 a h" by (simp add: ext)
  with h_is_pr show ?thesis by (simp add: pr_rec1)
qed

lemma pred_is_pr: "(\<lambda> x. x - (1::nat)) \<in> PrimRec1"
proof -
  have S1: "PrimRecOp1 0 (\<lambda> x y. x) \<in> PrimRec1"
  proof (rule pr_rec1)
    show "(\<lambda> x y. x) \<in> PrimRec2" by (rule pr_id2_1)
  qed
  have "(\<lambda> x. x-(1::nat)) = PrimRecOp1 0 (\<lambda> x y. x)" (is "_ = ?f")
  proof -
    have "\<And> x. (?f x = x-(1::nat))" by (induct_tac x, auto)
    thus ?thesis by (simp add: ext)
  qed
  with S1 show ?thesis by simp
qed

lemma op_sub_is_pr [prec]: "(\<lambda> x y. x-y) \<in> PrimRec2"
proof (rule pr_swap)
 show "(\<lambda> x y. y - x) \<in> PrimRec2"
  proof -
    have S1: "PrimRecOp (\<lambda> x. x) (\<lambda> x y z.  y-(1::nat)) \<in> PrimRec2"
    proof (rule pr_rec)
      show "(\<lambda> x. x) \<in> PrimRec1" by (rule pr_id1_1)
    next
      from pred_is_pr pr_id3_2 show "(\<lambda> x y z. y-(1::nat)) \<in> PrimRec3" by (rule pr_comp1_3)
    qed
    have "(\<lambda> x y. y - x) = PrimRecOp (\<lambda> x. x) (\<lambda> x y z.  y-(1::nat))" (is "_ = ?f")
    proof -
      have "\<And> x y. (?f y x = x - y)" by (induct_tac y, auto)
      thus ?thesis by (simp add: ext)
    qed
    with S1 show ?thesis by simp
  qed
qed

lemmas [prec] =
  const_is_pr [of 0] const_is_pr_2 [of 0] const_is_pr_3 [of 0]
  const_is_pr [of 1] const_is_pr_2 [of 1] const_is_pr_3 [of 1]
  const_is_pr [of 2] const_is_pr_2 [of 2] const_is_pr_3 [of 2]

definition
  sgn1 :: "nat \<Rightarrow> nat" where
  "sgn1 x = (case x of 0 \<Rightarrow> 0 | Suc y \<Rightarrow> 1)"

definition
  sgn2 :: "nat \<Rightarrow> nat" where
  "sgn2 x \<equiv> (case x of 0 \<Rightarrow> 1 | Suc y \<Rightarrow> 0)"

definition
  abs_of_diff :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "abs_of_diff = (\<lambda> x y. (x - y) + (y - x))"

lemma sgn1_nz_impl_arg_pos: "sgn1 x \<noteq> 0 \<Longrightarrow> x > 0" by (cases x) auto
lemma sgn1_zero_impl_arg_zero: "sgn1 x = 0 \<Longrightarrow> x = 0" by (cases x) auto
lemma sgn2_nz_impl_arg_zero: "sgn2 x \<noteq> 0 \<Longrightarrow> x = 0" by (cases x) auto
lemma sgn2_zero_impl_arg_pos: "sgn2 x = 0 \<Longrightarrow> x > 0" by (cases x) auto

lemma sgn1_nz_eq_arg_pos: "(sgn1 x \<noteq> 0) = (x > 0)" by (cases x) auto
lemma sgn1_zero_eq_arg_zero: "(sgn1 x = 0) = (x = 0)" by (cases x) auto
lemma sgn2_nz_eq_arg_pos: "(sgn2 x \<noteq> 0) = (x = 0)" by (cases x) auto
lemma sgn2_zero_eq_arg_zero: "(sgn2 x = 0) = (x > 0)" by (cases x) auto

lemma sgn1_pos_eq_one: "sgn1 x > 0 \<Longrightarrow> sgn1 x = 1" by (cases x) auto
lemma sgn2_pos_eq_one: "sgn2 x > 0 \<Longrightarrow> sgn2 x = 1" by (cases x) auto

lemma sgn2_eq_1_sub_arg: "sgn2 = (\<lambda> x. 1 - x)"
proof (rule ext)
  fix x show "sgn2 x = 1 - x" by (cases x) auto
qed

lemma sgn1_eq_1_sub_sgn2: "sgn1  = (\<lambda> x. 1 - (sgn2 x))"
proof
  fix x show "sgn1 x = 1 - sgn2 x"
  proof -
    have "1- sgn2 x = 1 - (1 - x)" by (simp add: sgn2_eq_1_sub_arg)
    then show ?thesis by (simp add: sgn1_def, cases x, auto)
  qed
qed

lemma sgn2_is_pr [prec]: "sgn2 \<in> PrimRec1"
proof -
  have "(\<lambda> x. 1 - x) \<in> PrimRec1" by prec0
  thus ?thesis by (simp add: sgn2_eq_1_sub_arg)
qed

lemma sgn1_is_pr [prec]: "sgn1 \<in> PrimRec1"
proof -
  from sgn2_is_pr have "(\<lambda> x. 1 - (sgn2 x)) \<in> PrimRec1" by prec0
  thus ?thesis by (simp add: sgn1_eq_1_sub_sgn2)
qed

lemma abs_of_diff_is_pr [prec]: "abs_of_diff \<in> PrimRec2" unfolding abs_of_diff_def by prec0

lemma abs_of_diff_eq: "(abs_of_diff x y = 0) = (x = y)" by (simp add: abs_of_diff_def, arith)

lemma sf_is_pr [prec]: "sf \<in> PrimRec1"
proof -
  have S1: "PrimRecOp1 0 (\<lambda> x y. y + x + 1) \<in> PrimRec1"
  proof (rule pr_rec1)
    show "(\<lambda> x y. y + x + 1) \<in> PrimRec2" by prec0
  qed
  have "(\<lambda> x. sf x) = PrimRecOp1 0 (\<lambda> x y. y + x + 1)" (is "_ = ?f")
  proof -
    have "\<And> x. (?f x = sf x)"
    proof (induct_tac x)
      show "?f 0 = sf 0" by (simp add: sf_at_0)
    next
      fix x assume "?f x = sf x"
      with sf_at_Suc show "?f (Suc x) = sf (Suc x)"  by auto
    qed
    thus ?thesis by (simp add: ext)
  qed
  with S1 show ?thesis by simp
qed

lemma c_pair_is_pr [prec]: "c_pair \<in> PrimRec2"
proof -
  have "c_pair = (\<lambda> x y. sf (x+y) + x)" by (simp add: c_pair_def ext)
  moreover from sf_is_pr have "(\<lambda> x y. sf (x+y) + x) \<in> PrimRec2" by prec0
  ultimately show ?thesis by (simp)
qed

lemma if_is_pr: "\<lbrakk> p \<in> PrimRec1; q1 \<in> PrimRec1; q2 \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. if (p x = 0) then (q1 x) else (q2 x)) \<in> PrimRec1"
proof -
  have if_as_pr: "(\<lambda> x. if (p x = 0) then (q1 x) else (q2 x)) = (\<lambda> x. (sgn2 (p x)) * (q1 x) + (sgn1 (p x)) * (q2 x))"
  proof (rule ext)
    fix x show "(if (p x = 0) then (q1 x) else (q2 x)) = (sgn2 (p x)) * (q1 x) + (sgn1 (p x)) * (q2 x)" (is "?left = ?right")
    proof cases
      assume A1: "p x = 0"
      then have S1: "?left = q1 x" by simp
      from A1 have S2: "?right = q1 x" by simp
      from S1 S2 show ?thesis by simp
    next
      assume A2: "p x \<noteq> 0"
      then have S3: "p x > 0" by simp
      then show ?thesis by simp
    qed
  qed
  assume "p \<in> PrimRec1" and "q1 \<in> PrimRec1" and "q2 \<in> PrimRec1"
  then have "(\<lambda> x. (sgn2 (p x)) * (q1 x) + (sgn1 (p x)) * (q2 x)) \<in> PrimRec1" by prec0
  with if_as_pr show ?thesis by simp
qed

lemma if_eq_is_pr [prec]: "\<lbrakk> p1 \<in> PrimRec1; p2 \<in> PrimRec1; q1 \<in> PrimRec1; q2 \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. if (p1 x = p2 x) then (q1 x) else (q2 x)) \<in> PrimRec1"
proof -
  have S1: "(\<lambda> x. if (p1 x = p2 x) then (q1 x) else (q2 x)) = (\<lambda> x. if (abs_of_diff (p1 x) (p2 x) = 0) then (q1 x) else (q2 x))" (is "?L = ?R") by (simp add: abs_of_diff_eq)
  assume A1: "p1 \<in> PrimRec1" and A2: "p2 \<in> PrimRec1"
  with abs_of_diff_is_pr have S2: "(\<lambda> x. abs_of_diff (p1 x) (p2 x)) \<in> PrimRec1" by prec0
  assume "q1 \<in> PrimRec1" and "q2 \<in> PrimRec1"
  with S2 have "?R \<in> PrimRec1" by (rule if_is_pr)
  with S1 show ?thesis by simp
qed

lemma if_is_pr2 [prec]: "\<lbrakk> p \<in> PrimRec2; q1 \<in> PrimRec2; q2 \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. if (p x y = 0) then (q1 x y) else (q2 x y)) \<in> PrimRec2"
proof -
  have if_as_pr: "(\<lambda> x y. if (p x y = 0) then (q1 x y) else (q2 x y)) = (\<lambda> x y. (sgn2 (p x y)) * (q1 x y) + (sgn1 (p x y)) * (q2 x y))"
  proof (rule ext, rule ext)
    fix x fix y show "(if (p x y = 0) then (q1 x y) else (q2 x y)) = (sgn2 (p x y)) * (q1 x y) + (sgn1 (p x y)) * (q2 x y)" (is "?left = ?right")
    proof cases
      assume A1: "p x y = 0"
      then have S1: "?left = q1 x y" by simp
      from A1 have S2: "?right = q1 x y" by simp
      from S1 S2 show ?thesis by simp
    next
      assume A2: "p x y \<noteq> 0"
      then have S3: "p x y > 0" by simp
      then show ?thesis by simp
    qed
  qed
  assume "p \<in> PrimRec2" and "q1 \<in> PrimRec2" and "q2 \<in> PrimRec2"
  then have "(\<lambda> x y. (sgn2 (p x y)) * (q1 x y) + (sgn1 (p x y)) * (q2 x y)) \<in> PrimRec2" by prec0
  with if_as_pr show ?thesis by simp
qed

lemma if_eq_is_pr2: "\<lbrakk> p1 \<in> PrimRec2; p2 \<in> PrimRec2; q1 \<in> PrimRec2; q2 \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. if (p1 x y = p2 x y) then (q1 x y) else (q2 x y)) \<in> PrimRec2"
proof -
  have S1: "(\<lambda> x y. if (p1 x y = p2 x y) then (q1 x y) else (q2 x y)) = (\<lambda> x y. if (abs_of_diff (p1 x y) (p2 x y) = 0) then (q1 x y) else (q2 x y))" (is "?L = ?R") by (simp add: abs_of_diff_eq)
  assume A1: "p1 \<in> PrimRec2" and A2: "p2 \<in> PrimRec2"
  with abs_of_diff_is_pr have S2: "(\<lambda> x y. abs_of_diff (p1 x y) (p2 x y)) \<in> PrimRec2" by prec0
  assume "q1 \<in> PrimRec2" and "q2 \<in> PrimRec2"
  with S2 have "?R \<in> PrimRec2" by (rule if_is_pr2)
  with S1 show ?thesis by simp
qed

lemma if_is_pr3 [prec]: "\<lbrakk> p \<in> PrimRec3; q1 \<in> PrimRec3; q2 \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. if (p x y z = 0) then (q1 x y z) else (q2 x y z)) \<in> PrimRec3"
proof -
  have if_as_pr: "(\<lambda> x y z. if (p x y z = 0) then (q1 x y z) else (q2 x y z)) = (\<lambda> x y z. (sgn2 (p x y z)) * (q1 x y z) + (sgn1 (p x y z)) * (q2 x y z))"
  proof (rule ext, rule ext, rule ext)
    fix x fix y fix z show "(if (p x y z = 0) then (q1 x y z) else (q2 x y z)) = (sgn2 (p x y z)) * (q1 x y z) + (sgn1 (p x y z)) * (q2 x y z)" (is "?left = ?right")
    proof cases
      assume A1: "p x y z = 0"
      then have S1: "?left = q1 x y z" by simp
      from A1 have S2: "?right = q1 x y z" by simp
      from S1 S2 show ?thesis by simp
    next
      assume A2: "p x y z \<noteq> 0"
      then have S3: "p x y z > 0" by simp
      then show ?thesis by simp
    qed
  qed
  assume "p \<in> PrimRec3" and "q1 \<in> PrimRec3" and "q2 \<in> PrimRec3"
  then have "(\<lambda> x y z. (sgn2 (p x y z)) * (q1 x y z) + (sgn1 (p x y z)) * (q2 x y z)) \<in> PrimRec3"
    by prec0
  with if_as_pr show ?thesis by simp
qed

lemma if_eq_is_pr3: "\<lbrakk> p1 \<in> PrimRec3; p2 \<in> PrimRec3; q1 \<in> PrimRec3; q2 \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. if (p1 x y z = p2 x y z) then (q1 x y z) else (q2 x y z)) \<in> PrimRec3"
proof -
  have S1: "(\<lambda> x y z. if (p1 x y z = p2 x y z) then (q1 x y z) else (q2 x y z)) = (\<lambda> x y z. if (abs_of_diff (p1 x y z) (p2 x y z) = 0) then (q1 x y z) else (q2 x y z))" (is "?L = ?R") by (simp add: abs_of_diff_eq)
  assume A1: "p1 \<in> PrimRec3" and A2: "p2 \<in> PrimRec3"
  with abs_of_diff_is_pr have S2: "(\<lambda> x y z. abs_of_diff (p1 x y z) (p2 x y z)) \<in> PrimRec3"
    by prec0
  assume "q1 \<in> PrimRec3" and "q2 \<in> PrimRec3"
  with S2 have "?R \<in> PrimRec3" by (rule if_is_pr3)
  with S1 show ?thesis by simp
qed

ML \<open>
fun get_if_by_index 1 = @{thm if_eq_is_pr}
  | get_if_by_index 2 = @{thm if_eq_is_pr2}
  | get_if_by_index 3 = @{thm if_eq_is_pr3}
  | get_if_by_index _ = raise BadArgument

fun if_comp_tac ctxt = SUBGOAL (fn (t, i) =>
  let
    val t = extract_trueprop_arg (Logic.strip_imp_concl t)
    val (t1, t2) = extract_set_args t
    val n2 =
      let
        val Const(s, _) = t2
      in
        get_num_by_set s
      end
    val (name, _, n1) = extract_free_arg t1
  in
    if name = @{const_name If} then
      resolve_tac ctxt [get_if_by_index n2] i
    else
      let
        val comp = get_comp_by_indexes (n1, n2)
      in
        Rule_Insts.res_inst_tac ctxt
          [((("f", 0), Position.none), Variable.revert_fixed ctxt name)] [] comp i
      end
  end
  handle BadArgument => no_tac)

fun prec_tac ctxt facts i =
  Method.insert_tac ctxt facts i THEN
  REPEAT (resolve_tac ctxt [@{thm const_is_pr}, @{thm const_is_pr_2}, @{thm const_is_pr_3}] i ORELSE
    assume_tac ctxt i ORELSE if_comp_tac ctxt i)
\<close>

method_setup prec = \<open>
  Attrib.thms >> (fn ths => fn ctxt => Method.METHOD (fn facts =>
    HEADGOAL (prec_tac ctxt (facts @ Named_Theorems.get ctxt @{named_theorems prec}))))
\<close> "apply primitive recursive functions"

subsection \<open>Bounded least operator\<close>

definition
  b_least :: "(nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)" where
  "b_least f x \<equiv> (Least (%y. y = x \<or> (y < x \<and> (f x y) \<noteq> 0)))"

definition
  b_least2 :: "(nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat)" where
  "b_least2 f x y \<equiv> (Least (%z. z = y \<or> (z < y \<and> (f x z) \<noteq> 0)))"

lemma b_least_aux1: "b_least f x = x \<or> (b_least f x < x \<and> (f x (b_least f x)) \<noteq> 0)"
proof -
  let ?P = "%y. y = x \<or> (y < x \<and> (f x y) \<noteq> 0)"
  have "?P x" by simp
  then have "?P (Least ?P)" by (rule LeastI)
  thus ?thesis by (simp add: b_least_def)
qed

lemma b_least_le_arg: "b_least f x \<le> x"
proof -
  have "b_least f x = x \<or> (b_least f x < x \<and> (f x (b_least f x)) \<noteq> 0)" by (rule b_least_aux1)
  from this show ?thesis by (arith)
qed

lemma less_b_least_impl_zero: "y < b_least f x \<Longrightarrow> f x y = 0"
proof -
  assume A1: "y < b_least f x" (is "_ < ?b")
  have "b_least f x \<le> x" by (rule b_least_le_arg)
  with A1 have S1: "y < x" by simp
  with A1 have " y < (Least (%y. y = x \<or> (y < x \<and> (f x y) \<noteq> 0)))" by (simp add: b_least_def)
  then have "\<not> (y = x \<or> (y < x \<and> (f x y) \<noteq> 0))" by (rule not_less_Least)
  with S1 show ?thesis by simp
qed

lemma nz_impl_b_least_le: "(f x y) \<noteq> 0 \<Longrightarrow> (b_least f x) \<le> y"
proof (rule ccontr)
  assume A1: "f x y \<noteq> 0"
  assume "\<not> b_least f x \<le> y"
  then have "y < b_least f x" by simp
  with A1 show False by (simp add: less_b_least_impl_zero)
qed

lemma b_least_less_impl_nz: "b_least f x < x \<Longrightarrow> f x (b_least f x) \<noteq> 0"
proof -
  assume A1: "b_least f x < x"
  have "b_least f x = x \<or> (b_least f x < x \<and> (f x (b_least f x)) \<noteq> 0)" by (rule b_least_aux1)
  from A1 this show ?thesis by simp
qed

lemma b_least_less_impl_eq: "b_least f x < x \<Longrightarrow> (b_least f x) = (Least (%y. (f x y) \<noteq> 0))"
proof -
  assume A1: "b_least f x < x" (is "?b < _")
  let ?B = "(Least (%y. (f x y) \<noteq> 0))"
  from A1 have S1: "f x ?b \<noteq> 0" by (rule b_least_less_impl_nz)
  from S1 have S2: "?B  \<le> ?b" by (rule Least_le)
  from S1 have S3: "f x ?B \<noteq> 0" by (rule LeastI)
  from S3 have S4: "?b \<le> ?B" by (rule nz_impl_b_least_le)
  from S2 S4 show ?thesis by simp
qed

lemma less_b_least_impl_zero2: "\<lbrakk>y < x; b_least f x = x\<rbrakk> \<Longrightarrow> f x y = 0" by (simp add: less_b_least_impl_zero)

lemma nz_impl_b_least_less: "\<lbrakk>y<x; (f x y) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least f x) < x"
proof -
  assume A1: "y < x"
  assume "f x y \<noteq> 0"
  then have "b_least f x \<le> y" by (rule nz_impl_b_least_le)
  with A1 show ?thesis by simp
qed

lemma b_least_aux2: "\<lbrakk>y<x; (f x y) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least f x) = (Least (%y. (f x y) \<noteq> 0))"
proof -
  assume A1: "y < x" and A2: "f x y \<noteq> 0"
  from A1 A2 have S1: "b_least f x < x" by (rule nz_impl_b_least_less)
  thus ?thesis by (rule b_least_less_impl_eq)
qed

lemma b_least2_aux1: "b_least2 f x y = y \<or> (b_least2 f x y < y \<and> (f x (b_least2 f x y)) \<noteq> 0)"
proof -
  let ?P = "%z. z = y \<or> (z < y \<and> (f x z) \<noteq> 0)"
  have "?P y" by simp
  then have "?P (Least ?P)" by (rule LeastI)
  thus ?thesis by (simp add: b_least2_def)
qed

lemma b_least2_le_arg: "b_least2 f x y \<le> y"
proof -
  let ?B = "b_least2 f x y"
  have "?B = y \<or> (?B < y \<and> (f x ?B) \<noteq> 0)" by (rule b_least2_aux1)
  from this show ?thesis by (arith)
qed

lemma less_b_least2_impl_zero: "z < b_least2 f x y \<Longrightarrow> f x z = 0"
proof -
  assume A1: "z < b_least2 f x y" (is "_ < ?b")
  have "b_least2 f x y \<le> y" by (rule b_least2_le_arg)
  with A1 have S1: "z < y" by simp
  with A1 have " z < (Least (%z. z = y \<or> (z < y \<and> (f x z) \<noteq> 0)))" by (simp add: b_least2_def)
  then have "\<not> (z = y \<or> (z < y \<and> (f x z) \<noteq> 0))" by (rule not_less_Least)
  with S1 show ?thesis by simp
qed

lemma nz_impl_b_least2_le: "(f x z) \<noteq> 0 \<Longrightarrow> (b_least2 f x y) \<le> z"
proof -
  assume A1: "f x z \<noteq> 0"
  have S1: "z < b_least2 f x y \<Longrightarrow> f x z = 0" by (rule less_b_least2_impl_zero)
  from A1 S1 show ?thesis by arith
qed

lemma b_least2_less_impl_nz: "b_least2 f x y < y \<Longrightarrow> f x (b_least2 f x y) \<noteq> 0"
proof -
  assume A1: "b_least2 f x y < y"
  have "b_least2 f x y = y \<or> (b_least2 f x y < y \<and> (f x (b_least2 f x y)) \<noteq> 0)" by (rule b_least2_aux1)
  with A1 show ?thesis by simp
qed

lemma b_least2_less_impl_eq: "b_least2 f x y < y \<Longrightarrow> (b_least2 f x y) = (Least (%z. (f x z) \<noteq> 0))"
proof -
  assume A1: "b_least2 f x y < y" (is "?b < _")
  let ?B = "(Least (%z. (f x z) \<noteq> 0))"
  from A1 have S1: "f x ?b \<noteq> 0" by (rule b_least2_less_impl_nz)
  from S1 have S2: "?B  \<le> ?b" by (rule Least_le)
  from S1 have S3: "f x ?B \<noteq> 0" by (rule LeastI)
  from S3 have S4: "?b \<le> ?B" by (rule nz_impl_b_least2_le)
  from S2 S4 show ?thesis by simp
qed

lemma less_b_least2_impl_zero2: "\<lbrakk>z<y; b_least2 f x y = y\<rbrakk> \<Longrightarrow> f x z = 0"
proof -
  assume  "z < y" and "b_least2 f x y = y"
  hence "z < b_least2 f x y" by simp
  thus ?thesis by (rule less_b_least2_impl_zero)
qed

lemma nz_b_least2_impl_less: "\<lbrakk>z<y; (f x z) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least2 f x y) < y"
proof (rule ccontr)
  assume A1: "z < y"
  assume A2: "f x z \<noteq> 0"
  assume "\<not> (b_least2 f x y) < y" then have A3: "y \<le> (b_least2 f x y)" by simp
  have "b_least2 f x y \<le> y" by (rule b_least2_le_arg)
  with A3 have "b_least2 f x y = y" by simp
  with A1 have "f x z = 0" by (rule less_b_least2_impl_zero2)
  with A2 show False by simp
qed

lemma b_least2_less_impl_eq2: "\<lbrakk>z < y; (f x z) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least2 f x y) = (Least (%z. (f x z) \<noteq> 0))"
proof -
  assume A1: "z < y" and A2: "f x z \<noteq> 0"
  from A1 A2 have S1: "b_least2 f x y < y" by (rule nz_b_least2_impl_less)
  thus ?thesis by (rule b_least2_less_impl_eq)
qed

lemma b_least2_aux2: "b_least2 f x y < y \<Longrightarrow> b_least2 f x (Suc y) = b_least2 f x y"
proof -
  let ?B = "b_least2 f x y"
  assume A1: "?B < y"
  from A1 have S1: "f x ?B \<noteq> 0" by (rule b_least2_less_impl_nz)
  from S1 have S2: "b_least2 f x (Suc y) \<le> ?B" by (simp add: nz_impl_b_least2_le)
  from A1 S2 have S3: "b_least2 f x (Suc y) < Suc y" by (simp)
  from S3 have S4: "f x (b_least2 f x (Suc y)) \<noteq> 0" by (rule b_least2_less_impl_nz)
  from S4 have S5: "?B \<le> b_least2 f x (Suc y)" by (rule nz_impl_b_least2_le)
  from S2 S5 show ?thesis by simp
qed

lemma b_least2_aux3: "\<lbrakk> b_least2 f x y = y; f x y \<noteq> 0\<rbrakk> \<Longrightarrow> b_least2 f x (Suc y) = y"
proof -
  assume A1: "b_least2 f x y =y"
  assume A2: "f x y \<noteq> 0"
  from A2 have S1: "b_least2 f x (Suc y) \<le> y" by (rule nz_impl_b_least2_le)
  have S2: "b_least2 f x (Suc y) < y \<Longrightarrow> False"
  proof -
    assume A2_1: "b_least2 f x (Suc y) < y" (is "?z < _")
    from A2_1 have S2_1: "?z < Suc y" by simp
    from S2_1 have S2_2: "f x ?z \<noteq> 0" by (rule b_least2_less_impl_nz)
    from A2_1 S2_2 have S2_3: "b_least2 f x y < y" by (rule nz_b_least2_impl_less)
    from S2_3 A1 show ?thesis by simp
  qed
  from S2 have S3: "\<not> (b_least2 f x (Suc y) < y)" by auto
  from S1 S3 show ?thesis by simp
qed

lemma b_least2_mono: "y1 \<le> y2 \<Longrightarrow> b_least2 f x y1 \<le> b_least2 f x y2"
proof (rule ccontr)
  assume A1: "y1 \<le> y2"
  let ?b1 = "b_least2 f x y1" and ?b2 = "b_least2 f x y2"
  assume "\<not> ?b1 \<le> ?b2" then have A2: "?b2 < ?b1" by simp
  have S1: "?b1 \<le> y1" by (rule b_least2_le_arg)
  have S2: "?b2 \<le> y2" by (rule b_least2_le_arg)
  from A1 A2 S1 S2 have S3: "?b2 < y2" by simp
  then have S4: "f x ?b2 \<noteq> 0" by (rule b_least2_less_impl_nz)
  from A2 have S5: "f x ?b2 = 0" by (rule less_b_least2_impl_zero)
  from S4 S5 show False by simp
qed

lemma b_least2_aux4: "\<lbrakk> b_least2 f x y = y; f x y = 0\<rbrakk> \<Longrightarrow> b_least2 f x (Suc y) = Suc y"
proof -
  assume A1: "b_least2 f x y = y"
  assume A2: "f x y = 0"
  have S1: "b_least2 f x (Suc y) \<le> Suc y" by (rule b_least2_le_arg)
  have S2: "y \<le> b_least2 f x (Suc y)"
  proof -
    have "y \<le> Suc y" by simp
    then have "b_least2 f x y \<le> b_least2 f x (Suc y)" by (rule b_least2_mono)
    with A1 show ?thesis by simp
  qed
  from S1 S2  have "b_least2 f x (Suc y) =y \<or> b_least2 f x (Suc y) = Suc y" by arith
  moreover
  {
    assume A3: "b_least2 f x (Suc y) = y"
    have "f x y \<noteq> 0"
    proof -
      have "y < Suc y" by simp
      with A3 have "b_least2 f x (Suc y) < Suc y" by simp
      from this have "f x (b_least2 f x (Suc y)) \<noteq> 0" by (simp add: b_least2_less_impl_nz)
      with A3 show "f x y \<noteq> 0" by simp
    qed
    with A2 have ?thesis by simp
  }
  moreover
  {
    assume "b_least2 f x (Suc y) = Suc y"
    then have ?thesis by simp
  }
  ultimately show ?thesis by blast
qed

lemma b_least2_at_zero: "b_least2 f x 0 = 0"
proof -
  have S1: "b_least2 f x 0 \<le> 0" by (rule b_least2_le_arg)
  from S1 show ?thesis by auto
qed

theorem pr_b_least2: "f \<in> PrimRec2 \<Longrightarrow> b_least2 f \<in> PrimRec2"
proof -
  define loc_Op1 where "loc_Op1 = (\<lambda> (f::nat \<Rightarrow> nat \<Rightarrow> nat) x y z. (sgn1 (z - y)) * y + (sgn2 (z - y))*((sgn1 (f x z))*z + (sgn2 (f x z))*(Suc z)))"
  define loc_Op2 where "loc_Op2 = (\<lambda> f. PrimRecOp_last (\<lambda> x. 0) (loc_Op1 f))"
  have loc_op2_lm_1: "\<And> f x y. loc_Op2 f x y < y \<Longrightarrow> loc_Op2 f x (Suc y) = loc_Op2 f x y"
  proof -
    fix f x y
    let ?b = "loc_Op2 f x y"
    have S1: "loc_Op2 f x (Suc y) = (loc_Op1 f) x ?b y" by (simp add: loc_Op2_def)
    assume "?b < y"
    then have "y - ?b > 0" by simp
    then have "loc_Op1 f x ?b y = ?b" by (simp add: loc_Op1_def)
    with S1 show "loc_Op2 f x y < y \<Longrightarrow> loc_Op2 f x (Suc y) = loc_Op2 f x y" by simp
  qed
  have loc_op2_lm_2: "\<And> f x y. \<lbrakk>\<not>(loc_Op2 f x y < y); f x y \<noteq> 0\<rbrakk> \<Longrightarrow> loc_Op2 f x (Suc y) = y"
  proof -
    fix f x y
    let ?b = "loc_Op2 f x y" and ?h = "loc_Op1 f"
    have S1: "loc_Op2 f x (Suc y) = ?h x ?b y" by (simp add: loc_Op2_def)
    assume "\<not>(?b < y)"
    then have S2: "y - ?b = 0" by simp
    assume "f x y \<noteq> 0"
    with S2 have "?h x ?b y = y" by (simp add: loc_Op1_def)
    with S1 show "loc_Op2 f x (Suc y) = y" by simp
  qed
  have loc_op2_lm_3: "\<And> f x y. \<lbrakk>\<not>(loc_Op2 f x y < y); f x y = 0\<rbrakk> \<Longrightarrow> loc_Op2 f x (Suc y) = Suc y"
  proof -
    fix f x y
    let ?b = "loc_Op2 f x y" and ?h = "loc_Op1 f"
    have S1: "loc_Op2 f x (Suc y) = ?h x ?b y" by (simp add: loc_Op2_def)
    assume "\<not>(?b < y)"
    then have S2: "y - ?b = 0" by simp
    assume "f x y = 0"
    with S2 have "?h x ?b y = Suc y" by (simp add: loc_Op1_def)
    with S1 show "loc_Op2 f x (Suc y) = Suc y" by simp
  qed
  have Op2_eq_b_least2_at_point: "\<And> f x y. loc_Op2 f x y = b_least2 f x y"
  proof - fix f x show "\<And> y. loc_Op2 f x y = b_least2 f x y"
  proof (induct_tac y)
    show "loc_Op2 f x 0 = b_least2 f x 0" by (simp add: loc_Op2_def b_least2_at_zero)
  next
    fix y
    assume A1: "loc_Op2 f x y = b_least2 f x y"
    then show "loc_Op2 f x (Suc y) = b_least2 f x (Suc y)"
    proof cases
      assume A2: "loc_Op2 f x y < y"
      then have S1: "loc_Op2 f x (Suc y) = loc_Op2 f x y" by (rule loc_op2_lm_1)
      from A1 A2 have "b_least2 f x y < y" by simp
      then have S2: "b_least2 f x (Suc y) = b_least2 f x y" by (rule b_least2_aux2)
      from A1 S1 S2 show ?thesis by simp
    next
      assume A3: "\<not> loc_Op2 f x y < y"
      have A3': "b_least2 f x y = y"
      proof -
        have "b_least2 f x y \<le> y" by (rule b_least2_le_arg)
        from A1 A3 this show ?thesis by simp
      qed
      then show ?thesis
      proof cases
        assume A4: "f x y \<noteq> 0"
        with A3 have S3: "loc_Op2 f x (Suc y) = y" by (rule loc_op2_lm_2)
        from A3' A4 have S4: "b_least2 f x (Suc y) = y" by (rule b_least2_aux3)
        from S3 S4 show ?thesis by simp
      next
        assume "\<not> f x y \<noteq>  0"
        then have A5: "f x y = 0" by simp
        with A3 have S5: "loc_Op2 f x (Suc y) = Suc y" by (rule loc_op2_lm_3)
        from A3' A5 have S6: "b_least2 f x (Suc y) = Suc y" by (rule b_least2_aux4)
        from S5 S6 show ?thesis by simp
      qed
    qed
  qed
  qed
  have Op2_eq_b_least2: "loc_Op2 = b_least2" by (simp add: Op2_eq_b_least2_at_point ext)
  assume A1: "f \<in> PrimRec2"
  have pr_loc_Op2: "loc_Op2 f \<in> PrimRec2"
  proof -
    from A1 have S1: "loc_Op1 f \<in> PrimRec3" by (simp add: loc_Op1_def, prec)
    from pr_zero S1 have S2: "PrimRecOp_last (\<lambda> x. 0) (loc_Op1 f) \<in> PrimRec2" by (rule pr_rec_last)
    from this show ?thesis by (simp add: loc_Op2_def)
  qed
  from Op2_eq_b_least2 this show "b_least2 f \<in> PrimRec2" by simp
qed

lemma b_least_def1: "b_least f = (\<lambda> x. b_least2 f x x)" by (simp add: b_least2_def b_least_def ext)

theorem pr_b_least: "f \<in> PrimRec2 \<Longrightarrow> b_least f \<in> PrimRec1"
proof -
  assume "f \<in> PrimRec2"
  then have "b_least2 f \<in> PrimRec2" by (rule pr_b_least2)
  from this pr_id1_1 pr_id1_1 have "(\<lambda> x. b_least2 f x x) \<in> PrimRec1" by (rule pr_comp2_1)
  then show ?thesis by (simp add: b_least_def1)
qed

subsection \<open>Examples\<close>

theorem c_sum_as_b_least: "c_sum = (\<lambda> u. b_least2 (\<lambda> u z. (sgn1 (sf(z+1) - u))) u (Suc u))"
proof (rule ext)
  fix u show "c_sum u = b_least2 (\<lambda> u z. (sgn1 (sf(z+1) - u))) u (Suc u)"
  proof -
    have lm_1: "(\<lambda> x y. (sgn1 (sf(y+1) - x) \<noteq> 0)) = (\<lambda> x y. (x < sf(y+1)))"
    proof (rule ext, rule ext)
      fix x y show "(sgn1 (sf(y+1) - x) \<noteq> 0) = (x < sf(y+1))"
      proof -
        have "(sgn1 (sf(y+1) - x) \<noteq> 0) = (sf(y+1) - x > 0)" by (rule sgn1_nz_eq_arg_pos)
        thus "(sgn1 (sf(y+1) - x) \<noteq> 0) = (x < sf(y+1))" by auto
      qed
    qed (* lm_1 *)
    let ?f = "\<lambda> u z. (sgn1 (sf(z+1) - u))"
    have S1: "?f u u \<noteq> 0"
    proof -
      have S1_1: "u+1 \<le> sf(u+1)" by (rule arg_le_sf)
      have S1_2: "u < u+1" by simp
      from S1_1 S1_2 have S1_3: "u < sf(u+1)" by simp
      from S1_3 have S1_4: "sf(u+1) - u > 0" by simp
      from S1_4 have S1_5: "sgn1 (sf(u+1)-u) = 1" by simp
      from S1_5 show ?thesis by simp
    qed
    have S3: "u < Suc u" by simp
    from S3 S1 have S4: "b_least2 ?f u (Suc u) = (Least (%z. (?f u z) \<noteq> 0))" by (rule b_least2_less_impl_eq2)
    let ?P = "\<lambda> u z. ?f u z \<noteq> 0"
    let ?Q = "\<lambda> u z. u < sf(z+1)"
    from lm_1 have S6: "?P = ?Q" by simp
    from S6 have S7: "(%z. ?P u z) = (%z. ?Q u z)" by (rule fun_cong)
    from S7 have S8: "(Least (%z. ?P u z)) = (Least (%z. ?Q u z))" by auto
    from S4 S8 have S9: "b_least2 ?f u (Suc u) = (Least (%z. u < sf(z+1)))" by (rule trans)
    thus ?thesis by (simp add: c_sum_def)
  qed
qed

theorem c_sum_is_pr: "c_sum \<in> PrimRec1"
proof -
  let ?f = "\<lambda> u z. (sgn1 (sf(z+1) - u))"
  have S1: "(\<lambda> u z. sgn1 ((sf(z+1) - u))) \<in> PrimRec2" by prec
  define g where "g = b_least2 ?f"
  from g_def S1 have "g \<in> PrimRec2" by (simp add: pr_b_least2)
  then have S2: "(\<lambda> u. g u (Suc u)) \<in> PrimRec1" by prec
  from g_def have "c_sum = (\<lambda> u. g u (Suc u))" by (simp add: c_sum_as_b_least ext)
  with S2 show ?thesis by simp
qed

theorem c_fst_is_pr [prec]: "c_fst \<in> PrimRec1"
proof -
  have S1: "(\<lambda> u. c_fst u) = (\<lambda> u. (u - sf (c_sum u)))" by (simp add: c_fst_def ext)
  from c_sum_is_pr have "(\<lambda> u. (u - sf (c_sum u))) \<in> PrimRec1" by prec
  with S1 show ?thesis by simp
qed

theorem c_snd_is_pr [prec]: "c_snd \<in> PrimRec1"
proof -
  have S1: "c_snd = (\<lambda> u. (c_sum u) - (c_fst u))" by (simp add: c_snd_def ext)
  from c_sum_is_pr c_fst_is_pr have S2: "(\<lambda> u. (c_sum u) - (c_fst u)) \<in> PrimRec1" by prec
  from S1 this show ?thesis by simp
qed

theorem pr_1_to_2: "f \<in> PrimRec1 \<Longrightarrow> (\<lambda> x y. f (c_pair x y)) \<in> PrimRec2" by prec

theorem pr_2_to_1: "f \<in> PrimRec2 \<Longrightarrow> (\<lambda> z. f (c_fst z) (c_snd z)) \<in> PrimRec1" by prec

definition "pr_conv_1_to_2 = (\<lambda> f x y. f (c_pair x y))"
definition "pr_conv_1_to_3 = (\<lambda> f x y z. f (c_pair (c_pair x y) z))"
definition "pr_conv_2_to_1 = (\<lambda> f x. f (c_fst x) (c_snd x))"
definition "pr_conv_3_to_1 = (\<lambda> f x. f (c_fst (c_fst x)) (c_snd (c_fst x)) (c_snd x))"
definition "pr_conv_3_to_2 = (\<lambda> f. pr_conv_1_to_2 (pr_conv_3_to_1 f))"
definition "pr_conv_2_to_3 = (\<lambda> f. pr_conv_1_to_3 (pr_conv_2_to_1 f))"

lemma [simp]: "pr_conv_1_to_2 (pr_conv_2_to_1 f) = f" by(simp add: pr_conv_1_to_2_def pr_conv_2_to_1_def)
lemma [simp]: "pr_conv_2_to_1 (pr_conv_1_to_2 f) = f" by(simp add: pr_conv_1_to_2_def pr_conv_2_to_1_def)
lemma [simp]: "pr_conv_1_to_3 (pr_conv_3_to_1 f) = f" by(simp add: pr_conv_1_to_3_def pr_conv_3_to_1_def)
lemma [simp]: "pr_conv_3_to_1 (pr_conv_1_to_3 f) = f" by(simp add: pr_conv_1_to_3_def pr_conv_3_to_1_def)
lemma [simp]: "pr_conv_3_to_2 (pr_conv_2_to_3 f) = f" by(simp add: pr_conv_3_to_2_def pr_conv_2_to_3_def)
lemma [simp]: "pr_conv_2_to_3 (pr_conv_3_to_2 f) = f" by(simp add: pr_conv_3_to_2_def pr_conv_2_to_3_def)

lemma pr_conv_1_to_2_lm: "f \<in> PrimRec1 \<Longrightarrow> pr_conv_1_to_2 f \<in> PrimRec2" by (simp add: pr_conv_1_to_2_def, prec)
lemma pr_conv_1_to_3_lm: "f \<in> PrimRec1 \<Longrightarrow> pr_conv_1_to_3 f \<in> PrimRec3" by (simp add: pr_conv_1_to_3_def, prec)
lemma pr_conv_2_to_1_lm: "f \<in> PrimRec2 \<Longrightarrow> pr_conv_2_to_1 f \<in> PrimRec1" by (simp add: pr_conv_2_to_1_def, prec)
lemma pr_conv_3_to_1_lm: "f \<in> PrimRec3 \<Longrightarrow> pr_conv_3_to_1 f \<in> PrimRec1" by (simp add: pr_conv_3_to_1_def, prec)
lemma pr_conv_3_to_2_lm: "f \<in> PrimRec3 \<Longrightarrow> pr_conv_3_to_2 f \<in> PrimRec2"
proof -
  assume "f \<in> PrimRec3"
  then have "pr_conv_3_to_1 f \<in> PrimRec1" by (rule pr_conv_3_to_1_lm)
  thus ?thesis by (simp add: pr_conv_3_to_2_def pr_conv_1_to_2_lm)
qed
lemma pr_conv_2_to_3_lm: "f \<in> PrimRec2 \<Longrightarrow> pr_conv_2_to_3 f \<in> PrimRec3"
proof -
  assume "f \<in> PrimRec2"
  then have "pr_conv_2_to_1 f \<in> PrimRec1" by (rule pr_conv_2_to_1_lm)
  thus ?thesis by (simp add: pr_conv_2_to_3_def pr_conv_1_to_3_lm)
qed

theorem b_least2_scheme: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec1; \<forall> x. h x < g x; \<forall> x. f x (h x) \<noteq> 0; \<forall> z x. z < h x \<longrightarrow> f x z = 0 \<rbrakk> \<Longrightarrow>
                            h \<in> PrimRec1"
proof -
  assume f_is_pr: "f \<in> PrimRec2"
  assume g_is_pr: "g \<in> PrimRec1"
  assume h_lt_g: "\<forall> x. h x < g x"
  assume f_at_h_nz: "\<forall> x. f x (h x) \<noteq> 0"
  assume h_is_min: "\<forall> z x. z < h x \<longrightarrow> f x z = 0"
  have h_def: "h = (\<lambda> x. b_least2 f x (g x))"
  proof
    fix x show "h x = b_least2 f x (g x)"
    proof -
      from f_at_h_nz have S1: "b_least2 f x (g x) \<le> h x" by (simp add: nz_impl_b_least2_le)
      from h_lt_g have "h x < g x" by auto
      with S1 have "b_least2 f x (g x) < g x" by simp
      then have S2: "f x (b_least2 f x (g x)) \<noteq> 0" by (rule b_least2_less_impl_nz)
      have S3: "h x \<le> b_least2 f x (g x)"
      proof (rule ccontr)
        assume "\<not> h x \<le> b_least2 f x (g x)" then have "b_least2 f x (g x) < h x" by auto
        with h_is_min have "f x (b_least2 f x (g x)) = 0" by simp
        with S2 show False by auto
      qed
      from S1 S3 show ?thesis by auto
    qed
  qed
  define f1 where "f1 = b_least2 f"
  from f_is_pr f1_def have f1_is_pr: "f1 \<in> PrimRec2" by (simp add: pr_b_least2)
  with g_is_pr have "(\<lambda> x. f1 x (g x)) \<in> PrimRec1" by prec
  with h_def f1_def show "h \<in> PrimRec1" by auto
qed

theorem b_least2_scheme2: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec2; \<forall> x y. h x y < g x y; \<forall> x y. f x y (h x y) \<noteq> 0;
                             \<forall> z x y. z < h x y \<longrightarrow> f x y z = 0 \<rbrakk> \<Longrightarrow>
                             h \<in> PrimRec2"
proof -
  assume f_is_pr: "f \<in> PrimRec3"
  assume g_is_pr: "g \<in> PrimRec2"
  assume h_lt_g: "\<forall> x y. h x y < g x y"
  assume f_at_h_nz: "\<forall> x y. f x y (h x y) \<noteq> 0"
  assume h_is_min: "\<forall> z x y. z < h x y \<longrightarrow> f x y z = 0"
  define f1 where "f1 = pr_conv_3_to_2 f"
  define g1 where "g1 = pr_conv_2_to_1 g"
  define h1 where "h1 = pr_conv_2_to_1 h"
  from f_is_pr f1_def have f1_is_pr: "f1 \<in> PrimRec2" by (simp add: pr_conv_3_to_2_lm)
  from g_is_pr g1_def have g1_is_pr: "g1 \<in> PrimRec1" by (simp add: pr_conv_2_to_1_lm)
  from h_lt_g h1_def g1_def have h1_lt_g1: "\<forall> x. h1 x < g1 x" by (simp add: pr_conv_2_to_1_def)
  from f_at_h_nz f1_def h1_def have f1_at_h1_nz: "\<forall> x. f1 x (h1 x) \<noteq> 0" by (simp add: pr_conv_2_to_1_def pr_conv_3_to_2_def pr_conv_3_to_1_def pr_conv_1_to_2_def)
  from h_is_min f1_def h1_def have h1_is_min: "\<forall> z x. z < h1 x \<longrightarrow> f1 x z = 0" by (simp add: pr_conv_2_to_1_def pr_conv_3_to_2_def pr_conv_3_to_1_def pr_conv_1_to_2_def)
  from f1_is_pr g1_is_pr h1_lt_g1 f1_at_h1_nz h1_is_min have h1_is_pr: "h1 \<in> PrimRec1" by (rule b_least2_scheme)
  from h1_def have "h = pr_conv_1_to_2 h1" by simp
  with h1_is_pr show "h \<in> PrimRec2" by (simp add: pr_conv_1_to_2_lm)
qed

theorem div_is_pr: "(\<lambda> a b. a div b) \<in> PrimRec2"
proof -
  define f where "f a b z = (sgn1 b) * (sgn1 (b*(z+1)-a)) + (sgn2 b)*(sgn2 z)" for a b z
  have f_is_pr: "f \<in> PrimRec3" unfolding f_def by prec
  define h where "h a b = a div b" for a b :: nat
  define g where "g a b = a + 1" for a b :: nat
  have g_is_pr: "g \<in> PrimRec2" unfolding g_def by prec
  have h_lt_g: "\<forall> a b. h a b < g a b"
  proof (rule allI, rule allI)
    fix a b
    from h_def have "h a b \<le> a" by simp
    also from g_def have "a < g a b" by simp
    ultimately show "h a b < g a b" by simp
  qed
  have f_at_h_nz: "\<forall> a b. f a b (h a b) \<noteq> 0"
  proof (rule allI, rule allI)
    fix a b show "f a b (h a b) \<noteq> 0"
    proof cases
      assume A: "b = 0"
      with h_def have "h a b = 0" by simp
      with f_def A show ?thesis by simp
    next
      assume A: "b \<noteq> 0"
      then have S1: "b > 0" by auto
      from A f_def have S2: "f a b (h a b) = sgn1 (b * (h a b + 1) - a)" by simp
      then have "?thesis = (sgn1(b * (h a b + 1) - a) \<noteq> 0)" by auto
      also have "\<dots> = (b * (h a b + 1) - a > 0)" by (rule sgn1_nz_eq_arg_pos)
      also have "\<dots> = (a < b * (h a b + 1))" by auto
      also have "\<dots> = (a < b * (h a b) + b)" by auto
      also from h_def have "\<dots> = (a < b * (a div b) + b)" by simp
      finally have S3: "?thesis = (a < b * (a div b) + b)" by auto
      have S4: "a < b * (a div b) + b"
      proof -
        from S1 have S4_1: "a mod b < b" by (rule mod_less_divisor)
        also have S4_2: "b * (a div b) + a mod b = a" by (rule mult_div_mod_eq)
        from S4_1 have S4_3: "b * (a div b) + a mod b < b * (a div b) + b" by arith
        from S4_2 S4_3 show ?thesis by auto
      qed
      from S3 S4 show ?thesis by auto
    qed
  qed
  have h_is_min: "\<forall> z a b. z < h a b \<longrightarrow> f a b z = 0"
  proof (rule allI, rule allI, rule allI, rule impI)
    fix a b z assume A: "z < h a b" show "f a b z = 0"
    proof -
      from A h_def have S1: "z < a div b" by simp
      then have S2: "a div b > 0" by simp
      have S3: "b \<noteq> 0"
      proof (rule ccontr)
        assume "\<not> b \<noteq> 0" then have "b = 0" by auto
        then have "a div b = 0" by auto
        with S2 show False by auto
      qed
      from S3 have b_pos: "0 < b" by auto
      from S1 have S4: "z+1 \<le> a div b" by auto
      from b_pos have "(b * (z+1) \<le> b * (a div b)) = (z+1 \<le> a div b)" by (rule nat_mult_le_cancel1)
      with S4 have S5: "b*(z+1) \<le> b*(a div b)" by simp
      moreover have "b*(a div b) \<le> a"
      proof -
        have "b*(a div b) + (a mod b) = a" by (rule mult_div_mod_eq)
        moreover have "0 \<le> a mod b" by auto
        ultimately show ?thesis by arith
      qed
      ultimately have S6: "b*(z+1) \<le> a"
        by (simp add: minus_mod_eq_mult_div [symmetric])
      then have "b*(z+1) - a = 0" by auto
      with S3 f_def show ?thesis by simp
    qed
  qed
  from f_is_pr g_is_pr h_lt_g f_at_h_nz h_is_min have h_is_pr: "h \<in> PrimRec2" by (rule b_least2_scheme2)
  with h_def [abs_def] show ?thesis by simp
qed

theorem mod_is_pr: "(\<lambda> a b. a mod b) \<in> PrimRec2"
proof -
  have "(\<lambda> (a::nat) (b::nat). a mod b) = (\<lambda> a b. a - (a div b) * b)"
  proof (rule ext, rule ext)
    fix a b show "(a::nat) mod b = a - (a div b) * b" by (rule minus_div_mult_eq_mod [symmetric])
  qed
  also from div_is_pr have "(\<lambda> a b. a - (a div b) * b) \<in> PrimRec2" by prec
  ultimately show ?thesis by auto
qed

theorem pr_rec_last_scheme: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec3; \<forall> x. f x 0 = g x; \<forall> x y. f x (Suc y) = h x (f x y) y \<rbrakk> \<Longrightarrow> f \<in> PrimRec2"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  assume h_is_pr: "h \<in> PrimRec3"
  assume f_at_0: "\<forall> x. f x 0 = g x"
  assume f_at_Suc: "\<forall> x y. f x (Suc y) = h x (f x y) y"
  from f_at_0 f_at_Suc have "\<And> x y. f x y = PrimRecOp_last g h x y" by (induct_tac y, simp_all)
  then have "f = PrimRecOp_last g h" by (simp add: ext)
  with g_is_pr h_is_pr show ?thesis by (simp add: pr_rec_last)
qed

theorem power_is_pr: "(\<lambda> (x::nat) (n::nat). x ^ n) \<in> PrimRec2"
proof -
  define g :: "nat \<Rightarrow> nat" where "g x = 1" for x
  define h where "h a b c = a * b" for a b c :: nat
  have g_is_pr: "g \<in> PrimRec1" unfolding g_def by prec
  have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
  let ?f = "\<lambda> (x::nat) (n::nat). x ^ n"
  have f_at_0: "\<forall> x. ?f x 0 = g x"
  proof
    fix x show "x ^ 0 = g x" by (simp add: g_def)
  qed
  have f_at_Suc: "\<forall> x y. ?f x (Suc y) = h x (?f x y) y"
  proof (rule allI, rule allI)
    fix x y show "?f x (Suc y) = h x (?f x y) y" by (simp add: h_def)
  qed
  from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_last_scheme)
qed

end


\<^marker>\<open>creator "Maximilian P.L. Haslbeck"\<close>
section "Analysis of the inner loop of the Coupon Collector Example"
theory Coupon_Collector_Inner
imports ERT_Of_IID_Loop
begin

paragraph \<open>Summary\<close>

text \<open>This theory formalizes the new proof rules for ert of f-iid loops and generalizes the
      result to angelic weakest preexpectation.
      The first result is Theorem 4 of @{cite batzESOP18}
    \<close>

lemma ennreal_divide_distrib: "(a + b::ennreal) / c = a / c + b / c"
  by (simp add: field_simps divide_ennreal_def)

definition "innerb (N::nat) = (WHILE (%s. s ''b'' \<noteq> 1) DO
        Assign ''b'' (%s. map_pmf (\<lambda>b. if b then 0 else 1)
                         (bernoulli_pmf (real (s ''a'') / N))))"

definition "coco N = Assign ''b'' (\<lambda>s. return_pmf (0)) ;;
                     Assign ''a'' (\<lambda>s. return_pmf (1)) ;;
                     innerb N"

subsection \<open>Semantic Approach\<close>

text \<open>This semantic proof is taken from theorem "ert_cc" in Coupon_Collector
    by Johannes Hölzl.
    The heart of that proof is in essence what constitutes the proof rule @{thm prove_rule}.
    The application of @{thm lfp_parallel_induct} in there is inspired by the use of that
    induction scheme in the proof of the inner loop in ert_cc.
  \<close>

lemma fixes N::nat
  assumes N: "N>1"
  shows "ert (compile (coco N)) 0 s = 3 +  (2 * real N / (real N - 1))"
proof -
  { fix s :: state and W :: exp
    assume   a: "s ''a'' < N" and "s ''a'' \<ge> 0" and b: "s ''b'' = 1 \<or> s ''b'' = 0"
    then obtain i where ai: "s ''a'' = i"
      using nonneg_int_cases by blast
    with a have "i<N" by simp
    let ?f = "\<lambda>W' s. 1 + (if s ''b'' \<noteq> 1 then W' s else W s)"
    let ?g = "\<lambda>W' s. 1 + \<integral>\<^sup>+ b. W' (s(''b'':=(if b then 0 else 1))) \<partial>bernoulli_pmf (real (s ''a'') / N)"
    let ?r = "\<lambda>i s r::ennreal. (2 + (W (s(''b'':=1)) * (1 - real i / N))) + (real i / N) * r"
    have *: "sup_continuous (\<lambda>x. ?g (?f x))" "sup_continuous (?r i s)" for i :: nat and s :: state
      by (auto intro!: order_continuous_intros)
    have eq: "lfp (\<lambda>x. ?f (?g x)) = ?f (lfp (\<lambda>x. ?g (?f x)))"
      by (rule lfp_rolling[where g="?f", symmetric])
         (auto simp: mono_def le_fun_def intro!: nn_integral_mono)
    have i: "\<And>s x. s ''b'' = x \<Longrightarrow> (s(''b'' := x)) = s" by auto
    { fix s'::state and i assume "i < N" and x: "s' ''a'' = i" "s' ''b'' \<noteq> 1"  and b: "s' ''b'' = 1 \<or> s' ''b'' = 0"
      have "lfp (\<lambda>x. ?g (?f x)) s' = lfp (?r i s')"
        using * x b
      proof (induction rule: lfp_parallel_induct)
        case (step a b)
        then have k: "s' ''b'' = 0" by auto
        then have z: "s'(''b'' := 0) = s'" by auto
          from step(1,2) k z  \<open>i < N\<close> show ?case
          apply (subst nn_integral_add)
            apply simp_all
            apply (simp add:   field_simps one_add_one[symmetric] del: one_add_one)
          done
      qed (auto simp: SUP_image)
      also have "\<dots> = (2 + (W (s'(''b'':=1))) * (1 - real i / real N)) / (1 - real i / real N)"
        using \<open>i < N\<close>
        apply (subst lfp_linear)
        by (simp_all add: ennreal_minus[symmetric])
      also have "\<dots> = 2 / (1 - real i / real N) + W (s'(''b'':=1))"
        using \<open>i < N\<close>
        apply (subst ennreal_divide_distrib)
        by (simp add: divide_ennreal[symmetric] ennreal_mult_divide_eq)
      also have "2 / (1 - real i / real N) = 2 * real N / (N - i)"
        using \<open>i < N\<close> by (simp add: field_simps)
      finally have "lfp (\<lambda>x. ?g (?f x)) s' = 2 * real N / (N - i) + W (s'(''b'':=1))"
        . } note t=this
    have " lfp (\<lambda>Wa s. 1 + (if s ''b'' \<noteq> 1 then (1 + (\<lambda>x. \<integral>\<^sup>+ xa. Wa (x(''b'' := if xa then 0 else 1)) \<partial>measure_pmf (bernoulli_pmf (real (x ''a'') / real N)))) s else W s)) s
          = lfp (\<lambda>x. ?f (?g x)) s"
      by (metis (no_types, lifting) one_fun_apply plus_fun_apply)
    also from t[of i s, OF \<open>i < N\<close> ai _ b] have "\<dots> = (if s ''b'' \<noteq> 1 then 1 + 2 * (real N / (N - i) ) else 1) + W (s(''b'':=1))"
      unfolding eq apply auto apply(subst i) by auto
    also have "real (N - i) = real_of_int (int N - s ''a'')"
      using \<open>i < N\<close> ai by auto
    finally have " lfp (\<lambda>Wa s. 1 + (if s ''b'' \<noteq> 1 then (1 + (\<lambda>x. \<integral>\<^sup>+ xa. Wa (x(''b'' := if xa then 0 else 1)) \<partial>measure_pmf (bernoulli_pmf (real (x ''a'') / real N)))) s else W s)) s =
  ennreal (if s ''b'' \<noteq> 1 then 1 + 2 * (real N / real_of_int (int N - s ''a'')) else 1) + W (s(''b'' := 1))"
      .
    }
    note inner = this
    {
      fix s:: state and f :: exp
      have "0 \<le> s ''a'' \<Longrightarrow> s ''a'' <N \<Longrightarrow> s ''b'' = 0 \<or> s ''b'' = 1
           \<Longrightarrow>  ert (compile (innerb N)) f s =
              (if s ''b'' \<noteq> 1 then 1 + 2 * (real N / real (N - s ''a'')) else 1) + f (s(''b'' := 1))"
        unfolding innerb_def apply (simp only: map_pmf_comp ert.simps compile.simps)
        apply(subst nn_integral_map_pmf) apply(subst inner)
        by auto
    } note l=this

    from assms show ?thesis  unfolding coco_def
      apply auto apply(subst l) apply auto
      apply(auto simp only: ennreal_numeral[symmetric] ennreal_1[symmetric]  )
      apply(subst ennreal_plus[symmetric]) apply auto[2]
      apply(subst ennreal_plus[symmetric]) apply auto[2]
      apply(subst ennreal_plus[symmetric]) apply auto[2]
      apply(subst ennreal_plus[symmetric]) apply auto[2]
      by simp
  qed

subsection "Using the Prove Rule for f-iid Loops"

lemma fixes N::nat
  assumes N: "N>1"
  shows "ert (compile (coco N)) 0 s = 3 +  (2 * real N / (real N - 1))"
proof -

  {
    fix s :: state assume a: "s ''b'' = 0" "s ''a''=1" "s ''b'' = 0 \<or> s ''b''=1"
    have "ert (compile (innerb N)) 0 s = 1 + 2 / (1 - ennreal (1 / real N))"
      unfolding innerb_def
      apply(subst prove_rule)
      using a N
      by (auto simp: fiid_def unaffected_def Vars_def lift2_def)
  } note k=this

  from N have *: "1 - 1 / real N = (real N - 1) / real N"
    by(simp add: diff_divide_distrib)
  have l: "(2::ennreal) = ennreal 2" by auto
  have eq: "2 / (1 - ennreal (1 / real N))
        =  ennreal (2 * real N / (real N - 1))"
    apply(subst ennreal_1[symmetric]) apply(subst ennreal_minus)
    using N   apply(auto simp add: divide_ennreal)
    unfolding l apply(subst divide_ennreal) apply auto
    unfolding *
    apply(subst divide_divide_eq_right) by simp

  show ?thesis unfolding coco_def apply auto
    apply(subst k) using N apply auto using eq by auto
qed

text \<open>We can even generalize it to arbitrary a, and thus obtain the real inner loop
      of the coupon collector.\<close>

definition "coco2 N a = Assign ''b'' (\<lambda>s. return_pmf (0)) ;;
                     Assign ''a'' (\<lambda>s. return_pmf (a)) ;;
                     innerb N"

lemma fixes N::nat
  assumes N: "N>1" "a<N"
  shows "ert (compile (coco2 N a)) 0 s = 3 +  (2 * real N / (real N - a))"
proof -

  {
    fix s :: state assume a: "s ''b'' = 0" "a\<le>N" "s ''a''=a" "s ''b'' = 0 \<or> s ''b''=1"
    have "ert (compile (innerb N)) 0 s = 1 + 2 / (1 - ennreal (a / real N))"
      unfolding innerb_def
      apply(subst prove_rule)
      using a N
      by (auto simp: fiid_def unaffected_def Vars_def lift2_def)

  } note k=this

  from N have *: "1 - 1 / real N = (real N - 1) / real N"
    by(simp add: diff_divide_distrib)
  have l: "(2::ennreal) = ennreal 2" by auto
  have eq: "2 / (1 - ennreal (real a / real N))
        =  ennreal (2 * real N / (real N - real a))"
    apply(subst ennreal_1[symmetric]) apply(subst ennreal_minus)
    using N   apply(auto simp add: divide_ennreal)
    unfolding l apply(subst divide_ennreal) apply auto
    unfolding *
    by (metis (mono_tags, hide_lams) Suc_lessD diff_divide_distrib divide_divide_eq_right divide_self_if gr0_implies_Suc of_nat_neq_0)

  show ?thesis unfolding coco2_def apply auto
    apply(subst k) using N apply auto using eq by auto
qed

end


theory P01
imports Main
begin

(*
useful commands
using [[simp_trace]] shows the used rewrite rules and what has been rewritten in the output tab
using [[simp_trace_new]] only shows the rewrites in a new window
using [[simp_trace_new mode=full]] shows the used rewrite rules and what has been rewritten
simp only: <rule name> only uses one simplification rule and some trivial simplifications
subst really only uses one simplification rule

how to typecast :  int (5::nat)  ==  (5::int) (write for example int like a function \<longrightarrow> int (value))
*)

(*using a default value*)
fun p01_1 ::  "'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
"p01_1 [] def = def"|
"p01_1 [x] _ = x"|
"p01_1 (x#xs) def = p01_1 xs def"

(*evaluate an expression*)
value "p01_1 [1,2,3,4] 5 :: int"
value "p01_1 [] 5 :: int"

(*show the type of an expression*)
term p01_1

(*show the definition of a theorem*)
thm p01_1.simps(1)
thm append_Nil

theorem tp01_1_1 : "p01_1 [] a = a"
apply (rule p01_1.simps(1))
done

theorem isar_tp01_1_1 :"p01_1 [] a = a"
proof -
  show ?thesis by (rule p01_1.simps(1))
qed

theorem tp01_1_2 : "p01_1 ( ls @ [a]) b = a "
apply (induct "ls")
apply simp
apply (case_tac "ls @ [a]")
apply simp
apply simp
done

(*step by step rewriting*)
theorem tp01_1_4 : "p01_1 (ls @ [a]) b = a"
apply (induct "ls")
  apply (subst append.append_Nil)
  apply (subst p01_1.simps(2))
  apply (rule refl)
apply (case_tac ls)
(*case ls = []*)
  apply (erule_tac ?t = ls and ?s = "[]" in  ssubst)
  apply (subst append.append_Cons)
  apply (subst append.append_Nil)
  apply (subst  p01_1.simps(3))
  apply (subst p01_1.simps(2))
  apply (rule refl)
(*case ls = aaa # list*)
  apply (rule_tac ?t = ls and ?s = "aaa # list" in ssubst)
  apply assumption
  apply (rule_tac ?t = ls and ?s = "aaa # list" in ssubst)
  apply assumption
  apply (subst  append.append_Cons)+ (*the "+" means that we apply the same rule as often as possible*)
  apply (subst p01_1.simps(3))
  apply hypsubst
  apply (subst (asm) append.append_Cons)
  apply (assumption)
done

(*isar proof using automation*)
theorem isar_tp01_1_2 : "p01_1 ( ls @ [a]) b = a "
proof (induction ls)
{
  show " p01_1 ([] @ [a]) b = a" by simp
}
{
  fix aa ls
  show " p01_1 (ls @ [a]) b = a \<Longrightarrow> p01_1 ((aa # ls) @ [a]) b = a "
  proof (cases ls)
  {
    show " p01_1 (ls @ [a]) b = a \<Longrightarrow> ls = [] \<Longrightarrow> p01_1 ((aa # ls) @ [a]) b = a" by simp
    fix ab list
    show "p01_1 (ls @ [a]) b = a \<Longrightarrow> ls = ab # list \<Longrightarrow> p01_1 ((aa # ls) @ [a]) b = a " by simp
  }
  qed
}
qed

(*step by step syntactical replacement with Isar*)
theorem isar_tp01_1_3 : fixes ls a b  shows "p01_1 ( ls @ [a]) b = a "
proof (induct ls)
 case Nil
  have "p01_1 ([] @ [a]) b =  p01_1 [a] b" unfolding append_Nil ..  (*instead of   the two dots ".." one could write "by (rule refl)" *)(*instead of unfolding \<rightarrow> "by (subst append_Nil[where ?ys = "[a]"]; rule refl)" *)
  also have "\<dots> = a" unfolding p01_1.simps(2) ..
  finally show "p01_1 ([] @ [a]) b = a" .
next
 case (Cons  aa ls)
  show " p01_1 (ls @ [a]) b = a \<Longrightarrow>  p01_1 ((aa # ls) @ [a]) b = a "
  proof (cases ls)
   case Nil
    assume "ls = []"
    assume "p01_1 (ls @ [a]) b = a"
    have " p01_1 ((aa # ls) @ [a]) b =  p01_1 (aa # ls @ [a]) b " unfolding append_Cons ..
    also have "\<dots> = p01_1 (aa # [] @ [a]) b" unfolding \<open>ls = []\<close> ..
    also have "\<dots> = p01_1 (aa # [a]) b" unfolding append_Nil ..
    also have "\<dots> = p01_1 [a] b" unfolding p01_1.simps(3) ..
    also have "\<dots> = a" unfolding p01_1.simps(2)  ..
    finally show "p01_1 ((aa # ls) @ [a]) b = a" .
  next
   case (Cons ab list)
    fix ab list
    assume IH:"p01_1 (ls @ [a]) b = a"
    assume "ls = ab # list"

    from  \<open>ls= ab # list\<close> and  IH have "p01_1 ((ab # list) @ [a]) b = a"  by (rule subst)
    with append_Cons have  "p01_1 (ab # list @ [a]) b = a" by (rule subst)
    note IH2 = this

    have  "p01_1 ((aa # ls) @ [a]) b = p01_1 ((aa # ab # list)@ [a]) b" unfolding \<open>ls = ab # list\<close> ..
    also have "\<dots> =  p01_1 (aa # (ab # list)@ [a]) b " unfolding append_Cons ..
    also have "\<dots> =  p01_1 (aa # ab # list@ [a]) b" unfolding append_Cons ..
    also have "\<dots> = p01_1 (ab # list @ [a]) b " unfolding p01_1.simps(3) ..
    also have "\<dots> = a " unfolding IH2 ..
    finally show " p01_1 ((aa # ls) @ [a]) b = a" .
  qed
qed

(*on other way to proof this (a bit nonsensical ... )*)
theorem isar_tp01_1_4 : fixes ls a b  shows "p01_1 ( ls @ [a]) b = a "
proof (induct ls)
{
  show "p01_1 ([] @ [a]) b = a"
  proof (subst append_Nil)
  {
    show " p01_1 [a] b = a"
    proof (subst p01_1.simps(2))
    {
      show "a = a" by (rule refl)
    }
    qed
  }
  qed
  fix aa ls
  assume "p01_1 (ls @ [a]) b = a"
  show " p01_1 ((aa # ls) @ [a]) b = a "
  proof (cases ls)
  {
    assume "ls = []"
    show "p01_1 ((aa # ls) @ [a]) b = a"
    proof (subst \<open>ls=[]\<close>)
    {
      show "p01_1 ([aa] @ [a]) b = a"
      proof (subst append_Cons)
      {
        show "p01_1 (aa # [] @ [a]) b = a"
        proof (subst append_Nil)
        {
          show " p01_1 [aa, a] b = a"
          proof (subst p01_1.simps(3))
          {
            show "p01_1 [a] b = a"
            proof (subst p01_1.simps(2))
            {
              show "a = a" by (rule refl)
            }
            qed
          }
          qed
        }
        qed
      }
      qed
    }
    qed
  }
  fix ab list
  assume "ls = ab # list"
  from this and  \<open>p01_1 (ls @ [a]) b = a\<close> have "p01_1 ((ab # list) @ [a]) b = a" by (rule subst)
  with append_Cons have "p01_1 (ab # list @ [a]) b = a" by (rule subst)
  show "p01_1 ((aa # ls) @ [a]) b = a"
  proof (subst \<open>ls = ab # list\<close>)
  {
    show " p01_1 ((aa # ab # list) @ [a]) b = a "
    proof (subst  append_Cons)
    {
      show "p01_1 (aa # (ab # list) @ [a]) b = a "
      proof (subst append_Cons )
      {
        show "p01_1 (aa # ab # list @ [a]) b = a "
        proof (subst p01_1.simps(3))
        {
          show "p01_1 (ab # list @ [a]) b = a " by (rule \<open>p01_1 (ab # list @ [a]) b = a\<close>)
        }
        qed
      }
      qed
    }
    qed
  }
  qed
  qed
}
qed

find_theorems "(?x \<noteq> ?x) = False"
lemma "p01_1 ls a \<noteq> a \<Longrightarrow> ls \<noteq> Nil"
using [[simp_trace_new mode=full]]
proof (induct ls)
 case Nil
  assume "p01_1 [] a \<noteq> a"
  hence "a \<noteq> a" unfolding p01_1.simps(1) ..
  hence "\<not>(True)" unfolding simp_thms by (rule FalseE) (*the usage of simp_thms is discourage , use simp instead. I just want to show how this works*)
  hence "False" unfolding simp_thms by (rule FalseE)
  thus ?case by (rule FalseE)
 next
  fix aa ls
  assume "(p01_1 ls a \<noteq> a \<Longrightarrow> ls \<noteq> [])"
  show "\<And>aa ls. (p01_1 ls a \<noteq> a \<Longrightarrow> ls \<noteq> []) \<Longrightarrow> p01_1 (aa # ls) a \<noteq> a \<Longrightarrow> aa # ls \<noteq> []" by auto
  thm list.distinct(2)

(*from now on I will mix isar and apply-script proofs and I will also mix step-by-step solving with automation*)

fun p01_2 :: "'a list \<Rightarrow> 'a option" where
"p01_2 [] = None"|
"p01_2 [x] = Some x"|
"p01_2 (x#xs) = p01_2 xs"

value "p01_2 [1,2,3,4,5] :: int option"
value "p01_2 [] :: int option"

term p01_2

lemma tp01_2_1 : "p01_2 [] = None"
apply (rule p01_2.simps(1))
done

lemma  isar_tp01_2_1 : "p01_2 [] = None"
proof -
show ?thesis by (rule p01_2.simps(1))
qed

lemma