theory Ugraphs
imports
  Girth_Chromatic_Misc
begin

section \<open>Undirected Simple Graphs\<close>

text \<open>
  In this section, we define some basics of graph theory needed to formalize
  the Chromatic-Girth theorem.
\<close>

text \<open>
  For readability, we introduce synonyms for the types of vertexes, edges,
  graphs and walks.
\<close>
type_synonym uvert = nat
type_synonym uedge = "nat set"
type_synonym ugraph = "uvert set \<times> uedge set"
type_synonym uwalk = "uvert list"

abbreviation uedges :: "ugraph \<Rightarrow> uedge set" where
  "uedges G \<equiv> snd G"

abbreviation uverts :: "ugraph \<Rightarrow> uvert set" where
  "uverts G \<equiv> fst G"

fun mk_uedge :: "uvert \<times> uvert \<Rightarrow> uedge" where
   "mk_uedge (u,v) = {u,v}"

text \<open>All edges over a set of vertexes @{term S}:\<close>
definition "all_edges S \<equiv> mk_uedge ` {uv \<in> S \<times> S. fst uv \<noteq> snd uv}"

definition uwellformed :: "ugraph \<Rightarrow> bool" where
  "uwellformed G \<equiv> (\<forall>e\<in>uedges G. card e = 2 \<and> (\<forall>u \<in> e. u \<in> uverts G))"

fun uwalk_edges :: "uwalk \<Rightarrow> uedge list" where
    "uwalk_edges [] = []"
  | "uwalk_edges [x] = []"
  | "uwalk_edges (x # y # ys) = {x,y} # uwalk_edges (y # ys)"

definition uwalk_length :: "uwalk \<Rightarrow> nat" where
  "uwalk_length p \<equiv> length (uwalk_edges p)"

definition uwalks :: "ugraph \<Rightarrow> uwalk set" where
  "uwalks G \<equiv> {p. set p \<subseteq> uverts G \<and> set (uwalk_edges p) \<subseteq> uedges G \<and> p \<noteq> []}"

definition ucycles :: "ugraph \<Rightarrow> uwalk set" where
  "ucycles G \<equiv> {p. uwalk_length p \<ge> 3 \<and> p \<in> uwalks G \<and> distinct (tl p) \<and> hd p = last p}"

definition remove_vertex :: "ugraph \<Rightarrow> nat \<Rightarrow> ugraph" ("_ -- _" [60,60] 60) where
  "remove_vertex G u \<equiv> (uverts G - {u}, uedges G - {A \<in> uedges G. u \<in> A})"

subsection \<open>Basic Properties\<close>

lemma uwalk_length_conv: "uwalk_length p = length p - 1"
  by (induct p rule: uwalk_edges.induct) (auto simp: uwalk_length_def)

lemma all_edges_mono:
  "vs \<subseteq> ws \<Longrightarrow> all_edges vs \<subseteq> all_edges ws"
unfolding all_edges_def by auto

lemma all_edges_subset_Pow: "all_edges A \<subseteq> Pow A"
  by (auto simp: all_edges_def)

lemma in_mk_uedge_img: "(a,b) \<in> A \<or> (b,a) \<in> A \<Longrightarrow> {a,b} \<in> mk_uedge ` A"
  by (auto intro: rev_image_eqI)

lemma distinct_edgesI:
  assumes "distinct p" shows "distinct (uwalk_edges p)"
proof -
  from assms have "?thesis" "\<And>u. u \<notin> set p \<Longrightarrow> (\<And>v. u \<noteq> v \<Longrightarrow> {u,v} \<notin> set (uwalk_edges p))"
    by (induct p rule: uwalk_edges.induct) auto
  then show ?thesis by simp
qed

lemma finite_ucycles:
  assumes "finite (uverts G)"
  shows "finite (ucycles G)"
proof -
  have "ucycles G \<subseteq> {xs. set xs \<subseteq> uverts G \<and> length xs \<le> Suc (card (uverts G))}"
  proof (rule, simp)
    fix p assume "p \<in> ucycles G"
    then have "distinct (tl p)" and "set p \<subseteq> uverts G"
      unfolding ucycles_def uwalks_def by auto
    moreover
    then have "set (tl p) \<subseteq> uverts G"
      by (auto simp: list_set_tl)
    with assms have "card (set (tl p)) \<le> card (uverts G)"
      by (rule card_mono)
    then have "length (p) \<le> 1 + card (uverts G)"
      using distinct_card[OF \<open>distinct (tl p)\<close>] by auto
    ultimately show "set p \<subseteq> uverts G \<and> length p \<le> Suc (card (uverts G))" by auto
  qed
  moreover
  have "finite {xs. set xs \<subseteq> uverts G \<and> length xs \<le> Suc (card (uverts G))}"
    using assms by (rule finite_lists_length_le)
  ultimately
  show ?thesis by (rule finite_subset)
qed

lemma ucycles_distinct_edges:
  assumes "c \<in> ucycles G" shows "distinct (uwalk_edges c)"
proof -
  from assms have c_props: "distinct (tl c)" "4 \<le> length c" "hd c = last c"
    by (auto simp add: ucycles_def uwalk_length_conv)
  then have "{hd c, hd (tl c)} \<notin> set (uwalk_edges (tl c))"
  proof (induct c rule: uwalk_edges.induct)
    case (3 x y ys)
    then have "hd ys \<noteq> last ys" by (cases ys) auto
    moreover
    from 3 have "uwalk_edges (y # ys) = {y, hd ys} # uwalk_edges ys"
      by (cases ys) auto
    moreover
    { fix xs have "set (uwalk_edges xs) \<subseteq> Pow (set xs)"
        by (induct xs rule: uwalk_edges.induct) auto }
    ultimately
    show ?case using 3 by auto
  qed simp_all
  moreover
  from assms have "distinct (uwalk_edges (tl c))"
    by (intro distinct_edgesI) (simp add: ucycles_def)
  ultimately
  show ?thesis by (cases c rule: list_exhaust3) auto
qed

lemma card_left_less_pair:
  fixes A :: "('a :: linorder) set"
  assumes "finite A"
  shows "card {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}
    = (card A * (card A - 1)) div 2"
using assms
proof (induct A)
  case (insert x A)

  show ?case
  proof (cases "card A")
    case (Suc n)
    have "{(a,b). a \<in> insert x A \<and> b \<in> insert x A \<and> a < b}
        = {(a,b). a \<in> A \<and> b \<in> A \<and> a < b} \<union> (\<lambda>a. if a < x then (a,x) else (x,a)) ` A"
      using \<open>x \<notin> A\<close> by (auto simp: order_less_le)
    moreover
    have "finite {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}"
      using insert by (auto intro: finite_subset[of _ "A \<times> A"])
    moreover
    have "{(a,b). a \<in> A \<and> b \<in> A \<and> a < b} \<inter> (\<lambda>a. if a < x then (a,x) else (x,a)) ` A = {}"
      using \<open>x \<notin> A\<close> by auto
    moreover have "inj_on (\<lambda>a. if a < x then (a, x) else (x, a)) A"
      by (auto intro: inj_onI split: if_split_asm)
    ultimately show ?thesis using insert Suc
      by (simp add: card_Un_disjoint card_image del: if_image_distrib)
  qed (simp add: card_eq_0_iff insert)
qed simp

lemma card_all_edges:
  assumes "finite A"
  shows "card (all_edges A) = card A choose 2"
proof -
  have inj_on_mk_uedge: "inj_on mk_uedge {(a,b). a < b}"
    by (rule inj_onI) (auto simp: doubleton_eq_iff)
  have "all_edges A = mk_uedge ` {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}" (is "?L = ?R")
    by (auto simp: all_edges_def intro!: in_mk_uedge_img)
  then have "card ?L = card ?R" by simp
  also have "\<dots> = card {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}"
    using inj_on_mk_uedge by (blast intro: card_image subset_inj_on)
  also have "\<dots> = (card A * (card A - 1)) div 2"
    using card_left_less_pair using assms by simp
  also have "\<dots> = (card A choose 2)"
    by (simp add: n_choose_2_nat)
  finally show ?thesis .
qed

lemma verts_Gu: "uverts (G -- u) = uverts G - {u}"
  unfolding remove_vertex_def by simp

lemma edges_Gu: "uedges (G -- u) \<subseteq> uedges G"
  unfolding remove_vertex_def by auto

subsection \<open>Girth, Independence and Vertex Colorings\<close>

definition girth :: "ugraph \<Rightarrow> enat" where
  "girth G \<equiv> INF p\<in> ucycles G. enat (uwalk_length p)"

definition independent_sets :: "ugraph \<Rightarrow> uvert set set" where
  "independent_sets Gr \<equiv> {vs. vs \<subseteq> uverts Gr \<and> all_edges vs \<inter> uedges Gr = {}}"

definition \<alpha> :: "ugraph \<Rightarrow> enat" where
   "\<alpha> G \<equiv> SUP vs \<in> independent_sets G. enat (card vs)"

definition vertex_colorings :: "ugraph \<Rightarrow> uvert set set set" where
  "vertex_colorings G \<equiv> {C. \<Union>C = uverts G \<and> (\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<and>
    (\<forall>c\<in>C. c \<noteq> {} \<and> (\<forall>u \<in> c. \<forall>v \<in> c. {u,v} \<notin> uedges G))}"

text \<open>The chromatic number $\chi$:\<close>
definition chromatic_number :: "ugraph \<Rightarrow> enat" where
  "chromatic_number G \<equiv> INF c\<in> (vertex_colorings G). enat (card c)"

lemma independent_sets_mono:
  "vs \<in> independent_sets G \<Longrightarrow> us \<subseteq> vs \<Longrightarrow> us \<in> independent_sets G"
  using Int_mono[OF all_edges_mono, of us vs "uedges G" "uedges G"]
  unfolding independent_sets_def by auto

lemma le_\<alpha>_iff:
  assumes "0 < k"
  shows "k \<le> \<alpha> Gr \<longleftrightarrow> k \<in> card ` independent_sets Gr" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then obtain vs where "vs \<in> independent_sets Gr" and "k \<le> card vs"
    using assms unfolding \<alpha>_def enat_le_Sup_iff by auto
  moreover
  then obtain us where "us \<subseteq> vs" and "k = card us"
    using card_Ex_subset by auto
  ultimately
  have "us \<in> independent_sets Gr"  by (auto intro: independent_sets_mono)
  then show ?R using \<open>k = card us\<close> by auto
qed (auto intro: SUP_upper simp: \<alpha>_def)

lemma zero_less_\<alpha>:
  assumes "uverts G \<noteq> {}"
  shows "0 < \<alpha> G"
proof -
  from assms obtain a where "a \<in> uverts G" by auto
  then have "0 < enat (card {a})" "{a} \<in> independent_sets G"
    by (auto simp: independent_sets_def all_edges_def)
  then show ?thesis unfolding \<alpha>_def less_SUP_iff ..
qed

lemma \<alpha>_le_card:
  assumes "finite (uverts G)"
  shows "\<alpha> G \<le> card(uverts G)"
proof -
  { fix x assume "x \<in> independent_sets G"
    then have "x \<subseteq> uverts G" by (auto simp: independent_sets_def) }
  with assms show ?thesis unfolding \<alpha>_def
    by (intro SUP_least) (auto intro: card_mono)
qed

lemma \<alpha>_fin: "finite (uverts G) \<Longrightarrow> \<alpha> G \<noteq> \<infinity>"
  using \<alpha>_le_card[of G] by (cases "\<alpha> G") auto

lemma \<alpha>_remove_le:
  shows "\<alpha> (G -- u) \<le> \<alpha> G"
proof -
  have "independent_sets (G -- u) \<subseteq> independent_sets G" (is "?L \<subseteq> ?R")
    using all_edges_subset_Pow by (simp add: independent_sets_def remove_vertex_def) blast
  then show ?thesis unfolding \<alpha>_def
    by (rule SUP_subset_mono) simp
qed

text \<open>
  A lower bound for the chromatic number of a graph can be given in terms of
  the independence number
\<close>
lemma chromatic_lb:
  assumes wf_G: "uwellformed G"
    and fin_G: "finite (uverts G)"
    and neG: "uverts G \<noteq> {}"
  shows "card (uverts G) / \<alpha> G \<le> chromatic_number G"
proof -
  from wf_G have "(\<lambda>v. {v}) ` uverts G \<in> vertex_colorings G"
    by (auto simp: vertex_colorings_def uwellformed_def)
  then have "chromatic_number G \<noteq> top"
    by (simp add: chromatic_number_def) (auto simp: top_enat_def)
  then obtain vc where vc_vc: "vc \<in> vertex_colorings G"
    and vc_size:"chromatic_number G = card vc"
    unfolding chromatic_number_def by (rule enat_in_INF)

  have fin_vc_elems: "\<And>c. c \<in> vc \<Longrightarrow> finite c"
    using vc_vc by (intro finite_subset[OF _ fin_G]) (auto simp: vertex_colorings_def)

  have sum_vc_card: "(\<Sum>c \<in> vc. card c) = card (uverts G)"
      using fin_vc_elems vc_vc unfolding vertex_colorings_def
      by (simp add: card_Union_disjoint[symmetric] pairwise_def disjnt_def)

  have "\<And>c. c \<in> vc \<Longrightarrow> c \<in> independent_sets G"
    using vc_vc by (auto simp: vertex_colorings_def independent_sets_def all_edges_def)
  then have "\<And>c. c \<in> vc \<Longrightarrow> card c \<le> \<alpha> G"
    using vc_vc fin_vc_elems by (subst le_\<alpha>_iff) (auto simp add: vertex_colorings_def)
  then have "(\<Sum>c\<in>vc. card c) \<le> card vc * \<alpha> G"
    using sum_bounded_above[of vc card "\<alpha> G"]
    by (simp add: of_nat_eq_enat[symmetric] of_nat_sum)
  then have "ereal_of_enat (card (uverts G)) \<le> ereal_of_enat (\<alpha> G) * ereal_of_enat (card vc)"
    by (simp add: sum_vc_card ereal_of_enat_pushout ac_simps del: ereal_of_enat_simps)
  with zero_less_\<alpha>[OF neG] \<alpha>_fin[OF fin_G] vc_size show ?thesis
    by (simp add: ereal_divide_le_pos)
qed

end


section \<open> Derived SI-Units\<close>

theory SI_Derived
  imports SI_Prefix
begin

subsection \<open> Definitions \<close>

abbreviation "newton \<equiv> kilogram \<^bold>\<cdot> metre \<^bold>\<cdot> second\<^sup>-\<^sup>\<two>"

type_synonym 'a newton = "'a[M \<cdot> L \<cdot> T\<^sup>-\<^sup>2, SI]"

abbreviation "pascal \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>-\<^sup>\<one> \<^bold>\<cdot> second\<^sup>-\<^sup>\<two>"

type_synonym 'a pascal = "'a[M \<cdot> L\<^sup>-\<^sup>1 \<cdot> T\<^sup>-\<^sup>2, SI]"

abbreviation "volt \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<three> \<^bold>\<cdot> ampere\<^sup>-\<^sup>\<one>"

type_synonym 'a volt = "'a[M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>3 \<cdot> I\<^sup>-\<^sup>1, SI]"

abbreviation "farad \<equiv> kilogram\<^sup>-\<^sup>\<one> \<^bold>\<cdot> metre\<^sup>-\<^sup>\<two> \<^bold>\<cdot> second\<^sup>\<four> \<^bold>\<cdot> ampere\<^sup>\<two>"

type_synonym 'a farad = "'a[M\<^sup>-\<^sup>1 \<cdot> L\<^sup>-\<^sup>2 \<cdot> T\<^sup>4 \<cdot> I\<^sup>2, SI]"

abbreviation "ohm \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<three> \<^bold>\<cdot> ampere\<^sup>-\<^sup>\<two>"

type_synonym 'a ohm = "'a[M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>3 \<cdot> I\<^sup>-\<^sup>2, SI]"

abbreviation "siemens \<equiv> kilogram\<^sup>-\<^sup>\<one> \<^bold>\<cdot> metre\<^sup>-\<^sup>\<two> \<^bold>\<cdot> second\<^sup>\<three> \<^bold>\<cdot> ampere\<^sup>\<two>"

abbreviation "weber \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<two> \<^bold>\<cdot> ampere\<^sup>-\<^sup>\<one>"

abbreviation "tesla \<equiv> kilogram \<^bold>\<cdot> second\<^sup>-\<^sup>\<two> \<^bold>\<cdot> ampere\<^sup>-\<^sup>\<one>"

abbreviation "henry \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<two> \<^bold>\<cdot> ampere\<^sup>-\<^sup>\<two>"

abbreviation "lux \<equiv> candela \<^bold>\<cdot> steradian \<^bold>\<cdot> metre\<^sup>-\<^sup>\<two>"

abbreviation (input) "becquerel \<equiv> second\<^sup>-\<^sup>\<one>"

abbreviation "gray \<equiv> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<two>"

abbreviation "sievert \<equiv> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<two>"

abbreviation "katal \<equiv> mole \<^bold>\<cdot> second\<^sup>-\<^sup>\<one>"

definition degrees_celcius :: "'a::field_char_0 \<Rightarrow> 'a[\<Theta>]" ("_\<degree>C" [999] 999)
  where [si_eq]: "degrees_celcius x = (x *\<^sub>Q kelvin) + approx_ice_point"

definition [si_eq]: "gram = milli *\<^sub>Q kilogram"

subsection \<open> Equivalences \<close>

lemma joule_alt_def: "joule \<cong>\<^sub>Q newton \<^bold>\<cdot> metre"
  by si_calc

lemma watt_alt_def: "watt \<cong>\<^sub>Q joule \<^bold>/ second"
  by si_calc

lemma volt_alt_def: "volt = watt \<^bold>/ ampere"
  by simp

lemma farad_alt_def: "farad \<cong>\<^sub>Q coulomb \<^bold>/ volt"
  by si_calc

lemma siemens_alt_def: "siemens \<cong>\<^sub>Q ampere \<^bold>/ volt"
  by si_calc

lemma weber_alt_def: "weber \<cong>\<^sub>Q volt \<^bold>\<cdot> second"
  by si_calc

lemma tesla_alt_def: "tesla \<cong>\<^sub>Q weber \<^bold>/ metre\<^sup>\<two>"
  by si_calc

lemma henry_alt_def: "henry \<cong>\<^sub>Q weber \<^bold>/ ampere"
  by si_calc

lemma lux_alt_def: "lux = lumen \<^bold>/ metre\<^sup>\<two>"
  by simp

lemma gray_alt_def: "gray \<cong>\<^sub>Q joule \<^bold>/ kilogram"
  by si_calc

lemma sievert_alt_def: "sievert \<cong>\<^sub>Q joule \<^bold>/ kilogram"
  by si_calc

subsection \<open> Properties \<close>

lemma kilogram: "kilo *\<^sub>Q gram = kilogram"
  by (si_simp)

lemma celcius_to_kelvin: "T\<degree>C = (T *\<^sub>Q kelvin) + (273.15 *\<^sub>Q kelvin)"
  by (si_simp)

end


theory CFG
imports Main
begin

typedecl symbol

type_synonym rule = "symbol \<times> symbol list"

type_synonym sentence = "symbol list"

locale CFG =
  fixes \<NN> :: "symbol set"
  fixes \<TT> :: "symbol set"
  fixes \<RR> :: "rule set"
  fixes \<SS> :: "symbol"
  assumes disjunct_symbols: "\<NN> \<inter> \<TT> = {}"
  assumes startsymbol_dom: "\<SS> \<in> \<NN>"
  assumes validRules: "\<forall> (N, \<alpha>) \<in> \<RR>. N \<in> \<NN> \<and> (\<forall> s \<in> set \<alpha>. s \<in> \<NN> \<union> \<TT>)"
begin

definition is_terminal :: "symbol \<Rightarrow> bool"
where
  "is_terminal s = (s \<in> \<TT>)"

definition is_nonterminal :: "symbol \<Rightarrow> bool"
where
  "is_nonterminal s = (s \<in> \<NN>)"

lemma is_nonterminal_startsymbol:"is_nonterminal \<SS>"
  by (simp add: is_nonterminal_def startsymbol_dom)

definition is_symbol :: "symbol \<Rightarrow> bool"
where
  "is_symbol s = (is_terminal s \<or> is_nonterminal s)"

definition is_sentence :: "sentence \<Rightarrow> bool"
where
  "is_sentence s = list_all is_symbol s"

definition is_word :: "sentence \<Rightarrow> bool"
where
  "is_word s = list_all is_terminal s"

definition derives1 :: "sentence \<Rightarrow> sentence \<Rightarrow> bool"
where
  "derives1 u v =
     (\<exists> x y N \<alpha>.
          u = x @ [N] @ y
        \<and> v = x @ \<alpha> @ y
        \<and> is_sentence x
        \<and> is_sentence y
        \<and> (N, \<alpha>) \<in> \<RR>)"

definition derivations1 :: "(sentence \<times> sentence) set"
where
  "derivations1 = { (u,v) | u v. derives1 u v }"

definition derivations :: "(sentence \<times> sentence) set"
where
  "derivations = derivations1^*"

definition derives :: "sentence \<Rightarrow> sentence \<Rightarrow> bool"
where
  "derives u v = ((u, v) \<in> derivations)"

definition is_derivation :: "sentence \<Rightarrow> bool"
where
  "is_derivation u = derives [\<SS>] u"

definition \<L> :: "sentence set"
where
  "\<L> = { v | v. is_word v \<and> is_derivation v}"

definition "\<L>\<^sub>P"  :: "sentence set"
where
  "\<L>\<^sub>P = { u | u v. is_word u \<and> is_derivation (u@v) }"

end

end


theory Event_Priority
imports
  "Main"
begin

text \<open> This theory defines a partial order type. \<close>

abbreviation less :: "('e \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> 'e \<Rightarrow> 'e \<Rightarrow> bool" where
"less f a b == f a b \<and> \<not>(f b a)"

text \<open> Here less is used to satisfy the axiom less_le_not_le of preorders. \<close>

typedef 'e partialorder = "{x :: 'e \<Rightarrow> 'e \<Rightarrow> bool. class.order x (less x)}"
  morphisms porder2f f2porder
  apply (simp add:class.order_def class.preorder_def class.order_axioms_def)
  apply (rule exI[where x="(=)"])
  by simp

text \<open> Thus @{type partialorder} is the type of all partial orders over the
       given type. \<close>

thm porder2f_induct
thm f2porder_inverse

definition my_le :: "'a partialorder \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where "my_le P = (porder2f P)"
definition my_lt :: "'a partialorder \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where "my_lt P = (less (my_le P))"

lemma porder2f_ref: "porder2f p x x"
  apply (induct p)
  apply (simp add:f2porder_inverse)
  by (simp add:class.order_def class.preorder_def class.order_axioms_def)

interpretation partialorder: order "my_le p" "my_lt p"
  apply (unfold_locales)
     apply (auto simp add:my_le_def my_lt_def)
    apply (induct p, simp add:f2porder_inverse)
    apply (simp add:class.order_def class.preorder_def class.order_axioms_def)
   apply (induct p, simp add:f2porder_inverse)
   apply (simp add:class.order_def class.order_axioms_def)
   apply (auto simp only:class.preorder_def)
  apply (induct p, simp add:f2porder_inverse)
  by (simp add:class.order_def class.order_axioms_def)

text \<open> We define the following notation so that the operator \<le> and < can be parametrised
       with a specific partial order. \<close>

syntax
  "_porder_le"    :: "'a \<Rightarrow> 'a partialorder \<Rightarrow> 'a \<Rightarrow> bool" ("(_/ \<le>\<^sup>*_ _)" [51, 51] 50)
  "_porder_lt"    :: "'a \<Rightarrow> 'a partialorder  \<Rightarrow> 'a \<Rightarrow> bool" ("(_/ <\<^sup>*_ _)" [51, 51] 50)

translations
  "x \<le>\<^sup>*p y" == "CONST my_le p x y"
  "x <\<^sup>*p y" == "CONST my_lt p x y"

definition maximal :: "'a partialorder \<Rightarrow> 'a \<Rightarrow> bool" ("maximal'(_,_')" 65) where
"maximal(p,a) = (\<forall>x. (\<not> (a \<le>\<^sup>*p x) \<or> x \<le>\<^sup>*p a))"

lemma some_higher_not_maximal:
  assumes "z <\<^sup>*p b"
  shows "\<not>maximal(p,z)"
  using assms unfolding maximal_def apply auto
  by (meson partialorder.less_le_not_le)

lemma maximal_iff:
  "maximal(p,z) = (\<not>(\<exists>x. z <\<^sup>*p x))"
  unfolding maximal_def apply auto
  by (meson partialorder.less_le_not_le)+

lemma tau_max: "(\<forall>x. (x \<le>\<^sup>*(p) \<tau>)) \<Longrightarrow> \<not>(\<exists>x. (\<tau> <\<^sup>*(p) x))"
  apply auto
  by (simp add: partialorder.less_le_not_le)

lemma tau_max_imp_any_le_imp_le_tau:
  assumes "(\<forall>x. (x \<le>\<^sup>*(p) \<tau>))" "a <\<^sup>*p b"
  shows "a <\<^sup>*(p) \<tau>"
  using assms
  by (metis my_lt_def partialorder.order.not_eq_order_implies_strict)

end


theory Isar_Induction_Demo
imports Main
begin

section "Case distinction and induction"

subsection "Case distinction"

text \<open>Explicit:\<close>

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []" thus ?thesis by simp
next
  fix y ys assume "xs = y#ys"
  thus ?thesis by simp
qed

text \<open>Implicit:\<close>

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  case Nil
thm Nil
  thus ?thesis by simp
next
  case (Cons y ys)
thm Cons
  thus ?thesis by simp
qed

subsection \<open>Structural induction for type @{typ nat}\<close>

text \<open>Explicit:\<close>

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

text \<open>In more detail:\<close>

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume IH: "?P n"
  have "\<Sum>{0..Suc n} = \<Sum>{0..n} + Suc n" by simp
  also have "\<dots> = n*(n+1) div 2 + Suc n" using IH by simp
  also have "\<dots> = (Suc n)*((Suc n)+1) div 2" by simp
  finally show "?P(Suc n)" .
qed

text \<open>Implicit:\<close>

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
proof (induction n)
  case 0
  show ?case by simp
next
  case (Suc n)
thm Suc
  thus ?case by simp
qed

text \<open>Induction with \<open>\<Longrightarrow>\<close>:\<close>

lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
thm Cons.IH (* Induction hypothesis *)
thm Cons.prems (* Premises of the step case *)
thm Cons
  from Cons.prems have "x = a \<or> x : set xs" by simp
  thus ?case
  proof
    assume "x = a"
    hence "a#xs = [] @ x # xs" by simp
    thus ?thesis by blast
  next
    assume "x : set xs"
    then obtain ys zs where "xs = ys @ x # zs" using Cons.IH by auto
    hence "a#xs = (a#ys) @ x # zs" by simp
    thus ?thesis by blast
  qed
qed

subsection "Computation induction"

fun div2 :: "nat \<Rightarrow> nat" where
"div2 0 = 0" |
"div2 (Suc 0) = 0" |
"div2 (Suc(Suc n)) = div2 n + 1"

lemma "2 * div2 n \<le> n"
proof(induction n rule: div2.induct)
  case 1
  show ?case by simp
next
  case 2
  show ?case by simp
next
  case (3 n)
  have "2 * div2 (Suc(Suc n)) = 2 * div2 n + 2" by simp
  also have "\<dots> \<le> n + 2" using "3.IH" by simp
  also have "\<dots> = Suc(Suc n)" by simp
  finally show ?case .
qed

text \<open>Note that \<open>3.IH\<close> is not a valid name, it needs double quotes: \<open>"3.IH"\<close>.\<close>

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a (x # y # zs) = x # a # sep a (y # zs)" |
"sep a xs = xs"

thm sep.simps

lemma "map f (sep a xs) = sep (f a) (map f xs)"
proof (induction a xs rule: sep.induct)
  case (1 a x y zs)
  thus ?case by simp
next
  case ("2_1" a)
  show ?case by simp
next
  case ("2_2" a v)
  show ?case by simp
qed

subsection "Rule induction"

inductive ev :: "nat => bool" where
ev0:  "ev 0" |
evSS:  "ev n \<Longrightarrow> ev(Suc(Suc n))"

declare ev.intros [simp]

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case evSS thus ?case by arith
qed

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case (evSS m)
thm evSS
thm evSS.IH
thm evSS.hyps
  from evSS.IH obtain k where "m = 2*k" by blast
  hence "Suc(Suc m) = 2*(k+1)" by simp
  thus "\<exists>k. Suc(Suc m) = 2*k" by blast
qed

subsection "Inductive definition of the reflexive transitive closure"

consts step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>" 55)

inductive steps :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>*" 55) where
refl: "x \<rightarrow>* x" |
step: "\<lbrakk> x \<rightarrow> y; y \<rightarrow>* z \<rbrakk> \<Longrightarrow> x \<rightarrow>* z"

declare refl[simp, intro]

text "Explicit and by hand:"

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  fix x assume "x \<rightarrow>* z"
  thus "x \<rightarrow>* z" . (* by assumption *)
next
  fix x' x y :: 'a
  assume "x' \<rightarrow> x" and "x \<rightarrow>* y"
  assume IH: "y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
  assume "y \<rightarrow>* z"
  show "x' \<rightarrow>* z" by(rule step[OF `x' \<rightarrow> x` IH[OF `y\<rightarrow>*z`]])
qed

text \<open>Implicit and automatic:\<close>

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  case refl thus ?case .
next
  case (step x' x y)
  (* x' x y not used in proof text, just for demo *)
thm step
thm step.IH
thm step.hyps
thm step.prems
  show ?case
    by (metis step.hyps(1) step.IH step.prems steps.step)
qed

subsection "Rule inversion"

lemma assumes "ev n" shows "ev(n - 2)"
proof-
  from `ev n` show "ev(n - 2)"
  proof cases
    case ev0
thm ev0
    then show ?thesis by simp
  next
    case (evSS k)
thm evSS
    then show ?thesis by simp
  qed
qed

text \<open>Impossible cases are proved automatically:\<close>

lemma "\<not> ev(Suc 0)"
proof
  assume "ev(Suc 0)"
  then show False
  proof cases
  qed
qed

end


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

datatype 'a formula =
  is_Atom: Atom "'a"
  | is_Neg: Neg "'a formula"
  | is_Disj: Or "'a formula" "'a formula"
  | is_Conj: And "'a formula" "'a formula"

primrec sat :: "('a \<Rightarrow> bool) \<Rightarrow> 'a formula \<Rightarrow> bool"
  where "sat v (Atom p) = v p"
  | "sat v (Neg \<phi>) = (\<not> sat v \<phi>)"
  | "sat v (Or \<phi> \<psi>) = (sat v \<phi> \<or> sat v \<psi>)"
  | "sat v (And \<phi> \<psi>) = (sat v \<phi> \<and> sat v \<psi>)"

primrec subformula :: "'a formula \<Rightarrow> 'a formula \<Rightarrow> bool"
  where "subformula \<phi> (Atom p) = (\<phi> = Atom p)"
  | "subformula \<phi> (Neg \<psi>) = (\<phi> = Neg \<psi> \<or> subformula \<phi> \<psi>)"
  | "subformula \<phi> (Or \<psi> \<gamma>) = (\<phi> = Or \<psi> \<gamma> \<or> subformula \<phi> \<psi> \<or> subformula \<phi> \<gamma>)"
  | "subformula \<phi> (And \<psi> \<gamma>) = (\<phi> = And \<psi> \<gamma> \<or> subformula \<phi> \<psi> \<or> subformula \<phi> \<gamma>)"

bundle syntax_no_notation
begin

no_notation Atom ("@\<^sub>F_" [85] 85)
     and formula.Neg ("\<not>\<^sub>F _" [82] 82)
     and formula.And (infixr "\<and>\<^sub>F" 80)
     and formula.Or (infixr "\<or>\<^sub>F" 80)
     and sat ("_ \<Turnstile> _" [55, 55] 55)

end

bundle syntax_notation
begin

notation Atom ("@\<^sub>F_" [85] 85)
     and formula.Neg ("\<not>\<^sub>F _" [82] 82)
     and formula.And (infixr "\<and>\<^sub>F" 80)
     and formula.Or (infixr "\<or>\<^sub>F" 80)
     and sat ("_ \<Turnstile> _" [55, 55] 55)

end

unbundle syntax_notation

fun is_literal :: "'a formula \<Rightarrow> bool"
  where "is_literal (@\<^sub>F p) = True"
  | "is_literal (\<not>\<^sub>F (@\<^sub>F p)) = True"
  | "is_literal _ = False"

lemma is_literal_iff: "is_literal \<phi> \<longleftrightarrow> (\<exists>p. \<phi> = @\<^sub>F p \<or> \<phi> = \<not>\<^sub>F @\<^sub>F p)"
  by (cases \<phi> rule: is_literal.cases, simp_all)

lemma is_literal_NegD: "is_literal (\<not>\<^sub>F \<phi>) \<Longrightarrow> \<exists>p. \<phi> = @\<^sub>F p"
  by (clarsimp simp: is_literal_iff)

primrec is_clause :: "'a formula \<Rightarrow> bool"
  where "is_clause (@\<^sub>F p) = True"
  | "is_clause (\<not>\<^sub>F \<phi>) = is_literal (\<not>\<^sub>F \<phi>)"
  | "is_clause (\<phi> \<or>\<^sub>F \<psi>) = (is_clause \<phi> \<and> is_clause \<psi>)"
  | "is_clause (\<phi> \<and>\<^sub>F \<psi>) = False"

lemma is_clause_iff_rec:
  "is_clause \<phi> \<longleftrightarrow> (is_literal \<phi> \<or> (\<exists>\<psi> \<gamma>. is_clause \<psi> \<and> is_clause \<gamma> \<and> \<phi> = \<psi> \<or>\<^sub>F \<gamma>))"
  by (induct \<phi>, simp_all)

fun is_CNF :: "'a formula \<Rightarrow> bool"
  where "is_CNF (@\<^sub>F p) = True"
  | "is_CNF (\<not>\<^sub>F (@\<^sub>F p)) = True"
  | "is_CNF (\<not>\<^sub>F \<phi>) = False"
  | "is_CNF (\<phi> \<or>\<^sub>F \<psi>) = (is_clause \<phi> \<and> is_clause \<psi>)"
  | "is_CNF (\<phi> \<and>\<^sub>F \<psi>) = (is_CNF \<phi> \<and> is_CNF \<psi>)"

lemma is_CNF_iff_rec:
  "is_CNF \<phi> \<longleftrightarrow> (is_clause \<phi> \<or> (\<exists>\<psi> \<gamma>. is_CNF \<psi> \<and> is_CNF \<gamma> \<and> \<phi> = \<psi> \<and>\<^sub>F \<gamma>))"
  by (induct \<phi> rule: is_CNF.induct, simp_all)

lemmas is_CNFD = iffD1[OF is_CNF_iff_rec]
  and is_CNFI = iffD2[OF is_CNF_iff_rec]

lemma clause_is_CNF: "is_clause \<phi> \<Longrightarrow> is_CNF \<phi>"
  by (induct \<phi> rule: is_CNF.induct, auto)

lemma is_CNF_NegD: "is_CNF (\<not>\<^sub>F \<phi>) \<Longrightarrow> \<exists>p. \<phi> = @\<^sub>F p"
  by (cases \<phi> rule: is_CNF.cases, simp_all)

fun push_neg :: "'a formula \<Rightarrow> 'a formula"
  where "push_neg (@\<^sub>F p) = @\<^sub>F p"
  | "push_neg (\<not>\<^sub>F (@\<^sub>F p)) = \<not>\<^sub>F (@\<^sub>F p)"
  | "push_neg (\<not>\<^sub>F (\<not>\<^sub>F \<phi>)) = push_neg \<phi>"
  | "push_neg (\<not>\<^sub>F (\<phi> \<or>\<^sub>F \<psi>)) = (push_neg (\<not>\<^sub>F \<phi>)) \<and>\<^sub>F (push_neg (\<not>\<^sub>F \<psi>))"
  | "push_neg (\<not>\<^sub>F (\<phi> \<and>\<^sub>F \<psi>)) = (push_neg (\<not>\<^sub>F \<phi>)) \<or>\<^sub>F (push_neg (\<not>\<^sub>F \<psi>))"
  | "push_neg (\<phi> \<or>\<^sub>F \<psi>) = (push_neg \<phi>) \<or>\<^sub>F (push_neg \<psi>)"
  | "push_neg (\<phi> \<and>\<^sub>F \<psi>) = (push_neg \<phi>) \<and>\<^sub>F (push_neg \<psi>)"

lemma sat_push_neg_iff: "v \<Turnstile> push_neg \<phi> \<longleftrightarrow> v \<Turnstile> \<phi>"
  by (induct \<phi> rule: push_neg.induct, simp_all)

lemma NNF_push_neg:
  "subformula \<psi> (push_neg \<phi>) \<Longrightarrow> is_Neg \<psi> \<Longrightarrow> is_literal \<psi>"
  by (induct \<phi> rule: push_neg.induct)
    (auto simp add: is_literal_iff)

fun distrib_law :: "'a formula \<Rightarrow> 'a formula \<Rightarrow> 'a formula"
  where "distrib_law \<phi> \<psi> =
    (case \<phi> of
      \<phi>\<^sub>1 \<and>\<^sub>F \<phi>\<^sub>2 \<Rightarrow> (distrib_law \<phi>\<^sub>1 \<psi>) \<and>\<^sub>F (distrib_law \<phi>\<^sub>2 \<psi>)
      | _ \<Rightarrow> (case \<psi> of
          \<psi>\<^sub>1 \<and>\<^sub>F \<psi>\<^sub>2 \<Rightarrow> (distrib_law \<phi> \<psi>\<^sub>1) \<and>\<^sub>F (distrib_law \<phi> \<psi>\<^sub>2)
          | _ \<Rightarrow> \<phi> \<or>\<^sub>F \<psi>))"

lemma distrib_law__clauses:
  assumes "is_clause \<phi>"
    and "is_clause \<psi>"
  shows "is_clause (distrib_law \<phi> \<psi>)"
  using assms
  by - (induct \<phi>; induct \<psi>; force simp add: is_literal_iff)

lemma distrib_law_CNF_clause:
  assumes "is_CNF \<phi>"
    and "is_clause \<psi>"
  shows "is_CNF (distrib_law \<phi> \<psi>)"
    and "is_CNF (distrib_law \<psi> \<phi>)"
  using assms
  by - (induct \<phi>; induct \<psi>; force simp add: is_literal_iff dest: is_CNF_NegD)+

lemma is_CNF_distrib_law:
  assumes "is_CNF \<phi>"
    and "is_CNF \<psi>"
  shows "is_CNF (distrib_law \<phi> \<psi>)"
  using assms
  by (induct \<phi>; induct \<psi>; clarsimp simp add: is_literal_iff dest!: is_CNF_NegD)
    (metis distrib_law.simps distrib_law_CNF_clause(2))

lemma sat_distrib_law1:
  "is_clause \<phi> \<Longrightarrow> is_clause \<psi> \<Longrightarrow> v \<Turnstile> distrib_law \<phi> \<psi> \<longleftrightarrow> v \<Turnstile> \<phi> \<or>\<^sub>F \<psi>"
  by (induct \<phi>; induct \<psi>; clarsimp)

lemma sat_distrib_law2:
  "is_clause \<phi> \<Longrightarrow> is_CNF \<psi> \<Longrightarrow> \<psi> = \<psi>\<^sub>1 \<and>\<^sub>F \<psi>\<^sub>2 \<Longrightarrow> v \<Turnstile> distrib_law \<phi> \<psi> \<longleftrightarrow> v \<Turnstile> (\<phi> \<or>\<^sub>F \<psi>\<^sub>1) \<and>\<^sub>F (\<phi> \<or>\<^sub>F \<psi>\<^sub>2)"
  apply (induct \<phi>; induct \<psi> arbitrary: \<psi>\<^sub>1 \<psi>\<^sub>2; clarsimp simp: is_literal_iff)
  oops

fun to_CNF :: "'a formula \<Rightarrow> 'a formula"
  where "to_CNF (\<phi> \<and>\<^sub>F \<psi>) = to_CNF \<phi> \<and>\<^sub>F to_CNF \<psi>"
  | "to_CNF (\<phi> \<or>\<^sub>F \<psi>) = distrib_law (to_CNF \<phi>) (to_CNF \<psi>)"
  | "to_CNF \<phi> = \<phi>"

lemma "is_CNF (to_CNF (push_neg \<phi>))"
  by (induct \<phi> rule: push_neg.induct)
    (simp_all add: is_CNF_distrib_law
      del: distrib_law.simps)

value "is_CNF (\<not>\<^sub>F ((@\<^sub>Fp \<and>\<^sub>F @\<^sub>Fq) \<and>\<^sub>F \<not>\<^sub>F @\<^sub>Fr))"

value "to_CNF (push_neg (\<not>\<^sub>F ((@\<^sub>Fp \<and>\<^sub>F @\<^sub>Fq) \<and>\<^sub>F \<not>\<^sub>F @\<^sub>Fr)))"

(*>*)
end
(*<*)


(*<*)

theory FOL
imports Main

begin

(*>*)

section {* Quantifier Rules in Action *}

text{* Here is one version of
       the first example proof from the lecture on predicate logic *}

lemma "(\<forall>x. P x) \<longrightarrow> (\<exists>y. P y)"
  apply (rule impI)
  apply (frule_tac x=a in spec)
  apply (rule_tac x=a in exI)
  by assumption

text {* This proof is rather unusual in that in the second step, it is
  sufficient to instantiate the universally quantified hypothesis with a new
  variable `a' which is unconstrained by any formulas in the sequent.

  More commonly we instantiate formulas with terms built with free
  variables already present in the sequent.  See the next couple of
  proofs. *}

text{* Here is the 2nd example proof from Lecture 5, with some
renaming of bound variables to make the formulas and proofs a little
clearer. This shows use of left and right forall introduction rules. *}

lemma "(\<forall>u. P u \<longrightarrow> Q u) \<and> (\<forall>v. P v) \<longrightarrow> (\<forall>w. Q w)"
  apply (rule impI)
  apply (erule conjE)
  apply (rule allI)
  apply (erule_tac x="w" in allE)
  apply (erule_tac x="w" in allE)
  apply (erule impE)
  by assumption+

text {* An example showing use of left and right exists introduction rules *}

lemma " (\<exists>z. P z) \<and> Q \<longrightarrow> (\<exists>y. P y \<and> Q)"
apply (rule impI)
apply (erule conjE)
apply (erule exE)
apply (rule_tac x="z" in exI)
apply (rule conjI)
apply assumption+
done

text {* Here's a variation on the classical exists right introduction
rule exCI in the Isabelle library.  The advantage of this one is that
it doesn't introduce meta-variables into the sequent. *}

lemma exCIF: "((\<forall>x. \<not>(P x)) \<Longrightarrow> False) \<Longrightarrow> \<exists>x. P x"
by auto

text {* An example of the use of exCIF *}

lemma "\<not>( \<not> P a \<and> \<not> P b) \<longrightarrow> (\<exists>z. P z)"
apply (rule impI)
apply (rule exCIF)
apply (erule notE)
apply (rule conjI)
apply (erule_tac x="a" in allE)
apply assumption
apply (erule_tac x="b" in allE)
apply assumption
done

section {* Cheaters are losers *}

lemma Cheaters:
  "\<lbrakk>(\<exists>x. cheats x) \<longrightarrow> (\<forall>x. loses x);
    (\<forall>x. cheats x \<longrightarrow> loses x) \<longrightarrow> loses me\<rbrakk> \<Longrightarrow> loses me"
apply (erule mp)      (* View mp rule as special left intro rule for implies*)
apply (rule allI)
apply (rule impI)     (* From here on, is little choice in next rules *)
apply (erule impE)
apply (rule_tac x="x" in exI)
apply assumption
apply (erule_tac x="x" in allE)
apply assumption
done

section {* Use of meta-variables in Isabelle goals *}

text{* Meta-variables (also called schematic-variables in the Isabelle
documentation) in goals can be considered to be existentially
quantified at the sequent level.  As a proof proceeds, the proof is
free to substitute in more specialised terms for the meta-variables.

Often, the unification that happens when rules are applied will find
the needed meta-variable instantiations.  This saves having to enter
instantiating terms explicitly.  However using meta-variables in goals
and instantiating them with unification can be rather confusing when
first starting out.  All the Isabelle exercises and coursework can be
accomplished without exploiting them.

Below are some examples of proofs involving meta-variables.
*}

text {* Example 1 again *}

lemma "(\<forall>x. P x) \<longrightarrow> (\<exists>y. P y)"
  apply (rule impI)
  apply (rule exI)
  apply (drule spec)
  apply assumption
done

text {* Example II again.  Here the meta-variables introduced are
actually functions taking as argument a variable universally
meta-quantified at the sequent level.  This indicates that any
instantiating term for the meta-variables can make use of the
universally quantified variable.  *}

lemma "(\<forall>x. P x \<longrightarrow> Q x) \<and> (\<forall>x. P x) \<longrightarrow> (\<forall>x. Q x)"
  apply (rule impI)
  apply (erule conjE)
  apply (rule allI)
  apply (erule allE)
  apply (erule allE)
  apply (erule mp)
  by assumption

text {* The example again of how existential quantification
distributes over conjunction.  Once you have stepped through the
proof, try doing it again with the order of the exE and exI rules
swapped.  Why does the proof fail? *}

lemma " (\<exists>z. P z) \<and> Q \<longrightarrow> (\<exists>y. P y \<and> Q)"
apply (rule impI)
apply (erule conjE)
apply (erule exE)
apply (rule exI)
apply (rule conjI)
apply assumption+
done

end


section \<open> Unrestriction \<close>

theory utp_unrest
  imports utp_expr_insts
begin

subsection \<open> Definitions and Core Syntax \<close>

text \<open> Unrestriction is an encoding of semantic freshness that allows us to reason about the
  presence of variables in predicates without being concerned with abstract syntax trees.
  An expression $p$ is unrestricted by lens $x$, written $x \mathop{\sharp} p$, if
  altering the value of $x$ has no effect on the valuation of $p$. This is a sufficient
  notion to prove many laws that would ordinarily rely on an \emph{fv} function.

  Unrestriction was first defined in the work of Marcel Oliveira~\cite{Oliveira2005-PHD,Oliveira07} in his
  UTP mechanisation in \emph{ProofPowerZ}. Our definition modifies his in that our variables
  are semantically characterised as lenses, and supported by the lens laws, rather than named
  syntactic entities. We effectively fuse the ideas from both Feliachi~\cite{Feliachi2010} and
  Oliveira's~\cite{Oliveira07} mechanisations of the UTP, the former being also purely semantic
  in nature.

  We first set up overloaded syntax for unrestriction, as several concepts will have this
  defined. \<close>

consts
  unrest :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

syntax
  "_unrest" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<sharp>" 20)

translations
  "_unrest x p" == "CONST unrest x p"
  "_unrest (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_unrest (x +\<^sub>L y) P"

text \<open> Our syntax translations support both variables and variable sets such that we can write down
  predicates like @{term "&x \<sharp> P"} and also @{term "{&x,&y,&z} \<sharp> P"}.

  We set up a simple tactic for discharging unrestriction conjectures using a simplification set. \<close>

named_theorems unrest
method unrest_tac = (simp add: unrest)?

text \<open> Unrestriction for expressions is defined as a lifted construct using the underlying lens
  operations. It states that lens $x$ is unrestricted by expression $e$ provided that, for any
  state-space binding $b$ and variable valuation $v$, the value which the expression evaluates
  to is unaltered if we set $x$ to $v$ in $b$. In other words, we cannot effect the behaviour
  of $e$ by changing $x$. Thus $e$ does not observe the portion of state-space characterised
  by $x$. We add this definition to our overloaded constant. \<close>

lift_definition unrest_uexpr :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> bool"
is "\<lambda> x e. \<forall> b v. e (put\<^bsub>x\<^esub> b v) = e b" .

adhoc_overloading
  unrest unrest_uexpr

lemma unrest_expr_alt_def:
  "weak_lens x \<Longrightarrow> (x \<sharp> P) = (\<forall> b b'. \<lbrakk>P\<rbrakk>\<^sub>e (b \<oplus>\<^sub>L b' on x) = \<lbrakk>P\<rbrakk>\<^sub>e b)"
  by (transfer, metis lens_override_def weak_lens.put_get)

subsection \<open> Unrestriction laws \<close>

text \<open> We now prove unrestriction laws for the key constructs of our expression model. Many
  of these depend on lens properties and so variously employ the assumptions @{term mwb_lens} and
  @{term vwb_lens}, depending on the number of assumptions from the lenses theory is required.

  Firstly, we prove a general property -- if $x$ and $y$ are both unrestricted in $P$, then their composition
  is also unrestricted in $P$. One can interpret the composition here as a union -- if the two sets
  of variables $x$ and $y$ are unrestricted, then so is their union. \<close>

lemma unrest_var_comp [unrest]:
  "\<lbrakk> x \<sharp> P; y \<sharp> P \<rbrakk> \<Longrightarrow> x;y \<sharp> P"
  by (transfer, simp add: lens_defs)

lemma unrest_svar [unrest]: "(&x \<sharp> P) \<longleftrightarrow> (x \<sharp> P)"
  by (transfer, simp add: lens_defs)

lemma unrest_lens_comp [unrest]: "x \<sharp> e \<Longrightarrow> x:y \<sharp> e"
  by (simp add: lens_comp_def unrest_uexpr.rep_eq)

text \<open> No lens is restricted by a literal, since it returns the same value for any state binding. \<close>

lemma unrest_lit [unrest]: "x \<sharp> \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

text \<open> If one lens is smaller than another, then any unrestriction on the larger lens implies
  unrestriction on the smaller. \<close>

lemma unrest_sublens:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<sharp> P" "y \<subseteq>\<^sub>L x"
  shows "y \<sharp> P"
  using assms
  by (transfer, metis (no_types, lifting) lens.select_convs(2) lens_comp_def sublens_def)

text \<open> If two lenses are equivalent, and thus they characterise the same state-space regions,
  then clearly unrestrictions over them are equivalent. \<close>

lemma unrest_equiv:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "mwb_lens y" "x \<approx>\<^sub>L y" "x \<sharp> P"
  shows "y \<sharp> P"
  by (metis assms lens_equiv_def sublens_pres_mwb sublens_put_put unrest_uexpr.rep_eq)

text \<open> If we can show that an expression is unrestricted on a bijective lens, then is unrestricted
  on the entire state-space. \<close>

lemma bij_lens_unrest_all:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "bij_lens X" "X \<sharp> P"
  shows "\<Sigma> \<sharp> P"
  using assms bij_lens_equiv_id lens_equiv_def unrest_sublens by blast

lemma bij_lens_unrest_all_eq:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "bij_lens X"
  shows "(\<Sigma> \<sharp> P) \<longleftrightarrow> (X \<sharp> P)"
  by (meson assms bij_lens_equiv_id lens_equiv_def unrest_sublens)

text \<open> If an expression is unrestricted by all variables, then it is unrestricted by any variable \<close>

lemma unrest_all_var:
  fixes e :: "('a, '\<alpha>) uexpr"
  assumes "\<Sigma> \<sharp> e"
  shows "x \<sharp> e"
  by (metis assms id_lens_def lens.simps(2) unrest_uexpr.rep_eq)

text \<open> We can split an unrestriction composed by lens plus \<close>

lemma unrest_plus_split:
  fixes P :: "('a, '\<alpha>) uexpr"
  assumes "x \<bowtie> y" "vwb_lens x" "vwb_lens y"
  shows "unrest (x +\<^sub>L y) P \<longleftrightarrow> (x \<sharp> P) \<and> (y \<sharp> P)"
  using assms
  by (meson lens_plus_right_sublens lens_plus_ub sublens_refl unrest_sublens unrest_var_comp vwb_lens_wb)

text \<open> The following laws demonstrate the primary motivation for lens independence: a variable
  expression is unrestricted by another variable only when the two variables are independent.
  Lens independence thus effectively allows us to semantically characterise when two variables,
  or sets of variables, are different. \<close>

lemma unrest_var [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> y \<sharp> var x"
  by (transfer, auto)

lemma unrest_iuvar [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y \<sharp> $x"
  by (simp add: unrest_var)

lemma unrest_ouvar [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y\<acute> \<sharp> $x\<acute>"
  by (simp add: unrest_var)

text \<open> The following laws follow automatically from independence of input and output variables. \<close>

lemma unrest_iuvar_ouvar [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "mwb_lens y"
  shows "$x \<sharp> $y\<acute>"
  by (metis prod.collapse unrest_uexpr.rep_eq var.rep_eq var_lookup_out var_update_in)

lemma unrest_ouvar_iuvar [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "mwb_lens y"
  shows "$x\<acute> \<sharp> $y"
  by (metis prod.collapse unrest_uexpr.rep_eq var.rep_eq var_lookup_in var_update_out)

text \<open> Unrestriction distributes through the various function lifting expression constructs;
  this allows us to prove unrestrictions for the majority of the expression language. \<close>

lemma unrest_appl [unrest]: "\<lbrakk> x \<sharp> f; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> f |> v"
  by (transfer, simp)

lemma unrest_uop [unrest]: "x \<sharp> e \<Longrightarrow> x \<sharp> uop f e"
  by (simp add: unrest)

lemma unrest_bop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> bop f u v"
  by (simp add: unrest)

lemma unrest_trop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w \<rbrakk> \<Longrightarrow> x \<sharp> trop f u v w"
  by (simp add: unrest)

lemma unrest_qtop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w; x \<sharp> y \<rbrakk> \<Longrightarrow> x \<sharp> qtop f u v w y"
  by (simp add: unrest)

text \<open> For convenience, we also prove unrestriction rules for the bespoke operators on equality,
  numbers, arithmetic etc. \<close>

lemma unrest_zero [unrest]: "x \<sharp> 0"
  by (simp add: unrest_lit zero_uexpr_def)

lemma unrest_one [unrest]: "x \<sharp> 1"
  by (simp add: one_uexpr_def unrest_lit)

lemma unrest_numeral [unrest]: "x \<sharp> (numeral n)"
  by (simp add: numeral_uexpr_simp unrest_lit)

lemma unrest_sgn [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> sgn u"
  by (simp add: sgn_uexpr_def unrest_uop)

lemma unrest_abs [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> abs u"
  by (simp add: abs_uexpr_def unrest_uop)

lemma unrest_plus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u + v"
  by (simp add: plus_uexpr_def unrest)

lemma unrest_uminus [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> - u"
  by (simp add: uminus_uexpr_def unrest)

lemma unrest_minus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u - v"
  by (simp add: minus_uexpr_def unrest)

lemma unrest_times [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u * v"
  by (simp add: times_uexpr_def unrest)

lemma unrest_divide [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u / v"
  by (simp add: divide_uexpr_def unrest)

lemma unrest_case_prod [unrest]: "\<lbrakk> \<And> i j. x \<sharp> P i j \<rbrakk> \<Longrightarrow> x \<sharp> case_prod P v"
  by (simp add: prod.split_sel_asm)

text \<open> For a $\lambda$-term we need to show that the characteristic function expression does
  not restrict $v$ for any input value $x$. \<close>

lemma unrest_ulam [unrest]:
  "\<lbrakk> \<And> x. v \<sharp> F x \<rbrakk> \<Longrightarrow> v \<sharp> (\<lambda>\<^sub>u x \<bullet> F x)"
  by (transfer, simp)

end


theory Chapter5
  imports Main
begin

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

text{*
\section*{Chapter 5}

\exercise
Give a readable, structured proof of the following lemma:
*}
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
proof -
  have "T x y \<or> T y x" using T by blast
  thus "T x y"
  proof
    assume "T x y"
    thus "T x y" by simp
  next
    assume "T y x"
    hence "A y x" using TA by blast
    hence "x = y" using assms(4) A by blast
    thus "T x y" using \<open>T y x\<close> by auto
  qed
qed

text{*
Each step should use at most one of the assumptions @{text T}, @{text A}
or @{text TA}.
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
*}
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  let ?len_ys = "length xs div 2"
  assume 1: "length xs mod 2 = 0"
  then obtain ys where 2: "ys = take ?len_ys xs" by blast
  then obtain zs where "zs = drop ?len_ys xs" by blast
  hence "xs = ys @ zs \<and> length ys = length zs"
    using 1 2
    by fastforce
  thus ?thesis by blast
next
  let ?len_ys = "length xs div 2 + 1"
  assume 1: "length xs mod 2 \<noteq> 0"
  then obtain ys where 2: "ys = take ?len_ys xs" by blast
  then obtain zs where "zs = drop ?len_ys xs" by blast
  hence "xs = ys @ zs \<and> length ys = length zs + 1"
    using 1 2
    by (smt (verit, ccfv_SIG) add.assoc add.commute add.right_neutral add_diff_cancel_right' add_self_div_2 append_take_drop_id div_add1_eq drop_drop length_append length_drop not_mod_2_eq_0_eq_1)
  thus ?thesis by blast
qed

lemma "length (tl xs) = length xs - 1"
proof (cases xs)
  case Nil
  thus ?thesis by simp
next
  case (Cons y ys)
  thus ?thesis by simp
qed

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
proof (induction n)
  case 0
  show "?case" by simp
next
  case (Suc n)
  thus "?case" by simp
qed

text{*
Hint: There are predefined functions @{const take} and {const drop} of type
@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\exercise
Give a structured proof by rule inversion:
*}
inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"

lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
proof -
  show ?thesis using a
  proof cases
    case evSS
    then show ?thesis by auto
  qed
qed

text{*
\exercise
Give a structured proof by rule inversions:
*}

lemma "\<not> ev(Suc(Suc(Suc 0)))" (is "\<not>?P")
proof
  assume "?P"
  hence "ev (Suc 0)" using ev.cases by auto
  thus "False" using ev.cases by auto
qed

text{*
If there are no cases to be proved you can close
a proof immediateley with \isacom{qed}.
\endexercise

\exercise
Recall predicate @{const star} from Section 4.5 and @{const iter}
from Exercise~\ref{exe:iter}.
*}

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_0: "iter r 0 x x" |
iter_Suc: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case (iter_0 x)
  thus ?case by (simp add: star.refl)
next
  case (iter_Suc x y n z)
  thus ?case by (simp add: star.step)
qed

text{*
Prove this lemma in a structured style, do not just sledgehammer each case of the
required induction.
\endexercise

\exercise
Define a recursive function
*}

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems [] = {}" |
"elems (x#xs) = {x} \<union> elems xs"

value "elems ([1,2,2,4,4,3,4]::(nat list))"

text{* that collects all elements of a list into a set. Prove *}

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
  proof cases
    assume "a = x"
    then obtain ys where ys: "(ys::'a list) = []" by auto
    then obtain zs where zs: "zs = xs" by auto
    then have "x \<notin> elems ys" using ys by auto
    thus ?case using \<open>a = x\<close> ys by blast
  next
    assume "a \<noteq> x"
    then have "x : elems xs" using Cons.prems by auto
    then obtain ys old_ys zs where
      "ys = a # old_ys"
      "xs = old_ys @ x # zs"
      "x \<notin> elems old_ys"
    using Cons.IH by blast
  then have "a # xs = ys @ x # zs \<and> x \<notin> elems ys" using `a \<noteq> x` by auto
  then show ?case by auto
  qed
qed

text{*
\endexercise

\exercise
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a recursive function *}
(* your definition/proof here *)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

text{* such that @{term"balanced n w"}
is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove *}

corollary "balanced n w \<longleftrightarrow> S (replicate n a @ w)"

text{* where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
*}

end