section \<open>Generic laws about complements\<close>

theory Laws_Complement
  imports Laws Axioms_Complement
begin

notation comp_update (infixl "*\<^sub>u" 55)
notation tensor_update (infixr "\<otimes>\<^sub>u" 70)

definition \<open>complements F G \<longleftrightarrow> compatible F G \<and> iso_register (F;G)\<close>

lemma complementsI: \<open>compatible F G \<Longrightarrow> iso_register (F;G) \<Longrightarrow> complements F G\<close>
  using complements_def by blast

lemma complements_sym: \<open>complements G F\<close> if \<open>complements F G\<close>
proof (rule complementsI)
  show [simp]: \<open>compatible G F\<close>
    using compatible_sym complements_def that by blast
  from that have \<open>iso_register (F;G)\<close>
    by (meson complements_def)
  then obtain I where [simp]: \<open>register I\<close> and \<open>(F;G) o I = id\<close> and \<open>I o (F;G) = id\<close>
    using iso_register_def by blast
  have \<open>register (swap o I)\<close>
    using \<open>register I\<close> register_comp register_swap by blast
  moreover have \<open>(G;F) o (swap o I) = id\<close>
    by (simp add: \<open>(F;G) \<circ> I = id\<close> rewriteL_comp_comp)
  moreover have \<open>(swap o I) o (G;F) = id\<close>
    by (metis (no_types, opaque_lifting) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
  ultimately show \<open>iso_register (G;F)\<close>
    using \<open>compatible G F\<close> iso_register_def pair_is_register by blast
qed

definition complement :: \<open>('a::domain update \<Rightarrow> 'b::domain update) \<Rightarrow> (('a,'b) complement_domain update \<Rightarrow> 'b update)\<close> where
  \<open>complement F = (SOME G :: ('a, 'b) complement_domain update \<Rightarrow> 'b update. compatible F G \<and> iso_register (F;G))\<close>

lemma register_complement[simp]: \<open>register (complement F)\<close> if \<open>register F\<close>
  using complement_exists[OF that]
  by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)

lemma complement_is_complement:
  assumes \<open>register F\<close>
  shows \<open>complements F (complement F)\<close>
  using complement_exists[OF assms] unfolding complements_def
  by (metis (mono_tags, lifting) complement_def some_eq_imp)

lemma complement_unique:
  assumes \<open>complements F G\<close>
  shows \<open>equivalent_registers G (complement F)\<close>
  apply (rule complement_unique[where F=F])
  using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+

lemma compatible_complement[simp]: \<open>register F \<Longrightarrow> compatible F (complement F)\<close>
  using complement_is_complement complements_def by blast

lemma complements_register_tensor:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  shows \<open>complements (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
proof (rule complementsI)
  have sep4: \<open>separating TYPE('z::domain) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d) |a b c d. True}\<close>
    apply (rule separating_tensor'[where A=\<open>{(a \<otimes>\<^sub>u b) |a b. True}\<close> and B=\<open>{(c \<otimes>\<^sub>u d) |c d. True}\<close>])
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
    by auto
  show compat: \<open>compatible (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
    by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
  let ?reorder = \<open>((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
  have [simp]: \<open>register ?reorder\<close>
    by auto
  have [simp]: \<open>?reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close>
    for a::\<open>'t::domain update\<close> and b::\<open>'u::domain update\<close> and c::\<open>'v::domain update\<close> and d::\<open>'w::domain update\<close>
    by (simp add: register_pair_apply Fst_def Snd_def tensor_update_mult)
  have [simp]: \<open>iso_register ?reorder\<close>
    apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
     apply (rule register_eqI[OF sep4]) apply auto[3]
    apply (rule register_eqI[OF sep4]) by auto
  have \<open>(F \<otimes>\<^sub>r G; complement F \<otimes>\<^sub>r complement G) = ((F; complement F) \<otimes>\<^sub>r (G; complement G)) o ?reorder\<close>
    apply (rule register_eqI[OF sep4])
    by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
        simp: compat register_pair_apply tensor_update_mult)
  moreover have \<open>iso_register \<dots>\<close>
    apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
    using assms complement_is_complement complements_def by blast+
  ultimately show \<open>iso_register (F \<otimes>\<^sub>r G;complement F \<otimes>\<^sub>r complement G)\<close>
    by simp
qed

definition is_unit_register where
  \<open>is_unit_register U \<longleftrightarrow> complements U id\<close>

lemma register_unit_register[simp]: \<open>is_unit_register U \<Longrightarrow> register U\<close>
  by (simp add: compatible_def complements_def is_unit_register_def)

lemma unit_register_compatible[simp]: \<open>compatible U X\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
  by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))

lemma unit_register_compatible'[simp]: \<open>compatible X U\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
  using compatible_sym that(1) that(2) unit_register_compatible by blast

lemma compatible_complement_left[simp]: \<open>register X \<Longrightarrow> compatible (complement X) X\<close>
  using compatible_sym complement_is_complement complements_def by blast

lemma compatible_complement_right[simp]: \<open>register X \<Longrightarrow> compatible X (complement X)\<close>
  using complement_is_complement complements_def by blast

lemma unit_register_pair[simp]: \<open>equivalent_registers X (U; X)\<close> if [simp]: \<open>is_unit_register U\<close> \<open>register X\<close>
proof -
  have \<open>equivalent_registers id (U; id)\<close>
    using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
  also have \<open>equivalent_registers \<dots> (U; (X; complement X))\<close>
    apply (rule equivalent_registers_pair_right)
     apply (auto intro!: unit_register_compatible)
    using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
  also have \<open>equivalent_registers \<dots> ((U; X); complement X)\<close>
    apply (rule equivalent_registers_assoc)
    by auto
  finally have \<open>complements (U; X) (complement X)\<close>
    by (auto simp: equivalent_registers_def complements_def)
  moreover have \<open>equivalent_registers (X; complement X) id\<close>
    by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
  ultimately show ?thesis
    by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed

lemma unit_register_compose_left:
  assumes [simp]: \<open>is_unit_register U\<close>
  assumes [simp]: \<open>register A\<close>
  shows \<open>is_unit_register (A o U)\<close>
proof -
  have \<open>compatible (A o U) (A; complement A)\<close>
    apply (auto intro!: compatible3')
    by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
  then have compat[simp]: \<open>compatible (A o U) id\<close>
    by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
  have \<open>equivalent_registers (A o U; id) (A o U; (A; complement A))\<close>
    apply (auto intro!: equivalent_registers_pair_right)
    using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
  also have \<open>equivalent_registers \<dots> ((A o U; A o id); complement A)\<close>
    apply auto
    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
  also have \<open>equivalent_registers \<dots> (A o (U; id); complement A)\<close>
    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
  also have \<open>equivalent_registers \<dots> (A o id; complement A)\<close>
    apply (intro equivalent_registers_pair_left equivalent_registers_comp)
      apply (auto simp: assms)
    using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
  also have \<open>equivalent_registers \<dots> id\<close>
    by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
  finally show ?thesis
    using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed

lemma unit_register_compose_right:
  assumes [simp]: \<open>is_unit_register U\<close>
  assumes [simp]: \<open>iso_register A\<close>
  shows \<open>is_unit_register (U o A)\<close>
proof (unfold is_unit_register_def, rule complementsI)
  show \<open>compatible (U \<circ> A) id\<close>
    by (simp add: iso_register_is_register)
  have 1: \<open>iso_register ((U;id) \<circ> A \<otimes>\<^sub>r id)\<close>
    by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
  have 2: \<open>id \<circ> ((U;id) \<circ> A \<otimes>\<^sub>r id) = (U \<circ> A;id)\<close>
    by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
  show \<open>iso_register (U \<circ> A;id)\<close>
    using 1 2 by auto
qed

lemma unit_register_unique:
  assumes \<open>is_unit_register F\<close>
  assumes \<open>is_unit_register G\<close>
  shows \<open>equivalent_registers F G\<close>
proof -
  have \<open>complements F id\<close> \<open>complements G id\<close>
    using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
  then show ?thesis
    by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed

lemma unit_register_domains_isomorphic:
  fixes F :: \<open>'a::domain update \<Rightarrow> 'c::domain update\<close>
  fixes G :: \<open>'b::domain update \<Rightarrow> 'd::domain update\<close>
  assumes \<open>is_unit_register F\<close>
  assumes \<open>is_unit_register G\<close>
  shows \<open>\<exists>I :: 'a update \<Rightarrow> 'b update. iso_register I\<close>
proof -
  have \<open>is_unit_register ((\<lambda>d. tensor_update id_update d) o G)\<close>
    by (simp add: assms(2) unit_register_compose_left)
  moreover have \<open>is_unit_register ((\<lambda>c. tensor_update c id_update) o F)\<close>
    using assms(1) register_tensor_left unit_register_compose_left by blast
  ultimately have \<open>equivalent_registers ((\<lambda>d. tensor_update id_update d) o G) ((\<lambda>c. tensor_update c id_update) o F)\<close>
    using unit_register_unique by blast
  then show ?thesis
    unfolding equivalent_registers_def by auto
qed

lemma id_complement_is_unit_register[simp]: \<open>is_unit_register (complement id)\<close>
  by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)

type_synonym unit_register_domain = \<open>(some_domain, some_domain) complement_domain\<close>
definition unit_register :: \<open>unit_register_domain update \<Rightarrow> 'a::domain update\<close> where \<open>unit_register = (SOME U. is_unit_register U)\<close>

lemma unit_register_is_unit_register[simp]: \<open>is_unit_register (unit_register :: unit_register_domain update \<Rightarrow> 'a::domain update)\<close>
proof -
  let ?U0 = \<open>complement id :: unit_register_domain update \<Rightarrow> some_domain update\<close>
  let ?U1 = \<open>complement id :: ('a, 'a) complement_domain update \<Rightarrow> 'a update\<close>
  have \<open>is_unit_register ?U0\<close> \<open>is_unit_register ?U1\<close>
    by auto
  then obtain I :: \<open>unit_register_domain update \<Rightarrow> ('a, 'a) complement_domain update\<close> where \<open>iso_register I\<close>
    apply atomize_elim by (rule unit_register_domains_isomorphic)
  with \<open>is_unit_register ?U1\<close> have \<open>is_unit_register (?U1 o I)\<close>
    by (rule unit_register_compose_right)
  then show ?thesis
    by (metis someI_ex unit_register_def)
qed

lemma unit_register_domain_tensor_unit:
  fixes U :: \<open>'a::domain update \<Rightarrow> _\<close>
  assumes \<open>is_unit_register U\<close>
  shows \<open>\<exists>I :: 'b::domain update \<Rightarrow> ('a*'b) update. iso_register I\<close>
  (* Can we show that I = (\<lambda>x. tensor_update id_update x) ? It would be nice but I do not see how to prove it. *)
proof -
  have \<open>equivalent_registers (id :: 'b update \<Rightarrow> _) (complement id; id)\<close>
    using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
  then obtain J :: \<open>'b update \<Rightarrow> ((('b, 'b) complement_domain * 'b) update)\<close> where \<open>iso_register J\<close>
    using equivalent_registers_def iso_register_inv by blast
  moreover obtain K :: \<open>('b, 'b) complement_domain update \<Rightarrow> 'a update\<close> where \<open>iso_register K\<close>
    using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
  ultimately have \<open>iso_register ((K \<otimes>\<^sub>r id) o J)\<close>
    by auto
  then show ?thesis
    by auto
qed

lemma compatible_complement_pair1:
  assumes \<open>compatible F G\<close>
  shows \<open>compatible F (complement (F;G))\<close>
  by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)

lemma compatible_complement_pair2:
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>compatible G (complement (F;G))\<close>
proof -
  have \<open>compatible (F;G) (complement (F;G))\<close>
    by simp
  then have \<open>compatible ((F;G) o Snd) (complement (F;G))\<close>
    by auto
  then show ?thesis
    by (auto simp: register_pair_Snd)
qed

lemma equivalent_complements:
  assumes \<open>complements F G\<close>
  assumes \<open>equivalent_registers G G'\<close>
  shows \<open>complements F G'\<close>
  apply (rule complementsI)
   apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
  by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)

lemma complements_complement_pair:
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>complements F (G; complement (F;G))\<close>
proof (rule complementsI)
  have \<open>equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))\<close>
    apply (rule equivalent_registers_assoc)
    by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
  also have \<open>equivalent_registers \<dots> id\<close>
    by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
  finally show \<open>iso_register (F;(G;complement (F;G)))\<close>
    using equivalent_registers_sym iso_register_equivalent_id by blast
  show \<open>compatible F (G;complement (F;G))\<close>
    using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed

lemma equivalent_registers_complement:
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers (complement F) (complement G)\<close>
proof -
  have \<open>complements F (complement F)\<close>
    using assms complement_is_complement equivalent_registers_register_left by blast
  with assms have \<open>complements G (complement F)\<close>
    by (meson complements_sym equivalent_complements)
  then show ?thesis
    by (rule complement_unique)
qed

lemma complements_complement_pair':
  assumes [simp]: \<open>compatible F G\<close>
  shows \<open>complements G (F; complement (F;G))\<close>
proof -
  have \<open>equivalent_registers (F;G) (G;F)\<close>
    apply (rule equivalent_registersI[where I=swap])
    by auto
  then have \<open>equivalent_registers (complement (F;G)) (complement (G;F))\<close>
    by (rule equivalent_registers_complement)
  then have \<open>equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))\<close>
    apply (rule equivalent_registers_pair_right[rotated])
    using assms compatible_complement_pair1 by blast
  moreover have \<open>complements G (F; complement (G;F))\<close>
    apply (rule complements_complement_pair)
    using assms compatible_sym by blast
  ultimately show ?thesis
    by (meson equivalent_complements equivalent_registers_sym)
qed

lemma complements_chain:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  shows \<open>complements (F o G) (complement F; F o complement G)\<close>
proof (rule complementsI)
  show \<open>compatible (F o G) (complement F; F o complement G)\<close>
    by auto
  have \<open>equivalent_registers (F \<circ> G;(complement F;F \<circ> complement G)) (F \<circ> G;(F \<circ> complement G;complement F))\<close>
    apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r swap\<close>])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have \<open>equivalent_registers \<dots> ((F \<circ> G;F \<circ> complement G);complement F)\<close>
    apply (rule equivalent_registersI[where I=assoc])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have \<open>equivalent_registers \<dots> (F o (G; complement G);complement F)\<close>
    by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
        equivalent_registers_sym equivalent_registers_trans register_comp_pair)
  also have \<open>equivalent_registers \<dots> (F o id;complement F)\<close>
    apply (rule equivalent_registers_pair_left, simp)
    apply (rule equivalent_registers_comp, simp)
    by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
  also have \<open>equivalent_registers \<dots> id\<close>
    by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
  finally show \<open>iso_register (F \<circ> G;(complement F;F \<circ> complement G))\<close>
    using equivalent_registers_sym iso_register_equivalent_id by blast
qed

lemma complements_Fst_Snd[simp]: \<open>complements Fst Snd\<close>
  by (auto intro!: complementsI simp: pair_Fst_Snd)

lemma complements_Snd_Fst[simp]: \<open>complements Snd Fst\<close>
  by (auto intro!: complementsI simp flip: swap_def)

lemma compatible_unit_register[simp]: \<open>register F \<Longrightarrow> compatible F unit_register\<close>
  using compatible_sym unit_register_compatible unit_register_is_unit_register by blast

lemma complements_id_unit_register[simp]: \<open>complements id unit_register\<close>
  using complements_sym is_unit_register_def unit_register_is_unit_register by blast

lemma complements_iso_unit_register: \<open>iso_register I \<Longrightarrow> is_unit_register U \<Longrightarrow> complements I U\<close>
  using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast

lemma iso_register_complement_is_unit_register[simp]:
  assumes \<open>iso_register F\<close>
  shows \<open>is_unit_register (complement F)\<close>
  by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)

text \<open>Adding support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> to the [@{attribute register}] attribute\<close>
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of \<open>is_unit_register _\<close>]

no_notation comp_update (infixl "*\<^sub>u" 55)
no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)

end


theory ex2_08 imports Main begin

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse _ [] = []" |
"intersperse _ [x] = [x]" |
"intersperse c (x#xs) = x # c # intersperse c xs"

value "intersperse 0 [1,2,3]"

theorem "map f (intersperse a xs) = intersperse (f a) (map f xs)"
apply(induction xs rule: intersperse.induct)
apply auto
done

end


theory ShortestPath
imports
  HOL.Complex
  "../Graph_Theory/Graph_Theory"
  "HOL-Library.Extended_Nat"
begin

section {*Shortest Path (with non-negative edge costs)*}
text{* The following theory is used in the verification of a certifying algorithm's checker for shortest path. For more information see \cite{FrameworkVerificationofCertifyingComputations}. *}

locale basic_sp =
  fin_digraph +
  fixes dist :: "'a \<Rightarrow> ereal"
  fixes c :: "'b \<Rightarrow> real"
  fixes s :: "'a"
  assumes s_in_G: "s \<in> verts G"
  assumes general_source_val: "dist s \<le> 0"
  assumes trian:
    "\<And>e. e \<in> arcs G \<Longrightarrow>
      dist (head G e) \<le> dist (tail G e) + c e"

locale basic_just_sp =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

locale shortest_path_pos_cost =
  basic_just_sp +
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

locale basic_just_sp_pred =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        pred v = Some e \<and>
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

sublocale basic_just_sp_pred \<subseteq> basic_just_sp
using basic_just_sp_pred_axioms
unfolding basic_just_sp_pred_def
   basic_just_sp_pred_axioms_def
  by unfold_locales (blast)

locale shortest_path_pos_cost_pred =
  basic_just_sp_pred +
  assumes s_in_G: "s \<in> verts G"
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

sublocale shortest_path_pos_cost_pred \<subseteq> shortest_path_pos_cost
using shortest_path_pos_cost_pred_axioms
by unfold_locales
   (auto simp: shortest_path_pos_cost_pred_def
   shortest_path_pos_cost_pred_axioms_def)

lemma tail_value_helper:
  assumes "hd p = last p"
  assumes "distinct p"
  assumes "p \<noteq> []"
  shows "p = [hd p]"
  by (metis assms distinct.simps(2) list.sel(1) neq_Nil_conv last_ConsR last_in_set)

lemma (in basic_sp) dist_le_cost:
  fixes v :: 'a
  fixes p :: "'b list"
  assumes "awalk s p v"
  shows "dist v \<le> awalk_cost c p"
  using assms
proof (induct "length p" arbitrary: p v)
  case 0
  hence "s = v" by auto
  thus ?case using 0(1) general_source_val
    by (metis awalk_cost_Nil length_0_conv zero_ereal_def)
next
  case (Suc n)
  then obtain p' e where p'e: "p = p' @ [e]"
    by (cases p rule: rev_cases) auto
  then obtain u where ewu: "awalk s p' u \<and> awalk u [e] v"
    using awalk_append_iff Suc(3) by simp
  hence du: "dist u \<le> ereal (awalk_cost c p')"
    using Suc p'e by simp
  from ewu have ust: "u = tail G e" and vta: "v = head G e"
    by auto
  hence "dist v \<le> dist u + c e"
    using ewu du ust trian[where e=e] by force
  with du have "dist v \<le> ereal (awalk_cost c p') + c e"
    by (metis add_right_mono order_trans)
  thus "dist v \<le> awalk_cost c p"
    using awalk_cost_append p'e by simp
qed

lemma (in fin_digraph) witness_path:
  assumes "\<mu> c s v = ereal r"
  shows "\<exists> p. apath s p v \<and> \<mu> c s v = awalk_cost c p"
proof -
  have sv: "s \<rightarrow>\<^sup>* v"
    using shortest_path_inf[of s v c] assms by fastforce
  {
    fix p assume "awalk s p v"
    then have no_neg_cyc:
    "\<not> (\<exists>w q. awalk w q w \<and> w \<in> set (awalk_verts s p) \<and> awalk_cost c q < 0)"
      using neg_cycle_imp_inf_\<mu> assms by force
  }
  thus ?thesis using no_neg_cyc_reach_imp_path[OF sv] by presburger
qed

lemma (in basic_sp)  dist_le_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<le> \<mu> c s v"
proof (rule ccontr)
  assume nt: "\<not> ?thesis"
  show False
  proof (cases "\<mu> c s v")
    show "\<And>r. \<mu> c s v = ereal r \<Longrightarrow> False"
    proof -
      fix r assume r_asm: "\<mu> c s v = ereal r"
      hence sv: "s \<rightarrow>\<^sup>* v"
        using shortest_path_inf[where u=s and v=v and f=c] by auto
      obtain p where
        "awalk s p v"
        "\<mu> c s v = awalk_cost c p"
        using witness_path[OF r_asm] unfolding apath_def by force
      thus False using nt dist_le_cost by simp
    qed
  next
    show "\<mu> c s v = \<infinity> \<Longrightarrow> False" using nt by simp
  next
    show "\<mu> c s v = - \<infinity> \<Longrightarrow> False" using dist_le_cost
    proof -
      assume asm: "\<mu> c s v = - \<infinity>"
      let ?C = "(\<lambda>x. ereal (awalk_cost c x)) ` {p. awalk s p v}"
      have "\<exists>x\<in> ?C. x < dist v"
        using nt unfolding \<mu>_def not_le INF_less_iff by simp
      then obtain p where
        "awalk s p v"
        "awalk_cost c p < dist v"
        by force
      thus False using dist_le_cost by force
    qed
  qed
qed

lemma (in basic_just_sp) dist_ge_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "num v \<noteq> \<infinity>"
  assumes "dist v \<noteq> -\<infinity>"
  assumes "\<mu> c s s = ereal 0"
  assumes "dist s = 0"
  assumes "\<And>u. u\<in>verts G \<Longrightarrow> u\<noteq>s \<Longrightarrow>
            num u \<noteq> \<infinity> \<Longrightarrow> num u \<noteq> enat 0"
  shows "dist v \<ge> \<mu> c s v"
proof -
  obtain n where "enat n = num v" using assms(2) by force
  thus ?thesis using assms
  proof(induct n arbitrary: v)
  case 0 thus ?case by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "v = head G e"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(4) Suc(2) by force
      have  ds: "dist (tail G e) = \<mu> c s (tail G e)"
        using Suc(1)[OF ns tail_in_verts[OF e_assms(1)] nsinf]
        Suc(5-8) e_assms(3) dist_le_\<mu>[OF tail_in_verts[OF e_assms(1)]]
        by simp
      have dmuc:"dist v \<ge> \<mu> c s (tail G e) + ereal (c e)"
        using e_assms(3) ds  by auto
      thus ?thesis
      proof (cases "dist v = \<infinity>")
      case False
        have "arc_to_ends G e = (tail G e, v)"
          unfolding arc_to_ends_def
          by (simp add: e_assms(2))
        obtain r where  \<mu>r: "\<mu> c s (tail G e) = ereal r"
           using e_assms(3) Suc(5) ds False
           by (cases "\<mu> c s (tail G e)", auto)
        obtain p where
          "awalk s p (tail G e)" and
          \<mu>s: "\<mu> c s (tail G e) = ereal (awalk_cost c p)"
          using witness_path[OF \<mu>r] unfolding apath_def
          by blast
        then have pe: "awalk s (p @ [e]) v"
          using e_assms(1,2) by (auto simp: awalk_simps)
        hence muc:"\<mu> c s v \<le> \<mu> c s (tail G e) + ereal (c e)"
        using \<mu>s min_cost_le_walk_cost[OF pe] by simp
        thus  "dist v \<ge> \<mu> c s v"  using dmuc by simp
      qed simp
    qed (simp add: Suc(6,7))
  qed
qed

lemma (in shortest_path_pos_cost) num_not0:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "num v \<noteq> \<infinity>"
  shows "num v \<noteq> enat 0"
proof -
  obtain ku where "num v = ku + enat 1"
    using assms just by blast
  thus ?thesis  by (induct ku) auto
qed

lemma (in shortest_path_pos_cost) dist_ne_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<noteq> -\<infinity>"
proof (cases "num v = \<infinity>")
case False
  obtain n where "enat n = num v"
    using False by force
  thus ?thesis using assms False
  proof(induct n arbitrary: v)
  case 0 thus ?case
    using num_not0 tail_val by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case True
      thus ?thesis using tail_val by simp
    next
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(3) Suc(2) by force
      have "dist (tail G e ) \<noteq> - \<infinity>"
        by (rule Suc(1) [OF ns tail_in_verts[OF e_assms(1)] nsinf])
      thus ?thesis using e_assms(2) by simp
    qed
  qed
next
case True
  thus ?thesis using no_path[OF assms] by simp
qed

theorem (in shortest_path_pos_cost) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using no_path[OF assms(1)] dist_le_\<mu>[OF assms(1)]
    dist_ge_\<mu>[OF assms(1) _ dist_ne_ninf[OF assms(1)]
    tail_value_check[OF s_in_G] tail_val num_not0]
    by fastforce

corollary (in shortest_path_pos_cost_pred) correct_shortest_path_pred:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using correct_shortest_path assms by simp

end


(*  Title:      ZF/AC/AC16_lemmas.thy
    Author:     Krzysztof Grabczewski

Lemmas used in the proofs concerning AC16
*)

theory AC16_lemmas
imports AC_Equiv Hartog Cardinal_aux
begin

lemma cons_Diff_eq: "a\<notin>A \<Longrightarrow> cons(a,A)-{a}=A"
by fast

lemma nat_1_lepoll_iff: "1\<lesssim>X \<longleftrightarrow> (\<exists>x. x \<in> X)"
  unfolding lepoll_def
apply (rule iffI)
apply (fast intro: inj_is_fun [THEN apply_type])
apply (erule exE)
apply (rule_tac x = "\<lambda>a \<in> 1. x" in exI)
apply (fast intro!: lam_injective)
done

lemma eqpoll_1_iff_singleton: "X\<approx>1 \<longleftrightarrow> (\<exists>x. X={x})"
apply (rule iffI)
apply (erule eqpollE)
apply (drule nat_1_lepoll_iff [THEN iffD1])
apply (fast intro!: lepoll_1_is_sing)
apply (fast intro!: singleton_eqpoll_1)
done

lemma cons_eqpoll_succ: "\<lbrakk>x\<approx>n; y\<notin>x\<rbrakk> \<Longrightarrow> cons(y,x)\<approx>succ(n)"
  unfolding succ_def
apply (fast elim!: cons_eqpoll_cong mem_irrefl)
done

lemma subsets_eqpoll_1_eq: "{Y \<in> Pow(X). Y\<approx>1} = {{x}. x \<in> X}"
apply (rule equalityI)
apply (rule subsetI)
apply (erule CollectE)
apply (drule eqpoll_1_iff_singleton [THEN iffD1])
apply (fast intro!: RepFunI)
apply (rule subsetI)
apply (erule RepFunE)
apply (rule CollectI, fast)
apply (fast intro!: singleton_eqpoll_1)
done

lemma eqpoll_RepFun_sing: "X\<approx>{{x}. x \<in> X}"
  unfolding eqpoll_def bij_def
apply (rule_tac x = "\<lambda>x \<in> X. {x}" in exI)
apply (rule IntI)
apply (unfold inj_def surj_def, simp)
apply (fast intro!: lam_type RepFunI intro: singleton_eq_iff [THEN iffD1], simp)
apply (fast intro!: lam_type)
done

lemma subsets_eqpoll_1_eqpoll: "{Y \<in> Pow(X). Y\<approx>1}\<approx>X"
apply (rule subsets_eqpoll_1_eq [THEN ssubst])
apply (rule eqpoll_RepFun_sing [THEN eqpoll_sym])
done

lemma InfCard_Least_in:
     "\<lbrakk>InfCard(x); y \<subseteq> x; y \<approx> succ(z)\<rbrakk> \<Longrightarrow> (\<mu> i. i \<in> y) \<in> y"
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll,
                         THEN succ_lepoll_imp_not_empty, THEN not_emptyE])
apply (fast intro: LeastI
            dest!: InfCard_is_Card [THEN Card_is_Ord]
            elim: Ord_in_Ord)
done

lemma subsets_lepoll_lemma1:
     "\<lbrakk>InfCard(x); n \<in> nat\<rbrakk>
      \<Longrightarrow> {y \<in> Pow(x). y\<approx>succ(succ(n))} \<lesssim> x*{y \<in> Pow(x). y\<approx>succ(n)}"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>y \<in> {y \<in> Pow(x) . y\<approx>succ (succ (n))}.
                      <\<mu> i. i \<in> y, y-{\<mu> i. i \<in> y}>" in exI)
apply (rule_tac d = "\<lambda>z. cons (fst(z), snd(z))" in lam_injective)
 apply (blast intro!: Diff_sing_eqpoll intro: InfCard_Least_in)
apply (simp, blast intro: InfCard_Least_in)
done

lemma set_of_Ord_succ_Union: "(\<forall>y \<in> z. Ord(y)) \<Longrightarrow> z \<subseteq> succ(\<Union>(z))"
apply (rule subsetI)
apply (case_tac "\<forall>y \<in> z. y \<subseteq> x", blast )
apply (simp, erule bexE)
apply (rule_tac i=y and j=x in Ord_linear_le)
apply (blast dest: le_imp_subset elim: leE ltE)+
done

lemma subset_not_mem: "j \<subseteq> i \<Longrightarrow> i \<notin> j"
by (fast elim!: mem_irrefl)

lemma succ_Union_not_mem:
     "(\<And>y. y \<in> z \<Longrightarrow> Ord(y)) \<Longrightarrow> succ(\<Union>(z)) \<notin> z"
apply (rule set_of_Ord_succ_Union [THEN subset_not_mem], blast)
done

lemma Union_cons_eq_succ_Union:
     "\<Union>(cons(succ(\<Union>(z)),z)) = succ(\<Union>(z))"
by fast

lemma Un_Ord_disj: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> i \<union> j = i | i \<union> j = j"
by (fast dest!: le_imp_subset elim: Ord_linear_le)

lemma Union_eq_Un: "x \<in> X \<Longrightarrow> \<Union>(X) = x \<union> \<Union>(X-{x})"
by fast

lemma Union_in_lemma [rule_format]:
     "n \<in> nat \<Longrightarrow> \<forall>z. (\<forall>y \<in> z. Ord(y)) \<and> z\<approx>n \<and> z\<noteq>0 \<longrightarrow> \<Union>(z) \<in> z"
apply (induct_tac "n")
apply (fast dest!: eqpoll_imp_lepoll [THEN lepoll_0_is_0])
apply (intro allI impI)
apply (erule natE)
apply (fast dest!: eqpoll_1_iff_singleton [THEN iffD1]
            intro!: Union_singleton, clarify)
apply (elim not_emptyE)
apply (erule_tac x = "z-{xb}" in allE)
apply (erule impE)
apply (fast elim!: Diff_sing_eqpoll
                   Diff_sing_eqpoll [THEN eqpoll_succ_imp_not_empty])
apply (subgoal_tac "xb \<union> \<Union>(z - {xb}) \<in> z")
apply (simp add: Union_eq_Un [symmetric])
apply (frule bspec, assumption)
apply (drule bspec)
apply (erule Diff_subset [THEN subsetD])
apply (drule Un_Ord_disj, assumption, auto)
done

lemma Union_in: "\<lbrakk>\<forall>x \<in> z. Ord(x); z\<approx>n; z\<noteq>0; n \<in> nat\<rbrakk> \<Longrightarrow> \<Union>(z) \<in> z"
by (blast intro: Union_in_lemma)

lemma succ_Union_in_x:
     "\<lbrakk>InfCard(x); z \<in> Pow(x); z\<approx>n; n \<in> nat\<rbrakk> \<Longrightarrow> succ(\<Union>(z)) \<in> x"
apply (rule Limit_has_succ [THEN ltE])
prefer 3 apply assumption
apply (erule InfCard_is_Limit)
apply (case_tac "z=0")
apply (simp, fast intro!: InfCard_is_Limit [THEN Limit_has_0])
apply (rule ltI [OF PowD [THEN subsetD] InfCard_is_Card [THEN Card_is_Ord]], assumption)
apply (blast intro: Union_in
                    InfCard_is_Card [THEN Card_is_Ord, THEN Ord_in_Ord])+
done

lemma succ_lepoll_succ_succ:
     "\<lbrakk>InfCard(x); n \<in> nat\<rbrakk>
      \<Longrightarrow> {y \<in> Pow(x). y\<approx>succ(n)} \<lesssim> {y \<in> Pow(x). y\<approx>succ(succ(n))}"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>z \<in> {y\<in>Pow(x). y\<approx>succ(n)}. cons(succ(\<Union>(z)), z)"
       in exI)
apply (rule_tac d = "\<lambda>z. z-{\<Union>(z) }" in lam_injective)
apply (blast intro!: succ_Union_in_x succ_Union_not_mem
             intro: cons_eqpoll_succ Ord_in_Ord
             dest!: InfCard_is_Card [THEN Card_is_Ord])
apply (simp only: Union_cons_eq_succ_Union)
apply (rule cons_Diff_eq)
apply (fast dest!: InfCard_is_Card [THEN Card_is_Ord]
            elim: Ord_in_Ord
            intro!: succ_Union_not_mem)
done

lemma subsets_eqpoll_X:
     "\<lbrakk>InfCard(X); n \<in> nat\<rbrakk> \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)} \<approx> X"
apply (induct_tac "n")
apply (rule subsets_eqpoll_1_eqpoll)
apply (rule eqpollI)
apply (rule subsets_lepoll_lemma1 [THEN lepoll_trans], assumption+)
apply (rule eqpoll_trans [THEN eqpoll_imp_lepoll])
 apply (erule eqpoll_refl [THEN prod_eqpoll_cong])
apply (erule InfCard_square_eqpoll)
apply (fast elim: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
            intro!: succ_lepoll_succ_succ)
done

lemma image_vimage_eq:
     "\<lbrakk>f \<in> surj(A,B); y \<subseteq> B\<rbrakk> \<Longrightarrow> f``(converse(f)``y) = y"
  unfolding surj_def
apply (fast dest: apply_equality2 elim: apply_iff [THEN iffD2])
done

lemma vimage_image_eq: "\<lbrakk>f \<in> inj(A,B); y \<subseteq> A\<rbrakk> \<Longrightarrow> converse(f)``(f``y) = y"
by (fast elim!: inj_is_fun [THEN apply_Pair] dest: inj_equality)

lemma subsets_eqpoll:
     "A\<approx>B \<Longrightarrow> {Y \<in> Pow(A). Y\<approx>n}\<approx>{Y \<in> Pow(B). Y\<approx>n}"
  unfolding eqpoll_def
apply (erule exE)
apply (rule_tac x = "\<lambda>X \<in> {Y \<in> Pow (A) . \<exists>f. f \<in> bij (Y, n) }. f``X" in exI)
apply (rule_tac d = "\<lambda>Z. converse (f) ``Z" in lam_bijective)
apply (fast intro!: bij_is_inj [THEN restrict_bij, THEN bij_converse_bij,
                                THEN comp_bij]
            elim!: bij_is_fun [THEN fun_is_rel, THEN image_subset])
apply (blast intro!:  bij_is_inj [THEN restrict_bij]
                      comp_bij bij_converse_bij
                      bij_is_fun [THEN fun_is_rel, THEN image_subset])
apply (fast elim!: bij_is_inj [THEN vimage_image_eq])
apply (fast elim!: bij_is_surj [THEN image_vimage_eq])
done

lemma WO2_imp_ex_Card: "WO2 \<Longrightarrow> \<exists>a. Card(a) \<and> X\<approx>a"
  unfolding WO2_def
apply (drule spec [of _ X])
apply (blast intro: Card_cardinal eqpoll_trans
          well_ord_Memrel [THEN well_ord_cardinal_eqpoll, THEN eqpoll_sym])
done

lemma lepoll_infinite: "\<lbrakk>X\<lesssim>Y; \<not>Finite(X)\<rbrakk> \<Longrightarrow> \<not>Finite(Y)"
by (blast intro: lepoll_Finite)

lemma infinite_Card_is_InfCard: "\<lbrakk>\<not>Finite(X); Card(X)\<rbrakk> \<Longrightarrow> InfCard(X)"
  unfolding InfCard_def
apply (fast elim!: Card_is_Ord [THEN nat_le_infinite_Ord])
done

lemma WO2_infinite_subsets_eqpoll_X: "\<lbrakk>WO2; n \<in> nat; \<not>Finite(X)\<rbrakk>
        \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
apply (drule WO2_imp_ex_Card)
apply (elim allE exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (drule infinite_Card_is_InfCard, assumption)
apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans)
done

lemma well_ord_imp_ex_Card: "well_ord(X,R) \<Longrightarrow> \<exists>a. Card(a) \<and> X\<approx>a"
by (fast elim!: well_ord_cardinal_eqpoll [THEN eqpoll_sym]
         intro!: Card_cardinal)

lemma well_ord_infinite_subsets_eqpoll_X:
     "\<lbrakk>well_ord(X,R); n \<in> nat; \<not>Finite(X)\<rbrakk> \<Longrightarrow> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
apply (drule well_ord_imp_ex_Card)
apply (elim allE exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (drule infinite_Card_is_InfCard, assumption)
apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans)
done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_tree_Flatten3
  imports "../../Test_Base"
begin

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

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil

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

(*fun did not finish the proof*)
function flatten3 :: "'a Tree => 'a list" where
  "flatten3 (Node (Node p x2 q) z2 r) =
   flatten3 (Node p x2 (Node q z2 r))"
| "flatten3 (Node (Nil) z2 r) = cons2 z2 (flatten3 r)"
| "flatten3 (Nil) = nil2"
  by pat_completeness auto

fun flatten0 :: "'a Tree => 'a list" where
  "flatten0 (Node p z q) =
   x (flatten0 p) (x (cons2 z (nil2)) (flatten0 q))"
| "flatten0 (Nil) = nil2"

theorem property0 :
  "((flatten3 p) = (flatten0 p))"
  oops

end


theory Boolean_Algebra_Extras
  imports Lattice
begin

record 'a huntington_algebra = "'a partial_object" +
  hor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+\<index>" 70)
  hnot :: "'a \<Rightarrow> 'a" ("!\<index>")

no_notation
  Groups.plus_class.plus (infixl "+" 65) and
  Groups.one_class.one ("1") and
  Groups.zero_class.zero ("0")

locale huntington_algebra = fixes A (structure)
  assumes hor_closed: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x + y \<in> carrier A"
  and hnot_closed: "x \<in> carrier A \<Longrightarrow> !x \<in> carrier A"
  and huntington: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x = !(!x + y) + !(!x + !y)"
  and comm: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x + y = y + x"
  and assoc: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> (x + y) + z = x + (y + z)"
  and carrier_non_empty: "carrier A \<noteq> {}"

begin

  (* Following Allan L. Mann's 'A complete proof of the Robbins conjecture' *)

  lemma or_left_cong: "x = z \<Longrightarrow> x + y = z + y" by auto

  lemma or_right_cong: "y = z \<Longrightarrow> x + y = x + z" by auto

  lemma not_cong: "x = y \<Longrightarrow> !x = !y" by auto

  lemma H1: assumes xc: "x \<in> carrier A" shows "x + !x = !x + !(!x)"
  proof -
    have nxc: "!x \<in> carrier A" and nnxc: "!(!x) \<in> carrier A"
      by (metis assms hnot_closed)+
    have "x + !x = !(!x + !(!x)) + !(!x + !(!(!x))) + (!(!(!x) + !(!x)) + !(!(!x) + !(!(!x))))"
      by (subst huntington[OF nxc nnxc], subst huntington[OF xc nnxc], simp)
    also have "... = !(!(!x) + !x) + !(!(!x) + !(!x)) + (!(!(!(!x)) + !x) + !(!(!(!x)) + !(!x)))"
      by (smt assoc comm hnot_closed hor_closed nxc)
    also have "... = !x + !(!x)"
      by (rule sym, subst huntington[OF nnxc nxc], subst huntington[OF nxc nxc], simp)
    finally show ?thesis .
  qed

  lemma double_neg: assumes xc: "x \<in> carrier A" shows "!(!x) = x"
  proof -
    have nxc: "!x \<in> carrier A" and nnxc: "!(!x) \<in> carrier A"
      by (metis assms hnot_closed)+
    have "!(!x) = !(!(!(!x)) + !x) + !(!(!(!x)) + !(!x))"
      by (subst huntington[OF nnxc nxc], simp)
    also have "... = !(!(!(!x)) + !x) + !(!x + x)"
      by (rule or_right_cong, rule not_cong, metis H1 assms comm hnot_closed)
    also have "... = !(!x + !x) + !(!x + x)"
      by (smt H1 comm hnot_closed hor_closed huntington nxc)
    also have "... = x"
      by (metis assms comm hnot_closed hor_closed huntington)
    finally show ?thesis .
  qed

  lemma H2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> !x = !y \<Longrightarrow> x = y" by (metis double_neg)

  definition hand :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<cdot>" 80) where
    "x \<cdot> y = !(!x + !y)"

  lemma hand_closed: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier A"
    by (metis hand_def hnot_closed hor_closed)

  lemma de_morgan1: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> !(x + y) = !x \<cdot> !y"
    by (metis double_neg hand_def)

  lemma de_morgan2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> !(x \<cdot> y) = !x + !y"
    by (metis double_neg hand_def hnot_closed hor_closed)

  lemma hor_as_hand: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x + y = !(!x \<cdot> !y)"
    by (metis (lifting) de_morgan2 double_neg hnot_closed)

  lemma hunt_var: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x = x\<cdot>y + x\<cdot>!y"
    by (metis (lifting) hand_def hnot_closed huntington)

  lemma hand_comm: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>y = y\<cdot>x"
    by (metis (lifting) comm hand_def hnot_closed)

  lemma hand_assoc: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> (x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)"
    by (smt assoc de_morgan2 hand_def hnot_closed)

  lemma and_right_cong: "y = z \<Longrightarrow> x\<cdot>y = x\<cdot>z" by auto

  lemma and_left_cong: "x = y \<Longrightarrow> x\<cdot>z = y\<cdot>z" by auto

  definition one_f :: "'a \<Rightarrow> 'a" where
    "one_f x \<equiv> x + !x"

  lemma one_f_const:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A"
    shows "one_f x = one_f y"
  proof -
    have nxc: "!x \<in> carrier A" and nyc: "!y \<in> carrier A"
      by (metis hnot_closed xc yc)+
    have "one_f x = x + !x"
      by (simp add: one_f_def)
    also have "... = ! (! x + ! y) + ! (! x + ! (! y)) + (! (! (! x) + ! y) + ! (! (! x) + ! (! y)))"
      by (subst huntington[OF nxc nyc], subst huntington[OF xc nyc], simp)
    also have "... = ! (! y + ! x) + ! (! y + ! (! x)) + (! (! (! y) + ! x) + ! (! (! y) + ! (! x)))"
      by (smt assoc comm hnot_closed hor_closed nxc nyc)
    also have "... = y + !y"
      by (rule sym, subst huntington[OF nyc nxc], subst huntington[OF yc nxc], simp)
    also have "... = one_f y"
      by (simp add: one_f_def)
    finally show ?thesis .
  qed

  definition hone :: "'a" ("1") where
    "1 \<equiv> THE x. x \<in> (one_f ` carrier A)"

  lemma one_prop: "x \<in> carrier A \<Longrightarrow> x + !x = 1"
    by (simp add: hone_def, rule the1I2, auto, (metis one_f_def one_f_const)+)

  lemma one_closed: "1 \<in> carrier A"
    apply (simp add: hone_def)
    apply (rule the1I2)
    apply auto
    apply (metis carrier_non_empty empty_is_image ex_in_conv)
    apply (metis one_f_const)
    by (metis hnot_closed hor_closed one_f_def)

  definition hzero :: "'a" ("0") where
    "0 = !1"

  lemma zero_closed: "0 \<in> carrier A"
    by (metis hnot_closed hzero_def one_closed)

  lemma or_zero:
    assumes xc: "x \<in> carrier A"
    shows "x + 0 = x"
  proof -
    have "!1 = 0"
      by (metis hzero_def)
    also have "... = ! (! 0 + 0) + ! (! 0 + ! 0)"
      by (subst huntington[OF zero_closed zero_closed], simp)
    also have "... = 0 + !(!0 + !0)"
      by (metis (lifting) double_neg hzero_def one_closed one_prop)
    also have "... = !1 + !(1 + 1)"
      by (metis hzero_def double_neg one_closed)
    finally have eq1: "!1 = !1 + !(1 + 1)" .

    hence eq2: "1 = 1 + !(1 + 1)"
      by (smt assoc double_neg hnot_closed hor_closed hzero_def one_prop zero_closed)

    hence eq3: "1 = 1 + 1"
      by (metis assoc hnot_closed hor_closed one_closed one_prop)

    from eq1 and eq3 have eq4: "0 = 0 + 0"
      by (metis hzero_def)

    have "x + 0 = ! (! x + x) + ! (! x + ! x) + 0"
      by (subst huntington[OF xc xc], simp)
    also have "... = !(!x + !x) + 0 + 0"
      by (smt assms comm hnot_closed hor_closed hzero_def one_prop)
    also have "... = !(!x + !x) + 0"
      by (metis assms assoc eq4 hand_closed hand_def zero_closed)
    also have "... = !(!x + !x) + !(!x + x)"
      by (metis assms comm hnot_closed hzero_def one_prop)
    also have "... = x"
      by (metis assms double_neg hand_def hunt_var)
    finally show ?thesis .
  qed

  lemma and_one: "x \<in> carrier A \<Longrightarrow> x\<cdot>1 = x"
    by (metis double_neg hand_def hnot_closed hzero_def or_zero)

  lemma and_zero: "x \<in> carrier A \<Longrightarrow> x\<cdot>0 = 0"
    by (smt H1 assoc de_morgan2 hand_def hnot_closed hor_closed hunt_var hzero_def one_prop)

  lemma or_one: "x \<in> carrier A \<Longrightarrow> x + 1 = 1"
    by (smt and_zero hand_def hnot_closed hor_as_hand hzero_def one_closed one_prop)

  lemma or_idem: "x \<in> carrier A \<Longrightarrow> x + x = x"
    by (smt double_neg hand_closed hnot_closed hor_as_hand huntington hzero_def one_prop or_zero)

  lemma and_idem: "x \<in> carrier A \<Longrightarrow> x\<cdot>x = x"
    by (metis double_neg hand_def hnot_closed or_idem)

  definition HBA :: "'a ord" where
    "HBA = \<lparr>carrier = carrier A, le = (\<lambda>x y. x + y = y)\<rparr>"

  lemma HBA_ord: "order HBA"
    by (default, simp_all add: HBA_def, (metis or_idem assoc comm)+)

  lemma HBA_carrier [simp]: "carrier HBA = carrier A"
    by (simp add: HBA_def)

  lemma HBA_lub: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> order.is_lub HBA (x + y) {x, y}"
    apply (simp add: order.is_lub_simp[OF HBA_ord], safe)
    apply (simp_all add: HBA_def)
    apply (metis hor_closed)
    apply (metis assoc or_idem)
    apply (metis assoc comm or_idem)
    by (metis assoc)

  lemma glb1: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<cdot> y + x = x"
    by (smt and_idem assoc de_morgan2 hand_closed hand_def hnot_closed huntington)

  lemma glb2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<cdot> y + y = y"
    by (smt and_idem assoc de_morgan2 hand_closed hand_comm hand_def hnot_closed huntington)

  lemma absorb1: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>(x + y) = x"
    by (smt comm double_neg glb1 hand_closed hand_def hnot_closed)

  lemma HBA_glb: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> order.is_glb HBA (x \<cdot> y) {x, y}"
    apply (simp add: order.is_glb_simp[OF HBA_ord], safe)
    apply (simp_all add: HBA_def)
    apply (metis hand_closed)
    apply (metis glb1)
    apply (metis glb2)
    by (smt H2 de_morgan1 de_morgan2 glb1 hand_assoc hand_closed hand_comm hnot_closed)

  lemma HBA_js: "join_semilattice HBA"
    apply default
    prefer 4
    apply (rule_tac x = "x + y" in bexI)
    apply simp
    apply (metis HBA_lub)
    apply (simp_all add: HBA_def)
    apply (metis hor_closed)
    apply (metis or_idem)
    apply (metis assoc)
    by (metis comm)

  lemma HBA_ms: "meet_semilattice HBA"
    apply default
    prefer 4
    apply (rule_tac x = "x \<cdot> y" in bexI)
    apply simp
    apply (metis HBA_glb)
    apply (simp_all add: HBA_def)
    apply (metis hand_closed)
    apply (metis or_idem)
    apply (metis assoc)
    by (metis comm)

  lemma HBA_lattice: "lattice HBA"
    by (simp add: lattice_def, metis HBA_ms HBA_js)

  lemma HBA_join [simp]: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<squnion>\<^bsub>HBA\<^esub> y = x + y"
    apply (simp add: order.join_def[OF HBA_ord] order.lub_def[OF HBA_ord])
    apply (rule the1I2)
    apply auto
    apply (metis HBA_lub)
    apply (metis HBA_ord order.is_lub_unique)
    by (metis HBA_lub HBA_ord order.is_lub_unique)

  lemma HBA_meet [simp]: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqinter>\<^bsub>HBA\<^esub> y = x\<cdot>y"
    apply (simp add: order.meet_def[OF HBA_ord] order.glb_def[OF HBA_ord])
    apply (rule the1I2)
    apply auto
    apply (metis HBA_glb)
    apply (metis HBA_ord order.is_glb_unique)
    by (metis (lifting) HBA_glb HBA_ord order.is_glb_unique)

  lemma HBA_bounded: "bounded_lattice HBA"
    apply (simp add: bounded_lattice_def bounded_lattice_axioms_def)
    apply safe
    apply (rule HBA_lattice)
    apply (rule_tac x = 0 in bexI)
    apply (metis comm or_zero zero_closed)
    apply (metis zero_closed)
    apply (rule_tac x = 1 in bexI)
    apply (metis and_one hand_comm one_closed)
    by (metis one_closed)

  lemma HBA_top [simp]: "bounded_lattice.top HBA = 1"
    apply (simp add: bounded_lattice.top_def[OF HBA_bounded])
    apply (rule the1I2)
    apply (simp_all add: HBA_def)
    apply (metis and_one comm glb2 one_closed)
    by (metis double_neg hnot_closed one_prop)

  lemma HBA_bot [simp]: "bounded_lattice.bot HBA = 0"
    apply (simp add: bounded_lattice.bot_def[OF HBA_bounded])
    apply (rule the1I2)
    apply (simp_all add: HBA_def)
    apply (metis (lifting) comm or_zero zero_closed)
    by (metis or_zero zero_closed)

  lemma HBA_complemented: "complemented_lattice HBA"
    apply (simp add: complemented_lattice_def complemented_lattice_axioms_def)
    apply safe
    apply (metis HBA_bounded)
    apply (rule_tac x = "!x" in exI)
    apply (subgoal_tac "!x \<in> carrier A")
    apply simp
    apply (metis hand_def hzero_def one_prop)
    by (metis hnot_closed)

  lemma distl:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A" and zc: "z \<in> carrier A"
    shows "x\<cdot>(y + z) = x\<cdot>y + x\<cdot>z"
  proof -
    have c1: "x\<cdot>y \<in> carrier A"
      by (metis hand_closed xc yc)
    have c2: "x\<cdot>(y + z)\<cdot>!y \<in> carrier A"
      by (metis hand_closed hnot_closed hor_closed xc yc zc)

    have "x\<cdot>(y + z) = x\<cdot>(y + z)\<cdot>y + x\<cdot>(y + z)\<cdot>!y"
      by (smt comm hand_closed hnot_closed hor_closed hunt_var xc yc zc)
    also have "... = x\<cdot>y + x\<cdot>(y + z)\<cdot>!y"
      apply (rule or_left_cong)
      by (smt double_neg glb1 hand_assoc hand_closed hnot_closed hor_as_hand xc yc zc)
    also have "... = (x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z) + (x\<cdot>(y + z)\<cdot>!y\<cdot>z + x\<cdot>(y + z)\<cdot>!y\<cdot>!z)"
      by (subst hunt_var[OF c1 zc], subst hunt_var[OF c2 zc], simp)
    also have "... = (x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z) + (x\<cdot>!y\<cdot>z + x\<cdot>(y + z)\<cdot>!y\<cdot>!z)"
      apply (rule or_right_cong, rule or_left_cong)
      by (smt absorb1 comm hand_assoc hand_closed hand_comm hnot_closed hor_closed xc yc zc)
    also have "... = (x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z) + (x\<cdot>!y\<cdot>z + x\<cdot>(y + z)\<cdot>!(y+z))"
      by (smt de_morgan1 hand_assoc hand_closed hnot_closed hor_closed xc yc zc)
    also have "... = (x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z) + (x\<cdot>!y\<cdot>z + x\<cdot>0)"
      by (smt hand_assoc hand_def hnot_closed hor_closed hzero_def one_prop xc yc zc)
    also have "... = (x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z) + (x\<cdot>!y\<cdot>z + 0)"
      by (metis and_zero xc)
    also have "... = x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z + x\<cdot>!y\<cdot>z"
      by (metis hand_closed hnot_closed or_zero xc yc zc)
    also have "... = x\<cdot>y\<cdot>z + x\<cdot>y\<cdot>!z + x\<cdot>y\<cdot>z + x\<cdot>!y\<cdot>z"
      by (metis (no_types) c1 comm glb1 hand_closed hunt_var zc)
    also have "... = x\<cdot>y + x\<cdot>z"
      by (smt assoc hand_assoc hand_closed hand_comm hnot_closed hunt_var xc yc zc)
    finally show ?thesis .
  qed

  lemma distr:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A" and zc: "z \<in> carrier A"
    shows "(x + y)\<cdot>z = x\<cdot>z + y\<cdot>z"
    by (metis distl hand_comm hor_closed xc yc zc)

  lemma HBA_distributive: "distributive_lattice HBA"
    apply (simp add: distributive_lattice_def distributive_lattice_axioms_def)
    apply safe
    apply (metis HBA_lattice)
    apply (subgoal_tac "y + z \<in> carrier A" "x\<cdot>y \<in> carrier A" "x\<cdot>z \<in> carrier A")
    apply simp
    apply (metis distl)
    apply (metis hand_closed)+
    apply (metis hor_closed)
    apply (subgoal_tac "y\<cdot>z \<in> carrier A" "x + y \<in> carrier A" "x + z \<in> carrier A")
    apply simp
    apply (smt and_idem assoc comm distl distr glb1 glb2 hand_closed hand_def hor_as_hand)
    apply (metis hor_closed)+
    by (metis hand_closed)

  lemma HBA_ba: "boolean_algebra HBA"
    by (simp add: boolean_algebra_def, metis HBA_complemented HBA_distributive)

end

lemma huntington_induces_ba:
  assumes hunt: "huntington_algebra \<lparr>carrier = A, hor = p, hnot = n\<rparr>"
  shows "boolean_algebra \<lparr>carrier = A, le = (\<lambda>x y. p x y = y)\<rparr>"
proof -
  let ?H = "\<lparr>carrier = A, hor = p, hnot = n\<rparr>"

  have "boolean_algebra (huntington_algebra.HBA ?H)"
    by (metis assms huntington_algebra.HBA_ba)

  moreover have "\<lparr>carrier = A, le = (\<lambda>x y. p x y = y)\<rparr> = huntington_algebra.HBA ?H"
    by (simp add: huntington_algebra.HBA_def[OF hunt])

  ultimately show ?thesis by auto
qed

notation
  Groups.plus_class.plus (infixl "+" 65) and
  Groups.one_class.one ("1") and
  Groups.zero_class.zero ("0")

no_notation
  huntington_algebra.hor (infixl "+\<index>" 70) and
  huntington_algebra.hnot ("!\<index>")

datatype 'a bexpr = BLeaf 'a
                  | BOr "'a bexpr" "'a bexpr" (infixl ":+:" 70)
                  | BNot "'a bexpr"
                  | BAnd "'a bexpr" "'a bexpr" (infixl ":\<cdot>:" 70)
                  | BOne
                  | BZero

primrec bexpr_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a bexpr \<Rightarrow> 'b bexpr" where
  "bexpr_map f (BLeaf x) = BLeaf (f x)"
| "bexpr_map f (BOr x y) = BOr (bexpr_map f x) (bexpr_map f y)"
| "bexpr_map f (BNot x) = BNot (bexpr_map f x)"
| "bexpr_map f (BAnd x y) = BAnd (bexpr_map f x) (bexpr_map f y)"
| "bexpr_map f BOne = BOne"
| "bexpr_map f BZero = BZero"

primrec bexpr_leaves :: "'a bexpr \<Rightarrow> 'a set" where
  "bexpr_leaves (BLeaf x) = {x}"
| "bexpr_leaves (BOr x y) = bexpr_leaves x \<union> bexpr_leaves y"
| "bexpr_leaves (BNot x) = bexpr_leaves x"
| "bexpr_leaves (BAnd x y) = bexpr_leaves x \<union> bexpr_leaves y"
| "bexpr_leaves BOne = {}"
| "bexpr_leaves BZero = {}"

inductive hunt_cong :: "'a bexpr \<Rightarrow> 'a bexpr \<Rightarrow> bool" where
  refl [intro]: "hunt_cong x x"
| sym [sym]: "hunt_cong x y \<Longrightarrow> hunt_cong y x"
| trans [trans]: "\<lbrakk>hunt_cong x y; hunt_cong y z\<rbrakk> \<Longrightarrow> hunt_cong x z"
| or_compat: "hunt_cong x1 x2 \<Longrightarrow> hunt_cong y1 y2 \<Longrightarrow> hunt_cong (BOr x1 y1) (BOr x2 y2)"
| not_compat: "hunt_cong x y \<Longrightarrow> hunt_cong (BNot x) (BNot y)"
| and_compat: "hunt_cong x1 x2 \<Longrightarrow> hunt_cong y1 y2 \<Longrightarrow> hunt_cong (BAnd x1 y1) (BAnd x2 y2)"
| huntington: "hunt_cong (BNot (BNot x :+: y) :+: BNot (BNot x :+: BNot y)) x"
| comm: "hunt_cong (x :+: y) (y :+: x)"
| assoc: "hunt_cong ((x :+: y) :+: z) (x :+: (y :+: z))"
| one: "hunt_cong (x :+: BNot x) BOne"
| zero: "hunt_cong (BNot BOne) BZero"
| meet: "hunt_cong (x :\<cdot>: y) (BNot (BNot x :+: BNot y))"

quotient_type 'a bterm = "'a bexpr" / "hunt_cong"
  apply (simp add: equivp_def, auto)
  apply (subgoal_tac "\<forall>z. hunt_cong x z = hunt_cong y z")
  apply auto
  by (metis hunt_cong.sym hunt_cong.trans)+

lift_definition bt_or :: "'a bterm \<Rightarrow> 'a bterm \<Rightarrow> 'a bterm" is BOr
  by (rule hunt_cong.or_compat, assumption+)

lift_definition bt_not :: "'a bterm \<Rightarrow> 'a bterm" is BNot
  by (rule hunt_cong.not_compat, assumption)

lift_definition bt_and :: "'a bterm \<Rightarrow> 'a bterm \<Rightarrow> 'a bterm" is BAnd
  by (rule hunt_cong.and_compat, assumption+)

lift_definition bt_one :: "'a bterm" is BOne
  by (rule hunt_cong.refl)

lift_definition bt_zero :: "'a bterm" is BZero
  by (rule hunt_cong.refl)

definition free_ba where "free_ba \<equiv> \<lparr>carrier = UNIV, le = (\<lambda>x y. bt_or x y = y)\<rparr>"

lemma free_ba_hunt: "huntington_algebra \<lparr>carrier = UNIV, hor = bt_or, hnot = bt_not\<rparr>"
proof (default, simp_all)
  fix x y z :: "'b bterm"
  show "x = bt_or (bt_not (bt_or (bt_not x) y)) (bt_not (bt_or (bt_not x) (bt_not y)))"
    by (rule HOL.sym, transfer, rule hunt_cong.huntington)
  show "bt_or x y = bt_or y x"
    by (transfer, rule hunt_cong.comm)
  show "bt_or (bt_or x y) z = bt_or x (bt_or y z)"
    by (transfer, rule hunt_cong.assoc)
qed

abbreviation BTH where "BTH \<equiv> \<lparr>carrier = UNIV, hor = bt_or, hnot = bt_not\<rparr>"

lemma bt_hone [simp]: "huntington_algebra.hone BTH = bt_one"
proof -
  have "bt_or bt_one (bt_not bt_one) = bt_one"
    by (transfer, metis one)
  thus ?thesis
    by (simp add: huntington_algebra.one_prop[symmetric, OF free_ba_hunt])
qed

lemma bt_hzero [simp]: "huntington_algebra.hzero BTH = bt_zero"
proof -
  have "bt_not bt_one = bt_zero"
    by (transfer, metis zero)
  thus ?thesis
    by (simp add: huntington_algebra.hzero_def[OF free_ba_hunt])
qed

interpretation hba: huntington_algebra "BTH"
  where "hor BTH x y = bt_or x y"
  and "hnot BTH x = bt_not x"
  and "huntington_algebra.hand BTH x y = bt_and x y"
  and "huntington_algebra.hone BTH = bt_one"
  and "huntington_algebra.hzero BTH = bt_zero"
  and "x \<in> carrier BTH = True"
  apply (simp_all add: free_ba_hunt)
  apply (simp add: huntington_algebra.hand_def[OF free_ba_hunt])
  apply transfer
  apply (metis hunt_cong.sym meet)
  done

theorem free_ba: "boolean_algebra free_ba"
proof (simp add: free_ba_def)
  from free_ba_hunt
  show "boolean_algebra \<lparr>carrier = UNIV, le = \<lambda>x y. bt_or x y = y\<rparr>"
    by (rule huntington_induces_ba)
qed

lemma free_ba_ord: "order free_ba"
  apply (insert free_ba)
  apply (simp add: boolean_algebra_def distributive_lattice_def)
  apply (simp add: lattice_def join_semilattice_def)
  by auto

lemma [simp]: "x \<squnion>\<^bsub>free_ba\<^esub> y = bt_or x y"
  apply (simp add: order.join_def[OF free_ba_ord] order.lub_simp[OF free_ba_ord])
  apply (simp add: free_ba_def)
  apply (rule the1I2)
  apply auto
  apply (smt hba.assoc hba.comm hba.or_idem)
  apply (metis hba.comm)
  by (metis (full_types) hba.assoc hba.comm hba.or_idem)

lemma [simp]: "x \<sqinter>\<^bsub>free_ba\<^esub> y = bt_and x y"
  apply (simp add: order.meet_def[OF free_ba_ord] order.glb_simp[OF free_ba_ord])
  apply (simp add: free_ba_def)
  apply (rule the1I2)
  apply auto
  apply (rule_tac x = "bt_and x y" in exI)
  apply (metis hba.absorb1 hba.distl hba.glb2 hba.hand_comm)
  apply (metis hba.comm)
  by (smt hba.absorb1 hba.distr hba.glb2 hba.hand_comm)

lemma free_ba_bl: "bounded_lattice free_ba"
  apply (insert free_ba)
  apply (simp add: boolean_algebra_def complemented_lattice_def)
  apply auto
  done

lemma [simp]: "bounded_lattice.top free_ba = bt_one"
  apply (simp add: bounded_lattice.top_def[OF free_ba_bl])
  apply (simp add: free_ba_def)
  apply (rule the1I2)
  apply auto
  apply (metis hba.or_one)
  apply (metis hba.comm)
  by (metis hba.comm hba.or_one)

lemma [simp]: "bounded_lattice.bot free_ba = bt_zero"
  apply (simp add: bounded_lattice.bot_def[OF free_ba_bl])
  apply (simp add: free_ba_def)
  apply (rule the1I2)
  apply auto
  apply (metis hba.comm hba.or_zero)
  apply (metis hba.or_zero)
  by (metis hba.or_zero)

interpretation ba: join_semilattice free_ba
  where "x \<squnion>\<^bsub>free_ba\<^esub> y = bt_or x y"
  and "x \<sqinter>\<^bsub>free_ba\<^esub> y = bt_and x y"
  and "carrier free_ba = UNIV"
  and "bounded_lattice.top free_ba = bt_one"
  and "bounded_lattice.bot free_ba = bt_zero"
  by (insert free_ba, simp_all add: boolean_algebra_def distributive_lattice_def lattice_def, auto)

interpretation ba: meet_semilattice free_ba
  where "x \<squnion>\<^bsub>free_ba\<^esub> y = bt_or x y"
  and "x \<sqinter>\<^bsub>free_ba\<^esub> y = bt_and x y"
  and "carrier free_ba = UNIV"
  and "bounded_lattice.top free_ba = bt_one"
  and "bounded_lattice.bot free_ba = bt_zero"
  by (insert free_ba, simp_all add: boolean_algebra_def distributive_lattice_def lattice_def, auto)

interpretation ba: boolean_algebra free_ba
  where "x \<squnion>\<^bsub>free_ba\<^esub> y = bt_or x y"
  and "x \<sqinter>\<^bsub>free_ba\<^esub> y = bt_and x y"
  and "carrier free_ba = UNIV"
  and "bounded_lattice.top free_ba = bt_one"
  and "bounded_lattice.bot free_ba = bt_zero"
  by (insert free_ba, simp_all)

end


theory PartialQuantales
  imports PartialMonoid Quantale_Sup
begin

notation pmult_one ("1'")

text {*
  Quantales with \<Squnion> distributivity
*}

class partial_near_quantale = complete_lattice + partial_semigroup +
  assumes partial_qSup_distr: "\<forall>y \<in> Y. y ## x \<Longrightarrow> \<Squnion> Y * x = \<Squnion> ((\<lambda>y. y * x) ` Y)"

class partial_pre_quantale = partial_near_quantale +
  assumes partial_qSup_subdistl:  "\<forall>y \<in> Y. x ## y \<Longrightarrow> \<Squnion> ((\<lambda>y. x * y) ` Y) \<le> x * \<Squnion> Y"

class partial_quantale = partial_pre_quantale +
  assumes partial_qSup_supdistl: "\<forall>y \<in> Y. x ## y \<Longrightarrow> x * \<Squnion> Y \<le> \<Squnion> ((\<lambda>y. x * y) ` Y)"
begin

lemma partial_qSup_distl: "\<forall>y \<in> Y. x ## y \<Longrightarrow> x * \<Squnion> Y = \<Squnion> ((\<lambda>y. x * y) ` Y)"
  by (metis antisym_conv partial_qSup_subdistl partial_qSup_supdistl)

end

(* Quantale with different signature, derived from partial mult *)
class near_quantale_pmult = partial_near_quantale + totality
begin
sublocale Sup_pmult!: near_quantale_Sup _ _ _ _ _ _ _ _ pmult
  apply (default, metis pmult_assoc totality)
  by (metis partial_qSup_distr totality)
end

class near_quantale_pmult_unital = near_quantale_pmult + partial_monoid
begin
sublocale Sup_pmult!: near_quantale_Sup_unital "1'" "op *"
  by default (simp_all add: pmult_onel pmult_oner)

end

class pre_quantale_pmult = partial_pre_quantale + totality
begin
subclass near_quantale_pmult ..
sublocale Sup_pmult!: pre_quantale_Sup  _ _ _ _ _ _ _ _ pmult
  by default (metis partial_qSup_subdistl totality)
end

class quantale_pmult = partial_quantale + totality
begin
subclass pre_quantale_pmult ..
sublocale Sup_pmult!: quantale_Sup _ _ _ _ _ _ _ _ pmult
  by default (metis partial_qSup_supdistl totality)
end

class quantale_pmult_unital = near_quantale_pmult_unital + quantale_pmult
begin
sublocale Sup_pmult!: quantale_Sup_unital "1'" "op *" ..
end

class comm_quantale_pmult = quantale_pmult + partial_ab_semigroup
class comm_quantale_pmult_unital = quantale_pmult_unital + comm_quantale_pmult
class distrib_quantale_pmult = quantale_pmult + complete_distrib_lattice
class distrib_comm_quantale_pmult_unital = distrib_quantale_pmult + comm_quantale_pmult_unital

end


chapter \<open>Abstract Formulation of Tarski's Theorems\<close>

text \<open>We prove Tarski's proof-theoretic and semantic theorems about the
non-definability and respectively non-expressiveness (in the standard model) of truth\<close>

(*<*)
theory Tarski
  imports Goedel_Formula Standard_Model_More
begin
(*>*)

section \<open>Non-Definability of Truth\<close>

context Goedel_Form
begin

context
  fixes T :: 'fmla
  assumes T[simp,intro!]: "T \<in> fmla"
  and Fvars_T[simp]: "Fvars T = {xx}"
  and prv_T: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv (eqv (subst T \<langle>\<phi>\<rangle> xx) \<phi>)"
begin

definition \<phi>T :: 'fmla where "\<phi>T \<equiv> diag (neg T)"

lemma \<phi>T[simp,intro!]: "\<phi>T \<in> fmla" and
Fvars_\<phi>T[simp]: "Fvars \<phi>T = {}"
  unfolding \<phi>T_def PP_def by auto

lemma bprv_\<phi>T_eqv:
"bprv (eqv \<phi>T (neg (subst T \<langle>\<phi>T\<rangle> xx)))"
  unfolding \<phi>T_def using bprv_diag_eqv[of "neg T"] by simp

lemma prv_\<phi>T_eqv:
"prv (eqv \<phi>T (neg (subst T \<langle>\<phi>T\<rangle> xx)))"
  using d_dwf.bprv_prv'[OF _ bprv_\<phi>T_eqv, simplified] .

lemma \<phi>T_prv_fls: "prv fls"
using prv_eqv_eqv_neg_prv_fls2[OF _ _ prv_T[OF \<phi>T Fvars_\<phi>T] prv_\<phi>T_eqv] by auto

end \<comment> \<open>context\<close>

theorem Tarski_proof_theoretic:
assumes "T \<in> fmla" "Fvars T = {xx}"
and "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv (eqv (subst T \<langle>\<phi>\<rangle> xx) \<phi>)"
shows "\<not> consistent"
using \<phi>T_prv_fls[OF assms] consistent_def by auto

end \<comment> \<open>context @{locale Goedel_Form}\<close>

section \<open>Non-Expressiveness of Truth\<close>

text \<open>This follows as a corollary of the syntactic version, after taking prv
to be isTrue on sentences.Indeed, this is a virtue of our abstract treatment
of provability: We don't work with a particular predicate, but with any predicate
that is closed under some rules --- which could as well be a semantic notion of truth (for sentences).\<close>

locale Goedel_Form_prv_eq_isTrue =
Goedel_Form
  var trm fmla Var num FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  prv bprv
  enc
  P
  S
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var num FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and prv bprv
and enc ("\<langle>_\<rangle>")
and S
and P
+
fixes isTrue :: "'fmla \<Rightarrow> bool"
assumes prv_eq_isTrue: "\<And> \<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv \<phi> = isTrue \<phi>"
begin

theorem Tarski_semantic:
assumes 0: "T \<in> fmla" "Fvars T = {xx}"
and 1: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> isTrue (eqv (subst T \<langle>\<phi>\<rangle> xx) \<phi>)"
shows "\<not> consistent"
using assms prv_eq_isTrue[of "eqv (subst T \<langle>_\<rangle> xx) _"]
  by (intro Tarski_proof_theoretic[OF 0]) auto

text \<open>NB: To instantiate the semantic version of Tarski's theorem for a truth predicate
isTruth on sentences, one needs to extend it to a predicate "prv" on formulas and verify
that "prv" satisfies the rules of intuitionistic logic.\<close>

end \<comment> \<open>context @{locale Goedel_Form_prv_eq_isTrue}\<close>

(*<*)
end
(*>*)


theory prop_03
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun length :: "'a list => Nat" where
  "length (Nil2) = Z"
  | "length (Cons2 y xs) = S (length xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster plus length append *)

lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_aa [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

(*hipster length append
lemma lemma_aj []: "append x2 Nil2 = x2"
by (hipster_induct_schemes length.simps append.simps)

lemma lemma_ak []: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes length.simps append.simps)

lemma unknown' []: "length (append x y) = length (append y x)"
oops*)

(*hipster length append plus
lemma lemma_ab [thy_expl]: "plus (length x2) (length y2) = length (append x2 y2)"
by (hipster_induct_schemes length.simps append.simps plus.simps)

lemma lemma_ac [thy_expl]: "plus (length x4) (length y4) = length (append y4 x4)"
by (hipster_induct_schemes length.simps append.simps plus.simps)*)
hipster length append plus

  theorem x0 [thy_expl]:
    "(length (append x y)) = (plus (length y) (length x))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

lemma unknown [thy_expl]: "length (append x y) = length (append y x)"
by (metis thy_expl)

end


section {*I\_epda\_base*}
theory
  I_epda_base

imports
  PRJ_07__ENTRY

begin

record ('state, 'event, 'stack) epda_step_label =
  edge_src :: "'state"
  edge_event :: "'event option"
  edge_pop :: "'stack list"
  edge_push :: "'stack list"
  edge_trg :: "'state"

record ('state, 'event, 'stack) epda =
  epda_states :: "'state set"
  epda_events :: "'event set"
  epda_gamma :: "'stack set"
  epda_delta :: "('state, 'event, 'stack) epda_step_label set"
  epda_initial :: "'state"
  epda_box :: "'stack"
  epda_marking :: "'state set"

definition epda_effects :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list set"
  where
    "epda_effects G \<equiv>
  {w. set w \<subseteq> epda_events G}"

definition valid_epda_step_label :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> ('state, 'event, 'stack) epda_step_label
  \<Rightarrow> bool"
  where
    "valid_epda_step_label G e \<equiv>
  edge_src e \<in> epda_states G
  \<and> edge_trg e \<in> epda_states G
  \<and> option_to_set (edge_event e) \<subseteq> epda_events G
  \<and> edge_pop e \<in> may_terminated_by (epda_gamma G) (epda_box G)
  \<and> edge_push e \<in> may_terminated_by (epda_gamma G) (epda_box G)
  \<and> (edge_pop e \<in> must_terminated_by (epda_gamma G) (epda_box G)
     \<longleftrightarrow> edge_push e \<in> must_terminated_by (epda_gamma G) (epda_box G))"

definition valid_epda :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> bool"
  where
    "valid_epda G \<equiv>
  finite (epda_states G)
  \<and> finite (epda_events G)
  \<and> finite (epda_gamma G)
  \<and> finite (epda_delta G)
  \<and> epda_initial G \<in> epda_states G
  \<and> epda_box G \<in> epda_gamma G
  \<and> epda_marking G \<subseteq> epda_states G
  \<and> (\<forall>e\<in> epda_delta G. valid_epda_step_label G e)"

lemma valid_epda_step_label_not_terminated_by_eq: "
  valid_epda_step_label M e
  \<Longrightarrow> (edge_pop e \<in> not_terminated_by (epda_gamma M) (epda_box M)
  \<longleftrightarrow> edge_push e \<in> not_terminated_by (epda_gamma M) (epda_box M))"
  apply(simp add: valid_epda_step_label_def)
  apply(simp add: may_terminated_by_def must_terminated_by_def not_terminated_by_def append_language_def kleene_star_def)
  apply(rule order_antisym)
   apply(clarsimp)
   apply(rename_tac a aa x)(*strict*)
   apply(force)
  apply(force)
  done

datatype ('state, 'event, 'stack) epda_destinations =
  state "'state"
  | edge "('state, 'event, 'stack)epda_step_label"

definition epda_destinations :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> ('state, 'event, 'stack) epda_destinations set"
  where
    "epda_destinations G \<equiv>
  state ` (epda_states G) \<union> edge ` (epda_delta G)"

definition epda_step_labels :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> ('state, 'event, 'stack) epda_step_label set"
  where
    "epda_step_labels G \<equiv>
  epda_delta G"

definition epda_no_empty_steps_from_marking_states :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> bool"
  where
    "epda_no_empty_steps_from_marking_states G \<equiv>
  \<forall>e.
    e \<in> epda_delta G
    \<longrightarrow> edge_src e \<in> epda_marking G
    \<longrightarrow> edge_event e \<noteq> None"

definition epda_empty_history :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list"
  where
    "epda_empty_history G \<equiv>
  []"
declare epda_empty_history_def [simp add]

definition epda_empty_history_fragment :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list"
  where
    "epda_empty_history_fragment G \<equiv>
  []"
declare epda_empty_history_fragment_def [simp add]

definition epda_empty_scheduler :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list"
  where
    "epda_empty_scheduler G \<equiv>
  []"
declare epda_empty_scheduler_def [simp add]

definition epda_empty_scheduler_fragment :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list"
  where
    "epda_empty_scheduler_fragment G \<equiv>
  []"
declare epda_empty_scheduler_fragment_def [simp add]

definition epda_fixed_schedulers :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list set"
  where
    "epda_fixed_schedulers G \<equiv>
  {[]}"
declare epda_fixed_schedulers_def [simp add]

definition epda_empty_fixed_scheduler :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list"
  where
    "epda_empty_fixed_scheduler G \<equiv>
  []"
declare epda_empty_fixed_scheduler_def [simp add]

definition epda_empty_unfixed_scheduler :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list"
  where
    "epda_empty_unfixed_scheduler G \<equiv>
  []"
declare epda_empty_unfixed_scheduler_def [simp add]

definition epda_fixed_scheduler_extendable :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list
  \<Rightarrow> bool"
  where
    "epda_fixed_scheduler_extendable G w \<equiv>
  True"
declare epda_fixed_scheduler_extendable_def [simp add]

definition epda_unfixed_scheduler_extendable :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'event list
  \<Rightarrow> bool"
  where
    "epda_unfixed_scheduler_extendable G w \<equiv>
  True"
declare epda_unfixed_scheduler_extendable_def [simp add]

definition epda_sub :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> ('state, 'event, 'stack) epda
  \<Rightarrow> bool"
  where
    "epda_sub G1 G2 \<equiv>
  epda_states G1 \<subseteq> epda_states G2
  \<and> epda_marking G1 \<subseteq> epda_marking G2
  \<and> epda_delta G1 \<subseteq> epda_delta G2
  \<and> epda_gamma G1 \<subseteq> epda_gamma G2
  \<and> epda_events G1 \<subseteq> epda_events G2
  \<and> epda_initial G1 = epda_initial G2
  \<and> epda_box G1 = epda_box G2"

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_rotate_snoc_self
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun snoc :: "'a => 'a list => 'a list" where
"snoc y (nil2) = cons2 y (nil2)"
| "snoc y (cons2 z2 ys) = cons2 z2 (snoc y ys)"

fun rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 z22 xs1) = rotate z2 (snoc z22 xs1)"

theorem property0 :
  "((rotate n (x xs xs)) = (x (rotate n xs) (rotate n xs)))"
  oops

end


section \<open> CSP and Circus process examples \<close>

theory utp_csp_ex
  imports "../theories/circus/utp_circus"
begin

subsection \<open> Sequential Examples \<close>

text \<open> In this theory we calculate reactive designs for a number of simple CSP/Circus processes. \<close>

datatype ev = a | b | c

lemma csp_ex_1:
  "(a \<^bold>\<rightarrow> Skip) = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> \<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>}\<^sub>u) \<diamondop> \<Phi>(true,id\<^sub>s,\<langle>\<guillemotleft>a\<guillemotright>\<rangle>))"
  by (rdes_simp)

lemma csp_ex_2:
  "(a \<^bold>\<rightarrow> Chaos) = \<^bold>R\<^sub>s ((\<I>(true,\<langle>\<guillemotleft>a\<guillemotright>\<rangle>)) \<turnstile> \<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>}\<^sub>u) \<diamondop> false)"
  by (rdes_simp)

lemma csp_ex_3:
  "(a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> Skip)
   =  \<^bold>R\<^sub>s (true\<^sub>r \<turnstile> (\<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>}\<^sub>u) \<or> \<E>(true,\<langle>\<guillemotleft>a\<guillemotright>\<rangle>, {\<guillemotleft>b\<guillemotright>}\<^sub>u)) \<diamondop> \<Phi>(true,id\<^sub>s,\<langle>\<guillemotleft>a\<guillemotright>, \<guillemotleft>b\<guillemotright>\<rangle>))"
  by (rdes_simp)

lemma csp_ex_4:
  "(a \<^bold>\<rightarrow> Stop \<box> b \<^bold>\<rightarrow> Skip) =
   \<^bold>R\<^sub>s (true\<^sub>r \<turnstile> (\<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>, \<guillemotleft>b\<guillemotright>}\<^sub>u) \<or> \<E>(true,\<langle>\<guillemotleft>a\<guillemotright>\<rangle>, {}\<^sub>u)) \<diamondop> \<Phi>(true,id\<^sub>s,\<langle>\<guillemotleft>b\<guillemotright>\<rangle>))"
  by (rdes_simp)

lemma csp_ex_5:
  "(a \<^bold>\<rightarrow> Chaos \<box> b \<^bold>\<rightarrow> Skip) = \<^bold>R\<^sub>s (\<I>(true,\<langle>\<guillemotleft>a\<guillemotright>\<rangle>) \<turnstile> \<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>, \<guillemotleft>b\<guillemotright>}\<^sub>u) \<diamondop> \<Phi>(true,id\<^sub>s,\<langle>\<guillemotleft>b\<guillemotright>\<rangle>))"
  by (rdes_simp)

lemma csp_ex_6:
  assumes "P is NCSP" "Q is NCSP"
  shows "(a \<^bold>\<rightarrow> P \<box> a \<^bold>\<rightarrow> Q) = a \<^bold>\<rightarrow> (P \<sqinter> Q)"
  by (rdes_simp cls: assms)

lemma csp_ex_7: "a \<^bold>\<rightarrow> a \<^bold>\<rightarrow> a \<^bold>\<rightarrow> Miracle \<sqsubseteq> a \<^bold>\<rightarrow> Miracle"
  by (rdes_refine)

lemma csp_ex_8:
  "a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> Skip \<box> c \<^bold>\<rightarrow> Skip =
   \<^bold>R\<^sub>s (true\<^sub>r \<turnstile> (\<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>, \<guillemotleft>c\<guillemotright>}\<^sub>u) \<or> \<E>(true,\<langle>\<guillemotleft>a\<guillemotright>\<rangle>, {\<guillemotleft>b\<guillemotright>}\<^sub>u)) \<diamondop> (\<Phi>(true,id\<^sub>s,\<langle>\<guillemotleft>a\<guillemotright>, \<guillemotleft>b\<guillemotright>\<rangle>) \<or> \<Phi>(true,id\<^sub>s,\<langle>\<guillemotleft>c\<guillemotright>\<rangle>)))"
  by (rdes_simp)

subsection \<open> State Examples \<close>

lemma assign_prefix_ex:
  assumes "vwb_lens x"
  shows "x :=\<^sub>C 1 ;; a \<^bold>\<rightarrow> x :=\<^sub>C (&x + 2) = a \<^bold>\<rightarrow> x :=\<^sub>C 3"
  (is "?lhs = ?rhs")
proof -
  from assms have "?lhs = \<^bold>R\<^sub>s (true\<^sub>r \<turnstile> \<E>(true,\<langle>\<rangle>, {\<guillemotleft>a\<guillemotright>}\<^sub>u) \<diamondop> \<Phi>(true,[&x \<mapsto>\<^sub>s 3],\<langle>\<guillemotleft>a\<guillemotright>\<rangle>))"
    by (rdes_simp)
  also have "... = ?rhs"
    by (rdes_simp)
  finally show ?thesis .
qed

subsection \<open> Parallel Examples \<close>

lemma csp_parallel_ex1:
  "(a \<^bold>\<rightarrow> Skip) \<lbrakk>{a}\<rbrakk>\<^sub>C (a \<^bold>\<rightarrow> Skip) = a \<^bold>\<rightarrow> Skip" (is "?lhs = ?rhs")
  by (rdes_eq)

lemma csp_parallel_ex2:
  "(a \<^bold>\<rightarrow> Skip) \<lbrakk>{a,b}\<rbrakk>\<^sub>C (b \<^bold>\<rightarrow> Skip) = Stop" (is "?lhs = ?rhs")
  by (rdes_eq)

lemma csp_parallel_ex3:
  "(a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> Skip) \<lbrakk>{b}\<rbrakk>\<^sub>C (b \<^bold>\<rightarrow> c \<^bold>\<rightarrow> Skip) = a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> c \<^bold>\<rightarrow> Skip" (is "?lhs = ?rhs")
  by (rdes_eq)

lemma csp_parallel_ex4:
  "(a \<^bold>\<rightarrow> Skip \<box> b \<^bold>\<rightarrow> Skip) \<lbrakk>{b}\<rbrakk>\<^sub>C (b \<^bold>\<rightarrow> Skip) = a \<^bold>\<rightarrow> Stop \<box> b \<^bold>\<rightarrow> Skip" (is "?lhs = ?rhs")
  by (rdes_eq)

lemma csp_parallel_ex5:
  "(a \<^bold>\<rightarrow> Chaos \<box> b \<^bold>\<rightarrow> Skip) \<lbrakk>{a, b}\<rbrakk>\<^sub>C (b \<^bold>\<rightarrow> Skip) = b \<^bold>\<rightarrow> Skip" (is "?lhs = ?rhs")
  by (rdes_eq)

lemma csp_parallel_ex6:
  assumes "vwb_lens ns\<^sub>1" "vwb_lens ns\<^sub>2" "x \<subseteq>\<^sub>L ns\<^sub>1" "y \<subseteq>\<^sub>L ns\<^sub>2" "ns\<^sub>1 \<bowtie> ns\<^sub>2"
  shows "(x :=\<^sub>C u) \<lbrakk>ns\<^sub>1\<parallel>{b}\<parallel>ns\<^sub>2\<rbrakk> (y :=\<^sub>C v) = \<langle>[x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v]\<rangle>\<^sub>C"
  using assms by (rdes_eq)

lemma csp_interleave_ex1: "(a \<^bold>\<rightarrow> Skip) ||| (b \<^bold>\<rightarrow> Skip) = (a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> Skip \<box> b \<^bold>\<rightarrow> a \<^bold>\<rightarrow> Skip)"
  by (rdes_eq)

lemma csp_hiding_ex1: "(a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> Skip) \\\<^sub>C {b} = a \<^bold>\<rightarrow> Skip"
  by (rdes_eq)

lemma "(while\<^sub>C true do a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> Skip od) \<lbrakk>{b}\<rbrakk>\<^sub>C (while\<^sub>C true do b \<^bold>\<rightarrow> c \<^bold>\<rightarrow> Skip od) =
       while\<^sub>C true do a \<^bold>\<rightarrow> b \<^bold>\<rightarrow> c \<^bold>\<rightarrow> Skip od"
  apply (rdes_eq_split)
  oops

(*
lemma
  assumes "P is NCSP" "Q is NCSP" "pre\<^sub>R P = true" "pre\<^sub>R Q = true" "B\<^sub>1 \<noteq> {}" "A\<^sub>1 \<noteq> {}"
    "peri\<^sub>R(P) = (\<Sqinter> i\<in>A\<^sub>1\<bullet> \<E>(s\<^sub>P\<^sub>1(i),t\<^sub>P\<^sub>1(i),E\<^sub>P(i)))"
    "post\<^sub>R(P) = (\<Sqinter> i\<in>A\<^sub>2\<bullet> \<Phi>(s\<^sub>P\<^sub>2(i),\<sigma>\<^sub>P(i),t\<^sub>P\<^sub>2(i)))"
    "peri\<^sub>R(Q) = (\<Sqinter> i\<in>B\<^sub>1\<bullet> \<E>(s\<^sub>Q\<^sub>1(i),t\<^sub>Q\<^sub>1(i),E\<^sub>Q(i)))"
    "post\<^sub>R(Q) = (\<Sqinter> i\<in>B\<^sub>2\<bullet> \<Phi>(s\<^sub>Q\<^sub>2(i),\<sigma>\<^sub>Q(i),t\<^sub>Q\<^sub>2(i)))"
  shows "(a \<^bold>\<rightarrow> P) ||| (b \<^bold>\<rightarrow> Q) = (a \<^bold>\<rightarrow> (P ||| (b \<^bold>\<rightarrow> Q)) \<box> b \<^bold>\<rightarrow> ((a \<^bold>\<rightarrow> P) ||| Q))"
  apply (rdes_eq_split cls: assms(1-2))
    apply (simp_all add: assms wp rpred closure usubst unrest rdes_rel_norms)
*)

end


theory PSem
imports Main
begin

datatype object_type = pointer | variable     (*object types to be added, specifically variable?*)

type_synonym address = nat
type_synonym id = nat

record posem =
  A :: "id \<Rightarrow> (nat \<times> object_type) option"
  alloc_addrs :: "nat set"  (*locations in ran(A ps)*)

definition "newran loc ps \<equiv> \<exists>b. (loc, b)\<in>ran(A ps)"

definition "isfree_addr a ps \<equiv> a\<notin>(alloc_addrs ps) "

definition "constant_alloc_ass ps \<equiv> \<forall>loc. (loc \<in> alloc_addrs ps \<longleftrightarrow> newran loc ps)"

definition "Unique_allocs ps \<equiv> \<forall>prov . prov\<in> dom(A ps)
\<longrightarrow> (\<nexists>prov'. prov'\<noteq>prov \<and> prov'\<in> dom(A ps) \<and> fst(the(A ps prov')) = fst(the(A ps prov)))"

definition "psem_rules ps \<equiv> Unique_allocs ps \<and> constant_alloc_ass ps"

lemmas alloc_general_lemmas [simp] = newran_def isfree_addr_def constant_alloc_ass_def
                                      Unique_allocs_def psem_rules_def

definition "allocate_object ps loc prov ps' typ \<equiv> isfree_addr loc ps \<and> prov \<notin> dom(A ps)
 \<and> ps' = ps\<lparr>A := (A ps) (prov:=Some (loc, typ)),
            alloc_addrs := (alloc_addrs ps \<union> {loc})\<rparr>"

definition "kill ps prov ps' \<equiv>  prov \<in> dom(A ps)
\<and> ps' = ps \<lparr> A:= (A ps) (prov:= None),
            alloc_addrs := (alloc_addrs ps - {fst(the(A ps prov))})\<rparr>"

lemmas alloc_operation_lemmas [simp] = allocate_object_def kill_def

(*------------might be useful in other proofs----------------*)
lemma in_dom_notNone :
  "prov\<in>dom(A ps) \<Longrightarrow> \<exists>loc b. A ps prov = Some (loc,b)"
  by auto

lemma "prov\<in>dom(A ps) \<Longrightarrow> constant_alloc_ass ps \<Longrightarrow> fst(the(A ps prov)) \<in> alloc_addrs ps"
  apply(simp)
  by (metis fst_conv in_dom_notNone option.sel ranI)

lemma set_alloc_addr_lem1:
  "allocate_object ps loc prov ps' typ
  \<Longrightarrow> prov \<notin> dom(A ps)"
  by auto

lemma set_alloc_addr_lem2:
  "allocate_object ps loc prov ps' typ
  \<Longrightarrow> prov \<in> dom(A ps')"
  by auto

lemma pssimp : "kill ps prov ps' \<Longrightarrow>
  A ps' prov = None \<and> alloc_addrs ps' = alloc_addrs ps - {fst(the(A ps prov))}"
  by(simp)

lemma uniqueness_lemma1:
  "constant_alloc_ass ps \<Longrightarrow>
 psem_rules ps \<Longrightarrow>
 locb \<in> alloc_addrs ps \<Longrightarrow>
 prova=provb \<Longrightarrow> fst(the(A ps prova)) = loca \<Longrightarrow> fst(the(A ps provb)) = locb \<Longrightarrow> loca=locb"
  by (simp)

lemma uniqueness_lemma2:
  "constant_alloc_ass ps \<Longrightarrow> Unique_allocs ps \<Longrightarrow>
 \<not>isfree_addr loca ps \<Longrightarrow>
 \<not>isfree_addr locb ps \<Longrightarrow>
 prova=provb \<Longrightarrow> fst(the(A ps prova)) = loca \<Longrightarrow> fst(the(A ps provb)) = locb \<Longrightarrow> loca=locb"
  by (simp)

lemma uniqueness_lemma3:
  "constant_alloc_ass ps \<Longrightarrow>
 isfree_addr loca ps \<Longrightarrow>
 \<nexists>prova b. A ps prova = Some (loca,b)"
  apply simp
  by (metis ranI)

lemma alloc_step_1:
  assumes "prov \<notin> dom(A ps)"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "prov \<in> dom(A ps')"
  using assms by simp

lemma alloc_step_2:
  assumes "prov \<notin> dom(A ps)"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "\<not>(isfree_addr loc ps')"
  using assms by simp

lemma alloc_step_3:
  assumes "prov \<notin> dom(A ps)"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "\<not>(isfree_addr loc ps')"
  using assms by simp

lemma kill_preserves_structure_1:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "isfree_addr loc ps'"
  using assms apply simp
  apply clarify
  by auto

lemma kill_preserves_structure_2:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "Unique_allocs ps"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "\<not>newran loc ps'"
  using assms apply simp
  apply clarify apply auto
  by (metis ComplD domI fstI insertCI option.sel ran_restrictD restrict_complement_singleton_eq)

(*-----------------penultimate--------------------*)

lemma testingthisone:
  "(loc,b)\<in>ran(A ps) \<Longrightarrow> (\<exists>prov. (prov\<in>dom(A ps) \<and> the(A ps prov) = (loc,b)))"
  by (smt (verit) domI mem_Collect_eq option.sel ran_def)

lemma allocation_preserves_structure:
  assumes "psem_rules ps"
  and "allocate_object ps loc prov ps' typ"
shows "constant_alloc_ass ps'"
  using assms apply simp
  apply clarify
  by (metis Domain_iff Domain_insert insertCI insertE option.exhaust_sel ran_map_upd)

lemma kill_preserves_structure:
  assumes "psem_rules ps"
  and "kill ps prov ps'"
shows " constant_alloc_ass ps'"
  using assms apply simp
  apply auto
  apply (metis domIff fun_upd_apply old.prod.inject option.collapse ranI testingthisone)
  apply (metis ranI ran_restrictD restrict_complement_singleton_eq)
  by (metis ComplD domI fst_eqD insertCI option.sel ran_restrictD restrict_complement_singleton_eq)

lemma allocation_preserves_uniqueness:
  assumes "psem_rules ps"
  and "allocate_object ps loc prov ps' typ"
shows "Unique_allocs ps'"
  using assms apply simp
  apply clarify apply safe
  apply (metis fst_conv option.sel ranI)
  by (metis fst_conv option.sel ranI)

lemma kill_preserves_uniqueness:
  assumes "psem_rules ps"
  and "kill ps prov ps'"
shows "Unique_allocs ps'"
  using assms by simp

(*-----------------summary--------------------*)

lemma psem_rules_preserved_alloc:
"psem_rules ps \<Longrightarrow> allocate_object ps loc prov ps' typ \<Longrightarrow> psem_rules ps'"
  unfolding psem_rules_def apply(intro conjI impI)
  using allocation_preserves_uniqueness psem_rules_def apply blast
  using allocation_preserves_structure psem_rules_def by blast

lemma psem_rules_preserved_kill:
"psem_rules ps \<Longrightarrow>  kill ps i ps' \<Longrightarrow> psem_rules ps'"
  unfolding psem_rules_def apply(intro conjI impI)
  using kill_preserves_uniqueness psem_rules_def apply blast
  using kill_preserves_structure psem_rules_def by blast

end