theory FiniteGraph
imports Main
begin

(*Lots of this theory is based on a work by Benedikt Nordhoff and Peter Lammich*)

section {*Specification of a finite directed graph*}

text{* A graph @{text "G=(V,E)"} consits of a set of vertices @{text V}, also called nodes,
       and a set of edges @{text E}. The edges are tuples of vertices. Both,
       the set of vertices and edges is finite. *}

(* Inspired by
Title: Dijkstra's Shortest Path Algorithm
Author: Benedikt Nordhoff and Peter Lammich
http://isa-afp.org/entries/Dijkstra_Shortest_Path.shtml
*)

section {* Graph  *}
subsection{*Definitions*}
  text {* A graph is represented by a record. *}
  record 'v graph =
    nodes :: "'v set"
    edges :: "('v \<times>'v) set"

  text {* In a well-formed graph, edges only go from nodes to nodes. *}
  locale wf_graph =
    fixes G :: "'v graph"
    -- "Edges only reference to existing nodes"
    assumes E_wf: "fst ` (edges G) \<subseteq> (nodes G)"
                     "snd ` (edges G) \<subseteq> (nodes G)"
    and finiteE: "finite (edges G)" (*implied by finiteV*)
    and finiteV: "finite (nodes G)"
  begin
    abbreviation "V \<equiv> (nodes G)"
    abbreviation "E \<equiv> (edges G)"

    lemma E_wfD2: "\<forall>e \<in> E. fst e \<in> V \<and> snd e \<in> V"
    by (auto simp add: E_wfD)
  end

subsection {* Basic operations on Graphs *}
  text {* The empty graph. *}
  definition empty :: "'v graph" where
    "empty \<equiv> \<lparr> nodes = {}, edges = {} \<rparr>"

  text {* Adds a node to a graph. *}
  definition add_node :: "'v \<Rightarrow> 'v graph \<Rightarrow> 'v graph" where
    "add_node v G \<equiv> \<lparr> nodes = ({v} \<union> (nodes G)), edges=edges G \<rparr>"

  text {* Deletes a node from a graph. Also deletes all adjacent edges. *}
  definition delete_node where "delete_node v G \<equiv> \<lparr>
      nodes = (nodes G) - {v},
      edges = {(e1, e2). (e1, e2) \<in> edges G \<and> e1 \<noteq> v \<and> e2 \<noteq> v}
    \<rparr>"

  text {* Adds an edge to a graph. *}
  definition add_edge where
  "add_edge v v' G = \<lparr>nodes = nodes G \<union> {v,v'}, edges = {(v, v')} \<union> edges G \<rparr>"

  text {* Deletes an edge from a graph. *}
  definition delete_edge where "delete_edge v v' G \<equiv> \<lparr>
      nodes = nodes G,
      edges = {(e1,e2). (e1, e2) \<in> edges G \<and> (e1,e2) \<noteq> (v,v')}
    \<rparr>"

  definition delete_edges::"'v graph \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> 'v graph" where
    "delete_edges G es \<equiv> \<lparr>
      nodes = nodes G,
      edges = {(e1,e2). (e1, e2) \<in> edges G \<and> (e1,e2) \<notin> es}
    \<rparr>"

  fun delete_edges_list::"'v graph \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> 'v graph" where
    "delete_edges_list G [] = G"|
    "delete_edges_list G ((v,v')#es) = delete_edges_list (delete_edge v v' G) es"

  definition fully_connected :: "'v graph \<Rightarrow> 'v graph" where
    "fully_connected G \<equiv> \<lparr>nodes = nodes G, edges = nodes G \<times> nodes G \<rparr>"

text {* Extended graph operations *}
  text {* Reflexive transitive successors of a node. Or: All reachable nodes for @{text v} including @{text v}. *}
  definition succ_rtran :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set" where
    "succ_rtran G v = {e2. (v,e2) \<in> (edges G)\<^sup>*}"

  text {* Transitive successors of a node. Or: All reachable nodes for @{text v}. *}
  definition succ_tran :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set" where
    "succ_tran G v = {e2. (v,e2) \<in> (edges G)\<^sup>+}"

  --"succ_tran is always finite"
  lemma succ_tran_finite: "wf_graph G \<Longrightarrow> finite (succ_tran G v)"
  proof -
    assume "wf_graph G"
    from wf_graph.finiteE[OF this] have "finite ((edges G)\<^sup>+)" using finite_trancl[symmetric, of "edges G"] by metis
    from this have "finite {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by simp
    from this have finite: "finite (snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+})" by (metis finite_imageI)
    have "{(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} \<subseteq> {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    have 1: "snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} \<subseteq> snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    have 2: "snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} = {e2. (v,e2) \<in> (edges G)\<^sup>+}" by force
    from 1 2 have "{e2. (v,e2) \<in> (edges G)\<^sup>+} \<subseteq> snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    from this finite have "finite {e2. (v, e2) \<in> (edges G)\<^sup>+}" by (metis finite_subset)
    thus "finite (succ_tran G v)" using succ_tran_def by metis
  qed

  text{* If there is no edge leaving from @{text v}, then @{text v} has no successors *}
  lemma succ_tran_empty: "\<lbrakk> wf_graph G; v \<notin> (fst ` edges G) \<rbrakk> \<Longrightarrow> succ_tran G v = {}"
    unfolding succ_tran_def using image_iff tranclD by fastforce

  text{* @{const succ_tran} is subset of nodes *}
  lemma succ_tran_subseteq_nodes: "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow> succ_tran G v \<subseteq> nodes G"
    unfolding succ_tran_def using tranclD2 wf_graph.E_wfD(2) by fastforce

  text {* The number of reachable nodes from @{text v} *}
  definition num_reachable :: "'v graph \<Rightarrow> 'v \<Rightarrow> nat" where
    "num_reachable G v = card (succ_tran G v)"

  definition num_reachable_norefl :: "'v graph \<Rightarrow> 'v \<Rightarrow> nat" where
    "num_reachable_norefl G v = card (succ_tran G v - {v})"

  text{*@{const card} returns @{term 0} for infinite sets.
        Here, for a well-formed graph, if @{const num_reachable} is zero, there are actually no nodes reachable.*}
  lemma num_reachable_zero: "\<lbrakk>wf_graph G; num_reachable G v = 0\<rbrakk> \<Longrightarrow> succ_tran G v = {}"
  unfolding num_reachable_def
  apply(subgoal_tac "finite (succ_tran G v)")
   apply(simp)
  apply(blast intro: succ_tran_finite)
  done
  lemma num_succtran_zero: "\<lbrakk>succ_tran G v = {}\<rbrakk> \<Longrightarrow> num_reachable G v = 0"
    unfolding num_reachable_def by simp
  lemma num_reachable_zero_iff: "\<lbrakk>wf_graph G\<rbrakk> \<Longrightarrow> (num_reachable G v = 0) \<longleftrightarrow> (succ_tran G v = {})"
  by(metis num_succtran_zero num_reachable_zero)

section{*Undirected Graph*}

subsection{*undirected graph simulation*}
  text {* Create undirected graph from directed graph by adding backward links *}

  definition backflows :: "('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set" where
    "backflows E \<equiv> {(r,s). (s,r) \<in> E}"

  definition undirected :: "'v graph \<Rightarrow> 'v graph"
    where "undirected G = \<lparr> nodes = nodes G, edges = (edges G) \<union> {(b,a). (a,b) \<in> edges G} \<rparr>"

section {*Graph Lemmas*}

  lemma graph_eq_intro: "(nodes (G::'a graph) = nodes G') \<Longrightarrow> (edges G = edges G') \<Longrightarrow> G = G'" by simp

  -- "finite"
  lemma wf_graph_finite_filterE: "wf_graph G \<Longrightarrow> finite {(e1, e2). (e1, e2) \<in> edges G \<and> P e1 e2}"
  by(simp add: wf_graph.finiteE split_def)
  lemma wf_graph_finite_filterV: "wf_graph G \<Longrightarrow> finite {n. n \<in> nodes G \<and> P n}"
  by(simp add: wf_graph.finiteV)

  -- "empty"
  lemma empty_wf[simp]: "wf_graph empty"
    unfolding empty_def by unfold_locales auto
  lemma nodes_empty[simp]: "nodes empty = {}" unfolding empty_def by simp
  lemma edges_empty[simp]: "edges empty = {}" unfolding empty_def by simp

  -- "add node"
  lemma add_node_wf[simp]: "wf_graph g \<Longrightarrow> wf_graph (add_node v g)"
    unfolding add_node_def wf_graph_def by (auto)

  lemma delete_node_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_node v G)"
    by(auto simp add: delete_node_def wf_graph_def wf_graph_finite_filterE)

  -- "add edgde"
  lemma add_edge_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (add_edge v v' G)"
    by(auto simp add: add_edge_def add_node_def wf_graph_def)

  -- "delete edge"
  lemma delete_edge_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_edge v v' G)"
    by(auto simp add: delete_edge_def add_node_def wf_graph_def split_def)

  -- "delte edges"
  lemma delete_edges_list_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_edges_list G E)"
    by(induction E arbitrary: G, simp, force)
  lemma delete_edges_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_edges G E)"
    by(auto simp add: delete_edges_def add_node_def wf_graph_def split_def)
  lemma delete_edges_list_set: "delete_edges_list G E = delete_edges G (set E)"
    proof(induction E arbitrary: G)
    case Nil thus ?case by (simp add: delete_edges_def)
    next
    case (Cons e E) thus ?case by(cases e)(simp add: delete_edge_def delete_edges_def)
    qed
  lemma delete_edges_list_union: "delete_edges_list G (ff @ keeps) = delete_edges G (set ff \<union> set keeps)"
   by(simp add: delete_edges_list_set)
  lemma add_edge_delete_edges_list:
    "(add_edge (fst a) (snd a) (delete_edges_list G (a # ff))) = (add_edge (fst a) (snd a) (delete_edges G (set ff)))"
   by(auto simp add: delete_edges_list_set delete_edges_def add_edge_def add_node_def)
  lemma delete_edges_empty[simp]: "delete_edges G {} = G"
   by(simp add: delete_edges_def)
  lemma delete_edges_simp2: "delete_edges G E = \<lparr> nodes = nodes G, edges = edges G - E\<rparr>"
   by(auto simp add: delete_edges_def)
  lemma delete_edges_set_nodes: "nodes (delete_edges G E) = nodes G"
   by(simp add: delete_edges_simp2)
  lemma delete_edges_edges_mono: "E' \<subseteq> E \<Longrightarrow> edges (delete_edges G E) \<subseteq> edges (delete_edges G E')"
    by(simp add: delete_edges_def, fast)
  lemma delete_edges_edges_empty: "(delete_edges G (edges G)) = G\<lparr>edges := {}\<rparr>"
    by(simp add: delete_edges_simp2)

 --"add delete"
  lemma add_delete_edge: "wf_graph (G::'a graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow> add_edge a b (delete_edge a b G) = G"
   apply(simp add: delete_edge_def add_edge_def wf_graph_def)
   apply(intro graph_eq_intro)
    by auto

  lemma add_delete_edges: "wf_graph (G::'v graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow> (a,b) \<notin> fs \<Longrightarrow>
    add_edge a b (delete_edges G (insert (a, b) fs)) = (delete_edges G fs)"
    by(auto simp add: delete_edges_simp2 add_edge_def wf_graph_def)

 --"fully_connected"
  lemma fully_connected_simp: "fully_connected \<lparr>nodes = N, edges = ignore \<rparr>\<equiv> \<lparr>nodes = N, edges = N \<times> N \<rparr>"
    by(simp add: fully_connected_def)
  lemma fully_connected_wf: "wf_graph G \<Longrightarrow> wf_graph (fully_connected G)"
    by(simp add: fully_connected_def wf_graph_def)

 --"succ_tran"
 lemma succ_tran_mono:
  "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> succ_tran \<lparr>nodes=N, edges=E'\<rparr> v \<subseteq> succ_tran \<lparr>nodes=N, edges=E\<rparr> v"
   apply(drule wf_graph.finiteE)
   apply(frule_tac A="E'" in rev_finite_subset, simp)
   apply(simp add: num_reachable_def)
   apply(simp add: succ_tran_def)
   apply(metis (lifting, full_types) Collect_mono trancl_mono)
  done

  --"num_reachable"
  lemma num_reachable_mono:
  "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> num_reachable \<lparr>nodes=N, edges=E'\<rparr> v \<le> num_reachable \<lparr>nodes=N, edges=E\<rparr> v"
   apply(simp add: num_reachable_def)
   apply(frule_tac E'="E'" and v="v" in succ_tran_mono, simp)
   apply(frule_tac v="v" in succ_tran_finite)
   apply(simp add: card_mono)
  done

  --"num_reachable_norefl"
  lemma num_reachable_norefl_mono:
  "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> num_reachable_norefl \<lparr>nodes=N, edges=E'\<rparr> v \<le> num_reachable_norefl \<lparr>nodes=N, edges=E\<rparr> v"
   apply(simp add: num_reachable_norefl_def)
   apply(frule_tac E'="E'" and v="v" in succ_tran_mono, simp)
   apply(frule_tac v="v" in succ_tran_finite)
   using card_mono by (metis Diff_mono finite_Diff subset_refl)

  --"backflows"
  lemma backflows_wf:
    "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> wf_graph \<lparr>nodes=N, edges=backflows E\<rparr>"
    using [[simproc add: finite_Collect]] by(auto simp add: wf_graph_def backflows_def)
  lemma undirected_backflows:
    "undirected G = \<lparr> nodes = nodes G, edges = (edges G) \<union> backflows (edges G) \<rparr>"
    by(simp add: backflows_def undirected_def)
  lemma backflows_id:
    "backflows (backflows E) = E"
    by(simp add: backflows_def)

lemmas graph_ops=add_node_def delete_node_def add_edge_def delete_edge_def delete_edges_simp2

  --"wf_graph"
  lemma wf_graph_remove_edges: "wf_graph \<lparr> nodes = V, edges = E \<rparr> \<Longrightarrow> wf_graph \<lparr> nodes = V, edges=E - X\<rparr>"
    by (metis delete_edges_simp2 delete_edges_wf select_convs(1) select_convs(2))

  lemma wf_graph_remove_edges_union:
    "wf_graph \<lparr> nodes = V, edges = E \<union> E' \<rparr> \<Longrightarrow> wf_graph \<lparr> nodes = V, edges=E\<rparr>"
    by(auto simp add: wf_graph_def)

  lemma wf_graph_union_edges: "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; wf_graph \<lparr> nodes = V, edges=E'\<rparr> \<rbrakk> \<Longrightarrow>
     wf_graph \<lparr> nodes = V, edges=E \<union> E'\<rparr>"
    by(auto simp add: wf_graph_def)

  lemma wf_graph_add_subset_edges: "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; E' \<subseteq> E \<rbrakk> \<Longrightarrow>
     wf_graph \<lparr> nodes = V, edges= E \<union> E'\<rparr>"
    by(auto simp add: wf_graph_def) (metis rev_finite_subset)

(*Inspired by
Benedikt Nordhoff and Peter Lammich
Dijkstra's Shortest Path Algorithm
http://isa-afp.org/entries/Dijkstra_Shortest_Path.shtml*)
(*more a literal copy of http://isa-afp.org/browser_info/current/AFP/Dijkstra_Shortest_Path/Graph.html*)

  text {* Successors of a node. *}
  definition succ :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set"
    where "succ G v \<equiv> {v'. (v,v')\<in>edges G}"

  lemma succ_finite[simp, intro]: "finite (edges G) \<Longrightarrow> finite (succ G v)"
    unfolding succ_def
    by (rule finite_subset[where B="snd`edges G"]) force+

  lemma succ_empty: "succ empty v = {}" unfolding empty_def succ_def by auto

  lemma (in wf_graph) succ_subset: "succ G v \<subseteq> V"
    unfolding succ_def using E_wf
    by (force)

end


theory Solver
  imports Main
begin

datatype formula = Var string | Const bool | Not formula | And formula formula | Or formula formula

type_synonym state = "string \<Rightarrow> bool"

fun eval :: "formula \<Rightarrow> state \<Rightarrow> bool"
  where
    "eval (Const b) s = b"
  | "eval (Var x) s = s x"
  | "eval (Not F) s = (\<not>(eval F s))"
  | "eval (And F G) s = (eval F s \<and> eval G s)"
  | "eval (Or F G) s = (eval F s \<or> eval G s)"

definition satisfiable :: "formula \<Rightarrow> bool"
  where "satisfiable F \<equiv> (\<exists>s. eval F s = True)"

lemma "satisfiable (Const True)"
proof -
  have "eval (Const True) (\<lambda>x. True)" by simp
  thus ?thesis using satisfiable_def by simp
qed

lemma "\<not>satisfiable (Const False)"
proof -
  have "\<forall>s. eval (Const False) s = False" by simp
  thus ?thesis using satisfiable_def by simp
qed

datatype literal = P string | N string

type_synonym clauseCNF = "literal list"

type_synonym formulaCNF = "clauseCNF list"

fun leval :: "literal \<Rightarrow> state \<Rightarrow> bool"
  where
    "leval (P x) s = s x"
  | "leval (N x) s = (\<not>s x)"

fun ceval :: "clauseCNF \<Rightarrow> state \<Rightarrow> bool"
  where
    "ceval [] s = False"
  | "ceval (l # ls) s = (leval l s \<or> ceval ls s)"

fun evalCNF :: "formulaCNF \<Rightarrow> state \<Rightarrow> bool"
  where
    "evalCNF [] s = True"
  | "evalCNF (c # cs) s = (ceval c s \<and> evalCNF cs s)"

fun literal_to_formula :: "literal \<Rightarrow> formula"
  where
    "literal_to_formula (P x) = Var x"
  | "literal_to_formula (N x) = Not (Var x)"

fun clause_to_formula :: "clauseCNF \<Rightarrow> formula"
  where
    "clause_to_formula [] = Const False"
  | "clause_to_formula (l # ls) = Or (literal_to_formula l) (clause_to_formula ls)"

fun toFormula :: "formulaCNF \<Rightarrow> formula"
  where
    "toFormula [] = Const True"
  | "toFormula (c # cs) = And (clause_to_formula c) (toFormula cs)"

lemma ltf_eval: "leval l s \<longleftrightarrow> eval (literal_to_formula l) s"
  by (induction l) auto

lemma ctf_eval: "ceval c s \<longleftrightarrow> eval (clause_to_formula c) s"
  by (induction c) (auto simp: ltf_eval)

lemma toFormula_eval: "evalCNF cs s \<longleftrightarrow> eval (toFormula cs) s"
  by (induction cs) (auto simp: ctf_eval)

fun toCNF :: "formula \<Rightarrow> formulaCNF"
  where
    "toCNF (Var x) = [[P x]]"
  | "toCNF (Const b) = (if b then [] else [[]])"
(*| "toCNF (Not F) = (case F of (Var x) \<Rightarrow> [[N x]]
                                | Const b \<Rightarrow> toCNF (Const (\<not>b))
                                | Not G \<Rightarrow> toCNF G
                                | And G H \<Rightarrow> [c1@c2 . c1 \<leftarrow> toCNF (Not G), c2 \<leftarrow> toCNF (Not H)]
                                | Or G H \<Rightarrow> toCNF (Not G) @ toCNF (Not H))"*)
  | "toCNF (Not (Var x)) = [[N x]]"
  | "toCNF (Not (Const b)) = toCNF (Const (\<not>b))"
  | "toCNF (Not (Not G)) = toCNF G"
  | "toCNF (Not (And F G)) = [c1@c2 . c1 \<leftarrow> toCNF (Not F), c2 \<leftarrow> toCNF (Not G)]"
  | "toCNF (Not (Or F G)) = toCNF (Not F) @ toCNF (Not G)"
  | "toCNF (And F G) = (toCNF F) @ (toCNF G)"
  | "toCNF (Or F G) = [c1@c2 . c1 \<leftarrow> toCNF F, c2 \<leftarrow> toCNF G]"

lemma evalCNF_app: "evalCNF (cs1 @ cs2) s = (evalCNF cs1 s \<and> evalCNF cs2 s)"
  by (induction cs1) auto

lemma evalCNF_fold_aux: "(b \<and> evalCNF cs s) = fold (\<lambda>c b. ceval c s \<and> b) cs b"
  by (induction cs arbitrary: b) (simp_all, metis)

lemma evalCNF_is_fold: "evalCNF cs s = fold (\<lambda>c b. ceval c s \<and> b) cs True"
  using evalCNF_fold_aux by auto

lemma ceval_app: "ceval (c1 @ c2) s = (ceval c1 s \<or> ceval c2 s)"
  by (induction c1) auto

lemma cnf_or_distr: "evalCNF (map ((@) a) cs) s = (ceval a s \<or> evalCNF cs s)"
  by (induction cs) (auto simp: ceval_app)

lemma cnf_or: "evalCNF [c1@c2 . c1 \<leftarrow> cs1, c2 \<leftarrow> cs2] s = (evalCNF cs1 s \<or> evalCNF cs2 s)"
  by (induction cs1) (auto simp: evalCNF_app cnf_or_distr)

lemma deMorgan_NAND: "eval (Not (And F G)) = eval (Or (Not F) (Not G))"
  by (induction F) auto

lemma deMorgan_NOR: "eval (Not (Or F G)) = eval (And (Not F) (Not G))"
  by (induction F) auto

lemma evalCNF_not: "evalCNF (toCNF (formula.Not F)) s = (\<not>evalCNF (toCNF F) s)"
  by (induction F) (auto split: if_splits simp: evalCNF_app cnf_or)

lemma toCNF_eval: "eval F s \<longleftrightarrow> evalCNF (toCNF F) s"
  by (induction F) (auto simp: evalCNF_app cnf_or evalCNF_not)

fun literal_var :: "literal \<Rightarrow> string"
  where
    "literal_var (P x) = x"
  | "literal_var (N x) = x"

fun clause_vars :: "clauseCNF \<Rightarrow> string list"
  where
    "clause_vars [] = []"
  | "clause_vars (l # ls) = literal_var l # clause_vars ls"

fun cnf_vars :: "formulaCNF \<Rightarrow> string list"
  where
    "cnf_vars [] = []"
  | "cnf_vars (c # cs) = clause_vars c @ cnf_vars cs"

fun vals :: "string list \<Rightarrow> state list"
  where
    "vals [] = [\<lambda>s. False]"
  | "vals (x # xs) = [s(x:=False) . s \<leftarrow> vals xs] @ [s(x:=True) . s \<leftarrow> vals xs]"

definition solver_bruteforce :: "formulaCNF \<Rightarrow> bool"
  where
    "solver_bruteforce cs = fold (\<or>) [evalCNF cs s . s \<leftarrow> vals (cnf_vars cs)] (False)"

lemma not_foldOrFalse_if_not_contains_True: "True \<notin> set ls \<Longrightarrow> fold (\<or>) ls (False) = False"
  by (induction ls) auto

lemma foldOr_true: "fold (\<or>) ls True = True"
  by (induction ls) auto

lemma foldOrFalse_weaker: "fold (\<or>) ls False \<Longrightarrow> fold (\<or>) ls b"
proof (induction ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  have "fold (\<or>) (a # ls) False = fold (\<or>) ls a" by simp
  then show ?case using Cons by (cases a, auto)
qed

lemma fold_or_False_if_contains_True: "True \<in> set ls \<Longrightarrow> fold (\<or>) ls False"
proof (induction ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  then have "a = True \<or> True \<in> set ls" by simp
  then show ?case
  proof (rule disjE)
    assume "a = True"
    then show "fold (\<or>) (a # ls) False" using foldOr_true \<open>a = True\<close> by auto
  next
    assume "True \<in> set ls"
    then have "fold (\<or>) ls False" using Cons by simp
    then show "fold (\<or>) (a # ls) False" using foldOrFalse_weaker by simp
  qed
qed

lemma foldOr_iff_contains_True: "fold (\<or>) ls False = (True \<in> set ls)"
  using not_foldOrFalse_if_not_contains_True fold_or_False_if_contains_True by auto

lemma solver_bruteforce_alt_def:"solver_bruteforce cs = (\<exists>s \<in> set (vals (cnf_vars cs)). evalCNF cs s)"
  unfolding solver_bruteforce_def
  using foldOr_iff_contains_True by auto

lemma solver_bruteforce_correct: "solver_bruteforce cs \<Longrightarrow> satisfiable (toFormula cs)"
  unfolding satisfiable_def
  using solver_bruteforce_alt_def toFormula_eval by blast

lemma vals_false_everywhere_else: "(\<And>x. x \<notin> set cs \<Longrightarrow> t x = False) \<Longrightarrow> (t \<in> set (vals cs))"
  apply (induction cs arbitrary: t)
   apply auto
  by (smt (z3) fun_upd_def fun_upd_triv fun_upd_upd image_iff)

lemma vals_contains_aux: "\<forall>s. \<exists>t \<in> set (vals (cnf_vars cs)). \<forall>x \<in> set (cnf_vars cs). (s x = t x)"
proof
  fix s
  let ?t = "(\<lambda>x. (if x \<in> set (cnf_vars cs) then s x else False))"
  have *: "?t \<in> set (vals (cnf_vars cs))" using vals_false_everywhere_else by simp
  have "\<forall>x \<in> set (cnf_vars cs). (s x = ?t x)" by simp
  then show "\<exists>t \<in> set (vals (cnf_vars cs)). \<forall>x \<in> set (cnf_vars cs). (s x = t x)" using *
    by (metis (no_types, lifting))
qed

lemma leval_state_inj: "s (literal_var l) = t (literal_var l) \<Longrightarrow> leval l s = leval l t"
  apply (induction l)
  apply auto
  done

lemma ceval_state_inj: "(\<forall>x \<in> set (clause_vars ls). s x = t x) \<Longrightarrow> (ceval ls s = ceval ls t)"
  apply (induction ls)
   apply (auto)
  using leval_state_inj
     apply blast
  using leval_state_inj apply blast
  using leval_state_inj apply metis
  using leval_state_inj apply metis
  done

lemma evalCNF_state_inj: "(\<forall>x \<in> set (cnf_vars cs). s x = t x) \<Longrightarrow> (evalCNF cs s = evalCNF cs t)"
  apply (induction cs)
   apply auto
  using ceval_state_inj apply blast+
  done

lemma vals_contains: "\<forall>s. \<exists>t \<in> set (vals (cnf_vars cs)). evalCNF cs s = evalCNF cs t"
proof
  fix s
  have "\<exists>t \<in> set (vals (cnf_vars cs)). \<forall>x \<in> set (cnf_vars cs). (s x = t x)" using vals_contains_aux by simp
  then show "\<exists>t \<in> set (vals (cnf_vars cs)). evalCNF cs s = evalCNF cs t" using evalCNF_state_inj by blast
qed

lemma solver_bruteforce_complete: "satisfiable (toFormula cs) \<Longrightarrow> solver_bruteforce cs"
  unfolding satisfiable_def
  apply (simp add: toFormula_eval[symmetric])
proof -
  assume assm: "\<exists>s. evalCNF cs s"
  then obtain s where s_def: "evalCNF cs s" by blast
  then have "\<exists>t \<in> set (vals (cnf_vars cs)). evalCNF cs s = evalCNF cs t" using assm vals_contains by auto
  then have "\<exists>t \<in> set (vals (cnf_vars cs)). evalCNF cs t" using s_def by simp
  then obtain t where "t \<in> set (vals (cnf_vars cs)) \<and> evalCNF cs t" by blast
  then show ?thesis using solver_bruteforce_alt_def[symmetric] by auto
qed

lemma solver_bruteforce_runtime: "length (vals cs) = 2 ^ (length cs)"
  by (induction cs) auto

fun contains :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  where
    "contains x [] = False"
  | "contains x (y # ys) = (if x = y then True else contains x ys)"

fun not :: "literal \<Rightarrow> literal"
  where
    "not (P x) = N x"
  | "not (N x) = P x"

fun unit_clauses :: "formulaCNF \<Rightarrow> clauseCNF list"
  where
    "unit_clauses [] = []"
  | "unit_clauses (c # cs) = (if length c = 1 then c # unit_clauses cs else unit_clauses cs)"

fun delete :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
    "delete x [] = []"
  | "delete x (y # ys) = (if x = y then delete x ys else y # (delete x ys))"

fun unit_propagate :: "clauseCNF \<Rightarrow> formulaCNF \<Rightarrow> formulaCNF"
  where
    "unit_propagate c [] = []"
  | "unit_propagate c (c' # cs) = (let l = hd c
                                   in
                                     (if contains l c'
                                      then unit_propagate c cs
                                      else if contains (not l) c' then removeAll (not l) c' # unit_propagate c cs
                                      else c' # unit_propagate c cs)
                                   )"

definition literals :: "formulaCNF \<Rightarrow> literal list"
  where
    "literals cs \<equiv> concat cs"

declare literals_def[simp]

definition pure_literal :: "literal \<Rightarrow> formulaCNF \<Rightarrow> bool"
  where
    "pure_literal l cs = (l \<in> set (literals cs) \<and> (not l) \<notin> set (literals cs))"

value "1 \<notin> ({}::nat set)"
fun pure_literall :: "literal \<Rightarrow> formulaCNF \<Rightarrow> bool"
  where
    "pure_literall l [] = False"
  | "pure_literall l (c # cs) = (contains l c \<and> \<not>contains (not l) c \<and> pure_literall l cs)"

definition pure_literals :: "formulaCNF \<Rightarrow> literal list"
  where
    "pure_literals cs = filter (\<lambda>l. pure_literall l cs ) (literals cs)"

declare pure_literals_def[simp]

fun pure_literal_assign :: "literal \<Rightarrow> formulaCNF \<Rightarrow> formulaCNF"
  where
    "pure_literal_assign l [] = []"
  | "pure_literal_assign l (c # cs) = (if contains l c then pure_literal_assign l cs else c # (pure_literal_assign l cs))"

fun pure_literal_elimm :: "formulaCNF \<Rightarrow> literal list \<Rightarrow> formulaCNF"
  where
    "pure_literal_elimm cs [] = cs"
  | "pure_literal_elimm cs (l # ls) = pure_literal_elimm (pure_literal_assign l cs) ls"

fun pure_literal_elim :: "formulaCNF \<Rightarrow> formulaCNF"
  where
    "pure_literal_elim cs = fold (\<lambda>l cs. pure_literal_assign l cs) (pure_literals cs) cs"

fun falt :: "('b \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'a"
  where
    "falt f a [] = a"
  | "falt f a (x # xs) = falt f (f x a) xs"

fun unit_propagate_all :: "formulaCNF \<Rightarrow> clauseCNF list \<Rightarrow> formulaCNF"
  where
    "unit_propagate_all cs [] = cs"
  | "unit_propagate_all cs (uc # ucs) = unit_propagate_all (unit_propagate uc cs) ucs"

lemma "unit_propagate_all cs ucs = fold (\<lambda>uc. unit_propagate uc) ucs cs"
  apply (induction ucs arbitrary: cs)
  apply auto
  done

definition uprog :: "formulaCNF \<Rightarrow> formulaCNF" where "uprog cs \<equiv> fold (\<lambda>uc. unit_propagate uc) (unit_clauses cs) cs"

text\<open>
uprog cs (u # uc) = uprog (uprog cs u) uc"
\<close>

fun choose_literal :: "formulaCNF \<Rightarrow> literal"
  where
    "choose_literal cs = (if (literals cs) = [] then undefined else (hd (literals cs)))"

fun subst :: "formulaCNF \<Rightarrow> literal \<Rightarrow> bool \<Rightarrow> formulaCNF"
  where
    "subst [] l b = []"
  | "subst (c # cs) l b = (case b of False \<Rightarrow> removeAll l c # subst cs l b |
                                     True \<Rightarrow> (if contains l c then subst cs l b else c # subst cs l b)) "

definition consistent :: "formulaCNF \<Rightarrow> bool"
  where
    "consistent cs = (\<forall>l \<in> set (literals cs). (not l) \<notin> set (literals cs))"

declare consistent_def[simp]

text
\<open>
http://poincare.matf.bg.ac.rs/~filip/phd/classic-dpll-verification.pdf

Termination proof can be made manually !

\<close>

value "solver_bruteforce [[P ''x'', P ''y''], [P ''z'', P ''y''], [N ''y'']]"
value "pure_literal_elim (uprog [[P ''x'', P ''y''], [P ''z'', P ''y''], [N ''y'']])"
value "consistent (subst (pure_literal_elim (uprog [[P ''x'', P ''y''], [P ''z'', P ''y''], [N ''y'']])) (P ''x'') True)"
value "subst (pure_literal_elim (uprog [[P ''x'', P ''y''], [P ''z'', P ''y''], [N ''y'']])) (P ''z'') True"

fun size :: "formulaCNF \<Rightarrow> nat"
  where
    "size []  = 0"
  | "size (c # cs) = length c + size cs"

lemma size_unit_propagate: "size (unit_propagate c cs) \<le> size cs"
  apply (induction cs arbitrary: c)
   apply auto
  by (smt add_mono_thms_linordered_semiring(1) le_add1 le_add_same_cancel1 length_removeAll_less_eq list.inject nat_add_left_cancel_le size.elims trans_le_add2)

declare uprog_def[simp]

lemma size_unit_propagate_all: "size (unit_propagate_all cs ucs) \<le> size cs"
  apply (induction ucs arbitrary: cs)
   apply auto
  using le_trans size_unit_propagate by blast

lemma size_pure_literal_assign: "size (pure_literal_assign l cs) \<le> size cs"
  apply (induction cs)
   apply auto
  done
lemma size_pure_literal_elim: "size (pure_literal_elimm cs ls) \<le> size cs"
  apply (induction ls arbitrary: cs)
   apply auto
  using size_pure_literal_assign le_trans by blast

lemma size_subst_weak: "size (subst cs l b) \<le> size cs"
  apply (induction cs)
   apply (auto split: bool.split)
  by (simp add: add_mono_thms_linordered_semiring(1))

lemma size_subst_False:"l \<in> set (literals cs) \<Longrightarrow> size (subst cs l False) < size cs"
  apply (induction cs)
   apply auto
   apply (simp add: add_less_le_mono length_removeAll_less size_subst_weak)
  by (meson add_le_less_mono length_removeAll_less_eq)

lemma contains_iff_elem: "contains l c \<longleftrightarrow> l \<in> set c"
  apply (induction c)
   apply auto
  done

lemma size_partition_filter: "size cs = size (filter (\<lambda>x. K x) cs) + size (filter (\<lambda>x. \<not>K x) cs)"
  apply (induction cs)
   apply auto
  done
lemma subst_True_filter_def: "subst cs l True = filter (\<lambda>c. \<not>contains l c) cs"
  apply (induction cs)
  apply auto
  done

lemma contains_size: "contains c cs \<Longrightarrow> size [c] \<le> size cs"
  apply (induction cs)
   apply (auto split: if_splits)
  done

lemma size_subst_True: "l \<in> set (literals cs) \<Longrightarrow> size (subst cs l True) < size cs"
proof-
  assume assm: "l \<in> set (literals cs)"
  then have "\<exists>c \<in> set cs. contains l c" using contains_iff_elem[symmetric] by force
  then obtain c where cdef:"c \<in> set cs \<and> contains l c" by blast
  then have "length c > 0" using assm by auto

  have "contains c (filter (\<lambda>c. contains l c) cs)" using cdef by (simp add: contains_iff_elem)
  then have "size (filter (\<lambda>c. contains l c) cs) \<ge> size [c]" using contains_size cdef by blast
  then have *: "size (filter (\<lambda>c. contains l c) cs) > 0" using \<open>length c > 0\<close>
    using gr_zeroI by fastforce

  have "size cs = size (filter (\<lambda>c. contains l c) cs) + size (subst cs l True)" using size_partition_filter subst_True_filter_def by auto

  then show "size (subst cs l True) < size cs" using subst_True_filter_def * by simp
qed

lemma size_subst_strong: "l \<in> set (literals cs) \<Longrightarrow> size (subst cs l b) < size cs"
  using size_subst_True size_subst_False by (cases b) auto

lemma size_subst_main: "literals cs \<noteq> [] \<Longrightarrow> l = choose_literal cs \<Longrightarrow> size (subst cs l b) < size cs"
proof -
  assume assms: "literals cs \<noteq> []" "l = choose_literal cs"
  then have " l = hd (literals cs)" by auto
  then have " l \<in> set (literals cs)" using assms
    using list.set_sel(1) by blast
  then show ?thesis using size_subst_strong by simp
qed

function solver_dpll :: "formulaCNF \<Rightarrow> bool"
  where
    "solver_dpll cs = (if consistent cs then True
                       else if contains [] cs then False
                       else
                         let cs\<^sub>1 = unit_propagate_all cs (unit_clauses cs); cs\<^sub>2 = pure_literal_elimm cs\<^sub>1 (pure_literals cs\<^sub>1); l = choose_literal cs\<^sub>2
                         in
                           (if literals cs\<^sub>2 = [] then (if contains [] cs\<^sub>2 then False else True)
                            else
                              solver_dpll (subst cs\<^sub>2 l True) \<or> (solver_dpll (subst cs\<^sub>2 l False))
                           )
                       )"
  by pat_completeness auto
termination
  apply (relation "measure (\<lambda>cs. (size cs))")
    apply (auto simp: size_pure_literal_elim size_unit_propagate_all size_subst_main split: if_splits)
   apply (smt Nil_eq_concat_conv le_trans list.set_sel(1) literals_def not_le size_pure_literal_elim size_subst_strong size_unit_propagate_all)
  by (smt Nil_eq_concat_conv antisym leI le_trans list.set_sel(1) literals_def size_pure_literal_elim size_subst_weak size_subst_strong size_unit_propagate_all)

end


theory InduccionGeneral
imports Main
begin

section {* La función mitad *}

text {* (mitad x) es la mitad del número natural x. Por ejemplo,
     mitad (Suc (Suc (Suc (Suc 0)))) = Suc (Suc 0)
     mitad (Suc (Suc (Suc 0)))       = Suc 0
*}
fun mitad :: "nat \<Rightarrow> nat"
where
  "mitad 0             = 0"
| "mitad (Suc 0)       = 0"
| "mitad (Suc (Suc n)) = 1 + mitad n"

value "mitad (Suc (Suc (Suc (Suc 0))))"
lemma "mitad (Suc (Suc (Suc (Suc 0)))) = Suc (Suc 0)" by simp
value "mitad (Suc (Suc (Suc 0)))"
lemma "mitad (Suc (Suc (Suc 0))) = Suc 0" by simp

text {* El esquema de inducción correspondiente a la función mitad es
     \<lbrakk>P 0; P (Suc 0); \<And>n. P n \<Longrightarrow> P (Suc (Suc n))\<rbrakk> \<Longrightarrow> P a
  es decir, para demostrar que todo número a tiene la propiedad P basta
  demostrar que:
  · 0 tiene la propiedad P
  · (Suc 0) tiene la propiedad P
  · si n tiene la propiedad P, entonces (Suc (Suc n)) también la tiene.
*}
thm mitad.induct [no_vars]

text {* Prop.: Para todo n, 2 * mitad n \<le> n *}
lemma "2 * mitad n \<le> n"
apply (induction n rule: mitad.induct)
apply auto
done

section {* La función intercala *}

text {* (intercala x ys) es la lista obtenida intercalando x entre los
  elementos de ys. Por ejemplo,
     intercala a [x,y,z] = [x, a, y, a, z]" by simp
*}
fun intercala :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "intercala a []       = []"
| "intercala a [x]      = [x]"
| "intercala a (x#y#zs) = x # a # intercala a (y#zs)"

value "intercala a [x,y,z]"
lemma "intercala a [x,y,z] = [x, a, y, a, z]" by simp

text {* El esquema de inducción correspondiente a la función intercala es
     \<lbrakk>\<And>a. P a [];
      \<And>a x. P a [x];
      \<And>a x y zs. P a (y # zs) \<Longrightarrow> P a (x # y # zs)\<rbrakk>
     \<Longrightarrow> P b xs
  es decir, para demostrar que para todo b y xs el par (b,xs) se tiene
  la propiedad P basta demostrar que:
  · para todo a, el par (a,[]) tiene la propiedad P
  · para todo a, el par (a,[x]) tiene la propiedad P
  · para todo a, x, y, zs, si el par (a,y#zs) tiene la propiedad P
    entonces el par (a,x#y#zs) tiene la propiedad P.
*}
thm intercala.induct [no_vars]

text {* Prop.: Aplicar la función f al resultado de intercalar a en xs
  es lo mismo que intercalar (f a) en las imágenes de xs mediante f. *}
lemma "map f (intercala a xs) = intercala (f a) (map f xs)"
apply (induction a xs rule: intercala.induct)
apply auto
done

end


(* Title: Resolvable_Designs.thy
   Author: Chelsea Edmonds
*)

section \<open>Resolvable Designs\<close>
text \<open>Resolvable designs have further structure, and can be "resolved" into a set of resolution
classes. A resolution class is a subset of blocks which exactly partitions the point set.
Definitions based off the handbook \<^cite>\<open>"colbournHandbookCombinatorialDesigns2007"\<close>
 and Stinson \<^cite>\<open>"stinsonCombinatorialDesignsConstructions2004"\<close>.
This theory includes a proof of an alternate statement of Bose's theorem\<close>

theory Resolvable_Designs imports BIBD
begin

subsection \<open>Resolutions and Resolution Classes\<close>
text \<open>A resolution class is a partition of the point set using a set of blocks from the design
A resolution is a group of resolution classes partitioning the block collection\<close>

context incidence_system
begin

definition resolution_class :: "'a set set \<Rightarrow> bool" where
"resolution_class S \<longleftrightarrow> partition_on \<V> S \<and> (\<forall> bl \<in> S . bl \<in># \<B>)"

lemma resolution_classI [intro]: "partition_on \<V>  S \<Longrightarrow> (\<And> bl . bl \<in> S \<Longrightarrow> bl \<in># \<B>)
    \<Longrightarrow> resolution_class S"
  by (simp add: resolution_class_def)

lemma resolution_classD1: "resolution_class S \<Longrightarrow> partition_on \<V> S"
  by (simp add: resolution_class_def)

lemma resolution_classD2: "resolution_class S \<Longrightarrow>  bl \<in> S \<Longrightarrow> bl \<in># \<B>"
  by (simp add: resolution_class_def)

lemma resolution_class_empty_iff: "resolution_class {} \<longleftrightarrow> \<V>  = {}"
  by (auto simp add: resolution_class_def partition_on_def)

lemma resolution_class_complete: "\<V>  \<noteq> {} \<Longrightarrow> \<V>  \<in># \<B> \<Longrightarrow> resolution_class {\<V>}"
  by (auto simp add: resolution_class_def partition_on_space)

lemma resolution_class_union: "resolution_class S \<Longrightarrow> \<Union>S = \<V> "
  by (simp add: resolution_class_def partition_on_def)

lemma (in finite_incidence_system) resolution_class_finite: "resolution_class S \<Longrightarrow> finite S"
  using finite_elements finite_sets by (auto simp add: resolution_class_def)

lemma (in design) resolution_class_sum_card: "resolution_class S \<Longrightarrow> (\<Sum>bl \<in> S . card bl) = \<v>"
  using resolution_class_union finite_blocks
  by (auto simp add: resolution_class_def partition_on_def card_Union_disjoint)

definition resolution:: "'a set multiset multiset \<Rightarrow> bool" where
"resolution P \<longleftrightarrow> partition_on_mset \<B> P \<and> (\<forall> S \<in># P . distinct_mset S \<and> resolution_class (set_mset S))"

lemma resolutionI : "partition_on_mset \<B> P \<Longrightarrow> (\<And> S . S \<in>#P \<Longrightarrow> distinct_mset S) \<Longrightarrow>
    (\<And> S . S\<in># P \<Longrightarrow> resolution_class (set_mset S)) \<Longrightarrow> resolution P"
  by (simp add: resolution_def)

lemma (in proper_design) resolution_blocks: "distinct_mset \<B> \<Longrightarrow> disjoint (set_mset \<B>) \<Longrightarrow>
    \<Union>(set_mset \<B>) = \<V> \<Longrightarrow> resolution {#\<B>#}"
  unfolding resolution_def resolution_class_def partition_on_mset_def partition_on_def
  using design_blocks_nempty blocks_nempty by auto

end

subsection \<open>Resolvable Design Locale\<close>
text \<open>A resolvable design is one with a resolution P\<close>
locale resolvable_design = design +
  fixes partition :: "'a set multiset multiset" ("\<P>")
  assumes resolvable: "resolution \<P>"
begin

lemma resolutionD1: "partition_on_mset \<B> \<P>"
  using resolvable by (simp add: resolution_def)

lemma resolutionD2: "S \<in>#\<P> \<Longrightarrow> distinct_mset S"
  using resolvable by (simp  add: resolution_def)

lemma resolutionD3: " S\<in># \<P> \<Longrightarrow> resolution_class (set_mset S)"
  using resolvable by (simp add: resolution_def)

lemma resolution_class_blocks_disjoint: "S \<in># \<P> \<Longrightarrow> disjoint (set_mset S)"
  using resolutionD3 by (simp add: partition_on_def resolution_class_def)

lemma resolution_not_empty: "\<B> \<noteq> {#} \<Longrightarrow> \<P> \<noteq> {#}"
  using partition_on_mset_not_empty resolutionD1 by auto

lemma resolution_blocks_subset: "S \<in># \<P> \<Longrightarrow> S \<subseteq># \<B>"
  using partition_on_mset_subsets resolutionD1 by auto

end

lemma (in incidence_system) resolvable_designI [intro]: "resolution \<P> \<Longrightarrow> design \<V> \<B> \<Longrightarrow>
    resolvable_design \<V> \<B> \<P>"
  by (simp add: resolvable_design.intro resolvable_design_axioms.intro)

subsection \<open>Resolvable Block Designs\<close>
text \<open>An RBIBD is a resolvable BIBD - a common subclass of interest for block designs\<close>
locale r_block_design = resolvable_design + block_design
begin
lemma resolution_class_blocks_constant_size: "S \<in># \<P> \<Longrightarrow> bl \<in># S \<Longrightarrow> card bl = \<k>"
  by (metis resolutionD3 resolution_classD2 uniform_alt_def_all)

lemma resolution_class_size1:
  assumes "S \<in># \<P>"
  shows "\<v> = \<k> * size S"
proof -
  have "(\<Sum>bl \<in># S . card bl) = (\<Sum>bl \<in> (set_mset S) . card bl)" using resolutionD2 assms
    by (simp add:  sum_unfold_sum_mset)
  then have eqv: "(\<Sum>bl \<in># S . card bl) = \<v>" using resolutionD3 assms resolution_class_sum_card
    by presburger
  have "(\<Sum>bl \<in># S . card bl) = (\<Sum>bl \<in># S . \<k>)" using resolution_class_blocks_constant_size assms
    by auto
  thus ?thesis using eqv by auto
qed

lemma resolution_class_size2:
  assumes "S \<in># \<P>"
  shows "size S = \<v> div \<k>"
  using resolution_class_size1 assms
  by (metis nonzero_mult_div_cancel_left not_one_le_zero k_non_zero)

lemma resolvable_necessary_cond_v: "\<k> dvd \<v>"
proof -
  obtain S where s_in: "S \<in>#\<P>" using resolution_not_empty design_blocks_nempty by blast
  then have "\<k> * size S = \<v>" using resolution_class_size1 by simp
  thus ?thesis by (metis dvd_triv_left)
qed

end

locale rbibd = r_block_design + bibd

begin

lemma resolvable_design_num_res_classes: "size \<P> = \<r>"
proof -
  have k_ne0: "\<k> \<noteq> 0" using k_non_zero by auto
  have f1: "\<b> = (\<Sum>S \<in># \<P> . size S)"
    by (metis partition_on_msetD1 resolutionD1 size_big_union_sum)
  then have "\<b> = (\<Sum>S \<in># \<P> . \<v> div \<k>)" using resolution_class_size2 f1 by auto
  then have f2: "\<b> = (size \<P>) * (\<v> div \<k>)" by simp
  then have "size \<P> = \<b> div (\<v> div \<k>)"
    using b_non_zero by auto
  then have "size \<P> = (\<b> * \<k>) div \<v>" using f2 resolvable_necessary_cond_v
    by (metis div_div_div_same div_dvd_div dvd_triv_right k_ne0 nonzero_mult_div_cancel_right)
  thus ?thesis using necessary_condition_two
    by (metis nonzero_mult_div_cancel_left not_one_less_zero t_design_min_v)
qed

lemma resolvable_necessary_cond_b: "\<r> dvd \<b>"
proof -
  have f1: "\<b> = (\<Sum>S \<in># \<P> . size S)"
    by (metis partition_on_msetD1 resolutionD1 size_big_union_sum)
  then have "\<b> = (\<Sum>S \<in># \<P> . \<v> div \<k>)" using resolution_class_size2 f1 by auto
  thus ?thesis using resolvable_design_num_res_classes by simp
qed

subsubsection \<open>Bose's Inequality\<close>
text \<open>Boses inequality is an important theorem on RBIBD's. This is a proof
of an alternate statement of the thm, which does not require a linear algebraic approach,
taken directly from Stinson \<^cite>\<open>"stinsonCombinatorialDesignsConstructions2004"\<close>\<close>
theorem bose_inequality_alternate: "\<b> \<ge> \<v> + \<r> - 1 \<longleftrightarrow> \<r> \<ge> \<k> + \<Lambda>"
proof -
  from necessary_condition_two v_non_zero have r: \<open>\<r> = \<b> * \<k> div \<v>\<close>
    by (metis div_mult_self1_is_m)
  define k b v l r where intdefs: "k \<equiv> (int \<k>)" "b \<equiv> int \<b>" "v = int \<v>" "l \<equiv> int \<Lambda>" "r \<equiv> int \<r>"
  have kdvd: "k dvd (v * (r - k))"
    using intdefs
    by (simp add: resolvable_necessary_cond_v)
  have necess1_alt: "l * v - l = r * (k - 1)" using necessary_condition_one intdefs
    by (smt (verit) diff_diff_cancel int_ops(2) int_ops(6) k_non_zero nat_mult_1_right of_nat_0_less_iff
        of_nat_mult right_diff_distrib' v_non_zero)
  then have v_eq: "v = (r * (k - 1) + l) div l"
    using necessary_condition_one index_not_zero intdefs
    by (metis diff_add_cancel nonzero_mult_div_cancel_left not_one_le_zero of_nat_mult
        unique_euclidean_semiring_with_nat_class.of_nat_div)
  have ldvd: " \<And> x. l dvd (x * (r * (k - 1) + l))"
    by (metis necess1_alt diff_add_cancel dvd_mult dvd_triv_left)
  have "(b \<ge> v + r - 1) \<longleftrightarrow> ((\<v> * r) div k \<ge> v + r - 1)"
    using necessary_condition_two k_non_zero intdefs
    by (metis (no_types, lifting) nonzero_mult_div_cancel_right not_one_le_zero of_nat_eq_0_iff of_nat_mult)
  also have  "... \<longleftrightarrow> (((v * r) - (v * k)) div k \<ge> r - 1)"
    using k_non_zero k_non_zero r intdefs
    by (simp add: of_nat_div algebra_simps)
      (smt (verit, ccfv_threshold) One_nat_def div_mult_self4 of_nat_1 of_nat_mono)
  also have f2: " ... \<longleftrightarrow> ((v * ( r - k)) div k \<ge> ( r - 1))"
    using int_distrib(3) by (simp add: mult.commute)
  also have f2: " ... \<longleftrightarrow> ((v * ( r - k)) \<ge> k * ( r - 1))"
    using k_non_zero kdvd intdefs by auto
  also have "... \<longleftrightarrow> ((((r * (k - 1) + l ) div l) * (r - k)) \<ge> k * (r - 1))"
    using v_eq by presburger
  also have "... \<longleftrightarrow> ( (r - k) * ((r * (k - 1) + l ) div l) \<ge> (k * (r - 1)))"
    by (simp add: mult.commute)
  also have " ... \<longleftrightarrow> ( ((r - k) * (r * (k - 1) + l )) div l \<ge> (k * (r - 1)))"
    using div_mult_swap necessary_condition_one intdefs
    by (metis diff_add_cancel dvd_triv_left necess1_alt)
  also have " ... \<longleftrightarrow> (((r - k) * (r * (k - 1) + l ))  \<ge>  l * (k * (r - 1)))"
    using ldvd[of "(r - k)"] dvd_mult_div_cancel index_not_zero mult_strict_left_mono intdefs
    by (smt (verit) b_non_zero bibd_block_number bot_nat_0.extremum_strict div_0 less_eq_nat.simps(1)
      mult_eq_0_iff mult_left_le_imp_le mult_left_mono of_nat_0 of_nat_le_0_iff of_nat_le_iff of_nat_less_iff)
  also have 1: "... \<longleftrightarrow> (((r - k) * (r * (k - 1))) + ((r - k) * l )  \<ge>  l * (k * (r - 1)))"
    by (simp add: distrib_left)
  also have "... \<longleftrightarrow> (((r - k) * r * (k - 1)) \<ge> l * k * (r - 1) - ((r - k) * l ))"
    using mult.assoc by linarith
  also have "... \<longleftrightarrow> (((r - k) * r * (k - 1)) \<ge> (l * k * r) - (l * k) - ((r * l) -(k * l )))"
    using distrib_right by (simp add: distrib_left right_diff_distrib' left_diff_distrib')
  also have "... \<longleftrightarrow> (((r - k) * r * (k - 1)) \<ge> (l * k * r)  - ( l * r))"
    by (simp add: mult.commute)
  also have "... \<longleftrightarrow> (((r - k) * r * (k - 1)) \<ge> (l  * (k * r))  - ( l * r))"
    by linarith
  also have "... \<longleftrightarrow> (((r - k) * r * (k - 1)) \<ge> (l  * (r * k))  - ( l * r))"
    by (simp add: mult.commute)
  also have "... \<longleftrightarrow> (((r - k) * r * (k - 1)) \<ge> l * r * (k - 1))"
    by (simp add:  mult.assoc int_distrib(4))
  finally have "(b \<ge> v + r - 1) \<longleftrightarrow> (r \<ge> k + l)"
    using index_lt_replication mult_right_le_imp_le r_gzero mult_cancel_right k_non_zero intdefs
    by (smt (z3) of_nat_0_less_iff of_nat_1 of_nat_le_iff of_nat_less_iff)
  then have "\<b> \<ge> \<v> + \<r> - 1 \<longleftrightarrow> \<r> \<ge> \<k> + \<Lambda>"
    using k_non_zero le_add_diff_inverse of_nat_1 of_nat_le_iff intdefs by linarith
  thus ?thesis by simp
qed
end
end


theory Matching
imports Main
begin

type_synonym label = nat

section {* Definitions *}

definition finite_graph :: "'v set => ('v * 'v) set \<Rightarrow> bool" where
  "finite_graph V E = (finite V \<and> finite E \<and>
  (\<forall> e \<in> E. fst e \<in> V \<and> snd e \<in> V \<and> fst e ~= snd e))"

definition degree :: "('v * 'v) set \<Rightarrow> 'v \<Rightarrow> nat" where
  "degree E v = card {e \<in> E. fst e = v \<or> snd e = v}"

definition edge_as_set :: "('v * 'v) \<Rightarrow> 'v set" where
  "edge_as_set e = {fst e, snd e}"

definition N :: "'v set \<Rightarrow> ('v \<Rightarrow> label) \<Rightarrow> nat \<Rightarrow> nat" where
  "N V L i = card {v \<in> V. L v = i}"

definition weight:: "label set \<Rightarrow> (label \<Rightarrow> nat) \<Rightarrow> nat" where
  "weight LV f = f 1 + (\<Sum>i\<in>LV. (f i) div 2)"

definition OSC :: "('v \<Rightarrow> label) \<Rightarrow> ('v * 'v) set \<Rightarrow> bool" where
  "OSC L E = (\<forall>e \<in> E. L (fst e) = 1 \<or> L (snd e) = 1 \<or>
                     L (fst e) = L (snd e) \<and> L (fst e) > 1)"

definition disjoint_edges :: "('v * 'v) \<Rightarrow> ('v * 'v) \<Rightarrow> bool" where
  "disjoint_edges e1 e2 = (fst e1 \<noteq> fst e2 \<and> fst e1 \<noteq> snd e2 \<and>
                          snd e1 \<noteq> fst e2 \<and> snd e1 \<noteq> snd e2)"

definition matching :: "'v set \<Rightarrow> ('v * 'v) set \<Rightarrow> ('v * 'v) set \<Rightarrow> bool" where
  "matching V E M = (M \<subseteq> E \<and> finite_graph V E \<and>
  (\<forall>e1 \<in> M. \<forall> e2 \<in> M. e1 \<noteq> e2 \<longrightarrow> disjoint_edges e1 e2))"

definition matching_i :: "nat \<Rightarrow> 'v set \<Rightarrow> ('v * 'v) set \<Rightarrow> ('v * 'v) set \<Rightarrow>
  ('v \<Rightarrow> label) \<Rightarrow> ('v * 'v) set" where
  "matching_i i V E M L = {e \<in> M. i=1 \<and> (L (fst e) = i \<or> L (snd e) = i)
  \<or> i>1 \<and> L (fst e) = i \<and> L (snd e) = i}"

definition V_i:: "nat \<Rightarrow> 'v set \<Rightarrow> ('v * 'v) set \<Rightarrow> ('v * 'v) set \<Rightarrow>
                  ('v \<Rightarrow> label) \<Rightarrow> 'v set" where
  "V_i i V E M L = \<Union> (edge_as_set ` matching_i i V E M L)"

definition endpoint_inV :: "'v set \<Rightarrow> ('v * 'v) \<Rightarrow> 'v" where
  "endpoint_inV V e = (if fst e \<in> V then fst e else snd e)"

definition relevant_endpoint :: "('v \<Rightarrow> label) \<Rightarrow> 'v set \<Rightarrow>
                                 ('v * 'v) \<Rightarrow> 'v" where
  "relevant_endpoint L V e = (if L (fst e) = 1 then fst e else snd e)"

section {* Lemmas *}

lemma definition_of_range:
  "endpoint_inV V1 ` matching_i 1 V E M L =
  { v. \<exists> e \<in> matching_i 1 V E M L. endpoint_inV V1 e = v }" by auto

lemma matching_i_edges_as_sets:
  "edge_as_set ` matching_i i V E M L =
  { e1. \<exists> (u, v) \<in> matching_i i V E M L. edge_as_set (u, v) = e1}" by auto

lemma matching_disjointness:
  assumes "matching V E M"
  assumes "e1 \<in> M"
  assumes "e2 \<in> M"
  assumes "e1 \<noteq> e2"
  shows  "edge_as_set e1 \<inter> edge_as_set e2 = {}"
  using assms
  by (auto simp add: edge_as_set_def disjoint_edges_def matching_def)

lemma expand_set_containment:
  assumes "matching V E M"
  assumes "e \<in> M"
  shows "e \<in> E"
  using assms
  by (auto simp add:matching_def)

theorem injectivity:
  assumes is_osc: "OSC L E"
  assumes is_m: "matching V E M"
  assumes e1_in_M1: "e1 \<in> matching_i 1 V E M L"
      and e2_in_M1: "e2 \<in> matching_i 1 V E M L"
  assumes diff: "(e1 \<noteq> e2)"
  shows "endpoint_inV {v \<in> V. L v = 1} e1 \<noteq> endpoint_inV {v \<in> V. L v = 1} e2"
proof -
  from e1_in_M1 have "e1 \<in> M" by (auto simp add: matching_i_def)
  moreover
  from e2_in_M1 have "e2 \<in> M" by (auto simp add: matching_i_def)
  ultimately
  have disjoint_edge_sets: "edge_as_set e1 \<inter> edge_as_set e2 = {}"
    using diff is_m matching_disjointness by fast
  then show ?thesis by (auto simp add: edge_as_set_def endpoint_inV_def)
qed

subsection {* @{text "|M1| \<le> n1"} *}

lemma card_M1_le_NVL1:
  assumes "matching V E M"
  assumes "OSC L E"
  shows "card (matching_i 1 V E M L) \<le> ( N V L 1)"
proof -
  let ?f = "endpoint_inV {v \<in> V. L v = 1}"
  let ?A = "matching_i 1 V E M L"
  let ?B = "{v \<in> V. L v = 1}"
  have "inj_on ?f ?A" using assms injectivity
    unfolding inj_on_def by blast
  moreover have "?f ` ?A \<subseteq> ?B"
  proof -
    {
      fix e assume "e \<in> matching_i 1 V E M L"
      then have "endpoint_inV {v \<in> V. L v = 1} e \<in> {v \<in> V. L v = 1}"
        using assms
        by (auto simp add: endpoint_inV_def matching_def
          matching_i_def OSC_def finite_graph_def definition_of_range)
    }
    then show ?thesis using assms definition_of_range by blast
  qed
  moreover have "finite ?B" using assms
    by (simp add: matching_def finite_graph_def)
  ultimately show ?thesis unfolding N_def by (rule card_inj_on_le)
qed

lemma edge_as_set_inj_on_Mi:
  assumes "matching V E M"
  shows "inj_on edge_as_set (matching_i i V E M L)"
  using assms
  unfolding inj_on_def edge_as_set_def matching_def
    disjoint_edges_def matching_i_def
  by blast

lemma card_Mi_eq_card_edge_as_set_Mi:
  assumes "matching V E M"
  shows "card (matching_i i V E M L) = card (edge_as_set` matching_i i V E M L)"
  (is "card ?Mi = card (?f ` _)")
proof -
  from assms have "bij_betw ?f ?Mi (?f ` ?Mi)"
    by (simp add: bij_betw_def matching_i_edges_as_sets edge_as_set_inj_on_Mi)
  then show ?thesis by (rule bij_betw_same_card)
qed

lemma card_edge_as_set_Mi_twice_card_partitions:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "2 * card (edge_as_set`matching_i i V E M L)
  = card (V_i i V E M L)" (is "2 * card ?C = card ?Vi")
proof -
  from assms have 1: "finite (\<Union> ?C)"
    by (auto simp add: matching_def finite_graph_def
      matching_i_def edge_as_set_def finite_subset)
  show ?thesis unfolding V_i_def
  proof (rule card_partition)
    show "finite ?C" using 1 by (rule finite_UnionD)
  next
    show "finite (\<Union> ?C)" using 1 .
  next
    fix c assume "c \<in> ?C" then show "card c = 2"
    proof (rule imageE)
      fix x
      assume 2: "c = edge_as_set x" and 3: "x \<in> matching_i i V E M L"
      with assms have "x \<in> E"
        unfolding matching_i_def matching_def by blast
      then have "fst x \<noteq> snd x" using assms 3
        by (auto simp add: matching_def finite_graph_def)
      with 2 show ?thesis by (auto simp add: edge_as_set_def)
    qed
  next
    fix x1 x2
    assume 4: "x1 \<in> ?C" and 5: "x2 \<in> ?C" and 6: "x1 \<noteq> x2"
    {
      fix e1 e2
      assume 7: "x1 = edge_as_set e1" "e1 \<in> matching_i i V E M L"
        "x2 = edge_as_set e2" "e2 \<in> matching_i i V E M L"
      from assms have "matching V E M" by simp
      moreover
      from 7 assms have "e1 \<in> M" and "e2 \<in> M"
        by (simp_all add: matching_i_def)
      moreover from 6 7 have "e1 \<noteq> e2" by blast
      ultimately have "x1 \<inter> x2 = {}" unfolding 7
        by (rule matching_disjointness)
    }
    with 4 5 show "x1 \<inter> x2 = {}" by clarsimp
  qed
qed

lemma card_Mi_twice_card_Vi:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "2 * card (matching_i i V E M L) = card (V_i i V E M L)"
proof -
  from assms have "finite (V_i i V E M L)"
    by (auto simp add: edge_as_set_def finite_subset
      matching_def finite_graph_def V_i_def matching_i_def )
  with assms show ?thesis
    by (simp add: card_Mi_eq_card_edge_as_set_Mi
      card_edge_as_set_Mi_twice_card_partitions V_i_def)
qed

lemma card_Mi_le_floor_div_2_Vi:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "card (matching_i i V E M L) \<le> (card (V_i i V E M L)) div 2"
  using card_Mi_twice_card_Vi[OF assms]
  by arith

lemma card_Vi_le_NVLi:
  assumes "i>1 \<and> matching V E M"
  shows "card (V_i i V E M L) \<le> N V L i"
  unfolding N_def
proof (rule card_mono)
  show "finite {v \<in> V. L v = i}" using assms
    by (simp add: matching_def finite_graph_def)
next
  let ?A = "edge_as_set ` matching_i i V E M L"
  let ?C = "{v \<in> V. L v = i}"
  show "V_i i V E M L \<subseteq> ?C" using assms unfolding V_i_def
  proof (intro Union_least)
    fix X assume "X \<in> ?A"
    with assms have "\<exists>x \<in> matching_i i V E M L. edge_as_set x = X"
      by (simp add: matching_i_edges_as_sets)
    with assms show "X \<subseteq> ?C"
      unfolding finite_graph_def matching_def
        matching_i_def edge_as_set_def by blast
  qed
qed

subsection {* @{text "|Mi| \<le> \<lfloor>ni/2\<rfloor>"} *}

lemma card_Mi_le_floor_div_2_NVLi:
  assumes "OSC L E \<and> matching V E M \<and> i > 1"
  shows "card (matching_i i V E M L) \<le> (N V L i) div 2"
proof -
  from assms have "card (V_i i V E M L) \<le> (N V L i)"
    by (simp add: card_Vi_le_NVLi)
  then have "card (V_i i V E M L) div 2 \<le> (N V L i) div 2"
    by simp
  moreover from assms have
    "card (matching_i i V E M L) \<le> card (V_i i V E M L) div 2"
    by (intro card_Mi_le_floor_div_2_Vi)
  ultimately show ?thesis by auto
qed
subsection {* @{text "|M| \<le> \<Sum>|Mi|"} *}
lemma card_M_le_sum_card_Mi:
assumes "matching V E M" and "OSC L E"
shows "card M \<le> (\<Sum> i \<in> L`V. card (matching_i i V E M L))"
  (is "card _ \<le> ?CardMi")
proof -
  let ?UnMi = "\<Union>x \<in> L`V. matching_i x V E M L"
  from assms have 1: "finite ?UnMi"
    by (auto simp add: matching_def
      finite_graph_def matching_i_def finite_subset)
  {
    fix e assume e_inM: "e \<in> M"
    let ?v = "relevant_endpoint L V e"
    have 1: "e \<in> matching_i (L ?v) V E M L" using assms e_inM
      proof cases
        assume "L (fst e) = 1"
        thus ?thesis using assms e_inM
          by (simp add: relevant_endpoint_def matching_i_def)
      next
        assume a: "L (fst e) \<noteq> 1"
        have "L (fst e) = 1 \<or> L (snd e) = 1
          \<or>  (L (fst e) = L (snd e) \<and> L (fst e) >1)"
          using assms e_inM unfolding OSC_def
          by (blast intro: expand_set_containment)
        thus ?thesis using assms e_inM a
          by (auto simp add: relevant_endpoint_def matching_i_def)
      qed
      have 2: "?v \<in> V" using assms e_inM
        by (auto simp add: matching_def
          relevant_endpoint_def matching_i_def finite_graph_def)
      then have "\<exists> v \<in> V. e \<in> matching_i (L v) V E M L" using assms 1 2
        by (intro bexI)
    }
    with assms have "M \<subseteq> ?UnMi" by (auto)
    with assms and 1 have "card M \<le> card ?UnMi" by (intro card_mono)
    moreover from assms have "card ?UnMi = ?CardMi"
    proof (intro card_UN_disjoint)
      show "finite (L`V)" using assms
        by (simp add: matching_def finite_graph_def)
    next
      show "\<forall>i\<in>L`V. finite (matching_i i V E M L)" using assms
        unfolding matching_def finite_graph_def matching_i_def
        by (blast intro: finite_subset)
    next
      show "\<forall>i \<in> L`V. \<forall>j \<in> L`V. i \<noteq> j \<longrightarrow>
        matching_i i V E M L \<inter> matching_i j V E M L = {}" using assms
        by (auto simp add: matching_i_def)
    qed
  ultimately show ?thesis by simp
qed

theorem card_M_le_weight_NVLi:
  assumes "matching V E M" and "OSC L E"
  shows "card M \<le> weight {i \<in> L ` V. i > 1} (N V L)" (is "_ \<le> ?W")
proof -
  let ?M01 = "\<Sum>i| i \<in> L`V \<and> (i=1 \<or> i=0). card (matching_i i V E M L)"
  let ?Mgr1 = "\<Sum>i| i \<in> L`V \<and> 1 < i. card (matching_i i V E M L)"
  let ?Mi = "\<Sum> i\<in>L`V. card (matching_i i V E M L)"
  have "card M \<le> ?Mi" using assms by (rule card_M_le_sum_card_Mi)
  moreover
  have "?Mi \<le> ?W"
  proof -
    let ?A = "{i \<in> L ` V. i = 1 \<or> i = 0}"
    let ?B = "{i \<in> L ` V. 1 < i}"
    let ?g = "\<lambda> i. card (matching_i i V E M L)"
    let ?set01 = "{ i. i : L ` V & (i = 1 | i = 0)}"
    have a: "L ` V = ?A \<union> ?B" using assms by auto
    have "finite V" using assms
      by (simp add: matching_def finite_graph_def)
    have b: "setsum ?g (?A \<union> ?B) = setsum ?g ?A + setsum ?g ?B"
      using assms `finite V` by (auto intro: setsum.union_disjoint)
    have 1: "?Mi = ?M01+ ?Mgr1" using assms a b
      by (simp add: matching_def finite_graph_def)
    moreover
    have 0: "card (matching_i 0 V E M L) = 0" using assms
      by (simp add: matching_i_def)
      have 2: "?M01 \<le> N V L 1"
      proof cases
        assume a: "1 \<in> L`V"
        have "?M01 = card (matching_i 1 V E M L)"
        proof cases
          assume b: "0 \<in> L`V"
          with a assms have  "?set01 = {0, 1}" by blast
          thus ?thesis using assms 0 by simp
        next
          assume b: "0 \<notin> L`V"
          with a have "?set01 = {1}" by (auto simp del:One_nat_def)
          thus ?thesis by simp
        qed
        thus ?thesis using assms a
          by (simp del: One_nat_def, intro card_M1_le_NVL1)
      next
        assume a: "1 \<notin> L`V"
        show ?thesis
        proof cases
          assume b: "0 \<in> L`V"
          with a assms have  "?set01 = {0}" by (auto simp del:One_nat_def)
          thus ?thesis using assms 0 by auto
        next
          assume b: "0 \<notin> L`V"
          with a have "?set01 = {}" by (auto simp del:One_nat_def)
            then have "?M01 = (\<Sum>i\<in>{}. card (matching_i i V E M L))" by auto
            thus ?thesis by simp
          qed
        qed
      moreover
      have 3: "?Mgr1 \<le> (\<Sum>i|i\<in>L`V \<and> 1 < i. N V L i div 2)" using assms
        by (intro setsum_mono card_Mi_le_floor_div_2_NVLi, simp)
    ultimately
    show ?thesis using 1 2 3 assms by (simp add: weight_def)
  qed
  ultimately show ?thesis by simp
qed

section {* Final Theorem *}
text{* The following theorem is due to Edmond~\cite{Edmonds:matching}: *}

theorem maximum_cardinality_matching:
  assumes "matching V E M" and "OSC L E"
  and "card M = weight {i \<in> L ` V. i > 1} (N V L)"
  and "matching V E M'"
  shows "card M' \<le> card M"
  using assms card_M_le_weight_NVLi
  by simp

text{* The widely used algorithmic library LEDA has a certifying algorithm for maximum cardinality matching.
This Isabelle proof is part of the work done to verify the checker of this certifying algorithm. For more information see \cite{VerificationofCertifyingComputations}. *}
end


theory Concrete_Semantics_3_2
  imports Main
begin
(* from 3.1 *)
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N(i1+i2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x ) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

(* from 3.1 *)

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)" |
"bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b =  Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b1 b2 = And b1 b2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n1) (N n2) = Bc(n1 < n2)" |
"less a1 a2 = Less a1 a2"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b1 b2) = and (bsimp b1) (bsimp b2)" |
"bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a b = And (Not(Less a b))  (Not(Less b a))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a b = Not (And (Not (Less a b))  (Not(Eq a b)))"

lemma "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply(auto)
  done

lemma "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply(auto)
  done

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 v) s = v" |
"ifval (If a b c) s = (if (ifval a s) then (ifval b s) else (ifval c s))" |
"ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc v) = Bc2 v" |
"b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)" |
"b2ifexp (And b1 b2) = If (b2ifexp b1)  (b2ifexp  b2) (Bc2 False)" |
"b2ifexp (Less a1 a2) = Less2  a1 a2"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 v) = Bc v" |
"if2bexp (Less2 a b) = Less a b" |
"if2bexp (If a b c) = And (Not (And (if2bexp a) (Not (if2bexp b))))(Not (And (Not (if2bexp a)) (Not (if2bexp c))))"

lemma "bval b s = ifval (b2ifexp b) s"
  apply(induction b)
  apply(auto)
  done

lemma "ifval i s = bval (if2bexp i) s"
  apply(induction i)
  apply(auto)
  done

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x ) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR x) = True" |
"is_nnf (NOT (VAR x)) = True" |
"is_nnf (NOT y) = False" |
"is_nnf (OR a b) = (is_nnf a \<and> is_nnf b)" |
"is_nnf (AND a b) = (is_nnf a \<and> is_nnf b)"

(* pushing NOT inwards as much as possible *)
fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR x) = VAR x" |
"nnf (NOT (VAR x)) = NOT (VAR x)" |
"nnf (NOT (NOT a)) = nnf a" |
"nnf (NOT (OR  a b)) = AND (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (AND  a b)) = OR (nnf (NOT a)) (nnf (NOT b))" |
"nnf (AND  a  b) = AND (nnf a) (nnf b)" |
"nnf (OR  a  b) = OR (nnf a) (nnf b)"

lemma nnf_preserv : "pbval (nnf b) s = pbval b s"
  apply(induction b rule: nnf.induct)
  apply(auto)
  done

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf (VAR x) = True"|
"is_dnf (NOT y) = True" |
"is_dnf (OR a b) = (is_dnf a \<and> is_dnf b)" |
"is_dnf (AND (OR a b) c) = False" |
"is_dnf (AND a (OR b c)) = False" |
"is_dnf (AND a b) =  (is_dnf a \<and> is_dnf b)"

fun mk_dnf_conj :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"mk_dnf_conj e (OR a b) = OR (mk_dnf_conj e a) (mk_dnf_conj e b)" |
"mk_dnf_conj (OR a b) e  = OR (mk_dnf_conj a e) (mk_dnf_conj b e)" |
"mk_dnf_conj x  y  = AND x y"

lemma mk_dnf_preserv : "pbval (mk_dnf_conj a b) s = (pbval a s \<and> pbval b s)"
  apply(induction a b rule: mk_dnf_conj.induct)
  apply(auto)
  done

lemma mk_dnf_is_nnf: "is_nnf a \<Longrightarrow>
           is_nnf b \<Longrightarrow>
           is_nnf (mk_dnf_conj  a  b)"
  apply(induction a b rule:  mk_dnf_conj.induct)
  apply(auto)
  done

(* many counter examples occurs this way, TODO: make function for 'AND' *)

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
"dnf_of_nnf (VAR x) = VAR x" |
"dnf_of_nnf (NOT y) = NOT y" |
"dnf_of_nnf (OR a b) = OR (dnf_of_nnf a) (dnf_of_nnf b)" |
"dnf_of_nnf (AND a b) =  mk_dnf_conj (dnf_of_nnf a) (dnf_of_nnf b)"

lemma "pbval (dnf_of_nnf b) s = pbval b s"
  apply(induction b rule: dnf_of_nnf.induct )
  apply(simp_all add: mk_dnf_preserv)
  done

value "is_dnf(dnf_of_nnf(AND (OR (VAR []) (VAR [])) (OR (VAR []) (VAR []))))"

lemma mk_dnf_is_dnf: "is_dnf a \<Longrightarrow>
           is_dnf b \<Longrightarrow>
           is_dnf (mk_dnf_conj  a  b)"
  apply(induction a b rule:  mk_dnf_conj.induct)
  apply(auto)
  done

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply(induction b rule: dnf_of_nnf.induct)
  apply(auto simp add:  mk_dnf_is_dnf)
  done
end