section \<open>Graph rewriting and saturation\<close>
text \<open>Here we describe graph rewriting, again without connecting it to semantics.\<close>
theory GraphRewriting
  imports RulesAndChains
    "HOL-Library.Infinite_Set"
begin

(* Algorithm 1 on page 16 *)
text \<open>To describe Algorithm 1, we give a single step instead of the recursive call.
This allows us to reason about its effect without dealing with non-termination.
We define a worklist, saying what work can be done.
A valid selection needs to be made in order to ensure fairness.
To do a step, we define the function extend, and use it in @{term make_step}.
A function that always makes a valid selection is used in this step. \<close>

abbreviation graph_of where
  "graph_of \<equiv> \<lambda> X. LG (snd X) {0..<fst X}"

definition nextMax :: "nat set \<Rightarrow> nat"
  where
  "nextMax x \<equiv> if x = {} then 0 else Suc (Max x)"

lemma nextMax_max[intro]:
  assumes "finite x" "v \<in> x"
  shows "v < nextMax x" "v \<le> nextMax x"
  using Max.coboundedI[OF assms] assms(2) unfolding nextMax_def by auto

definition worklist :: "nat \<times> ('a \<times> nat \<times> nat) set
           \<Rightarrow> (('a, 'b) labeled_graph \<times> ('a, 'b) labeled_graph) set
              \<Rightarrow> (nat \<times> ('a, 'b) Graph_PreRule \<times> ('b \<times> nat) set) set" where
"worklist G Rs \<equiv> let G = graph_of G
  in {(N,R,f). R\<in> Rs \<and> graph_homomorphism (fst R) G f \<and> N = nextMax (Range f)
                 \<and> \<not> extensible R G f }"

definition valid_selection where
"valid_selection Rs G R f \<equiv>
  let wl = worklist G Rs in
    (nextMax (Range f), R,f) \<in> wl \<and>
    (\<forall> (N,_) \<in> wl. N \<ge> nextMax (Range f)) \<and>
    graph_rule R"

lemma valid_selection_exists:
  assumes "worklist G Rs \<noteq> {}"
          "set_of_graph_rules Rs"
  shows "\<exists>L R f. valid_selection Rs G R f"
proof -
  define wl where "wl = worklist G Rs" hence wl_ne:"wl \<noteq> {}" using assms(1) by auto
  let ?N = "LEAST N. N \<in> Domain wl"
  from wl_ne have "\<exists> N. N \<in> Domain wl" by auto
  with LeastI2 have "?N \<in> Domain wl" by metis
  then obtain L R f where NLRf:"(?N,(L,R),f)\<in>wl" by auto
  hence N_def:"?N = nextMax (Range f)"
    and in_Rs: "(L,R) \<in> Rs" unfolding wl_def worklist_def Let_def by auto
  from Least_le wl_ne Domain.intros case_prodI2
  have min:"(\<forall> (N',_) \<in> wl. N' \<ge> ?N)" by (metis (no_types, lifting))
  from in_Rs have "finite_graph R" "subgraph L R"
    using assms(2)[unfolded set_of_graph_rules_def] by auto
  with min NLRf N_def show ?thesis unfolding wl_def[symmetric] valid_selection_def by auto
qed

definition valid_selector where
"valid_selector Rs selector \<equiv> \<forall> G.
   (worklist G Rs \<noteq> {} \<longrightarrow> (\<exists> (R,f)\<in>UNIV. selector G = Some (R,f)
                               \<and> valid_selection Rs G R f)) \<and>
   (worklist G Rs = {} \<longrightarrow> selector G = None)"

lemma valid_selectorD[dest]:
  assumes "valid_selector Rs selector"
  shows "worklist G Rs = {} \<longleftrightarrow> selector G = None"
        "selector G = Some (R,f) \<Longrightarrow> valid_selection Rs G R f"
  using assms[unfolded valid_selector_def,rule_format,of G]
  by (cases "worklist G Rs = {}",auto)

text \<open>The following gives a valid selector.
      This selector is not useful as concrete implementation, because it used the choice operation.\<close>
definition non_constructive_selector where
"non_constructive_selector Rs G \<equiv> let wl = worklist G Rs in
   if wl = {} then None else Some (SOME (R,f). valid_selection Rs G R f) "

lemma non_constructive_selector:
  assumes "set_of_graph_rules Rs"
  shows "valid_selector Rs (non_constructive_selector Rs)"
  unfolding valid_selector_def proof((clarify,standard;clarify),goal_cases)
  case (1 n E)
  let ?x = "(SOME (R, f). valid_selection Rs (n, E) R f)"
  from valid_selection_exists[OF 1 assms]
  have "\<exists> R f. valid_selection Rs (n, E) R f" by auto
  hence "\<exists> x. valid_selection Rs (n, E) (fst x) (snd x)"
    by auto
  from this prod.case_eq_if tfl_some
  have "\<not> valid_selection Rs (n, E) (fst ?x) (snd ?x) \<Longrightarrow> False"
    by (metis (mono_tags, lifting))
  thus ?case unfolding non_constructive_selector_def Let_def using 1 by (auto simp:prod_eq_iff)
qed (auto simp:non_constructive_selector_def)

text \<open>The following is used to make a weak pushout step.
      In the paper, we aren't too specific on how this should be done. Here we are.
      We work on natural numbers in order to be able to pick fresh elements easily. \<close>
definition extend ::
    "nat \<Rightarrow> ('b, 'a::linorder) Graph_PreRule  \<Rightarrow> ('a \<times> nat) set \<Rightarrow> ('a \<times> nat) set" where
"extend n R f \<equiv> f \<union>
   (let V_new = sorted_list_of_set (vertices (snd R) - vertices (fst R))
    in set (zip V_new [n..<(n+length V_new)]))"

lemma nextMax_set[simp]:
  assumes "sorted xs"
  shows "nextMax (set xs) = (if xs = Nil then 0 else Suc (last xs))"
  using assms
proof(induct xs)
  case Nil show ?case unfolding nextMax_def by auto
next
  case (Cons a list)
  hence "list \<noteq> [] \<Longrightarrow> fold max list a = last list"
    using list_sorted_max by (metis last.simps)
  thus ?case unfolding nextMax_def Max.set_eq_fold by auto
qed

lemma nextMax_Un_eq[simp]:
"finite x \<Longrightarrow> finite y \<Longrightarrow> nextMax (x \<union> y) = max (nextMax x) (nextMax y)"
  unfolding nextMax_def using Max_Un by auto

lemma extend: (* extensible into the new graph *)
  assumes "graph_homomorphism (fst R) (LG E {0..<n}) f" "graph_rule R"
  defines "g \<equiv> extend n R f"
  defines "G' \<equiv> LG ((on_triple g `` (edges (snd R))) \<union> E) {0..<max n (nextMax (Range g))}"
  shows "graph_homomorphism (snd R) G' g" "agree_on (fst R) f g" "f \<subseteq> g"
        "subgraph (LG E {0..<n}) G'"
        "weak_universal (t:: 'x itself) R (LG E {0..<n}) G' f g"
proof -
  have ln:"length x = length [n..<n + length x]" for x::"'b list" by auto
  let ?R_L = "vertices (snd R) - vertices (fst R)"
  from assms
  have "graph_rule (fst R,snd R)" and fin_R:"finite (vertices (snd R))"
    and subsLR:"vertices (fst R) \<subseteq> vertices (snd R)" and gr_R:"graph (snd R)"
    unfolding subgraph_def graph_union_iff
    by auto
  hence fin_R_L[simp]:"finite ?R_L"
     and fin_L:"finite (vertices (fst R))"
     using finite_subset by auto
  from assms have f_dom:"Domain f = vertices (fst R)"
    and f_uni:"univalent f" unfolding graph_homomorphism_def by auto
  from assms[unfolded graph_homomorphism_def]
  have "f `` vertices (fst R) \<subseteq> vertices (LG E {0..<n})" by blast
  hence f_ran:"Range f \<subseteq> {0..<n}" using f_dom by auto
  let ?g = "(let V_new = sorted_list_of_set ?R_L
              in set (zip V_new [n..<n + length V_new]))" (* new part of g *)
  have fin_g':"finite ?g" "finite (Range ?g)" unfolding Let_def by auto
  have "finite (Domain f)" "univalent f" using assms(1) fin_L
    unfolding graph_homomorphism_def by auto
  hence fin_f:"finite (Range f)" unfolding Range_snd by auto
  hence fin_g:"finite (Range g)" unfolding extend_def g_def Let_def Range_Un_eq by auto
  have nextMax_f:"nextMax (Range f) \<le> n"
    using f_ran Max_in[OF fin_f] by (simp add:nextMax_def Suc_leI subset_eq)

  have "x \<in> Domain ?g \<Longrightarrow> x \<notin> Domain f" for x unfolding f_dom Let_def by auto
  hence g_not_f:"(x,y) \<in> ?g \<Longrightarrow> (x,z) \<notin> f" for x y z by auto
  have uni_g':"univalent ?g" "univalent (converse ?g)" unfolding Let_def by auto
  with f_uni have uni_g:"univalent g" by (auto simp:g_def extend_def g_not_f)
  from fin_g have "(a,b) \<in> g \<Longrightarrow> b < Suc (Max (Range g))" for a b
    unfolding less_Suc_eq_le by (rule Max.coboundedI) force
  hence "(a,b) \<in> g \<Longrightarrow> b < nextMax (Range g)" for a b
    unfolding nextMax_def by (cases "Range g = {}",auto)
  hence in_g:"(a,b) \<in> g \<Longrightarrow> b < max n (nextMax (Range g))" for a b by fastforce
  let ?G = "LG E {0..<n}"
  have gr_G:"graph ?G" using assms(1) unfolding graph_homomorphism_def by blast
  hence "(a, aa, b) \<in> E \<Longrightarrow> b < max n c" "(a, aa, b) \<in> E \<Longrightarrow> aa < max n c"
    for a aa b c by fastforce+
  hence gr_G':"graph G'" unfolding G'_def restrict_def using in_g by auto
  show "subgraph (LG E {0..<n}) G'"
    unfolding subgraph_def2[OF gr_G gr_G'] unfolding G'_def by auto
  have g_dom:"vertices (snd R) = Domain g" using subsLR
    unfolding g_def extend_def Domain_Un_eq f_dom by (auto simp:Let_def)
  show "graph_homomorphism (snd R) G' g"
    by (intro graph_homomorphismI[OF g_dom _ uni_g _ gr_R gr_G'])
       (auto simp:G'_def intro:in_g)
  show "f \<subseteq> g" by (auto simp:g_def extend_def)
  thus "agree_on (fst R) f g" using f_dom uni_g agree_on_subset equalityE by metis
  show "weak_universal t R ?G G' f g" proof fix a:: "('b \<times> 'x) set" fix b G
    assume a:"graph_homomorphism (snd R) G a"
             "graph_homomorphism ?G G b" "f O b \<subseteq> a"
    hence univ_b:"univalent b" and univ_a:"univalent a"
      and rng_b:"Range b \<subseteq> vertices G" and rng_a:"Range a \<subseteq> vertices G"
      and ep_b:"edge_preserving b (edges (LG E {0..<n})) (edges G)"
      and ep_a:"edge_preserving a (edges (snd R)) (edges G)"
      unfolding graph_homomorphism_def prod.sel labeled_graph.sel by blast+
    from a have dom_b:"Domain b = {0..<n}"
      and dom_a:"Domain a = vertices (snd R)" and v6: "graph G"
      unfolding graph_homomorphism_def prod.sel labeled_graph.sel by auto

    have help_dom_b:"(y, z) \<in> b \<Longrightarrow> n \<le> y \<Longrightarrow> False" for y z using dom_b
      by (metis Domain.DomainI atLeastLessThan_iff not_less)
    have disj_doms:"Domain b \<inter> Domain (?g\<inverse> O a) = {}" using help_dom_b
      unfolding Let_def by (auto dest!:set_zip_leftD)

    have "max n (nextMax (Range ?g)) = n + length (sorted_list_of_set ?R_L)" (is "_ = ?len")
      unfolding Let_def Range_snd set_map[symmetric] map_snd_zip[OF ln] nextMax_set[OF sorted_upt]
      by fastforce
    hence n_eq:"?len = max n (nextMax (Range g))"
      unfolding Range_snd[symmetric] g_def extend_def Range_Un_eq
                nextMax_Un_eq[OF fin_f fin_g'(2)] max.assoc[symmetric] max_absorb1[OF nextMax_f]
      by auto

    let ?h = "b \<union> ?g\<inverse> O a"

    have dg:"Domain (?g\<inverse>) = {n..<max n (nextMax (Range g))}"
      unfolding Let_def Domain_converse Range_set_zip[OF ln] atLeastLessThan_upt
      unfolding Range_snd n_eq ..
    have "?g `` Domain a = ?g `` (?R_L \<union> vertices (fst R))"
      using dom_a subsLR by auto
    also have "\<dots> = ?g `` ?R_L \<union> ?g `` vertices (fst R)" by auto
    also have "?g `` vertices (fst R) = {}" apply(rule Image_outside_Domain)
      unfolding Let_def Domain_set_zip[OF ln] by auto
    also have "?g `` ?R_L = Range ?g" apply(rule Image_Domain)
      unfolding Let_def Domain_set_zip[OF ln] by auto
    finally have dg2:"?g `` Domain a = {n..<max n (nextMax (Range g))}"
      unfolding Let_def Range_set_zip[OF ln] set_sorted_list_of_set[OF fin_R_L]
      unfolding n_eq set_upt by auto
    have "Domain (?g\<inverse> O a) = {n..<max n (nextMax (Range g))}"
      unfolding Domain_id_on converse_converse dg dg2 by auto
    hence v1: "vertices G' = Domain ?h" unfolding G'_def Domain_Un_eq dom_b by auto
    have "b `` vertices G' \<subseteq> vertices G" "(?g\<inverse> O a) `` vertices G' \<subseteq> vertices G"
      using rng_a rng_b by auto
    hence v2: "?h `` vertices G' \<subseteq> vertices G" by blast
    have v3: "univalent ?h"
      using disj_doms univalent_union[OF univ_b univalent_composes[OF uni_g'(2) univ_a]] by blast
    (* showing edge preservation *)
    { fix l x y x' y' assume a2:"(l,x,y) \<in> edges G'" "(x,x') \<in> ?h" "(y,y') \<in> ?h"
      have "(l,x',y') \<in> edges G" proof(cases "(l,x,y) \<in> edges ?G")
        case True
        with gr_G[THEN restrictD]
        have "x \<in> Domain b" "y \<in> Domain b" unfolding dom_b by auto
        hence "x \<notin> Domain (converse ?g O a)" "y \<notin> Domain (converse ?g O a)"
          using disj_doms by blast+
        hence "(x,x') \<in> b" "(y,y') \<in> b" using a2 by auto
        with ep_b True show ?thesis unfolding edge_preserving by auto
      next
        have "g O ?h = f O b \<union> ?g O b \<union> ((f O ?g\<inverse>) O a \<union> (?g O ?g\<inverse>) O a)"
          unfolding g_def extend_def by blast
        also have "(?g O ?g\<inverse>) = Id_on ?R_L"
          unfolding univalent_O_converse[OF uni_g'(2)] unfolding Let_def by auto
        also have "(f O ?g\<inverse>) = {}" using f_ran unfolding Let_def by (auto dest!:set_zip_leftD)
        also have "?g O b = {}" using help_dom_b unfolding Let_def by (auto dest!:set_zip_rightD)
        finally have gOh:"g O ?h \<subseteq> a" using a(3) by blast
        case False
        hence "(l,x,y) \<in> on_triple g `` edges (snd R)" using a2(1) unfolding G'_def by auto
        then obtain r_x r_y
          where r:"(l,r_x,r_y) \<in> edges (snd R)" "(r_x,x) \<in> g" "(r_y,y) \<in> g" by auto
        hence "(r_x,x') \<in> a" "(r_y,y') \<in> a" using gOh a2(2,3) by auto
        hence "(l,x',y') \<in> on_triple a `` edges (snd R)" using r(1) unfolding on_triple_def by auto
        thus ?thesis using ep_a unfolding edge_preserving by auto
      qed
    }
    hence v4: "edge_preserving ?h (edges G') (edges G)" by auto
    have "graph_homomorphism G' G ?h" by(fact graph_homomorphismI[OF v1 v2 v3 v4 gr_G' v6])
    thus "\<exists>h. graph_homomorphism G' G h \<and> b \<subseteq> h" by auto
  qed
qed

text \<open>Showing that the extend function indeed creates a valid pushout.\<close>
lemma selector_pushout:
  assumes "valid_selector Rs selector" "selector G'' = Some (R,f)"
  defines "G \<equiv> graph_of G''"
  assumes "graph G"
  defines "g \<equiv> extend (fst G'') R f"
  defines "G' \<equiv> LG (on_triple g `` edges (snd R) \<union> (snd G'')) {0..<max (fst G'') (nextMax (Range g))}"
  shows "pushout_step (t:: 'x itself) R G G'"
proof -
  have "valid_selection Rs G'' R f" using assms by(cases "selector G''",auto)
  hence igh:"graph_homomorphism (fst R) G f" "graph_rule R"
    unfolding valid_selection_def worklist_def G_def Let_def by auto
  have "subgraph G G'"
       "graph_homomorphism (fst R) G f"
       "graph_homomorphism (snd R) G' g"
       "f \<subseteq> g"
       "weak_universal t R G G' f g"
    using extend[OF igh[unfolded G_def],folded g_def,folded G'_def,folded G_def] igh(1)
    by auto
  thus ?thesis unfolding pushout_step_def by auto
qed

text \<open>Making a single step in Algorithm 1.
  A prerequisite is that its first argument is a @{term valid_selector}.\<close>

definition make_step where
"make_step selector S \<equiv>
   case selector S of
     None \<Rightarrow> S |
     Some (R,f) \<Rightarrow> (let g = extend (fst S) R f in
         (max (fst S) (nextMax (Range g)), (on_triple g `` (edges (snd R))) \<union> (snd S)))"

lemma WPC_through_make_step:
  assumes "set_of_graph_rules Rs" "graph (graph_of (X 0))"
     and makestep: "\<forall> i. X (Suc i) = make_step selector (X i)"
     and selector: "valid_selector Rs selector"
  shows "Simple_WPC t Rs (\<lambda> i. graph_of (X i))" "chain (\<lambda> i. graph_of (X i))"
proof
  note ms = makestep[unfolded make_step_def,rule_format]
  have gr:"graph (graph_of (X i))" for i proof(induct i)
    case (Suc i)
    then show ?case proof(cases "selector (X i)")
      case None
      then show ?thesis using ms Suc by auto
    next
      case (Some a)
      then obtain R f where Some:"selector (X i) = Some (R,f)" by fastforce
      then show ?thesis using ms[of i,unfolded Some Let_def]
        selector_pushout[OF selector Some Suc,of t
                        ,unfolded pushout_step_def subgraph_def]
        by auto
    qed
  qed (fact assms)
  show "chain (\<lambda> i. graph_of (X i))" unfolding chain_def
  proof(clarify) fix i
    show "subgraph (graph_of (X i)) (graph_of (X (i + 1)))"
    proof(cases "selector (X i)")
      case None
      then show ?thesis using ms gr by (auto intro!:graph_homomorphismI)
    next
      case Some
      then obtain R f where Some:"selector (X i) = Some (R,f)" by fastforce
      then show ?thesis using ms selector_pushout[OF selector Some gr,of t]
      unfolding pushout_step_def Let_def by simp
    qed
  qed
  show "graph_of (X i) = graph_of (X (Suc i)) \<or>
         (\<exists>R\<in>Rs. pushout_step t R (graph_of (X i)) (graph_of (X (Suc i))))" for i
  proof(cases "selector (X i)")
    case None thus ?thesis using ms by auto
  next
    case Some
    then obtain R f where Some:"selector (X i) = Some (R,f)" by fastforce
    hence "R \<in> Rs"
      using valid_selectorD(2)[OF selector,unfolded valid_selection_def worklist_def Let_def]
      by(cases R,blast)
    then show ?thesis using ms[of i,unfolded Some Let_def] selector_pushout[OF selector Some gr]
      unfolding make_step_def by auto
  qed
qed (fact assms)+

lemma N_occurs_finitely_often:
  assumes "finite Rs" "set_of_graph_rules Rs" "graph (graph_of (X 0))"
      and makestep: "\<And> i. X (Suc i) = make_step selector (X i)"
      and selector: "valid_selector Rs selector"
    shows "finite {(R,f). \<exists> i. R\<in> Rs \<and> graph_homomorphism (fst R) (graph_of (X i)) f
                        \<and> nextMax (Range f) \<le> N}" (is "finite {(R,f).?P R f}")
proof -
  have prod_eq : "(\<forall> x \<in> {(x, y). A x y}. B x) \<longleftrightarrow> (\<forall> x. A (fst x) (snd x) \<longrightarrow> B x)"
     "(x \<in> {(x, y). A x y}) \<longleftrightarrow> (A (fst x) (snd x))"
    for A B x by auto
  let ?S = "{(R,f).?P R f}"
  let "?Q R f" = "Domain f = vertices (fst (R::('a, 'b) Graph_PreRule)) \<and> univalent f \<and> nextMax (Range f) \<le> N"
  have seteq:"(\<Union>R\<in>Rs. {(R', f). R' = R \<and> ?Q R f}) = {(R,f). R \<in> Rs \<and> ?Q R f}" by auto
  have "\<forall> R \<in> Rs. finite {(R',f). R' = R \<and> ?Q R f}"
  proof fix R assume "R \<in> Rs"
    hence fin:"finite (vertices (fst R))" using assms by auto
    hence fin2:"finite (Pow (vertices (fst R) \<times> {0..N}))" by auto
    have fin:"Domain x = vertices (fst R) \<Longrightarrow> univalent x \<Longrightarrow> finite (snd ` x)"
      for x:: "('b \<times> nat) set" using fin univalent_finite[of x] by simp
    hence "Domain f = vertices (fst R) \<Longrightarrow>
      univalent f \<Longrightarrow> (a,b) \<in> f \<Longrightarrow> nextMax (Range f) \<le> N \<Longrightarrow> b \<le> N" for f a b
      unfolding Range_snd using image_eqI nextMax_max(2) snd_conv order.trans by metis
    hence sub:"{f. ?Q R f} \<subseteq> Pow (vertices (fst R) \<times> {0..N})"
      using nextMax_max[OF fin] by (auto simp:Range_snd image_def)
    from finite_subset[OF sub fin2] show "finite {(R',f). R' = R \<and> ?Q R f}" by auto
  qed
  from this[folded finite_UN[OF assms(1)],unfolded seteq]
  have fin:"finite {(R,f). R \<in> Rs \<and> ?Q R f}".
  have "?P R f \<Longrightarrow> R \<in> Rs \<and> ?Q R f" for R f
    unfolding graph_homomorphism_def by auto
  hence "?S \<subseteq> {(R,f). R \<in> Rs \<and> ?Q R f}" unfolding subset_eq prod_eq by blast
  from finite_subset[OF this fin] show ?thesis by auto
qed

lemma inj_on_infinite:
  assumes "infinite A" "inj_on f A" "range f \<subseteq> B"
  shows "infinite B"
proof -
  from assms[unfolded infinite_iff_countable_subset] obtain g::"nat \<Rightarrow> 'a" where
    g:"inj g \<and> range g \<subseteq> A" by blast
  hence i:"inj (f o g)" using assms(2) using comp_inj_on inj_on_subset by blast
  have "range (f o g) \<subseteq> B" using assms(3) by auto
  with i show ?thesis
    unfolding infinite_iff_countable_subset by blast
qed

lemma makestep_makes_selector_inj:
  assumes "selector (X y) = Some (R,f)"
          "selector (X x) = Some (R,f)"
          "valid_selector Rs selector"
    and step: "\<forall> i. X (Suc i) = make_step selector (X i)"
    and chain:"chain (\<lambda> i. graph_of (X i))"
  shows "x = y"
proof(rule ccontr)
  assume a:"x \<noteq> y"
  define x' y' where "x' \<equiv> min x y" "y' \<equiv> max x y"
  hence xy:"selector (X x') = Some (R, f)" "selector (X y') = Some (R, f)" "x' < y'"
    using assms(1,2) a unfolding min_def max_def by auto
  with valid_selectorD assms
  have "valid_selection Rs (X x') R f" "valid_selection Rs (X y') R f" by auto
  hence not_ex:"\<not> extensible R (graph_of (X y')) f"
    and hom:"graph_homomorphism (fst R) (graph_of (X x')) f" "graph_rule R"
    unfolding valid_selection_def Let_def worklist_def by auto
  have X:"X (Suc x') = (max (fst (X x')) (nextMax (Range (extend (fst (X x')) R f))),
          on_triple (extend (fst (X x')) R f) `` edges (snd R) \<union> snd (X x'))"
    unfolding step[unfolded make_step_def Let_def,rule_format] xy by auto
  let ?ex = "extend (fst (X x')) R f"
  have hom:"graph_homomorphism (snd R) (graph_of (X (Suc x'))) ?ex"
       and agr:"agree_on (fst R) f ?ex" using extend(1,2)[OF hom] unfolding X by auto
  from xy have "Suc x' \<le> y'" by auto
  with chain[unfolded chain_def2] have "subgraph (graph_of (X (Suc x'))) (graph_of (X y'))" by auto
  from subgraph_preserves_hom[OF this hom]
  have hom:"graph_homomorphism (snd R) (graph_of (X y')) ?ex".
  with agr have "extensible R (graph_of (X y')) f" unfolding extensible_def by auto
  thus False using not_ex by auto
qed

lemma fair_through_make_step:
  assumes "finite Rs" "set_of_graph_rules Rs" "graph (graph_of (X 0))"
     (* It should suffice to take infinitely many make_steps,
        rather than having every step be a make_step,
        but we focus on the algorithm as in the paper here *)
     and makestep: "\<forall> i. X (Suc i) = make_step selector (X i)"
     and selector: "valid_selector Rs selector"
  shows "fair_chain Rs (\<lambda> i. graph_of (X i))"
proof
  show chn:"chain (\<lambda>i. graph_of (X i))" using WPC_through_make_step assms by blast
  fix R f i
  assume Rs:"R \<in> Rs" and h:"graph_homomorphism (fst R) (graph_of (X i)) f"
  hence R:"finite (vertices (snd R))" "subgraph (fst R) (snd R)"  "finite (vertices (fst R))"
    using assms by auto
  hence f:"finite f" "finite (Range f)" "finite (Domain f)" "univalent f"
    using h unfolding graph_homomorphism_def Range_snd by auto
  define N where "N \<equiv> nextMax (Range f)"
  fix S
  let "?Q X' j" = " fst X' \<in> Rs
                  \<and> graph_homomorphism (fst (fst X')) (graph_of (X (j+i))) (snd X')
                  \<and> nextMax (Range (snd X')) \<le> N"
  let ?S = "{(R,f). \<exists>j. ?Q (R,f) j}"
  from assms(4) have "\<And>ia. X (Suc ia + i) = make_step selector (X (ia + i))" by auto
  note r = assms(1,2) chain_then_restrict[OF chn] this assms(5)
  from N_occurs_finitely_often[of Rs "\<lambda> j. X (j + i)",OF r]
  have fin_S:"finite ?S" by auto
  { assume a:"\<forall>j. \<not> extensible R (graph_of (X j)) f"
    let "?P X' j" = "?Q X' j \<and> Some X' = selector (X (j+i))"
    { fix j let ?j = "j+i" have "?j \<ge> i" by auto
      from subgraph_preserves_hom[OF chain[OF chn this] h]
      have h:"graph_homomorphism (fst R) (graph_of (X ?j)) f".
      have "\<not> extensible R (graph_of (X ?j)) f" using a by blast
      with h Rs have wl:"(nextMax (Range f),R,f) \<in> worklist (X ?j) Rs"
        unfolding worklist_def Let_def set_eq_iff by auto
      hence "worklist (X ?j) Rs \<noteq> {}" by auto
      with valid_selectorD[OF selector]
      obtain R' f'
        where sel:"Some (R',f') = selector (X ?j)"
                  "valid_selection Rs (X ?j) R' f'" by auto
      hence max:"(nextMax (Range f'), R', f') \<in> worklist (X ?j) Rs"
                "(\<forall>(N, _)\<in>worklist (X ?j) Rs. nextMax (Range f') \<le> N)"
        unfolding valid_selection_def Let_def by auto
      with wl have "nextMax (Range f') \<le> N" unfolding N_def by auto
      with max(1)[unfolded worklist_def Let_def mem_Collect_eq prod.case] sel(1)
      have "\<exists> X'. ?P X' j" by (metis fst_conv snd_conv)
    }
    then obtain ch where ch:"\<And> j. ?P (ch j) j" by metis (* uses 'choice' internally *)
    have inj:"inj ch" proof fix x y assume "ch x = ch y"
      with ch[of x] ch[of y]
      have "selector (X (x + i)) = Some (ch x)" "selector (X (y + i)) = Some (ch x)" by auto
      with makestep_makes_selector_inj[OF _ _ selector makestep chn] have "x + i = y + i"
        by (cases "ch x",metis (full_types))
      thus "x = y" by auto
    qed
    have "ch x \<in> ?S" for x using ch[of x] unfolding mem_Collect_eq by(intro case_prodI2) metis
    hence "range ch \<subseteq> ?S" unfolding UNIV_def by(rule image_Collect_subsetI)
    with infinite_iff_countable_subset inj have "infinite ?S" by blast
    with fin_S have "False" by auto
  }
  thus "\<exists>j. extensible R (graph_of (X j)) f" by auto
qed

fun mk_chain where
  "mk_chain sel Rs init 0 = init" |
  "mk_chain sel Rs init (Suc n) = mk_chain sel Rs (make_step sel init) n"

lemma mk_chain:
  "\<forall> i. mk_chain sel Rs init (Suc i) = make_step sel (mk_chain sel Rs init i)"
proof
  fix i
  show "mk_chain sel Rs init (Suc i) = make_step sel (mk_chain sel Rs init i)"
    by (induct i arbitrary:init,auto)
qed

text \<open>Algorithm 1, abstractly.\<close>
abbreviation the_lcg where
"the_lcg sel Rs init \<equiv> chain_sup (\<lambda>i. graph_of (mk_chain sel Rs init i))"

lemma mk_chain_edges:
  assumes "valid_selector Rules sel"
          "\<Union> ((edges o snd) ` Rules) \<subseteq> L \<times> UNIV"
          "edges (graph_of G) \<subseteq> L \<times> UNIV"
  shows "edges (graph_of (mk_chain sel Rules G i)) \<subseteq> L \<times> UNIV"
using assms(3) proof(induct i arbitrary:G)
  case 0
  then show ?case using assms(2) by auto
next
  case (Suc i G)
  hence "edges (graph_of (make_step sel G)) \<subseteq> L \<times> UNIV"
  proof(cases "sel G")
    case None show ?thesis unfolding None make_step_def using Suc by auto
  next
    case (Some a)
    then obtain R f where Some:"sel G = Some (R, f)" by fastforce
    hence "(a, x, y) \<in> edges (snd R) \<Longrightarrow> a \<in> L" for a x y
      using assms(2) valid_selectorD(2)[OF assms(1) Some]
      unfolding valid_selection_def Let_def worklist_def by auto
    then show ?thesis unfolding Some make_step_def Let_def using Suc by auto
  qed
  thus ?case unfolding mk_chain.simps by(rule Suc)
qed

lemma the_lcg_edges:
  assumes "valid_selector Rules sel"
          "fst ` (\<Union> ((edges o snd) ` Rules)) \<subseteq> L" (is "fst `?fR \<subseteq> _")
          "fst ` snd G \<subseteq> L"
  shows "fst ` edges (the_lcg sel Rules G) \<subseteq> L"
proof -
  from assms have "fst `?fR \<times> UNIV \<subseteq> L \<times> UNIV" "fst `(edges (graph_of G)) \<times> UNIV \<subseteq> L \<times> UNIV"
    by auto
  hence "(\<Union> ((edges o snd) ` Rules)) \<subseteq> L \<times> UNIV" "edges (graph_of G) \<subseteq> L \<times> UNIV"
    using fst_UNIV[of ?fR] fst_UNIV[of "(edges (graph_of G))"] by blast+
  note assms = assms(1) this
  have "edges (graph_of (mk_chain sel Rules G i)) \<subseteq> L \<times> UNIV" for i
    using mk_chain_edges[OF assms,unfolded Times_subset_cancel2[OF UNIV_I]].
  hence "edges (the_lcg sel Rules G) \<subseteq> L \<times> UNIV" unfolding chain_sup_def by auto
  thus ?thesis by auto
qed

text \<open>Lemma 9.\<close>
lemma lcg_through_make_step:
assumes "finite Rs" "set_of_graph_rules Rs" "graph (graph_of init)"
        "valid_selector Rs sel"
  shows "least_consequence_graph t Rs (graph_of init) (the_lcg sel Rs init)"
proof -
  from assms have gr:"graph (graph_of (mk_chain sel Rs init 0))" by auto
  note assms = assms(1,2) this mk_chain assms(4)
  from set_of_graph_rulesD[OF assms(2)]
  have "(\<And>R. R \<in> Rs \<Longrightarrow> subgraph (fst R) (snd R) \<and> finite_graph (fst R))" by auto
  from fair_chain_impl_consequence_graph[OF fair_through_make_step[OF assms] this]
       wpc_simpl[OF WPC_through_make_step(1)[OF assms(2-)],THEN wpc_least]
  show ?thesis unfolding least_consequence_graph_def by auto
qed

end


header {* Tema 3: Deducción natural proposicional con Isabelle/HOL *}

theory T3
imports Main
begin

text {*
  En este tema se presentan los ejemplos del tema de deducción natural
  proposicional siguiendo la presentación de Huth y Ryan en su libro
  "Logic in Computer Science" http://goo.gl/qsVpY y, más concretamente,
  a la forma como se explica en la asignatura de "Lógica informática" (LI)
  http://goo.gl/AwDiv

  La página al lado de cada ejemplo indica la página de las transparencias
  donde se encuentra la demostración. *}

subsection {* Reglas de la conjunción *}

text {*
  Ejemplo 1 (p. 4). Demostrar que
     p \<and> q, r \<turnstile> q \<and> r.
  *}

-- "La demostración detallada es"
lemma ejemplo_1_1:
  assumes 1: "p \<and> q" and
          2: "r"
  shows "q \<and> r"
proof -
  have 3: "q" using 1 by (rule conjunct2)
  show 4: "q \<and> r" using 3 2 by (rule conjI)
qed
thm ejemplo_1_1
text {*
  Notas sobre el lenguaje: En la demostración anterior se ha usado
  · "assumes" para indicar las hipótesis,
  · "and" para separar las hipótesis,
  · "shows" para indicar la conclusión,
  · "proof" para iniciar la prueba,
  · "qed" para terminar la pruebas,
  · "-" (después de "proof") para no usar el método por defecto,
  · "have" para establecer un paso,
  · "using" para usar hechos en un paso,
  · "by (rule ..)" para indicar la regla con la que se peueba un hecho,
  · "show" para establecer la conclusión.

  Notas sobre la lógica: Las reglas de la conjunción son
  · conjI:      \<lbrakk>P; Q\<rbrakk> \<Longrightarrow> P \<and> Q
  · conjunct1:  P \<and> Q \<Longrightarrow> P
  · conjunct2:  P \<and> Q \<Longrightarrow> Q
*}

text {* Se pueden dejar implícitas las reglas como sigue *}

lemma ejemplo_1_2:
  assumes 1: "p \<and> q" and
          2: "r"
  shows "q \<and> r"
proof -
  have 3: "q" using 1 ..
  show 4: "q \<and> r" using 3 2 ..
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · ".." para indicar que se prueba por la regla correspondiente. *}

text {* Se pueden eliminar las etiquetas como sigue *}

lemma ejemplo_1_3:
  assumes "p \<and> q"
          "r"
  shows   "q \<and> r"
proof -
  have "q" using assms(1) ..
  thus "q \<and> r" using assms(2) ..
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "assms(n)" para indicar la hipótesis n y
  · "thus" para demostrar la conclusión usando el hecho anterior.
  Además, no es necesario usar and entre las hipótesis. *}

text {* Se puede automatizar la demostración como sigue *}

lemma ejemplo_1_4:
  assumes "p \<and> q"
          "r"
  shows   "q \<and> r"
using assms
by auto

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "assms" para indicar las hipótesis y
  · "by auto" para demostrar la conclusión automáticamente. *}

text {* Se puede automatizar totalmente la demostración como sigue *}

lemma ejemplo_1_5:
  "\<lbrakk>p \<and> q; r\<rbrakk> \<Longrightarrow> q \<and> r"
by auto

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "\<lbrakk> ... \<rbrakk>" para representar las hipótesis,
  · ";" para separar las hipótesis y
  · "\<Longrightarrow>" para separar las hipótesis de la conclusión. *}

text {* Se puede hacer la demostración por razonamiento hacia atrás,
  como sigue *}

lemma ejemplo_1_6:
  assumes "p \<and> q"
      and "r"
  shows   "q \<and> r"
proof (rule conjI)
  show "q" using assms(1) by (rule conjunct2)
next
  show "r" using assms(2) by this
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "proof (rule r)" para indicar que se hará la demostración con la
    regla r,
  · "next" para indicar el comienzo de la prueba del siguiente
    subobjetivo,
  · "this" para indicar el hecho actual. *}

text {* Se pueden dejar implícitas las reglas como sigue *}

lemma ejemplo_1_7:
  assumes "p \<and> q"
          "r"
  shows   "q \<and> r"
proof
  show "q" using assms(1) ..
next
  show "r" using assms(2) .
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "." para indicar por el hecho actual. *}

subsection {* Reglas de la doble negación *}

text {*
  La regla de eliminación de la doble negación es
  · notnotD: \<not>\<not> P \<Longrightarrow> P

  Para ajustarnos al tema de LI vamos a introducir la siguiente regla de
  introducción de la doble negación
  · notnotI: P \<Longrightarrow> \<not>\<not> P
  aunque, de momento, no detallamos su demostración.
*}

lemma notnotI [intro!]: "P \<Longrightarrow> \<not>\<not> P"
by auto

text {*
  Ejemplo 2. (p. 5)
       p, \<not>\<not>(q \<and> r) \<turnstile> \<not>\<not>p \<and> r
*}

-- "La demostración detallada es"
lemma ejemplo_2_1:
  assumes 1: "p" and
          2: "\<not>\<not>(q \<and> r)"
  shows      "\<not>\<not>p \<and> r"
proof -
  have 3: "\<not>\<not>p" using 1 by (rule notnotI)
  have 4: "q \<and> r" using 2 by (rule notnotD)
  have 5: "r" using 4 by (rule conjunct2)
  show 6: "\<not>\<not>p \<and> r" using 3 5 by (rule conjI)
qed

-- "La demostración estructurada es"
lemma ejemplo_2_2:
  assumes "p"
          "\<not>\<not>(q \<and> r)"
  shows   "\<not>\<not>p \<and> r"
proof -
  have  "\<not>\<not>p" using assms(1) ..
  have  "q \<and> r" using assms(2) by (rule notnotD)
  hence "r" ..
  with `\<not>\<not>p` show  "\<not>\<not>p \<and> r" ..
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "hence" para indicar que se tiene por el hecho anterior,
  · `...` para referenciar un hecho y
  · "with P show Q" para indicar que con el hecho anterior junto con el
    hecho P se demuestra Q. *}

-- "La demostración automática es"
lemma ejemplo_2_3:
  assumes "p"
          "\<not>\<not>(q \<and> r)"
  shows   "\<not>\<not>p \<and> r"
using assms
by auto

text {* Se puede demostrar hacia atrás *}

lemma ejemplo_2_4:
  assumes "p"
          "\<not>\<not>(q \<and> r)"
  shows   "\<not>\<not>p \<and> r"
proof  (rule conjI)
  show "\<not>\<not>p" using assms(1) by (rule notnotI)
next
  have "q \<and> r" using assms(2) by (rule notnotD)
  thus "r" by (rule conjunct2)
qed

text {* Se puede eliminar las reglas en la demostración anterior, como
  sigue: *}

lemma ejemplo_2_5:
  assumes "p"
          "\<not>\<not>(q \<and> r)"
  shows   "\<not>\<not>p \<and> r"
proof
  show "\<not>\<not>p" using assms(1) ..
next
  have "q \<and> r" using assms(2) by (rule notnotD)
  thus "r" ..
qed

subsection {* Regla de eliminación del condicional *}

text {*
  La regla de eliminación del condicional es la regla del modus ponens
  · mp: \<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q
*}

text {*
  Ejemplo 3. (p. 6) Demostrar que
     \<not>p \<and> q, \<not>p \<and> q \<longrightarrow> r \<or> \<not>p \<turnstile> r \<or> \<not>p
*}

-- "La demostración detallada es"
lemma ejemplo_3_1:
  assumes 1: "\<not>p \<and> q" and
          2: "\<not>p \<and> q \<longrightarrow> r \<or> \<not>p"
  shows      "r \<or> \<not>p"
proof -
  show "r \<or> \<not>p" using 2 1 by (rule mp)
qed

-- "La demostración estructurada es"
lemma ejemplo_3_2:
  assumes "\<not>p \<and> q"
          "\<not>p \<and> q \<longrightarrow> r \<or> \<not>p"
  shows   "r \<or> \<not>p"
proof -
  show "r \<or> \<not>p" using assms(2,1) ..
qed

-- "La demostración automática es"
lemma ejemplo_3_3:
  assumes "\<not>p \<and> q"
          "\<not>p \<and> q \<longrightarrow> r \<or> \<not>p"
  shows   "r \<or> \<not>p"
using assms
by auto

text {*
  Ejemplo 4 (p. 6) Demostrar que
     p, p \<longrightarrow> q, p \<longrightarrow> (q \<longrightarrow> r) \<turnstile> r
 *}

-- "La demostración detallada es"
lemma ejemplo_4_1:
  assumes 1: "p" and
          2: "p \<longrightarrow> q" and
          3: "p \<longrightarrow> (q \<longrightarrow> r)"
  shows "r"
proof -
  have 4: "q" using 2 1 by (rule mp)
  have 5: "q \<longrightarrow> r" using 3 1 by (rule mp)
  show 6: "r" using 5 4 by (rule mp)
qed

-- "La demostración estructurada es"
lemma ejemplo_4_2:
  assumes "p"
          "p \<longrightarrow> q"
          "p \<longrightarrow> (q \<longrightarrow> r)"
  shows "r"
proof -
  have "q" using assms(2,1) ..
  have "q \<longrightarrow> r" using assms(3,1) ..
  thus "r" using `q` ..
qed

-- "La demostración automática es"
lemma ejemplo_4_3:
  "\<lbrakk>p; p \<longrightarrow> q; p \<longrightarrow> (q \<longrightarrow> r)\<rbrakk> \<Longrightarrow> r"
by auto

subsection {* Regla derivada del modus tollens *}

text {*
  Para ajustarnos al tema de LI vamos a introducir la regla del modus
  tollens
  · mt: \<lbrakk>F \<longrightarrow> G; \<not>G\<rbrakk> \<Longrightarrow> \<not>F
  aunque, de momento, sin detallar su demostración.
*}

lemma mt: "\<lbrakk>F \<longrightarrow> G; \<not>G\<rbrakk> \<Longrightarrow> \<not>F"
by auto

text {*
  Ejemplo 5 (p. 7). Demostrar
     p \<longrightarrow> (q \<longrightarrow> r), p, \<not>r \<turnstile> \<not>q
 *}

-- "La demostración detallada es"
lemma ejemplo_5_1:
  assumes 1: "p \<longrightarrow> (q \<longrightarrow> r)" and
          2: "p" and
          3: "\<not>r"
  shows "\<not>q"
proof -
  have 4: "q \<longrightarrow> r" using 1 2 by (rule mp)
  show "\<not>q" using 4 3 by (rule mt)
qed

-- "La demostración estructurada es"
lemma ejemplo_5_2:
  assumes "p \<longrightarrow> (q \<longrightarrow> r)"
          "p"
          "\<not>r"
  shows   "\<not>q"
proof -
  have "q \<longrightarrow> r" using assms(1,2) ..
  thus "\<not>q" using assms(3) by (rule mt)
qed

-- "La demostración automática es"
lemma ejemplo_5_3:
  assumes "p \<longrightarrow> (q \<longrightarrow> r)"
          "p"
          "\<not>r"
  shows   "\<not>q"
using assms
by auto

text {*
  Ejemplo 6. (p. 7) Demostrar
     \<not>p \<longrightarrow> q, \<not>q \<turnstile> p
*}

-- "La demostración detallada es"
lemma ejemplo_6_1:
  assumes 1: "\<not>p \<longrightarrow> q" and
          2: "\<not>q"
  shows "p"
proof -
  have 3: "\<not>\<not>p" using 1 2 by (rule mt)
  show "p" using 3 by (rule notnotD)
qed

-- "La demostración estructurada es"
lemma ejemplo_6_2:
  assumes "\<not>p \<longrightarrow> q"
          "\<not>q"
  shows   "p"
proof -
  have "\<not>\<not>p" using assms(1,2) by (rule mt)
  thus "p" by (rule notnotD)
qed

-- "La demostración automática es"
lemma ejemplo_6_3:
  "\<lbrakk>\<not>p \<longrightarrow> q; \<not>q\<rbrakk> \<Longrightarrow> p"
by auto

text {*
  Ejemplo 7. (p. 7) Demostrar
     p \<longrightarrow> \<not>q, q \<turnstile> \<not>p
  *}

-- "La demostración detallada es"
lemma ejemplo_7_1:
  assumes 1: "p \<longrightarrow> \<not>q" and
          2: "q"
  shows "\<not>p"
proof -
  have 3: "\<not>\<not>q" using 2 by (rule notnotI)
  show "\<not>p" using 1 3 by (rule mt)
qed

-- "La demostración detallada es"
lemma ejemplo_7_2:
  assumes "p \<longrightarrow> \<not>q"
          "q"
  shows   "\<not>p"
proof -
  have "\<not>\<not>q" using assms(2) by (rule notnotI)
  with assms(1) show "\<not>p" by (rule mt)
qed

-- "La demostración estructurada es"
lemma ejemplo_7_3:
  "\<lbrakk>p \<longrightarrow> \<not>q; q\<rbrakk> \<Longrightarrow> \<not>p"
by auto

subsection {* Regla de introducción del condicional *}

text {*
  La regla de introducción del condicional es
  · impI: (P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q
*}

text {*
  Ejemplo 8. (p. 8) Demostrar
     p \<longrightarrow> q \<turnstile> \<not>q \<longrightarrow> \<not>p
*}

-- "La demostración detallada es"
lemma ejemplo_8_1:
  assumes 1: "p \<longrightarrow> q"
  shows "\<not>q \<longrightarrow> \<not>p"
proof -
  { assume 2: "\<not>q"
    have "\<not>p" using 1 2 by (rule mt) }
  thus "\<not>q \<longrightarrow> \<not>p" by (rule impI)
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "{ ... }" para representar una caja. *}

-- "La demostración estructurada es"
lemma ejemplo_8_2:
  assumes "p \<longrightarrow> q"
  shows "\<not>q \<longrightarrow> \<not>p"
proof
  assume "\<not>q"
  with assms show "\<not>p" by (rule mt)
qed

-- "La demostración automática es"
lemma ejemplo_8_3:
  assumes "p \<longrightarrow> q"
  shows "\<not>q \<longrightarrow> \<not>p"
using assms
by auto

text {*
  Ejemplo 9. (p. 9) Demostrar
     \<not>q \<longrightarrow> \<not>p \<turnstile> p \<longrightarrow> \<not>\<not>q
*}

-- "La demostración detallada es"
lemma ejemplo_9_1:
  assumes 1: "\<not>q \<longrightarrow> \<not>p"
  shows "p \<longrightarrow> \<not>\<not>q"
proof -
  { assume 2: "p"
    have 3: "\<not>\<not>p" using 2 by (rule notnotI)
    have "\<not>\<not>q" using 1 3 by (rule mt) }
  thus "p \<longrightarrow> \<not>\<not>q" by (rule impI)
qed

-- "La demostración estructurada es"
lemma ejemplo_9_2:
  assumes "\<not>q \<longrightarrow> \<not>p"
  shows    "p \<longrightarrow> \<not>\<not>q"
proof
  assume "p"
  hence "\<not>\<not>p" by (rule notnotI)
  with assms show "\<not>\<not>q" by (rule mt)
qed

-- "La demostración automática es"
lemma ejemplo_9_3:
  assumes "\<not>q \<longrightarrow> \<not>p"
  shows "p \<longrightarrow> \<not>\<not>q"
using assms
by auto

text {*
  Ejemplo 10 (p. 9). Demostrar
     \<turnstile> p \<longrightarrow> p
*}

-- "La demostración detallada es"
lemma ejemplo_10_1:
  "p \<longrightarrow> p"
proof -
  { assume 1: "p"
    have "p" using 1 by this }
  thus "p \<longrightarrow> p" by (rule impI)
qed

-- "La demostración estructurada es"
lemma ejemplo_10_2:
  "p \<longrightarrow> p"
proof (rule impI)
qed

-- "La demostración automática es"
lemma ejemplo_10_3:
  "p \<longrightarrow> p"
by auto

text {*
  Ejemplo 11 (p. 10) Demostrar
     \<turnstile> (q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r))
 *}

-- "La demostración detallada es"
lemma ejemplo_11_1:
  "(q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r))"
proof -
  { assume 1: "q \<longrightarrow> r"
    { assume 2: "\<not>q \<longrightarrow> \<not>p"
      { assume 3: "p"
        have 4: "\<not>\<not>p" using 3 by (rule notnotI)
        have 5: "\<not>\<not>q" using 2 4 by (rule mt)
        have 6: "q" using 5 by (rule notnotD)
        have "r" using 1 6 by (rule mp) }
      hence "p \<longrightarrow> r" by (rule impI) }
    hence "(\<not>q \<longrightarrow> \<not>p) \<longrightarrow> p \<longrightarrow> r" by (rule impI) }
  thus "(q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> p \<longrightarrow> r)" by (rule impI)
qed

-- "La demostración hacia atrás es"
lemma ejemplo_11_2:
  "(q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r))"
proof (rule impI)
  assume 1: "q \<longrightarrow> r"
  show "(\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r)"
  proof (rule impI)
    assume 2: "\<not>q \<longrightarrow> \<not>p"
    show "p \<longrightarrow> r"
    proof (rule impI)
      assume 3: "p"
      have 4: "\<not>\<not>p" using 3 by (rule notnotI)
      have 5: "\<not>\<not>q" using 2 4 by (rule mt)
      have 6: "q" using 5 by (rule notnotD)
      show "r" using 1 6 by (rule mp)
    qed
  qed
qed

-- "La demostración hacia atrás con reglas implícitas es"
lemma ejemplo_11_3:
  "(q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r))"
proof
  assume 1: "q \<longrightarrow> r"
  show "(\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r)"
  proof
    assume 2: "\<not>q \<longrightarrow> \<not>p"
    show "p \<longrightarrow> r"
    proof
      assume 3: "p"
      have 4: "\<not>\<not>p" using 3 ..
      have 5: "\<not>\<not>q" using 2 4 by (rule mt)
      have 6: "q" using 5 by (rule notnotD)
      show "r" using 1 6 ..
    qed
  qed
qed

-- "La demostración sin etiquetas es"
lemma ejemplo_11_4:
  "(q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r))"
proof
  assume "q \<longrightarrow> r"
  show "(\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r)"
  proof
    assume "\<not>q \<longrightarrow> \<not>p"
    show "p \<longrightarrow> r"
    proof
      assume "p"
      hence "\<not>\<not>p" ..
      with `\<not>q \<longrightarrow> \<not>p` have "\<not>\<not>q" by (rule mt)
      hence "q" by (rule notnotD)
      with `q \<longrightarrow> r` show "r" ..
    qed
  qed
qed

-- "La demostración automática es"
lemma ejemplo_11_5:
  "(q \<longrightarrow> r) \<longrightarrow> ((\<not>q \<longrightarrow> \<not>p) \<longrightarrow> (p \<longrightarrow> r))"
by auto

subsection {* Reglas de la disyunción *}

text {*
  Las reglas de la introducción de la disyunción son
  · disjI1: P \<Longrightarrow> P \<or> Q
  · disjI2: Q \<Longrightarrow> P \<or> Q
  La regla de elimación de la disyunción es
  · disjE:  \<lbrakk>P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R
*}

text {*
  Ejemplo 12 (p. 11). Demostrar
     p \<or> q \<turnstile> q \<or> p
*}

-- "La demostración detallada es"
lemma ejemplo_12_1:
  assumes "p \<or> q"
  shows "q \<or> p"
proof -
  have "p \<or> q" using assms by this
  moreover
  { assume 2: "p"
    have "q \<or> p" using 2 by (rule disjI2) }
  moreover
  { assume 3: "q"
    have "q \<or> p" using 3 by (rule disjI1) }
  ultimately show "q \<or> p" by (rule disjE)
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "moreover" para separar los bloques y
  · "ultimately" para unir los resultados de los bloques. *}

-- "La demostración detallada con reglas implícitas es"
lemma ejemplo_12_2:
  assumes "p \<or> q"
  shows "q \<or> p"
proof -
  note `p \<or> q`
  moreover
  { assume "p"
    hence "q \<or> p" .. }
  moreover
  { assume "q"
    hence "q \<or> p" .. }
  ultimately show "q \<or> p" ..
qed

text {*
  Nota sobre el lenguaje: En la demostración anterior se ha usado
  · "note" para copiar un hecho. *}

-- "La demostración hacia atrás es"
lemma ejemplo_12_3:
  assumes 1: "p \<or> q"
  shows "q \<or> p"
using 1
proof (rule disjE)
  { assume 2: "p"
    show "q \<or> p" using 2 by (rule disjI2) }
next
  { assume 3: "q"
    show "q \<or> p" using 3 by (rule disjI1) }
qed

-- "La demostración hacia atrás con reglas implícitas es"
lemma ejemplo_12_4:
  assumes "p \<or> q"
  shows "q \<or> p"
using assms
proof
  { assume  "p"
    thus "q \<or> p" .. }
next
  { assume "q"
    thus "q \<or> p" .. }
qed

-- "La demostración automática es"
lemma ejemplo_12_5:
  assumes "p \<or> q"
  shows "q \<or> p"
using assms
by auto

text {*
  Ejemplo 13. (p. 12) Demostrar
     q \<longrightarrow> r \<turnstile> p \<or> q \<longrightarrow> p \<or> r
*}

-- "La demostración detallada es"
lemma ejemplo_13_1:
  assumes 1: "q \<longrightarrow> r"
  shows "p \<or> q \<longrightarrow> p \<or> r"
proof (rule impI)
  assume 2: "p \<or> q"
  thus "p \<or> r"
  proof
    { assume 3: "p"
      show "p \<or> r" using 3 by (rule disjI1) }
  next
    { assume 4: "q"
      have 5: "r" using 1 4 by (rule mp)
      show "p \<or> r" using 5 by (rule disjI2) }
  qed
qed

-- "La demostración estructurada es"
lemma ejemplo_13_2:
  assumes "q \<longrightarrow> r"
  shows "p \<or> q \<longrightarrow> p \<or> r"
proof
  assume "p \<or> q"
  thus "p \<or> r"
  proof
    assume "p"
    thus "p \<or> r" ..
  next
    assume 1:"q"
      have "r" using assms 1 ..
      thus "p \<or> r" ..
  qed
qed

-- "La demostración automática es"
lemma ejemplo_13_3:
  assumes "q \<longrightarrow> r"
  shows "p \<or> q \<longrightarrow> p \<or> r"
using assms
by auto

subsection {* Regla de copia *}

text {*
  Ejemplo 14 (p. 13). Demostrar
     \<turnstile> p \<longrightarrow> (q \<longrightarrow> p)
*}

-- "La demostración detallada es"
lemma ejemplo_14_1:
  "p \<longrightarrow> (q \<longrightarrow> p)"
proof (rule impI)
  assume 1: "p"
  show "q \<longrightarrow> p"
  proof (rule impI)
    assume "q"
    show "p" using 1 by this
  qed
qed

-- "La demostración estructurada es"
lemma ejemplo_14_2:
  "p \<longrightarrow> (q \<longrightarrow> p)"
proof
  assume "p"
  thus "q \<longrightarrow> p" ..
qed

-- "La demostración automática es"
lemma ejemplo_14_3:
  "p \<longrightarrow> (q \<longrightarrow> p)"
by auto

subsection {* Reglas de la negación *}

text {*
  La regla de eliminación de lo falso es
  · FalseE: False \<Longrightarrow> P
  La regla de eliminación de la negación es
  · notE: \<lbrakk>\<not>P; P\<rbrakk> \<Longrightarrow> R
  La regla de introducción de la negación es
  · notI: (P \<Longrightarrow> False) \<Longrightarrow> \<not>P
*}

text {*
  Ejemplo 15 (p. 15). Demostrar
     \<not>p \<or> q \<turnstile> p \<longrightarrow> q
*}

-- "La demostración detallada es"
lemma ejemplo_15_1:
  assumes 1: "\<not>p \<or> q"
  shows "p \<longrightarrow> q"
proof
  assume 2: "p"
  note 1
  thus "q"
  proof (* (rule disjE) *)
    assume 3: "\<not>p"
      show "q" using 3 2 by (rule notE)
   next
    assume 4: "q"
    show "q" using 4 by this
  qed
qed

-- "La demostración estructurada es"
lemma ejemplo_15_2:
  assumes "\<not>p \<or> q"
  shows "p \<longrightarrow> q"
proof
  assume "p"
  note `\<not>p \<or> q`
  thus "q"
  proof
    { assume "\<not>p"
      thus "q" using `p` .. }
  next
    { assume "q"
      thus "q" . }
  qed
qed

-- "La demostración automática es"
lemma ejemplo_15_3:
  assumes "\<not>p \<or> q"
  shows "p \<longrightarrow> q"
using assms
by auto

text {*
  Ejemplo 16 (p. 16). Demostrar
     p \<longrightarrow> q, p \<longrightarrow> \<not>q \<turnstile> \<not>p
*}

-- "La demostración detallada es"
lemma ejemplo_16_1:
  assumes 1: "p \<longrightarrow> q" and
          2: "p \<longrightarrow> \<not>q"
  shows "\<not>p"
proof (rule notI)
  assume 3: "p"
  have 4: "q" using 1 3 by (rule mp)
  have 5: "\<not>q" using 2 3 by (rule mp)
  show False using 5 4 by (rule notE)
qed

-- "La demostración estructurada es"
lemma ejemplo_16_2:
  assumes "p \<longrightarrow> q"
          "p \<longrightarrow> \<not>q"
  shows "\<not>p"
proof
  assume "p"
  have "q" using assms(1) `p` ..
  have "\<not>q" using assms(2) `p` ..
  thus False using `q` ..
qed

-- "La demostración automática es"
lemma ejemplo_16_3:
  assumes "p \<longrightarrow> q"
          "p \<longrightarrow> \<not>q"
  shows "\<not>p"
using assms
by auto

subsection {* Reglas del bicondicional *}

text {*
  La regla de introducción del bicondicional es
  · iffI: \<lbrakk>P \<Longrightarrow> Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q
  Las reglas de eliminación del bicondicional son
  · iffD1: \<lbrakk>Q \<longleftrightarrow> P; Q\<rbrakk> \<Longrightarrow> P
  · iffD2: \<lbrakk>P \<longleftrightarrow> Q; Q\<rbrakk> \<Longrightarrow> P
*}

text {*
  Ejemplo 17 (p. 17) Demostrar
*}

-- "La demostración detallada es"
lemma ejemplo_17_1:
  "(p \<and> q) \<longleftrightarrow> (q \<and> p)"
proof (rule iffI)
  { assume 1: "p \<and> q"
    have 2: "p" using 1 by (rule conjunct1)
    have 3: "q" using 1 by (rule conjunct2)
    show "q \<and> p" using 3 2 by (rule conjI) }
next
  { assume 4: "q \<and> p"
    have 5: "q" using 4 by (rule conjunct1)
    have 6: "p" using 4 by (rule conjunct2)
    show "p \<and> q" using 6 5 by (rule conjI) }
qed

-- "La demostración estructurada es"
lemma ejemplo_17_2:
  "(p \<and> q) \<longleftrightarrow> (q \<and> p)"
proof
  { assume 1: "p \<and> q"
    have "p" using 1 ..
    have "q" using 1 ..
    show "q \<and> p" using `q` `p` .. }
next
  { assume 2: "q \<and> p"
    have "q" using 2 ..
    have "p" using 2 ..
    show "p \<and> q" using `p` `q`  .. }
qed

-- "La demostración automática es"
lemma ejemplo_17_3:
  "(p \<and> q) \<longleftrightarrow> (q \<and> p)"
by auto

text {*
  Ejemplo 18 (p. 18). Demostrar
     p \<longleftrightarrow> q, p \<or> q \<turnstile> p \<and> q
*}

-- "La demostración detallada es"
lemma ejemplo_18_1:
  assumes 1: "p \<longleftrightarrow> q" and
          2: "p \<or> q"
  shows "p \<and> q"
using 2
proof (rule disjE)
  { assume 3: "p"
    have 4: "q" using 1 3 by (rule iffD1)
    show "p \<and> q" using 3 4 by (rule conjI) }
next
  { assume 5: "q"
    have 6: "p" using 1 5 by (rule iffD2)
    show "p \<and> q" using 6 5 by (rule conjI) }
qed

-- "La demostración estructurada es"
lemma ejemplo_18_2:
  assumes "p \<longleftrightarrow> q"
          "p \<or> q"
  shows  "p \<and> q"
using assms(2)
proof
  { assume "p"
    with assms(1) have "q" ..
    with `p` show "p \<and> q" .. }
next
  { assume "q"
    with assms(1) have "p" ..
    thus "p \<and> q" using `q` .. }
qed

-- "La demostración automática es"
lemma ejemplo_18_3:
  assumes "p \<longleftrightarrow> q"
          "p \<or> q"
  shows "p \<and> q"
using assms
by auto

subsection {* Reglas derivadas *}

subsubsection {* Regla del modus tollens *}

text {*
  Ejemplo 19 (p. 20) Demostrar la regla del modus tollens a partir de
  las reglas básicas.
*}

-- "La demostración detallada es"
lemma ejemplo_20_1:
  assumes 1: "F \<longrightarrow> G" and
          2: "\<not>G"
  shows "\<not>F"
proof (rule notI)
  assume 3: "F"
  have 4: "G" using 1 3 by (rule mp)
  show False using 2 4 by (rule notE)
qed

-- "La demostración estructurada es"
lemma ejemplo_20_2:
  assumes "F \<longrightarrow> G"
          "\<not>G"
  shows   "\<not>F"
proof
  assume "F"
  with assms(1) have "G" ..
  with assms(2) show False ..
qed

-- "La demostración automática es"
lemma ejemplo_20_3:
  assumes "F \<longrightarrow> G"
          "\<not>G"
  shows "\<not>F"
using assms
by auto

subsubsection {* Regla de la introducción de la doble negación *}

text {*
  Ejemplo 21 (p. 21) Demostrar la regla de introducción de la doble
  negación a partir de las reglas básicas.
*}

-- "La demostración detallada es"
lemma ejemplo_21_1:
  assumes 1: "F"
  shows "\<not>\<not>F"
proof (rule notI)
  assume 2: "\<not>F"
  show False using 2 1 by (rule notE)
qed

-- "La demostración estructurada es"
lemma ejemplo_21_2:
  assumes "F"
  shows "\<not>\<not>F"
proof
  assume "\<not>F"
  thus False using assms ..
qed

-- "La demostración automática es"
lemma ejemplo_21_3:
  assumes "F"
  shows "\<not>\<not>F"
using assms
by auto

subsubsection {* Regla de reducción al absurdo *}

text {*
  La regla de reducción al absurdo en Isabelle se correponde con la
  regla clásica de contradicción
  · ccontr: (\<not>P \<Longrightarrow> False) \<Longrightarrow> P
*}

subsubsection {* Ley del tercio excluso *}

text {*
  La ley del tercio excluso es
  · excluded_middle: \<not>P \<or> P
*}

text {*
  Ejemplo 22 (p. 23). Demostrar la ley del tercio excluso a partir de
  las reglas básicas.
*}

-- "La demostración detallada es"
lemma ejemplo_22_1:
  "F \<or> \<not>F"
proof (rule ccontr)
  assume 1: "\<not>(F \<or> \<not>F)"
  thus False
  proof (rule notE)
    show "F \<or> \<not>F"
    proof (rule disjI2)
      show "\<not>F"
      proof (rule notI)
        assume 2: "F"
        hence 3: "F \<or> \<not>F" by (rule disjI1)
        show False using 1 3 by (rule notE)
      qed
    qed
  qed
qed

-- "La demostración estructurada es"
lemma ejemplo_22_2:
  "F \<or> \<not>F"
proof (rule ccontr)
  assume "\<not>(F \<or> \<not>F)"
  thus False
  proof (rule notE)
    show "F \<or> \<not>F"
    proof (rule disjI2)
      show "\<not>F"
      proof (rule notI)
        assume "F"
        hence "F \<or> \<not>F" ..
        with `\<not>(F \<or> \<not>F)`show False ..
      qed
    qed
  qed
qed

-- "La demostración automática es"
lemma ejemplo_22_3:
  "F \<or> \<not>F"
using assms
by auto

text {*
  Ejemplo 23 (p. 24). Demostrar
     p \<longrightarrow> q \<turnstile> \<not>p \<or> q
*}

-- "La demostración detallada es"
lemma ejemplo_23_1:
  assumes 1: "p \<longrightarrow> q"
  shows "\<not>p \<or> q"
proof -
  have "\<not>p \<or> p" by (rule excluded_middle)
  thus "\<not>p \<or> q"
  proof (rule disjE)
    { assume "\<not>p"
      thus "\<not>p \<or> q" by (rule disjI1) }
  next
    { assume 2: "p"
      have "q" using 1 2 by (rule mp)
      thus "\<not>p \<or> q" by (rule disjI2) }
  qed
qed

-- "La demostración estructurada es"
lemma ejemplo_23_2:
  assumes "p \<longrightarrow> q"
  shows "\<not>p \<or> q"
proof -
  have "\<not>p \<or> p" ..
  thus "\<not>p \<or> q"
  proof
    { assume "\<not>p"
      thus "\<not>p \<or> q" .. }
  next
    { assume "p"
      with assms have "q" ..
      thus "\<not>p \<or> q" .. }
  qed
qed

-- "La demostración automática es"
lemma ejemplo_23_3:
  assumes "p \<longrightarrow> q"
  shows "\<not>p \<or> q"
using assms
by auto

subsection {* Demostraciones por contradicción *}

text {*
  Ejemplo 24. Demostrar que
     \<not>p, p \<or> q \<turnstile> q
*}

-- "La demostración detallada es"
lemma ejemplo_24_1:
  assumes "\<not>p"
          "p \<or> q"
  shows   "q"
using `p \<or> q`
proof (rule disjE)
  assume "p"
  with assms(1) show "q" by contradiction
next
  assume "q"
  thus "q" by assumption
qed

-- "La demostración estructurada es"
lemma ejemplo_24_2:
  assumes "\<not>p"
          "p \<or> q"
  shows "q"
using `p \<or> q`
proof
  assume "p"
  with assms(1) show "q" ..
next
  assume "q"
  thus "q" .
qed

-- "La demostración automática es"
lemma ejemplo_24_3:
  assumes "\<not>p"
          "p \<or> q"
  shows "q"
using assms
by auto

end


theory Algebra_Group_E1
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"subtype_def\", \"subtype_pred_def\", \"ga_assoc___Xx__\",
     \"ga_right_unit___Xx__\", \"ga_left_unit___Xx__\", \"inv_Group\",
     \"rinv_Group\"]"

typedecl Elem

consts
X__Xx__X :: "Elem => Elem => Elem" ("(_/ *''/ _)" [54,54] 52)
X_inv :: "Elem => Elem" ("inv''/'(_')" [3] 999)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)
e :: "Elem"

axioms
subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. P x --> x = injection (projection x))) &
  (ALL x. P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x *' e = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. e *' x = x"

inv_Group [rule_format] : "ALL x. inv'(x) *' x = e"

declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group [simp]

theorem rinv_Group : "ALL x. x *' inv'(x) = e"
  proof
    fix x
    have "x *' inv'(x) = (inv'(inv'(x)) *' inv'(x)) *' (x *' inv'(x))"
      by simp
    also have "\<dots> = inv'(inv'(x))  *' ((inv'(x) *' x) *' inv'(x))"
      by (simp only: ga_assoc___Xx__)
    also have "\<dots> = e" by simp
    finally show "x *' inv'(x) = e" by simp
  qed

ML "Header.record \"rinv_Group\""

end