theory Extended_Graph_Theory
  imports
    Main
    Graph_Theory.Arc_Walk
begin

section "Additional theorems for the Graph Theory library"

text \<open>
  This section contains lemmas that are not directly related to GROOVE graphs but are
  relevant for directed graphs in Graph Theory. It is very similar to the 'Stuff' theory
  included with Graph Theory, but then with theorems that could be interesting for
  Graph Theory.
\<close>

inductive_set (in wf_digraph) awalks :: "'b awalk set"
  where
    rule_awalks: "\<And>u v p. awalk u p v \<Longrightarrow> p \<in> awalks"

inductive (in wf_digraph) awalk_altdef :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool"
  where
    rule_awalk_empty_walk: "\<And>u. u \<in> verts G \<Longrightarrow> awalk_altdef u [] u" |
    rule_awalk_first_edge: "\<And>a. a \<in> arcs G \<Longrightarrow> awalk_altdef (tail G a) [a] (head G a)" |
    rule_awalk_add_edge: "\<And>p ps a v. awalk_altdef (tail G p) (p # ps) v \<Longrightarrow> a \<in> arcs G \<Longrightarrow>
      head G a = tail G p \<Longrightarrow> awalk_altdef (tail G a) (a # p # ps) v"

lemma (in wf_digraph) awalk_altdef_correct:
  shows "\<And>u p v. awalk u p v = awalk_altdef u p v"
proof
  fix u p v
  assume awalk_valid: "awalk u p v"
  have "\<And>u v. awalk u p v \<Longrightarrow> awalk_altdef u p v"
  proof (induct p)
    case Nil
    then show ?case
      using wf_digraph.rule_awalk_empty_walk wf_digraph_axioms
      by fastforce
  next
    case (Cons p1 ps)
    then show ?case
    proof (induct ps)
      case Nil
      show ?case
        using Nil.prems(2) awalk_Cons_iff rule_awalk_first_edge
        by fastforce
    next
      case (Cons p2 ps)
      then have "awalk (tail G p2) (p2 # ps) v"
        by (simp add: awalk_Cons_iff)
      then show ?case
        using Cons.prems(1) Cons.prems(2) awalk_Cons_iff rule_awalk_add_edge
        by fastforce
    qed
  qed
  then show "awalk_altdef u p v"
    using awalk_valid
    by simp
next
  fix u p v
  assume "awalk_altdef u p v"
  then show "awalk u p v"
  proof (induct rule: awalk_altdef.induct)
    case (rule_awalk_empty_walk u)
    then show ?case
      by (simp add: awalk_Nil_iff)
  next
    case (rule_awalk_first_edge a)
    then show ?case
      by (fact arc_implies_awalk)
  next
    case (rule_awalk_add_edge p ps a v)
    then show ?case
      by (simp add: awalk_Cons_iff)
  qed
qed

inductive_set (in wf_digraph) apaths :: "'b awalk set"
  where
    rule_apaths: "\<And>u v p. apath u p v \<Longrightarrow> p \<in> apaths"

inductive (in wf_digraph) apath_altdef :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool"
  where
    rule_apath_empty_walk: "\<And>u. u \<in> verts G \<Longrightarrow> apath_altdef u [] u" |
    rule_apath_first_edge: "\<And>a. a \<in> arcs G \<Longrightarrow> tail G a \<noteq> head G a \<Longrightarrow> apath_altdef (tail G a) [a] (head G a)" |
    rule_apath_add_edge: "\<And>p ps a v. apath_altdef (tail G p) (p # ps) v \<Longrightarrow> a \<in> arcs G \<Longrightarrow>
      head G a = tail G p \<Longrightarrow> tail G a \<notin> set (awalk_verts (tail G p) (p # ps)) \<Longrightarrow> apath_altdef (tail G a) (a # p # ps) v"

lemma (in wf_digraph) apath_altdef_correct:
  shows "\<And>u p v. apath u p v = apath_altdef u p v"
proof
  fix u p v
  assume apath_valid: "apath u p v"
  have "\<And>u v. apath u p v \<Longrightarrow> apath_altdef u p v"
  proof (induct p)
    case Nil
    then show ?case
      using wf_digraph.rule_apath_empty_walk wf_digraph_axioms apath_Nil_iff
      by fastforce
  next
    case (Cons p1 ps)
    then show ?case
    proof (induct ps)
      case Nil
      then have "u \<noteq> v"
        using apath_nonempty_ends
        by blast
      then show ?case
        using Nil.prems(2) apath_Cons_iff apath_Nil_iff rule_apath_first_edge
        by fastforce
    next
      case (Cons p2 ps)
      then have "apath (tail G p2) (p2 # ps) v"
        using apath_Cons_iff
        by fastforce
      then show ?case
        using Cons.prems(1) Cons.prems(2) apath_Cons_iff rule_apath_add_edge
        by fastforce
    qed
  qed
  then show "apath_altdef u p v"
    using apath_valid
    by simp
next
  fix u p v
  assume "apath_altdef u p v"
  then show "apath u p v"
  proof (induct rule: apath_altdef.induct)
    case (rule_apath_empty_walk u)
    then show ?case
      by (simp add: apath_Nil_iff)
  next
    case (rule_apath_first_edge a)
    then show ?case
      by (simp add: apath_Cons_iff wf_digraph.apath_Nil_iff wf_digraph_axioms)
  next
    case (rule_apath_add_edge p ps a v)
    then show ?case
      by (simp add: apath_Cons_iff)
  qed
qed

lemma (in wf_digraph) all_apaths_are_awalks: "apaths \<subseteq> awalks"
proof
  fix x
  assume "x \<in> apaths"
  then show "x \<in> awalks"
  proof (induct x)
    case (rule_apaths u v p)
    then have "apath_altdef u p v"
      by (simp add: apath_altdef_correct)
    then show ?case
    proof (induct)
      case (rule_apath_empty_walk u)
      then show ?case
        using awalk_Nil_iff awalks.rule_awalks
        by simp
    next
      case (rule_apath_first_edge a)
      then show ?case
        using arc_implies_awalk awalks.rule_awalks
        by blast
    next
      case (rule_apath_add_edge p ps a v)
      then have "awalk_altdef (tail G a) (a # p # ps) v"
        using apath_altdef_correct awalkI_apath awalk_altdef_correct rule_awalk_add_edge
        by blast
      then show ?case
        using awalk_altdef_correct awalks.rule_awalks
        by simp
    qed
  qed
qed

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

lemma (in wf_digraph) edge_in_arc_to_tuple_is_edge:
  shows "\<And>x y. (x, y) \<in> arc_to_tuple ` arcs G \<Longrightarrow> \<exists>a. head G a = x \<and> tail G a = y \<and> a \<in> arcs G"
  using arc_to_tuple_def
  by auto

lemma (in wf_digraph) edge_in_arc_to_tuple_head_vertice:
  shows "\<And>x y. (x, y) \<in> (arc_to_tuple ` arcs G)\<^sup>+ \<Longrightarrow> x \<in> verts G"
proof-
  fix x y
  assume "(x, y) \<in> (arc_to_tuple ` arcs G)\<^sup>+"
  then show "x \<in> verts G"
  proof (induct)
    case (base a)
    then show ?case
      using edge_in_arc_to_tuple_is_edge head_in_verts
      by blast
  next
    case (step a b)
    then show ?case
      by blast
  qed
qed

lemma (in wf_digraph) edge_in_arc_to_tuple_tail_vertice:
  shows "\<And>x y. (x, y) \<in> (arc_to_tuple ` arcs G)\<^sup>+ \<Longrightarrow> y \<in> verts G"
proof-
  fix x y
  assume "(x, y) \<in> (arc_to_tuple ` arcs G)\<^sup>+"
  then show "y \<in> verts G"
  proof (induct)
    case (base a)
    then show ?case
      using edge_in_arc_to_tuple_is_edge tail_in_verts
      by blast
  next
    case (step a b)
    then show ?case
      using edge_in_arc_to_tuple_is_edge tail_in_verts
      by blast
  qed
qed

primrec awalk_subset :: "'b \<Rightarrow> 'b awalk \<Rightarrow> 'b awalk" where
  "awalk_subset q [] = []" |
  "awalk_subset q (e # es) = (if e = q then [e] else e # awalk_subset q es)"

lemma (in wf_digraph) non_distinct_awalk_impl_shorter_walk:
  shows "\<And>u v w. p \<noteq> [] \<Longrightarrow> apath u p v \<Longrightarrow> awalk v [q] w \<Longrightarrow> \<not>distinct (tl (awalk_verts u (q#p))) \<Longrightarrow> apath u (awalk_subset q p) w"
proof-
  fix u v w
  assume p_not_empty: "p \<noteq> []"
  assume apath_p: "apath u p v"
  then have apath_altdef: "apath_altdef u p v"
    by (simp add: apath_altdef_correct)
  have awalk_p: "awalk u p v"
    using apath_p
    unfolding apath_def
    by simp
  have distinct_awalk_p: "distinct (awalk_verts u p)"
    using apath_p
    unfolding apath_def
    by simp
  assume "awalk v [q] w"
  then have awalk_q: "awalk_altdef v [q] w"
    by (simp add: awalk_altdef_correct)
  assume non_distinct_awalk_qp: "\<not>distinct (tl (awalk_verts u (q#p)))"
  then have "q \<in> set p"
    using awalk_verts.simps(2) awalk_verts_ne_eq distinct_awalk_p list.sel(3) p_not_empty
    by metis
  show "apath u (awalk_subset q p) w"
    using awalk_verts.simps(2) awalk_verts_ne_eq distinct_awalk_p list.sel(3) non_distinct_awalk_qp p_not_empty
    by metis
qed

lemma (in wf_digraph) tail_distinct_awalk_impl_shorter_path:
  shows "\<And>u v. apath u p v \<Longrightarrow> apath v [q] u \<Longrightarrow> cycle (q # p)"
proof-
  fix u v
  assume apath_uv: "apath u p v"
  assume apath_vu: "apath v [q] u"
  show "cycle (q # p)"
    unfolding cycle_def
    using apath_def apath_uv apath_vu awalk_Cons_iff
    by auto
qed

lemma (in wf_digraph) awalk_impl_rtrancl:
  shows "\<And>u v. awalk u p v \<Longrightarrow> (v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>*"
proof (induct p)
  case Nil
  then show ?case
    by auto
next
  case (Cons a p)
  then have shorter_walk: "awalk (head G a) p v"
    by (simp add: awalk_Cons_iff)
  have "(head G a, u) \<in> (arc_to_tuple ` arcs G)\<^sup>*"
    using Cons.prems arc_to_tuple_def awalk_Cons_iff
    by auto
  then show ?case
    using Cons.hyps rtrancl_trans shorter_walk
    by metis
qed

lemma (in wf_digraph) no_rtrancl_impl_no_awalk:
  shows "\<And>u v. (v, u) \<notin> (arc_to_tuple ` arcs G)\<^sup>* \<Longrightarrow> \<not>awalk u p v"
  using awalk_impl_rtrancl
  by blast

lemma (in wf_digraph) rtrancl_impl_awalk:
  shows "\<And>u v. u \<in> verts G \<Longrightarrow> v \<in> verts G \<Longrightarrow> (v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>* \<Longrightarrow> \<exists>p. awalk u p v"
proof-
  fix u v
  assume u_in_verts: "u \<in> verts G"
  assume v_in_verts: "v \<in> verts G"
  assume "(v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>*"
  then have "\<exists>p. awalk_altdef u p v"
  proof (induct)
    case base
    then show ?case
      using rule_awalk_empty_walk v_in_verts
      by blast
  next
    case (step y z)
    then have "\<exists>p. awalk_altdef z p y"
      using arc_to_tuple_def rule_awalk_first_edge
      by fastforce
    then show ?case
      using step.hyps(3) awalk_altdef_correct reachable_awalk reachable_trans
      by metis
  qed
  then show "\<exists>p. awalk u p v"
    by (simp add: awalk_altdef_correct)
qed

lemma (in wf_digraph) no_awalk_impl_no_rtrancl:
  shows "\<And>u v. u \<in> verts G \<Longrightarrow> v \<in> verts G \<Longrightarrow> \<forall>p. \<not>awalk u p v \<Longrightarrow> (v, u) \<notin> (arc_to_tuple ` arcs G)\<^sup>*"
  using rtrancl_impl_awalk
  by blast

inductive_set (in wf_digraph) cycles :: "'b awalk set"
  where
    rule_cycles: "\<And>u p. awalk u p u \<Longrightarrow> p \<noteq> [] \<Longrightarrow> distinct (tl (awalk_verts u p)) \<Longrightarrow> p \<in> cycles"

lemma (in wf_digraph) all_cycles_are_awalks: "cycles \<subseteq> awalks"
proof
  fix x
  assume "x \<in> cycles"
  then show "x \<in> awalks"
    using awalks.rule_awalks cycles.cases
    by metis
qed

lemma (in wf_digraph) valid_cycle_in_cycles: "\<And>p. p \<in> cycles \<longleftrightarrow> cycle p"
proof
  fix p
  assume "p \<in> cycles"
  then show "cycle p"
  proof (induct)
    case (rule_cycles u p)
    then show ?case
      using pre_digraph.cycle_def
      by blast
  qed
next
  fix p
  assume "cycle p"
  then show "p \<in> cycles"
    using pre_digraph.cycle_def wf_digraph.cycles.simps wf_digraph_axioms
    by metis
qed

lemma (in wf_digraph) non_empty_awalk_impl_trancl:
  shows "\<And>u v. p \<noteq> [] \<Longrightarrow> awalk u p v \<Longrightarrow> (v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+"
proof (induct p)
  case Nil
  then show ?case
    by simp
next
  case (Cons a p)
  then have shorter_walk: "awalk (head G a) p v"
    by (simp add: awalk_Cons_iff)
  have "(head G a, u) \<in> (arc_to_tuple ` arcs G)\<^sup>*"
    using Cons.prems(2) arc_implies_awalk awalk_Cons_iff wf_digraph.awalk_impl_rtrancl wf_digraph_axioms
    by metis
  then show ?case
    using Cons.prems(2) awalk_Cons_iff no_rtrancl_impl_no_awalk pre_digraph.arc_to_tuple_def
    using rev_image_eqI rtrancl_eq_or_trancl trancl.r_into_trancl trancl_rtrancl_trancl
    by metis
qed

lemma (in wf_digraph) no_trancl_impl_no_non_empty_awalk:
  shows "\<And>u v. p \<noteq> [] \<Longrightarrow> (v, u) \<notin> (arc_to_tuple ` arcs G)\<^sup>+ \<Longrightarrow> \<not>awalk u p v"
  using non_empty_awalk_impl_trancl
  by blast

lemma (in wf_digraph) trancl_impl_awalk:
  shows "\<And>u v. (v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+ \<Longrightarrow> \<exists>p. awalk u p v"
proof-
  fix u v
  assume "(v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+"
  then have "\<exists>p. awalk_altdef u p v"
  proof (induct)
    case (base y)
    then show ?case
      using arc_to_tuple_def rule_awalk_first_edge
      by fastforce
  next
    case (step y z)
    then have "\<exists>p. p \<noteq> [] \<and> awalk_altdef z p y"
      using arc_to_tuple_def rule_awalk_first_edge
      by fastforce
    then have awalk_z_y: "\<exists>p. p \<noteq> [] \<and> awalk z p y"
      by (simp add: awalk_altdef_correct)
    have "\<exists>p. awalk y p v"
      using step.hyps(3)
      by (simp add: awalk_altdef_correct)
    then have "\<exists>p. awalk z p v"
      using awalk_z_y awalk_appendI
      by blast
    then show ?case
      by (simp add: awalk_altdef_correct)
  qed
  then show "\<exists>p. awalk u p v"
    by (simp add: awalk_altdef_correct)
qed

lemma (in wf_digraph) no_awalk_impl_no_trancl:
  shows "\<And>u v. \<forall>p. \<not>awalk u p v \<Longrightarrow> (v, u) \<notin> (arc_to_tuple ` arcs G)\<^sup>+"
  using trancl_impl_awalk
  by blast

lemma (in wf_digraph) irrefl_trancl_impl_apath:
  shows "\<And>u v. (v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+ \<Longrightarrow> irrefl ((arc_to_tuple ` arcs G)\<^sup>+) \<Longrightarrow> \<exists>p. apath u p v"
proof-
  fix u v
  assume irrefl_edges: "irrefl ((arc_to_tuple ` arcs G)\<^sup>+)"
  assume "(v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+"
  then have "\<exists>p. apath_altdef u p v"
    using irrefl_edges
  proof (induct)
    case (base y)
    then have "irrefl (arc_to_tuple ` arcs G)"
      unfolding irrefl_def
      by blast
    then have "v \<noteq> y"
      unfolding irrefl_def
      using base.hyps
      by blast
    then show ?case
      using base.hyps arc_to_tuple_def rule_apath_first_edge
      by fastforce
  next
    case (step y z)
    then have "irrefl (arc_to_tuple ` arcs G)"
      unfolding irrefl_def
      by blast
    then have "y \<noteq> z"
      unfolding irrefl_def
      using step.hyps
      by blast
    then have zy_apath: "\<exists>p. apath_altdef z p y"
      using step.hyps arc_to_tuple_def rule_apath_first_edge
      by fastforce
    have yv_apath: "\<exists>p. apath_altdef y p v"
      using step.hyps step.prems
      by blast
    then show ?case
      using zy_apath apath_altdef_correct reachable_apath reachable_trans
      by metis
  qed
  then show "\<exists>p. apath u p v"
    by (simp add: apath_altdef_correct)
qed

lemma (in wf_digraph) no_apath_impl_no_irrefl_trancl:
  shows "\<And>u v. (v, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+ \<Longrightarrow> \<forall>p. \<not>apath u p v \<Longrightarrow> \<not>irrefl ((arc_to_tuple ` arcs G)\<^sup>+)"
  using irrefl_trancl_impl_apath
  by blast

lemma (in wf_digraph) loop_edge_trancl_impl_cyclic_awalk: "(u, u) \<in> arc_to_tuple ` arcs G \<Longrightarrow> \<exists>p. p \<noteq> [] \<and> awalk u p u"
proof-
  fix u
  assume edge_def: "(u, u) \<in> arc_to_tuple ` arcs G"
  then have "u \<in> verts G"
  proof
    fix x
    assume "(u, u) = arc_to_tuple x"
    then have u_is_head_x: "u = head G x"
      using arc_to_tuple_def
      by simp
    assume x_in_arcs: "x \<in> arcs G"
    then have "head G x \<in> verts G"
      by simp
    then show "u \<in> verts G"
      by (simp add: u_is_head_x)
  qed
  have "\<exists>a. head G a = u \<and> tail G a = u \<and> awalk u [a] u"
    using edge_def arc_implies_awalk edge_in_arc_to_tuple_is_edge
    by metis
  then show "\<exists>p. p \<noteq> [] \<and> awalk u p u"
    by blast
qed

lemma (in wf_digraph) non_irrefl_trancl_impl_cyclic_awalk: "\<not>irrefl ((arc_to_tuple ` arcs G)\<^sup>+) \<Longrightarrow> \<exists>p v. p \<noteq> [] \<and> awalk v p v"
proof-
  assume "\<not>irrefl ((arc_to_tuple ` arcs G)\<^sup>+)"
  then have "\<exists>u. (u, u) \<in> (arc_to_tuple ` arcs G)\<^sup>+"
    using irrefl_def
    by blast
  then have "\<exists>u v. (u, u) \<in> arc_to_tuple ` arcs G \<or> (u, v) \<in> (arc_to_tuple ` arcs G)\<^sup>+ \<and> (v, u) \<in> arc_to_tuple ` arcs G"
    using tranclE
    by metis
  then show "\<exists>p v. p \<noteq> [] \<and> awalk v p v"
    using loop_edge_trancl_impl_cyclic_awalk reachable1_awalk reachable_awalkI reachable_neq_reachable1 reachable_reachable1_trans trancl.r_into_trancl trancl_impl_awalk
    by metis
qed

lemma (in wf_digraph) no_cyclic_awalk_impl_no_cycle: "(\<And>p v. \<not>awalk v p v) \<Longrightarrow> \<not>cycle p"
  unfolding cycle_def
  by simp

lemma (in wf_digraph) no_cycle_impl_no_cyclic_awalk: "(\<And>p. \<not>cycle p) \<Longrightarrow> p \<noteq> [] \<Longrightarrow> \<not>awalk v p v"
  unfolding cycle_def
proof-
  assume no_cycle_def: "\<And>p. \<nexists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> p \<noteq> []"
  then have "\<And>p u. \<not>awalk u p u \<or> \<not>distinct (tl (awalk_verts u p)) \<or> p = []"
    by simp
  assume "p \<noteq> []"
  then show "\<not>awalk v p v"
    using no_cycle_def awalk_cyc_decompE' closed_w_imp_cycle cycle_conv distinct_tl
    by metis
qed

lemma (in wf_digraph) no_cyclic_awalk_impl_irrefl_trancl: "(\<And>p v. p = [] \<or> \<not>awalk v p v) \<Longrightarrow> irrefl ((arc_to_tuple ` arcs G)\<^sup>+)"
  using non_irrefl_trancl_impl_cyclic_awalk
  by blast

lemma (in wf_digraph) acyclic_impl_irrefl_trancl: "(\<And>p. \<not>cycle p) \<Longrightarrow> irrefl ((arc_to_tuple ` arcs G)\<^sup>+)"
proof (intro no_cyclic_awalk_impl_irrefl_trancl)
  fix p v
  assume no_cycles: "\<And>p. \<not>cycle p"
  then show "p = [] \<or> \<not>awalk v p v"
    unfolding cycle_def
    using no_cycle_impl_no_cyclic_awalk no_cycles
    by blast
qed

lemma (in wf_digraph) irrefl_trancl_impl_acyclic:
  shows "\<And>p. irrefl ((arc_to_tuple ` arcs G)\<^sup>+) \<Longrightarrow> \<not>cycle p"
  unfolding cycle_def
  using irrefl_def non_empty_awalk_impl_trancl
  by metis

lemma (in wf_digraph) cycle_impl_not_irrefl_trancl:
  shows "cycle p \<Longrightarrow> \<not>irrefl ((arc_to_tuple ` arcs G)\<^sup>+)"
  using irrefl_trancl_impl_acyclic
  by blast

end


(*  Title:      A state based hotel key card system

    Author:     Tobias Nipkow, TU Muenchen
*)

(*<*)
theory State
imports Basis
begin

declare split_if_asm[split]
(*>*)

section{*A state based model*}

text{* The model is based on three opaque types @{typ guest},
@{typ key} and @{typ room}. Type @{typ card} is just an abbreviation
for @{typ"key \<times> key"}.

The state of the system is modelled as a record which combines the
information about the front desk, the rooms and the guests.
*}

record state =
 owns :: "room \<Rightarrow> guest option"
 currk :: "room \<Rightarrow> key"
 issued :: "key set"
 cards :: "guest \<Rightarrow> card set"
 roomk :: "room \<Rightarrow> key"
 isin :: "room \<Rightarrow> guest set"
 safe :: "room \<Rightarrow> bool"

text{*\noindent Reception records who @{const owns} a room (if anybody, hence
@{typ"guest option"}), the current key @{const currk} that has been
issued for a room, and which keys have been @{const issued} so
far. Each guest has a set of @{const cards}. Each room has a key
@{const roomk} recorded in the lock and a set @{const isin} of
occupants. The auxiliary variable @{const safe} is explained further
below; we ignore it for now.

In specification languages like Z, VDM and B we would now define a
number of operations on this state space. Since they are the only
permissible operations on the state, this defines a set of
\emph{reachable} states. In a purely logical environment like
Isabelle/HOL this set can be defined directly by an inductive
definition. Each clause of the definition corresponds to a
transition/operation/event. This is the standard approach to modelling
state machines in theorem provers.

The set of reachable states of the system (called @{text reach}) is
defined by four transitions: initialization, checking in, entering a room,
and leaving a room: *}

(*<*)
inductive_set reach :: "state set"
where
(*>*)
init:
"inj initk \<Longrightarrow>
\<lparr> owns = (\<lambda>r. None), currk = initk, issued = range initk,
  cards = (\<lambda>g. {}), roomk = initk, isin = (\<lambda>r. {}),
  safe = (\<lambda>r. True) \<rparr> \<in> reach"

| check_in:
"\<lbrakk> s \<in> reach; k \<notin> issued s \<rbrakk> \<Longrightarrow>
s\<lparr> currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g),
   safe := (safe s)(r := False) \<rparr> \<in> reach"

| enter_room:
"\<lbrakk> s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'} \<rbrakk> \<Longrightarrow>
s\<lparr> isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = \<lfloor>g\<rfloor> \<and> isin s r = {} \<and> k' = currk s r
                              \<or> safe s r)
  \<rparr> \<in> reach"

| exit_room:
"\<lbrakk> s \<in> reach;  g \<in> isin s r \<rbrakk> \<Longrightarrow>
s\<lparr> isin := (isin s)(r := isin s r - {g}) \<rparr> \<in> reach"

text{*\bigskip There is no check-out event because it is implicit in the next
check-in for that room: this covers the cases where a guest leaves without checking out (in which case the room should not be blocked forever) or where
the hotel decides to rent out a room prematurely, probably by accident.
Neither do guests have to return their cards at any point because they may
loose cards or may pretended to have lost them.
We will now explain the events.
\begin{description}
\item[@{text init}]
Initialization requires that every room has a different key, i.e.\
that @{const currk} is injective. Nobody
owns a room, the keys of all rooms are recorded as issued, nobody has
a card, and all rooms are empty.
\item[@{thm[source] enter_room}]
A guest may enter if either of the two keys on his card equal the room key.
Then @{text g} is added to the occupants of @{text r} and
the room key is set to the second key on the card.
Normally this has no effect because the second key is already the room key.
But when entering for the first time, the first key on the card equals
the room key and then the lock is actually recoded.
\item[@{text exit_room}]
removes an occupant from the occupants of a room.
\item[@{text check_in}] for room @{text r} and guest @{text g}
issues the card @{term"(currk s r, k)"}
to @{text g}, where @{text k} is new, makes @{text g} the owner of the room,
and sets @{term"currk s r"} to the new key @{text k}.
\end{description}

The reader can easily check that our specification allows the intended
distributed implementation: entering only reads and writes the key in
that lock, and check-in only reads and writes the information at
reception.

In contrast to Jackson we require that initially distinct rooms have
distinct keys. This protects the hotel from its guests: otherwise a
guest may be able to enter rooms he does not own, potentially stealing
objects from those rooms. Of course he can also steal objects from his
own room, but in that case it is easier to hold him responsible. In
general, the hotel may just want to minimize the opportunity for
theft.

The main difference to Jackson's model is that his can talk about
transitions between states rather than merely about reachable
states. This means that he can specify that unauthorized entry into a
room should not occur. Because our specification does not formalize
the transition relation itself, we need to include the @{text isin}
component in order to
express the same requirement. In the end, we would like to establish
that the system is \emph{safe}: only the owner of a room can be in a
room:
\begin{center}
@{prop"s \<in> reach \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"}
\end{center}
Unfortunately, this is just not true. It does not take a PhD in
computer science to come up with the following scenario: because
guests can retain their cards, there is nothing to stop a guest from
reentering his old room after he has checked out (in our model: after
the next guest has checked in), but before the next guest has entered
his room. Hence the best we can do is to prove a conditional safety
property: under certain conditions, the above safety property
holds. The question is: which conditions? It is clear that the room
must be empty when its owner enters it, or all bets
are off. But is that sufficient? Unfortunately not. Jackson's Alloy tool
took 2 seconds~\cite[p.~303]{Jackson06}
to find the following ``guest-in-the-middle'' attack:

\begin{enumerate}

\item Guest 1 checks in and obtains a card $(k_1,k_2)$ for room 1 (whose key
in the lock is $k_1$). Guest 1 does not enter room 1.

\item Guest 2 checks in, obtains a card $(k_2,k_3)$ for room 1, but
does not enter room 1 either.

\item Guest 1 checks in again, obtains a card $(k_3,k_4)$, goes to
room 1, opens it with his old card $(k_1,k_2)$, finds the room empty,
and feels safe \ldots

\end{enumerate}
After Guest~1 has left his room, Guest~2 enters and makes off with the
luggage.

Jackson now assumes that guests return their cards upon
check-out, which can be modelled as follows: upon check-in, the new card
is not added to the guest's set of cards but it replaces his previous
set of cards, i.e.\ guests return old cards the next time they check
in.  Under this assumption, Alloy finds no more counterexamples to
safety --- at least not up to 6 cards and keys and 3 guests and
rooms. This is not a proof but a strong indication that the given
assumptions suffice for safety. We prove that this is indeed the case.

It should be noted that the system also suffers from a liveness
problem: if a guest never enters the room he checked in to, that room
is forever blocked. In practice this is dealt with by a master key. We
ignore liveness.

\subsection{Formalizing safety}
\label{sec:formalizing-safety}

It should be clear that one cannot force guests to always return their
cards (or, equivalently, never to use an old card). We can only prove that if
they do, their room is safe. However, we do not follow Jackson's
approach of globally assuming everybody returns their old cards upon
check-in. Instead we would like to take a local approach where it is up
to each guest whether he follows this safety policy. We allow
guests to keep their cards but make safety dependent on how they use
them.  This generality requires a finer grained model: we need to
record if a guest has entered his room in a safe manner,
i.e.\ if it was empty and if he used the latest key for the room, the
one stored at reception.
The auxiliary variable @{const safe} records for each room if this
was the case at some point between his last check-in and now.
The main theorem will be that if a room is safe in this
manner, then only the owner can be in the room.
Now we explain how @{const safe} is modified with each event:

\begin{description}
\item[@{text init}] sets @{const safe} to @{const True} for every room.
\item[@{text check_in}] for room @{text r} resets @{prop"safe s r"}
because it is not safe for the new owner yet.
\item[@{thm[source] enter_room}] for room @{text r} sets @{prop"safe s r"} if
the owner entered an empty room using the latest card issued for that room
by reception, or if the room was already safe.
\item[@{text exit_room}] does not modify @{const safe}.
\end{description}

The reader should convince his or herself that @{const safe}
corresponds to the informal safety policy set out above.  Note that a
guest may find his room non-empty the first time he enters, and
@{const safe} will not be set, but he may come back later, find the
room empty, and then @{const safe} will be set. Furthermore, it is
important that @{thm[source] enter_room} cannot reset @{const safe}
due to the disjunct @{text"\<or> safe s r"}.  Hence @{text check_in} is
the only event that can reset @{const safe}.  That is, a room stays
safe until the next @{text check_in}.  Additionally @{const safe} is
initially @{const True}, which is fine because initially injectivity
of @{text initk} prohibits illegal entries by non-owners.

Note that because none of the other state components depend on @{const
safe}, it is truly auxiliary: it can be deleted from the system and
the same set of reachable states is obtained, modulo the absence of
@{const safe}.

We have formalized a very general safety policy of always using the
latest card. A special case of this policy is the one called
\emph{NoIntervening} by Jackson~\cite[p.~200]{Jackson06}: every @{text
check_in} must immediately be followed by the corresponding @{thm[source]
enter_room}.
*}

(*<*)
lemma currk_issued[simp]: "s : reach \<Longrightarrow> currk s r : issued s"
by (induct set: reach) auto

lemma key1_issued[simp]: "s : reach \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k : issued s"
by (induct set: reach) auto

lemma key2_issued[simp]: "s : reach \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k' : issued s"
by (induct set: reach) auto

lemma roomk_issued[simp]: "s : reach \<Longrightarrow> roomk s k : issued s"
by (induct set: reach) auto

lemma currk_inj[simp]:
 "s : reach \<Longrightarrow> \<forall>r r'. (currk s r = currk s r') = (r = r')"
by (induct set: reach) (auto simp:inj_on_def)

lemma key1_not_currk[simp]:
 "s : reach \<Longrightarrow> (currk s r,k') \<notin> cards s g"
by (induct set: reach) auto

lemma guest_key2_disj[simp]:
 "\<lbrakk> s : reach; (k\<^sub>1,k) \<in> cards s g\<^sub>1; (k\<^sub>2,k) \<in> cards s g\<^sub>2 \<rbrakk> \<Longrightarrow> g\<^sub>1=g\<^sub>2"
by (induct set: reach) auto

lemma safe_roomk_currk[simp]:
 "s : reach \<Longrightarrow> safe s r \<Longrightarrow> roomk s r = currk s r"
by (induct set: reach) auto

lemma safe_only_owner_enter_normal_aux[simp]:
 "\<lbrakk> s : reach; safe s r; (k',roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g"
by (induct set: reach) (auto)

lemma safe_only_owner_enter_normal:
assumes "s : reach"
shows "\<lbrakk> safe s r; (k',roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g"
using assms
proof induct
  case (enter_room s k k1 g1 r1)
  let ?s' = "s\<lparr>isin := (isin s)(r1 := isin s r1 \<union> {g1}),
               roomk := (roomk s)(r1 := k1),
               safe := (safe s)
                 (r1 :=
                    owns s r1 = Some g1 \<and> isin s r1 = {} \<and> k1 = currk s r1 \<or>
                    safe s r1)\<rparr>"
  note s = `s \<in> reach`
  and IH = `\<lbrakk> safe s r; (k', roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g`
  and card_g1 = `(k,k1) \<in> cards s g1` and safe = `safe ?s' r`
  and card_g = `(k',roomk ?s' r) \<in> cards ?s' g`
  have "roomk s r1 = k \<or> roomk s r1 = k1" using `roomk s r1 \<in> {k,k1}` by simp
  thus ?case
  proof
    assume [symmetric,simp]: "roomk s r1 = k"
    show ?thesis
    proof (cases "r1 = r")
      assume "r1 \<noteq> r" with IH safe card_g show ?thesis by simp
    next
      assume [simp]: "r1 = r"
      hence safe': "owns s r = Some g1 \<or> safe s r"
        using safe by auto
      thus ?thesis
      proof
        assume "safe s r"
        with s card_g1 have False by simp
        thus ?thesis ..
      next
        assume [simp]: "owns s r = Some g1"
        thus "owns ?s' r = Some g"
          using s card_g card_g1 by simp
      qed
    qed
  next
    assume "roomk s r1 = k1"
    with enter_room show ?case by auto
  qed
qed auto

theorem "s : reach \<Longrightarrow> safe s r \<Longrightarrow> g : isin s r \<Longrightarrow> owns s r = Some g"
by (induct set: reach) auto

theorem safe: assumes "s : reach"
shows "safe s r \<Longrightarrow> g : isin s r \<Longrightarrow> owns s r = Some g"
using assms
proof induct
  case (enter_room s k1 k2 g1 r1)
  let ?s' = "s\<lparr>isin := (isin s)(r1 := isin s r1 \<union> {g1}),
               roomk := (roomk s)(r1 := k2),
               safe := (safe s)
                 (r1 :=
                    owns s r1 = Some g1 \<and> isin s r1 = {} \<and> k2 = currk s r1 \<or>
                    safe s r1)\<rparr>"
  note s = `s \<in> reach`
  and IH = `\<lbrakk> safe s r; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g`
  and card_g1 = `(k1,k2) \<in> cards s g1` and safe = `safe ?s' r`
  and isin = `g \<in> isin ?s' r`
  show ?case
    proof (cases "r1 = r")
      assume "r1 \<noteq> r" with IH isin safe show ?thesis by simp
    next
      assume [simp]: "r1 = r"
      have "g \<in> isin s r \<or> g = g1" using isin by auto
      thus ?thesis
      proof
        assume g: "g \<in> isin s r"
        then have "safe s r" using safe by auto
        with g show ?thesis using IH by simp
      next
        assume [simp]: "g = g1"
        have "k2 = roomk s r1 \<or> k1 = roomk s r1"
          using `roomk s r1 \<in> {k1,k2}` by auto
        thus ?thesis
        proof
          assume "k2 = roomk s r1"
          with card_g1 s safe show ?thesis
            by auto
      next
        assume [simp]: "k1 = roomk s r1"
        have "owns s r = Some g1 \<or> safe s r" using safe by auto
        thus ?thesis
        proof
          assume "owns s r = Some g1" thus ?thesis by simp
        next
          assume "safe s r"
          hence False using s card_g1 by auto
          thus ?thesis ..
        qed
      qed
    qed
  qed
qed auto
(*>*)

text{*

\subsection{Verifying safety}
\label{sec:verisafe}

All of our lemmas are invariants of @{const reach}.
The complete list, culminating in the main theorem, is this:
\begin{lemma}\label{state-lemmas}
\begin{enumerate}
\item @{thm currk_issued}
\item @{thm key1_issued}
\item @{thm key2_issued}
\item @{thm roomk_issued}
\item \label{currk_inj} @{thm currk_inj}
\item \label{key1_not_currk} @{thm key1_not_currk}
\item @{thm guest_key2_disj}
\item \label{safe_roomk_currk} @{thm[display] safe_roomk_currk}
\item \label{safe_only_owner_enter_normal} @{thm safe_only_owner_enter_normal}
\end{enumerate}
\end{lemma}
\begin{theorem}\label{safe-state}
@{thm[mode=IfThen] safe}
\end{theorem}
The lemmas and the theorem are proved in this order, each one is marked as a
simplification rule, and each proof is a one-liner: induction on
@{prop"s \<in> reach"} followed by @{text auto}.

Although, or maybe even because these proofs work so smoothly one may
like to understand why. Hence we examine the proof of
Theorem~\ref{safe-state} in more detail. The only interesting case is
@{thm[source] enter_room}. We assume that guest @{text g\<^sub>1} enters room
@{text r\<^sub>1} with card @{term"(k\<^sub>1,k\<^sub>2)"} and call the new state @{text t}.
We assume @{prop"safe t r"} and @{prop"g \<in> isin t r"} and prove
@{prop"owns t r = \<lfloor>g\<rfloor>"} by case distinction.
If @{prop"r\<^sub>1 \<noteq> r"}, the claim follows directly from the induction hypothesis
using \mbox{@{prop"safe s r"}} and @{prop"g \<in> isin t r"}
because @{prop"owns t r = owns s r"} and @{prop"safe t r = safe s r"}.
If @{prop"r\<^sub>1 = r"} then @{prop"g \<in> isin t r"} is equivalent with
@{prop"g \<in> isin s r \<or> g = g\<^sub>1"}. If @{prop"g \<in> isin s r"} then
\mbox{@{prop"safe s r"}} follows from @{prop"safe t r"} by
definition of @{thm[source]enter_room} because @{prop"g \<in> isin s r"}
implies @{prop"isin s r \<noteq> {}"}. Hence the induction hypothesis implies the
claim.  If @{prop"g = g\<^sub>1"} we make another case distinction.
If @{prop"k\<^sub>2 = roomk s r"}, the claim follows immediately from
Lemma~\ref{state-lemmas}.\ref{safe_only_owner_enter_normal} above:
only the owner of a room can possess a card where the second
key is the room key.
If @{prop"k\<^sub>1 = roomk s r"} then, by definition of @{thm[source]enter_room},
@{prop"safe t r"} implies @{prop"owns s r = \<lfloor>g\<rfloor> \<or> safe s r"}.
In the first case the claim is immediate. If @{prop"safe s r"}
then @{prop"roomk s r = currk s r"}
(by Lemma~\ref{state-lemmas}.\ref{safe_roomk_currk})
and thus @{prop"(currk s r, k\<^sub>2) \<in> cards s g"} by assumption
@{prop"(k\<^sub>1,k\<^sub>2) \<in> cards s g\<^sub>1"}, thus contradicting
Lemma~\ref{state-lemmas}.\ref{key1_not_currk}.

This detailed proof shows that a number of case distinctions are
required. Luckily, they all suggest themselves to Isabelle via the
definition of function update (@{text":="}) or via disjunctions that
arise automatically.
*}

(*<*)
end
(*>*)


(* Author: Dmitriy Traytel *)

section \<open>Normalization of WS1S Formulas\<close>

(*<*)
theory WS1S_Normalization
imports WS1S
begin
(*>*)

fun nNot where
  "nNot (FNot \<phi>) = \<phi>"
| "nNot (FAnd \<phi>1 \<phi>2) = FOr (nNot \<phi>1) (nNot \<phi>2)"
| "nNot (FOr \<phi>1 \<phi>2) = FAnd (nNot \<phi>1) (nNot \<phi>2)"
| "nNot \<phi> = FNot \<phi>"

primrec norm where
  "norm (FQ a m) = FQ a m"
| "norm (FLess m n) = FLess m n"
| "norm (FIn m M) = FIn m M"
| "norm (FOr \<phi> \<psi>) = FOr (norm \<phi>) (norm \<psi>)"
| "norm (FAnd \<phi> \<psi>) = FAnd (norm \<phi>) (norm \<psi>)"
| "norm (FNot \<phi>) = nNot (norm \<phi>)"
| "norm (FExists \<phi>) = FExists (norm \<phi>)"
| "norm (FEXISTS \<phi>) = FEXISTS (norm \<phi>)"

context formula
begin

lemma satisfies_nNot[simp]: "(w, I) \<Turnstile> nNot \<phi> \<longleftrightarrow> (w, I) \<Turnstile> FNot \<phi>"
  by (induct \<phi> rule: nNot.induct) auto

lemma FOV_nNot[simp]: "FOV (nNot \<phi>) = FOV (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma SOV_nNot[simp]: "SOV (nNot \<phi>) = SOV (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma pre_wf_formula_nNot[simp]: "pre_wf_formula n (nNot \<phi>) = pre_wf_formula n (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma FOV_norm[simp]: "FOV (norm \<phi>) = FOV \<phi>"
  by (induct \<phi>) auto

lemma SOV_norm[simp]: "SOV (norm \<phi>) = SOV \<phi>"
  by (induct \<phi>) auto

lemma pre_wf_formula_norm[simp]: "pre_wf_formula n (norm \<phi>) = pre_wf_formula n \<phi>"
  by (induct \<phi> arbitrary: n) auto

lemma satisfies_norm[simp]: "wI \<Turnstile> norm \<phi> \<longleftrightarrow> wI \<Turnstile> \<phi>"
  by (induct \<phi> arbitrary: wI) auto

lemma lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_norm[simp]: "lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n (norm \<phi>) = lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<phi>"
  unfolding lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_def by auto

end

(*<*)
end
(*>*)


(* Author: Tobias Nipkow and Gerwin Klein *)

section "Compiler for IMP"

theory Chapter8_3 imports "Chapter7_8/Big_Step" "~~/src/HOL/IMP/Star"
begin

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

type_synonym state = "nat \<Rightarrow> val"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD nat | ADD | STORE nat |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [0, 1],stk) | i t stk.
    [LOAD 1, STORE 0] \<turnstile>
    (0, <0 := 3, 1 := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the excution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2::int)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (if c\<^sub>2 = SKIP then
    (let cc\<^sub>1 = ccomp c\<^sub>1; cb = bcomp b False (size cc\<^sub>1) in cb @ cc\<^sub>1)
   else (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2))" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])" |
"ccomp (REPEAT c UNTIL b) =
 (let cc = ccomp c; cb = bcomp b True 1 in cc @ cb @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
next
  case (RepeatTrue b s2 c s1 s3 stk)
   (* ccomp (REPEAT c_ UNTIL b_) \<turnstile> (0, s\<^sub>1_, stk) \<rightarrow>* (size (ccomp (REPEAT c_ UNTIL b_)), s\<^sub>3_, stk) *)
   let ?cc = "ccomp c"
   let ?cb = "bcomp b True 1"
   let ?prog = "ccomp (REPEAT c UNTIL b)"
   have prog_def: "?prog = ?cc @ ?cb @ [JMP (-(size ?cc + size ?cb + 1))]" by auto
   from RepeatTrue.IH have "?prog \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cc, s2, stk)" by fastforce
   moreover from `\<not>bval b s2` bcomp_correct[where n=1 and b=b and f=True and s=s2 and stk=stk]
     have "?cb \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cb, s2, stk)"
     by auto
   moreover have "?cc @ ?cb \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cc + size ?cb, s2, stk)" using exec_appendL calculation by auto
   moreover have "?prog \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cc + size ?cb, s2, stk)" using exec_appendR calculation prog_def append_assoc by metis
   moreover have "?prog \<turnstile> (size ?cc + size ?cb, s2, stk) \<rightarrow> (0, s2, stk)" by auto
   moreover have "?prog \<turnstile> (0, s1, stk) \<rightarrow>* (0, s2, stk)" by (meson star_trans calculation prog_def star_step1)
   ultimately show ?case using RepeatTrue.IH star_trans by smt
   (* FIXME smt: just needs suitable instantiation of star_trans *)
qed fastforce+

end


(*
    Title:      Code_Matrix.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Code generation for vectors and matrices\<close>

theory Code_Matrix
imports
  Rank_Nullity_Theorem.Miscellaneous
  Code_Set
begin

text\<open>In this file the code generator is set up properly to allow the execution of matrices
      represented as funcions over finite types.\<close>

lemmas vec.vec_nth_inverse[code abstype]

lemma [code abstract]: "vec_nth 0 = (%x. 0)" by (metis zero_index)
lemma [code abstract]: "vec_nth 1 = (%x. 1)" by (metis one_index)
lemma [code abstract]: "vec_nth (a + b) =  (%i. a$i + b$i)" by (metis vector_add_component)
lemma [code abstract]: "vec_nth (a - b) =  (%i. a$i - b$i)" by (metis vector_minus_component)
lemma [code abstract]: "vec_nth (vec n) = (\<lambda>i. n)" unfolding vec_def by fastforce
lemma [code abstract]: "vec_nth (a * b) =  (%i. a$i * b$i)" unfolding vector_mult_component by auto
lemma [code abstract]: "vec_nth (c *s x) = (\<lambda>i. c * (x$i))" unfolding vector_scalar_mult_def by auto
lemma [code abstract]: "vec_nth (a - b) =  (%i. a$i - b$i)" by (metis vector_minus_component)

definition mat_mult_row
  where "mat_mult_row m m' f = vec_lambda (%c. sum (%k. ((m$f)$k) * ((m'$k)$c)) (UNIV :: 'n::finite set))"

lemma mat_mult_row_code [code abstract]:
  "vec_nth (mat_mult_row m m' f) = (%c. sum (%k. ((m$f)$k) * ((m'$k)$c)) (UNIV :: 'n::finite set))"
  by(simp add: mat_mult_row_def fun_eq_iff)

lemma mat_mult [code abstract]: "vec_nth (m ** m') = mat_mult_row m m'"
  unfolding matrix_matrix_mult_def mat_mult_row_def[abs_def]
  using vec_lambda_beta by auto

lemma matrix_vector_mult_code [code abstract]:
  "vec_nth (A *v x) = (%i. (\<Sum>j\<in>UNIV. A $ i $ j * x $ j))" unfolding matrix_vector_mult_def by fastforce

lemma vector_matrix_mult_code [code abstract]:
  "vec_nth (x v* A) = (%j. (\<Sum>i\<in>UNIV. A $ i $ j * x $ i))" unfolding vector_matrix_mult_def by fastforce

definition mat_row
  where "mat_row k i = vec_lambda (%j. if i = j then k else 0)"

lemma mat_row_code [code abstract]:
  "vec_nth (mat_row k i) = (%j. if i = j then k else 0)" unfolding mat_row_def by auto

lemma [code abstract]: "vec_nth (mat k) = mat_row k"
  unfolding mat_def unfolding mat_row_def[abs_def] by auto

definition transpose_row
   where "transpose_row A i = vec_lambda (%j. A $ j $ i)"

lemma transpose_row_code [code abstract]:
  "vec_nth (transpose_row A i) = (%j.  A $ j $ i)" by (metis transpose_row_def vec_lambda_beta)

lemma transpose_code[code abstract]:
  "vec_nth (transpose A) = transpose_row A"
  by (auto simp: transpose_def transpose_row_def)

lemma [code abstract]: "vec_nth (row i A) =  (($) (A $ i))" unfolding row_def by fastforce
lemma [code abstract]: "vec_nth (column j A) = (%i. A $ i $ j)" unfolding column_def by fastforce

definition "rowvector_row v i = vec_lambda (%j. (v$j))"

lemma rowvector_row_code [code abstract]:
  "vec_nth (rowvector_row v i) = (%j. (v$j))" unfolding rowvector_row_def by auto

lemma [code abstract]: "vec_nth (rowvector v) = rowvector_row v"
  unfolding rowvector_def unfolding rowvector_row_def[abs_def] by auto

definition "columnvector_row v i = vec_lambda (%j. (v$i))"

lemma columnvector_row_code [code abstract]:
  "vec_nth (columnvector_row v i) = (%j. (v$i))" unfolding columnvector_row_def by auto

lemma [code abstract]: "vec_nth (columnvector v) = columnvector_row v"
  unfolding columnvector_def unfolding columnvector_row_def[abs_def] by auto

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Test Dioids\<close>

theory Test_Dioid
  imports Kleene_Algebra.Dioid
begin

text \<open>
  Tests are embedded in a weak dioid, a dioid without the right annihilation and left distributivity axioms, using an
  operator $t$ defined by a complementation operator. This allows us to use tests in weak settings, such as Probabilistic Kleene Algebra and Demonic Refinement Algebra.
\<close>

subsection \<open>Test Monoids\<close>

class n_op =
  fixes n_op :: "'a \<Rightarrow> 'a" ("n _" [90] 91)

class test_monoid = monoid_mult + n_op +
  assumes tm1 [simp]: "n n 1 = 1"
  and tm2 [simp]: "n x \<cdot> n n x = n 1"
  and tm3: "n x \<cdot> n (n n z \<cdot> n n y) = n (n (n x \<cdot> n y) \<cdot> n (n x \<cdot> n z))"

begin

(*no_notation zero_class.zero ("0")*)

definition a_zero :: "'a" ("o") where
  "o \<equiv> n 1"

abbreviation "t x \<equiv> n n x"

definition n_add_op :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<oplus>" 65) where
  "x \<oplus> y \<equiv> n (n x \<cdot> n y)"

lemma "n 1 \<cdot> x = n 1"
(*nitpick*) oops

lemma "x \<cdot> n 1 = n 1"
(*nitpick*) oops

lemma "n 1 \<cdot> x = n 1 \<Longrightarrow> n x \<cdot> y \<cdot> t z = n 1 \<Longrightarrow> n x \<cdot> y = n x \<cdot> y \<cdot> n z  "
(*nitpick*) oops

lemma n_t_closed [simp]: "t (n x) = n x"
proof -
  have "\<And>x y. n x \<cdot> n (t (n x) \<cdot> t y) = t (n x \<cdot> n y)"
    by (simp add: local.tm3)
  thus ?thesis
   by (metis (no_types) local.mult_1_right local.tm1 local.tm2 local.tm3 mult_assoc)
qed

lemma mult_t_closed [simp]: "t (n x \<cdot> n y) = n x \<cdot> n y"
  by (metis local.mult_1_right local.tm1 local.tm2 local.tm3 n_t_closed)

lemma n_comm_var: "n (n x \<cdot> n y) = n (n y \<cdot> n x)"
  by (metis local.mult_1_left local.tm1 local.tm3 n_t_closed)

lemma n_comm: "n x \<cdot> n y = n y \<cdot> n x"
  using mult_t_closed n_comm_var by fastforce

lemma huntington1 [simp]: "n (n (n n x \<cdot> n y) \<cdot> n (n n x \<cdot> n n y)) = n n x"
  by (metis local.mult_1_right local.tm1 local.tm2 local.tm3)

lemma huntington2 [simp]: "n (n x \<oplus> n n y) \<oplus> n (n x \<oplus> n y) = n n x"
  by (simp add: n_add_op_def)

lemma t_mult_closure: "t x = x \<Longrightarrow> t y = y \<Longrightarrow> t (x \<cdot> y) = x \<cdot> y"
  by (metis mult_t_closed)

lemma n_t_compl [simp]: "n x \<oplus> t x = 1"
  using n_add_op_def local.tm1 local.tm2 by presburger

lemma zero_least1 [simp]: "o \<oplus> n x = n x"
  by (simp add: a_zero_def n_add_op_def)

lemma zero_least2 [simp]: "o \<cdot> n x = o"
  by (metis a_zero_def local.tm2 local.tm3 mult_assoc mult_t_closed zero_least1)

lemma zero_least3 [simp]: "n x \<cdot> o  = o"
  using a_zero_def n_comm zero_least2 by fastforce

lemma one_greatest1 [simp]: "1 \<oplus> n x = 1"
  by (metis (no_types) a_zero_def local.tm1 n_add_op_def n_comm_var zero_least3)

lemma one_greatest2 [simp]: "n x \<oplus> 1 = 1"
  by (metis n_add_op_def n_comm_var one_greatest1)

lemma n_add_idem [simp]: "n x \<oplus> n x = n x"
  by (metis huntington1 local.mult_1_right n_t_closed n_t_compl n_add_op_def)

lemma n_mult_idem [simp]: "n x \<cdot> n x = n x"
  by (metis mult_t_closed n_add_idem n_add_op_def)

lemma n_preserve [simp]: "n x \<cdot> n y \<cdot> n x = n y \<cdot> n x"
  by (metis mult_assoc n_comm n_mult_idem)

lemma n_preserve2 [simp]: "n x \<cdot> n y \<cdot> t x = o"
  by (metis a_zero_def local.tm2 mult_assoc n_comm zero_least3)

lemma de_morgan1 [simp]: "n (n x \<cdot> n y) = t x \<oplus> t y"
  by (simp add: n_add_op_def)

lemma de_morgan4 [simp]: "n (t x \<oplus> t y) = n x \<cdot> n y"
  using n_add_op_def mult_t_closed n_t_closed by presburger

lemma n_absorb1 [simp]: "n x \<oplus> n x \<cdot> n y = n x"
  by (metis local.mult_1_right local.tm1 local.tm3 one_greatest2 n_add_op_def)

lemma n_absorb2 [simp]: "n x \<cdot> (n x \<oplus> n y) = n x"
  by (metis mult_t_closed n_absorb1 n_add_op_def)

lemma n_distrib1: "n x \<cdot> (n y \<oplus> n z) = (n x \<cdot> n y) \<oplus> (n x \<cdot> n z)"
  using local.tm3 n_comm_var  n_add_op_def by presburger

lemma n_distrib1_opp: "(n x \<oplus> n y) \<cdot> n z  = (n x \<cdot> n z) \<oplus> (n y \<cdot> n z)"
  using n_add_op_def n_comm n_distrib1 by presburger

lemma n_distrib2: "n x \<oplus> n y \<cdot> n z = (n x \<oplus> n y) \<cdot> (n x \<oplus> n z)"
  by (metis mult_t_closed n_distrib1 n_mult_idem  n_add_op_def)

lemma n_distrib2_opp: "n x \<cdot> n y \<oplus> n z = (n x \<oplus> n z) \<cdot> (n y \<oplus> n z)"
  by (metis de_morgan1 mult_t_closed n_distrib1_opp n_add_op_def)

definition ts_ord :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "x \<sqsubseteq> y = (n x \<cdot> n y = n y)"

lemma ts_ord_alt: "n x \<sqsubseteq> n y \<longleftrightarrow> n x \<oplus> n y = n y"
  by (metis mult_t_closed n_t_closed ts_ord_def n_add_op_def)

lemma ts_ord_refl: "n x \<sqsubseteq> n x"
  by (simp add: ts_ord_def)

lemma ts_ord_trans: "n x \<sqsubseteq> n y \<Longrightarrow> n y \<sqsubseteq> n z \<Longrightarrow> n x \<sqsubseteq> n z"
  by (metis mult_assoc ts_ord_def)

lemma ts_ord_antisym: "n x \<sqsubseteq> n y \<Longrightarrow> n y \<sqsubseteq> n x \<Longrightarrow> n x = n y"
  by (metis n_add_idem n_comm ts_ord_def n_add_op_def)

lemma ts_ord_mult_isol: "n x \<sqsubseteq> n y \<Longrightarrow> n z \<cdot> n x \<sqsubseteq> n z \<cdot> n y"
proof -
  assume "n x \<sqsubseteq> n y"
  hence "n (n (n z \<cdot> n x) \<cdot> n (n z \<cdot> n y)) = n z \<cdot> n y"
    by (metis mult_t_closed n_add_idem n_distrib1 ts_ord_def n_add_op_def)
  thus ?thesis
    by (metis mult_t_closed ts_ord_def)
qed

lemma ts_ord_mult_isor: "n x \<sqsubseteq> n y \<Longrightarrow> n x \<cdot> n z \<sqsubseteq> n y \<cdot> n z"
  using n_comm ts_ord_mult_isol by auto

lemma ts_ord_add_isol: "n x \<sqsubseteq> n y \<Longrightarrow> n z \<oplus> n x \<sqsubseteq> n z \<oplus> n y"
  by (metis mult_assoc mult_t_closed n_mult_idem ts_ord_def n_add_op_def)

lemma ts_ord_add_isor: "n x \<sqsubseteq> n y \<Longrightarrow> n x \<oplus> n z \<sqsubseteq> n y \<oplus> n z"
  using n_add_op_def n_comm ts_ord_add_isol by presburger

lemma ts_ord_anti: "n x \<sqsubseteq> n y \<Longrightarrow> t y \<sqsubseteq> t x"
  by (metis n_absorb2 n_add_idem n_comm ts_ord_def n_add_op_def)

lemma ts_ord_anti_iff: "n x \<sqsubseteq> n y \<longleftrightarrow> t y \<sqsubseteq> t x"
  using ts_ord_anti by force

lemma zero_ts_ord: "o \<sqsubseteq> n x"
  by (simp add: a_zero_def ts_ord_def)

lemma n_subid: "n x \<sqsubseteq> 1"
  by (simp add: a_zero_def[symmetric] ts_ord_def)

lemma n_mult_lb1: "n x \<cdot> n y \<sqsubseteq> n x"
  by (metis (no_types) local.mult_1_right local.tm1 n_comm n_subid ts_ord_mult_isor)

lemma n_mult_lb2: "n x \<cdot> n y \<sqsubseteq> n y"
  by (metis n_comm n_mult_lb1)

lemma n_mult_glbI: "n z \<sqsubseteq> n x \<Longrightarrow>  n z \<sqsubseteq> n y \<Longrightarrow> n z \<sqsubseteq> n x \<cdot> n y"
  by (metis n_t_closed ts_ord_anti_iff ts_ord_def ts_ord_mult_isol)

lemma n_add_ub1: "n x \<sqsubseteq> n x \<oplus> n y"
  by (metis (no_types) n_absorb2 n_mult_lb2 n_add_op_def)

lemma n_add_ub2: "n y \<sqsubseteq> n x \<oplus> n y"
  by (metis n_add_ub1 n_comm_var n_add_op_def)

lemma n_add_lubI: "n x \<sqsubseteq> n z \<Longrightarrow> n y \<sqsubseteq> n z \<Longrightarrow> n x \<oplus> n y \<sqsubseteq> n z"
  by (metis ts_ord_add_isol ts_ord_alt)

lemma n_add_lub: "n x \<sqsubseteq> n z \<and> n y \<sqsubseteq> n z \<longleftrightarrow> n x \<oplus> n y \<sqsubseteq> n z"
  by (metis n_add_lubI n_add_op_def n_add_ub1 n_add_ub2 ts_ord_trans)

lemma n_galois1: "n x \<sqsubseteq> n y \<oplus> n z \<longleftrightarrow> n x \<cdot> t y \<sqsubseteq> n z"
proof
  assume "n x \<sqsubseteq> n y \<oplus> n z"
  hence "n x \<cdot> t y \<sqsubseteq> (n y \<oplus> n z ) \<cdot> t y"
    by (metis n_add_op_def ts_ord_mult_isor)
  also have "... = n y \<cdot> t y \<oplus> n z \<cdot> t y"
    using n_add_op_def local.tm3 n_comm by presburger
  also have "... = n z \<cdot> t y"
    using a_zero_def local.tm2 n_distrib2 zero_least1 by presburger
  finally show "n x \<cdot> t y \<sqsubseteq> n z"
    by (metis mult_t_closed n_mult_glb)
next
  assume a: "n x \<cdot> t y \<sqsubseteq> n z"
  have "n x = t (n x \<cdot> (n y \<oplus> t y))"
    using local.mult_1_right n_t_closed n_t_compl by presburger
  also have "... = t (n x \<cdot> n y \<oplus> n x \<cdot> t y)"
    using n_distrib1 by presburger
  also have "...  \<sqsubseteq> t (n y \<oplus> n x \<cdot> t y)"
    by (metis calculation local.mult_1_right mult_t_closed n_add_op_def n_add_ub2 n_distrib2 n_t_compl)
  finally show "n x \<sqsubseteq> n y \<oplus> n z"
    by (metis (no_types, hide_lams) a mult_t_closed ts_ord_add_isol ts_ord_trans n_add_op_def)
qed

lemma n_galois2: "n x \<sqsubseteq> t y \<oplus> n z \<longleftrightarrow> n x \<cdot> n y \<sqsubseteq> n z"
  by (metis n_galois1 n_t_closed)

lemma n_distrib_alt: "n x \<cdot> n z = n y \<cdot> n z \<Longrightarrow> n x \<oplus> n z = n y \<oplus> n z \<Longrightarrow> n x = n y"
proof -
  assume a: "n x \<cdot> n z = n y \<cdot> n z" and b: "n x \<oplus> n z = n y \<oplus> n z"
  have "n x = n x \<oplus> n x \<cdot> n z"
    using n_absorb1 by presburger
  also have "... = n x \<oplus> n y \<cdot> n z"
    using a by presburger
  also have "... = (n x \<oplus> n y) \<cdot> (n x \<oplus> n z)"
    using n_distrib2 by blast
  also have "... = (n y \<oplus> n x) \<cdot> (n y \<oplus> n z)"
    using n_add_op_def b n_comm by presburger
  also have "... = n y \<cdot> (n x \<oplus> n z)"
    by (metis a b n_distrib1 n_distrib2 n_mult_idem)
  also have "... = n y \<cdot> (n y \<oplus> n z)"
    using b by presburger
  finally show "n x = n y"
    using n_absorb2 by presburger
qed

lemma n_dist_var1: "(n x \<oplus> n y) \<cdot> (t x \<oplus> n z) = t x \<cdot> n y \<oplus> n x \<cdot> n z"
proof -
  have "(n x \<oplus> n y) \<cdot> (t x \<oplus> n z) = n x \<cdot> t x \<oplus> n y \<cdot> t x \<oplus> (n x \<cdot> n z \<oplus> n y \<cdot> n z)"
    using n_add_op_def n_distrib1 n_distrib1_opp by presburger
  also have "... = t x \<cdot> n y \<oplus> (n x \<cdot> n z \<oplus> (n x \<oplus> t x) \<cdot> t (n y \<cdot> n z))"
    using n_add_op_def local.mult_1_left local.tm1 local.tm2 n_comm n_t_closed by presburger
  also have "... = t x \<cdot> n y \<oplus> (n x \<cdot> n z \<oplus> (n x \<cdot> n y \<cdot> n z \<oplus> t x \<cdot> n y \<cdot> n z))"
    by (metis mult_assoc mult_t_closed n_distrib1_opp)
  also have "... = (t x \<cdot> n y \<oplus> t x \<cdot> n y \<cdot> n z) \<oplus> (n x \<cdot> n z \<oplus> n x \<cdot> n y \<cdot> n z)"
proof -
  have f1: "\<And>a aa ab. n n (n (a::'a) \<cdot> (n aa \<cdot> n ab)) = n a \<cdot> (n aa \<cdot> n ab)"
    by (metis (full_types) mult_t_closed)
  have "\<And>a aa ab. n (a::'a) \<cdot> (n aa \<cdot> n ab) = n aa \<cdot> (n ab \<cdot> n a)"
    by (metis mult_assoc n_comm)
  hence "n (n (n y \<cdot> n n x) \<cdot> n n (n (n x \<cdot> n z) \<cdot> (n (n x \<cdot> n y \<cdot> n z) \<cdot> n (n y \<cdot> n n x \<cdot> n z)))) = n (n (n y \<cdot> n n x) \<cdot> n (n y \<cdot> n n x \<cdot> n z) \<cdot> (n (n x \<cdot> n z) \<cdot> n (n x \<cdot> n y \<cdot> n z)))"
    using f1 mult_assoc by presburger
  thus ?thesis
    using mult_t_closed n_add_op_def n_comm by presburger
qed
     also have "... = (t x \<cdot> n y \<oplus> t (t x \<cdot> n y) \<cdot> n z) \<oplus> (n x \<cdot> n z \<oplus> t (n x \<cdot> n z) \<cdot> n y)"
    using mult_assoc mult_t_closed n_comm by presburger
  also have "... = (t x \<cdot> n y \<cdot> (1 \<oplus> n z)) \<oplus> (n x \<cdot> n z \<cdot> (1 \<oplus> n y))"
    by (metis a_zero_def n_add_op_def local.mult_1_right local.tm1 mult_t_closed n_absorb1 zero_least2)
  finally show ?thesis
    by simp
qed

lemma n_dist_var2: "n (n x \<cdot> n y \<oplus> t x \<cdot> n z) = n x \<cdot> t y \<oplus> t x \<cdot> t z"
  by (metis (no_types) n_add_op_def n_dist_var1 n_t_closed)

end

subsection \<open>Test Near-Semirings\<close>

class test_near_semiring_zerol = ab_near_semiring_one_zerol + n_op + plus_ord +
  assumes test_one [simp]: "n n 1 = 1"
  and test_mult [simp]: "n n (n x \<cdot> n y) = n x \<cdot> n y"
  and test_mult_comp [simp]: "n x \<cdot> n n x = 0"
  and test_de_morgan [simp]: "n (n n x \<cdot> n n y) = n x + n y"

begin

lemma n_zero [simp]: "n 0 = 1"
proof -
  have "n 0 = n (n 1 \<cdot> n n 1)"
    using local.test_mult_comp by presburger
  also have "... = n (n 1 \<cdot> 1)"
    by simp
  finally show ?thesis
    by simp
qed

lemma n_one [simp]: "n 1 = 0"
proof -
  have "n 1 = n 1 \<cdot> 1"
    by simp
  also have "... = n 1 \<cdot> n n 1"
    by simp
  finally show ?thesis
    using test_mult_comp by metis
qed

lemma one_idem [simp]: "1 + 1 = 1"
proof -
  have "1 + 1 = n n 1 + n n 1"
    by simp
  also have "... = n (n n n 1 \<cdot> n n n 1)"
    using local.test_de_morgan by presburger
  also have "... = n (0 \<cdot> n n n 1)"
    by simp
  also have "... = n 0"
    by simp
  finally show ?thesis
    by simp
qed

subclass near_dioid_one_zerol
proof
  fix x
  have "x + x = (1 + 1) \<cdot> x"
    using local.distrib_right' local.mult_onel by presburger
  also have "... = 1 \<cdot> x"
    by simp
  finally show "x + x = x"
    by simp
qed

lemma t_n_closed [simp]: "n n (n x) = n x"
proof -
  have "n n (n x) = n (n n x \<cdot> 1)"
    by simp
  also have "... = n (n n x \<cdot> n n 1)"
    by simp
  also have "... = n x + n 1"
    using local.test_de_morgan by presburger
  also have "... = n x + 0"
    by simp
  finally show ?thesis
    by simp
qed

lemma t_de_morgan_var1 [simp]: "n (n x \<cdot> n y) = n n x + n n y"
  by (metis local.test_de_morgan t_n_closed)

lemma n_mult_comm: "n x \<cdot> n y = n y \<cdot> n x"
proof -
  have "n x \<cdot> n y = n n (n x \<cdot> n y)"
    by (metis local.test_mult)
  also have "... = n (n n x + n n y)"
    by simp
  also have "... = n (n n y + n n x)"
    by (metis add_commute)
  also have "... = n n (n y \<cdot> n x)"
    by simp
  finally show ?thesis
    by (metis local.test_mult)
qed

lemma tm3': "n x \<cdot> n (n n z \<cdot> n n y) = n (n (n x \<cdot> n y) \<cdot> n (n x \<cdot> n z))"
proof -
  have "n x \<cdot> n (n n z \<cdot> n n y) = n (n n y \<cdot> n n z) \<cdot> n x"
    using n_mult_comm by presburger
  also have "... = (n y + n z) \<cdot> n x"
    by simp
  also have "... = n y \<cdot> n x + n z \<cdot> n x"
    by simp
  also have "... = n n (n x \<cdot> n y) + n n (n x \<cdot> n z)"
    by (metis local.test_mult n_mult_comm)
  finally show ?thesis
    by (metis t_de_morgan_var1)
qed

subclass test_monoid
proof
  show "n n 1 = 1"
    by simp
  show "\<And>x. n x \<cdot> n n x = n 1"
    by simp
  show " \<And>x z y. n x \<cdot> n (n n z \<cdot> n n y) = n (n (n x \<cdot> n y) \<cdot> n (n x \<cdot> n z))"
    using tm3' by blast
qed

lemma ord_transl [simp]: "n x \<le> n y \<longleftrightarrow> n x \<sqsubseteq> n y"
  by (simp add: local.join.sup.absorb_iff2 local.n_add_op_def local.ts_ord_alt)

lemma add_transl [simp]: "n x + n y = n x \<oplus> n y"
  by (simp add: local.n_add_op_def)

lemma zero_trans: "0 = o"
  by (metis local.a_zero_def n_one)

definition test :: "'a \<Rightarrow> bool" where
  "test p \<equiv> t p = p"

notation n_op ("!_" [101] 100)

lemma test_prop: "(\<forall>x. test x \<longrightarrow> P x) \<longleftrightarrow> (\<forall>x. P (t x))"
  by (metis test_def t_n_closed)

lemma test_propI: "test x \<Longrightarrow> P x \<Longrightarrow> P (t x)"
  by (simp add: test_def)

lemma test_propE [elim!]: "test x \<Longrightarrow> P (t x) \<Longrightarrow> P x"
  by (simp add: test_def)

lemma test_comp_closed [simp]: "test p \<Longrightarrow> test (!p)"
  by (simp add: test_def)

lemma test_double_comp_var: "test p \<Longrightarrow> p = !(!p)"
  by auto

lemma test_mult_closed: "test p \<Longrightarrow> test q \<Longrightarrow> test (p \<cdot> q)"
  by (metis local.test_mult test_def)

lemma t_add_closed [simp]: "t (n x + n y) = n x + n y"
  by (metis local.test_de_morgan t_n_closed)

lemma test_add_closed: "test p \<Longrightarrow> test q \<Longrightarrow> test (p + q)"
  by (metis t_add_closed test_def)

lemma test_mult_comm_var: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> q = q \<cdot> p"
  using n_mult_comm by auto

lemma t_zero [simp]: "t 0 = 0"
  by simp

lemma test_zero_var: "test 0"
  by (simp add: test_def)

lemma test_one_var: "test 1"
  by (simp add: test_def)

lemma test_preserve: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> q \<cdot> p = q \<cdot> p"
  by auto

lemma test_preserve2: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> q \<cdot> !p = 0"
  by (metis local.a_zero_def local.n_preserve2 n_one test_double_comp_var)

lemma n_subid': "n x \<le> 1"
  using local.n_subid n_zero ord_transl by blast

lemma test_subid: "test p \<Longrightarrow> p \<le> 1"
  using n_subid' by auto

lemma test_mult_idem_var [simp]: "test p \<Longrightarrow> p \<cdot> p = p"
  by auto

lemma n_add_comp [simp]: "n x + t x = 1"
  by simp

lemma n_add_comp_var [simp]: "t x + n x = 1"
  by (simp add: add_commute)

lemma test_add_comp [simp]: "test p \<Longrightarrow> p + !p = 1"
  using n_add_comp by fastforce

lemma test_comp_mult1 [simp]: "test p \<Longrightarrow> !p \<cdot> p = 0"
  by auto

lemma test_comp_mult2 [simp]: "test p \<Longrightarrow> p \<cdot> !p = 0"
  using local.test_mult_comp by fastforce

lemma test_comp: "test p \<Longrightarrow> \<exists>q. test q \<and> p + q = 1 \<and> p \<cdot> q = 0"
  using test_add_comp test_comp_closed test_comp_mult2 by blast

lemma n_absorb1' [simp]: "n x + n x \<cdot> n y = n x"
  by (metis add_transl local.de_morgan4 local.n_absorb1)

lemma test_absorb1 [simp]: "test p \<Longrightarrow> test q \<Longrightarrow> p + p \<cdot> q = p"
  by auto

lemma n_absorb2' [simp]: "n x \<cdot> (n x + n y) = n x"
  by simp

lemma test_absorb2: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> (p + q) = p"
  by auto

lemma n_distrib_left: "n x \<cdot> (n y + n z) = (n x \<cdot> n y) + (n x \<cdot> n z)"
  by (metis (no_types) add_transl local.de_morgan4 local.n_distrib1)

lemma test_distrib_left: "test p \<Longrightarrow>  test q \<Longrightarrow> test r \<Longrightarrow> p \<cdot> (q + r) = p \<cdot> q + p \<cdot> r"
  using n_distrib_left by auto

lemma de_morgan1': "test p \<Longrightarrow> test q \<Longrightarrow> !p + !q = !(p \<cdot> q)"
  by auto

lemma n_de_morgan_var2 [simp]: "n (n x + n y) = t x \<cdot> t y"
  by (metis local.test_de_morgan local.test_mult)

lemma n_de_morgan_var3 [simp]: "n (t x + t y) = n x \<cdot> n y"
  by simp

lemma de_morgan2: "test p \<Longrightarrow> test q \<Longrightarrow> !p \<cdot> !q = !(p + q)"
  by auto

lemma de_morgan3: "test p \<Longrightarrow> test q \<Longrightarrow> !(!p + !q) = p \<cdot> q"
  using local.de_morgan1' local.t_mult_closure test_def by auto

lemma de_morgan4': "test p \<Longrightarrow> test q \<Longrightarrow> !(!p \<cdot> !q) = p + q"
  by auto

lemma n_add_distr: "n x + (n y \<cdot> n z) = (n x + n y) \<cdot> (n x + n z)"
  by (metis add_transl local.n_distrib2 n_de_morgan_var3)

lemma test_add_distr: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p + q \<cdot> r = (p + q) \<cdot> (p + r)"
  using n_add_distr by fastforce

lemma n_add_distl: "(n x \<cdot> n y) + n z = (n x + n z) \<cdot> (n y + n z)"
  by (simp add: add_commute n_add_distr)

lemma test_add_distl_var: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<cdot> q + r = (p + r) \<cdot> (q + r)"
  by (simp add: add_commute test_add_distr)

lemma n_ord_def_alt: "n x \<le> n y \<longleftrightarrow> n x \<cdot> n y = n x"
  by (metis (no_types) local.join.sup.absorb_iff2 local.n_absorb2' local.n_mult_lb2 ord_transl)

lemma test_leq_mult_def_var: "test p \<Longrightarrow> test q \<Longrightarrow> p \<le> q \<longleftrightarrow> p \<cdot> q = p"
  using n_ord_def_alt by auto

lemma n_anti: "n x \<le> n y \<Longrightarrow> t y \<le> t x"
  using local.ts_ord_anti ord_transl by blast

lemma n_anti_iff: "n x \<le> n y \<longleftrightarrow> t y \<le> t x"
  using n_anti by fastforce

lemma test_comp_anti_iff: "test p \<Longrightarrow> test q \<Longrightarrow> p \<le> q \<longleftrightarrow> !q \<le> !p"
  using n_anti_iff by auto

lemma n_restrictl: "n x \<cdot> y \<le> y"
  using local.mult_isor n_subid' by fastforce

lemma test_restrictl: "test p \<Longrightarrow> p \<cdot> x \<le> x"
  by (auto simp: n_restrictl)

lemma n_mult_lb1': "n x \<cdot> n y \<le> n x"
  by (simp add: local.join.sup.orderI)

lemma test_mult_lb1: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> q \<le> p"
  by (auto simp: n_mult_lb1')

lemma n_mult_lb2': "n x \<cdot> n y \<le> n y"
  by (fact local.n_restrictl)

lemma test_mult_lb2: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> q \<le> q"
  by (rule test_restrictl)

lemma n_mult_glbI': "n z \<le> n x \<Longrightarrow>  n z \<le> n y \<Longrightarrow> n z \<le> n x \<cdot> n y"
  by (metis mult_isor n_ord_def_alt)

lemma test_mult_glbI:  "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<le> q \<Longrightarrow> p \<le> r \<Longrightarrow> p \<le> q \<cdot> r"
  by (metis (no_types) local.mult_isor test_leq_mult_def_var)

lemma n_mult_glb': "n z \<le> n x \<and> n z \<le> n y \<longleftrightarrow> n z \<le> n x \<cdot> n y"
  using local.order_trans n_mult_glbI' n_mult_lb1' n_mult_lb2' by blast

lemma test_mult_glb: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<le> q \<and> p \<le> r \<longleftrightarrow> p \<le> q \<cdot> r"
  using local.n_mult_glb' by force

lemma n_galois1': "n x \<le> n y + n z \<longleftrightarrow> n x \<cdot> t y \<le> n z"
proof -
  have "n x \<le> n y + n z \<longleftrightarrow> n x \<sqsubseteq> n y \<oplus> n z"
    by (metis local.test_de_morgan ord_transl n_add_op_def)
  also have "... \<longleftrightarrow> n x \<cdot> t y \<sqsubseteq> n z"
    using local.n_galois1 by auto
  also have "... \<longleftrightarrow> n x \<cdot> t y \<le> n z"
    by (metis local.test_mult ord_transl)
  finally show ?thesis
    by simp
qed

lemma test_galois1: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<le> q + r \<longleftrightarrow> p \<cdot> !q \<le> r"
  using n_galois1' by auto

lemma n_galois2': "n x \<le> t y + n z \<longleftrightarrow> n x \<cdot> n y \<le> n z"
  using local.n_galois1' by auto

lemma test_galois2: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<le> !q + r \<longleftrightarrow> p \<cdot> q \<le> r"
  using test_galois1 by auto

lemma n_huntington2: "n (n x + t y) + n (n x + n y) = n n x"
  by simp

lemma test_huntington2: "test p \<Longrightarrow> test q \<Longrightarrow> !(p + q) + !(p + !q) = !p"
proof -
  assume a1: "test p"
  assume a2: "test q"
  have "p = !(!p)"
    using a1 test_double_comp_var by blast
  thus ?thesis
    using a2 by (metis (full_types) n_huntington2 test_double_comp_var)
qed

lemma n_kat_1_opp: "n x \<cdot> y \<cdot> n z = y \<cdot> n z \<longleftrightarrow> t x \<cdot> y \<cdot> n z = 0"
proof
  assume "n x \<cdot> y \<cdot> n z = y \<cdot> n z"
  hence "t x \<cdot> y \<cdot> n z = t x \<cdot> n x \<cdot> y \<cdot> n z"
    by (simp add: mult_assoc)
  thus " t x \<cdot> y \<cdot> n z = 0"
    by (simp add: n_mult_comm)
next
  assume "n n x \<cdot> y \<cdot> n z = 0"
  hence "n x \<cdot> y \<cdot> n z = 1 \<cdot> y \<cdot> n z"
    by (metis local.add_zerol local.distrib_right' n_add_comp t_n_closed)
  thus "n x \<cdot> y \<cdot> n z = y \<cdot> n z"
    by auto
qed

lemma test_eq4: "test p \<Longrightarrow> test q \<Longrightarrow> !p \<cdot> x \<cdot> !q = x \<cdot> !q \<longleftrightarrow> p \<cdot> x \<cdot> !q = 0"
  using n_kat_1_opp by auto

lemma n_kat_1_var: "t x \<cdot> y \<cdot> t z = y \<cdot> t z \<longleftrightarrow> n x \<cdot> y \<cdot> t z = 0"
  by (simp add: n_kat_1_opp)

lemma test_kat_1: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> x \<cdot> q = x \<cdot> q \<longleftrightarrow> !p \<cdot> x \<cdot> q = 0"
  using n_kat_1_var by auto

lemma n_kat_21_opp:  "y \<cdot> n z \<le> n x \<cdot> y \<Longrightarrow> n x \<cdot> y \<cdot> n z = y \<cdot> n z"
proof -
  assume "y \<cdot> n z \<le> n x \<cdot> y"
  hence "y \<cdot> n z + n x \<cdot> y = n x \<cdot> y"
    by (meson local.join.sup_absorb2)
  hence "n x \<cdot> y \<cdot> n z = y \<cdot> n z + (n x \<cdot> (y \<cdot> n z) + 0)"
    by (metis local.add_zeror local.distrib_right' local.n_mult_idem mult_assoc)
  thus ?thesis
    by (metis local.add_zeror local.distrib_right' local.join.sup_absorb2 local.join.sup_left_commute local.mult_onel local.n_subid')
qed

lemma test_kat_21_opp: "test p \<Longrightarrow> test q \<Longrightarrow> x \<cdot> q \<le> p \<cdot> x \<longrightarrow> p \<cdot> x \<cdot> q = x \<cdot> q"
  using n_kat_21_opp by auto

lemma  " n x \<cdot> y \<cdot> n z = y \<cdot> n z \<Longrightarrow> y \<cdot> n z \<le> n x \<cdot> y"
  (*nitpick*) oops

lemma n_distrib_alt': "n x \<cdot> n z = n y \<cdot> n z \<Longrightarrow> n x + n z = n y + n z \<Longrightarrow> n x = n y"
  using local.n_distrib_alt by auto

lemma test_distrib_alt: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<cdot> r = q \<cdot> r \<and> p + r = q + r \<longrightarrow> p = q"
  using n_distrib_alt by auto

lemma n_eq1: "n x \<cdot> y \<le> z \<and> t x \<cdot> y \<le> z \<longleftrightarrow> y \<le> z"
proof -
  have  "n x \<cdot> y \<le> z \<and> t x \<cdot> y \<le> z \<longleftrightarrow> n x \<cdot> y + t x \<cdot> y \<le> z"
    by simp
  also have "... \<longleftrightarrow> (n x + t x) \<cdot> y \<le> z"
    using local.distrib_right' by presburger
  finally show ?thesis
    by auto
qed

lemma test_eq1: "test p \<Longrightarrow> y \<le> x \<longleftrightarrow> p \<cdot> y \<le> x \<and> !p \<cdot> y \<le> x"
  using n_eq1 by auto

lemma n_dist_var1': "(n x + n y) \<cdot> (t x + n z) = t x \<cdot> n y + n x \<cdot> n z"
  by (metis add_transl local.n_dist_var1 local.test_mult)

lemma test_dist_var1: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> (p + q) \<cdot> (!p + r) = !p \<cdot> q + p \<cdot> r"
  using n_dist_var1' by fastforce

lemma n_dist_var2': "n (n x \<cdot> n y + t x \<cdot> n z) = n x \<cdot> t y + t x \<cdot> t z"
proof -
  have f1: "!x \<cdot> !y = !(!(!x \<cdot> !y))"
    using n_de_morgan_var3 t_de_morgan_var1 by presburger
  have "!(!(!x)) = !x"
    by simp
  thus ?thesis
    using f1 by (metis (no_types) n_de_morgan_var3 n_dist_var1' t_de_morgan_var1)
qed

lemma test_dist_var2: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> !(p \<cdot> q + !p \<cdot> r) = (p \<cdot> !q + !p \<cdot> !r)"
  using n_dist_var2' by auto

lemma test_restrictr: "test p \<Longrightarrow> x \<cdot> p \<le> x"
  (* nitpick *) oops

lemma test_eq2: "test p \<Longrightarrow> z \<le> p \<cdot> x + !p \<cdot> y \<longleftrightarrow> p \<cdot> z \<le> p \<cdot> x \<and> !p \<cdot> z \<le> !p \<cdot> y"
  (* nitpick *) oops

lemma test_eq3: "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q \<longleftrightarrow> p \<cdot> x \<le> x \<cdot> q"
  (* nitpick *) oops

lemma test1: "\<lbrakk>test p; test q; p \<cdot> x \<cdot> !q = 0\<rbrakk> \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; x \<cdot> !q = !p \<cdot> x \<cdot> !q\<rbrakk> \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
  (* nitpick *) oops

lemma comm_add: "\<lbrakk>test p; p\<cdot>x = x\<cdot>p; p\<cdot>y = y\<cdot>p\<rbrakk> \<Longrightarrow> p\<cdot>(x + y) = (x + y)\<cdot>p"
  (* nitpick *) oops

lemma comm_add_var: "\<lbrakk>test p; test q; test r; p\<cdot>x = x\<cdot>p; p\<cdot>y = y\<cdot>p\<rbrakk> \<Longrightarrow> p\<cdot>(q\<cdot>x + r\<cdot>y) = (q\<cdot>x + r\<cdot>y)\<cdot>p"
  (* nitpick *) oops

lemma "test p \<Longrightarrow> p \<cdot> x = x \<cdot> p \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> p \<and> !p \<cdot> x = !p \<cdot> x \<cdot> !p "
  (* nitpick *) oops

lemma test_distrib: "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> (p + q)\<cdot>(q\<cdot>y + !q\<cdot>x) = q\<cdot>y + !q\<cdot>p\<cdot>x"
  (* nitpick *) oops

end

subsection \<open>Test Near Semirings with Distributive Tests\<close>

text \<open>
  We now make the assumption that tests distribute over finite sums of arbitrary elements from the left.
  This can be justified in models such as multirelations and probabilistic predicate transformers.
\<close>

class test_near_semiring_zerol_distrib = test_near_semiring_zerol  +
  assumes n_left_distrib: "n x \<cdot> (y + z) = n x \<cdot> y + n x \<cdot> z"

begin

lemma n_left_distrib_var: "test p \<Longrightarrow> p \<cdot> (x + y) = p \<cdot> x + p \<cdot> y"
  using n_left_distrib by auto

lemma n_mult_left_iso: "x \<le> y \<Longrightarrow> n z \<cdot> x \<le> n z \<cdot> y"
  by (metis local.join.sup.absorb_iff1 local.n_left_distrib)

lemma test_mult_isol: "test p \<Longrightarrow> x \<le> y \<Longrightarrow> p \<cdot> x \<le> p \<cdot> y"
  using n_mult_left_iso by auto

lemma "test p \<Longrightarrow> x \<cdot> p \<le> x"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q \<longleftrightarrow> p \<cdot> x \<le> x \<cdot> q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; p \<cdot> x \<cdot> !q = 0\<rbrakk> \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; x \<cdot> !q = !p \<cdot> x \<cdot> !q\<rbrakk> \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
  (* nitpick *) oops

text \<open>Next, we study tests with commutativity conditions.\<close>

lemma comm_add: "test p \<Longrightarrow>  p \<cdot> x = x \<cdot> p \<Longrightarrow>  p \<cdot> y = y \<cdot> p \<Longrightarrow> p \<cdot> (x + y) = (x + y) \<cdot> p"
  by (simp add: n_left_distrib_var)

lemma comm_add_var: "test p \<Longrightarrow> test q \<Longrightarrow> test r \<Longrightarrow> p \<cdot> x = x \<cdot> p \<Longrightarrow> p \<cdot> y = y \<cdot> p \<Longrightarrow> p \<cdot> (q \<cdot> x + r \<cdot> y) = (q \<cdot> x + r \<cdot> y) \<cdot> p"
proof -
  assume a1: "test p"
  assume a2: "test q"
  assume a3: "p \<cdot> x = x \<cdot> p"
  assume a4: "test r"
  assume a5: "p \<cdot> y = y \<cdot> p"
  have f6: "p \<cdot> (q \<cdot> x) = q \<cdot> p \<cdot> x"
    using a2 a1 local.test_mult_comm_var mult_assoc by presburger
  have "p \<cdot> (r \<cdot> y) = r \<cdot> p \<cdot> y"
    using a4 a1 by (simp add: local.test_mult_comm_var mult_assoc)
  thus ?thesis
    using f6 a5 a3 a1 by (simp add: mult_assoc n_left_distrib_var)
qed

lemma test_distrib: "test p \<Longrightarrow> test q \<Longrightarrow> (p + q) \<cdot> (q \<cdot> y + !q \<cdot> x) = q \<cdot> y + !q \<cdot> p \<cdot> x"
proof -
  assume a: "test p" and b: "test q"
  hence "(p + q) \<cdot> (q \<cdot> y + !q \<cdot> x) = p \<cdot> q \<cdot> y + p \<cdot> !q \<cdot> x + q \<cdot> q \<cdot> y + q \<cdot> !q \<cdot> x"
    using local.add.assoc local.distrib_right' mult_assoc n_left_distrib_var by presburger
  also have "... = p \<cdot> q \<cdot> y + !q \<cdot> p \<cdot> x + q \<cdot> y"
   by (simp add: a b local.test_mult_comm_var)
  also have "... = (p + 1) \<cdot> q \<cdot> y + !q \<cdot> p \<cdot> x"
    using add_commute local.add.assoc by force
  also have "... = q \<cdot> y + !q \<cdot> p \<cdot> x"
    by (simp add: a local.join.sup.absorb2 local.test_subid)
  finally show ?thesis
    by simp
qed

end

subsection \<open>Test Predioids\<close>

text \<open>
  The following class is relevant for probabilistic Kleene algebras.
\<close>

class test_pre_dioid_zerol = test_near_semiring_zerol_distrib + pre_dioid

begin

lemma n_restrictr: "x \<cdot> n y \<le> x"
  using local.mult_isol local.n_subid' by fastforce

lemma test_restrictr: "test p \<Longrightarrow> x \<cdot> p \<le> x"
  using n_restrictr by fastforce

lemma n_kat_2: "n x \<cdot> y = n x \<cdot> y \<cdot> n z \<longleftrightarrow> n x \<cdot> y \<le> y \<cdot> n z"
proof
  assume "n x \<cdot> y = n x \<cdot> y \<cdot> n z"
  thus "n x \<cdot> y \<le> y \<cdot> n z"
    by (metis mult.assoc n_restrictl)
next
  assume "n x \<cdot> y \<le> y \<cdot> n z"
  hence "n x \<cdot> y  \<le> n x \<cdot> y \<cdot> n z"
    by (metis local.mult_isol local.n_mult_idem mult_assoc)
  thus "n x \<cdot> y  = n x \<cdot> y \<cdot> n z"
    by (simp add: local.order.antisym n_restrictr)
qed

lemma test_kat_2: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q \<longleftrightarrow> p \<cdot> x \<le> x \<cdot> q"
  using n_kat_2 by auto

lemma n_kat_2_opp: "y \<cdot> n z = n x \<cdot> y \<cdot> n z \<longleftrightarrow> y \<cdot> n z \<le> n x \<cdot> y"
  by (metis local.n_kat_21_opp n_restrictr)

lemma test_kat_2_opp: "test p \<Longrightarrow> test q \<Longrightarrow> x \<cdot> q  = p \<cdot> x \<cdot> q \<longleftrightarrow> x \<cdot> q \<le> p \<cdot> x"
  by (metis local.test_kat_21_opp test_restrictr)

lemma "\<lbrakk>test p; test q; p\<cdot>x\<cdot>!q = 0\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>x\<cdot>q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; x\<cdot>!q = !p\<cdot>x\<cdot>!q\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>x\<cdot>q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> x \<cdot> (p + q) \<le> x \<cdot> p + x \<cdot> q"
  (* nitpick *) oops

end

text \<open>
  The following class is relevant for Demonic Refinement Algebras.
\<close>

class test_semiring_zerol = test_near_semiring_zerol + semiring_one_zerol

begin

subclass dioid_one_zerol ..

subclass test_pre_dioid_zerol
proof
show "\<And>x y z. !x \<cdot> (y + z) = !x \<cdot> y + !x \<cdot> z"
  by (simp add: local.distrib_left)
qed

lemma n_kat_31: "n x \<cdot> y \<cdot> t z = 0 \<Longrightarrow> n x \<cdot> y \<cdot> n z = n x \<cdot> y"
proof -
  assume a: "n x \<cdot> y \<cdot> t z = 0"
  have "n x \<cdot> y = n x \<cdot> y \<cdot> (n z + t z)"
    by simp
  also have "... = n x \<cdot> y \<cdot> n z + n x \<cdot> y \<cdot> t z"
    using local.distrib_left by blast
  finally show "n x \<cdot> y \<cdot> n z = n x \<cdot> y"
    using a  by auto
qed

lemma test_kat_31: "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> x \<cdot> !q = 0 \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
  by (metis local.test_double_comp_var n_kat_31)

lemma n_kat_var: "t x \<cdot> y \<cdot> t z = y \<cdot> t z \<Longrightarrow> n x \<cdot> y \<cdot> n z = n x \<cdot> y"
  using local.n_kat_1_var n_kat_31 by blast

lemma test1_var: "test p \<Longrightarrow> test q \<Longrightarrow> x \<cdot> !q = !p \<cdot> x \<cdot> !q \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> q"
  by (metis local.test_eq4 test_kat_31)

lemma "\<lbrakk>test p; test q; p\<cdot>x\<cdot>!q = 0\<rbrakk> \<Longrightarrow> !p\<cdot>x\<cdot>q = 0"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; p\<cdot>x = p\<cdot>x\<cdot>q\<rbrakk> \<Longrightarrow> x\<cdot>!q = !p\<cdot>x\<cdot>!q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; p\<cdot>x = p\<cdot>x\<cdot>q\<rbrakk> \<Longrightarrow> p\<cdot>x\<cdot>!q = 0"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; p\<cdot>x = p\<cdot>x\<cdot>q\<rbrakk> \<Longrightarrow> !p\<cdot>x\<cdot>q = 0"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; x\<cdot>!q = !p\<cdot>x\<cdot>!q\<rbrakk> \<Longrightarrow> !p\<cdot>x\<cdot>q = 0"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; !p\<cdot>x\<cdot>q = 0\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>x\<cdot>q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; !p\<cdot>x\<cdot>q = 0\<rbrakk> \<Longrightarrow> x\<cdot>!q = !p\<cdot>x\<cdot>!q"
  (* nitpick *) oops

lemma "\<lbrakk>test p; test q; !p\<cdot>x\<cdot>q = 0\<rbrakk> \<Longrightarrow> p\<cdot>x\<cdot>!q = 0"
  (* nitpick *) oops

lemma "test p \<Longrightarrow> p \<cdot> x = p \<cdot> x \<cdot> p \<and> !p \<cdot> x = !p \<cdot> x \<cdot> !p \<Longrightarrow> p \<cdot> x = x \<cdot> p"
  (* nitpick *) oops

end

subsection \<open>Test Semirings\<close>

text \<open>
  The following class is relevant for Kleene Algebra with Tests.
\<close>

class test_semiring = test_semiring_zerol + semiring_one_zero

begin

lemma n_kat_1: "n x \<cdot> y \<cdot> t z = 0 \<longleftrightarrow> n x \<cdot> y \<cdot> n z = n x \<cdot> y"
  by (metis local.annir local.n_kat_31 local.test_mult_comp mult_assoc)

lemma test_kat_1': "test p \<Longrightarrow> test q \<Longrightarrow> p \<cdot> x \<cdot> !q = 0 \<longleftrightarrow> p \<cdot> x =  p \<cdot> x \<cdot> q"
  by (metis local.test_double_comp_var n_kat_1)

lemma n_kat_3: "n x \<cdot> y \<cdot> t z = 0 \<longleftrightarrow> n x \<cdot> y \<le> y \<cdot> n z"
  using local.n_kat_2 n_kat_1 by force

lemma test_kat_3: "test p \<Longrightarrow> test q \<Longrightarrow>  p \<cdot> x \<cdot> !q = 0 \<longleftrightarrow> p \<cdot> x \<le> x \<cdot> q"
  using n_kat_3 by auto

lemma n_kat_prop: "n x \<cdot> y \<cdot> n z = n x \<cdot> y \<longleftrightarrow> t x \<cdot> y \<cdot> t z = y \<cdot> t z"
  by (metis local.annir local.n_kat_1_opp local.n_kat_var local.t_n_closed local.test_mult_comp mult_assoc)

lemma test_kat_prop: "test p \<Longrightarrow> test q  \<Longrightarrow>  p \<cdot> x = p \<cdot> x \<cdot> q  \<longleftrightarrow> x \<cdot> !q = !p \<cdot> x \<cdot> !q"
  by (metis local.annir local.test1_var local.test_comp_mult2 local.test_eq4 mult_assoc)

lemma n_kat_3_opp: "t x \<cdot> y \<cdot> n z = 0 \<longleftrightarrow> y \<cdot> n z \<le> n x \<cdot> y"
  by (metis local.n_kat_1_var local.n_kat_2_opp local.t_n_closed)

lemma kat_1_var: "n x \<cdot> y \<cdot> n z = y \<cdot> n z \<longleftrightarrow> y \<cdot> n z \<le> n x \<cdot> y"
  using local.n_kat_2_opp by force

lemma "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> (p\<cdot>x\<cdot>!q = 0) \<Longrightarrow> (!p\<cdot>x\<cdot>q = 0)"
  (* nitpick *) oops

lemma "n x \<cdot> y + t x \<cdot> z = n x \<cdot> y \<or> n x \<cdot> y + t x \<cdot> z = t x \<cdot> z"
(*nitpick*)
oops

end

end