theory ShortestPathNeg

(*
  This theory uses the graph library and
  several lemmas that were proven in the
  shortest path theory
*)
imports
  "../Graph_Theory/Graph_Theory"
  "ShortestPath"

begin
section {*Shortest Path (with general edge costs)*}
(*
  In this locale we assume we are given a
  wellformed directed graph $G = (V,E)$ with
  finite $V$ and $E$ (this is the assumption
  $graphG$). Moreover, a source vertex $s$ in
  $V$ . In addition, a cost function c, a function
 $num:V\to \Nat$, $parent\dash edge:V\to E \cup $*)
locale shortest_paths_locale_step1 =
  fixes G :: "('a, 'b) pre_digraph" (structure)
  fixes s :: "'a"
  fixes c :: "'b \<Rightarrow> real"
  fixes num :: "'a \<Rightarrow> nat"
  fixes parent_edge :: "'a \<Rightarrow> 'b option"
  fixes dist :: "'a  \<Rightarrow> ereal"
  assumes graphG: "fin_digraph G"
  assumes s_assms:
    "s \<in> verts G"
    "dist s \<noteq> \<infinity>"
    "parent_edge s = None"
    "num s = 0"
  assumes  parent_num_assms:
    "\<And>v.  \<lbrakk>v \<in> verts G; v \<noteq> s; dist v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
    (\<exists>e \<in> arcs G. parent_edge v = Some e \<and>
    head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
    num v  = num (tail G e) + 1)"
  assumes noPedge: "\<And>e. e\<in>arcs G \<Longrightarrow>
    dist (tail G e) \<noteq> \<infinity> \<Longrightarrow> dist (head G e) \<noteq> \<infinity>"

sublocale shortest_paths_locale_step1 \<subseteq> fin_digraph G
  using graphG by auto

definition (in shortest_paths_locale_step1) enum :: "'a \<Rightarrow> enat" where
  "enum v = (if (dist v = \<infinity> \<or> dist v = - \<infinity>) then \<infinity> else num v)"

locale shortest_paths_locale_step2 =
  shortest_paths_locale_step1 +
  basic_just_sp G dist c s enum +
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"

function (in shortest_paths_locale_step1) pwalk :: "'a \<Rightarrow> 'b list"
where
  "pwalk v =
    (if (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G)
      then []
      else pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]
    )"
by auto
termination (in shortest_paths_locale_step1)
  using parent_num_assms
  by (relation "measure num", auto, fastforce)

lemma (in shortest_paths_locale_step1) pwalk_simps:
  "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G \<Longrightarrow> pwalk v = []"
  "v \<noteq> s \<Longrightarrow> dist v \<noteq> \<infinity> \<Longrightarrow> v \<in> verts G \<Longrightarrow>
    pwalk v = pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]"
by auto

definition (in shortest_paths_locale_step1) pwalk_verts :: "'a  \<Rightarrow> 'a set" where
  "pwalk_verts v = {u. u \<in> set (awalk_verts s (pwalk v))}"

locale shortest_paths_locale_step3 =
  shortest_paths_locale_step2 +
  fixes C :: "('a \<times>('b awalk)) set"
  assumes C_se:
    "C \<subseteq> {(u, p). dist u \<noteq> \<infinity> \<and> awalk u p u \<and> awalk_cost c p < 0}"
  assumes int_neg_cyc:
    "\<And>v. v \<in> verts G \<Longrightarrow> dist v = -\<infinity> \<Longrightarrow>
      (fst ` C) \<inter> pwalk_verts v  \<noteq> {}"

locale shortest_paths_locale_step2_pred =
  shortest_paths_locale_step1 +
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes bj: "basic_just_sp_pred G dist c s enum pred"
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"
(*
sublocale shortest_paths_locale_step2_pred \<subseteq> shortest_paths_locale_step2
using shortest_paths_locale_step2_pred_axioms
unfolding shortest_paths_locale_step2_pred_def
   shortest_paths_locale_step2_pred_axioms_def
   shortest_paths_locale_step2_def
   shortest_paths_locale_step2_axioms_def
try0
*)

lemma (in shortest_paths_locale_step1) num_s_is_min:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows "num v > 0"
     using parent_num_assms[OF assms] by fastforce

lemma (in shortest_paths_locale_step1) path_from_root_Vr_ex:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows  "\<exists>e. s \<rightarrow>\<^sup>* tail G e \<and>
          e \<in> arcs G \<and> head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
          parent_edge v = Some e \<and> num v = num (tail G e) + 1"
using assms
proof(induct "num v - 1" arbitrary : v)
case 0
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF 0(2-4)] by fast
  have "tail G e = s"
    using num_s_is_min[OF tail_in_verts [OF ee(1)] _ ee(3)]
    ee(5) 0(1) by auto
  then show ?case using ee by auto
next
case (Suc n')
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF Suc(3-5)] by fast
  then have ss: "tail G e \<noteq> s"
    using num_s_is_min tail_in_verts
    Suc(2) s_assms(4) by force
  have nst: "n' = num (tail G e) - 1"
    using ee(5) Suc(2) by presburger
  obtain e' where reach: "s \<rightarrow>\<^sup>* tail G e'" and
    e': "e' \<in> arcs G" "head G e' = tail G e" "dist (tail G e') \<noteq> \<infinity>"
    using Suc(1)[OF nst tail_in_verts[OF ee(1)] ss ee(3)] by blast
  from reach also have "tail G e' \<rightarrow> tail G e" using e'
    by (metis in_arcs_imp_in_arcs_ends)
  finally show ?case using e' ee by auto
qed

lemma (in shortest_paths_locale_step1) path_from_root_Vr:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "s \<rightarrow>\<^sup>* v"
proof(cases "v = s")
case True thus ?thesis using assms by simp
next
case False
  obtain e where "s \<rightarrow>\<^sup>* tail G e" "e \<in> arcs G" "head G e = v"
      using path_from_root_Vr_ex[OF assms(1) False assms(2)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e" "tail G e \<rightarrow> v"
    by (auto intro: in_arcs_imp_in_arcs_ends)
  then show ?thesis by (rule reachable_adj_trans)
qed

lemma (in shortest_paths_locale_step1) \<mu>_V_less_inf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "\<mu> c s v \<noteq> \<infinity>"
  using assms path_from_root_Vr \<mu>_reach_conv by force

lemma (in shortest_paths_locale_step2) enum_not0:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "enum v \<noteq> \<infinity>"
  shows "enum v \<noteq> enat 0"
     using parent_num_assms[OF assms(1,2)] assms unfolding enum_def by auto

lemma (in shortest_paths_locale_step2) dist_Vf_\<mu>:
  fixes v :: 'a
  assumes vG: "v \<in> verts G"
  assumes "\<exists>r. dist v = ereal r"
  shows "dist v = \<mu> c s v"
proof -
  have ds: "dist s =  0"
    using assms source_val unfolding enum_def by force
  have ews:"awalk s [] s"
    using s_assms(1) unfolding awalk_def by simp
  have mu: "\<mu> c s s = ereal 0"
    using min_cost_le_walk_cost[OF ews, where c=c]
    awalk_cost_Nil ds  dist_le_\<mu>[OF s_assms(1)] zero_ereal_def
    by simp
  thus ?thesis
    using ds assms dist_le_\<mu>[OF vG]
    dist_ge_\<mu>[OF vG _ _ mu ds enum_not0]
    unfolding enum_def by fastforce
qed

lemma (in shortest_paths_locale_step1) pwalk_awalk:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "awalk s (pwalk v) v"
proof (cases "v=s")
case True
  thus ?thesis
    using assms pwalk.simps[where v=v]
    awalk_Nil_iff by presburger
next
case False
  from assms show ?thesis
  proof (induct rule: pwalk.induct)
    fix v
    let ?e = "the (parent_edge v)"
    let ?u = "tail G ?e"
    assume ewu: "\<not> (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G) \<Longrightarrow>
                 ?u \<in> verts G \<Longrightarrow> dist ?u \<noteq> \<infinity> \<Longrightarrow>
                 awalk s (pwalk ?u) ?u"
    assume vG: "v \<in> verts G"
    assume dv: "dist v \<noteq> \<infinity>"
    thus "awalk s (pwalk v) v "
    proof (cases "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G")
    case True
      thus ?thesis
        using pwalk.simps vG dv
        awalk_Nil_iff by fastforce
    next
    case False
      obtain e  where ee:
        "e \<in>arcs G"
        "parent_edge v = Some e"
        "head G e = v"
        "dist (tail G e) \<noteq> \<infinity>"
        using parent_num_assms False by blast
      hence "awalk s (pwalk ?u) ?u"
        using ewu[OF False] tail_in_verts by simp
      hence "awalk s (pwalk (tail G e) @ [e]) v"
        using ee(1-3) vG
        by (auto simp: awalk_simps simp del: pwalk.simps)
      also have "pwalk (tail G e) @ [e] = pwalk v"
        using False ee(2) unfolding pwalk.simps[where v=v] by auto
      finally show ?thesis .
    qed
  qed
qed

lemma (in shortest_paths_locale_step3) \<mu>_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v = - \<infinity>"
  shows "\<mu> c s v = - \<infinity>"
proof -
  have "awalk s (pwalk v) v"
    using pwalk_awalk assms by force
moreover
  obtain w where ww: "w \<in> fst ` C \<inter> pwalk_verts v"
    using int_neg_cyc[OF assms] by blast
  then obtain q where
     "awalk w q w"
     "awalk_cost c q < 0"
     using C_se by auto
moreover
  have "w \<in> set (awalk_verts s (pwalk v))"
    using ww unfolding pwalk_verts_def by fast
ultimately
  show ?thesis using  neg_cycle_imp_inf_\<mu> by force
qed

lemma (in shortest_paths_locale_step3) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
proof(cases "dist v")
show " \<And>r. dist v = ereal r \<Longrightarrow> dist v = \<mu> c s v"
  using dist_Vf_\<mu>[OF assms] by simp
next
show "dist v = \<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_V_less_inf[OF assms]
  dist_le_\<mu>[OF assms] by simp
next
show "dist v = -\<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_ninf[OF assms] by simp
qed

end


section {* Substitution *}

theory utp_subst
imports
  utp_expr
  utp_unrest
begin

subsection {* Substitution definitions *}

text {* We introduce a polymorphic constant that will be used to represent application of
        a substitution, and also a set of theorems to represent laws. *}

consts
  usubst :: "'s \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "\<dagger>" 80)

named_theorems usubst

text {* A substitution is simply a transformation on the alphabet; it shows how variables
        should be mapped to different values. *}

type_synonym ('\<alpha>,'\<beta>) psubst = "'\<alpha> alphabet \<Rightarrow> '\<beta> alphabet"
type_synonym '\<alpha> usubst = "'\<alpha> alphabet \<Rightarrow> '\<alpha> alphabet"

lift_definition subst :: "('\<alpha>, '\<beta>) psubst \<Rightarrow> ('a, '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" is
"\<lambda> \<sigma> e b. e (\<sigma> b)" .

adhoc_overloading
  usubst subst

text {* Update the value of a variable to an expression in a substitution *}

consts subst_upd :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> 'v \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst"

definition subst_upd_uvar :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('a, '\<beta>) uvar \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst" where
"subst_upd_uvar \<sigma> x v = (\<lambda> b. put\<^bsub>x\<^esub> (\<sigma> b) (\<lbrakk>v\<rbrakk>\<^sub>eb))"

adhoc_overloading
  subst_upd subst_upd_uvar

text {* Lookup the expression associated with a variable in a substitution *}

lift_definition usubst_lookup :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('a, '\<beta>) uvar \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<langle>_\<rangle>\<^sub>s")
is "\<lambda> \<sigma> x b. get\<^bsub>x\<^esub> (\<sigma> b)" .

text {* Relational lifting of a substitution to the first element of the state space *}

definition unrest_usubst :: "('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> usubst \<Rightarrow> bool"
where "unrest_usubst x \<sigma> = (\<forall> \<rho> v. \<sigma> (put\<^bsub>x\<^esub> \<rho> v) = put\<^bsub>x\<^esub> (\<sigma> \<rho>) v)"

adhoc_overloading
  unrest unrest_usubst

nonterminal smaplet and smaplets

syntax
  "_smaplet"  :: "[salpha, 'a] => smaplet"             ("_ /\<mapsto>\<^sub>s/ _")
  ""          :: "smaplet => smaplets"            ("_")
  "_SMaplets" :: "[smaplet, smaplets] => smaplets" ("_,/ _")
  "_SubstUpd" :: "['m usubst, smaplets] => 'm usubst" ("_/'(_')" [900,0] 900)
  "_Subst"    :: "smaplets => 'a \<rightharpoonup> 'b"            ("(1[_])")

translations
  "_SubstUpd m (_SMaplets xy ms)"     == "_SubstUpd (_SubstUpd m xy) ms"
  "_SubstUpd m (_smaplet x y)"        == "CONST subst_upd m x y"
  "_Subst ms"                         == "_SubstUpd (CONST id) ms"
  "_Subst (_SMaplets ms1 ms2)"        <= "_SubstUpd (_Subst ms1) ms2"
  "_SMaplets ms1 (_SMaplets ms2 ms3)" <= "_SMaplets (_SMaplets ms1 ms2) ms3"

text {* Deletion of a substitution maplet *}

definition subst_del :: "'\<alpha> usubst \<Rightarrow> ('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> usubst" (infix "-\<^sub>s" 85) where
"subst_del \<sigma> x = \<sigma>(x \<mapsto>\<^sub>s &x)"

subsection {* Substitution laws *}

text {* We set up a simple substitution tactic that applies substitution and unrestriction laws *}

method subst_tac = (simp add: usubst unrest)?

lemma usubst_lookup_id [usubst]: "\<langle>id\<rangle>\<^sub>s x = var x"
  by (transfer, simp)

lemma usubst_lookup_upd [usubst]:
  assumes "mwb_lens x"
  shows "\<langle>\<sigma>(x \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x = v"
  using assms
  by (simp add: subst_upd_uvar_def, transfer) (simp)

lemma usubst_upd_idem [usubst]:
  assumes "mwb_lens x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, x \<mapsto>\<^sub>s v) = \<sigma>(x \<mapsto>\<^sub>s v)"
  by (simp add: subst_upd_uvar_def assms comp_def)

lemma usubst_upd_comm:
  assumes "x \<bowtie> y"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v) = \<sigma>(y \<mapsto>\<^sub>s v, x \<mapsto>\<^sub>s u)"
  using assms
  by (rule_tac ext, auto simp add: subst_upd_uvar_def assms comp_def lens_indep_comm)

lemma usubst_upd_comm2:
  assumes "z \<bowtie> y" and "mwb_lens x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v, z \<mapsto>\<^sub>s s) = \<sigma>(x \<mapsto>\<^sub>s u, z \<mapsto>\<^sub>s s, y \<mapsto>\<^sub>s v)"
  using assms
  by (rule_tac ext, auto simp add: subst_upd_uvar_def assms comp_def lens_indep_comm)

lemma swap_usubst_inj:
  fixes x y :: "('a, '\<alpha>) uvar"
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "inj [x \<mapsto>\<^sub>s &y, y \<mapsto>\<^sub>s &x]"
  using assms
  apply (auto simp add: inj_on_def subst_upd_uvar_def)
  apply (smt lens_indep_get lens_indep_sym var.rep_eq vwb_lens.put_eq vwb_lens_wb wb_lens_weak weak_lens.put_get)
done

lemma usubst_upd_var_id [usubst]:
  "vwb_lens x \<Longrightarrow> [x \<mapsto>\<^sub>s var x] = id"
  apply (simp add: subst_upd_uvar_def)
  apply (transfer)
  apply (rule ext)
  apply (auto)
done

lemma usubst_upd_comm_dash [usubst]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "\<sigma>($x\<acute> \<mapsto>\<^sub>s v, $x \<mapsto>\<^sub>s u) = \<sigma>($x \<mapsto>\<^sub>s u, $x\<acute> \<mapsto>\<^sub>s v)"
  using out_in_indep usubst_upd_comm by blast

lemma usubst_lookup_upd_indep [usubst]:
  assumes "mwb_lens x" "x \<bowtie> y"
  shows "\<langle>\<sigma>(y \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x = \<langle>\<sigma>\<rangle>\<^sub>s x"
  using assms
  by (simp add: subst_upd_uvar_def, transfer, simp)

lemma usubst_apply_unrest [usubst]:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s x = var x"
  by (simp add: unrest_usubst_def, transfer, auto simp add: fun_eq_iff, metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)

lemma subst_del_id [usubst]:
  "vwb_lens x \<Longrightarrow> id -\<^sub>s x = id"
  by (simp add: subst_del_def subst_upd_uvar_def, transfer, auto)

lemma subst_del_upd_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) -\<^sub>s x = \<sigma> -\<^sub>s x"
  by (simp add: subst_del_def subst_upd_uvar_def)

lemma subst_del_upd_diff [usubst]:
  "x \<bowtie> y \<Longrightarrow> \<sigma>(y \<mapsto>\<^sub>s v) -\<^sub>s x = (\<sigma> -\<^sub>s x)(y \<mapsto>\<^sub>s v)"
  by (simp add: subst_del_def subst_upd_uvar_def lens_indep_comm)

lemma subst_unrest [usubst]: "x \<sharp> P \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> P = \<sigma> \<dagger> P"
  by (simp add: subst_upd_uvar_def, transfer, auto)

lemma subst_compose_upd [usubst]: "x \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<circ> \<rho>(x \<mapsto>\<^sub>s v) = (\<sigma> \<circ> \<rho>)(x \<mapsto>\<^sub>s v) "
  by (simp add: subst_upd_uvar_def, transfer, auto simp add: unrest_usubst_def)

lemma id_subst [usubst]: "id \<dagger> v = v"
  by (transfer, simp)

lemma subst_lit [usubst]: "\<sigma> \<dagger> \<guillemotleft>v\<guillemotright> = \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

lemma subst_var [usubst]: "\<sigma> \<dagger> var x = \<langle>\<sigma>\<rangle>\<^sub>s x"
  by (transfer, simp)

lemma usubst_ulambda [usubst]: "\<sigma> \<dagger> (\<lambda> x \<bullet> P(x)) = (\<lambda> x \<bullet> \<sigma> \<dagger> P(x))"
  by (transfer, simp)

lemma unrest_usubst_del [unrest]: "\<lbrakk> vwb_lens x; x \<sharp> (\<langle>\<sigma>\<rangle>\<^sub>s x); x \<sharp> \<sigma> -\<^sub>s x \<rbrakk> \<Longrightarrow>  x \<sharp> (\<sigma> \<dagger> P)"
  by (simp add: subst_del_def subst_upd_uvar_def unrest_upred_def unrest_usubst_def subst.rep_eq usubst_lookup.rep_eq)
     (metis vwb_lens.put_eq)

text {* We set up a purely syntactic order on variable lenses which is useful for the substitution
        normal form. *}

definition var_name_ord :: "('a, '\<alpha>) uvar \<Rightarrow> ('b, '\<alpha>) uvar \<Rightarrow> bool" where
[no_atp]: "var_name_ord x y = True"

syntax
  "_var_name_ord" :: "salpha \<Rightarrow> salpha \<Rightarrow> bool" (infix "\<prec>\<^sub>v" 65)

translations
  "_var_name_ord x y" == "CONST var_name_ord x y"

lemma usubst_upd_comm_ord [usubst]:
  assumes "x \<bowtie> y" "y \<prec>\<^sub>v x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v) = \<sigma>(y \<mapsto>\<^sub>s v, x \<mapsto>\<^sub>s u)"
  by (simp add: assms(1) usubst_upd_comm)

text {* We add the symmetric definition of input and output variables to substitution laws
        so that the variables are correctly normalised after substitution. *}

lemma subst_uop [usubst]: "\<sigma> \<dagger> uop f v = uop f (\<sigma> \<dagger> v)"
  by (transfer, simp)

lemma subst_bop [usubst]: "\<sigma> \<dagger> bop f u v = bop f (\<sigma> \<dagger> u) (\<sigma> \<dagger> v)"
  by (transfer, simp)

lemma subst_trop [usubst]: "\<sigma> \<dagger> trop f u v w = trop f (\<sigma> \<dagger> u) (\<sigma> \<dagger> v) (\<sigma> \<dagger> w)"
  by (transfer, simp)

lemma subst_qtop [usubst]: "\<sigma> \<dagger> qtop f u v w x = qtop f (\<sigma> \<dagger> u) (\<sigma> \<dagger> v) (\<sigma> \<dagger> w) (\<sigma> \<dagger> x)"
  by (transfer, simp)

lemma subst_plus [usubst]: "\<sigma> \<dagger> (x + y) = \<sigma> \<dagger> x + \<sigma> \<dagger> y"
  by (simp add: plus_uexpr_def subst_bop)

lemma subst_times [usubst]: "\<sigma> \<dagger> (x * y) = \<sigma> \<dagger> x * \<sigma> \<dagger> y"
  by (simp add: times_uexpr_def subst_bop)

lemma subst_mod [usubst]: "\<sigma> \<dagger> (x mod y) = \<sigma> \<dagger> x mod \<sigma> \<dagger> y"
  by (simp add: mod_uexpr_def usubst)

lemma subst_div [usubst]: "\<sigma> \<dagger> (x div y) = \<sigma> \<dagger> x div \<sigma> \<dagger> y"
  by (simp add: divide_uexpr_def usubst)

lemma subst_minus [usubst]: "\<sigma> \<dagger> (x - y) = \<sigma> \<dagger> x - \<sigma> \<dagger> y"
  by (simp add: minus_uexpr_def subst_bop)

lemma subst_uminus [usubst]: "\<sigma> \<dagger> (- x) = - (\<sigma> \<dagger> x)"
  by (simp add: uminus_uexpr_def subst_uop)

lemma usubst_sgn [usubst]: "\<sigma> \<dagger> sgn x = sgn (\<sigma> \<dagger> x)"
  by (simp add: sgn_uexpr_def subst_uop)

lemma usubst_abs [usubst]: "\<sigma> \<dagger> abs x = abs (\<sigma> \<dagger> x)"
  by (simp add: abs_uexpr_def subst_uop)

lemma subst_zero [usubst]: "\<sigma> \<dagger> 0 = 0"
  by (simp add: zero_uexpr_def subst_lit)

lemma subst_one [usubst]: "\<sigma> \<dagger> 1 = 1"
  by (simp add: one_uexpr_def subst_lit)

lemma subst_eq_upred [usubst]: "\<sigma> \<dagger> (x =\<^sub>u y) = (\<sigma> \<dagger> x =\<^sub>u \<sigma> \<dagger> y)"
  by (simp add: eq_upred_def usubst)

lemma subst_subst [usubst]: "\<sigma> \<dagger> \<rho> \<dagger> e = (\<rho> \<circ> \<sigma>) \<dagger> e"
  by (transfer, simp)

lemma subst_upd_comp [usubst]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "\<rho>(x \<mapsto>\<^sub>s v) \<circ> \<sigma> = (\<rho> \<circ> \<sigma>)(x \<mapsto>\<^sub>s \<sigma> \<dagger> v)"
  by (rule ext, simp add:uexpr_defs subst_upd_uvar_def, transfer, simp)

nonterminal uexprs and svars and salphas

syntax
  "_psubst"  :: "[logic, svars, uexprs] \<Rightarrow> logic"
  "_subst"   :: "logic \<Rightarrow> uexprs \<Rightarrow> salphas \<Rightarrow> logic" ("(_\<lbrakk>_'/_\<rbrakk>)" [999,0,0] 1000)
  "_uexprs"  :: "[logic, uexprs] => uexprs" ("_,/ _")
  ""         :: "logic => uexprs" ("_")
  "_svars"   :: "[svar, svars] => svars" ("_,/ _")
  ""         :: "svar => svars" ("_")
  "_salphas" :: "[salpha, salphas] => salphas" ("_,/ _")
  ""         :: "salpha => salphas" ("_")

translations
  "_subst P es vs" => "CONST subst (_psubst (CONST id) vs es) P"
  "_psubst m (_salphas x xs) (_uexprs v vs)" => "_psubst (_psubst m x v) xs vs"
  "_psubst m x v"  => "CONST subst_upd m x v"
  "P\<lbrakk>v/$x\<rbrakk>" <= "CONST usubst (CONST subst_upd (CONST id) (CONST ivar x) v) P"
  "P\<lbrakk>v/$x\<acute>\<rbrakk>" <= "CONST usubst (CONST subst_upd (CONST id) (CONST ovar x) v) P"
  "P\<lbrakk>v/x\<rbrakk>" <= "CONST usubst (CONST subst_upd (CONST id) x v) P"

lemma subst_singleton:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "x \<sharp> \<sigma>"
  shows "\<sigma>(x \<mapsto>\<^sub>s v) \<dagger> P = (\<sigma> \<dagger> P)\<lbrakk>v/x\<rbrakk>"
  using assms
  by (simp add: usubst)

lemmas subst_to_singleton = subst_singleton id_subst

subsection {* Unrestriction laws *}

lemma unrest_usubst_single [unrest]:
  "\<lbrakk> mwb_lens x; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> P\<lbrakk>v/x\<rbrakk>"
  by (transfer, auto simp add: subst_upd_uvar_def unrest_upred_def)

lemma unrest_usubst_id [unrest]:
  "mwb_lens x \<Longrightarrow> x \<sharp> id"
  by (simp add: unrest_usubst_def)

lemma unrest_usubst_upd [unrest]:
  "\<lbrakk> x \<bowtie> y; x \<sharp> \<sigma>; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> \<sigma>(y \<mapsto>\<^sub>s v)"
  by (simp add: subst_upd_uvar_def unrest_usubst_def unrest_upred.rep_eq lens_indep_comm)

lemma unrest_subst [unrest]:
  "\<lbrakk> x \<sharp> P; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> x \<sharp> (\<sigma> \<dagger> P)"
  by (transfer, simp add: unrest_usubst_def)
end


(*  Title:      HOL/Quotient_Examples/Quotient_Message.thy
    Author:     Christian Urban

Message datatype, based on an older version by Larry Paulson.
*)

theory Quotient_Message
imports Main "~~/src/HOL/Library/Quotient_Syntax"
begin

subsection\<open>Defining the Free Algebra\<close>

datatype
  freemsg = NONCE  nat
        | MPAIR  freemsg freemsg
        | CRYPT  nat freemsg
        | DECRYPT  nat freemsg

inductive
  msgrel::"freemsg \<Rightarrow> freemsg \<Rightarrow> bool" (infixl "\<sim>" 50)
where
  CD:    "CRYPT K (DECRYPT K X) \<sim> X"
| DC:    "DECRYPT K (CRYPT K X) \<sim> X"
| NONCE: "NONCE N \<sim> NONCE N"
| MPAIR: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> MPAIR X Y \<sim> MPAIR X' Y'"
| CRYPT: "X \<sim> X' \<Longrightarrow> CRYPT K X \<sim> CRYPT K X'"
| DECRYPT: "X \<sim> X' \<Longrightarrow> DECRYPT K X \<sim> DECRYPT K X'"
| SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
| TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"

lemmas msgrel.intros[intro]

text\<open>Proving that it is an equivalence relation\<close>

lemma msgrel_refl: "X \<sim> X"
by (induct X) (auto intro: msgrel.intros)

theorem equiv_msgrel: "equivp msgrel"
proof (rule equivpI)
  show "reflp msgrel" by (rule reflpI) (simp add: msgrel_refl)
  show "symp msgrel" by (rule sympI) (blast intro: msgrel.SYM)
  show "transp msgrel" by (rule transpI) (blast intro: msgrel.TRANS)
qed

subsection\<open>Some Functions on the Free Algebra\<close>

subsubsection\<open>The Set of Nonces\<close>

primrec
  freenonces :: "freemsg \<Rightarrow> nat set"
where
  "freenonces (NONCE N) = {N}"
| "freenonces (MPAIR X Y) = freenonces X \<union> freenonces Y"
| "freenonces (CRYPT K X) = freenonces X"
| "freenonces (DECRYPT K X) = freenonces X"

theorem msgrel_imp_eq_freenonces:
  assumes a: "U \<sim> V"
  shows "freenonces U = freenonces V"
  using a by (induct) (auto)

subsubsection\<open>The Left Projection\<close>

text\<open>A function to return the left part of the top pair in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.\<close>
primrec
  freeleft :: "freemsg \<Rightarrow> freemsg"
where
  "freeleft (NONCE N) = NONCE N"
| "freeleft (MPAIR X Y) = X"
| "freeleft (CRYPT K X) = freeleft X"
| "freeleft (DECRYPT K X) = freeleft X"

text\<open>This theorem lets us prove that the left function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
lemma msgrel_imp_eqv_freeleft_aux:
  shows "freeleft U \<sim> freeleft U"
  by (fact msgrel_refl)

theorem msgrel_imp_eqv_freeleft:
  assumes a: "U \<sim> V"
  shows "freeleft U \<sim> freeleft V"
  using a
  by (induct) (auto intro: msgrel_imp_eqv_freeleft_aux)

subsubsection\<open>The Right Projection\<close>

text\<open>A function to return the right part of the top pair in a message.\<close>
primrec
  freeright :: "freemsg \<Rightarrow> freemsg"
where
  "freeright (NONCE N) = NONCE N"
| "freeright (MPAIR X Y) = Y"
| "freeright (CRYPT K X) = freeright X"
| "freeright (DECRYPT K X) = freeright X"

text\<open>This theorem lets us prove that the right function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
lemma msgrel_imp_eqv_freeright_aux:
  shows "freeright U \<sim> freeright U"
  by (fact msgrel_refl)

theorem msgrel_imp_eqv_freeright:
  assumes a: "U \<sim> V"
  shows "freeright U \<sim> freeright V"
  using a
  by (induct) (auto intro: msgrel_imp_eqv_freeright_aux)

subsubsection\<open>The Discriminator for Constructors\<close>

text\<open>A function to distinguish nonces, mpairs and encryptions\<close>
primrec
  freediscrim :: "freemsg \<Rightarrow> int"
where
   "freediscrim (NONCE N) = 0"
 | "freediscrim (MPAIR X Y) = 1"
 | "freediscrim (CRYPT K X) = freediscrim X + 2"
 | "freediscrim (DECRYPT K X) = freediscrim X - 2"

text\<open>This theorem helps us prove @{term "Nonce N \<noteq> MPair X Y"}\<close>
theorem msgrel_imp_eq_freediscrim:
  assumes a: "U \<sim> V"
  shows "freediscrim U = freediscrim V"
  using a by (induct) (auto)

subsection\<open>The Initial Algebra: A Quotiented Message Type\<close>

quotient_type msg = freemsg / msgrel
  by (rule equiv_msgrel)

text\<open>The abstract message constructors\<close>

quotient_definition
  "Nonce :: nat \<Rightarrow> msg"
is
  "NONCE"
done

quotient_definition
  "MPair :: msg \<Rightarrow> msg \<Rightarrow> msg"
is
  "MPAIR"
by (rule MPAIR)

quotient_definition
  "Crypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
is
  "CRYPT"
by (rule CRYPT)

quotient_definition
  "Decrypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
is
  "DECRYPT"
by (rule DECRYPT)

text\<open>Establishing these two equations is the point of the whole exercise\<close>
theorem CD_eq [simp]:
  shows "Crypt K (Decrypt K X) = X"
  by (lifting CD)

theorem DC_eq [simp]:
  shows "Decrypt K (Crypt K X) = X"
  by (lifting DC)

subsection\<open>The Abstract Function to Return the Set of Nonces\<close>

quotient_definition
   "nonces:: msg \<Rightarrow> nat set"
is
  "freenonces"
by (rule msgrel_imp_eq_freenonces)

text\<open>Now prove the four equations for @{term nonces}\<close>

lemma nonces_Nonce [simp]:
  shows "nonces (Nonce N) = {N}"
  by (lifting freenonces.simps(1))

lemma nonces_MPair [simp]:
  shows "nonces (MPair X Y) = nonces X \<union> nonces Y"
  by (lifting freenonces.simps(2))

lemma nonces_Crypt [simp]:
  shows "nonces (Crypt K X) = nonces X"
  by (lifting freenonces.simps(3))

lemma nonces_Decrypt [simp]:
  shows "nonces (Decrypt K X) = nonces X"
  by (lifting freenonces.simps(4))

subsection\<open>The Abstract Function to Return the Left Part\<close>

quotient_definition
  "left:: msg \<Rightarrow> msg"
is
  "freeleft"
by (rule msgrel_imp_eqv_freeleft)

lemma left_Nonce [simp]:
  shows "left (Nonce N) = Nonce N"
  by (lifting freeleft.simps(1))

lemma left_MPair [simp]:
  shows "left (MPair X Y) = X"
  by (lifting freeleft.simps(2))

lemma left_Crypt [simp]:
  shows "left (Crypt K X) = left X"
  by (lifting freeleft.simps(3))

lemma left_Decrypt [simp]:
  shows "left (Decrypt K X) = left X"
  by (lifting freeleft.simps(4))

subsection\<open>The Abstract Function to Return the Right Part\<close>

quotient_definition
  "right:: msg \<Rightarrow> msg"
is
  "freeright"
by (rule msgrel_imp_eqv_freeright)

text\<open>Now prove the four equations for @{term right}\<close>

lemma right_Nonce [simp]:
  shows "right (Nonce N) = Nonce N"
  by (lifting freeright.simps(1))

lemma right_MPair [simp]:
  shows "right (MPair X Y) = Y"
  by (lifting freeright.simps(2))

lemma right_Crypt [simp]:
  shows "right (Crypt K X) = right X"
  by (lifting freeright.simps(3))

lemma right_Decrypt [simp]:
  shows "right (Decrypt K X) = right X"
  by (lifting freeright.simps(4))

subsection\<open>Injectivity Properties of Some Constructors\<close>

text\<open>Can also be proved using the function @{term nonces}\<close>
lemma Nonce_Nonce_eq [iff]:
  shows "(Nonce m = Nonce n) = (m = n)"
proof
  assume "Nonce m = Nonce n"
  then show "m = n"
    by (descending) (drule msgrel_imp_eq_freenonces, simp)
next
  assume "m = n"
  then show "Nonce m = Nonce n" by simp
qed

lemma MPair_imp_eq_left:
  assumes eq: "MPair X Y = MPair X' Y'"
  shows "X = X'"
  using eq
  by (descending) (drule msgrel_imp_eqv_freeleft, simp)

lemma MPair_imp_eq_right:
  shows "MPair X Y = MPair X' Y' \<Longrightarrow> Y = Y'"
  by (descending) (drule msgrel_imp_eqv_freeright, simp)

theorem MPair_MPair_eq [iff]:
  shows "(MPair X Y = MPair X' Y') = (X=X' & Y=Y')"
  by (blast dest: MPair_imp_eq_left MPair_imp_eq_right)

theorem Nonce_neq_MPair [iff]:
  shows "Nonce N \<noteq> MPair X Y"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

text\<open>Example suggested by a referee\<close>

theorem Crypt_Nonce_neq_Nonce:
  shows "Crypt K (Nonce M) \<noteq> Nonce N"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

text\<open>...and many similar results\<close>

theorem Crypt2_Nonce_neq_Nonce:
  shows "Crypt K (Crypt K' (Nonce M)) \<noteq> Nonce N"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

theorem Crypt_Crypt_eq [iff]:
  shows "(Crypt K X = Crypt K X') = (X=X')"
proof
  assume "Crypt K X = Crypt K X'"
  hence "Decrypt K (Crypt K X) = Decrypt K (Crypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Crypt K X = Crypt K X'" by simp
qed

theorem Decrypt_Decrypt_eq [iff]:
  shows "(Decrypt K X = Decrypt K X') = (X=X')"
proof
  assume "Decrypt K X = Decrypt K X'"
  hence "Crypt K (Decrypt K X) = Crypt K (Decrypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Decrypt K X = Decrypt K X'" by simp
qed

lemma msg_induct [case_names Nonce MPair Crypt Decrypt, cases type: msg]:
  assumes N: "\<And>N. P (Nonce N)"
      and M: "\<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y)"
      and C: "\<And>K X. P X \<Longrightarrow> P (Crypt K X)"
      and D: "\<And>K X. P X \<Longrightarrow> P (Decrypt K X)"
  shows "P msg"
  using N M C D
  by (descending) (auto intro: freemsg.induct)

subsection\<open>The Abstract Discriminator\<close>

text\<open>However, as \<open>Crypt_Nonce_neq_Nonce\<close> above illustrates, we don't
need this function in order to prove discrimination theorems.\<close>

quotient_definition
  "discrim:: msg \<Rightarrow> int"
is
  "freediscrim"
by (rule msgrel_imp_eq_freediscrim)

text\<open>Now prove the four equations for @{term discrim}\<close>

lemma discrim_Nonce [simp]:
  shows "discrim (Nonce N) = 0"
  by (lifting freediscrim.simps(1))

lemma discrim_MPair [simp]:
  shows "discrim (MPair X Y) = 1"
  by (lifting freediscrim.simps(2))

lemma discrim_Crypt [simp]:
  shows "discrim (Crypt K X) = discrim X + 2"
  by (lifting freediscrim.simps(3))

lemma discrim_Decrypt [simp]:
  shows "discrim (Decrypt K X) = discrim X - 2"
  by (lifting freediscrim.simps(4))

end


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

section \<open>Defining data structure and \\
          key function remove\_max\<close>

theory RemoveMax
imports Sort
begin

subsection \<open>Describing data structure\<close>

text\<open>
We have already said that we are going to formalize heap and selection
sort and to show connections between these two sorts.  However, one
can immediately notice that selection sort is using list and heap sort
is using heap during its work. It would be very difficult to show
equivalency between these two sorts if it is continued straightforward
and independently proved that they satisfy conditions of locale
\verb|Sort|. They work with different objects. Much better thing to do
is to stay on the abstract level and to add the new locale, one that
describes characteristics of both list and heap.
\<close>

locale Collection =
  fixes empty :: "'b"
  \<comment> \<open>-- Represents empty element of the object (for example, for list it is $[]$)\<close>
  fixes is_empty :: "'b \<Rightarrow> bool"
  \<comment> \<open>-- Function that checks weather the object is empty or not\<close>
  fixes of_list :: "'a list \<Rightarrow> 'b"
  \<comment> \<open>-- Function transforms given list to desired object (for example,
    for heap sort, function {\em of\_list} transforms list to heap)\<close>
  fixes multiset :: "'b \<Rightarrow> 'a multiset"
  \<comment> \<open>-- Function makes a multiset from the given object. A multiset is a collection without order.\<close>
  assumes is_empty_inj: "is_empty e \<Longrightarrow> e = empty"
  \<comment> \<open>-- It must be assured that the empty element is {\em empty}\<close>
  assumes is_empty_empty: "is_empty empty"
  \<comment> \<open>-- Must be satisfied that function {\em is\_empty} returns true for element {\em empty}\<close>
  assumes multiset_empty: "multiset empty = {#}"
  \<comment> \<open>-- Multiset of an empty object is empty multiset.\<close>
  assumes multiset_of_list: "multiset (of_list i) = mset i"
  \<comment> \<open>-- Multiset of an object gained by
  applying function {\em of\_list} must be the same as the multiset of
  the list. This, practically, means that function {\em of\_list} does
  not delete or change elements of the starting list.\<close>
begin
  lemma is_empty_as_list: "is_empty e \<Longrightarrow> multiset e = {#}"
    using is_empty_inj multiset_empty
    by auto

  definition set :: "'b \<Rightarrow> 'a set" where
     [simp]: "set l = set_mset (multiset l)"
end

subsection \<open>Function remove\_max\<close>

text\<open>
We wanted to emphasize that algorithms are same. Due to
the complexity of the implementation it usually happens that simple
properties are omitted, such as the connection between these two
sorting algorithms. This is a key feature that should be presented to
students in order to understand these algorithms. It is not unknown
that students usually prefer selection sort for its simplicity whereas
avoid heap sort for its complexity. However, if we can present them as
the algorithms that are same they may hesitate less in using the heap
sort. This is why the refinement is important. Using this technique we
were able to notice these characteristics. Separate verification would
not bring anything new. Being on the abstract level does not only
simplify the verifications, but also helps us to notice and to show
students important features. Even further, we can prove them formally
and completely justify our observation.
\<close>

locale RemoveMax = Collection empty is_empty of_list  multiset for
  empty :: "'b" and
  is_empty :: "'b \<Rightarrow> bool" and
  of_list :: "'a::linorder list \<Rightarrow> 'b" and
  multiset :: "'b \<Rightarrow> 'a::linorder multiset" +
  fixes remove_max :: "'b \<Rightarrow> 'a \<times> 'b"
  \<comment> \<open>--- Function that removes maximum element from the object of type $'b$.
      It returns maximum element and the object without that maximum element.\<close>
  fixes inv :: "'b \<Rightarrow> bool"
  \<comment> \<open>--- It checks weather the object is in required condition.
      For example, if we expect to work with heap it checks weather the object
      is heap. This is called {\em invariant condition}\<close>
  assumes of_list_inv: "inv (of_list x)"
  \<comment> \<open>--- This condition assures that function {\em of\_list}
      made a object with desired property.\<close>
  assumes remove_max_max:
     "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> m = Max (set l)"
  \<comment> \<open>--- First parameter of the return value of the
      function {\em remove\_max} is the maximum element\<close>
  assumes remove_max_multiset:
     "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow>
      add_mset m (multiset l') = multiset l"
  \<comment> \<open>--- Condition for multiset, ensures that nothing new is added or nothing
      is lost after applying {\em remove\_max} function.\<close>
  assumes remove_max_inv:
     "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> inv l'"
  \<comment> \<open>--- Ensures that invariant condition is true after removing maximum element.
      Invariant condition must be true in each step of sorting algorithm, for example
      if we are sorting using heap than in each iteration we must have heap and function
      {\em remove\_max} must not change that.\<close>
begin

lemma remove_max_multiset_size:
  "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow>
               size (multiset l) > size (multiset l')"
using remove_max_multiset[of l m l']
by (metis mset_subset_size multi_psub_of_add_self)

lemma remove_max_set:
  "\<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow>
                                 set l' \<union> {m} = set l"
using remove_max_multiset[of l m l']
by (metis Un_insert_right local.set_def set_mset_add_mset_insert sup_bot_right)

text\<open>As it is said before
in each iteration invariant condition must be satisfied, so the {\em
  inv l} is always true, e.g. before and after execution of any
function. This is also the reason why sort function must be defined as
partial. This function parameters stay the same in each step of
iteration -- list stays list, and heap stays heap. As we said before,
in Isabelle/HOL we can only define total function, but there is a
mechanism that enables total function to appear as partial one:\<close>

partial_function (tailrec) ssort' where
  "ssort' l sl =
      (if is_empty l then
          sl
       else
          let
            (m, l') = remove_max l
          in
            ssort' l' (m # sl))"
declare ssort'.simps[code]
definition ssort :: "'a list \<Rightarrow> 'a list" where
  "ssort l = ssort' (of_list l) []"

inductive ssort'_dom where
   step: "\<lbrakk>\<And>m l'. \<lbrakk>\<not> is_empty l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow>
                  ssort'_dom (l', m # sl)\<rbrakk> \<Longrightarrow> ssort'_dom (l, sl)"
lemma ssort'_termination:
  assumes "inv (fst p)"
  shows "ssort'_dom p"
using assms
proof (induct p rule: wf_induct[of "measure (\<lambda>(l, sl). size (multiset l))"])
  let ?r = "measure (\<lambda>(l, sl). size (multiset l))"
  fix p :: "'b \<times> 'a list"
  assume "inv (fst p)" and *:
         "\<forall>y. (y, p) \<in> ?r \<longrightarrow> inv (fst y) \<longrightarrow> ssort'_dom y"
  obtain l sl where "p = (l, sl)"
    by (cases p) auto
  show "ssort'_dom p"
  proof (subst \<open>p = (l, sl)\<close>, rule ssort'_dom.step)
    fix m l'
    assume "\<not> is_empty l" "(m, l') = remove_max l"
    show "ssort'_dom (l', m#sl)"
    proof (rule *[rule_format])
      show "((l', m#sl), p) \<in> ?r" "inv (fst (l', m#sl))"
        using \<open>p = (l, sl)\<close> \<open>inv (fst p)\<close> \<open>\<not> is_empty l\<close>
        using \<open>(m, l') = remove_max l\<close>
        using remove_max_inv[of l m l']
        using remove_max_multiset_size[of l m l']
        by auto
    qed
  qed
qed simp

lemma ssort'Induct:
  assumes "inv l" "P l sl"
   "\<And> l sl m l'.
    \<lbrakk>\<not> is_empty l; inv l; (m, l') = remove_max l; P l sl\<rbrakk> \<Longrightarrow> P l' (m # sl)"
  shows "P empty (ssort' l sl)"
proof-
  from \<open>inv l\<close> have "ssort'_dom (l, sl)"
    using ssort'_termination
    by auto
  thus ?thesis
    using assms
  proof (induct "(l, sl)" arbitrary: l sl rule: ssort'_dom.induct)
    case (step l sl)
    show ?case
    proof (cases "is_empty l")
      case True
      thus ?thesis
        using step(4) step(5) ssort'.simps[of l sl] is_empty_inj[of l]
        by simp
    next
      case False
      let ?p = "remove_max l"
      let ?m = "fst ?p" and ?l' = "snd ?p"
      show ?thesis
        using False step(2)[of ?m ?l'] step(3)
        using step(4) step(5)[of l ?m ?l' sl] step(5)
        using remove_max_inv[of l ?m ?l']
        using ssort'.simps[of l sl]
        by (cases ?p) auto
    qed
  qed
qed

lemma mset_ssort':
  assumes "inv l"
  shows "mset (ssort' l sl) = multiset l + mset sl"
using assms
proof-
    have "multiset empty + mset (ssort' l sl) = multiset l + mset sl"
      using assms
    proof (rule ssort'Induct)
      fix l1 sl1 m l'
      assume "\<not> is_empty l1"
             "inv l1"
             "(m, l') = remove_max l1"
             "multiset l1 + mset sl1 = multiset l + mset sl"
      thus "multiset l' + mset (m # sl1) = multiset l + mset sl"
        using remove_max_multiset[of l1 m l']
        by (metis union_mset_add_mset_left union_mset_add_mset_right mset.simps(2))
    qed simp
    thus ?thesis
      using multiset_empty
      by simp
qed

lemma sorted_ssort: "sorted (ssort i)"
unfolding ssort_def
using sorted_ssort'[of "of_list i" "[]"] of_list_inv
by auto

lemma permutation_ssort: "ssort l <~~> l"
proof (subst mset_eq_perm[symmetric])
  show "mset (ssort l) = mset l"
    unfolding ssort_def
    using mset_ssort'[of "of_list l" "[]"]
    using multiset_of_list of_list_inv
    by simp
qed
end

text\<open>Using assumptions given in the definitions of the locales {\em
  Collection} and {\em RemoveMax} for the functions {\em multiset},
{\em is\_empty}, {\em of\_list} and {\em remove\_max} it is no
difficulty to show:\<close>

sublocale RemoveMax < Sort ssort
by (unfold_locales) (auto simp add: sorted_ssort permutation_ssort)

end


theory "AList-Utils"
imports Main "Library/AList"
begin

text {* We want to have @{text delete} and @{text update} back in the namespace. *}

abbreviation delete where "delete \<equiv> AList.delete"
abbreviation update where "update \<equiv> AList.update"

subsubsection {* The domain of an associative list *}

definition domA
  where "domA h = fst ` set h"

lemma domA_append[simp]:"domA (a @ b) = domA a \<union> domA b"
  and [simp]:"domA ((v,e) # h) = insert v (domA h)"
  and [simp]:"domA (p # h) = insert (fst p) (domA h)"
  and [simp]:"domA [] = {}"
  by (auto simp add: domA_def)

lemma domA_from_set:
  "(x, e) \<in> set h \<Longrightarrow> x \<in> domA h"
by (induct h, auto)

lemma finite_domA[simp]:
  "finite (domA \<Gamma>)"
  by (auto simp add: domA_def)

lemma domA_delete[simp]:
  "domA (delete x \<Gamma>) = domA \<Gamma> - {x}"
  by (induct \<Gamma>) auto

lemma delete_not_domA[simp]:
  "x \<notin> domA \<Gamma> \<Longrightarrow>  delete x \<Gamma> = \<Gamma>"
  by (induct \<Gamma>) auto

lemma dom_map_of_conv_domA:
  "dom (map_of \<Gamma>) = domA \<Gamma>"
  by (induct \<Gamma>) (auto simp add: dom_if)

lemma domA_map_of_Some_the:
  "x \<in> domA \<Gamma> \<Longrightarrow> map_of \<Gamma> x = Some (the (map_of \<Gamma> x))"
  by (induct \<Gamma>) (auto simp add: dom_if)

subsubsection {* Other lemmas about associative lists *}

lemma delete_set_none: "(map_of l)(x := None) = map_of (delete x l)"
proof (induct l)
  case Nil thus ?case by simp
  case (Cons l ls)
  from this[symmetric]
  show ?case
  by (cases "fst l = x") auto
qed

lemma delete_append[simp]: "delete x (l1 @ l2) = delete x l1 @ delete x l2"
  unfolding AList.delete_eq by simp

lemma map_of_delete_insert:
  assumes "map_of \<Gamma> x = Some e"
  shows "map_of ((x,e) # delete x \<Gamma>) = map_of \<Gamma>"
  using assms by (induct \<Gamma>) (auto split:prod.split)

lemma map_add_domA[simp]:
  "x \<in> domA \<Gamma> \<Longrightarrow> (map_of \<Delta> ++ map_of \<Gamma>) x = map_of \<Gamma> x"
  "x \<notin> domA \<Gamma> \<Longrightarrow> (map_of \<Delta> ++ map_of \<Gamma>) x = map_of \<Delta> x"
    apply (metis dom_map_of_conv_domA map_add_dom_app_simps(1))
    apply (metis dom_map_of_conv_domA map_add_dom_app_simps(3))
    done

lemma map_of_empty[simp]:
  "Map.empty = map_of \<Delta> \<longleftrightarrow> \<Delta> = []"
  apply (cases \<Delta>)
  apply auto
  by (metis fun_upd_same option.distinct(1))

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Order\<close>
theory Binary_Relations_Order
  imports
    Binary_Relations_Order_Base
    Binary_Relations_Reflexive
    Binary_Relations_Symmetric
    Binary_Relations_Transitive
begin

paragraph \<open>Summary\<close>
text \<open>Basic results about the order on binary relations.\<close>

lemma in_dom_if_rel_if_rel_comp_le:
  assumes "(R \<circ>\<circ> S) \<le> (S \<circ>\<circ> R)"
  and "R x y" "S y z"
  shows "in_dom S x"
  using assms by (blast intro: in_dom_if_in_dom_rel_comp)

lemma in_codom_if_rel_if_rel_comp_le:
  assumes "(R \<circ>\<circ> S) \<le> (S \<circ>\<circ> R)"
  and "R x y" "S y z"
  shows "in_codom R z"
  using assms by (blast intro: in_codom_if_in_codom_rel_comp)

lemma rel_comp_le_rel_inv_if_rel_comp_le_if_symmetric:
  assumes symms: "symmetric R1" "symmetric R2"
  and le: "(R1 \<circ>\<circ> R2) \<le> R3"
  shows "(R2 \<circ>\<circ> R1) \<le> R3\<inverse>"
proof -
  from le have "(R1 \<circ>\<circ> R2)\<inverse> \<le> R3\<inverse>" by blast
  with symms show ?thesis by simp
qed

lemma rel_inv_le_rel_comp_if_le_rel_comp_if_symmetric:
  assumes symms: "symmetric R1" "symmetric R2"
  and le: "R3 \<le> (R1 \<circ>\<circ> R2)"
  shows "R3\<inverse> \<le> (R2 \<circ>\<circ> R1)"
proof -
  from le have "R3\<inverse> \<le> (R1 \<circ>\<circ> R2)\<inverse>" by blast
  with symms show ?thesis by simp
qed

corollary rel_comp_le_rel_comp_if_rel_comp_le_rel_comp_if_symmetric:
  assumes "symmetric R1" "symmetric R2" "symmetric R3" "symmetric R4"
  and "(R1 \<circ>\<circ> R2) \<le> (R3 \<circ>\<circ> R4)"
  shows "(R2 \<circ>\<circ> R1) \<le> (R4 \<circ>\<circ> R3)"
proof -
  from assms have "(R2 \<circ>\<circ> R1) \<le> (R3 \<circ>\<circ> R4)\<inverse>"
    by (intro rel_comp_le_rel_inv_if_rel_comp_le_if_symmetric)
  with assms show ?thesis by simp
qed

corollary rel_comp_le_rel_comp_iff_if_symmetric:
  assumes "symmetric R1" "symmetric R2" "symmetric R3" "symmetric R4"
  shows "(R1 \<circ>\<circ> R2) \<le> (R3 \<circ>\<circ> R4) \<longleftrightarrow> (R2 \<circ>\<circ> R1) \<le> (R4 \<circ>\<circ> R3)"
  using assms
  by (blast intro: rel_comp_le_rel_comp_if_rel_comp_le_rel_comp_if_symmetric)

corollary eq_if_le_rel_if_symmetric:
  assumes "symmetric R" "symmetric S"
  and "(R \<circ>\<circ> S) \<le> (S \<circ>\<circ> R)"
  shows "(R \<circ>\<circ> S) = (S \<circ>\<circ> R)"
  using assms rel_comp_le_rel_comp_iff_if_symmetric[of R S]
  by (intro antisym) auto

lemma rel_comp_le_rel_comp_if_le_rel_if_reflexive_on_in_codom_if_transitive:
  assumes trans: "transitive S"
  and refl_on: "reflexive_on (in_codom S) R"
  and le_rel: "R \<le> S"
  shows "R \<circ>\<circ> S \<le> S \<circ>\<circ> R"
proof (rule le_relI)
  fix x1 x2 assume"(R \<circ>\<circ> S) x1 x2"
  then obtain x3 where "R x1 x3" "S x3 x2" by blast
  then have "S x1 x3" using le_rel by blast
  with \<open>S x3 x2\<close> have "S x1 x2" using trans by blast
  with refl_on have "R x2 x2" by blast
  then show "(S \<circ>\<circ> R) x1 x2" using \<open>S x1 x2\<close> by blast
qed

end


(*  Title:      HOL/Library/Quotient_Option.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section {* Quotient infrastructure for the option type *}

theory Quotient_Option
imports Main Quotient_Syntax
begin

subsection {* Rules for the Quotient package *}

lemma rel_option_map1:
  "rel_option R (map_option f x) y \<longleftrightarrow> rel_option (\<lambda>x. R (f x)) x y"
  by (simp add: rel_option_iff split: option.split)

lemma rel_option_map2:
  "rel_option R x (map_option f y) \<longleftrightarrow> rel_option (\<lambda>x y. R x (f y)) x y"
  by (simp add: rel_option_iff split: option.split)

declare
  map_option.id [id_simps]
  option.rel_eq [id_simps]

lemma reflp_rel_option:
  "reflp R \<Longrightarrow> reflp (rel_option R)"
  unfolding reflp_def split_option_all by simp

lemma option_symp:
  "symp R \<Longrightarrow> symp (rel_option R)"
  unfolding symp_def split_option_all
  by (simp only: option.rel_inject option.rel_distinct) fast

lemma option_transp:
  "transp R \<Longrightarrow> transp (rel_option R)"
  unfolding transp_def split_option_all
  by (simp only: option.rel_inject option.rel_distinct) fast

lemma option_equivp [quot_equiv]:
  "equivp R \<Longrightarrow> equivp (rel_option R)"
  by (blast intro: equivpI reflp_rel_option option_symp option_transp elim: equivpE)

lemma option_quotient [quot_thm]:
  assumes "Quotient3 R Abs Rep"
  shows "Quotient3 (rel_option R) (map_option Abs) (map_option Rep)"
  apply (rule Quotient3I)
  apply (simp_all add: option.map_comp comp_def option.map_id[unfolded id_def] option.rel_eq rel_option_map1 rel_option_map2 Quotient3_abs_rep [OF assms] Quotient3_rel_rep [OF assms])
  using Quotient3_rel [OF assms]
  apply (simp add: rel_option_iff split: option.split)
  done

declare [[mapQ3 option = (rel_option, option_quotient)]]

lemma option_None_rsp [quot_respect]:
  assumes q: "Quotient3 R Abs Rep"
  shows "rel_option R None None"
  by (rule option.ctr_transfer(1))

lemma option_Some_rsp [quot_respect]:
  assumes q: "Quotient3 R Abs Rep"
  shows "(R ===> rel_option R) Some Some"
  by (rule option.ctr_transfer(2))

lemma option_None_prs [quot_preserve]:
  assumes q: "Quotient3 R Abs Rep"
  shows "map_option Abs None = None"
  by (rule Option.option.map(1))

lemma option_Some_prs [quot_preserve]:
  assumes q: "Quotient3 R Abs Rep"
  shows "(Rep ---> map_option Abs) Some = Some"
  apply(simp add: fun_eq_iff)
  apply(simp add: Quotient3_abs_rep[OF q])
  done

end


theory Exercise3
  imports Exercise2
begin

fun deskip :: "com \<Rightarrow> com" where
"deskip (SKIP) = (SKIP)" |
"deskip (x ::= a) = (x ::= a)" |
"deskip (c1 ;; c2)
  = (if ((skip_ua c1) \<and> (skip_ua c2))
      then (SKIP)
      else if (skip_ua c1)
      then (deskip c2)
      else if (skip_ua c2)
      then (deskip c1)
      else ((deskip c1) ;; (deskip c2)))" |
"deskip (IF b THEN c1 ELSE c2)
  = (if ((skip_ua c1) \<and> (skip_ua c2))
      then (SKIP)
      else (IF b THEN (deskip c1) ELSE (deskip c2)))" |
"deskip (WHILE b DO c)
  = (WHILE b DO (deskip c))"

lemma "(deskip c = SKIP) \<longleftrightarrow> (skip_ua c)"
proof
  assume "deskip c = SKIP"
  thus "skip_ua c"
  proof induction
    case (Seq c1 c2)
    hence "((skip_ua c1) \<and> (skip_ua c2))"
      by (metis com.distinct(3) deskip.simps(3))
    thus ?case by simp
  next
    case (If b c1 c2)
    hence "((skip_ua c1) \<and> (skip_ua c2))"
      by (metis com.distinct(5) deskip.simps(4))
    thus ?case by simp
  qed auto
next
  assume "skip_ua c"
  thus "deskip c = SKIP"
  proof (induction c)
    case (Seq c1 c2)
    hence "((skip_ua c1) \<and> (skip_ua c2))" by simp
    thus ?case by simp
  next
    case (If b c1 c2)
    hence "((skip_ua c1) \<and> (skip_ua c2))" by simp
    thus ?case by simp
  qed auto
qed

value "deskip (SKIP;; WHILE b DO ((x ::= a);; SKIP))"

theorem deskip_equiv: "deskip c \<sim> c"
proof induction
  case (Seq c1 c2)
  have
    "(skip_ua c1 \<and> skip_ua c2)
      \<or> (skip_ua c1 \<and> \<not> skip_ua c2)
      \<or> (\<not> skip_ua c1 \<and> skip_ua c2)
      \<or> (\<not> skip_ua c1 \<and> \<not> skip_ua c2)"
    by auto
  thus ?case
  proof (elim disjE)
    assume assm: "skip_ua c1 \<and> skip_ua c2"
    hence skipped: "deskip (c1 ;; c2) = SKIP" by simp
    have "c1 \<sim> SKIP \<and> c2 \<sim> SKIP"
      using assm skip_ua_impl_equiv
      by presburger
    hence "SKIP \<sim> (c1 ;; c2)"
      using Exercise2.seq assm skip_ua_impl_equiv
      by presburger
    thus ?case
      using skipped
      by presburger
  next
    assume assm: "skip_ua c1 \<and> \<not> skip_ua c2"
    hence "deskip (c1 ;; c2) = deskip c2" by simp
    hence rdct: "deskip (c1 ;; c2) \<sim> c2"
      using `deskip c2 \<sim> c2` by simp
    have "c1 \<sim> SKIP"
      using assm skip_ua_impl_equiv by presburger
    hence "c2 \<sim> (c1 ;; c2)" by auto
    thus ?case using rdct by simp
  next
    assume assm: "\<not> skip_ua c1 \<and> skip_ua c2"
    hence "deskip (c1 ;; c2) = deskip c1" by simp
    hence rdct: "deskip (c1 ;; c2) \<sim> c1"
      using `deskip c1 \<sim> c1` by simp
    have "c2 \<sim> SKIP"
      using assm skip_ua_impl_equiv by presburger
    hence "c1 \<sim> (c1 ;; c2)" by auto
    thus ?case using rdct by simp
  next
    assume assm: "\<not> skip_ua c1 \<and> \<not> skip_ua c2"
    have expn:
      "deskip (c1 ;; c2)
        = ((deskip c1) ;; (deskip c2))"
      using assm deskip.simps(3)
      by presburger
    have "((deskip c1) ;; (deskip c2)) \<sim> (c1 ;; c2)"
      using `deskip c1 \<sim> c1` `deskip c2 \<sim> c2`
      by auto
    thus ?case
      using expn
      by presburger
  qed
next
  case (If b c1 c2)
  have
    "((skip_ua c1) \<and> (skip_ua c2))
      \<or> \<not> ((skip_ua c1) \<and> (skip_ua c2))"
    by simp
  thus ?case
  proof
    assume assm: "(skip_ua c1) \<and> (skip_ua c2)"
    hence isskip: "deskip (IF b THEN c1 ELSE c2) = SKIP" by simp
    have "c1 \<sim> SKIP \<and> c2 \<sim> SKIP"
      using assm skip_ua_impl_equiv
      by presburger
    hence "SKIP \<sim> (IF b THEN c1 ELSE c2)" by blast
    thus ?thesis using isskip by simp
  next
    assume assm: "\<not> ((skip_ua c1) \<and> (skip_ua c2))"
    hence
      "deskip (IF b THEN c1 ELSE c2)
        = (IF b THEN (deskip c1) ELSE (deskip c2))"
      by simp
    thus ?thesis
      using `deskip c1 \<sim> c1` `deskip c2 \<sim> c2`
      by auto
  qed
next
  case (While b c)
  have "deskip (WHILE b DO c) = (WHILE b DO (deskip c))"
    by simp
  thus ?case using `deskip c \<sim> c`
    using while_equiv by presburger
qed simp+

end


section \<open> Introduction \<close>

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

text \<open> In this paper, we use Isabelle/HOL to verify some elementary theorems and alternative axiomatizations
of classical extensional mereology, as well as some of its weaker subtheories.\footnote{For similar
developments see \<^cite>\<open>"sen_computational_2017"\<close> and \<^cite>\<open>"bittner_formal_2018"\<close>.} We mostly follow the
presentations from \<^cite>\<open>"simons_parts:_1987"\<close>, \<^cite>\<open>"varzi_parts_1996"\<close> and \<^cite>\<open>"casati_parts_1999"\<close>,
with some important corrections from \<^cite>\<open>"pontow_note_2004"\<close> and \<^cite>\<open>"hovda_what_2009"\<close> as well as
some detailed proofs adapted from \<^cite>\<open>"pietruszczak_metamereology_2018"\<close>.\footnote{For help with
this project I am grateful to Zach Barnett, Sam Baron, Bob Beddor, Olivier Danvy, Mark Goh,
Jeremiah Joven Joaquin, Wang-Yen Lee, Kee Wei Loo, Bruno Woltzenlogel Paleo, Michael Pelczar, Hsueh Qu,
Abelard Podgorski, Divyanshu Sharma, Manikaran Singh, Neil Sinhababu, Weng-Hong Tang and Zhang Jiang.} \<close>

text \<open> We will use the following notation throughout.\footnote{See \<^cite>\<open>"simons_parts:_1987"\<close> pp. 99-100
for a helpful comparison of alternative notations.} \<close>

typedecl i
consts part :: "i \<Rightarrow> i \<Rightarrow> bool" ("P")
consts overlap :: "i \<Rightarrow> i \<Rightarrow> bool" ("O")
consts proper_part :: "i \<Rightarrow> i \<Rightarrow> bool" ("PP")
consts sum :: "i \<Rightarrow> i \<Rightarrow> i" (infix "\<oplus>" 52)
consts product :: "i \<Rightarrow> i \<Rightarrow> i" (infix "\<otimes>" 53)
consts difference :: "i \<Rightarrow> i \<Rightarrow> i" (infix "\<ominus>" 51)
consts complement:: "i \<Rightarrow> i" ("\<midarrow>")
consts universe :: "i" ("u")
consts general_sum :: "(i \<Rightarrow> bool) \<Rightarrow> i" (binder "\<sigma>" 9)
consts general_product :: "(i \<Rightarrow> bool) \<Rightarrow> i" (binder "\<pi>" [8] 9)

section \<open> Premereology \<close>

text \<open> The theory of \emph{premereology} assumes parthood is reflexive and transitive.\footnote{
For discussion of reflexivity see \<^cite>\<open>"kearns_can_2011"\<close>. For transitivity see \<^cite>\<open>"varzi_note_2006"\<close>.}
In other words, parthood is assumed to be a partial ordering relation.\footnote{Hence the name \emph{premereology},
from \<^cite>\<open>"parsons_many_2014"\<close> p. 6.} Overlap is defined as common parthood.\footnote{See
\<^cite>\<open>"simons_parts:_1987"\<close> p. 28, \<^cite>\<open>"varzi_parts_1996"\<close> p. 261 and \<^cite>\<open>"casati_parts_1999"\<close> p. 36. } \<close>

locale PM =
  assumes part_reflexivity: "P x x"
  assumes part_transitivity : "P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
  assumes overlap_eq: "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)"
begin

subsection \<open> Parthood \<close>

lemma identity_implies_part : "x = y \<Longrightarrow> P x y"
proof -
  assume "x = y"
  moreover have "P x x" by (rule part_reflexivity)
  ultimately show "P x y" by (rule subst)
qed

subsection \<open> Overlap \<close>

lemma overlap_intro: "P z x \<Longrightarrow> P z y \<Longrightarrow> O x y"
proof-
  assume "P z x"
  moreover assume "P z y"
  ultimately have "P z x \<and> P z y"..
  hence "\<exists> z. P z x \<and> P z y"..
  with overlap_eq show "O x y"..
qed

lemma part_implies_overlap: "P x y \<Longrightarrow> O x y"
proof -
  assume "P x y"
  with part_reflexivity have "P x x \<and> P x y"..
  hence "\<exists> z. P z x \<and> P z y"..
  with overlap_eq show "O x y"..
qed

lemma overlap_reflexivity: "O x x"
proof -
  have "P x x \<and> P x x" using part_reflexivity part_reflexivity..
  hence "\<exists> z. P z x \<and> P z x"..
  with overlap_eq show "O x x"..
qed

lemma overlap_symmetry: "O x y \<Longrightarrow> O y x"
proof-
  assume "O x y"
  with overlap_eq have "\<exists> z. P z x \<and> P z y"..
  hence "\<exists> z. P z y \<and> P z x" by auto
  with overlap_eq show "O y x"..
qed

lemma overlap_monotonicity: "P x y \<Longrightarrow> O z x \<Longrightarrow> O z y"
proof -
  assume "P x y"
  assume "O z x"
  with overlap_eq have "\<exists> v. P v z \<and> P v x"..
  then obtain v where v: "P v z \<and> P v x"..
  hence "P v z"..
  moreover from v have "P v x"..
  hence "P v y" using \<open>P x y\<close> by (rule part_transitivity)
  ultimately have "P v z \<and> P v y"..
  hence "\<exists> v. P v z \<and> P v y"..
  with overlap_eq show "O z y"..
qed

text \<open> The next lemma is from \<^cite>\<open>"hovda_what_2009"\<close> p. 66. \<close>

lemma overlap_lemma: "\<exists>x. (P x y \<and> O z x) \<longrightarrow> O y z"
proof -
  fix x
  have "P x y \<and> O z x \<longrightarrow> O y z"
  proof
    assume antecedent: "P x y \<and> O z x"
    hence "O z x"..
    with overlap_eq have "\<exists>v. P v z \<and> P v x"..
    then obtain v where v: "P v z \<and> P v x"..
    hence "P v x"..
    moreover from antecedent have "P x y"..
    ultimately have "P v y" by (rule part_transitivity)
    moreover from v have "P v z"..
    ultimately have "P v y \<and> P v z"..
    hence "\<exists>v. P v y \<and> P v z"..
    with overlap_eq show "O y z"..
  qed
  thus "\<exists>x. (P x y \<and> O z x) \<longrightarrow> O y z"..
qed

subsection \<open> Disjointness \<close>

lemma disjoint_implies_distinct: "\<not> O x y \<Longrightarrow> x \<noteq> y"
proof -
  assume "\<not> O x y"
  show "x \<noteq> y"
  proof
    assume "x = y"
    hence "\<not> O y y" using \<open>\<not> O x y\<close> by (rule subst)
    thus "False" using overlap_reflexivity..
  qed
qed

lemma disjoint_implies_not_part: "\<not> O x y \<Longrightarrow> \<not> P x y"
proof -
  assume "\<not> O x y"
  show "\<not> P x y"
  proof
    assume "P x y"
    hence "O x y" by (rule part_implies_overlap)
    with \<open>\<not> O x y\<close> show "False"..
  qed
qed

lemma disjoint_symmetry: "\<not> O x y \<Longrightarrow> \<not> O y x"
proof -
  assume "\<not> O x y"
  show "\<not> O y x"
  proof
    assume "O y x"
    hence "O x y" by (rule overlap_symmetry)
    with \<open>\<not> O x y\<close> show "False"..
  qed
qed

lemma disjoint_demonotonicity: "P x y \<Longrightarrow> \<not> O z y \<Longrightarrow> \<not> O z x"
proof -
  assume "P x y"
  assume "\<not> O z y"
  show "\<not> O z x"
  proof
    assume "O z x"
    with \<open>P x y\<close> have "O z y"
      by (rule overlap_monotonicity)
    with \<open>\<not> O z y\<close> show "False"..
  qed
qed

end

(*<*)end(*>*)


(* Title:      Conway Algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Conway Algebras\<close>

theory Conway
  imports Dioid
begin

text \<open>
  We define a weak regular algebra which can serve as a common basis for Kleene algebra and demonic reginement algebra.
  It is closely related to an axiomatisation given by Conway~\cite{conway71regular}.
\<close>

class dagger_op =
  fixes dagger :: "'a \<Rightarrow> 'a" ("_\<^sup>\<dagger>" [101] 100)

subsection\<open>Near Conway Algebras\<close>

class near_conway_base = near_dioid_one + dagger_op +
  assumes dagger_denest: "(x + y)\<^sup>\<dagger> = (x\<^sup>\<dagger> \<cdot> y)\<^sup>\<dagger> \<cdot> x\<^sup>\<dagger>"
  and dagger_prod_unfold [simp]: "1 + x \<cdot> (y \<cdot> x)\<^sup>\<dagger> \<cdot> y = (x \<cdot> y)\<^sup>\<dagger>"

begin

lemma dagger_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (metis dagger_prod_unfold mult_1_left mult_1_right)

lemma dagger_unfoldl: "1 + x \<cdot> x\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by auto

lemma dagger_unfoldr_eq [simp]: "1 + x\<^sup>\<dagger> \<cdot> x = x\<^sup>\<dagger>"
  by (metis dagger_prod_unfold mult_1_right mult_1_left)

lemma dagger_unfoldr: "1 + x\<^sup>\<dagger> \<cdot> x \<le> x\<^sup>\<dagger>"
  by auto

lemma dagger_unfoldl_distr [simp]: "y + x \<cdot> x\<^sup>\<dagger> \<cdot> y = x\<^sup>\<dagger> \<cdot> y"
  by (metis distrib_right' mult_1_left dagger_unfoldl_eq)

lemma dagger_unfoldr_distr [simp]: "y + x\<^sup>\<dagger> \<cdot> x \<cdot> y = x\<^sup>\<dagger> \<cdot> y"
  by (metis dagger_unfoldr_eq distrib_right' mult_1_left mult.assoc)

lemma dagger_refl: "1 \<le> x\<^sup>\<dagger>"
  using dagger_unfoldl local.join.sup.bounded_iff by blast

lemma dagger_plus_one [simp]: "1 + x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (simp add: dagger_refl local.join.sup_absorb2)

lemma star_1l: "x \<cdot> x\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  using dagger_unfoldl local.join.sup.bounded_iff by blast

lemma star_1r: "x\<^sup>\<dagger> \<cdot> x \<le> x\<^sup>\<dagger>"
  using dagger_unfoldr local.join.sup.bounded_iff by blast

lemma dagger_ext: "x \<le> x\<^sup>\<dagger>"
  by (metis dagger_unfoldl_distr local.join.sup.boundedE star_1r)

lemma dagger_trans_eq [simp]: "x\<^sup>\<dagger> \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (metis dagger_unfoldr_eq local.dagger_denest local.join.sup.idem mult_assoc)

lemma dagger_subdist:  "x\<^sup>\<dagger> \<le> (x + y)\<^sup>\<dagger>"
  by (metis dagger_unfoldr_distr local.dagger_denest local.order_prop)

lemma dagger_subdist_var:  "x\<^sup>\<dagger> + y\<^sup>\<dagger> \<le> (x + y)\<^sup>\<dagger>"
  using dagger_subdist local.join.sup_commute by fastforce

lemma dagger_iso [intro]: "x \<le> y \<Longrightarrow> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger>"
  by (metis less_eq_def dagger_subdist)

lemma star_square: "(x \<cdot> x)\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by (metis dagger_plus_one dagger_subdist dagger_trans_eq dagger_unfoldr_distr local.dagger_denest local.distrib_right' local.eq_iff  local.join.sup_commute local.less_eq_def  local.mult_onel mult_assoc)

lemma dagger_rtc1_eq [simp]: "1 + x + x\<^sup>\<dagger> \<cdot> x\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (simp add: local.dagger_ext local.dagger_refl local.join.sup_absorb2)

text \<open>Nitpick refutes the next lemmas.\<close>

lemma " y + y \<cdot> x\<^sup>\<dagger> \<cdot> x = y \<cdot> x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
  oops

lemma "y \<cdot> x\<^sup>\<dagger> = y + y \<cdot> x \<cdot> x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
  oops

lemma "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<cdot> (y \<cdot> x\<^sup>\<dagger>)\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
  oops

lemma "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

lemma "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
(*nitpick [expect = genuine]*)
oops

lemma "x\<^sup>\<dagger> \<cdot> x = x \<cdot> x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

end

subsection\<open>Pre-Conway Algebras\<close>

class pre_conway_base = near_conway_base + pre_dioid_one

begin

lemma dagger_subdist_var_3: "x\<^sup>\<dagger> \<cdot> y\<^sup>\<dagger> \<le> (x + y)\<^sup>\<dagger>"
  using local.dagger_subdist_var local.mult_isol_var by fastforce

lemma dagger_subdist_var_2: "x \<cdot> y \<le> (x + y)\<^sup>\<dagger>"
  by (meson dagger_subdist_var_3 local.dagger_ext local.mult_isol_var local.order.trans)

lemma dagger_sum_unfold [simp]: "x\<^sup>\<dagger> + x\<^sup>\<dagger> \<cdot> y \<cdot> (x + y)\<^sup>\<dagger> = (x + y)\<^sup>\<dagger>"
  by (metis local.dagger_denest local.dagger_unfoldl_distr mult_assoc)

end

subsection \<open>Conway Algebras\<close>

class conway_base = pre_conway_base + dioid_one

begin

lemma troeger: "(x + y)\<^sup>\<dagger> \<cdot> z = x\<^sup>\<dagger> \<cdot> (y \<cdot> (x + y)\<^sup>\<dagger> \<cdot> z + z)"
proof -
  have "(x + y)\<^sup>\<dagger> \<cdot> z = x\<^sup>\<dagger> \<cdot> z + x\<^sup>\<dagger> \<cdot> y \<cdot> (x + y)\<^sup>\<dagger> \<cdot> z"
    by (metis dagger_sum_unfold local.distrib_right')
  thus ?thesis
   by (metis add_commute local.distrib_left mult_assoc)
qed

lemma dagger_slide_var1: "x\<^sup>\<dagger> \<cdot> x \<le> x \<cdot> x\<^sup>\<dagger>"
  by (metis local.dagger_unfoldl_distr local.dagger_unfoldr_eq local.distrib_left local.eq_iff local.mult_1_right mult_assoc)

lemma dagger_slide_var1_eq: "x\<^sup>\<dagger> \<cdot> x = x \<cdot> x\<^sup>\<dagger>"
  by (metis local.dagger_unfoldl_distr local.dagger_unfoldr_eq local.distrib_left local.mult_1_right mult_assoc)

lemma dagger_slide_eq: "(x \<cdot> y)\<^sup>\<dagger> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<dagger>"
proof -
  have "(x \<cdot> y)\<^sup>\<dagger> \<cdot> x = x + x \<cdot> (y \<cdot> x)\<^sup>\<dagger> \<cdot> y \<cdot> x"
    by (metis local.dagger_prod_unfold local.distrib_right' local.mult_onel)
  also have "... = x \<cdot> (1 + (y \<cdot> x)\<^sup>\<dagger> \<cdot> y \<cdot> x)"
    using local.distrib_left local.mult_1_right mult_assoc by presburger
  finally show ?thesis
    by (simp add: mult_assoc)
qed

end

subsection \<open>Conway Algebras with  Zero\<close>

class near_conway_base_zerol = near_conway_base + near_dioid_one_zerol

begin

lemma dagger_annil [simp]: "1 + x \<cdot> 0 = (x \<cdot> 0)\<^sup>\<dagger>"
  by (metis annil dagger_unfoldl_eq mult.assoc)

lemma zero_dagger [simp]: "0\<^sup>\<dagger> = 1"
  by (metis add_0_right annil dagger_annil)

end

class pre_conway_base_zerol = near_conway_base_zerol + pre_dioid

class conway_base_zerol = pre_conway_base_zerol + dioid

subclass (in pre_conway_base_zerol) pre_conway_base ..

subclass (in conway_base_zerol) conway_base ..

context conway_base_zerol
begin

lemma "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger> \<cdot> z"
(*nitpick [expect=genuine]*)
oops

end

subsection \<open>Conway Algebras with Simulation\<close>

class near_conway = near_conway_base +
  assumes dagger_simr: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<dagger> \<le> y\<^sup>\<dagger> \<cdot> z"

begin

lemma dagger_slide_var: "x \<cdot> (y \<cdot> x)\<^sup>\<dagger> \<le> (x \<cdot> y)\<^sup>\<dagger> \<cdot> x"
  by (metis eq_refl dagger_simr mult.assoc)

text \<open>Nitpick refutes the next lemma.\<close>

lemma dagger_slide: "x \<cdot> (y \<cdot> x)\<^sup>\<dagger> = (x \<cdot> y)\<^sup>\<dagger> \<cdot> x"
(*nitpick [expect=genuine]*)
  oops

text \<open>
  We say that $y$ preserves $x$ if $x \cdot y \cdot x = x \cdot y$ and $!x \cdot y \cdot !x = !x \cdot y$. This definition is taken
  from Solin~\cite{Solin11}. It is useful for program transformation.
\<close>

lemma preservation1: "x \<cdot> y \<le> x \<cdot> y \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<dagger> \<le> (x \<cdot> y + z)\<^sup>\<dagger> \<cdot> x"
proof -
  assume "x \<cdot> y \<le> x \<cdot> y \<cdot> x"
  hence "x \<cdot> y \<le> (x \<cdot> y + z) \<cdot> x"
    by (simp add: local.join.le_supI1)
  thus ?thesis
    by (simp add: local.dagger_simr)
qed

end

class near_conway_zerol = near_conway + near_dioid_one_zerol

class pre_conway = near_conway + pre_dioid_one

begin

subclass pre_conway_base ..

lemma dagger_slide: "x \<cdot> (y \<cdot> x)\<^sup>\<dagger> = (x \<cdot> y)\<^sup>\<dagger> \<cdot> x"
  by (metis add.commute dagger_prod_unfold join.sup_least mult_1_right mult.assoc subdistl dagger_slide_var dagger_unfoldl_distr antisym)

lemma dagger_denest2: "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<cdot> (y \<cdot> x\<^sup>\<dagger>)\<^sup>\<dagger>"
  by (metis dagger_denest dagger_slide)

lemma preservation2: "y \<cdot> x \<le> y \<Longrightarrow> (x \<cdot> y)\<^sup>\<dagger> \<cdot> x \<le> x \<cdot> y\<^sup>\<dagger>"
  by (metis dagger_slide local.dagger_iso local.mult_isol)

lemma preservation1_eq: "x \<cdot> y \<le> x \<cdot> y \<cdot> x \<Longrightarrow> y \<cdot> x \<le> y \<Longrightarrow> (x \<cdot> y)\<^sup>\<dagger> \<cdot> x = x \<cdot> y\<^sup>\<dagger>"
  by (simp add: local.dagger_simr local.eq_iff preservation2)

end

class pre_conway_zerol = near_conway_zerol + pre_dioid_one_zerol

begin

subclass pre_conway ..

end

class conway = pre_conway + dioid_one

class conway_zerol = pre_conway + dioid_one_zerol

begin

subclass conway_base ..

text \<open>Nitpick refutes the next lemmas.\<close>

lemma "1 = 1\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

lemma "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

lemma dagger_denest_var [simp]: "(x + y)\<^sup>\<dagger> = (x\<^sup>\<dagger> \<cdot> y\<^sup>\<dagger>)\<^sup>\<dagger>"
(* nitpick [expect=genuine]*)
oops

lemma star2 [simp]: "(1 + x)\<^sup>\<dagger> = x\<^sup>\<dagger>"
(*nitpick [expect=genuine]*)
oops

end

end


(* Title:     HOL/MiniML/W.thy
   Author:    Dieter Nazareth, Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

header "Correctness and completeness of type inference algorithm W"

theory W
imports MiniML
begin

type_synonym result_W = "(subst * typ * nat) option"

-- "type inference algorithm W"
primrec W :: "[expr, ctxt, nat] => result_W" where
  "W (Var i) A n =
     (if i < length A then Some( id_subst,
                                 bound_typ_inst (%b. TVar(b+n)) (A!i),
                                 n + (min_new_bound_tv (A!i)) )
                      else None)"

| "W (Abs e) A n = ( (S,t,m) := W e ((FVar n)#A) (Suc n);
                     Some( S, (S n) -> t, m) )"

| "W (App e1 e2) A n = ( (S1,t1,m1) := W e1 A n;
                         (S2,t2,m2) := W e2 ($S1 A) m1;
                         U := mgu ($S2 t1) (t2 -> (TVar m2));
                         Some( $U o $S2 o S1, U m2, Suc m2) )"

| "W (LET e1 e2) A n = ( (S1,t1,m1) := W e1 A n;
                         (S2,t2,m2) := W e2 ((gen ($S1 A) t1)#($S1 A)) m1;
                         Some( $S2 o S1, t2, m2) )"

declare Suc_le_lessD [simp]

inductive_cases has_type_casesE:
"A |- Var n :: t"
"A |- Abs e :: t"
"A |- App e1 e2 ::t"
"A |- LET e1 e2 ::t"

-- "the resulting type variable is always greater or equal than the given one"
lemma W_var_ge [rule_format (no_asm)]:
  "!A n S t m. W e A n  = Some (S,t,m) --> n<=m"
apply (induct_tac "e")
(* case Var(n) *)
apply (simp (no_asm) split add: split_option_bind)
(* case Abs e *)
apply (simp (no_asm) split add: split_option_bind)
apply (fast dest: Suc_leD)
(* case App e1 e2 *)
apply (simp (no_asm) split add: split_option_bind)
apply (blast intro: le_SucI le_trans)
(* case LET e1 e2 *)
apply (simp (no_asm) split add: split_option_bind)
apply (blast intro: le_trans)
done

declare W_var_ge [simp]

lemma W_var_geD:
  "Some (S,t,m) = W e A n ==> n<=m"
apply (simp add: eq_sym_conv)
done

lemma new_tv_compatible_W:
  "new_tv n A ==> Some (S,t,m) = W e A n ==> new_tv m A"
apply (drule W_var_geD)
apply (rule new_scheme_list_le)
apply assumption
apply assumption
done

lemma new_tv_bound_typ_inst_sch [rule_format (no_asm)]:
  "new_tv n sch --> new_tv (n + (min_new_bound_tv sch)) (bound_typ_inst (%b. TVar (b + n)) sch)"
apply (induct_tac "sch")
  apply simp
 apply (simp add: add.commute)
apply (intro strip)
apply simp
apply (erule conjE)
apply (rule conjI)
 apply (rule new_tv_le)
  prefer 2 apply (assumption)
 apply (rule add_le_mono)
  apply (simp (no_asm))
 apply (simp (no_asm) add: max_def)
apply (rule new_tv_le)
 prefer 2 apply (assumption)
apply (rule add_le_mono)
 apply (simp (no_asm))
apply (simp (no_asm) add: max_def)
done

declare new_tv_bound_typ_inst_sch [simp]

-- "resulting type variable is new"
lemma new_tv_W [rule_format (no_asm)]:
  "!n A S t m. new_tv n A --> W e A n = Some (S,t,m) -->
               new_tv m S & new_tv m t"
proof (induct e)
  case Var then show ?case
    apply (simp (no_asm) split add: split_option_bind)
    apply (intro strip)
    apply (drule new_tv_nth_nat_A)
    apply assumption
    apply (simp (no_asm_simp))
    done
next
  case Abs then show ?case
    apply (simp (no_asm) add: new_tv_subst new_tv_Suc_list split add: split_option_bind)
    apply (intro strip)
    apply (erule_tac x = "Suc n" in allE)
    apply (erule_tac x = " (FVar n) #A" in allE)
    apply (fastforce simp add: new_tv_subst new_tv_Suc_list)
    done
next
  case App then show ?case
    apply (simp (no_asm) split add: split_option_bind)
    apply (intro strip)
    apply (rename_tac S1 t1 n1 S2 t2 n2 S3)
    apply (erule_tac x = "n" in allE)
    apply (erule_tac x = "A" in allE)
    apply (erule_tac x = "S1" in allE)
    apply (erule_tac x = "t1" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (simp add: eq_sym_conv del: all_simps)
    apply (erule_tac x = "$S1 A" in allE)
    apply (erule_tac x = "S2" in allE)
    apply (erule_tac x = "t2" in allE)
    apply (erule_tac x = "n2" in allE)
    apply ( simp add: o_def rotate_Some)
    apply (rule conjI)
    apply (rule new_tv_subst_comp_2)
    apply (rule new_tv_subst_comp_2)
    apply (rule lessI [THEN less_imp_le, THEN new_tv_le])
    apply (rule_tac n = "n1" in new_tv_subst_le)
    apply (simp add: rotate_Some)
    apply (simp (no_asm_simp))
    apply (fast dest: W_var_geD intro: new_scheme_list_le new_tv_subst_scheme_list lessI [THEN less_imp_le [THEN new_tv_subst_le]])
    apply (erule sym [THEN mgu_new])
    apply (blast dest!: W_var_geD
      intro: lessI [THEN less_imp_le, THEN new_tv_le] new_tv_subst_te
      new_tv_subst_scheme_list new_scheme_list_le new_tv_le)

    apply (erule impE)
    apply (blast dest: W_var_geD intro: new_tv_subst_scheme_list new_scheme_list_le new_tv_le)
    apply clarsimp

    apply (rule lessI [THEN new_tv_subst_var])
    apply (erule sym [THEN mgu_new])
    apply (blast dest!: W_var_geD
      intro: lessI [THEN less_imp_le, THEN new_tv_le] new_tv_subst_te
      new_tv_subst_scheme_list new_scheme_list_le new_tv_le)

    apply (erule impE)
    apply (blast dest: W_var_geD intro: new_tv_subst_scheme_list new_scheme_list_le new_tv_le)
    apply clarsimp
    done
next
  case LET then show ?case
    apply (simp (no_asm) split add: split_option_bind)
    apply (intro strip)
    apply (erule allE,erule allE,erule allE,erule allE,erule allE, erule impE, assumption, erule impE, assumption)
    apply (erule conjE)
    apply (erule allE,erule allE,erule allE,erule allE,erule allE, erule impE, erule_tac [2] notE impE, tactic "assume_tac 2")
    apply (simp only: new_tv_def)
    apply (simp (no_asm_simp))
    apply (drule W_var_ge)+
    apply (rule allI)
    apply (intro strip)
    apply (simp only: free_tv_subst)
    apply (drule free_tv_app_subst_scheme_list [THEN subsetD])
    apply (best elim: less_le_trans)
    apply (erule conjE)
    apply (rule conjI)
    apply (simp only: o_def)
    apply (rule new_tv_subst_comp_2)
    apply (erule W_var_ge [THEN new_tv_subst_le])
    apply assumption
    apply assumption
    apply assumption
    done
qed

lemma free_tv_bound_typ_inst1 [rule_format (no_asm)]:
  "(v ~: free_tv sch) --> (v : free_tv (bound_typ_inst (TVar o S) sch)) --> (? x. v = S x)"
apply (induct_tac "sch")
apply simp
apply simp
apply (intro strip)
apply (rule exI)
apply (rule refl)
apply simp
done

declare free_tv_bound_typ_inst1 [simp]

lemma free_tv_W [rule_format (no_asm)]:
  "!n A S t m v. W e A n = Some (S,t,m) -->
          (v:free_tv S | v:free_tv t) --> v<n --> v:free_tv A"
proof (induct e)
  case (Var n) then show ?case
    apply (simp (no_asm) add: free_tv_subst split add: split_option_bind)
    apply (intro strip)
    apply (case_tac "v : free_tv (A!n)")
    apply simp
    apply (drule free_tv_bound_typ_inst1)
    apply (simp (no_asm) add: o_def)
    apply (erule exE)
    apply simp
    done
  case Abs then show ?case
    apply (simp add: free_tv_subst split add: split_option_bind del: all_simps)
    apply (intro strip)
    apply (rename_tac S t n1 v)
    apply (erule_tac x = "Suc n" in allE)
    apply (erule_tac x = "FVar n # A" in allE)
    apply (erule_tac x = "S" in allE)
    apply (erule_tac x = "t" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "v" in allE)
    apply (bestsimp intro: cod_app_subst simp add: less_Suc_eq)
    done
  case App then show ?case
    apply (simp (no_asm) split add: split_option_bind del: all_simps)
    apply (intro strip)
    apply (rename_tac S t n1 S1 t1 n2 S2 v)
    apply (erule_tac x = "n" in allE)
    apply (erule_tac x = "A" in allE)
    apply (erule_tac x = "S" in allE)
    apply (erule_tac x = "t" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "v" in allE)
    (* second case *)
    apply (erule_tac x = "$ S A" in allE)
    apply (erule_tac x = "S1" in allE)
    apply (erule_tac x = "t1" in allE)
    apply (erule_tac x = "n2" in allE)
    apply (erule_tac x = "v" in allE)
    apply (intro conjI impI | elim conjE)+
    apply (simp add: rotate_Some o_def)
    apply (drule W_var_geD)
    apply (drule W_var_geD)
    apply ( (frule less_le_trans) , (assumption))
    apply clarsimp
    apply (drule free_tv_comp_subst [THEN subsetD])
    apply (drule sym [THEN mgu_free])
    apply clarsimp
    apply (fastforce dest: free_tv_comp_subst [THEN subsetD] sym [THEN mgu_free] codD free_tv_app_subst_te [THEN subsetD] free_tv_app_subst_scheme_list [THEN subsetD] less_le_trans less_not_refl2 subsetD)
    apply simp
    apply (drule sym [THEN W_var_geD])
    apply (drule sym [THEN W_var_geD])
    apply ( (frule less_le_trans) , (assumption))
    apply clarsimp
    apply (drule mgu_free)
    apply (fastforce dest: mgu_free codD free_tv_subst_var [THEN subsetD] free_tv_app_subst_te [THEN subsetD] free_tv_app_subst_scheme_list [THEN subsetD] less_le_trans subsetD)
    done
next
  case LET then show ?case
    apply (simp (no_asm) split add: split_option_bind del: all_simps)
    apply (intro strip)
    apply (rename_tac S1 t1 n2 S2 t2 n3 v)
    apply (erule_tac x = "n" in allE)
    apply (erule_tac x = "A" in allE)
    apply (erule_tac x = "S1" in allE)
    apply (erule_tac x = "t1" in allE)
    apply (rotate_tac -1)
    apply (erule_tac x = "n2" in allE)
    apply (rotate_tac -1)
    apply (erule_tac x = "v" in allE)
    apply (erule (1) notE impE)
    apply (erule allE,erule allE,erule allE,erule allE,erule allE,erule_tac  x = "v" in allE)
    apply (erule (1) notE impE)
    apply simp
    apply (rule conjI)
    apply (fast dest!: codD free_tv_app_subst_scheme_list [THEN subsetD] free_tv_o_subst [THEN subsetD] W_var_ge dest: less_le_trans)
    apply (fast dest!: codD free_tv_app_subst_scheme_list [THEN subsetD] W_var_ge dest: less_le_trans)
    done
qed

lemma weaken_A_Int_B_eq_empty: "(!x. x : A --> x ~: B) ==> A Int B = {}"
apply fast
done

lemma weaken_not_elem_A_minus_B: "x ~: A | x : B ==> x ~: A - B"
apply fast
done

-- "correctness of W with respect to @{text has_type}"
lemma W_correct_lemma [rule_format (no_asm)]: "!A S t m n . new_tv n A --> Some (S,t,m) = W e A n --> $S A |- e :: t"
apply (induct_tac "e")
(* case Var n *)
apply simp
apply (intro strip)
apply (rule has_type.VarI)
apply (simp (no_asm))
apply (simp (no_asm) add: is_bound_typ_instance)
apply (rule exI)
apply (rule refl)
(* case Abs e *)
apply (simp add: app_subst_list split add: split_option_bind)
apply (intro strip)
apply (erule_tac x = " (mk_scheme (TVar n)) # A" in allE)
apply simp
apply (rule has_type.AbsI)
apply (drule le_refl [THEN le_SucI, THEN new_scheme_list_le])
apply (drule sym)
apply (erule allE)+
apply (erule impE)
apply (erule_tac [2] notE impE, tactic "assume_tac 2")
apply (simp (no_asm_simp))
apply assumption
(* case App e1 e2 *)
apply (simp (no_asm) split add: split_option_bind)
apply (intro strip)
apply (rename_tac S1 t1 n1 S2 t2 n2 S3)
apply (rule_tac ?t2.0 = "$ S3 t2" in has_type.AppI)
apply (rule_tac S1 = "S3" in app_subst_TVar [THEN subst])
apply (rule app_subst_Fun [THEN subst])
apply (rule_tac t = "$S3 (t2 -> (TVar n2))" and s = "$S3 ($S2 t1) " in subst)
apply simp
apply (simp only: subst_comp_scheme_list [symmetric] o_def)
apply ((rule has_type_cl_sub [THEN spec]) , (rule has_type_cl_sub [THEN spec]))
apply (simp add: eq_sym_conv)
apply (simp add: subst_comp_scheme_list [symmetric] o_def has_type_cl_sub eq_sym_conv)
apply (rule has_type_cl_sub [THEN spec])
apply (frule new_tv_W)
apply assumption
apply (drule conjunct1)
apply (frule new_tv_subst_scheme_list)
apply (rule new_scheme_list_le)
apply (rule W_var_ge)
apply assumption
apply assumption
apply (erule thin_rl)
apply (erule allE)+
apply (drule sym)
apply (drule sym)
apply (erule thin_rl)
apply (erule thin_rl)
apply (erule (1) notE impE)
apply (erule (1) notE impE)
apply assumption
(* case Let e1 e2 *)
apply (simp (no_asm) split add: split_option_bind)
apply (intro strip)
(*by (rename_tac "w q m1 S1 t1 m2 S2 t n2" 1); *)
apply (rename_tac S1 t1 m1 S2)
apply (rule_tac ?t1.0 = "$ S2 t1" in has_type.LETI)
 apply (simp (no_asm) add: o_def)
 apply (simp only: subst_comp_scheme_list [symmetric])
 apply (rule has_type_cl_sub [THEN spec])
 apply (drule_tac x = "A" in spec)
 apply (drule_tac x = "S1" in spec)
 apply (drule_tac x = "t1" in spec)
 apply (drule_tac x = "m1" in spec)
 apply (drule_tac x = "n" in spec)
 apply (erule (1) notE impE)
 apply (simp add: eq_sym_conv)
apply (simp (no_asm) add: o_def)
apply (simp only: subst_comp_scheme_list [symmetric])
apply (rule gen_subst_commutes [symmetric, THEN subst])
 apply (rule_tac [2] app_subst_Cons [THEN subst])
 apply (erule_tac [2] thin_rl)
 apply (drule_tac [2] x = "gen ($S1 A) t1 # $ S1 A" in spec)
 apply (drule_tac [2] x = "S2" in spec)
 apply (drule_tac [2] x = "t" in spec)
 apply (drule_tac [2] x = "m" in spec)
 apply (drule_tac [2] x = "m1" in spec)
 apply (frule_tac [2] new_tv_W)
  prefer 2 apply (assumption)
 apply (drule_tac [2] conjunct1)
 apply (frule_tac [2] new_tv_subst_scheme_list)
  apply (rule_tac [2] new_scheme_list_le)
   apply (rule_tac [2] W_var_ge)
   prefer 2 apply (assumption)
  prefer 2 apply (assumption)
 apply (erule_tac [2] impE)
  apply (rule_tac [2] A = "$ S1 A" in new_tv_only_depends_on_free_tv_scheme_list)
   prefer 2 apply simp
   apply (fast)
  prefer 2 apply (assumption)
 prefer 2 apply simp
apply (rule weaken_A_Int_B_eq_empty)
apply (rule allI)
apply (intro strip)
apply (rule weaken_not_elem_A_minus_B)
apply (case_tac "x < m1")
 apply (rule disjI2)
 apply (rule free_tv_gen_cons [THEN subst])
 apply (rule free_tv_W)
   apply assumption
  apply simp
 apply assumption
apply (rule disjI1)
apply (drule new_tv_W)
apply assumption
apply (drule conjunct2)
apply (rule new_tv_not_free_tv)
apply (rule new_tv_le)
 prefer 2 apply (assumption)
apply (simp add: linorder_not_less)
done

-- "Completeness of W w.r.t. @{text has_type}"
lemma W_complete_lemma [rule_format (no_asm)]:
  "ALL S' A t' n. $S' A |- e :: t' --> new_tv n A -->
               (EX S t. (EX m. W e A n = Some (S,t,m)) &
                       (EX R. $S' A = $R ($S A) & t' = $R t))"
apply (induct e)
   (* case Var n *)
   apply (intro strip)
   apply (simp (no_asm) cong add: conj_cong)
   apply (erule has_type_casesE)
   apply (simp add: is_bound_typ_instance)
   apply (erule exE)
   apply (hypsubst)
   apply (rename_tac "S")
   apply (rule_tac x = "%x. (if x < n then S' x else S (x - n))" in exI)
   apply (rule conjI)
   apply (simp (no_asm_simp))
   apply (simp (no_asm_simp) add: bound_typ_inst_composed_subst [symmetric] new_tv_nth_nat_A o_def nth_subst
                             del: bound_typ_inst_composed_subst)

  (* case Abs e *)
  apply (intro strip)
  apply (erule has_type_casesE)
  apply (erule_tac x = "%x. if x=n then t1 else (S' x) " in allE)
  apply (erule_tac x = " (FVar n) #A" in allE)
  apply (erule_tac x = "t2" in allE)
  apply (erule_tac x = "Suc n" in allE)
  apply (bestsimp dest!: mk_scheme_injective cong: conj_cong split: split_option_bind)

 (* case App e1 e2 *)
 apply (intro strip)
 apply (erule has_type_casesE)
 apply (erule_tac x = "S'" in allE)
 apply (erule_tac x = "A" in allE)
 apply (erule_tac x = "t2 -> t'" in allE)
 apply (erule_tac x = "n" in allE)
 apply safe
 apply (erule_tac x = "R" in allE)
 apply (erule_tac x = "$ S A" in allE)
 apply (erule_tac x = "t2" in allE)
 apply (erule_tac x = "m" in allE)
 apply simp
 apply safe
  apply (blast intro: sym [THEN W_var_geD] new_tv_W [THEN conjunct1] new_scheme_list_le new_tv_subst_scheme_list)

 (** LEVEL 33 **)
apply (subgoal_tac "$ (%x. if x=ma then t' else (if x: (free_tv t - free_tv Sa) then R x else Ra x)) ($ Sa t) = $ (%x. if x=ma then t' else (if x: (free_tv t - free_tv Sa) then R x else Ra x)) (ta -> (TVar ma))")
apply (rule_tac [2] t = "$ (%x. if x = ma then t' else (if x: (free_tv t - free_tv Sa) then R x else Ra x)) ($ Sa t) " and s = " ($ Ra ta) -> t'" in ssubst)
prefer 2 apply (simp (no_asm_simp) add: subst_comp_te) prefer 2
apply (rule_tac [2] eq_free_eq_subst_te)
prefer 2 apply (intro strip) prefer 2
apply (subgoal_tac [2] "na ~=ma")
 prefer 3 apply (best dest: new_tv_W sym [THEN W_var_geD] new_tv_not_free_tv new_tv_le)
apply (case_tac [2] "na:free_tv Sa")
(* n1 ~: free_tv S1 *)
apply (frule_tac [3] not_free_impl_id)
 prefer 3 apply (simp)
(* na : free_tv Sa *)
apply (drule_tac [2] A1 = "$ S A" in trans [OF _ subst_comp_scheme_list])
apply (drule_tac [2] eq_subst_scheme_list_eq_free)
 prefer 2 apply (fast intro: free_tv_W free_tv_le_new_tv dest: new_tv_W)
prefer 2 apply (simp (no_asm_simp)) prefer 2
apply (case_tac [2] "na:dom Sa")
(* na ~: dom Sa *)
 prefer 3 apply (simp add: dom_def)
(* na : dom Sa *)
apply (rule_tac [2] eq_free_eq_subst_te)
prefer 2 apply (intro strip) prefer 2
apply (subgoal_tac [2] "nb ~= ma")
apply (frule_tac [3] new_tv_W) prefer 3 apply assumption
apply (erule_tac [3] conjE)
apply (drule_tac [3] new_tv_subst_scheme_list)
   prefer 3 apply (fast intro: new_scheme_list_le dest: sym [THEN W_var_geD])
  prefer 3 apply (fastforce dest: new_tv_W new_tv_not_free_tv simp add: cod_def free_tv_subst)
 prefer 2 apply (fastforce simp add: cod_def free_tv_subst)
prefer 2 apply (simp (no_asm)) prefer 2
apply (rule_tac [2] eq_free_eq_subst_te)
prefer 2 apply (intro strip) prefer 2
apply (subgoal_tac [2] "na ~= ma")
apply (frule_tac [3] new_tv_W) prefer 3 apply assumption
apply (erule_tac [3] conjE)
apply (drule_tac [3] sym [THEN W_var_geD])
 prefer 3 apply (fast dest: new_scheme_list_le new_tv_subst_scheme_list new_tv_W new_tv_not_free_tv)
apply (case_tac [2] "na: free_tv t - free_tv Sa")
(* case na ~: free_tv t - free_tv Sa *)
 prefer 3
 apply simp
 apply fast
(* case na : free_tv t - free_tv Sa *)
prefer 2 apply simp prefer 2
apply (drule_tac [2] A1 = "$ S A" and r = "$ R ($ S A)" in trans [OF _ subst_comp_scheme_list])
apply (drule_tac [2] eq_subst_scheme_list_eq_free)
 prefer 2
 apply (fast intro: free_tv_W free_tv_le_new_tv dest: new_tv_W)
(** LEVEL 73 **)
 prefer 2 apply (simp add: free_tv_subst dom_def)
apply (simp (no_asm_simp) split add: split_option_bind)
apply safe
apply (drule mgu_Some)
 apply fastforce
(** LEVEL 78 *)
apply (drule mgu_mg, assumption)
apply (erule exE)
apply (rule_tac x = "Rb" in exI)
apply (rule conjI)
apply (drule_tac [2] x = "ma" in fun_cong)
 prefer 2 apply (simp add: eq_sym_conv)
apply (simp (no_asm) add: subst_comp_scheme_list)
apply (simp (no_asm) add: subst_comp_scheme_list [symmetric])
apply (rule_tac A1 = "($ Sa ($ S A))" in trans [OF _ subst_comp_scheme_list [symmetric]])
apply (simp add: o_def eq_sym_conv)
apply (drule_tac s = "Some ?X" in sym)
apply (rule eq_free_eq_subst_scheme_list)
apply safe
apply (subgoal_tac "ma ~= na")
apply (frule_tac [2] new_tv_W) prefer 2 apply assumption
apply (erule_tac [2] conjE)
apply (drule_tac [2] new_tv_subst_scheme_list)
 prefer 2 apply (fast intro: new_scheme_list_le dest: sym [THEN W_var_geD])
apply (frule_tac [2] n = "m" in new_tv_W) prefer 2 apply assumption
apply (erule_tac [2] conjE)
apply (drule_tac [2] free_tv_app_subst_scheme_list [THEN subsetD])
 apply (tactic {*
    (fast_tac (put_claset (claset_of @{theory_context Fun}) @{context}
      addDs [sym RS @{thm W_var_geD}, @{thm new_scheme_list_le}, @{thm codD},
        @{thm new_tv_not_free_tv}]) 2) *})
apply (case_tac "na: free_tv t - free_tv Sa")
(* case na ~: free_tv t - free_tv Sa *)
 prefer 2 apply simp apply blast
(* case na : free_tv t - free_tv Sa *)
apply simp
apply (drule free_tv_app_subst_scheme_list [THEN subsetD])
 apply (fastforce dest: codD trans [OF _ subst_comp_scheme_list]
                       eq_subst_scheme_list_eq_free
             simp add: free_tv_subst dom_def)
(* case Let e1 e2 *)
apply (erule has_type_casesE)
apply (erule_tac x = "S'" in allE)
apply (erule_tac x = "A" in allE)
apply (erule_tac x = "t1" in allE)
apply (erule_tac x = "n" in allE)
apply (erule (1) notE impE)
apply (erule (1) notE impE)
apply safe
apply (simp (no_asm_simp))
apply (erule_tac x = "R" in allE)
apply (erule_tac x = "gen ($ S A) t # $ S A" in allE)
apply (erule_tac x = "t'" in allE)
apply (erule_tac x = "m" in allE)
apply simp
apply (drule mp)
apply (rule has_type_le_env)
apply assumption
apply (simp (no_asm))
apply (rule gen_bound_typ_instance)
apply (drule mp)
apply (frule new_tv_compatible_W)
apply (rule sym)
apply assumption
apply (fast dest: new_tv_compatible_gen new_tv_subst_scheme_list new_tv_W)
apply safe
apply simp
apply (rule_tac x = "Ra" in exI)
apply (simp (no_asm) add: o_def subst_comp_scheme_list [symmetric])
done

lemma W_complete:
  "[] |- e :: t' ==> (? S t. (? m. W e [] n = Some(S,t,m)) &
                     (? R. t' = $ R t))"
apply (cut_tac A = "[]" and S' = "id_subst" and e = "e" and t' = "t'" in W_complete_lemma)
apply simp_all
done

end


(*  Title:      Bonsall_Krein_Milman.thy
    Author:     Christopher Hoskin
*)

section \<open>Bonsall Krein-Milman Theorem\<close>

text \<open> From my notes, 21-Aug 2011 \<close>

theory Bonsall_Krein_Milman
  imports "HOL-Analysis.Polytope" "HOL-Hahn_Banach.Subspace" "HOL-Hahn_Banach.Linearform"
begin

text \<open>Given a set of objects of the same type such that the set is closed under minus, plus, zero
and uminus (and scalar multiplication?) a map from the set to the real numbers is said to be
subadditive if it is homogenous for positive scalars and addition satisfies a triangle inequality. \<close>

(*
The following definition is motivated by the definition of seminorm in Hahn_Banach/Normed_Space.
Scalar \<cdot> multiplication is defined in Hahn_Banach/Vector_Space.
*)

locale subadditive =
  fixes A :: "'a::{minus, plus, zero, uminus} set"
  fixes subadditive :: "'a \<Rightarrow> real"    ("\<parallel>_\<parallel>")
  assumes positive_homogenous [iff?]: "x \<in> A \<Longrightarrow> \<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>"
    and subadditive [iff?]: "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> \<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"

(*
Need to show set of functions from a set to a real vector space forms a vector space.
Approach adopted from treatment of bcontfun in Analysis/Bounded_Continuous_Function
*)

definition "algdual = {f. linearform UNIV f}"

(* Can't get this definition right *)

(*
typedef (overloaded) ('a,'b) algdual ("(_ \<Rightarrow>\<^sub>L /_)" [22, 21] 21) =
  "algdual::('a::{minus,plus,uminus,zero}  \<Rightarrow> real) set"
*)

(*

instantiation algdual :: (set, real) real_vector
begin
end
*)

(*
 The following is definition is inspired by the definition of norm_pres_extensions in
 Hahn_Banach/Function_Order.

 dominated_functionals are the functionals on B dominated by p:B\<rightarrow>real
*)

definition
  dominated_functionals ::
   "'a::{plus,minus,uminus,zero} set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow>  ('a \<Rightarrow> real)  set"
   where
  "dominated_functionals B p
    = {x. (\<forall>b \<in> B. x b \<le> p b) \<and> linearform B x}"

(* convex is defined as convex :: "'a::real_vector set \<Rightarrow> bool" in Convex_Euclidean_Space *)

(* The following lemma won't work yet, as we don't know that the dominated functionals are a subset
 of a real vector space *)

lemma (in subadditive) dom_convex:
  fixes B
  assumes "vectorspace A" "subspace B A"
  shows "convex (dominated_functionals B p)"

(* proposition Bonsall_Krein_Milman:*)

end