theory Kruskal
  imports
    "./Graph_Definition"
    "./SeprefUF"
    Refine_Imperative_HOL.IICF
begin

definition corresponding_union_find :: "'v per \<Rightarrow> ('v, 'w) graph \<Rightarrow> bool"
  where "corresponding_union_find uf H \<equiv> (\<forall>a\<in>nodes H. \<forall>b\<in>nodes H.
      per_compare uf a b \<longleftrightarrow> (nodes_connected H a b))"

definition "uf_graph_invar uf_H \<equiv> case uf_H of (uf, H) \<Rightarrow>
    part_equiv uf \<and>
    corresponding_union_find uf H \<and>
    Domain uf = nodes H"

definition "uf_graph_rel \<equiv> br snd uf_graph_invar"

definition "graph_of_list l \<equiv> \<lparr>
  nodes = fst`set l \<union> (snd o snd)`set l,
  edges = set l \<rparr>"

definition "lst_graph_rel \<equiv> br graph_of_list (\<lambda>_. True)"

definition "lst_subgraph_invar l \<equiv> distinct l"
definition "subgraph_of_lst G l \<equiv> \<lparr>
  nodes = nodes G,
  edges = set l \<rparr>"
definition "lst_subgraph_rel G \<equiv> br (subgraph_of_lst G) lst_subgraph_invar"

definition "is_linorder_rel R \<equiv> (\<forall>x y. R x y \<or> R y x) \<and> (\<forall>x y z. R x y \<longrightarrow> R y z \<longrightarrow> R x z)"

definition "max_node l \<equiv> Max (insert 0 (nodes (graph_of_list l))) + 1"

lemma max_node_impl[code]: "max_node l = fold (\<lambda>(u,_,w) x. max u (max w x)) l 0 + 1"
proof -
  have "fold (\<lambda>(u,_,w) x. max u (max w x)) l a = Max (insert a (nodes (graph_of_list l)))" for a
    apply (induction l arbitrary: a)
    apply (auto simp: graph_of_list_def)
    subgoal for a b l aa
      apply (cases l)
      by (auto simp: ac_simps)
    done
  thus ?thesis unfolding max_node_def by auto
qed

locale Kruskal = finite_weighted_graph G
  for G :: "('v,'w::weight) graph"
begin

section \<open>Kruskal 0\<close>

definition empty_forest :: "('v, 'w) graph"
  where "empty_forest \<equiv> \<lparr> nodes = V, edges = {} \<rparr>"

definition previous_nodes_connected :: "('v, 'w) graph \<Rightarrow> ('v \<times> 'w \<times> 'v) set \<Rightarrow> bool"
  where "previous_nodes_connected H E' \<equiv>
    (\<forall>(a, w, b)\<in>E - E'. nodes_connected H a b)"

definition exists_min_spanning_forest :: "('v, 'w) graph \<Rightarrow> bool"
  where "exists_min_spanning_forest H \<equiv>
    (\<exists>T. subgraph H T \<and> minimum_spanning_forest T G)"

definition loop_invar_kruskal :: "('v \<times> 'w \<times> 'v) set \<Rightarrow> ('v, 'w) graph \<Rightarrow> bool"
  where "loop_invar_kruskal E' H \<equiv>
    forest H \<and>
    subgraph H G \<and>
    previous_nodes_connected H E' \<and>
    exists_min_spanning_forest H"

definition kruskal0 :: "('v, 'w) graph nres"
  where "kruskal0 \<equiv> do {
    l \<leftarrow> SPEC (\<lambda>l. set l = E \<and> sorted_by_rel edges_less_eq l);
    spanning_forest \<leftarrow> nfoldli l (\<lambda>_. True)
      (\<lambda>(a, w, b) H. do {
        ASSERT (subgraph H G);
        ASSERT (a\<in>V \<and> b\<in>V);
        if (nodes_connected H a b)
        then
          RETURN H
        else do {
          ASSERT ((a, w, b) \<in> E - edges H);
          RETURN (add_edge a w b H)
        }
      }) empty_forest;
    RETURN spanning_forest
  }"

lemma empty_forest_valid: "valid_graph empty_forest"
  unfolding empty_forest_def valid_graph_def
  by auto

lemma empty_exists_min_spanning_forest: "exists_min_spanning_forest empty_forest"
proof -
  from minimum_spanning_forest_exists obtain T where "minimum_spanning_forest T G"
    by auto
  moreover from this have "subgraph empty_forest T"
    unfolding subgraph_def empty_forest_def minimum_spanning_forest_def
      spanning_forest_def
    by simp
  ultimately show ?thesis
    unfolding exists_min_spanning_forest_def
    by auto
qed

lemma loop_invar_kruskal_empty: "loop_invar_kruskal E empty_forest"
  using empty_forest_valid empty_exists_min_spanning_forest
  unfolding loop_invar_kruskal_def empty_forest_def forest_def
    forest_axioms_def subgraph_def previous_nodes_connected_def
  by auto

lemma loop_invar_kruskal_valid_graph:
  assumes "loop_invar_kruskal E' H"
  shows "valid_graph H"
  using assms
  unfolding loop_invar_kruskal_def forest_def by simp

lemma loop_invar_kruskal_subgraph:
  assumes "loop_invar_kruskal E' H"
  shows "subgraph H G"
  using assms
  unfolding loop_invar_kruskal_def by simp

lemma loop_invar_kruskal_edge_not_in_graph:
  assumes invar: "loop_invar_kruskal (insert (a, w, b) E') H"
  assumes "(a, w, b) \<in> E"
  assumes "\<not> nodes_connected H a b"
  shows "(a, w, b) \<notin> edges H"
proof -
  from assms have "\<not> is_path_undir H a [(a, w, b)] b"
    by blast
  with \<open>(a, w, b)\<in>E\<close> valid_graph.is_path_undir_simps(2)[OF
      valid_subgraph[OF loop_invar_kruskal_subgraph[OF invar]]]
  show ?thesis
    by auto
qed

lemma preserve_previous_nodes_connected_no_add:
  assumes "previous_nodes_connected H (insert (a, w, b) E')"
  assumes "nodes_connected H a b"
  shows "previous_nodes_connected H E'"
  using assms
  unfolding previous_nodes_connected_def
  by blast

lemma preserve_previous_nodes_connected_add:
  assumes "previous_nodes_connected H (insert (a, w, b) E')"
  assumes "valid_graph H"
  shows "previous_nodes_connected (add_edge a w b H) E'"
  using assms
proof -
  have "nodes_connected (add_edge a w b H) v v'"
    if e: "(v, w', v')\<in>E - E'" for v w' v'
  proof (cases "(v, w', v') = (a, w, b)")
    case True
    with valid_graph.add_edge_is_connected[OF \<open>valid_graph H\<close>] show ?thesis
      by simp
  next
    case False
    with assms(1) e valid_graph.add_edge_is_path[OF \<open>valid_graph H\<close>]
    show ?thesis
      unfolding previous_nodes_connected_def
      by blast
  qed
  then show ?thesis
    unfolding previous_nodes_connected_def
    by auto
qed

lemma exists_min_spanning_forest_add:
  assumes "exists_min_spanning_forest H"
  assumes "previous_nodes_connected H (insert (a, w, b) (set l2))"
  assumes "subgraph H G"
  assumes "(a,w,b) \<in> E"
  assumes "\<not> nodes_connected H a b"
  assumes "sorted_by_rel edges_less_eq (l1 @ (a, w, b) # l2)"
  shows "exists_min_spanning_forest (add_edge a w b H)"
proof -
  from \<open>exists_min_spanning_forest H\<close> obtain F where subgraph_H_F: "subgraph H F"
      and msf_F: "minimum_spanning_forest F G"
      and valid_F: "valid_graph F" and forest_F: "forest F"
      and maximally_connected_F: "maximally_connected F G"
      and subgraph_F: "subgraph F G"
    unfolding exists_min_spanning_forest_def minimum_spanning_forest_def
      spanning_forest_def forest_def
    by blast
  from subgraph_F finite_E have finite_F: "finite (edges F)"
    unfolding subgraph_def by (auto simp: finite_subset)
  from subgraph_node[OF subgraph_F] E_validD[OF \<open>(a,w,b)\<in>E\<close>]
    have ab: "a\<in>nodes F" "b\<in>nodes F"
    by auto
  from valid_subgraph[OF \<open>subgraph H G\<close>]
  have valid_H: "valid_graph H"
    unfolding forest_def
    by simp
  show ?thesis
  proof (cases "(a,w,b) \<in> edges F")
    case True
    with subgraph_H_F ab have "subgraph (add_edge a w b H) F"
      unfolding subgraph_def add_edge_def
      by auto
    with msf_F show ?thesis
      unfolding exists_min_spanning_forest_def
      by auto
  next
    case False
    from maximally_connected_F \<open>(a,w,b)\<in>E\<close> is_path_undir_simps(2)[of a w b]
    have  "nodes_connected F a b"
      unfolding maximally_connected_def
      by (meson E_validD)
    from forest.delete_edge_from_path[OF forest_F this subgraph_H_F \<open>\<not> nodes_connected H a b\<close>]
    obtain x w' y where xy: "(x, w', y) \<in> edges F" "(x, w', y) \<notin> edges H" and
      not_connected: "\<not> nodes_connected (delete_edge x w' y F) a b" and
      connected_xy: "nodes_connected (add_edge a w b (delete_edge x w' y F)) x y"
      by blast
    obtain F' where F': "F' = add_edge a w b (delete_edge x w' y F)"
      by blast
    from valid_F have valid_delete_F: "valid_graph (delete_edge x w' y F)"
      by simp
    with F' have valid_F': "valid_graph F'"
      by simp
    from False have False': "(a, w, b) \<notin> edges (delete_edge x w' y F)"
      unfolding delete_edge_def by simp
    from forest.forest_delete_edge[OF forest_F]
    have forest_delete_F: "forest (delete_edge x w' y F)"
      by simp
    from False xy(1) have ab_neq_xy: "(x, w', y) \<noteq> (a, w, b)"
      by auto
    from F' subgraph_F \<open>(a,w,b) \<in> E\<close> have subgraph_F': "subgraph F' G"
      unfolding subgraph_def
      by (auto simp: E_validD)
    from subgraph_H_F xy have subgraph_H_delete_T: "subgraph H (delete_edge x w' y F)"
      unfolding subgraph_def delete_edge_def
      by auto
    have "\<not> nodes_connected H x y"
    proof
      assume asm: "nodes_connected H x y"
      from forest.cycle_free[OF forest_F] xy(1)
        have contr: "\<not> nodes_connected (delete_edge x w' y F) x y"
        by auto
      with asm valid_graph.is_path_undir_subgraph[OF valid_delete_F _ subgraph_H_delete_T]
      show False by blast
    qed
    with assms(2) ab_neq_xy have "(x, w', y) \<notin> E - (set l2)"
      unfolding previous_nodes_connected_def by blast
    moreover from xy(1) subgraph_F have "(x, w', y) \<in> E"
      unfolding subgraph_def
      by auto
    ultimately have "(x, w', y) \<in> set l2"
      by auto
    with assms(6) sorted_by_rel_append[of edges_less_eq l1 "(a, w, b) # l2"]
      sorted_by_rel_Cons[of edges_less_eq "(a, w, b)" l2]
    have *: "w \<le> w'"
      unfolding edges_less_eq_def
      by auto
    with F' False xy(1) finite_F sum.subset_diff[of "{(x, w', y)}" "edges F" "fst \<circ> snd"]
    have improvement: "edge_weight F' \<le> edge_weight F"
      unfolding edge_weight_def
      apply auto
      apply(subst ab_semigroup_add.add_commute[OF class.ordered_ab_semigroup_add.axioms(1)[OF class.weight.axioms(2)[OF weight_class.weight_axioms]], of _ w'])
      apply(auto simp: add_right_mono)
      done
    from F' subgraph_H_delete_T have "subgraph (add_edge a w b H) F'"
      unfolding subgraph_def
      by auto
    moreover from F' ab forest.forest_add_edge[OF forest_delete_F _ _ not_connected]
      have "forest F'"
        by simp
    moreover from connected_xy F' swap_delete_add_edge[OF ab_neq_xy, of F]
      delete_edge_maximally_connected[OF
        add_edge_maximally_connected[OF maximally_connected_F subgraph_F \<open>(a,w,b)\<in>E\<close>]
        add_edge_preserve_subgraph[OF subgraph_F \<open>(a,w,b)\<in>E\<close>]]
      have "maximally_connected F' G"
      unfolding subgraph_def by metis
    moreover from improvement msf_F have "optimal_forest F' G"
      unfolding minimum_spanning_forest_def optimal_forest_def
      by auto
    ultimately show ?thesis using subgraph_F'
      unfolding exists_min_spanning_forest_def minimum_spanning_forest_def
        spanning_forest_def
      by auto
  qed
qed

lemma union_preserves_forest:
  assumes "forest H"
  assumes "\<not> nodes_connected H a b"
  assumes "subgraph H G"
  assumes "a \<in> V"
  assumes "b \<in> V"
  shows "forest (add_edge a w b H)"
  using forest.forest_add_edge[OF \<open>forest H\<close> _ _ \<open>\<not>nodes_connected H a b\<close>]
    subgraph_node[OF \<open>subgraph H G\<close>] \<open>a\<in>V\<close> \<open>b\<in>V\<close>
  by simp

lemma union_preserves_loop_invar:
  assumes "loop_invar_kruskal (insert (a, w, b) (set l2)) H"
  assumes "\<not> nodes_connected H a b"
  assumes "insert (a, w, b) (set l1 \<union> set l2) = E"
  assumes "sorted_by_rel edges_less_eq (l1 @ (a, w, b) # l2)"
  shows "loop_invar_kruskal (set l2) (add_edge a w b H)"
  using assms insertI1[of "(a, w, b)" "(set l1 \<union> set l2)"]
  unfolding loop_invar_kruskal_def
  apply (auto simp: add_edge_preserve_subgraph)
  apply (meson E_validD union_preserves_forest)
  apply (auto simp: valid_subgraph E_validD exists_min_spanning_forest_add
          dest: preserve_previous_nodes_connected_add)
  done

lemma same_component_preserves_loop_invar:
  assumes "loop_invar_kruskal (insert (a, w, b) E') H"
  assumes "nodes_connected H a b"
  shows "loop_invar_kruskal E' H"
  using assms preserve_previous_nodes_connected_no_add
  unfolding loop_invar_kruskal_def
  by blast

lemma loop_invar_kruskal_final:
  assumes "loop_invar_kruskal {} H"
  shows "minimum_spanning_forest H G"
proof -
  from assms obtain T where T: "subgraph H T" "minimum_spanning_forest T G"
    unfolding loop_invar_kruskal_def exists_min_spanning_forest_def by auto
  with assms sub_spanning_forest_eq[of H T]
  show ?thesis
    unfolding loop_invar_kruskal_def minimum_spanning_forest_def
      spanning_forest_def previous_nodes_connected_def
    by simp
qed

theorem kruskal0_refine: "(kruskal0, SPEC (\<lambda>F. minimum_spanning_forest F G))\<in>\<langle>Id\<rangle>nres_rel"
  unfolding kruskal0_def
  apply(refine_vcg nfoldli_rule[where I="\<lambda>l1 l2 s. loop_invar_kruskal (set l2) s"])
  apply (auto
      simp: finite_E loop_invar_kruskal_empty loop_invar_kruskal_final
            loop_invar_kruskal_subgraph
      dest: same_component_preserves_loop_invar
            loop_invar_kruskal_edge_not_in_graph
            union_preserves_loop_invar)
  apply (metis insertI1 E_validD(1))
  apply (metis insertI1 E_validD(2))
  done

section \<open>Kruskal 1\<close>

definition kruskal1 :: "('v, 'w) graph nres"
  where "kruskal1 \<equiv> do {
    let initial_union_find = per_init V;
    l \<leftarrow> SPEC (\<lambda>l. set l = E \<and> sorted_by_rel edges_less_eq l);
    (per, spanning_forest) \<leftarrow> nfoldli l (\<lambda>_. True)
      (\<lambda>(a, w, b) (uf, H). do {
        ASSERT (a\<in>Domain uf \<and> b\<in>Domain uf);
        if per_compare uf a b
        then
          RETURN (uf, H)
        else do {
          let uf = per_union uf a b;
          ASSERT ((a, w, b) \<in> E - edges H);
          RETURN (uf, add_edge a w b H)
        }
      }) (initial_union_find, empty_forest);
    RETURN spanning_forest
  }"

lemma preserve_corresponding_union_find_add:
  assumes "corresponding_union_find uf H"
  assumes "a \<in> V"
  assumes "b \<in> V"
  assumes "Domain uf = nodes H"
  assumes "subgraph H G"
  assumes PER: "part_equiv uf"
  shows "corresponding_union_find (per_union uf a b) (add_edge a w b H)"
proof -
  from valid_subgraph[OF \<open>subgraph H G\<close>]
  have valid_H: "valid_graph H" .
  from \<open>subgraph H G\<close>
  have nodes_H: "nodes H = V"
    unfolding subgraph_def ..
  with \<open>a\<in>V\<close> \<open>b\<in>V\<close>
  have nodes_add_H: "nodes (add_edge a w b H) = nodes H"
    by auto
  have "(nodes_connected (add_edge a w b H) x y) \<longleftrightarrow> (x,y) \<in> per_union uf a b"
    if xy: "x\<in>nodes (add_edge a w b H) \<and> y\<in>nodes (add_edge a w b H)" for x y
  proof
    assume "nodes_connected (add_edge a w b H) x y"
    then obtain p where p: "is_path_undir (add_edge a w b H) x p y"
      by blast
    from \<open>a\<in>V\<close> \<open>b\<in>V\<close> \<open>Domain uf = nodes H\<close> nodes_H
    have [simp]: "a\<in>Domain (per_union uf a b)" "b\<in>Domain (per_union uf a b)"
      by auto
    from PER have PER': "part_equiv (per_union uf a b)"
      by (auto simp: union_part_equivp)
    show "(x,y) \<in> per_union uf a b"
    proof (cases "(a, w, b) \<in> set p \<or> (b, w, a) \<in> set p")
      case True
      from valid_graph.is_path_undir_split_distinct[OF add_edge_valid[OF valid_H] p True]
      obtain p' p'' u u' where
        "is_path_undir (add_edge a w b H) x p' u \<and>
        is_path_undir (add_edge a w b H) u' p'' y" and
        u: "u\<in>{a,b} \<and> u'\<in>{a,b}" and
        "(a, w, b) \<notin> set p' \<and> (b, w, a) \<notin> set p' \<and>
        (a, w, b) \<notin> set p'' \<and> (b, w, a) \<notin> set p''"
        by auto
      with \<open>a\<in>V\<close> \<open>b\<in>V\<close> \<open>Domain uf = nodes H\<close> \<open>subgraph H G\<close>
        valid_graph.add_edge_was_path[OF valid_H]
      have "is_path_undir H x p' u \<and> is_path_undir H u' p'' y"
        unfolding subgraph_def by auto
      with assms(1-5) xy u nodes_H have comps: "(x,u) \<in> uf \<and> (u', y) \<in> uf"
        unfolding corresponding_union_find_def
        by auto
      from comps per_union_impl have "(x,u) \<in> per_union uf a b"
        by auto
      also from u \<open>a\<in>V\<close> \<open>b\<in>V\<close> \<open>Domain uf = nodes H\<close> nodes_H
        part_equiv_refl'[OF PER' \<open>a\<in>Domain (per_union uf a b)\<close>]
        part_equiv_refl'[OF PER' \<open>b\<in>Domain (per_union uf a b)\<close>] part_equiv_sym[OF PER']
        per_union_related[OF PER]
      have "(u,u') \<in> per_union uf a b"
        by auto
      also (part_equiv_trans[OF PER']) from comps per_union_impl
      have "(u',y) \<in> per_union uf a b"
        by auto
      finally (part_equiv_trans[OF PER']) show ?thesis by simp
    next
      case False
      with \<open>a\<in>V\<close> \<open>b\<in>V\<close> nodes_H valid_graph.add_edge_was_path[OF valid_H p(1)]
      have "is_path_undir H x p y"
        by auto
      with assms(1) xy nodes_add_H have "(x,y)\<in>uf"
        unfolding corresponding_union_find_def
        by auto
      from per_union_impl[OF this] show ?thesis .
    qed
  next
    assume asm: "(x, y) \<in> per_union uf a b"
    show "nodes_connected (add_edge a w b H) x y"
      proof (cases "(x, y) \<in> uf")
        case True
        with assms(1) xy nodes_add_H have "nodes_connected H x y"
          unfolding corresponding_union_find_def
          by auto
        with valid_graph.add_edge_is_path[OF valid_H] show ?thesis
          by blast
      next
        case False
        with asm part_equiv_sym[OF PER]
        have "(x,a) \<in> uf \<and> (b,y) \<in> uf \<or>
              (x,b) \<in> uf \<and> (a,y) \<in> uf"
          unfolding per_union_def
          by auto
        with assms(1) \<open>a\<in>V\<close> \<open>b\<in>V\<close> xy nodes_H nodes_add_H obtain p q p' q'
          where "is_path_undir H x p a \<and> is_path_undir H b q y \<or>
                 is_path_undir H x p' b \<and> is_path_undir H a q' y"
          unfolding corresponding_union_find_def
          by fastforce
        with valid_graph.add_edge_is_path[OF valid_H]
        have "is_path_undir (add_edge a w b H) x p a \<and>
              is_path_undir (add_edge a w b H) b q y \<or>
              is_path_undir (add_edge a w b H) x p' b \<and>
              is_path_undir (add_edge a w b H) a q' y"
          by blast
        with valid_graph.is_path_undir_split'[OF add_edge_valid[OF valid_H]]
        have "is_path_undir (add_edge a w b H) x (p @ (a, w, b) # q) y \<or>
              is_path_undir (add_edge a w b H) x (p' @ (b, w, a) # q') y"
          by auto
        with valid_graph.is_path_undir_sym[OF add_edge_valid[OF valid_H]]
        show ?thesis
          by blast
      qed
  qed
  then show ?thesis unfolding corresponding_union_find_def by auto
qed

lemma corresponding_union_find_empty:
  shows "corresponding_union_find (per_init V) empty_forest"
proof -
  have "(nodes_connected empty_forest a b) \<longleftrightarrow> (a,b) \<in> per_init V"
    if ab: "a\<in>V \<and> b\<in>V" for a b
  proof
    assume "nodes_connected empty_forest a b"
    then obtain p where p: "is_path_undir empty_forest a p b"
      by blast
    then have "a = b"
      unfolding empty_forest_def
      by (induction p) auto
    with ab show "(a,b) \<in> per_init V"
      by (auto intro: part_equiv_refl')
  next
    assume "(a,b) \<in> per_init V"
    hence "a=b" by (auto intro: per_init_self)
    from ab have "is_path_undir empty_forest a [] a"
      unfolding empty_forest_def
      by auto
    with \<open>a=b\<close> show "nodes_connected empty_forest a b"
      by blast
  qed
  then show ?thesis
    unfolding corresponding_union_find_def empty_forest_def
    by simp
qed

lemma empty_forest_refine1: "((per_init V, empty_forest), empty_forest)\<in>uf_graph_rel"
  using corresponding_union_find_empty
  unfolding  uf_graph_rel_def uf_graph_invar_def empty_forest_def
  by (auto simp: in_br_conv)

theorem kruskal1_refine: "(kruskal1, kruskal0)\<in>\<langle>Id\<rangle>nres_rel"
  unfolding kruskal1_def kruskal0_def
  apply (rewrite at "let initial_union_find = per_init V in _" Let_def)
  apply (refine_rcg empty_forest_refine1)
  apply refine_dref_type
  unfolding uf_graph_rel_def uf_graph_invar_def
  apply (simp add: in_br_conv subgraph_def)+
  apply (simp add: corresponding_union_find_def)
  apply (auto simp: in_br_conv preserve_corresponding_union_find_add union_part_equivp)
  done

end

section \<open>Kruskal 2\<close>

locale Kruskal_list = Kruskal "graph_of_list l"
  for l :: "('v \<times> 'w::weight \<times> 'v) list"
begin

abbreviation "G\<equiv>graph_of_list l"

lemma l_G_refine: "(l, G) \<in> lst_graph_rel"
  unfolding lst_graph_rel_def
  by (auto simp: in_br_conv)

lemma E_impl: "set l = E"
  unfolding graph_of_list_def
  by simp

definition kruskal2 :: "('v, 'w) graph nres"
  where "kruskal2 \<equiv> do {
    let initial_union_find = per_init (V);
    let l = quicksort_by_rel edges_less_eq [] l;
    (per, spanning_forest) \<leftarrow> nfoldli l (\<lambda>_. True)
      (\<lambda>(a, w, b) (uf, H). do {
        ASSERT (a\<in>Domain uf \<and> b\<in>Domain uf);
        if per_compare uf a b
        then
          RETURN (uf, H)
        else do {
          let uf = per_union uf a b;
          ASSERT ((a, w, b) \<in> E - edges H);
          RETURN (uf, add_edge a w b H)
        }
      }) (initial_union_find, empty_forest);
    RETURN spanning_forest
  }"

lemma edges_less_eq_linorder: "is_linorder_rel edges_less_eq"
  unfolding edges_less_eq_def is_linorder_rel_def
  by (metis linear order_trans)

lemma sort_edges_correct: "sorted_by_rel edges_less_eq (quicksort_by_rel edges_less_eq [] l)"
  by (metis (no_types, hide_lams) edges_less_eq_linorder is_linorder_rel_def sorted_by_rel_quicksort_by_rel)

theorem kruskal2_refine: "(kruskal2, kruskal1)\<in>\<langle>Id\<rangle>nres_rel"
  unfolding kruskal2_def kruskal1_def
  apply (refine_rcg)
  apply refine_dref_type
  apply (vc_solve simp: E_impl sort_edges_correct)
  done

section \<open>Kruskal 3\<close>

definition "lst_empty_forest \<equiv> []"

definition kruskal3 :: "('v \<times> 'w \<times> 'v) list nres"
  where "kruskal3 \<equiv> do {
    let initial_union_find = per_init V;
    (per, spanning_forest) \<leftarrow> nfoldli (quicksort_by_rel edges_less_eq [] l) (\<lambda>_. True)
      (\<lambda>(a, w, b) (uf, l_H). do {
        ASSERT (a\<in>Domain uf \<and> b\<in>Domain uf);
        if per_compare uf a b
        then
          RETURN (uf, l_H)
        else do {
          let uf = per_union uf a b;
          RETURN (uf, (a, w, b)#l_H)
        }
      }) (initial_union_find, lst_empty_forest);
    RETURN spanning_forest
  }"

lemma add_edge_refine:
  assumes "(l_H, H) \<in> lst_subgraph_rel G"
  assumes "(a, w, b) \<in> E - edges H"
  shows "((a, w, b) # l_H, add_edge a w b H) \<in> lst_subgraph_rel G"
  using assms
  unfolding add_edge_def lst_subgraph_rel_def lst_subgraph_invar_def list_set_rel_def subgraph_of_lst_def
  by (auto simp: in_br_conv E_validD)

lemma empty_forest_refine3: "((per_init V, lst_empty_forest), (per_init V, empty_forest))\<in>Id \<times>\<^sub>r lst_subgraph_rel G"
  unfolding empty_forest_def lst_empty_forest_def lst_subgraph_rel_def lst_subgraph_invar_def subgraph_of_lst_def
  by (auto simp: in_br_conv)

theorem kruskal3_refine: "(kruskal3, kruskal2)\<in>\<langle>lst_subgraph_rel G\<rangle>nres_rel"
  unfolding kruskal3_def kruskal2_def
  apply (rewrite at "let l = quicksort_by_rel edges_less_eq [] l in _" Let_def)
  apply (refine_vcg empty_forest_refine3)
  apply refine_dref_type
  using add_edge_refine
  by auto

end

section \<open>Kruskal 4\<close>

locale Kruskal_list_nat = Kruskal_list l for
  l :: "(nat \<times> int \<times> nat) list"
begin

definition kruskal4 :: "(nat \<times> int \<times> nat) list nres"
  where "kruskal4 \<equiv> do {
    let initial_union_find = per_init' (max_node l);
    (per, spanning_forest) \<leftarrow> nfoldli (quicksort_by_rel edges_less_eq [] l) (\<lambda>_. True)
      (\<lambda>(a, w, b) (uf, l_H). do {
        ASSERT (a\<in>Domain uf \<and> b\<in>Domain uf);
        if per_compare uf a b
        then
          RETURN (uf, l_H)
        else do {
          let uf = per_union uf a b;
          RETURN (uf, (a, w, b)#l_H)
        }
      }) (initial_union_find, []);
    RETURN spanning_forest
  }"

lemma per_initN_refine: "(per_init' (max_node l), per_init V) \<in> per_supset_rel"
  unfolding per_supset_rel_def per_init'_def per_init_def max_node_def
  by (auto simp: less_Suc_eq_le finite_V)

theorem kruskal4_refine: "(kruskal4, kruskal3)\<in>\<langle>Id\<rangle>nres_rel"
  unfolding kruskal4_def kruskal3_def lst_empty_forest_def
  apply (refine_vcg)
  supply RELATESI[where R="per_supset_rel::(nat per \<times> _) set", refine_dref_RELATES]
  apply refine_dref_type
  apply (vc_solve simp: per_initN_refine)
  apply (auto dest: per_supset_rel_dom per_supset_compare per_supset_union)
  done

end

section \<open>Kruskal 5\<close>

concrete_definition kruskal5 uses Kruskal_list_nat.kruskal4_def

section \<open>Kruskal\<close>

definition "sort_edges \<equiv> quicksort_by_rel edges_less_eq []"

lemma [sepref_import_param]: "(sort_edges,sort_edges)\<in>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel" by simp
lemma [sepref_import_param]: "(max_node, max_node) \<in> \<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow> nat_rel" by simp

sepref_definition kruskal is
  "kruskal5" :: "(list_assn (nat_assn\<times>\<^sub>aint_assn\<times>\<^sub>anat_assn))\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
  unfolding kruskal5_def sort_edges_def[symmetric]
  apply (rewrite at "nfoldli _ _ _ (_,\<hole>)" HOL_list.fold_custom_empty)
  by sepref

context Kruskal_list_nat begin
  lemmas kruskal5_ref_spec = kruskal4_refine[
    unfolded kruskal5.refine[OF Kruskal_list_nat_axioms],
    FCOMP kruskal3_refine,
    FCOMP kruskal2_refine,
    FCOMP kruskal1_refine,
    FCOMP kruskal0_refine
    ]

  lemma kruskal6_refine: "(uncurry0 (kruskal l), uncurry0 (kruskal5 l))
    \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
    using kruskal.refine
    unfolding list_assn_pure_conv prod_assn_pure_conv
    unfolding hfref_def hn_refine_def pure_def hn_ctxt_def
    by auto

  lemma [fcomp_norm_simps]: "list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn) = id_assn"
    by (auto simp: list_assn_pure_conv)

  lemmas kruskal_ref_spec = kruskal6_refine[FCOMP kruskal5_ref_spec]
end

lemma kruskal_correct_forest:
  fixes l
  defines "G \<equiv> graph_of_list l"
  shows "<emp> kruskal l <\<lambda>r. \<up>(lst_subgraph_invar r \<and> minimum_spanning_forest (subgraph_of_lst G r) G)>\<^sub>t"
proof -
  interpret Kruskal "graph_of_list l"
    apply unfold_locales
    unfolding graph_of_list_def
    by auto force

  interpret Kruskal_list_nat l
    by unfold_locales

  show ?thesis
    using kruskal_ref_spec[to_hnr]
    unfolding hn_refine_def lst_subgraph_rel_def
    apply clarsimp
    apply (erule cons_post_rule)
    apply (sep_auto simp: hn_ctxt_def pure_def in_br_conv G_def)
    done
qed

lemma kruskal_correct_tree:
  fixes l
  defines "G \<equiv> graph_of_list l"
  assumes connected_G: "connected_graph G"
  shows "<emp> kruskal l <\<lambda>r. \<up>(lst_subgraph_invar r \<and> minimum_spanning_tree (subgraph_of_lst G r) G)>\<^sub>t"
  using kruskal_correct_forest minimum_spanning_forest_impl_tree2[OF _ connected_G]
  apply clarsimp
  apply (rule cons_post_rule)
  apply (auto simp: G_def)
  done

section \<open>Kruskal tree\<close>

definition kruskal_tree_spec :: "('v, 'w::weight) graph \<Rightarrow> ('v, 'w) graph option nres"
  where "kruskal_tree_spec G \<equiv> do {
    ASSERT (finite_graph G);
    SPEC (\<lambda>T'.
      if connected_graph G
      then \<exists>T. T' = Some T \<and> minimum_spanning_tree T G
      else T' = None)
    }"

definition kruskal_tree1 :: "('v, 'w::weight) graph \<Rightarrow> ('v, 'w) graph option nres"
  where "kruskal_tree1 G \<equiv> do {
    spanning_forest \<leftarrow> SPEC (\<lambda>F. minimum_spanning_forest F G);
    ASSERT (finite_graph spanning_forest);
    connected \<leftarrow> SPEC (\<lambda>conn. conn = connected_graph spanning_forest);
    if connected
    then RETURN (Some spanning_forest)
    else RETURN None
  }"

theorem kruskal_tree1_refine:
  "(kruskal_tree1 G, kruskal_tree_spec G) \<in> \<langle>Id\<rangle>nres_rel"
  unfolding kruskal_tree1_def kruskal_tree_spec_def
  apply(refine_vcg)
  apply (auto simp: minimum_spanning_forest_impl_tree[OF _ finite_graph.axioms(1)])
  using connected_graph.maximally_connected_impl_connected valid_graph.subgraph_impl_connected
    valid_graph.valid_subgraph
  unfolding minimum_spanning_forest_def spanning_forest_def finite_graph_def
    finite_graph_axioms_def subgraph_def
  apply auto
  using finite_subset
  by blast+

definition is_connected_spec :: "('v, 'w) graph \<Rightarrow> bool nres"
  where "is_connected_spec F \<equiv> do {
    ASSERT (forest F \<and> finite_graph F);
    SPEC (\<lambda>conn. conn = connected_graph F)
  }"

definition is_connected :: "('v, 'w) graph \<Rightarrow> bool nres"
  where "is_connected F \<equiv> do {
    let N = card (nodes F);
    RETURN (card (edges F) = N - 1)
  }"

lemma is_connected_refine:
  "(is_connected, is_connected_spec) \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding is_connected_def is_connected_spec_def
  apply(refine_vcg)
  using forest.connected_by_number_of_edges
  by auto

definition is_connected_list :: "(nat \<times> int \<times> nat) list \<Rightarrow> (nat \<times> int \<times> nat) list \<Rightarrow> bool"
  where "is_connected_list l l_F \<equiv>
    let N = length (remdups ((map fst l) @ (map (snd o snd) l)))
    in length l_F = N - 1"

definition kruskal_tree2 :: "(nat \<times> int \<times> nat) list \<Rightarrow> (nat \<times> int \<times> nat) list option nres"
  where "kruskal_tree2 l \<equiv> do {
    spanning_forest \<leftarrow> kruskal5 l;
    let connected = is_connected_list l spanning_forest;
    if connected
    then RETURN (Some spanning_forest)
    else RETURN None
  }"

context Kruskal_list_nat
begin

lemma is_connected_list_refine:
  "(RETURN o (is_connected_list l), is_connected) \<in> lst_subgraph_rel G \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding is_connected_list_def is_connected_def
  apply(refine_rcg)
  unfolding lst_subgraph_rel_def subgraph_of_lst_def graph_of_list_def lst_subgraph_invar_def
  by (auto simp: in_br_conv distinct_card length_remdups_card_conv)

theorem kruskal_tree2_refine:
  "(kruskal_tree2 l, kruskal_tree1 G) \<in> \<langle>\<langle>lst_subgraph_rel G\<rangle>option_rel\<rangle>nres_rel"
  unfolding kruskal_tree1_def kruskal_tree2_def
  apply (refine_rcg)
  apply clarsimp_all
  using kruskal5_ref_spec[param_fo, THEN nres_relD]
        is_connected_list_refine[FCOMP is_connected_refine, param_fo, THEN nres_relD]
  unfolding lst_subgraph_rel_def is_connected_spec_def subgraph_of_lst_def
    minimum_spanning_forest_def spanning_forest_def
  apply (auto simp: in_br_conv)
  by fastforce+

end

lemma [sepref_import_param]: "(is_connected_list,is_connected_list)\<in>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow> \<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow> bool_rel"
  by simp

lemmas [sepref_fr_rules] = kruskal.refine

sepref_definition kruskal_tree is
  "kruskal_tree2" :: "(list_assn (nat_assn\<times>\<^sub>aint_assn\<times>\<^sub>anat_assn))\<^sup>k \<rightarrow>\<^sub>a option_assn (list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn))"
  unfolding kruskal_tree2_def
  by sepref

context Kruskal_list_nat
begin
  lemma kruskal_tree3_refine: "(uncurry0 (kruskal_tree l), uncurry0 (kruskal_tree2 l))
    \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a option_assn (list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn))"
    using kruskal_tree.refine
    unfolding list_assn_pure_conv prod_assn_pure_conv
    unfolding hfref_def hn_refine_def pure_def hn_ctxt_def
    by auto

  lemmas kruskal_tree_ref_spec = kruskal_tree3_refine[FCOMP kruskal_tree2_refine[FCOMP kruskal_tree1_refine]]
end

lemma kruskal_tree_correct:
  fixes l
  defines "G \<equiv> graph_of_list l"
  shows "<emp> kruskal_tree l <\<lambda>r. \<up>(r = None \<and> \<not> connected_graph G \<or> connected_graph G \<and> lst_subgraph_invar (the r) \<and> minimum_spanning_tree (subgraph_of_lst G (the r)) G)>\<^sub>t"
proof -
  interpret Kruskal "graph_of_list l"
    apply unfold_locales
    unfolding graph_of_list_def
    by auto force

  interpret Kruskal_list_nat l
    by unfold_locales

  show ?thesis
    using kruskal_tree_ref_spec[to_hnr] finite_graph_axioms
    unfolding hn_refine_def lst_subgraph_rel_def kruskal_tree_spec_def
    apply (auto simp: valid_graph_axioms)
    apply (erule cons_post_rule)
    unfolding option_assn_pure_conv option_rel_def
    apply (sep_auto simp: pure_def in_br_conv G_def)
    done
qed

section \<open>Code export\<close>

export_code kruskal checking SML_imp
export_code kruskal in SML_imp module_name Kruskal (*file "Kruskal.sml"*)

export_code kruskal_tree checking SML_imp
export_code kruskal_tree in SML_imp module_name Kruskal_tree (*file "Kruskal_tree.sml"*)

ML_val \<open>
  val export_nat = @{code integer_of_nat}
  val import_nat = @{code nat_of_integer}
  val export_int = @{code integer_of_int}
  val import_int = @{code int_of_integer}
  val import_list = map (fn (a,b,c) => (import_nat a, (import_int b, import_nat c)))
  val export_list = map (fn (a,(b,c)) => (export_nat a, export_int b, export_nat c))

  fun kruskal l = @{code kruskal} (import_list l) () |> export_list
  fun kruskal_tree l = @{code kruskal_tree} (import_list l) () |> Option.map export_list

  val result = kruskal [(1,~9,2),(2,~3,3),(3,~4,1)]

  val result_tree = kruskal_tree [(1,~9,2),(2,~3,3),(3,~4,1),(4,3,5)]
\<close>

end


theory Monotone imports Main HOL.Option
begin
(*NOTES:
non-interference is hard with non-determinism, since you don't know that the same path will be chosen
consider changing commandeval to return set
might give problems with non-termination and side channels

*)

(*Option auxiliary*)
primrec map_foption where
  \<open>map_foption (Some f) op = map_option f op\<close> |
  \<open>map_foption None op = None\<close>

abbreviation \<open>bind_foption op f \<equiv> Option.bind f (Option.bind op)\<close>

lemma map_foption_none: \<open>f = None \<or> op = None \<Longrightarrow> map_foption f op = None\<close>
  by (metis map_foption.simps(1) map_foption.simps(2) option.exhaust_sel option.simps(8))

lemma map_foption_some: \<open>f = Some f' \<and> op = Some op' \<Longrightarrow> map_foption f op = Some (f' op')\<close>
  by simp

lemma map_foption2_equals_cases: \<open>
  map_foption (map_option f op1) op2 = (
  case (op1,op2) of
    (None,_) \<Rightarrow> None
  | (_,None) \<Rightarrow> None
  | (Some v,Some w) \<Rightarrow> Some (f v w))\<close>
  by (smt (verit) None_eq_map_option_iff is_none_simps(2) map_foption.simps(1) map_foption_none
      old.prod.case option.case_eq_if option.simps(9) option.split_sel)
(*----------------*)

(*defining artm---*)
datatype artm
  = Num int
  | Var nat
  | Arr nat artm
  | UMinus artm
  | Plus artm artm
  | Minus artm artm
  | Times artm artm
  | Divide artm artm
  | Modulo artm artm

fun artmEvaluate where
  \<open>artmEvaluate (\<sigma>,\<pi>) (Num i) = Some i\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Var x) = \<sigma> x\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Arr x a) = Option.bind (artmEvaluate (\<sigma>,\<pi>) a) (\<pi> x)\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (UMinus a) = map_option uminus (artmEvaluate (\<sigma>,\<pi>) a)\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Plus a1 a2) =
    map_foption (map_option plus (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Minus a1 a2) =
    map_foption (map_option minus (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Times a1 a2) =
    map_foption (map_option times (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Divide a1 a2) =
    map_foption (map_option divide (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close> |
  \<open>artmEvaluate (\<sigma>,\<pi>) (Modulo a1 a2) =
    map_foption (map_option modulo (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close>

lemma artm_eval_some_implies_operation:
  \<open>artmEvaluate (\<sigma>,\<pi>) (Num i) = Some i\<close> (is \<open>?p1\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) (Var x) = \<sigma> x\<close> (is \<open>?p2\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) (Arr x a) = (\<pi> x i)\<close> (is \<open>?s3 \<Longrightarrow> ?p3\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) (UMinus a) = Some (-i)\<close> (is \<open>?s4 \<Longrightarrow> ?p4\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a1 = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) a2 = Some j \<Longrightarrow>
    artmEvaluate (\<sigma>,\<pi>) (Plus a1 a2) = Some (i + j)\<close> (is \<open>?s51 \<Longrightarrow> ?s52 \<Longrightarrow> ?p5\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a1 = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) a2 = Some j \<Longrightarrow>
    artmEvaluate (\<sigma>,\<pi>) (Minus a1 a2) = Some (i - j)\<close> (is \<open>?s61 \<Longrightarrow> ?s62 \<Longrightarrow> ?p6\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a1 = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) a2 = Some j \<Longrightarrow>
    artmEvaluate (\<sigma>,\<pi>) (Times a1 a2) = Some (i * j)\<close>  (is \<open>?s71 \<Longrightarrow> ?s72 \<Longrightarrow> ?p7\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a1 = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) a2 = Some j \<Longrightarrow>
    artmEvaluate (\<sigma>,\<pi>) (Divide a1 a2) = Some (i div j)\<close> (is \<open>?s81 \<Longrightarrow> ?s82 \<Longrightarrow> ?p8\<close>)
  \<open>artmEvaluate (\<sigma>,\<pi>) a1 = Some i \<Longrightarrow> artmEvaluate (\<sigma>,\<pi>) a2 = Some j \<Longrightarrow>
    artmEvaluate (\<sigma>,\<pi>) (Modulo a1 a2) = Some (i mod j)\<close> (is \<open>?s91 \<Longrightarrow> ?s92 \<Longrightarrow> ?p9\<close>)
  by simp_all
(*----------------*)

(*defining bool---*)
datatype boolean
  = Tru
  | Neg boolean
  | Dis boolean boolean
  | Equal artm artm
  | Less artm artm

abbreviation \<open>Fals \<equiv> Neg Tru\<close>

abbreviation \<open>Con b1 b2 \<equiv> Neg (Dis (Neg b1) (Neg b2))\<close>

abbreviation \<open>LessEq a1 a2 \<equiv> Dis (Less a1 a2) (Equal a1 a2)\<close>

abbreviation \<open>NEqual a1 a2 \<equiv> Neg (Equal a1 a2)\<close>

fun booleanEvaluate where
  \<open>booleanEvaluate (\<sigma>,\<pi>) Tru = Some True\<close> |
  \<open>booleanEvaluate (\<sigma>,\<pi>) (Neg b) = map_option Not (booleanEvaluate (\<sigma>,\<pi>) b)\<close> |
  \<open>booleanEvaluate (\<sigma>,\<pi>) (Dis b1 b2) =
    map_foption (map_option (\<or>) (booleanEvaluate (\<sigma>,\<pi>) b1)) (booleanEvaluate (\<sigma>,\<pi>) b2)\<close> |
  \<open>booleanEvaluate (\<sigma>,\<pi>) (Equal a1 a2) =
    map_foption (map_option (=) (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close> |
  \<open>booleanEvaluate (\<sigma>,\<pi>) (Less a1 a2) =
    map_foption (map_option (<) (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close>

lemma EvaluateFals[simp]: \<open>booleanEvaluate (\<sigma>,\<pi>) Fals = Some False\<close>
  by simp

lemma EvaluateCon[simp]: \<open>booleanEvaluate (\<sigma>,\<pi>) (Con b1 b2) =
    map_foption (map_option (\<and>) (booleanEvaluate (\<sigma>,\<pi>) b1)) (booleanEvaluate (\<sigma>,\<pi>) b2)\<close>
  by (smt (z3) None_eq_map_option_iff booleanEvaluate.simps(2) booleanEvaluate.simps(3)
      map_foption.simps(1) map_foption.simps(2) option.collapse option.map_sel)

lemma EvaluateLessEq[simp]: \<open>
  booleanEvaluate (\<sigma>,\<pi>) (LessEq a1 a2) =
  map_foption (map_option (\<le>) (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close>
  (is \<open>?bol = ?artms\<close>)
proof-
  consider (a1None) \<open>artmEvaluate (\<sigma>,\<pi>) a1 = None\<close> | (a1Some) \<open>\<exists> i. artmEvaluate (\<sigma>,\<pi>) a1 = Some i\<close>
    by auto
  then show \<open>?thesis\<close>
  proof cases
    case a1None
    then show ?thesis
      by simp
  next
    case a1Some
    consider \<open>artmEvaluate (\<sigma>,\<pi>) a2 = None\<close> | \<open>\<exists> j. artmEvaluate (\<sigma>,\<pi>) a2 = Some j\<close>
      by auto
    then show ?thesis
      by (smt (z3) a1Some booleanEvaluate.simps(3) booleanEvaluate.simps(4) booleanEvaluate.simps(5)
          map_foption.simps(1) map_foption_none option.simps(9))
  qed
qed

lemma EvaluateNEqual[simp]: \<open>
  booleanEvaluate (\<sigma>,\<pi>) (NEqual a1 a2) =
  map_foption (map_option (\<noteq>) (artmEvaluate (\<sigma>,\<pi>) a1)) (artmEvaluate (\<sigma>,\<pi>) a2)\<close>
  (is \<open>?bol = ?artms\<close>)
proof-
  have \<open>artmEvaluate (\<sigma>,\<pi>) a1 = None \<or> (\<exists> i. artmEvaluate (\<sigma>,\<pi>) a1 = Some i)\<close>
    by auto
  moreover have \<open>artmEvaluate (\<sigma>,\<pi>) a2 = None \<or> (\<exists> j. artmEvaluate (\<sigma>,\<pi>) a2 = Some j)\<close>
    by auto
  ultimately show \<open>?thesis\<close> by fastforce
qed
(*----------------*)

(*defining coms---*)
datatype command
  = Skip
  | AssignV nat artm
  | AssignA nat artm artm
  | Sequence command command
  | If gcommand
  | Do gcommand
and gcommand
  = Case boolean command
  | Choice gcommand gcommand

abbreviation \<open>evaluateIfTrue f mem i c b \<equiv> if b then f mem i c else None\<close>

primrec updateVar where \<open>updateVar x (\<sigma>,\<pi>) i = Some (\<sigma>(x := Some i), \<pi>)\<close>

primrec updateArr where \<open>updateArr x (\<sigma>,\<pi>) i j = Some (\<sigma>, \<pi>(x := ((\<pi> x) (i := Some j))))\<close>

(*scheme for termination:*)
context begin
private datatype c = A | F c | R c
private function f where
  \<open>f (i :: nat) A = A\<close> |
  \<open>f i (F c) = f i c\<close> |
  \<open>f i (R c) = (if i = 0 then A else f (i - 1) (R c))\<close> (*only check in non-termination step*)
  by pat_completeness auto
termination
  by (relation "measure (\<lambda> (i,c). i + size c)") simp_all (*both size of i and term*)
end
(*\scheme for termination*)

function commandEvaluate gcommandEvaluate where
  \<open>commandEvaluate (i :: nat) mem Skip = None\<close> |
  \<open>commandEvaluate i mem (AssignV x a) =
    Option.bind (artmEvaluate mem a) (updateVar x mem)\<close> |
  \<open>commandEvaluate i mem (AssignA x a1 a2) =
    bind_foption (artmEvaluate mem a2) (map_option (updateArr x mem) (artmEvaluate mem a1))\<close> |
  \<open>commandEvaluate i mem (Sequence c1 c2) = (
    case commandEvaluate i mem c1 of
      None \<Rightarrow> None
    | Some mem' \<Rightarrow> commandEvaluate i mem' c2)\<close> |
  \<open>commandEvaluate i mem (If gc) = (
    case gcommandEvaluate i mem gc of
      None \<Rightarrow> None
    | Some mem' \<Rightarrow> mem')\<close> |
  \<open>commandEvaluate i mem (Do gc) = (
    if i > 0
    then
      case gcommandEvaluate i mem gc of
        None \<Rightarrow> None
      | Some None \<Rightarrow> Some mem
      | Some (Some mem') \<Rightarrow> commandEvaluate (i - 1) mem' (Do gc)
    else None)\<close> |
  \<open>gcommandEvaluate i mem (Case b c) = (
    case booleanEvaluate mem b of
      Some True \<Rightarrow> map_option Some (commandEvaluate i mem c)
    | Some False \<Rightarrow> Some None
    | None \<Rightarrow> None)\<close> |
  \<open>gcommandEvaluate i mem (Choice gc1 gc2) = (
    case (gcommandEvaluate i mem gc1, gcommandEvaluate i mem gc2) of
      (None, _) \<Rightarrow> None
    | (_,None) \<Rightarrow> None
    | (Some m, Some None) \<Rightarrow> Some m
    | (Some None, Some m) \<Rightarrow> Some m
    | (Some (Some m1), Some (Some m2)) \<Rightarrow> Some (Some (SOME m. m = m1 \<or> m = m2)))\<close>
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>x. case x of Inl (i,_,c) \<Rightarrow> i + size c | Inr (i,_,gc) \<Rightarrow> i + size gc)")
    simp_all
(*----------------*)

(*manual verifying*)
context begin
private abbreviation \<open>factorial \<equiv>
    Do (
      Case
        (Less (Num 0) (Var 1))
        (Sequence
          (AssignV 0 (Times (Var 0) (Var 1)))
          (AssignV 1 (Minus (Var 1) (Num 1)))))\<close>

(*pure isar proof that the program calculates the factorial when it succeeds:*)
private proposition \<open>
  \<sigma> 0 = Some m \<Longrightarrow>
  \<sigma> 1 = Some n \<Longrightarrow>
  n \<ge> 0 \<Longrightarrow>
  commandEvaluate i (\<sigma>,\<pi>) factorial = Some (\<sigma>',\<pi>') \<Longrightarrow>
  \<sigma>' 0 = Some m' \<Longrightarrow>
  m' = m * fact (nat n)\<close>
proof (induct i arbitrary: \<sigma> \<pi> m n m')
  case 0
  then show ?case by simp
next
  let ?ass0 = \<open>AssignV 0 (Times (Var 0) (Var 1))\<close>
  let ?ass1 = \<open>AssignV 1 (Minus (Var 1) (Num 1))\<close>
  let ?test = \<open>Less (Num 0) (Var 1)\<close>
  let ?body = \<open>Sequence ?ass0 ?ass1\<close>
  let ?gc = \<open>Case ?test ?body\<close>
  case (Suc i)
  then have not_none1:\<open>None \<noteq> commandEvaluate (Suc i) (\<sigma>, \<pi>) factorial\<close>
    by (metis not_Some_eq)
  then have not_none2:\<open>None \<noteq>
    gcommandEvaluate (Suc i) (\<sigma>, \<pi>) ?gc\<close> by fastforce
  consider
    \<open>booleanEvaluate (\<sigma>, \<pi>) ?test = Some True\<close> |
    \<open>booleanEvaluate (\<sigma>, \<pi>) ?test = Some False\<close>
    using Suc.prems(2) by fastforce
  then show ?case
  proof cases
    case 1
    then have gcdef:\<open>
      gcommandEvaluate (Suc i) (\<sigma>, \<pi>) ?gc =
      map_option Some (commandEvaluate (Suc i) (\<sigma>, \<pi>) ?body)\<close>
      by (smt (verit) gcommandEvaluate.simps(1) option.simps(5))
    then have not_none11: \<open>None \<noteq> commandEvaluate (Suc i) (\<sigma>, \<pi>) ?body\<close>
      using not_none2 by fastforce
    have not_none12: \<open>None \<noteq> commandEvaluate (Suc i) (\<sigma>, \<pi>) ?ass0\<close>
    proof (rule ccontr)
      assume \<open>\<not>(None \<noteq> commandEvaluate (Suc i) (\<sigma>, \<pi>) ?ass0)\<close>
      then have \<open>commandEvaluate (Suc i) (\<sigma>, \<pi>) ?body = None\<close> by simp
      then show False using not_none11 by simp
    qed
    then obtain tms where  tms_def:
      \<open>artmEvaluate (\<sigma>, \<pi>) (Times (Var 0) (Var 1)) = Some tms \<and> tms = m * n\<close>
      using Suc.prems by fastforce
    then have bodydef:
      \<open>commandEvaluate (Suc i) (\<sigma>, \<pi>) ?body = commandEvaluate (Suc i) (\<sigma>(0 := Some tms), \<pi>) ?ass1\<close>
      using not_none11 by auto
    then have not_none13: \<open>None \<noteq> commandEvaluate (Suc i) (\<sigma>(0 := Some tms), \<pi>) ?ass1\<close>
      using not_none11 by auto
    then have mns_def:
      \<open>artmEvaluate (\<sigma>(0 := Some tms), \<pi>) (Minus (Var 1) (Num 1)) = Some (n - 1)\<close>
      using Suc.prems by fastforce
    then have \<open>commandEvaluate (Suc i) (\<sigma>, \<pi>) ?body = Some (\<sigma>(0 := Some tms,1 := Some (n - 1)), \<pi>)\<close>
      using not_none11 bodydef by auto
    then have
      \<open>gcommandEvaluate (Suc i) (\<sigma>, \<pi>) ?gc = Some (Some (\<sigma>(0 := Some tms,1 := Some (n - 1)), \<pi>))\<close>
      using gcdef by simp
    then have \<open>
      commandEvaluate (Suc i) (\<sigma>, \<pi>) factorial =
      commandEvaluate i (\<sigma>(0 := Some tms,1 := Some (n - 1)), \<pi>) factorial\<close>
      by simp
    moreover have mns_grt_0:\<open>(n - 1) \<ge> 0\<close> using 1 mns_def by auto
    ultimately have
      \<open>commandEvaluate i (\<sigma>(0 := Some tms,1 := Some (n - 1)), \<pi>) factorial =
      Some (\<sigma>',\<pi>') \<and> \<sigma>' 0 = Some m' \<and> m' = tms * fact (nat (n - 1))\<close>
      by (metis (no_types, lifting) Suc.hyps Suc.prems(4)
          Suc.prems(5) fun_upd_other fun_upd_same zero_neq_one)
    then have \<open>m' = m * n * fact (nat (n - 1))\<close>
      by (simp add: mns_def tms_def)
    moreover have \<open>n * fact (nat (n - 1)) = fact (nat n)\<close> using mns_grt_0 mns_def
      by (simp add: fact_num_eq_if nat_diff_distrib)
    ultimately show ?thesis
      by simp
  next
    case 2
    then have \<open>gcommandEvaluate (Suc i) (\<sigma>, \<pi>) ?gc = Some None\<close>
      by (smt (verit) gcommandEvaluate.simps(1) option.simps(5))
    then have \<open>commandEvaluate (Suc i) (\<sigma>, \<pi>) factorial = Some (\<sigma>, \<pi>)\<close>
      by simp
    moreover have \<open>\<sigma> 1 = Some 0\<close>
      using 2 Suc.prems by simp
    ultimately show ?thesis
      using Suc.prems(1) Suc.prems(2) Suc.prems(4) Suc.prems(5) by auto
  qed
qed

private abbreviation \<open>non_deterministic \<equiv>
  If (Choice
    (Case
      (Equal (Var 0) (Num 0))
      (AssignV 0 (Num 1)))
    (Case
      (Equal (Var 1) (Num 0))
      (AssignV 1 (Num 1))))\<close>

private proposition \<open>
  commandEvaluate i mem non_deterministic = Some mem' \<Longrightarrow>
  ((fst mem) 0 = Some 0 \<and> (fst mem') 0 = Some 1) \<or> ((fst mem) 1 = Some 0 \<and> (fst mem') 1 = Some 1)\<close>
  (is \<open>?asm \<Longrightarrow> ?ex0 \<or> ?ex1\<close>)
proof-
  let ?ass0 = \<open>AssignV 0 (Num 1)\<close>
  let ?ass1 = \<open>AssignV 1 (Num 1)\<close>
  let ?tst0 = \<open>Equal (Var 0) (Num 0)\<close>
  let ?tst1 = \<open>Equal (Var 1) (Num 0)\<close>
  let ?cse0 = \<open>Case ?tst0 ?ass0\<close>
  let ?cse1 = \<open>Case ?tst1 ?ass1\<close>
  let ?gc = \<open>Choice ?cse0 ?cse1\<close>
  let ?gc_pair = \<open>(gcommandEvaluate i mem ?cse0, gcommandEvaluate i mem ?cse1)\<close>
  assume a:\<open>?asm\<close>
  have gcom_some: \<open>gcommandEvaluate i mem ?gc = Some (Some mem')\<close>
  proof-
    consider
      \<open>\<exists> mem_x. gcommandEvaluate i mem ?gc = Some (Some mem_x)\<close> |
      \<open>gcommandEvaluate i mem ?gc = Some None\<close> |
      \<open>gcommandEvaluate i mem ?gc = None\<close> by fastforce
    then show ?thesis
    proof cases
      case 1
      then obtain mem_x where mem_x_def:\<open>gcommandEvaluate i mem ?gc = Some (Some mem_x)\<close> by auto
      then have \<open>mem_x = mem'\<close> using a by auto
      then show ?thesis using mem_x_def by blast
    next
      case 2
      then show ?thesis using a by simp
    next
      case 3
      then show ?thesis using a by simp
    qed
  qed
  have ex0: \<open>gcommandEvaluate i mem ?cse0 = Some (Some mem') \<Longrightarrow> ?ex0\<close>
  proof-
    assume a2:\<open>gcommandEvaluate i mem ?cse0 = Some (Some mem')\<close>
    have tst0_some:\<open>booleanEvaluate mem ?tst0 = Some True\<close>
    proof (rule ccontr)
      assume \<open>booleanEvaluate mem ?tst0 \<noteq> Some True\<close>
      then have \<open>booleanEvaluate mem ?tst0 = Some False \<or> booleanEvaluate mem ?tst0 = None\<close> by auto
      then show False using a2 by auto
    qed
    have num_0_is_0:\<open>artmEvaluate mem (Num 0) = Some 0\<close>
      by (metis artmEvaluate.simps(1) old.prod.exhaust)
    moreover have \<open>artmEvaluate mem (Var 0) = artmEvaluate mem (Num 0)\<close>
    proof-
      have \<open>artmEvaluate mem (Var 0) \<noteq> None\<close>
        using tst0_some by (metis None_eq_map_option_iff booleanEvaluate.simps(4)
            map_foption.simps(2) old.prod.exhaust option.discI)
      then show ?thesis
        using tst0_some num_0_is_0
        by (smt (verit, best) booleanEvaluate.simps(4) map_foption_some old.prod.exhaust
            option.collapse option.sel option.simps(9))
    qed
    ultimately have part1:\<open>(fst mem) 0 = Some 0\<close>
      by (metis artmEvaluate.simps(2) prod.exhaust_sel)
    have num_1_is_1: \<open>artmEvaluate mem (Num 1) = Some 1\<close>
      by (metis artmEvaluate.simps(1) surj_pair)
    moreover have \<open>commandEvaluate i mem ?ass0 = Some (mem')\<close> using a2 tst0_some by auto
    ultimately have \<open>fst mem' = (fst mem)(0 := Some 1)\<close>
      by (metis (mono_tags, lifting) bind.bind_lunit commandEvaluate.simps(2) eq_fst_iff
          option.inject updateVar.simps)
    then show ?thesis using part1 by simp
  qed
  have ex1: \<open>gcommandEvaluate i mem ?cse1 = Some (Some mem') \<Longrightarrow> ?ex1\<close>sorry
  consider
    \<open>\<exists> x. ?gc_pair = (None,x)\<close> |
    \<open>\<exists> x. ?gc_pair = (x,None)\<close> |
    \<open>?gc_pair = (Some None,Some None)\<close> |
    \<open>\<exists> mem_x.
       ?gc_pair = (Some (Some mem_x),Some None)\<close> |
    \<open>\<exists> mem_x.
      ?gc_pair = (Some None,Some (Some mem_x))\<close> |
    \<open>\<exists> mem_x mem_y.
      ?gc_pair = (Some (Some mem_x),Some (Some mem_y))\<close>
    by force
  then show \<open>?ex0 \<or> ?ex1\<close>
  proof cases
    case 1
    then have \<open>False\<close> using gcom_some by simp
    then show ?thesis ..
  next
    case 2
    then have \<open>False\<close>
      using gcom_some by (metis (no_types, lifting) case_prod_conv gcommandEvaluate.simps(2)
          option.case_eq_if option.distinct(1))
    then show ?thesis ..
  next
    case 3
    then have \<open>False\<close> using gcom_some by simp
    then show ?thesis ..
  next
    case 4
    then show ?thesis using ex0 a by auto
  next
    case 5
    then show ?thesis using ex1 a by auto
  next
    case 6
    then show ?thesis sorry
  qed
qed
end
(*----------------*)

(*graph auxiliary-*)
fun is_path where
  empty_path: \<open>is_path graph start end [] = (start = end)\<close> |
  extend_path: \<open>
    is_path graph start end ((s,a,e) # path) =
    (s = start \<and> (s,a,e) \<in> graph \<and> is_path graph e end path)\<close>
(*----------------*)

(*program graphs--*)
datatype node
  = Start
  | Mid nat
  | Finish

primrec sucNode where
  \<open>sucNode Start = Mid 0\<close> |
  \<open>sucNode (Mid i) = Mid (i + 1)\<close> |
  \<open>sucNode Finish = Finish\<close>

datatype action
  = Skp
  | Tst boolean
  | AsV nat artm
  | AsA nat artm artm

primrec not_done where
  \<open>not_done (Case b _) = b\<close> |
  \<open>not_done (Choice gc1 gc2) = (Dis (not_done gc1) (not_done gc2))\<close>

lemma
  \<open>booleanEvaluate mem (not_done gc) = Some False \<Longrightarrow> gcommandEvaluate i mem gc = Some None\<close>
proof (induct gc)
case Skip
  then show ?thesis sorry
next
  case (AssignV x1 x2)
  then show ?thesis sorry
next
  case (AssignA x1 x2 x3)
  then show ?thesis sorry
next
  case (If gc)
  then show ?thesis sorry
next
  case (Do gc)
  then show ?thesis sorry
next
  fix x1 x2
  assume \<open>gcommandEvaluate i mem gc = Some None\<close>
  assume \<open>booleanEvaluate mem (not_done (Case x1 x2)) = Some False\<close>
  then show \<open>gcommandEvaluate i mem (Case x1 x2) = Some None\<close> sorry
next
  case (Choice gc1 gc2)
  then show ?case sorry
qed auto

fun edgesC edgesGC where
  \<open>edgesC maxnode snode fnode Skip = (maxnode,{(snode,Skp,fnode)})\<close> |
  \<open>edgesC maxnode snode fnode (AssignV x a) = (maxnode,{(snode,AsV x a,fnode)})\<close> |
  \<open>edgesC maxnode snode fnode (AssignA x a1 a2) = (maxnode,{(snode,AsA x a1 a2,fnode)})\<close> |
  \<open>edgesC maxnode snode fnode (Sequence c1 c2) = (
    let
      nnode = sucNode maxnode;
      (mnode,es) = edgesC nnode snode nnode c1;
      (mnode',es') = edgesC mnode nnode fnode c2 in
    (mnode',es \<union> es'))\<close> |
  \<open>edgesC maxnode snode fnode (If gc) = edgesGC maxnode snode fnode gc\<close> |
  \<open>edgesC maxnode snode fnode (Do gc) = (
    let (mnode,es) = edgesGC maxnode snode snode gc in
    (mnode,es \<union> {(snode,Tst (Neg (not_done gc)),fnode)}))\<close> |
  \<open>edgesGC maxnode snode fnode (Case b c) = (
    let
      nnode = sucNode maxnode;
      (mnode,es) = edgesC nnode nnode fnode c in
    (mnode,es \<union> {(snode,Tst b,nnode)}))\<close> |
  \<open>edgesGC maxnode snode fnode (Choice gc1 gc2) = (
    let
      (mnode,es) = edgesGC maxnode snode fnode gc1;
      (mnode',es') = edgesGC mnode snode fnode gc2 in
    (mnode',es \<union> es'))\<close>

(*----------------*)
end


(* Author: Tobias Nipkow *)

section "Hoare Logic"

theory Hoare imports Big_Step begin

subsection "Hoare Logic for Partial Correctness"

type_synonym assn = "state \<Rightarrow> bool"

definition
hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
  ("_[_'/_]" [1000,0,0] 999)
where "s[a/x] == s(x := aval a s)"

inductive
  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
where
Skip: "\<turnstile> {P} SKIP {P}"  |

Assign:  "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk>
      \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"  |

If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
     \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P} \<Longrightarrow>
        \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"  |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
        \<Longrightarrow> \<turnstile> {P'} c {Q'}"

lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If

lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If

text{* The assignment and While rule are awkward to use in actual proofs
because their pre and postcondition are of a very special form and the actual
goal would have to match this form exactly. Therefore we derive two variants
with arbitrary pre and postconditions. *}

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

lemma While':
assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile> {P} WHILE b DO c {Q}"
by(rule weaken_post[OF While[OF assms(1)] assms(2)])

end


theory T98
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(* Author: Tobias Nipkow *)

section \<open>Pairing Heap According to Oksaki (Modified)\<close>

theory Pairing_Heap_List2
imports
  "HOL-Library.Multiset"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

subsection \<open>Definitions\<close>

text \<open>This version of pairing heaps is a modified version
of the one by Okasaki \cite{Okasaki} that avoids structural invariants.\<close>

datatype 'a hp = Hp 'a (hps: "'a hp list")

type_synonym 'a heap = "'a hp option"

hide_const (open) insert

fun get_min  :: "'a heap \<Rightarrow> 'a" where
"get_min (Some(Hp x _)) = x"

fun link :: "('a::linorder) hp \<Rightarrow> 'a hp \<Rightarrow> 'a hp" where
"link (Hp x lx) (Hp y ly) =
    (if x < y then Hp x (Hp y ly # lx) else Hp y (Hp x lx # ly))"

fun merge :: "('a::linorder) heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"merge h None = h" |
"merge None h = h" |
"merge (Some h1) (Some h2) = Some(link h1 h2)"

lemma merge_None[simp]: "merge None h = h"
by(cases h)auto

fun insert :: "('a::linorder) \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x None = Some(Hp x [])" |
"insert x (Some h) = Some(link (Hp x []) h)"

fun pass\<^sub>1 :: "('a::linorder) hp list \<Rightarrow> 'a hp list" where
  "pass\<^sub>1 [] = []"
| "pass\<^sub>1 [h] = [h]"
| "pass\<^sub>1 (h1#h2#hs) = link h1 h2 # pass\<^sub>1 hs"

fun pass\<^sub>2 :: "('a::linorder) hp list \<Rightarrow> 'a heap" where
  "pass\<^sub>2 [] = None"
| "pass\<^sub>2 (h#hs) = Some(case pass\<^sub>2 hs of None \<Rightarrow> h | Some h' \<Rightarrow> link h h')"

fun merge_pairs :: "('a::linorder) hp list \<Rightarrow> 'a heap" where
  "merge_pairs [] = None"
| "merge_pairs [h] = Some h"
| "merge_pairs (h1 # h2 # hs) =
  Some(let h12 = link h1 h2 in case merge_pairs hs of None \<Rightarrow> h12 | Some h \<Rightarrow> link h12 h)"

fun del_min :: "('a::linorder) heap \<Rightarrow> 'a heap" where
  "del_min None = None"
| "del_min (Some(Hp x hs)) = pass\<^sub>2 (pass\<^sub>1 hs)"

subsection \<open>Correctness Proofs\<close>

text \<open>An optimization:\<close>

lemma pass12_merge_pairs: "pass\<^sub>2 (pass\<^sub>1 hs) = merge_pairs hs"
by (induction hs rule: merge_pairs.induct) (auto split: option.split)

declare pass12_merge_pairs[code_unfold]

subsubsection \<open>Invariants\<close>

fun php :: "('a::linorder) hp \<Rightarrow> bool" where
"php (Hp x hs) = (\<forall>h \<in> set hs. (\<forall>y \<in> set_hp h. x \<le> y) \<and> php h)"

definition invar :: "('a::linorder) heap \<Rightarrow> bool" where
"invar ho = (case ho of None \<Rightarrow> True | Some h \<Rightarrow> php h)"

lemma php_link: "php h1 \<Longrightarrow> php h2 \<Longrightarrow> php (link h1 h2)"
by (induction h1 h2 rule: link.induct) fastforce+

lemma invar_merge:
  "\<lbrakk> invar h1; invar h2 \<rbrakk> \<Longrightarrow> invar (merge h1 h2)"
by (auto simp: php_link invar_def split: option.splits)

lemma invar_insert: "invar h \<Longrightarrow> invar (insert x h)"
by (auto simp: php_link invar_def split: option.splits)

lemma invar_pass1: "\<forall>h \<in> set hs. php h \<Longrightarrow> \<forall>h \<in> set (pass\<^sub>1 hs). php h"
by(induction hs rule: pass\<^sub>1.induct) (auto simp: php_link)

lemma invar_pass2: "\<forall>h \<in> set hs. php h \<Longrightarrow> invar (pass\<^sub>2 hs)"
by (induction hs)(auto simp: php_link invar_def split: option.splits)

lemma invar_del_min: "invar h \<Longrightarrow> invar (del_min h)"
by(induction h rule: del_min.induct)
  (auto simp: invar_Some intro!: invar_pass1 invar_pass2)

subsubsection \<open>Functional Correctness\<close>

fun mset_hp :: "'a hp \<Rightarrow>'a multiset" where
"mset_hp (Hp x hs) = {#x#} + Union_mset(mset(map mset_hp hs))"

definition mset_heap :: "'a heap \<Rightarrow>'a multiset" where
"mset_heap ho = (case ho of None \<Rightarrow> {#} | Some h \<Rightarrow> mset_hp h)"

lemma set_mset_mset_hp: "set_mset (mset_hp h) = set_hp h"
by(induction h) auto

lemma mset_hp_empty[simp]: "mset_hp hp \<noteq> {#}"
by (cases hp) auto

lemma mset_heap_Some: "mset_heap(Some hp) = mset_hp hp"
by(simp add: mset_heap_def)

lemma mset_heap_empty: "mset_heap h = {#} \<longleftrightarrow> h = None"
by (cases h) (auto simp add: mset_heap_def)

lemma get_min_in:
  "h \<noteq> None \<Longrightarrow> get_min h \<in> set_hp(the h)"
by(induction rule: get_min.induct)(auto)

lemma get_min_min: "\<lbrakk> h \<noteq> None; invar h; x \<in> set_hp(the h) \<rbrakk> \<Longrightarrow> get_min h \<le> x"
by(induction h rule: get_min.induct)(auto simp: invar_def)

lemma mset_link: "mset_hp (link h1 h2) = mset_hp h1 + mset_hp h2"
by(induction h1 h2 rule: link.induct)(auto simp: add_ac)

lemma mset_merge: "mset_heap (merge h1 h2) = mset_heap h1 + mset_heap h2"
by (induction h1 h2 rule: merge.induct)
   (auto simp add: mset_heap_def mset_link ac_simps)

lemma mset_insert: "mset_heap (insert a h) = {#a#} + mset_heap h"
by(cases h) (auto simp add: mset_link mset_heap_def insert_def)

lemma mset_merge_pairs: "mset_heap (merge_pairs hs) = Union_mset(image_mset mset_hp (mset hs))"
by(induction hs rule: merge_pairs.induct)
  (auto simp: mset_merge mset_link mset_heap_def Let_def split: option.split)

lemma mset_del_min: "h \<noteq> None \<Longrightarrow>
  mset_heap (del_min h) = mset_heap h - {#get_min h#}"
by(induction h rule: del_min.induct)
  (auto simp: mset_heap_Some pass12_merge_pairs mset_merge_pairs)

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation pairing: Priority_Queue_Merge
where empty = None and is_empty = "\<lambda>h. h = None"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = invar and mset = mset_heap
proof(standard, goal_cases)
  case 1 show ?case by(simp add: mset_heap_def)
next
  case (2 q) thus ?case by(auto simp add: mset_heap_def split: option.split)
next
  case 3 show ?case by(simp add: mset_insert mset_merge)
next
  case 4 thus ?case by(simp add: mset_del_min mset_heap_empty)
next
  case (5 q) thus ?case using get_min_in[of q]
    by(auto simp add: eq_Min_iff get_min_min mset_heap_empty mset_heap_Some set_mset_mset_hp)
next
  case 6 thus ?case by (simp add: invar_def)
next
  case 7 thus ?case by(rule invar_insert)
next
  case 8 thus ?case by (simp add: invar_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: invar_merge)
qed

end


(*  Title:      HOL/ex/Sudoku.thy
    Author:     Tjark Weber
    Copyright   2005-2014
*)

section \<open>A SAT-based Sudoku Solver\<close>

theory Sudoku
imports MainRLT
begin

text \<open>
  See the paper ``A SAT-based Sudoku Solver'' (Tjark Weber, published at
  LPAR'05) for further explanations.  (The paper describes an older version of
  this theory that used the model finder \<open>refute\<close> to find Sudoku
  solutions.  The \<open>refute\<close> tool has since been superseded by
  \<open>nitpick\<close>, which is used below.)
\<close>

no_notation Groups.one_class.one ("1")

datatype digit = A ("1") | B ("2") | C ("3") | D ("4") | E ("5") | F ("6") | G ("7") | H ("8") | I ("9")

definition valid :: "digit => digit => digit => digit => digit => digit => digit => digit => digit => bool" where

  "valid x1 x2 x3 x4 x5 x6 x7 x8 x9 ==
    (x1 \<noteq> x2) \<and> (x1 \<noteq> x3) \<and> (x1 \<noteq> x4) \<and> (x1 \<noteq> x5) \<and> (x1 \<noteq> x6) \<and> (x1 \<noteq> x7) \<and> (x1 \<noteq> x8) \<and> (x1 \<noteq> x9)
    \<and> (x2 \<noteq> x3) \<and> (x2 \<noteq> x4) \<and> (x2 \<noteq> x5) \<and> (x2 \<noteq> x6) \<and> (x2 \<noteq> x7) \<and> (x2 \<noteq> x8) \<and> (x2 \<noteq> x9)
    \<and> (x3 \<noteq> x4) \<and> (x3 \<noteq> x5) \<and> (x3 \<noteq> x6) \<and> (x3 \<noteq> x7) \<and> (x3 \<noteq> x8) \<and> (x3 \<noteq> x9)
    \<and> (x4 \<noteq> x5) \<and> (x4 \<noteq> x6) \<and> (x4 \<noteq> x7) \<and> (x4 \<noteq> x8) \<and> (x4 \<noteq> x9)
    \<and> (x5 \<noteq> x6) \<and> (x5 \<noteq> x7) \<and> (x5 \<noteq> x8) \<and> (x5 \<noteq> x9)
    \<and> (x6 \<noteq> x7) \<and> (x6 \<noteq> x8) \<and> (x6 \<noteq> x9)
    \<and> (x7 \<noteq> x8) \<and> (x7 \<noteq> x9)
    \<and> (x8 \<noteq> x9)"

definition sudoku :: "digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit => bool" where

  "sudoku x11 x12 x13 x14 x15 x16 x17 x18 x19
          x21 x22 x23 x24 x25 x26 x27 x28 x29
          x31 x32 x33 x34 x35 x36 x37 x38 x39
          x41 x42 x43 x44 x45 x46 x47 x48 x49
          x51 x52 x53 x54 x55 x56 x57 x58 x59
          x61 x62 x63 x64 x65 x66 x67 x68 x69
          x71 x72 x73 x74 x75 x76 x77 x78 x79
          x81 x82 x83 x84 x85 x86 x87 x88 x89
          x91 x92 x93 x94 x95 x96 x97 x98 x99 ==

       valid x11 x12 x13 x14 x15 x16 x17 x18 x19
     \<and> valid x21 x22 x23 x24 x25 x26 x27 x28 x29
     \<and> valid x31 x32 x33 x34 x35 x36 x37 x38 x39
     \<and> valid x41 x42 x43 x44 x45 x46 x47 x48 x49
     \<and> valid x51 x52 x53 x54 x55 x56 x57 x58 x59
     \<and> valid x61 x62 x63 x64 x65 x66 x67 x68 x69
     \<and> valid x71 x72 x73 x74 x75 x76 x77 x78 x79
     \<and> valid x81 x82 x83 x84 x85 x86 x87 x88 x89
     \<and> valid x91 x92 x93 x94 x95 x96 x97 x98 x99

     \<and> valid x11 x21 x31 x41 x51 x61 x71 x81 x91
     \<and> valid x12 x22 x32 x42 x52 x62 x72 x82 x92
     \<and> valid x13 x23 x33 x43 x53 x63 x73 x83 x93
     \<and> valid x14 x24 x34 x44 x54 x64 x74 x84 x94
     \<and> valid x15 x25 x35 x45 x55 x65 x75 x85 x95
     \<and> valid x16 x26 x36 x46 x56 x66 x76 x86 x96
     \<and> valid x17 x27 x37 x47 x57 x67 x77 x87 x97
     \<and> valid x18 x28 x38 x48 x58 x68 x78 x88 x98
     \<and> valid x19 x29 x39 x49 x59 x69 x79 x89 x99

     \<and> valid x11 x12 x13 x21 x22 x23 x31 x32 x33
     \<and> valid x14 x15 x16 x24 x25 x26 x34 x35 x36
     \<and> valid x17 x18 x19 x27 x28 x29 x37 x38 x39
     \<and> valid x41 x42 x43 x51 x52 x53 x61 x62 x63
     \<and> valid x44 x45 x46 x54 x55 x56 x64 x65 x66
     \<and> valid x47 x48 x49 x57 x58 x59 x67 x68 x69
     \<and> valid x71 x72 x73 x81 x82 x83 x91 x92 x93
     \<and> valid x74 x75 x76 x84 x85 x86 x94 x95 x96
     \<and> valid x77 x78 x79 x87 x88 x89 x97 x98 x99"

text \<open>
  Just an arbitrary Sudoku grid:
\<close>

theorem "\<not> sudoku
    x11 x12 x13 x14 x15 x16 x17 x18 x19
    x21 x22 x23 x24 x25 x26 x27 x28 x29
    x31 x32 x33 x34 x35 x36 x37 x38 x39
    x41 x42 x43 x44 x45 x46 x47 x48 x49
    x51 x52 x53 x54 x55 x56 x57 x58 x59
    x61 x62 x63 x64 x65 x66 x67 x68 x69
    x71 x72 x73 x74 x75 x76 x77 x78 x79
    x81 x82 x83 x84 x85 x86 x87 x88 x89
    x91 x92 x93 x94 x95 x96 x97 x98 x99"
  nitpick [expect=genuine]
oops

text \<open>
  An ``easy'' Sudoku:
\<close>

theorem "\<not> sudoku
     5   3  x13 x14  7  x16 x17 x18 x19
     6  x22 x23  1   9   5  x27 x28 x29
    x31  9   8  x34 x35 x36 x37  6  x39
     8  x42 x43 x44  6  x46 x47 x48  3
     4  x52 x53  8  x55  3  x57 x58  1
     7  x62 x63 x64  2  x66 x67 x68  6
    x71  6  x73 x74 x75 x76  2   8  x79
    x81 x82 x83  4   1   9  x87 x88  5
    x91 x92 x93 x94  8  x96 x97  7   9 "
  nitpick [expect=genuine]
oops

text \<open>
  A ``hard'' Sudoku:
\<close>

theorem "\<not> sudoku
    x11  2  x13 x14 x15 x16 x17 x18 x19
    x21 x22 x23  6  x25 x26 x27 x28  3
    x31  7   4  x34  8  x36 x37 x38 x39
    x41 x42 x43 x44 x45  3  x47 x48  2
    x51  8  x53 x54  4  x56 x57  1  x59
     6  x62 x63  5  x65 x66 x67 x68 x69
    x71 x72 x73 x74  1  x76  7   8  x79
     5  x82 x83 x84 x85  9  x87 x88 x89
    x91 x92 x93 x94 x95 x96 x97  4  x99"
  nitpick [expect=genuine]
oops

text \<open>
  Some ``exceptionally difficult'' Sudokus, taken from
  \<^url>\<open>https://en.wikipedia.org/w/index.php?title=Algorithmics_of_sudoku&oldid=254685903\<close>
  (accessed December~2, 2008).
\<close>

text \<open>
\begin{verbatim}
Rating Program: gsf's sudoku q1 (rating)
Rating: 99408
Poster: JPF
Label: Easter Monster
1.......2.9.4...5...6...7...5.9.3.......7.......85..4.7.....6...3...9.8...2.....1
1 . . | . . . | . . 2
. 9 . | 4 . . | . 5 .
. . 6 | . . . | 7 . .
------+-------+------
. 5 . | 9 . 3 | . . .
. . . | . 7 . | . . .
. . . | 8 5 . | . 4 .
------+-------+------
7 . . | . . . | 6 . .
. 3 . | . . 9 | . 8 .
. . 2 | . . . | . . 1
\end{verbatim}
\<close>

theorem "\<not> sudoku
     1  x12 x13 x14 x15 x16 x17 x18  2
    x21  9  x23  4  x25 x26 x27  5  x29
    x31 x32  6  x34 x35 x36  7  x38 x39
    x41  5  x43  9  x45  3  x47 x48 x49
    x51 x52 x53 x54  7  x56 x57 x58 x59
    x61 x62 x63  8   5  x66 x67  4  x69
     7  x72 x73 x74 x75 x76  6  x78 x79
    x81  3  x83 x84 x85  9  x87  8  x89
    x91 x92  2  x94 x95 x96 x97 x98  1 "
  nitpick [expect=genuine]
oops

text \<open>
\begin{verbatim}
Rating Program: gsf's sudoku q1 (Processing time)
Rating: 4m19s@2 GHz
Poster: tarek
Label: tarek071223170000-052
..1..4.......6.3.5...9.....8.....7.3.......285...7.6..3...8...6..92......4...1...
. . 1 | . . 4 | . . .
. . . | . 6 . | 3 . 5
. . . | 9 . . | . . .
------+-------+------
8 . . | . . . | 7 . 3
. . . | . . . | . 2 8
5 . . | . 7 . | 6 . .
------+-------+------
3 . . | . 8 . | . . 6
. . 9 | 2 . . | . . .
. 4 . | . . 1 | . . .
\end{verbatim}
\<close>

theorem "\<not> sudoku
    x11 x12  1  x14 x15  4  x17 x18 x19
    x21 x22 x23 x24  6  x26  3  x28  5
    x31 x32 x33  9  x35 x36 x37 x38 x39
     8  x42 x43 x44 x45 x46  7  x48  3
    x51 x52 x53 x54 x55 x56 x57  2   8
     5  x62 x63 x64  7  x66  6  x68 x69
     3  x72 x73 x74  8  x76 x77 x78  6
    x81 x82  9   2  x85 x86 x87 x88 x89
    x91  4  x93 x94 x95  1  x97 x98 x99"
  nitpick [expect=genuine]
oops

text \<open>
\begin{verbatim}
Rating Program: Nicolas Juillerat's Sudoku explainer 1.2.1
Rating: 11.9
Poster: tarek
Label: golden nugget
.......39.....1..5..3.5.8....8.9...6.7...2...1..4.......9.8..5..2....6..4..7.....
. . . | . . . | . 3 9
. . . | . . 1 | . . 5
. . 3 | . 5 . | 8 . .
------+-------+------
. . 8 | . 9 . | . . 6
. 7 . | . . 2 | . . .
1 . . | 4 . . | . . .
------+-------+------
. . 9 | . 8 . | . 5 .
. 2 . | . . . | 6 . .
4 . . | 7 . . | . . .
\end{verbatim}
\<close>

theorem "\<not> sudoku
    x11 x12 x13 x14 x15 x16 x17  3   9
    x21 x22 x23 x24 x25  1  x27 x28  5
    x31 x32  3  x34  5  x36  8  x38 x39
    x41 x42  8  x44  9  x46 x47 x48  6
    x51  7  x53 x54 x55  2  x57 x58 x59
     1  x62 x63  4  x65 x66 x67 x68 x69
    x71 x72  9  x74  8  x76 x77  5  x79
    x81  2  x83 x84 x85 x86  6  x88 x89
     4  x92 x93  7  x95 x96 x97 x98 x99"
  nitpick [expect=genuine]
oops

text \<open>
\begin{verbatim}
Rating Program: dukuso's suexrat9
Rating: 4483
Poster: coloin
Label: col-02-08-071
.2.4.37.........32........4.4.2...7.8...5.........1...5.....9...3.9....7..1..86..
. 2 . | 4 . 3 | 7 . .
. . . | . . . | . 3 2
. . . | . . . | . . 4
------+-------+------
. 4 . | 2 . . | . 7 .
8 . . | . 5 . | . . .
. . . | . . 1 | . . .
------+-------+------
5 . . | . . . | 9 . .
. 3 . | 9 . . | . . 7
. . 1 | . . 8 | 6 . .
\end{verbatim}
\<close>

theorem "\<not> sudoku
    x11  2  x13  4  x15  3   7  x18 x19
    x21 x22 x23 x24 x25 x26 x27  3   2
    x31 x32 x33 x34 x35 x36 x37 x38  4
    x41  4  x43  2  x45 x46 x47  7  x49
     8  x52 x53 x54  5  x56 x57 x58 x59
    x61 x62 x63 x64 x65  1  x67 x68 x69
     5  x72 x73 x74 x75 x76  9  x78 x79
    x81  3  x83  9  x85 x86 x87 x88  7
    x91 x92  1  x94 x95  8   6  x98 x99"
  nitpick [expect=genuine]
oops

text \<open>
\begin{verbatim}
Rating Program: dukuso's suexratt (10000 2 option)
Rating: 2141
Poster: tarek
Label: golden nugget
.......39.....1..5..3.5.8....8.9...6.7...2...1..4.......9.8..5..2....6..4..7.....
. . . | . . . | . 3 9
. . . | . . 1 | . . 5
. . 3 | . 5 . | 8 . .
------+-------+------
. . 8 | . 9 . | . . 6
. 7 . | . . 2 | . . .
1 . . | 4 . . | . . .
------+-------+------
. . 9 | . 8 . | . 5 .
. 2 . | . . . | 6 . .
4 . . | 7 . . | . . .
\end{verbatim}
\<close>

theorem "\<not> sudoku
    x11 x12 x13 x14 x15 x16 x17  3   9
    x21 x22 x23 x24 x25  1  x27 x28  5
    x31 x32  3  x34  5  x36  8  x38 x39
    x41 x42  8  x44  9  x46 x47 x48  6
    x51  7  x53 x54 x55  2  x57 x58 x59
     1  x62 x63  4  x65 x66 x67 x68 x69
    x71 x72  9  x74  8  x76 x77  5  x79
    x81  2  x83 x84 x85 x86  6  x88 x89
     4  x92 x93  7  x95 x96 x97 x98 x99"
  nitpick [expect=genuine]
oops

end


theory Xor imports
  "HOL-Algebra.Complete_Lattice"
  "CryptHOL.Misc_CryptHOL"
begin

(* disable lattice syntax for type class lattices *)
no_notation
  bot_class.bot ("\<bottom>") and
  top_class.top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65)

context bounded_lattice begin

lemma top_join [simp]: "x \<in> carrier L \<Longrightarrow> \<top> \<squnion> x = \<top>"
  using eq_is_equal top_join by auto

lemma join_top [simp]: "x \<in> carrier L \<Longrightarrow> x \<squnion> \<top> = \<top>"
  using le_iff_meet by blast

lemma bot_join [simp]: "x \<in> carrier L \<Longrightarrow> \<bottom> \<squnion> x = x"
  using le_iff_meet by blast

lemma join_bot [simp]: "x \<in> carrier L \<Longrightarrow> x \<squnion> \<bottom> = x"
  by (metis bot_join join_comm)

lemma bot_meet [simp]: "x \<in> carrier L \<Longrightarrow> \<bottom> \<sqinter> x = \<bottom>"
  using bottom_meet by auto

lemma meet_bot [simp]: "x \<in> carrier L \<Longrightarrow> x \<sqinter> \<bottom> = \<bottom>"
  by (metis bot_meet meet_comm)

lemma top_meet [simp]: "x \<in> carrier L \<Longrightarrow> \<top> \<sqinter> x = x"
  by (metis le_iff_join meet_comm top_closed top_higher)

lemma meet_top [simp]: "x \<in> carrier L \<Longrightarrow> x \<sqinter> \<top> = x"
  by (metis meet_comm top_meet)

lemma join_idem [simp]: "x \<in> carrier L \<Longrightarrow> x \<squnion> x = x"
  using le_iff_meet by blast

lemma meet_idem [simp]: "x \<in> carrier L \<Longrightarrow> x \<sqinter> x = x"
  using le_iff_join le_refl by presburger

lemma meet_leftcomm: "x \<sqinter> (y \<sqinter> z) = y \<sqinter> (x \<sqinter> z)" if "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
  by (metis meet_assoc meet_comm that)

lemma join_leftcomm: "x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)" if "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
  by (metis join_assoc join_comm that)

lemmas meet_ac = meet_assoc meet_comm meet_leftcomm
lemmas join_ac = join_assoc join_comm join_leftcomm

end

record 'a boolean_algebra = "'a gorder" +
  compl :: "'a \<Rightarrow> 'a" ("\<^bold>-\<index>" 1000)

definition xor :: "('a, 'b) boolean_algebra_scheme \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<oplus>\<index>" 100) where
  "x \<oplus> y = (x \<squnion> y) \<sqinter> (\<^bold>- (x \<sqinter> y))" for L (structure)

locale boolean_algebra = bounded_lattice L
  for L (structure) +
  assumes compl_closed [intro, simp]: "x \<in> carrier L \<Longrightarrow> \<^bold>- x \<in> carrier L"
    and meet_compl_bot [simp]: "x \<in> carrier L \<Longrightarrow> \<^bold>- x \<sqinter> x = \<bottom>"
    and join_compl_top [simp]: "x \<in> carrier L \<Longrightarrow> \<^bold>- x \<squnion> x = \<top>"
    and join_meet_distrib1: "\<lbrakk> x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
begin

lemma join_meet_distrib2: "(y \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  if "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
  by (simp add: join_comm join_meet_distrib1 that)

lemma meet_join_distrib1: "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
  if [simp]: "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
proof -
  have "x \<sqinter> (y \<squnion> z) = (x \<sqinter> (x \<squnion> z)) \<sqinter> (y \<squnion> z)"
    using join_left le_iff_join by auto
  also have "\<dots> = x \<sqinter> (z \<squnion> (x \<sqinter> y))"
    by (simp add: join_comm join_meet_distrib1 meet_assoc)
  also have "\<dots> = ((x \<sqinter> y) \<squnion> x) \<sqinter> ((x \<sqinter> y) \<squnion> z)"
    by (metis join_comm le_iff_meet meet_closed meet_left that(1) that(2))
  also have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
    by (simp add: join_meet_distrib1)
  finally show ?thesis .
qed

lemma meet_join_distrib2: "(y \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
  if [simp]: "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
  by (simp add: meet_comm meet_join_distrib1)

lemmas join_meet_distrib = join_meet_distrib1 join_meet_distrib2

lemmas meet_join_distrib = meet_join_distrib1 meet_join_distrib2

lemmas distrib = join_meet_distrib meet_join_distrib

lemma meet_compl2_bot [simp]: "x \<in> carrier L \<Longrightarrow> x \<sqinter> \<^bold>- x = \<bottom>"
  by (metis meet_comm meet_compl_bot)

lemma join_compl2_top [simp]: "x \<in> carrier L \<Longrightarrow> x \<squnion> \<^bold>- x = \<top>"
  by (metis join_comm join_compl_top)

lemma compl_unique:
  assumes "x \<sqinter> y = \<bottom>"
    and "x \<squnion> y = \<top>"
    and [simp]: "x \<in> carrier L" "y \<in> carrier L"
  shows "\<^bold>- x = y"
proof -
  have "(x \<sqinter> \<^bold>- x) \<squnion> (\<^bold>- x \<sqinter> y) = (x \<sqinter> y) \<squnion> (\<^bold>- x \<sqinter> y)"
    using inf_compl_bot assms(1) by simp
  then have "(\<^bold>- x \<sqinter> x) \<squnion> (\<^bold>- x \<sqinter> y) = (y \<sqinter> x) \<squnion> (y \<sqinter> \<^bold>- x)"
    by (simp add: meet_comm)
  then have "\<^bold>- x \<sqinter> (x \<squnion> y) = y \<sqinter> (x \<squnion> \<^bold>- x)"
    using assms(3) assms(4) compl_closed meet_join_distrib1 by presburger
  then have "\<^bold>- x \<sqinter> \<top> = y \<sqinter> \<top>"
    by (simp add: assms(2))
  then show "\<^bold>- x = y"
    using le_iff_join top_higher by auto
qed

lemma double_compl [simp]: "\<^bold>- (\<^bold>- x) = x" if [simp]: "x \<in> carrier L"
  by(rule compl_unique)(simp_all)

lemma compl_eq_compl_iff [simp]: "\<^bold>- x = \<^bold>- y \<longleftrightarrow> x = y" if "x \<in> carrier L" "y \<in> carrier L"
  by (metis double_compl that that)

lemma compl_bot_eq [simp]: "\<^bold>- \<bottom> = \<top>"
  using le_iff_join le_iff_meet local.compl_unique top_higher by auto

lemma compl_top_eq [simp]: "\<^bold>- \<top> = \<bottom>"
  by (metis bottom_closed compl_bot_eq double_compl)

lemma compl_inf [simp]: "\<^bold>- (x \<sqinter> y) = \<^bold>- x \<squnion> \<^bold>- y" if [simp]: "x \<in> carrier L" "y \<in> carrier L"
proof (rule compl_unique)
  have "(x \<sqinter> y) \<sqinter> (\<^bold>- x \<squnion> \<^bold>- y) = (y \<sqinter> (x \<sqinter> \<^bold>- x)) \<squnion> (x \<sqinter> (y \<sqinter> \<^bold>- y))"
    by (smt compl_closed meet_assoc meet_closed meet_comm meet_join_distrib1 that)
  then show "(x \<sqinter> y) \<sqinter> (\<^bold>- x \<squnion> \<^bold>- y) = \<bottom>"
    by (metis bottom_closed bottom_lower le_iff_join le_iff_meet meet_comm meet_compl2_bot that)
next
  have "(x \<sqinter> y) \<squnion> (\<^bold>- x \<squnion> \<^bold>- y) = (\<^bold>- y \<squnion> (x \<squnion> \<^bold>- x)) \<sqinter> (\<^bold>- x \<squnion> (y \<squnion> \<^bold>- y))"
    by (smt compl_closed join_meet_distrib2 join_assoc join_comm local.boolean_algebra_axioms that join_closed)
  then show "(x \<sqinter> y) \<squnion> (\<^bold>- x \<squnion> \<^bold>- y) = \<top>"
    by (metis compl_closed join_compl2_top join_right le_iff_join le_iff_meet that top_closed)
qed simp_all

lemma compl_sup [simp]: "\<^bold>- (x \<squnion> y) = \<^bold>- x \<sqinter> \<^bold>- y" if "x \<in> carrier L" "y \<in> carrier L"
  by (metis compl_closed compl_inf double_compl meet_closed that)

lemma compl_mono:
  assumes "x \<sqsubseteq> y"
    and "x \<in> carrier L" "y \<in> carrier L"
  shows "\<^bold>- y \<sqsubseteq> \<^bold>- x"
  by (metis assms(1) assms(2) assms(3) compl_closed join_comm le_iff_join le_iff_meet compl_inf)

lemma compl_le_compl_iff [simp]: "\<^bold>- x \<sqsubseteq> \<^bold>- y \<longleftrightarrow> y \<sqsubseteq> x" if "x \<in> carrier L" "y \<in> carrier L"
  using that by (auto dest: compl_mono)

lemma compl_le_swap2:
  assumes "\<^bold>- y \<sqsubseteq> x" "x \<in> carrier L" "y \<in> carrier L"
  shows "\<^bold>- x \<sqsubseteq> y"
  by (metis assms compl_closed compl_le_compl_iff double_compl)

lemma join_compl_top_left1 [simp]: "\<^bold>- x \<squnion> (x \<squnion> y) = \<top>" if [simp]: "x \<in> carrier L" "y \<in> carrier L"
  by (simp add: join_assoc[symmetric])

lemma join_compl_top_left2 [simp]: "x \<squnion> (\<^bold>- x \<squnion> y) = \<top>" if [simp]: "x \<in> carrier L" "y \<in> carrier L"
  using join_compl_top_left1[of "\<^bold>- x" y] by simp

lemma meet_compl_bot_left1 [simp]: "\<^bold>- x \<sqinter> (x \<sqinter> y) = \<bottom>" if [simp]: "x \<in> carrier L" "y \<in> carrier L"
  by (simp add: meet_assoc[symmetric])

lemma meet_compl_bot_left2 [simp]: "x \<sqinter> (\<^bold>- x \<sqinter> y) = \<bottom>" if [simp]: "x \<in> carrier L" "y \<in> carrier L"
  using meet_compl_bot_left1[of "\<^bold>- x" y] by simp

lemma meet_compl_bot_right [simp]: "x \<sqinter> (y \<sqinter> \<^bold>- x) = \<bottom>" if [simp]: "x \<in> carrier L" "y \<in> carrier L"
  by (metis meet_compl_bot_left2 meet_comm that)

lemma xor_closed [intro, simp]: "\<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<oplus> y \<in> carrier L"
  by(simp add: xor_def)

lemma xor_comm: "\<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<oplus> y = y \<oplus> x"
  by(simp add: xor_def meet_join_distrib join_comm)

lemma xor_assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  if [simp]: "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
  by(simp add: xor_def)(simp add: meet_join_distrib meet_ac join_ac)

lemma xor_left_comm: "x \<oplus> (y \<oplus> z) = y \<oplus> (x \<oplus> z)" if "x \<in> carrier L" "y \<in> carrier L" "z \<in> carrier L"
  using that xor_assoc xor_comm by auto

lemma xor_inverse [simp]: "x \<oplus> x = \<bottom>" if "x \<in> carrier L"
  by(simp add: xor_def that)

lemma xor_left_inverse [simp]: "x \<oplus> x \<oplus> y = y" if "x \<in> carrier L" "y \<in> carrier L"
  using that xor_assoc by fastforce

lemmas xor_ac = xor_assoc xor_comm xor_left_comm

lemma inj_on_xor: "inj_on ((\<oplus>) x) (carrier L)" if "x \<in> carrier L"
  by(rule inj_onI)(metis that xor_left_inverse)

lemma surj_xor: "(\<oplus>) x ` carrier L = carrier L" if [simp]: "x \<in> carrier L"
proof(rule Set.set_eqI, rule iffI)
  fix y
  assume [simp]: "y \<in> carrier L"
  have "x \<oplus> y \<in> carrier L" by(simp)
  moreover have "y = x \<oplus> (x \<oplus> y)" by simp
  ultimately show "y \<in> (\<oplus>) x ` carrier L" by(rule rev_image_eqI)
qed auto

lemma one_time_pad: "map_spmf ((\<oplus>) x) (spmf_of_set (carrier L)) = spmf_of_set (carrier L)"
  if "x \<in> carrier L"
  apply(subst map_spmf_of_set_inj_on)
   apply(rule inj_on_xor[OF that])
  by(simp add: surj_xor that)

end

end