(* 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

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 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

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 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 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

end

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>"

lemma (in pre_digraph)
  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 (in pre_digraph)
  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 (in wf_digraph)  wf_digraph_add_arc[intro]:
  "wf_digraph (add_arc a)" by unfold_locales (auto simp: verts_add_arc_conv)

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

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 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

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

end

end


(*  Title:      HOL/MicroJava/DFA/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>Kildall's Algorithm \label{sec:Kildall}\<close>

theory Kildall
imports SemilatAlg "~~/src/HOL/Library/While_Combinator"
begin

primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set" where
  "propa f []      ss w = (ss,w)"
| "propa f (q'#qs) ss w = (let (q,t) = q';
                               u = t +_f ss!q;
                               w' = (if u = ss!q then w else insert q w)
                           in propa f qs (ss[q := u]) w')"

definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set" where
  "iter f step ss w == while (%(ss,w). w \<noteq> {})
       (%(ss,w). let p = SOME p. p \<in> w
                 in propa f (step p (ss!p)) ss (w-{p}))
       (ss,w)"

definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set" where
"unstables r step ss == {p. p < size ss \<and> \<not>stable r step ss p}"

definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list" where
"kildall r f step ss == fst(iter f step ss (unstables r step ss))"

primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list" where
  "merges f []      ss = ss"
| "merges f (p'#ps) ss = (let (p,s) = p' in merges f ps (ss[p := s +_f ss!p]))"

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
  (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] ++_f ss!p"
  (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
proof (induct ps)
  show "\<And>ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss \<in> list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
    by (cases p') auto
  assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
  from this [OF _ _ ps'] have IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" .

  from ss ab
  have "ss[a := b +_f ss!a] \<in> list n A" by (simp add: closedD)
  moreover
  from calculation l
  have "p < length (ss[a := b +_f ss!a])" by simp
  ultimately
  have "?P (ss[a := b +_f ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed

(** merges **)

lemma length_merges [simp]: "size(merges f ps ss) = size ss"
  by (induct ps arbitrary: ss) auto

lemma (in Semilat) merges_preserves_type_lemma:
shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
          \<longrightarrow> merges f ps xs \<in> list n A"
apply (insert closedI)
apply (unfold closed_def)
apply (induct_tac ps)
 apply simp
apply clarsimp
done

lemma (in Semilat) merges_preserves_type [simp]:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
  \<Longrightarrow> merges f ps xs \<in> list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs <=[r] merges f ps xs"
apply (induct_tac ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done

lemma (in Semilat) merges_incr:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
  \<Longrightarrow> xs <=[r] merges f ps xs"
  by (simp add: merges_incr_lemma)

lemma (in Semilat) merges_same_conv [rule_format]:
 "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
     (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x <=_r xs!p))"
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := x +_f xs!p] <=[r] xs")
     apply (drule_tac p = p in le_listD)
      apply simp
     apply simp
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done

lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x <=_r ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x +_f xs!p] <=[r] ys"
  apply(insert semilat)
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts <= A" and "set ss <= A"
    and "\<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p < size ts" and "ss <=[r] ts"
  shows "merges f ps ss <=[r] ts"
proof -
  { fix t ts ps
    have
    "\<And>qs. \<lbrakk>set ts <= A; \<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
    set qs <= set ps  \<longrightarrow>
    (\<forall>ss. set ss <= A \<longrightarrow> ss <=[r] ts \<longrightarrow> merges f qs ss <=[r] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply (rotate_tac -2)
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done
  } note this [dest]

  from assms show ?thesis by blast
qed

(** propa **)

lemma decomp_propa:
  "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
   propa f qs ss w =
   (merges f qs ss, {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un w)"
  apply (induct qs)
   apply simp
  apply (simp (no_asm))
  apply clarify
  apply simp
  apply (rule conjI)
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done

(** iter **)

lemma (in Semilat) stable_pres_lemma:
shows "\<lbrakk>pres_type step n A; bounded step n;
     ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
     \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
     \<forall>s'. (q,s') \<in> set (step p (ss ! p)) \<longrightarrow> s' +_f ss ! q = ss ! q;
     q \<notin> w \<or> q = p \<rbrakk>
  \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
  apply (unfold stable_def)
  apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q \<in> w")
  apply simp
  apply (rule ub1')
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done

lemma (in Semilat) merges_bounded_lemma:
 "\<lbrakk> mono r step n A; bounded step n;
    \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
    ss <=[r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
  \<Longrightarrow> merges f (step p (ss!p)) ss <=[r] ts"
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)

  apply (drule lesub_step_typeD, assumption)
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done

lemma termination_lemma:
  assumes semilat: "semilat (A, r, f)"
  shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
  ss <[r] merges f qs ss \<or>
  merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un (w-{p}) < w" (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format])
    apply assumption+
    defer
    apply (rule sym, assumption)
    defer apply simp
    apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t +_f ss ! q \<noteq> ss ! q)")
    apply (blast elim: equalityE)
    apply clarsimp
    apply (drule bspec, assumption)
    apply (drule bspec, assumption)
    apply clarsimp
    done
qed

lemma iter_properties[rule_format]:
  assumes semilat: "semilat (A, r, f)"
  shows "\<lbrakk> acc r ; pres_type step n A; mono r step n A;
     bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
     \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
   iter f step ss0 w0 = (ss',w')
   \<longrightarrow>
   ss' \<in> list n A \<and> stables r step ss' \<and> ss0 <=[r] ss' \<and>
   (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss' <=[r] ts)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" apply(insert semilat)
apply (unfold iter_def stables_def)
apply (rule_tac P = "%(ss,w).
 ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 <=[r] ss \<and>
 (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss <=[r] ts) \<and>
 (\<forall>p\<in>w. p < n)" and
 r = "{(ss',ss) . ss <[r] ss'} <*lex*> finite_psubset"
       in while_rule)

\<comment> "Invariant holds initially:"
apply (simp add:stables_def)

\<comment> "Invariant is preserved:"
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
 prefer 2 apply (fast intro: someI)
apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
 prefer 2
 apply clarify
 apply (rule conjI)
  apply(clarsimp, blast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply simp
 apply simp
apply (subst decomp_propa)
 apply fast
apply simp
apply (rule conjI)
 apply (rule merges_preserves_type)
 apply blast
 apply clarify
 apply (rule conjI)
  apply(clarsimp, fast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply blast
 apply blast
apply (rule conjI)
 apply clarify
 apply (blast intro!: stable_pres_lemma)
apply (rule conjI)
 apply (blast intro!: merges_incr intro: le_list_trans)
apply (rule conjI)
 apply clarsimp
 apply (blast intro!: merges_bounded_lemma)
apply (blast dest!: boundedD)

\<comment> "Postcondition holds upon termination:"
apply(clarsimp simp add: stables_def split_paired_all)

\<comment> "Well-foundedness of the termination relation:"
apply (rule wf_lex_prod)
 apply (insert orderI [THEN acc_le_listI])
 apply (simp add: acc_def lesssub_def wfP_wf_eq [symmetric])
apply (rule wf_finite_psubset)

\<comment> "Loop decreases along termination relation:"
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
 prefer 2 apply (fast intro: someI)
apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
 prefer 2
 apply clarify
 apply (rule conjI)
  apply(clarsimp, blast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply blast
 apply blast
apply (subst decomp_propa)
 apply blast
apply clarify
apply (simp del: listE_length
    add: lex_prod_def finite_psubset_def
         bounded_nat_set_is_finite)
apply (rule termination_lemma)
apply assumption+
defer
apply assumption
apply clarsimp
done

qed

lemma kildall_properties:
assumes semilat: "semilat (A, r, f)"
shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
     bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> list n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 <=[r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 <=[r] ts)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P"
apply (unfold kildall_def)
apply(case_tac "iter f step ss0 (unstables r step ss0)")
apply(simp)
apply (rule iter_properties)
apply (simp_all add: unstables_def stable_def)
apply (rule semilat)
done
qed

lemma is_bcv_kildall:
assumes semilat: "semilat (A, r, f)"
shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
  \<Longrightarrow> is_bcv r T step n A (kildall r f step)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P"
apply(unfold is_bcv_def wt_step_def)
apply(insert semilat kildall_properties[of A])
apply(simp add:stables_def)
apply clarify
apply(subgoal_tac "kildall r f step ss \<in> list n A")
 prefer 2 apply (simp(no_asm_simp))
apply (rule iffI)
 apply (rule_tac x = "kildall r f step ss" in bexI)
  apply (rule conjI)
   apply (blast)
  apply (simp  (no_asm_simp))
 apply(assumption)
apply clarify
apply(subgoal_tac "kildall r f step ss!p <=_r ts!p")
 apply simp
apply (blast intro!: le_listD less_lengthI)
done
qed

end


(*  Title:      HOL/Nonstandard_Analysis/NSCA.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2001, 2002 University of Edinburgh
*)

section\<open>Non-Standard Complex Analysis\<close>

theory NSCA
imports NSComplex HTranscendental
begin

abbreviation
   (* standard complex numbers reagarded as an embedded subset of NS complex *)
   SComplex  :: "hcomplex set" where
   "SComplex \<equiv> Standard"

definition \<comment> \<open>standard part map\<close>
  stc :: "hcomplex => hcomplex" where
  "stc x = (SOME r. x \<in> HFinite \<and> r\<in>SComplex \<and> r \<approx> x)"

subsection\<open>Closure Laws for SComplex, the Standard Complex Numbers\<close>

lemma SComplex_minus_iff [simp]: "(-x \<in> SComplex) = (x \<in> SComplex)"
  using Standard_minus by fastforce

lemma SComplex_add_cancel:
  "\<lbrakk>x + y \<in> SComplex; y \<in> SComplex\<rbrakk> \<Longrightarrow> x \<in> SComplex"
  using Standard_diff by fastforce

lemma SReal_hcmod_hcomplex_of_complex [simp]:
  "hcmod (hcomplex_of_complex r) \<in> \<real>"
  by (simp add: Reals_eq_Standard)

lemma SReal_hcmod_numeral: "hcmod (numeral w ::hcomplex) \<in> \<real>"
  by simp

lemma SReal_hcmod_SComplex: "x \<in> SComplex \<Longrightarrow> hcmod x \<in> \<real>"
  by (simp add: Reals_eq_Standard)

lemma SComplex_divide_numeral:
  "r \<in> SComplex \<Longrightarrow> r/(numeral w::hcomplex) \<in> SComplex"
  by simp

lemma SComplex_UNIV_complex:
  "{x. hcomplex_of_complex x \<in> SComplex} = (UNIV::complex set)"
  by simp

lemma SComplex_iff: "(x \<in> SComplex) = (\<exists>y. x = hcomplex_of_complex y)"
  by (simp add: Standard_def image_def)

lemma hcomplex_of_complex_image:
  "range hcomplex_of_complex = SComplex"
  by (simp add: Standard_def)

lemma inv_hcomplex_of_complex_image: "inv hcomplex_of_complex `SComplex = UNIV"
by (auto simp add: Standard_def image_def) (metis inj_star_of inv_f_f)

lemma SComplex_hcomplex_of_complex_image:
      "\<lbrakk>\<exists>x. x \<in> P; P \<le> SComplex\<rbrakk> \<Longrightarrow> \<exists>Q. P = hcomplex_of_complex ` Q"
  by (metis Standard_def subset_imageE)

lemma SComplex_SReal_dense:
     "\<lbrakk>x \<in> SComplex; y \<in> SComplex; hcmod x < hcmod y
      \<rbrakk> \<Longrightarrow> \<exists>r \<in> Reals. hcmod x< r \<and> r < hcmod y"
  by (simp add: SReal_dense SReal_hcmod_SComplex)

subsection\<open>The Finite Elements form a Subring\<close>

lemma HFinite_hcmod_hcomplex_of_complex [simp]:
  "hcmod (hcomplex_of_complex r) \<in> HFinite"
  by (auto intro!: SReal_subset_HFinite [THEN subsetD])

lemma HFinite_hcmod_iff [simp]: "hcmod x \<in> HFinite \<longleftrightarrow> x \<in> HFinite"
  by (simp add: HFinite_def)

lemma HFinite_bounded_hcmod:
  "\<lbrakk>x \<in> HFinite; y \<le> hcmod x; 0 \<le> y\<rbrakk> \<Longrightarrow> y \<in> HFinite"
  using HFinite_bounded HFinite_hcmod_iff by blast

subsection\<open>The Complex Infinitesimals form a Subring\<close>

lemma Infinitesimal_hcmod_iff:
  "(z \<in> Infinitesimal) = (hcmod z \<in> Infinitesimal)"
  by (simp add: Infinitesimal_def)

lemma HInfinite_hcmod_iff: "(z \<in> HInfinite) = (hcmod z \<in> HInfinite)"
  by (simp add: HInfinite_def)

lemma HFinite_diff_Infinitesimal_hcmod:
  "x \<in> HFinite - Infinitesimal \<Longrightarrow> hcmod x \<in> HFinite - Infinitesimal"
  by (simp add: Infinitesimal_hcmod_iff)

lemma hcmod_less_Infinitesimal:
  "\<lbrakk>e \<in> Infinitesimal; hcmod x < hcmod e\<rbrakk> \<Longrightarrow> x \<in> Infinitesimal"
  by (auto elim: hrabs_less_Infinitesimal simp add: Infinitesimal_hcmod_iff)

lemma hcmod_le_Infinitesimal:
  "\<lbrakk>e \<in> Infinitesimal; hcmod x \<le> hcmod e\<rbrakk> \<Longrightarrow> x \<in> Infinitesimal"
  by (auto elim: hrabs_le_Infinitesimal simp add: Infinitesimal_hcmod_iff)

subsection\<open>The ``Infinitely Close'' Relation\<close>

lemma approx_SComplex_mult_cancel_zero:
  "\<lbrakk>a \<in> SComplex; a \<noteq> 0; a*x \<approx> 0\<rbrakk> \<Longrightarrow> x \<approx> 0"
  by (metis Infinitesimal_mult_disj SComplex_iff mem_infmal_iff star_of_Infinitesimal_iff_0 star_zero_def)

lemma approx_mult_SComplex1: "\<lbrakk>a \<in> SComplex; x \<approx> 0\<rbrakk> \<Longrightarrow> x*a \<approx> 0"
  using SComplex_iff approx_mult_subst_star_of by fastforce

lemma approx_mult_SComplex2: "\<lbrakk>a \<in> SComplex; x \<approx> 0\<rbrakk> \<Longrightarrow> a*x \<approx> 0"
  by (metis approx_mult_SComplex1 mult.commute)

lemma approx_mult_SComplex_zero_cancel_iff [simp]:
  "\<lbrakk>a \<in> SComplex; a \<noteq> 0\<rbrakk> \<Longrightarrow> (a*x \<approx> 0) = (x \<approx> 0)"
  using approx_SComplex_mult_cancel_zero approx_mult_SComplex2 by blast

lemma approx_SComplex_mult_cancel:
     "\<lbrakk>a \<in> SComplex; a \<noteq> 0; a*w \<approx> a*z\<rbrakk> \<Longrightarrow> w \<approx> z"
  by (metis approx_SComplex_mult_cancel_zero approx_minus_iff right_diff_distrib)

lemma approx_SComplex_mult_cancel_iff1 [simp]:
     "\<lbrakk>a \<in> SComplex; a \<noteq> 0\<rbrakk> \<Longrightarrow> (a*w \<approx> a*z) = (w \<approx> z)"
  by (metis HFinite_star_of SComplex_iff approx_SComplex_mult_cancel approx_mult2)

(* TODO: generalize following theorems: hcmod -> hnorm *)

lemma approx_hcmod_approx_zero: "(x \<approx> y) = (hcmod (y - x) \<approx> 0)"
  by (simp add: Infinitesimal_hcmod_iff approx_def hnorm_minus_commute)

lemma approx_approx_zero_iff: "(x \<approx> 0) = (hcmod x \<approx> 0)"
by (simp add: approx_hcmod_approx_zero)

lemma approx_minus_zero_cancel_iff [simp]: "(-x \<approx> 0) = (x \<approx> 0)"
by (simp add: approx_def)

lemma Infinitesimal_hcmod_add_diff:
     "u \<approx> 0 \<Longrightarrow> hcmod(x + u) - hcmod x \<in> Infinitesimal"
  by (metis add.commute add.left_neutral approx_add_right_iff approx_def approx_hnorm)

lemma approx_hcmod_add_hcmod: "u \<approx> 0 \<Longrightarrow> hcmod(x + u) \<approx> hcmod x"
  using Infinitesimal_hcmod_add_diff approx_def by blast

subsection\<open>Zero is the Only Infinitesimal Complex Number\<close>

lemma Infinitesimal_less_SComplex:
  "\<lbrakk>x \<in> SComplex; y \<in> Infinitesimal; 0 < hcmod x\<rbrakk> \<Longrightarrow> hcmod y < hcmod x"
  by (auto intro: Infinitesimal_less_SReal SReal_hcmod_SComplex simp add: Infinitesimal_hcmod_iff)

lemma SComplex_Int_Infinitesimal_zero: "SComplex Int Infinitesimal = {0}"
  by (auto simp add: Standard_def Infinitesimal_hcmod_iff)

lemma SComplex_Infinitesimal_zero:
  "\<lbrakk>x \<in> SComplex; x \<in> Infinitesimal\<rbrakk> \<Longrightarrow> x = 0"
  using SComplex_iff by auto

lemma SComplex_HFinite_diff_Infinitesimal:
  "\<lbrakk>x \<in> SComplex; x \<noteq> 0\<rbrakk> \<Longrightarrow> x \<in> HFinite - Infinitesimal"
  using SComplex_iff by auto

lemma numeral_not_Infinitesimal [simp]:
  "numeral w \<noteq> (0::hcomplex) \<Longrightarrow> (numeral w::hcomplex) \<notin> Infinitesimal"
  by (fast dest: Standard_numeral [THEN SComplex_Infinitesimal_zero])

lemma approx_SComplex_not_zero:
  "\<lbrakk>y \<in> SComplex; x \<approx> y; y\<noteq> 0\<rbrakk> \<Longrightarrow> x \<noteq> 0"
  by (auto dest: SComplex_Infinitesimal_zero approx_sym [THEN mem_infmal_iff [THEN iffD2]])

lemma SComplex_approx_iff:
  "\<lbrakk>x \<in> SComplex; y \<in> SComplex\<rbrakk> \<Longrightarrow> (x \<approx> y) = (x = y)"
  by (auto simp add: Standard_def)

lemma approx_unique_complex:
  "\<lbrakk>r \<in> SComplex; s \<in> SComplex; r \<approx> x; s \<approx> x\<rbrakk> \<Longrightarrow> r = s"
  by (blast intro: SComplex_approx_iff [THEN iffD1] approx_trans2)

subsection \<open>Properties of \<^term>\<open>hRe\<close>, \<^term>\<open>hIm\<close> and \<^term>\<open>HComplex\<close>\<close>

lemma abs_hRe_le_hcmod: "\<And>x. \<bar>hRe x\<bar> \<le> hcmod x"
  by transfer (rule abs_Re_le_cmod)

lemma abs_hIm_le_hcmod: "\<And>x. \<bar>hIm x\<bar> \<le> hcmod x"
  by transfer (rule abs_Im_le_cmod)

lemma Infinitesimal_hRe: "x \<in> Infinitesimal \<Longrightarrow> hRe x \<in> Infinitesimal"
  using Infinitesimal_hcmod_iff abs_hRe_le_hcmod hrabs_le_Infinitesimal by blast

lemma Infinitesimal_hIm: "x \<in> Infinitesimal \<Longrightarrow> hIm x \<in> Infinitesimal"
  using Infinitesimal_hcmod_iff abs_hIm_le_hcmod hrabs_le_Infinitesimal by blast

lemma Infinitesimal_HComplex:
  assumes x: "x \<in> Infinitesimal" and y: "y \<in> Infinitesimal"
  shows "HComplex x y \<in> Infinitesimal"
proof -
  have "hcmod (HComplex 0 y) \<in> Infinitesimal"
    by (simp add: hcmod_i y)
  moreover have "hcmod (hcomplex_of_hypreal x) \<in> Infinitesimal"
    using Infinitesimal_hcmod_iff Infinitesimal_of_hypreal_iff x by blast
  ultimately have "hcmod (HComplex x y) \<in> Infinitesimal"
    by (metis Infinitesimal_add Infinitesimal_hcmod_iff add.right_neutral hcomplex_of_hypreal_add_HComplex)
  then show ?thesis
    by (simp add: Infinitesimal_hnorm_iff)
qed

lemma hcomplex_Infinitesimal_iff:
  "(x \<in> Infinitesimal) \<longleftrightarrow> (hRe x \<in> Infinitesimal \<and> hIm x \<in> Infinitesimal)"
  using Infinitesimal_HComplex Infinitesimal_hIm Infinitesimal_hRe by fastforce

lemma hRe_diff [simp]: "\<And>x y. hRe (x - y) = hRe x - hRe y"
  by transfer simp

lemma hIm_diff [simp]: "\<And>x y. hIm (x - y) = hIm x - hIm y"
  by transfer simp

lemma approx_hRe: "x \<approx> y \<Longrightarrow> hRe x \<approx> hRe y"
  unfolding approx_def by (drule Infinitesimal_hRe) simp

lemma approx_hIm: "x \<approx> y \<Longrightarrow> hIm x \<approx> hIm y"
  unfolding approx_def by (drule Infinitesimal_hIm) simp

lemma approx_HComplex:
  "\<lbrakk>a \<approx> b; c \<approx> d\<rbrakk> \<Longrightarrow> HComplex a c \<approx> HComplex b d"
  unfolding approx_def by (simp add: Infinitesimal_HComplex)

lemma hcomplex_approx_iff:
  "(x \<approx> y) = (hRe x \<approx> hRe y \<and> hIm x \<approx> hIm y)"
  unfolding approx_def by (simp add: hcomplex_Infinitesimal_iff)

lemma HFinite_hRe: "x \<in> HFinite \<Longrightarrow> hRe x \<in> HFinite"
  using HFinite_bounded_hcmod abs_ge_zero abs_hRe_le_hcmod by blast

lemma HFinite_hIm: "x \<in> HFinite \<Longrightarrow> hIm x \<in> HFinite"
  using HFinite_bounded_hcmod abs_ge_zero abs_hIm_le_hcmod by blast

lemma HFinite_HComplex:
  assumes "x \<in> HFinite" "y \<in> HFinite"
  shows "HComplex x y \<in> HFinite"
proof -
  have "HComplex x 0 \<in> HFinite" "HComplex 0 y \<in> HFinite"
    using HFinite_hcmod_iff assms hcmod_i by fastforce+
  then have "HComplex x 0 + HComplex 0 y \<in> HFinite"
    using HFinite_add by blast
  then show ?thesis
    by simp
qed

lemma hcomplex_HFinite_iff:
  "(x \<in> HFinite) = (hRe x \<in> HFinite \<and> hIm x \<in> HFinite)"
  using HFinite_HComplex HFinite_hIm HFinite_hRe by fastforce

lemma hcomplex_HInfinite_iff:
  "(x \<in> HInfinite) = (hRe x \<in> HInfinite \<or> hIm x \<in> HInfinite)"
  by (simp add: HInfinite_HFinite_iff hcomplex_HFinite_iff)

lemma hcomplex_of_hypreal_approx_iff [simp]:
  "(hcomplex_of_hypreal x \<approx> hcomplex_of_hypreal z) = (x \<approx> z)"
  by (simp add: hcomplex_approx_iff)

(* Here we go - easy proof now!! *)
lemma stc_part_Ex:
  assumes "x \<in> HFinite"
  shows "\<exists>t \<in> SComplex. x \<approx> t"
proof -
  let ?t = "HComplex (st (hRe x)) (st (hIm x))"
  have "?t \<in> SComplex"
    using HFinite_hIm HFinite_hRe Reals_eq_Standard assms st_SReal by auto
  moreover have "x \<approx> ?t"
    by (simp add: HFinite_hIm HFinite_hRe assms hcomplex_approx_iff st_HFinite st_eq_approx)
  ultimately show ?thesis ..
qed

lemma stc_part_Ex1: "x \<in> HFinite \<Longrightarrow> \<exists>!t. t \<in> SComplex \<and> x \<approx> t"
  using approx_sym approx_unique_complex stc_part_Ex by blast

subsection\<open>Theorems About Monads\<close>

lemma monad_zero_hcmod_iff: "(x \<in> monad 0) = (hcmod x \<in> monad 0)"
  by (simp add: Infinitesimal_monad_zero_iff [symmetric] Infinitesimal_hcmod_iff)

subsection\<open>Theorems About Standard Part\<close>

lemma stc_approx_self: "x \<in> HFinite \<Longrightarrow> stc x \<approx> x"
  unfolding stc_def
  by (metis (no_types, lifting) approx_reorient someI_ex stc_part_Ex1)

lemma stc_SComplex: "x \<in> HFinite \<Longrightarrow> stc x \<in> SComplex"
  unfolding stc_def
  by (metis (no_types, lifting) SComplex_iff approx_sym someI_ex stc_part_Ex)

lemma stc_HFinite: "x \<in> HFinite \<Longrightarrow> stc x \<in> HFinite"
  by (erule stc_SComplex [THEN Standard_subset_HFinite [THEN subsetD]])

lemma stc_unique: "\<lbrakk>y \<in> SComplex; y \<approx> x\<rbrakk> \<Longrightarrow> stc x = y"
  by (metis SComplex_approx_iff SComplex_iff approx_monad_iff approx_star_of_HFinite stc_SComplex stc_approx_self)

lemma stc_SComplex_eq [simp]: "x \<in> SComplex \<Longrightarrow> stc x = x"
  by (simp add: stc_unique)

lemma stc_eq_approx:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite; stc x = stc y\<rbrakk> \<Longrightarrow> x \<approx> y"
  by (auto dest!: stc_approx_self elim!: approx_trans3)

lemma approx_stc_eq:
     "\<lbrakk>x \<in> HFinite; y \<in> HFinite; x \<approx> y\<rbrakk> \<Longrightarrow> stc x = stc y"
  by (metis approx_sym approx_trans3 stc_part_Ex1 stc_unique)

lemma stc_eq_approx_iff:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> (x \<approx> y) = (stc x = stc y)"
  by (blast intro: approx_stc_eq stc_eq_approx)

lemma stc_Infinitesimal_add_SComplex:
  "\<lbrakk>x \<in> SComplex; e \<in> Infinitesimal\<rbrakk> \<Longrightarrow> stc(x + e) = x"
  using Infinitesimal_add_approx_self stc_unique by blast

lemma stc_Infinitesimal_add_SComplex2:
  "\<lbrakk>x \<in> SComplex; e \<in> Infinitesimal\<rbrakk> \<Longrightarrow> stc(e + x) = x"
  using Infinitesimal_add_approx_self2 stc_unique by blast

lemma HFinite_stc_Infinitesimal_add:
  "x \<in> HFinite \<Longrightarrow> \<exists>e \<in> Infinitesimal. x = stc(x) + e"
  by (blast dest!: stc_approx_self [THEN approx_sym] bex_Infinitesimal_iff2 [THEN iffD2])

lemma stc_add:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> stc (x + y) = stc(x) + stc(y)"
  by (simp add: stc_unique stc_SComplex stc_approx_self approx_add)

lemma stc_zero: "stc 0 = 0"
  by simp

lemma stc_one: "stc 1 = 1"
  by simp

lemma stc_minus: "y \<in> HFinite \<Longrightarrow> stc(-y) = -stc(y)"
  by (simp add: stc_unique stc_SComplex stc_approx_self approx_minus)

lemma stc_diff:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> stc (x-y) = stc(x) - stc(y)"
  by (simp add: stc_unique stc_SComplex stc_approx_self approx_diff)

lemma stc_mult:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk>
               \<Longrightarrow> stc (x * y) = stc(x) * stc(y)"
  by (simp add: stc_unique stc_SComplex stc_approx_self approx_mult_HFinite)

lemma stc_Infinitesimal: "x \<in> Infinitesimal \<Longrightarrow> stc x = 0"
  by (simp add: stc_unique mem_infmal_iff)

lemma stc_not_Infinitesimal: "stc(x) \<noteq> 0 \<Longrightarrow> x \<notin> Infinitesimal"
  by (fast intro: stc_Infinitesimal)

lemma stc_inverse:
  "\<lbrakk>x \<in> HFinite; stc x \<noteq> 0\<rbrakk>  \<Longrightarrow> stc(inverse x) = inverse (stc x)"
  by (simp add: stc_unique stc_SComplex stc_approx_self approx_inverse stc_not_Infinitesimal)

lemma stc_divide [simp]:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite; stc y \<noteq> 0\<rbrakk>
      \<Longrightarrow> stc(x/y) = (stc x) / (stc y)"
  by (simp add: divide_inverse stc_mult stc_not_Infinitesimal HFinite_inverse stc_inverse)

lemma stc_idempotent [simp]: "x \<in> HFinite \<Longrightarrow> stc(stc(x)) = stc(x)"
  by (blast intro: stc_HFinite stc_approx_self approx_stc_eq)

lemma HFinite_HFinite_hcomplex_of_hypreal:
  "z \<in> HFinite \<Longrightarrow> hcomplex_of_hypreal z \<in> HFinite"
  by (simp add: hcomplex_HFinite_iff)

lemma SComplex_SReal_hcomplex_of_hypreal:
     "x \<in> \<real> \<Longrightarrow>  hcomplex_of_hypreal x \<in> SComplex"
  by (simp add: Reals_eq_Standard)

lemma stc_hcomplex_of_hypreal:
 "z \<in> HFinite \<Longrightarrow> stc(hcomplex_of_hypreal z) = hcomplex_of_hypreal (st z)"
  by (simp add: SComplex_SReal_hcomplex_of_hypreal st_SReal st_approx_self stc_unique)

lemma hmod_stc_eq:
  assumes "x \<in> HFinite"
  shows "hcmod(stc x) = st(hcmod x)"
    by (metis SReal_hcmod_SComplex approx_HFinite approx_hnorm assms st_unique stc_SComplex_eq stc_eq_approx_iff stc_part_Ex)

lemma Infinitesimal_hcnj_iff [simp]:
  "(hcnj z \<in> Infinitesimal) \<longleftrightarrow> (z \<in> Infinitesimal)"
  by (simp add: Infinitesimal_hcmod_iff)

end


theory prop_01
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster take drop append *)
  theorem x0 :
    "(append (take n xs) (drop n xs)) = xs"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory SubstExp
  imports WellTypedExp
begin

    (*
      ####################################
        P2. variables in expressions
      ####################################
    *)

fun lam_vars :: "p_exp \<Rightarrow> string set" where
  "lam_vars (ConstExp c) = {}"
| "lam_vars (OpExp xop) = {}"
| "lam_vars (VarExp v) = {}"
| "lam_vars (PairExp e1 e2) = lam_vars e1 \<union> lam_vars e2"
| "lam_vars (IfExp e1 e2 e3) = lam_vars e1 \<union> lam_vars e2 \<union> lam_vars e3"
| "lam_vars (LamExp x e) = lam_vars e \<union> {x}"
| "lam_vars (AppExp e1 e2) = lam_vars e1 \<union> lam_vars e2"

  (*
definition subst_name_match where
  "subst_name_match x x' v = (x = x' \<and> v = NoRef)"
  *)
fun subst_exp :: "p_exp \<Rightarrow> string \<Rightarrow> p_exp \<Rightarrow> p_exp" where
  "subst_exp (ConstExp c) x e = ConstExp c"
| "subst_exp (OpExp xop) x e = OpExp xop"
| "subst_exp (VarExp (VarType x')) x e = (if x = x' then e else VarExp (VarType x'))"
| "subst_exp (VarExp v) x e = VarExp v"
| "subst_exp (PairExp e1 e2) x e = (PairExp (subst_exp e1 x e) (subst_exp e2 x e))"
| "subst_exp (IfExp e1 e2 e3) x e = (IfExp (subst_exp e1 x e) (subst_exp e2 x e) (subst_exp e3 x e))"
| "subst_exp (LamExp x' e') x e = (if x = x' then LamExp x' e' else LamExp x' (subst_exp e' x e))"
| "subst_exp (AppExp e1 e2) x e = (AppExp (subst_exp e1 x e) (subst_exp e2 x e))"

fun deep_alpha_rename :: "p_exp \<Rightarrow> string \<Rightarrow> string \<Rightarrow> p_exp" where
  "deep_alpha_rename (ConstExp c) x y = ConstExp c"
| "deep_alpha_rename (OpExp xop) x y = OpExp xop"
| "deep_alpha_rename (VarExp (VarType x')) x y = (if x = x' then VarExp (VarType y) else VarExp (VarType x'))"
| "deep_alpha_rename (VarExp v) x y = VarExp v"
| "deep_alpha_rename (PairExp e1 e2) x y = PairExp (deep_alpha_rename e1 x y) (deep_alpha_rename e2 x y)"
| "deep_alpha_rename (IfExp e1 e2 e3) x y =
  IfExp (deep_alpha_rename e1 x y) (deep_alpha_rename e2 x y) (deep_alpha_rename e3 x y)"
| "deep_alpha_rename (LamExp x' e) x y = (if x = x' then LamExp y (deep_alpha_rename e x y)
  else LamExp x' (deep_alpha_rename e x y))"
| "deep_alpha_rename (AppExp e1 e2) x y = AppExp (deep_alpha_rename e1 x y) (deep_alpha_rename e2 x y)"

fun lam_var_remove :: "p_exp \<Rightarrow> string \<Rightarrow> string \<Rightarrow> p_exp" where
  "lam_var_remove (ConstExp c) x y = ConstExp c"
| "lam_var_remove (OpExp xop) x y = OpExp xop"
| "lam_var_remove (VarExp v) x y = VarExp v"
| "lam_var_remove (PairExp e1 e2) x y = PairExp (lam_var_remove e1 x y) (lam_var_remove e2 x y)"
| "lam_var_remove (IfExp e1 e2 e3) x y = IfExp (lam_var_remove e1 x y) (lam_var_remove e2 x y) (lam_var_remove e3 x y)"
| "lam_var_remove (LamExp x' e) x y = (if x = x' then LamExp y (deep_alpha_rename e x y)
  else LamExp x' (lam_var_remove e x y))"
| "lam_var_remove (AppExp e1 e2) x y = AppExp (lam_var_remove e1 x y) (lam_var_remove e2 x y)"

fun pre_vars :: "('a * 'a) list \<Rightarrow> 'a set" where
  "pre_vars Nil = {}"
| "pre_vars ((x, y) # t) = {x} \<union> pre_vars t"

fun post_vars :: "('a * 'a) list \<Rightarrow> 'a set" where
  "post_vars Nil = {}"
| "post_vars ((x, y) # t) = {y} \<union> post_vars t"

fun unique_post_vars :: "('a * 'a) list \<Rightarrow> bool" where
  "unique_post_vars Nil = True"
| "unique_post_vars ((x, y) # t) = (y \<notin> post_vars t \<and> unique_post_vars t)"

fun lam_var_list_remove :: "p_exp \<Rightarrow> (string * string) list \<Rightarrow> p_exp" where
  "lam_var_list_remove e Nil = e"
| "lam_var_list_remove e ((x, y) # t) = lam_var_list_remove (lam_var_remove e x y) t"

  (***** a valid substitution must rename all lambdas in e to avoid the free variables of e' ****)

definition safe_subst_exp :: "p_exp \<Rightarrow> string \<Rightarrow> p_exp \<Rightarrow> p_exp \<Rightarrow> bool" where
  "safe_subst_exp e x e' e_f = (\<exists> vl. unique_post_vars vl \<and> pre_vars vl = lam_vars e \<and>
    x \<notin> ref_vars e \<and> post_vars vl \<inter> (lam_vars e \<union> free_vars e \<union> free_vars e' \<union> ref_vars e \<union> ref_vars e') = {} \<and>
    subst_exp (lam_var_list_remove e vl) x e' = e_f)"

lemma eq_own: "\<exists> r. is_own r"
  apply (rule_tac x="OwnPerm" in exI)
  apply (simp add: is_own_def)
  done

    (*
      ####################################
        P11. start for substitution type preservation
      ####################################
    *)

lemma subst_free_vars: "\<lbrakk> x \<in> free_vars (subst_exp e y e') \<rbrakk> \<Longrightarrow> (x \<in> free_vars e \<and> x \<noteq> y) \<or> x \<in> free_vars e'"
  apply (induct e)
        apply (auto)
      apply (case_tac xa)
       apply (auto)
      apply (case_tac "y = x1")
       apply (auto)
     apply (case_tac xa)
      apply (auto)
     apply (case_tac "y = x1")
      apply (auto)
    apply (case_tac "y = x1a")
     apply (auto)
   apply (case_tac "y = x")
    apply (auto)
  apply (case_tac "y = x1a")
   apply (auto)
  done

lemma free_res_vars: "\<lbrakk> Var x \<in> res_vars e \<rbrakk> \<Longrightarrow> x \<in> free_vars e"
  apply (induct e)
        apply (auto)
  apply (case_tac xa)
   apply (auto)
  done

lemma free_res_vars_rev: "\<lbrakk> x \<in> free_vars e \<rbrakk> \<Longrightarrow> Var x \<in> res_vars e"
  apply (induct e)
        apply (auto)
  apply (case_tac xa)
   apply (auto)
  done

lemma subst_res_vars: "\<lbrakk> x \<in> res_vars (subst_exp e y e') \<rbrakk> \<Longrightarrow> (x \<in> res_vars e \<and> x \<noteq> Var y) \<or> x \<in> res_vars e'"
  apply (induct e)
        apply (auto)
      apply (case_tac xa)
       apply (auto)
      apply (case_tac "y = x1")
       apply (auto)
     apply (case_tac xa)
      apply (auto)
     apply (case_tac "y = x1")
      apply (auto)
    apply (case_tac "y = x1a")
     apply (auto)
   apply (case_tac "y = x1a")
    apply (auto)
  apply (case_tac "y = x1a")
   apply (auto)
  done

lemma subst_np_vars: "\<lbrakk> x \<in> non_prim_vars env (subst_exp e y e') \<rbrakk> \<Longrightarrow> (x \<in> non_prim_vars env e \<and> x \<noteq> Var y) \<or> x \<in> non_prim_vars env e'"
  apply (simp add: non_prim_vars_def)
  apply (auto)
   apply (cut_tac x="x" and y="y" and e="e" and e'="e'" in subst_res_vars)
    apply (auto)
  apply (cut_tac x="x" and y="y" and e="e" and e'="e'" in subst_res_vars)
   apply (auto)
  done
    (*
lemma no_subst_ref_vars: "\<lbrakk> x \<notin> free_vars e; y \<notin> ref_vars e \<rbrakk> \<Longrightarrow> y \<notin> ref_vars (subst_exp e x e')"
  apply (induct e)
        apply (auto)
 (* apply (simp add: subst_name_match_def)*)
  done

lemma subst_ref_vars: "\<lbrakk> y \<notin> ref_vars e; y \<notin> ref_vars e' \<rbrakk> \<Longrightarrow> y \<notin> ref_vars (subst_exp e x e')"
  apply (induct e)
        apply (auto)
  done*)

lemma subst_type_preserve_no_fv: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; x \<notin> free_vars e \<rbrakk> \<Longrightarrow> well_typed env r_s1 (subst_exp e x e') tau r_s2 rx"
  apply (induction e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
      apply (case_tac xa)
       apply (auto)
     (*  apply (simp add: subst_name_match_def)*)
    (* pair case *)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="r_s3" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
      apply (rule_tac x="rx2" in exI)
      apply (auto)
    (* if case *)
     apply (rule_tac x="rx'" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (auto)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
    (* lambda case *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="r_end" in exI)
   apply (rule_tac x="r_s'" in exI)
   apply (auto)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (auto)
  done

end