theory SeCaV_Propositional_Solutions imports SeCaV_Propositional begin

section \<open>Exercise 1\<close>

proposition \<open>p \<and> q \<longrightarrow> p\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Con P Q) P
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con P Q),
      P
    ]
    \<close>
    using that by simp
  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Neg Q,
      P
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 2\<close>

proposition \<open>p \<and> q \<longrightarrow> q\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Con P Q) Q
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con P Q),
      Q
    ]
    \<close>
    using that by simp
  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Neg Q,
      Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 3\<close>

proposition \<open>(p \<longrightarrow> q) \<or> (q \<longrightarrow> r)\<close> by metis

lemma \<open>\<tturnstile>
  [
    Dis (Imp P Q) (Imp Q R)
  ]
  \<close>
proof -
  from AlphaDis have ?thesis if \<open>\<tturnstile>
    [
      Imp P Q,
      Imp Q R
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Q,
      Imp Q R
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp Q R,
      Q
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg Q,
      R,
      Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 4\<close>

proposition \<open>(p \<longrightarrow> q) \<longrightarrow> p \<longrightarrow> q\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Imp P Q) (Imp P Q)
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P Q),
      Imp P Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp P Q,
      Neg (Imp P Q)
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 5\<close>

proposition \<open>p \<longrightarrow> (p \<longrightarrow> q) \<longrightarrow> q\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp P (Imp (Imp P Q) Q)
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Imp (Imp P Q) Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp (Imp P Q) Q,
      Neg P
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P Q),
      Q,
      Neg P
    ]
    \<close>
    using that by simp
  with BetaImp have ?thesis if \<open>\<tturnstile>
    [
      P,
      Q,
      Neg P
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg Q,
      Q,
      Neg P
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P
    ]
    \<close> and \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 6\<close>

proposition \<open>p \<and> (p \<longrightarrow> q) \<longrightarrow> q\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Con P (Imp P Q)) Q
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con P (Imp P Q)),
      Q
    ]
    \<close>
    using that by simp
  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Neg (Imp P Q),
      Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P Q),
      Neg P,
      Q
    ]
    \<close>
    using that by simp
  with BetaImp have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P,
      Q
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg Q,
      Neg P,
      Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P
    ]
    \<close> and \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 7\<close>

proposition \<open>p \<longrightarrow> q \<longrightarrow> p\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp P (Imp Q P)
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Imp Q P
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp Q P,
      Neg P
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg Q,
      P,
      Neg P
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 8\<close>

proposition \<open>(p \<longrightarrow> q \<longrightarrow> r) \<longrightarrow> (p \<longrightarrow> q) \<longrightarrow> p \<longrightarrow> r\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Imp P (Imp Q R)) (Imp (Imp P Q) (Imp P R))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P (Imp Q R)),
      Imp (Imp P Q) (Imp P R)
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp (Imp P Q) (Imp P R),
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P Q),
      Imp P R,
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp P R,
      Neg (Imp P Q),
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      R,
      Neg (Imp P Q),
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P Q),
      Neg P,
      R,
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with BetaImp have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P,
      R,
      Neg (Imp P (Imp Q R))
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg Q,
      Neg P,
      R,
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with Basic have ?thesis if \<open>\<tturnstile>
    [
      Neg Q,
      Neg P,
      R,
      Neg (Imp P (Imp Q R))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp P (Imp Q R)),
      Neg P,
      Neg Q,
      R
    ]
    \<close>
    using that by simp
  with BetaImp have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P,
      Neg Q,
      R
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg (Imp Q R),
      Neg P,
      Neg Q,
      R
    ]
    \<close>
    using that by simp
  with Basic have ?thesis if \<open>\<tturnstile>
    [
      Neg (Imp Q R),
      Neg P,
      Neg Q,
      R
    ]
    \<close>
    using that by simp
  with BetaImp have ?thesis if \<open>\<tturnstile>
    [
      Q,
      Neg P,
      Neg Q,
      R
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg R,
      Neg P,
      Neg Q,
      R
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close> and \<open>\<tturnstile>
    [
      R,
      Neg R
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 9\<close>

proposition \<open>p \<or> q \<longrightarrow> q \<or> p\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Dis P Q) (Dis Q P)
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Dis P Q),
      Dis Q P
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Dis Q P,
      Neg (Dis P Q)
    ]
    \<close>
    using that by simp
  with AlphaDis have ?thesis if \<open>\<tturnstile>
    [
      Q,
      P,
      Neg (Dis P Q)
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Dis P Q),
      P,
      Q
    ]
    \<close>
    using that by simp
  with BetaDis have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      P,
      Q
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg Q,
      P,
      Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      P,
      Neg P
    ]
    \<close> and \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

end


(*  Title:      ZF/ex/misc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Composition of homomorphisms, Pastre's examples, ...
*)

section\<open>Miscellaneous ZF Examples\<close>

theory misc imports ZF begin

subsection\<open>Various Small Problems\<close>

text\<open>The singleton problems are much harder in HOL.\<close>
lemma singleton_example_1:
     "\<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  by blast

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  \<comment> \<open>Variant of the problem above.\<close>
  by blast

lemma "\<exists>!x. f (g(x)) = x \<Longrightarrow> \<exists>!y. g (f(y)) = y"
  \<comment> \<open>A unique fixpoint theorem --- \<open>fast\<close>/\<open>best\<close>/\<open>auto\<close> all fail.\<close>
  apply (erule ex1E, rule ex1I, erule subst_context)
  apply (rule subst, assumption, erule allE, rule subst_context, erule mp)
  apply (erule subst_context)
  done

text\<open>A weird property of ordered pairs.\<close>
lemma "b\<noteq>c \<Longrightarrow> \<langle>a,b\<rangle> \<inter> \<langle>a,c\<rangle> = \<langle>a,a\<rangle>"
by (simp add: Pair_def Int_cons_left Int_cons_right doubleton_eq_iff, blast)

text\<open>These two are cited in Benzmueller and Kohlhase's system description of
 LEO, CADE-15, 1998 (page 139-143) as theorems LEO could not prove.\<close>
lemma "(X = Y \<union> Z) \<longleftrightarrow> (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
by (blast intro!: equalityI)

text\<open>the dual of the previous one\<close>
lemma "(X = Y \<inter> Z) \<longleftrightarrow> (X \<subseteq> Y \<and> X \<subseteq> Z \<and> (\<forall>V. V \<subseteq> Y \<and> V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
by (blast intro!: equalityI)

text\<open>trivial example of term synthesis: apparently hard for some provers!\<close>
schematic_goal "a \<noteq> b \<Longrightarrow> a:?X \<and> b \<notin> ?X"
by blast

text\<open>Nice blast benchmark.  Proved in 0.3s; old tactics can't manage it!\<close>
lemma "\<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
by blast

text\<open>variant of the benchmark above\<close>
lemma "\<forall>x \<in> S. \<Union>(S) \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
by blast

(*Example 12 (credited to Peter Andrews) from
 W. Bledsoe.  A Maximal Method for Set Variables in Automatic Theorem-proving.
 In: J. Hayes and D. Michie and L. Mikulich, eds.  Machine Intelligence 9.
 Ellis Horwood, 53-100 (1979). *)
lemma "(\<forall>F. {x} \<in> F \<longrightarrow> {y} \<in> F) \<longrightarrow> (\<forall>A. x \<in> A \<longrightarrow> y \<in> A)"
by best

text\<open>A characterization of functions suggested by Tobias Nipkow\<close>
lemma "r \<in> domain(r)->B  \<longleftrightarrow>  r \<subseteq> domain(r)*B \<and> (\<forall>X. r `` (r -`` X) \<subseteq> X)"
by (unfold Pi_def function_def, best)

subsection\<open>Composition of homomorphisms is a Homomorphism\<close>

text\<open>Given as a challenge problem in
  R. Boyer et al.,
  Set Theory in First-Order Logic: Clauses for Gödel's Axioms,
  JAR 2 (1986), 287-327\<close>

text\<open>collecting the relevant lemmas\<close>
declare comp_fun [simp] SigmaI [simp] apply_funtype [simp]

(*Force helps prove conditions of rewrites such as comp_fun_apply, since
  rewriting does not instantiate Vars.*)
lemma "(\<forall>A f B g. hom(A,f,B,g) =
           {H \<in> A->B. f \<in> A*A->A \<and> g \<in> B*B->B \<and>
                     (\<forall>x \<in> A. \<forall>y \<in> A. H`(f`\<langle>x,y\<rangle>) = g`<H`x,H`y>)}) \<longrightarrow>
       J \<in> hom(A,f,B,g) \<and> K \<in> hom(B,g,C,h) \<longrightarrow>
       (K O J) \<in> hom(A,f,C,h)"
by force

text\<open>Another version, with meta-level rewriting\<close>
lemma "(\<And>A f B g. hom(A,f,B,g) \<equiv>
           {H \<in> A->B. f \<in> A*A->A \<and> g \<in> B*B->B \<and>
                     (\<forall>x \<in> A. \<forall>y \<in> A. H`(f`\<langle>x,y\<rangle>) = g`<H`x,H`y>)})
       \<Longrightarrow> J \<in> hom(A,f,B,g) \<and> K \<in> hom(B,g,C,h) \<longrightarrow> (K O J) \<in> hom(A,f,C,h)"
by force

subsection\<open>Pastre's Examples\<close>

text\<open>D Pastre.  Automatic theorem proving in set theory.
        Artificial Intelligence, 10:1--27, 1978.
Previously, these were done using ML code, but blast manages fine.\<close>

lemmas compIs [intro] = comp_surj comp_inj comp_fun [intro]
lemmas compDs [dest] =  comp_mem_injD1 comp_mem_surjD1
                        comp_mem_injD2 comp_mem_surjD2

lemma pastre1:
    "\<lbrakk>(h O g O f) \<in> inj(A,A);
        (f O h O g) \<in> surj(B,B);
        (g O f O h) \<in> surj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A\<rbrakk> \<Longrightarrow> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre3:
    "\<lbrakk>(h O g O f) \<in> surj(A,A);
        (f O h O g) \<in> surj(B,B);
        (g O f O h) \<in> inj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A\<rbrakk> \<Longrightarrow> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre4:
    "\<lbrakk>(h O g O f) \<in> surj(A,A);
        (f O h O g) \<in> inj(B,B);
        (g O f O h) \<in> inj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A\<rbrakk> \<Longrightarrow> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre5:
    "\<lbrakk>(h O g O f) \<in> inj(A,A);
        (f O h O g) \<in> surj(B,B);
        (g O f O h) \<in> inj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A\<rbrakk> \<Longrightarrow> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre6:
    "\<lbrakk>(h O g O f) \<in> inj(A,A);
        (f O h O g) \<in> inj(B,B);
        (g O f O h) \<in> surj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A\<rbrakk> \<Longrightarrow> h \<in> bij(C,A)"
by (unfold bij_def, blast)

end


theory SolverP2
  imports SolverP1b
begin

    (* phase 2: zero/non-zero solving *)

fun semi_sol_perm where
  "semi_sol_perm f_sub (SPerm p) = (if p = NoPerm then False else True)"
| "semi_sol_perm f_sub (SVar r) = f_sub r"

fun semi_sol_permx where
  "semi_sol_permx f_sub (XPerm p) = semi_sol_perm f_sub p"
| "semi_sol_permx f_sub (XType a) = False"
| "semi_sol_permx f_sub (XComp px qx) = (semi_sol_permx f_sub px \<or> semi_sol_permx f_sub qx)"
| "semi_sol_permx f_sub (XLift px q) = (semi_sol_permx f_sub px)"
| "semi_sol_permx f_sub (XIfZero px qx) = (semi_sol_permx f_sub px \<and> semi_sol_permx f_sub qx)"

fun semi_sol_crn2 where
  "semi_sol_crn2 f_sub (LeqCrn2 px q) = (semi_sol_permx f_sub px \<longrightarrow> semi_sol_perm f_sub q)"
| "semi_sol_crn2 f_sub (DisjCrn2 px qx) = True"
| "semi_sol_crn2 f_sub (MiniDisjCrn2 px qx) = True"

fun semi_sol_sat2 where
  "semi_sol_sat2 f_sub [] = True"
| "semi_sol_sat2 f_sub (c # c_t) = (semi_sol_crn2 f_sub c \<and> semi_sol_sat2 f_sub c_t)"

    (* - semi-sol correspondence *)

definition semi_sol_corr where
  "semi_sol_corr p_sub = (\<lambda> q. if p_sub q = NoPerm then False else True)"

    (* - semi-sol ordering / minimality *)

definition empty_semi_env where
  "empty_semi_env = (\<lambda> x. False)"

definition leq_semi_env where
  "leq_semi_env f_sub f_sub' = (\<forall> x. f_sub x \<longrightarrow> f_sub' x)"

definition min_semi_sol where
  "min_semi_sol f_sub c_list = (semi_sol_sat2 f_sub c_list \<and> (\<forall> f_sub'. semi_sol_sat2 f_sub' c_list \<longrightarrow> leq_semi_env f_sub f_sub'))"

    (* - semi-sol correspondence [left] *)

lemma corr_semi_sol_perm: "(eval_perm p_sub p \<noteq> NoPerm) = (semi_sol_perm (semi_sol_corr p_sub) p)"
  apply (case_tac p)
   apply (auto)
   apply (simp add: semi_sol_corr_def)
  apply (simp add: semi_sol_corr_def)
  done

lemma corr_semi_sol_permx: "(eval_permx p_sub p \<noteq> NoPerm) = (semi_sol_permx (semi_sol_corr p_sub) p)"
  apply (induct p)
      apply (auto)
       apply (simp add: corr_semi_sol_perm)
      apply (cut_tac p="x" in corr_semi_sol_perm)
      apply (auto)
     apply (case_tac "eval_permx p_sub p1")
       apply (auto)
     apply (case_tac "eval_permx p_sub p2")
       apply (auto)
    apply (case_tac "eval_permx p_sub p1")
      apply (auto)
    apply (case_tac "eval_permx p_sub p2")
      apply (auto)
   apply (case_tac "eval_permx p_sub p1")
     apply (auto)
  apply (case_tac "eval_permx p_sub p2")
    apply (auto)
  done

lemma corr_semi_sol_crn: "\<lbrakk> sol_sat_crn2 p_sub c \<rbrakk> \<Longrightarrow> semi_sol_crn2 (semi_sol_corr p_sub) c"
  apply (case_tac c)
   apply (auto)
  apply (cut_tac p="x12" in corr_semi_sol_perm)
   apply (auto)
  apply (case_tac "eval_permx p_sub x11")
    apply (auto)
  apply (cut_tac p="x11" in corr_semi_sol_permx)
   apply (auto)
  done

    (* if the constraints can be solved, they can be semi-solved *)
lemma corr_semi_sol: "\<lbrakk> sol_sat2 p_sub c_list \<rbrakk> \<Longrightarrow> semi_sol_sat2 (semi_sol_corr p_sub) c_list"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac corr_semi_sol_crn)
   apply (auto)
  done

    (* - minimal semi-solution existence *)

definition semi_sol_bound :: "('a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool" where
  "semi_sol_bound f_sub i = (\<exists> l. (\<forall> r. f_sub r \<longrightarrow> list_contain l r) \<and> length l = i)"

fun list_remove where
  "list_remove [] y = []"
| "list_remove (x # t) y = (if x = y then t else x # (list_remove t y))"

lemma remove_list_contain: "\<lbrakk> list_contain l x; x \<noteq> y \<rbrakk> \<Longrightarrow> list_contain (list_remove l y) x"
  apply (induct l)
   apply (auto)
  done

lemma remove_less_length: "\<lbrakk> list_contain l x \<rbrakk> \<Longrightarrow> length (list_remove l x) < length l"
  apply (induct l)
   apply (auto)
  done

lemma decr_semi_sol_bound: "\<lbrakk> semi_sol_bound f_sub i; leq_semi_env f_subx f_sub; f_subx \<noteq> f_sub \<rbrakk> \<Longrightarrow> (\<exists> j. semi_sol_bound f_subx j \<and> j < i)"
  apply (simp add: semi_sol_bound_def)
  apply (auto)
    (* if f_subx \<le> f_sub and f_subx \<noteq> f_sub, then there must be some r \<in> f_sub, r \<notin> f_subx *)
  apply (case_tac "\<forall> r. f_sub r \<longrightarrow> f_subx r")
   apply (simp add: leq_semi_env_def)
   apply (auto)
    (* we can remove this from l to construct a smaller list *)
  apply (rule_tac x="length (list_remove l r)" in exI)
  apply (auto)
   apply (rule_tac x="list_remove l r" in exI)
   apply (auto)
   apply (rule_tac remove_list_contain)
    apply (auto)
   apply (simp add: leq_semi_env_def)
  apply (rule_tac remove_less_length)
  apply (auto)
  done

fun all_var_perm where
  "all_var_perm (SPerm p) = []"
| "all_var_perm (SVar r) = [r]"

fun all_var_permx where
  "all_var_permx (XPerm p) = all_var_perm p"
| "all_var_permx (XType a) = []"
| "all_var_permx (XComp px qx) = all_var_permx px @ all_var_permx qx"
| "all_var_permx (XLift px q) = all_var_permx px @ all_var_perm q"
| "all_var_permx (XIfZero px qx) = all_var_permx px @ all_var_permx qx"

fun all_var_crn where
  "all_var_crn (LeqCrn2 px q) = all_var_permx px @ all_var_perm q"
| "all_var_crn (DisjCrn2 px qx) = all_var_permx px @ all_var_permx qx"
| "all_var_crn (MiniDisjCrn2 px qx) = all_var_permx px @ all_var_permx qx"

fun all_var_list where
  "all_var_list [] = []"
| "all_var_list (c # c_t) = all_var_crn c @ all_var_list c_t"

definition restr_semi_sol where
  "restr_semi_sol f_sub l = (\<lambda> r. if list_contain l r then f_sub r else False)"

lemma restr_semi_sol_perm: "\<lbrakk> semi_sol_perm f_sub p; sub_list (all_var_perm p) r_list \<rbrakk> \<Longrightarrow>
  semi_sol_perm (restr_semi_sol f_sub r_list) p"
  apply (case_tac p)
   apply (auto)
  apply (simp add: restr_semi_sol_def)
  apply (simp add: sub_list_def)
  done

lemma restr_semi_sol_perm_rev: "\<lbrakk> semi_sol_perm (restr_semi_sol f_sub r_list) p;
  sub_list (all_var_perm p) r_list \<rbrakk> \<Longrightarrow> semi_sol_perm f_sub p"
  apply (case_tac p)
   apply (auto)
  apply (simp add: restr_semi_sol_def)
  apply (simp add: sub_list_def)
  done

lemma restr_semi_sol_permx: "\<lbrakk> semi_sol_permx f_sub px; sub_list (all_var_permx px) r_list \<rbrakk> \<Longrightarrow>
  semi_sol_permx (restr_semi_sol f_sub r_list) px"
  apply (induct px)
     apply (auto)
       apply (rule_tac restr_semi_sol_perm)
        apply (auto)
      apply (cut_tac ?l1.0="all_var_permx px1" and lx="r_list" in append_sub_list1)
       apply (auto)
     apply (cut_tac ?l2.0="all_var_permx px2" and lx="r_list" in append_sub_list2)
      apply (auto)
    apply (cut_tac ?l1.0="all_var_permx px" and lx="r_list" in append_sub_list1)
     apply (auto)
   apply (cut_tac ?l1.0="all_var_permx px1" and lx="r_list" in append_sub_list1)
    apply (auto)
  apply (cut_tac ?l2.0="all_var_permx px2" and lx="r_list" in append_sub_list2)
   apply (auto)
  done

lemma restr_semi_sol_permx_rev: "\<lbrakk> semi_sol_permx (restr_semi_sol f_sub r_list) px;
  sub_list (all_var_permx px) r_list \<rbrakk> \<Longrightarrow> semi_sol_permx f_sub px"
  apply (induct px)
     apply (auto)
       apply (rule_tac restr_semi_sol_perm_rev)
        apply (auto)
      apply (cut_tac ?l1.0="all_var_permx px1" and lx="r_list" in append_sub_list1)
       apply (auto)
     apply (cut_tac ?l2.0="all_var_permx px2" and lx="r_list" in append_sub_list2)
      apply (auto)
    apply (cut_tac ?l1.0="all_var_permx px" and lx="r_list" in append_sub_list1)
     apply (auto)
   apply (cut_tac ?l1.0="all_var_permx px1" and lx="r_list" in append_sub_list1)
    apply (auto)
  apply (cut_tac ?l2.0="all_var_permx px2" and lx="r_list" in append_sub_list2)
   apply (auto)
  done

lemma restr_semi_sol_crn: "\<lbrakk> semi_sol_crn2 f_sub c; sub_list (all_var_crn c) r_list \<rbrakk> \<Longrightarrow>
  semi_sol_crn2 (restr_semi_sol f_sub r_list) c"
  apply (case_tac c)
   apply (auto)
   apply (cut_tac f_sub="f_sub" and px="x11" in restr_semi_sol_permx_rev)
     apply (auto)
   apply (rule_tac append_sub_list1)
   apply (auto)
  apply (cut_tac f_sub="f_sub" and p="x12" in restr_semi_sol_perm)
    apply (auto)
  apply (rule_tac append_sub_list2)
  apply (auto)
  done

lemma restr_semi_sol_sat_ih: "\<lbrakk> semi_sol_sat2 f_sub c_list; sub_list (all_var_list c_list) r_list \<rbrakk> \<Longrightarrow>
  semi_sol_sat2 (restr_semi_sol f_sub r_list) c_list"
  apply (induct c_list)
   apply (auto)
   apply (rule_tac restr_semi_sol_crn)
    apply (simp)
   apply (rule_tac append_sub_list1)
   apply (auto)
  apply (cut_tac ?l2.0="all_var_list c_list" and lx="r_list" in append_sub_list2)
   apply (auto)
  done

lemma restr_semi_sol_sat: "\<lbrakk> semi_sol_sat2 f_sub c_list\<rbrakk> \<Longrightarrow>
  semi_sol_sat2 (restr_semi_sol f_sub (all_var_list c_list)) c_list"
  apply (rule_tac restr_semi_sol_sat_ih)
    apply (auto)
  apply (rule_tac id_sub_list)
  done

lemma finite_semi_sol_exists: "\<lbrakk> semi_sol_sat2 f_sub c_list \<rbrakk> \<Longrightarrow> (\<exists> f_sub' i. semi_sol_sat2 f_sub' c_list \<and> semi_sol_bound f_sub' i)"
  apply (rule_tac x="restr_semi_sol f_sub (all_var_list c_list)" in exI)
  apply (rule_tac x="length (all_var_list c_list)" in exI)
  apply (auto)
   apply (rule_tac restr_semi_sol_sat)
   apply (simp)
  apply (simp add: semi_sol_bound_def)
  apply (rule_tac x="all_var_list c_list" in exI)
  apply (auto)
  apply (simp add: restr_semi_sol_def)
  apply (case_tac "list_contain (all_var_list c_list) r")
   apply (auto)
  done

lemma lmsse_ih: "\<lbrakk> semi_sol_sat2 f_sub c_list; semi_sol_bound f_sub i \<rbrakk> \<Longrightarrow> (\<exists> f_sub' j. semi_sol_sat2 f_sub' c_list \<and>
  semi_sol_bound f_sub' j \<and> (\<forall> f_subx. (semi_sol_sat2 f_subx c_list \<and> f_subx \<noteq> f_sub') \<longrightarrow> \<not> leq_semi_env f_subx f_sub'))"
  apply (induct i arbitrary: f_sub rule: less_induct)
    (* say that f_sub has no lesser semi-solution. then f_sub itself can be used *)
  apply (case_tac "\<forall> f_subx. (semi_sol_sat2 f_subx c_list \<and> f_subx \<noteq> f_sub) \<longrightarrow> \<not> leq_semi_env f_subx f_sub")
   apply (rule_tac x="f_sub" in exI)
   apply (auto)
    (* otherwise, there exists some lesser f_subx semi-solution. in this case, the bound must be less *)
  apply (cut_tac f_sub="f_sub" and i="x" and f_subx="f_subx" in decr_semi_sol_bound)
     apply (auto)
  done

lemma local_min_semi_sol_exists: "\<lbrakk> semi_sol_sat2 f_sub c_list \<rbrakk> \<Longrightarrow> (\<exists> f_sub' i.  semi_sol_sat2 f_sub' c_list \<and>
  (\<forall> f_subx. (semi_sol_sat2 f_subx c_list \<and> f_subx \<noteq> f_sub') \<longrightarrow> \<not> leq_semi_env f_subx f_sub'))"
    (* from f_sub, we derive finite semi-solution f_sub' *)
  apply (cut_tac c_list="c_list" in finite_semi_sol_exists)
   apply (auto)
    (* from the induction, we know that f_sub' can obtain a local minima f_sub'a *)
  apply (cut_tac f_sub="f_sub'" and i="i" and c_list="c_list" in lmsse_ih)
    apply (auto)
  done

definition inter_semi_sol where
  "inter_semi_sol f_sub f_sub' = (\<lambda> r. f_sub r \<and> f_sub' r)"

lemma inter_semi_sol_perm1: "\<lbrakk> semi_sol_perm (inter_semi_sol f_sub f_subx) p \<rbrakk> \<Longrightarrow> semi_sol_perm f_sub p"
  apply (case_tac p)
   apply (auto)
  apply (simp add: inter_semi_sol_def)
  done

lemma inter_semi_sol_perm2: "\<lbrakk> semi_sol_perm (inter_semi_sol f_sub f_subx) p \<rbrakk> \<Longrightarrow> semi_sol_perm f_subx p"
  apply (case_tac p)
   apply (auto)
  apply (simp add: inter_semi_sol_def)
  done

lemma inter_semi_sol_permx1: "\<lbrakk> semi_sol_permx (inter_semi_sol f_sub f_subx) p \<rbrakk> \<Longrightarrow> semi_sol_permx f_sub p"
  apply (induct p)
      apply (auto)
  apply (rule_tac inter_semi_sol_perm1)
  apply (simp)
  done

lemma inter_semi_sol_permx2: "\<lbrakk> semi_sol_permx (inter_semi_sol f_sub f_subx) p \<rbrakk> \<Longrightarrow> semi_sol_permx f_subx p"
  apply (induct p)
     apply (auto)
  apply (rule_tac inter_semi_sol_perm2)
  apply (simp)
  done

lemma inter_semi_sol_crn: "\<lbrakk> semi_sol_crn2 f_sub c; semi_sol_crn2 f_subx c \<rbrakk> \<Longrightarrow> semi_sol_crn2 (inter_semi_sol f_sub f_subx) c"
  apply (case_tac c)
   apply (auto)
     apply (cut_tac inter_semi_sol_permx1)
      apply (auto)
    apply (cut_tac inter_semi_sol_permx1)
     apply (auto)
   apply (cut_tac inter_semi_sol_permx2)
    apply (auto)
  apply (case_tac x12)
   apply (auto)
  apply (simp add: inter_semi_sol_def)
  done

lemma inter_semi_sol_sat: "\<lbrakk> semi_sol_sat2 f_sub c_list; semi_sol_sat2 f_subx c_list \<rbrakk> \<Longrightarrow> semi_sol_sat2 (inter_semi_sol f_sub f_subx) c_list"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac inter_semi_sol_crn)
   apply (auto)
  done

lemma eq_leq_semi_env: "\<lbrakk> \<forall> x. inter_semi_sol f_sub f_subx x = f_sub x \<rbrakk> \<Longrightarrow> leq_semi_env f_sub f_subx"
  apply (simp add: leq_semi_env_def)
  apply (auto)
  apply (simp add: inter_semi_sol_def)
  apply (erule_tac x="x" in allE)
  apply (auto)
  done

lemma inter_leq_semi_env1: "\<lbrakk> leq_semi_env f_sub f_subx \<rbrakk> \<Longrightarrow> leq_semi_env (inter_semi_sol f_sub f_sub') f_subx"
  apply (simp add: leq_semi_env_def)
  apply (simp add: inter_semi_sol_def)
  done

lemma inter_leq_semi_env2: "\<lbrakk> leq_semi_env f_sub' f_subx \<rbrakk> \<Longrightarrow> leq_semi_env (inter_semi_sol f_sub f_sub') f_subx"
  apply (simp add: leq_semi_env_def)
  apply (simp add: inter_semi_sol_def)
  done

lemma min_semi_sol_exists: "\<lbrakk> semi_sol_sat2 f_sub c_list \<rbrakk> \<Longrightarrow> (\<exists> m_sub. min_semi_sol m_sub c_list)"
    (* if we have a semi-solution, we should be able to find a semi-solution that has no solution lesser than it. *)
  apply (cut_tac f_sub="f_sub" and c_list="c_list" in local_min_semi_sol_exists)
   apply (auto)
    (* if every semi-solution is lesser, then it counts as a min *)
  apply (case_tac "\<forall> f_subx. \<not> semi_sol_sat2 f_subx c_list \<or> leq_semi_env f_sub' f_subx")
   apply (rule_tac x="f_sub'" in exI)
   apply (simp add: min_semi_sol_def)
  apply (auto)
    (* otherwise we have two "sibling" semi-solutions. we argue combining them creates a new semi-solution. *)
  apply (erule_tac x="inter_semi_sol f_sub' f_subx" in allE)
  apply (auto)
    apply (rule_tac inter_semi_sol_sat)
     apply (auto)
    (* the combination cannot be equal to f_sub', since then f_sub' \<le> f_subx *)
   apply (cut_tac f_sub="f_sub'" and f_subx="f_subx" in  eq_leq_semi_env)
    apply (auto)
    (* however this is a lesser solution, which is a contradiction *)
  apply (cut_tac f_sub="f_sub'" and f_subx="f_sub'" in inter_leq_semi_env1)
   apply (auto)
  apply (simp add: leq_semi_env_def)
  done

    (* min semi-sol algorithm *)

fun non_zero_perm where
  "non_zero_perm (SVar r) = False"
| "non_zero_perm (SPerm p) = (p \<noteq> NoPerm)"

fun non_zero_permx where
  "non_zero_permx (XPerm p) = non_zero_perm p"
| "non_zero_permx (XType a) = False"
| "non_zero_permx (XComp p q) = ((non_zero_permx p) \<or> (non_zero_permx q))"
| "non_zero_permx (XLift p q) = (non_zero_permx p)"
| "non_zero_permx (XIfZero px q) = ((non_zero_permx px) \<and> (non_zero_permx q))"

fun concrete_crn where
  "concrete_crn (LeqCrn2 px q) = non_zero_permx px"
| "concrete_crn (DisjCrn2 px qx) = False"
| "concrete_crn (MiniDisjCrn2 px qx) = False"

fun conc_crn_total :: "perm_crn2 list \<Rightarrow> nat" where
  "conc_crn_total [] = 0"
| "conc_crn_total (c # c_t) = (conc_crn_total c_t + (if concrete_crn c then 1 else 0))"

fun select_list where
  "select_list f [] = None"
| "select_list f (c # c_t) = (if f c then Some (c, c_t) else (case select_list f c_t of
    None \<Rightarrow> None
    | Some (cx, c_tx) \<Rightarrow> Some (cx, c # c_tx)
  ))"

lemma select_less_length: "\<lbrakk> select_list f c_l = Some (c, c_t) \<rbrakk> \<Longrightarrow> length c_t < length c_l"
  apply (induct c_l arbitrary: c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_l")
   apply (auto)
  done

fun sub1_perm where
  "sub1_perm (SPerm p) r = SPerm p"
| "sub1_perm (SVar r') r = (if r' = r then SPerm OwnPerm else SVar r')"

fun sub1_permx where
  "sub1_permx (XPerm p) r = XPerm (sub1_perm p r)"
| "sub1_permx (XType a) r = XType a"
| "sub1_permx (XComp px qx) r = XComp (sub1_permx px r) (sub1_permx qx r)"
| "sub1_permx (XLift px q) r = XLift (sub1_permx px r) (sub1_perm q r)"
| "sub1_permx (XIfZero px qx) r = XIfZero (sub1_permx px r) (sub1_permx qx r)"

fun sub1_crn where
  "sub1_crn (LeqCrn2 px q) r = LeqCrn2 (sub1_permx px r) (sub1_perm q r)"
| "sub1_crn (DisjCrn2 px qx) r = DisjCrn2 (sub1_permx px r) (sub1_permx qx r)"
| "sub1_crn (MiniDisjCrn2 px qx) r = MiniDisjCrn2 (sub1_permx px r) (sub1_permx qx r)"

fun sub1_crn_list where
  "sub1_crn_list [] r = []"
| "sub1_crn_list (c # c_t) r = sub1_crn c r # sub1_crn_list c_t r"

lemma sub1_same_length: "length c_list = length (sub1_crn_list c_list r)"
  apply (induct c_list)
   apply (auto)
  done

    (* takes a constraint list and returns the "minimum" semi-solution *)

function min_semi_sol_calc_f where
  "min_semi_sol_calc_f c_list = (case select_list concrete_crn c_list of
    None \<Rightarrow> Some empty_semi_env
    | Some (c, c_t) \<Rightarrow> (case c of
      LeqCrn2 px q \<Rightarrow> (case q of
        SPerm p \<Rightarrow> if p = NoPerm then None else min_semi_sol_calc_f c_t
        | SVar r \<Rightarrow> (case min_semi_sol_calc_f (sub1_crn_list c_t r) of
          None \<Rightarrow> None
          | Some f_sub \<Rightarrow> Some (\<lambda> r'. if r' = r then True else f_sub r')
        )
      )
      | other \<Rightarrow> None
    )
  )" by auto
termination
  apply (relation "measure length")
   apply (auto)
   apply (rule_tac select_less_length)
   apply (auto)
  apply (rule_tac t="length (sub1_crn_list b x2a)" and s="length b" in subst)
   apply (rule_tac sub1_same_length)
  apply (rule_tac select_less_length)
  apply (auto)
  done

definition min_semi_sol_calc where
  "min_semi_sol_calc c_list = min_semi_sol_calc_f c_list"

lemma select_cond_sat: "\<lbrakk> select_list f c_list = Some (c, c_t) \<rbrakk> \<Longrightarrow> f c"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

lemma select_semi_sol_crn: "\<lbrakk> semi_sol_sat2 f_sub c_list; select_list f c_list = Some (c, c_t) \<rbrakk> \<Longrightarrow> semi_sol_crn2 f_sub c"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

lemma select_semi_sol: "\<lbrakk> semi_sol_sat2 f_sub c_list; select_list f c_list = Some (c, c_t) \<rbrakk> \<Longrightarrow> semi_sol_sat2 f_sub c_t"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

lemma nz_semi_sol_perm: "\<lbrakk> non_zero_perm p \<rbrakk> \<Longrightarrow> semi_sol_perm f_sub p"
  apply (case_tac p)
   apply (auto)
  done

lemma nz_semi_sol_permx: "\<lbrakk> non_zero_permx p \<rbrakk> \<Longrightarrow> semi_sol_permx f_sub p"
  apply (induct p)
     apply (auto)
  apply (rule_tac nz_semi_sol_perm)
  apply (simp)
  done

lemma zero_semi_sol_perm: "\<lbrakk> \<not> non_zero_perm p \<rbrakk> \<Longrightarrow> \<not> semi_sol_perm empty_semi_env p"
  apply (simp add: empty_semi_env_def)
  apply (case_tac p)
   apply (auto)
  done

lemma zero_semi_sol_permx: "\<lbrakk> \<not> non_zero_permx p \<rbrakk> \<Longrightarrow> \<not> semi_sol_permx empty_semi_env p"
  apply (induct p)
      apply (auto)
  apply (simp add: zero_semi_sol_perm)
  done

lemma sub1_semi_sol_perm: "\<lbrakk> f_sub x \<rbrakk> \<Longrightarrow> semi_sol_perm f_sub p = semi_sol_perm f_sub (sub1_perm p x)"
  apply (case_tac p)
   apply (auto)
  done

lemma sub1_semi_sol_permx: "\<lbrakk> f_sub x \<rbrakk> \<Longrightarrow> semi_sol_permx f_sub px = semi_sol_permx f_sub (sub1_permx px x)"
  apply (induct px)
      apply (auto)
   apply (cut_tac f_sub="f_sub" and p="xa" in sub1_semi_sol_perm)
    apply (auto)
  apply (cut_tac f_sub="f_sub" and p="xa" in sub1_semi_sol_perm)
   apply (auto)
  done

lemma sub1_semi_sol_crn: "\<lbrakk> semi_sol_crn2 f_sub c; f_sub x \<rbrakk> \<Longrightarrow> semi_sol_crn2 f_sub (sub1_crn c x)"
  apply (case_tac c)
   apply (auto)
   apply (cut_tac f_sub="f_sub" and px="x11" in sub1_semi_sol_permx)
    apply (auto)
  apply (cut_tac f_sub="f_sub" and p="x12" in sub1_semi_sol_perm)
   apply (auto)
  done

lemma sub1_semi_sol_sat: "\<lbrakk> semi_sol_sat2 f_sub c_list; f_sub x \<rbrakk> \<Longrightarrow> semi_sol_sat2 f_sub (sub1_crn_list c_list x)"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac sub1_semi_sol_crn)
   apply (auto)
  done

lemma msscu_ih: "\<lbrakk> \<And>c_lista. \<lbrakk>length c_lista < length c_list; min_semi_sol_calc c_lista = None\<rbrakk> \<Longrightarrow> \<not> semi_sol_sat2 f_sub c_lista;
  length c_lista < length c_list; min_semi_sol_calc c_lista = None \<rbrakk> \<Longrightarrow> \<not> semi_sol_sat2 f_sub c_lista"
  apply (auto)
  done

    (* we want to prove two things. first - if mini semi-solution returns a semi-solution, it is actually the minimal semi-solution.
      second - if mini semi-solution does not return a semi-solution, there is no solution. *)

lemma min_semi_sol_calc_unsat: "\<lbrakk> min_semi_sol_calc c_list = None \<rbrakk> \<Longrightarrow>  \<not> semi_sol_sat2 f_sub c_list"
  apply (induct "length c_list" arbitrary: c_list rule: less_induct)
  apply (auto)
    (* unroll algorithm definition *)
  apply (case_tac "\<not> (case select_list concrete_crn c_list of None \<Rightarrow> Some empty_semi_env
         | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = NoPerm then None else min_semi_sol_calc_f c_t
         | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
             (case min_semi_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some f_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then True else f_sub r'))
         | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x) =
        None")
   apply (simp add: min_semi_sol_calc_def)
  apply (auto)
    (* attempt to select from list *)
  apply (case_tac "select_list concrete_crn c_list")
   apply (auto)
  apply (case_tac a)
    apply (auto)
    apply (case_tac x12)
     apply (auto)
    (* inequality over permission constant. case where p = 0 *)
    apply (case_tac "x1 = NoPerm")
      apply (auto)
      apply (cut_tac f_sub="f_sub" and c="LeqCrn2 x11 (SPerm NoPerm)" in select_semi_sol_crn)
        apply (auto)
      apply (cut_tac f="concrete_crn" and c="LeqCrn2 x11 (SPerm NoPerm)" in select_cond_sat)
       apply (auto)
      apply (cut_tac f_sub="f_sub" and p="x11" in nz_semi_sol_permx)
       apply (auto)
    (* - inductive case where p \<noteq> 0 *)
     apply (cut_tac c_lista="b" and c_list="c_list" in msscu_ih)
        apply (auto)
       apply (rule_tac select_less_length)
       apply (simp)
      apply (simp add: min_semi_sol_calc_def)
     apply (cut_tac c_list="c_list" and c_t="b" in select_semi_sol)
       apply (auto)
    (* inequality over permission var *)
    apply (cut_tac c_lista="sub1_crn_list b x2" and c_list="c_list" in msscu_ih)
       apply (auto)
      apply (rule_tac t="length (sub1_crn_list b x2)" and s="length b" in subst)
       apply (rule_tac sub1_same_length)
      apply (rule_tac select_less_length)
      apply (simp)
     apply (case_tac "case select_list concrete_crn (sub1_crn_list b x2) of None \<Rightarrow> Some empty_semi_env
              | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = NoPerm then None else min_semi_sol_calc_f c_t
              | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
                  (case min_semi_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some f_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then True else f_sub r'))
              | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x")
      apply (auto)
     apply (simp add: min_semi_sol_calc_def)
    (* if the constraints are solvable, then the solution assigns either 1 or 0 to r. we know an assignment of 0 will fail. an assignment of 1
        means sub1_crn_list should be solvable, a contradiction *)
    apply (case_tac "f_sub x2")
     apply (cut_tac c_list="b" and f_sub="f_sub" and x="x2" in sub1_semi_sol_sat)
       apply (rule_tac select_semi_sol)
        apply (auto)
    apply (cut_tac f_sub="f_sub" and c="LeqCrn2 x11 (SVar x2)" in select_semi_sol_crn)
      apply (auto)
    apply (cut_tac f="concrete_crn" and c="LeqCrn2 x11 (SVar x2)" in select_cond_sat)
     apply (auto)
    apply (cut_tac f_sub="f_sub" and p="x11" in nz_semi_sol_permx)
     apply (auto)
    (* disjointness cases, should never happen *)
   apply (cut_tac f="concrete_crn" and c="DisjCrn2 x21 x22" in select_cond_sat)
    apply (auto)
  apply (cut_tac f="concrete_crn" and c="MiniDisjCrn2 x31 x32" in select_cond_sat)
   apply (auto)
  done

lemma step2_solve_end: "\<lbrakk> select_list concrete_crn c_list = None \<rbrakk> \<Longrightarrow> semi_sol_sat2 empty_semi_env c_list"
  apply (induct c_list)
   apply (auto)
    (* prove constraint is valid *)
   apply (case_tac "concrete_crn a")
    apply (auto)
   apply (case_tac a)
     apply (auto)
   apply (cut_tac p="x11" in zero_semi_sol_permx)
    apply (auto)
    (* induction *)
  apply (case_tac "concrete_crn a")
   apply (auto)
  apply (case_tac "select_list concrete_crn c_list")
   apply (auto)
  done

lemma select_semi_sol_split: "\<lbrakk> select_list f c_list = Some (c, c_t); semi_sol_crn2 f_sub c;
  semi_sol_sat2 f_sub c_t \<rbrakk> \<Longrightarrow> semi_sol_sat2 f_sub c_list"
  apply (induct c_list arbitrary: c_t)
   apply (auto)
   apply (case_tac "f a")
    apply (auto)
   apply (case_tac "select_list f c_list")
    apply (auto)
  apply (case_tac "f a")
   apply (auto)
  apply (case_tac "select_list f c_list")
   apply (auto)
  done

lemma step2_solve_iter_c1: "\<lbrakk> select_list concrete_crn c_list = Some (LeqCrn2 px (SPerm p), c_t); p \<noteq> NoPerm;
  min_semi_sol f_sub c_t \<rbrakk> \<Longrightarrow> min_semi_sol f_sub c_list"
  apply (simp add: min_semi_sol_def)
  apply (auto)
   apply (rule_tac c="LeqCrn2 px (SPerm p)" in select_semi_sol_split)
     apply (auto)
    (* the main thing is to prove that f_sub is still minimal. say that there is some lesser f_sub'. then it must solve c_list' *)
  apply (cut_tac f_sub="f_sub'" and c_list="c_list" and c_t="c_t" in select_semi_sol)
    apply (auto)
  done

lemma add_semi_sol_perm: "\<lbrakk> semi_sol_perm f_sub (sub1_perm p r) \<rbrakk> \<Longrightarrow> semi_sol_perm (\<lambda>r'. r' \<noteq> r \<longrightarrow> f_sub r') p"
  apply (case_tac p)
   apply (auto)
  done

lemma add_semi_sol_permx_rev: "\<lbrakk> semi_sol_permx (\<lambda>r'. r' \<noteq> r \<longrightarrow> f_sub r') px \<rbrakk> \<Longrightarrow> semi_sol_permx f_sub (sub1_permx px r)"
  apply (induct px)
      apply (auto)
  apply (case_tac x)
   apply (auto)
  done

lemma add_semi_sol_crn: "\<lbrakk> semi_sol_crn2 f_sub (sub1_crn c r) \<rbrakk> \<Longrightarrow> semi_sol_crn2 (\<lambda>r'. r' \<noteq> r \<longrightarrow> f_sub r') c"
  apply (case_tac c)
    apply (auto)
   apply (cut_tac px="x11" and r="r" and f_sub="f_sub" in add_semi_sol_permx_rev)
    apply (auto)
  apply (rule_tac add_semi_sol_perm)
  apply (auto)
  done

lemma add_semi_sol: "\<lbrakk> semi_sol_sat2 f_sub (sub1_crn_list c_list r) \<rbrakk> \<Longrightarrow> semi_sol_sat2 (\<lambda>r'. r' \<noteq> r \<longrightarrow> f_sub r') c_list"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac add_semi_sol_crn)
  apply (auto)
  done

lemma add_leq_semi_env: "\<lbrakk> leq_semi_env f_sub f_subx; f_subx r \<rbrakk> \<Longrightarrow> leq_semi_env (\<lambda>r'. r' \<noteq> r \<longrightarrow> f_sub r') f_subx"
  apply (simp add: leq_semi_env_def)
  apply (auto)
  done

lemma step2_solve_iter_c2: "\<lbrakk> select_list concrete_crn c_list = Some (LeqCrn2 px (SVar r), c_t);
  min_semi_sol f_sub (sub1_crn_list c_t r) \<rbrakk> \<Longrightarrow> min_semi_sol (\<lambda>r'. r' \<noteq> r \<longrightarrow> f_sub r') c_list"
  apply (simp add: min_semi_sol_def)
  apply (auto)
    (* first we must prove that the new substitution solves *)
   apply (rule_tac c="LeqCrn2 px (SVar r)" in select_semi_sol_split)
     apply (auto)
   apply (rule_tac add_semi_sol)
   apply (auto)
    (* next we must prove that it is minimal. say that there is some lesser f_sub'. first we must have f_sub' r *)
  apply (case_tac "\<not> f_sub' r")
   apply (cut_tac f_sub="f_sub'" and c="LeqCrn2 px (SVar r)" in select_semi_sol_crn)
     apply (auto)
   apply (cut_tac c="LeqCrn2 px (SVar r)" and f="concrete_crn" in select_cond_sat)
    apply (auto)
   apply (cut_tac f_sub="f_sub'" and p="px" in nz_semi_sol_permx)
    apply (auto)
    (* we also know f_sub' must solve c_t. with these two facts combined, we have f_sub' solves c_t with r = 1  *)
  apply (cut_tac f_sub="f_sub'" and c_list="c_list" and c_t="c_t" in select_semi_sol)
    apply (auto)
  apply (cut_tac f_sub="f_sub'" and c_list="c_t" and x="r" in sub1_semi_sol_sat)
    apply (auto)
    (* this gives f_sub \<le> f_sub', which combined with f_sub' r gives us what we want *)
  apply (erule_tac x="f_sub'" in allE)
  apply (auto)
  apply (rule_tac add_leq_semi_env)
   apply (auto)
  done

lemma empty_leq_semi_env: "leq_semi_env empty_semi_env f_sub"
  apply (simp add: leq_semi_env_def)
  apply (simp add: empty_semi_env_def)
  done

lemma min_semi_sol_calc_sat: "\<lbrakk> min_semi_sol_calc c_list = Some f_sub \<rbrakk> \<Longrightarrow> min_semi_sol f_sub c_list"
  apply (induct "length c_list" arbitrary: c_list f_sub rule: less_induct)
    apply (case_tac "\<not> (case select_list concrete_crn c_list of None \<Rightarrow> Some empty_semi_env
         | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = NoPerm then None else min_semi_sol_calc_f c_t
         | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
             (case min_semi_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some f_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then True else f_sub r'))
         | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x) =
        Some f_sub")
   apply (simp add: min_semi_sol_calc_def)
  apply (auto)
  apply (case_tac "select_list concrete_crn c_list")
   apply (auto)
    (* base case *)
    apply (simp add: min_semi_sol_def)
   apply (auto)
    apply (rule_tac step2_solve_end)
    apply (auto)
   apply (rule_tac empty_leq_semi_env)
    (* case analysis over constraint *)
  apply (case_tac a)
    apply (auto)
  apply (case_tac x12)
   apply (auto)
    (* - inequality constraint. permission case *)
   apply (case_tac "x1 = NoPerm")
    apply (auto)
   apply (rule_tac px="x11" and p="x1" and c_t="b" in step2_solve_iter_c1)
     apply (auto)
   apply (cut_tac c_t="b" and c_l="c_list" in select_less_length)
    apply (auto)
   apply (case_tac "min_semi_sol_calc b = Some f_sub")
    apply (iprover)
   apply (simp add: min_semi_sol_calc_def)
    (* - inequality constraint. var case *)
  apply (case_tac "case select_list concrete_crn (sub1_crn_list b x2) of None \<Rightarrow> Some empty_semi_env
              | Some (LeqCrn2 px (SPerm p), c_t) \<Rightarrow> if p = NoPerm then None else min_semi_sol_calc_f c_t
              | Some (LeqCrn2 px (SVar r), c_t) \<Rightarrow>
                  (case min_semi_sol_calc_f (sub1_crn_list c_t r) of None \<Rightarrow> None | Some f_sub \<Rightarrow> Some (\<lambda>r'. if r' = r then True else f_sub r'))
              | Some (DisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x | Some (MiniDisjCrn2 x_perm1 x, c_t) \<Rightarrow> Map.empty x")
   apply (auto)
  apply (rule_tac px="x11" and c_t="b" in step2_solve_iter_c2)
  apply (auto)
  apply (case_tac "\<not> length (sub1_crn_list b x2) < length c_list")
   apply (cut_tac c_list="b" and r="x2" in sub1_same_length)
   apply (auto)
   apply (cut_tac c_t="b" and c_l="c_list" in select_less_length)
    apply (auto)
  apply (case_tac "min_semi_sol_calc (sub1_crn_list b x2) = Some a")
   apply (iprover)
  apply (simp add: min_semi_sol_calc_def)
  done

end


theory HC_To_UHC
  imports  Main Definitions_UHC HC_To_UHC_1 HC_To_UHC_2
begin

subsection \<open>Main theorem\<close>

lemma hc_implies_uhc:
  assumes "G \<in> hc"
  shows "hc_to_uhc G \<in> uhc"
proof -
  obtain Cycle where 1: "is_hc G Cycle"
    using assms hc_def
    by auto
  obtain Cy where 2: "Cy = (hd Cycle, 2) # to_cycle_uhc G (tl Cycle)"
    by simp
  then show ?thesis using 1 2 in_uhc assms G_leq_1_vertex_in_uhc
    by blast
qed

lemma in_uhc_implies_in_hc:
  assumes "hc_to_uhc G \<in> uhc"
  shows "G \<in> hc"
proof -
  obtain G' where 0: "G' = hc_to_uhc G"
    by auto
  obtain Cy1 where 1: "is_uhc G' Cy1"
    using assms uhc_def 0
    by auto
  obtain Cy2 where 2: "Cy2 = rev Cy1"
    by simp
  obtain C1 where 3: "C1 = to_cycle_hc Cy1"
    by auto
  obtain C2 where 4: "C2 = to_cycle_hc Cy2"
    by auto
  then show ?thesis
    using 0 1 2 3 4 in_hc assms G_leq_1_vertex_in_uhc
    by blast
qed

theorem is_reduction_hc_uhc:
  "is_reduction hc_to_uhc hc uhc"
  unfolding is_reduction_def using in_uhc_implies_in_hc hc_implies_uhc  by auto

end


(*  Title:      Primepow.thy
    Author:     Klaus Weidinger, TU Muenchen
    Copyright   2020

A simproc for the predicate "primepow (n::int)" from "Prime_Powers.thy".
*)

theory Primepow
  imports
    Main
    Complex_Main
    "HOL-Computational_Algebra.Primes"
    "HOL-Number_Theory.Prime_Powers"
    HOL.Num
    Prime
begin

text\<open>
Case distinction:
  case "n < 2": lemma 'primepow_false_lt2'
  case "n >= 2 & primepow n": lemma 'primepow_true'
  case "n >= 2 & ~primepow n": lemma 'primepow_false'
\<close>

lemma primepow_true:
  fixes p::nat and pp::nat
  assumes "p ^ m = pp" "m > 0" "prime p"
  shows "primepow pp"
proof -
  show "primepow pp" using assms by (auto simp: primepow_def)
qed

lemma primepow_false:
  fixes a::nat and b::nat and pp::nat
  assumes "a * ka = pp" "b * kb = pp" "a \<noteq> b" "prime a" "prime b"
  shows "\<not> primepow pp"
proof -
  have tmp: "a dvd pp" using assms and dvd_def by metis
  have "b dvd pp" using assms and dvd_def by metis
  thus "\<not> primepow pp" using assms and tmp by (auto simp: not_primepowI)
qed

lemma primepow_false_lt2:
  fixes n::nat
  assumes "n = 0 \<or> n = 1"
  shows "\<not> primepow n"
  using assms by auto

ML_file\<open>algorithms.ML\<close>
ML_file\<open>tools.ML\<close>

ML\<open>
signature PRIMEPOW =
sig

(* defines the upper (and lower) bound for the simproc *)
val limit: int Config.T

val parse: Thm.cterm -> int

(*                            pp    p     m                   pp    a     b   *)
datatype cert = TRUE_CERT of int * int * int | FALSE_CERT of int * int * int | LESS_THAN_2 of int
val mk_cert: int -> cert
val generate_proof: Proof.context -> cert -> thm option

val prove: Proof.context -> int -> thm option
val simproc: Proof.context -> Thm.cterm -> thm option

(* helper tools *)
val get_cert_number : cert -> int

end

structure Primepow : PRIMEPOW =
struct

val limit = Attrib.setup_config_int \<^binding>\<open>limit\<close> (K 1000000);
exception LIMIT

(*                            pp    p     m                   pp    a     b   *)
datatype cert = TRUE_CERT of int * int * int | FALSE_CERT of int * int * int | LESS_THAN_2 of int

fun parse ct = Tools.parse1 ct @{const_name "primepow"}

fun mk_cert n =
    if n < 2 then LESS_THAN_2 n else
    let
        val fs_mset = Algorithms.to_mset (Algorithms.factorize n)
    in
        if length fs_mset = 1 then TRUE_CERT (n, fst (hd fs_mset), snd (hd fs_mset))
                              else FALSE_CERT (n, fst (hd fs_mset), fst (hd (tl fs_mset)))
    end

exception ERROR
fun generate_proof ctxt (LESS_THAN_2 pp) =
        @{thm primepow_false_lt2}
            |> Drule.infer_instantiate' ctxt [Tools.nat2ct' ctxt pp]
            |> Tools.simp ctxt 1
            |> SOME
  | generate_proof ctxt (TRUE_CERT (pp, p, m)) =
    let
        val prime_p = case fst (Pratt.prove_prime [] p ctxt)
                        of SOME thm => thm |
                               NONE => raise ERROR
    in
        @{thm primepow_true}
            |> Drule.infer_instantiate' ctxt
                      (map (Tools.nat2ct' ctxt) [p, m, pp])
            |> Tools.simp ctxt 2
            |> (fn thm => thm OF [prime_p])
            |> SOME
    end
  | generate_proof ctxt (FALSE_CERT (pp, a, b)) =
    let
        val prime_a = case fst (Pratt.prove_prime [] a ctxt)
                        of SOME thm => thm |
                               NONE => raise ERROR
        val prime_b = case fst (Pratt.prove_prime [] b ctxt)
                        of SOME thm => thm |
                               NONE => raise ERROR
    in
        @{thm primepow_false}
            |> Drule.infer_instantiate' ctxt
                      (map (Tools.nat2ct' ctxt) [a, pp div a, pp, b, pp div b])
            |> Tools.simp ctxt 3
            |> (fn thm => thm OF [prime_a])
            |> (fn thm => thm OF [prime_b])
            |> SOME
    end

fun prove ctxt n =                   (* term                            *)
    n     |> mk_cert                 (* cert                            *)
          |> generate_proof ctxt     (* thm option                      *)
    handle ERROR => NONE
         | THM _ => NONE

fun simproc ctxt input =            (* term            *)
    input |> parse                  (* n               *)
          |> (fn n => if abs n < Config.get ctxt limit then n else raise LIMIT)
          |> prove ctxt             (* thm option      *)
          |> Tools.wrap             (* thm option      *)
    handle LIMIT => NONE
         | TERM _ => NONE

(* helper tools *)
fun get_cert_number (LESS_THAN_2 pp) = pp
  | get_cert_number (TRUE_CERT (pp, _, _)) = pp
  | get_cert_number (FALSE_CERT (pp, _, _)) = pp

end
\<close>

simproc_setup primepow_simproc ("primepow (numeral n::nat)") = \<open>K Primepow.simproc\<close>

end


theory Quantale_Tests
  imports Quantale "$AFP/KAT_and_DRA/SingleSorted/Test_Dioids"
begin

class quantales_tests = quantale + dioid_tests +
  assumes test_meet_closure: "test p \<Longrightarrow> test q \<Longrightarrow> test (p \<sqinter> q)"
begin

lemma test_meet: "test p \<Longrightarrow> test q \<Longrightarrow> p \<sqinter> q = p \<cdot> q"
  apply (auto simp: test_restrictl test_restrictr intro!: antisym)
  by (metis (no_types, lifting) local.inf.cobounded1 local.inf.cobounded2 local.test_leq_mult_def_var local.test_meet_closure local.test_mult_closed mult_assoc)

definition guards :: "('a \<times> 'a) set \<Rightarrow> 'a" where
  "guards GC \<equiv> \<Squnion>{b. \<exists>x. (b, x) \<in> GC \<and> test b}"

definition comm :: "('a \<times> 'a) set \<Rightarrow> 'a" where
  "comm GC \<equiv> \<Squnion>{b \<cdot> x | b x. (b, x) \<in> GC \<and> test b}"

definition select :: "('a \<times> 'a) set \<Rightarrow> 'a" where
  "select GC \<equiv> comm GC"

lemma test_export_eq: "test p \<Longrightarrow> test b \<Longrightarrow> p\<cdot>b\<cdot>x \<le> b\<cdot>x\<cdot>q \<longleftrightarrow> p\<cdot>b\<cdot>x \<le> x\<cdot>q"
proof (default, metis local.order_trans local.test_restrictl mult_assoc)
  assume assm: "test p" "test b" "p\<cdot>b\<cdot>x \<le> x\<cdot>q"
  hence "p\<cdot>b\<cdot>x = b\<cdot>(p\<cdot>b\<cdot>x)"
    by (metis local.test_mult_comm_var local.test_mult_idem_var mult_assoc)
  also have "... \<le> b\<cdot>(x\<cdot>q)"
    by (simp add: assm(3) local.mult_isol)
  finally show "p \<cdot> b \<cdot> x \<le> b \<cdot> x \<cdot> q"
    by (simp add: mult_assoc)
qed

lemma "test p \<Longrightarrow> test q \<Longrightarrow> \<forall>b x. (b, x) \<in> GC \<and> test b \<longrightarrow> p\<cdot>b\<cdot>x \<le> x\<cdot>q \<Longrightarrow> p\<cdot>(select GC) \<le> (select GC)\<cdot>q"
proof (auto simp: select_def)
  assume assm: "test p" "\<forall>b x. (b, x) \<in> GC \<and> test b \<longrightarrow> p \<cdot> b \<cdot> x \<le> x \<cdot> q"
  hence a: "\<forall>b x. (b, x) \<in> GC \<and> test b \<longrightarrow> p \<cdot> (b \<cdot> x) \<le> b \<cdot> x \<cdot> q"
    by (auto simp: test_export_eq mult_assoc[symmetric])
  have "p \<cdot> (comm GC) = \<Squnion>{p \<cdot> (b \<cdot> x) |b x. (b, x) \<in> GC \<and> test b}"
    by (auto simp: comm_def qSUP_distl2')
  also have "... \<le> \<Squnion>{b \<cdot> x \<cdot> q |b x. (b, x) \<in> GC \<and> test b}"
    apply (rule Sup_least)
    apply auto
    apply (rule Sup_upper2)
    apply auto
    using a apply auto
  done
  also have "... = comm GC \<cdot> q"
    by (auto simp: comm_def qSup_distr') (metis (no_types, lifting))
  finally show "p \<cdot> comm GC \<le> comm GC \<cdot> q" .
qed

end

end


(*  Title:      HOL/Proofs/Lambda/Eta.thy
    Author:     Tobias Nipkow and Stefan Berghofer
    Copyright   1995, 2005 TU Muenchen
*)

section \<open>Eta-reduction\<close>

theory Eta imports ParRed begin

subsection \<open>Definition of eta-reduction and relatives\<close>

primrec
  free :: "dB => nat => bool"
where
    "free (Var j) i = (j = i)"
  | "free (s \<degree> t) i = (free s i \<or> free t i)"
  | "free (Abs s) i = free s (i + 1)"

inductive
  eta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<eta>" 50)
where
    eta [simp, intro]: "\<not> free s 0 ==> Abs (s \<degree> Var 0) \<rightarrow>\<^sub>\<eta> s[dummy/0]"
  | appL [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t ==> s \<degree> u \<rightarrow>\<^sub>\<eta> t \<degree> u"
  | appR [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t ==> u \<degree> s \<rightarrow>\<^sub>\<eta> u \<degree> t"
  | abs [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t ==> Abs s \<rightarrow>\<^sub>\<eta> Abs t"

abbreviation
  eta_reds :: "[dB, dB] => bool"   (infixl "\<rightarrow>\<^sub>\<eta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<eta>\<^sup>* t == eta^** s t"

abbreviation
  eta_red0 :: "[dB, dB] => bool"   (infixl "\<rightarrow>\<^sub>\<eta>\<^sup>=" 50) where
  "s \<rightarrow>\<^sub>\<eta>\<^sup>= t == eta^== s t"

inductive_cases eta_cases [elim!]:
  "Abs s \<rightarrow>\<^sub>\<eta> z"
  "s \<degree> t \<rightarrow>\<^sub>\<eta> u"
  "Var i \<rightarrow>\<^sub>\<eta> t"

subsection \<open>Properties of \<open>eta\<close>, \<open>subst\<close> and \<open>free\<close>\<close>

lemma subst_not_free [simp]: "\<not> free s i \<Longrightarrow> s[t/i] = s[u/i]"
  by (induct s arbitrary: i t u) (simp_all add: subst_Var)

lemma free_lift [simp]:
    "free (lift t k) i = (i < k \<and> free t i \<or> k < i \<and> free t (i - 1))"
  apply (induct t arbitrary: i k)
  apply (auto cong: conj_cong)
  done

lemma free_subst [simp]:
    "free (s[t/k]) i =
      (free s k \<and> free t i \<or> free s (if i < k then i else i + 1))"
  apply (induct s arbitrary: i k t)
    prefer 2
    apply simp
    apply blast
   prefer 2
   apply simp
  apply (simp add: diff_Suc subst_Var split: nat.split)
  done

lemma free_eta: "s \<rightarrow>\<^sub>\<eta> t ==> free t i = free s i"
  by (induct arbitrary: i set: eta) (simp_all cong: conj_cong)

lemma not_free_eta:
    "[| s \<rightarrow>\<^sub>\<eta> t; \<not> free s i |] ==> \<not> free t i"
  by (simp add: free_eta)

lemma eta_subst [simp]:
    "s \<rightarrow>\<^sub>\<eta> t ==> s[u/i] \<rightarrow>\<^sub>\<eta> t[u/i]"
  by (induct arbitrary: u i set: eta) (simp_all add: subst_subst [symmetric])

theorem lift_subst_dummy: "\<not> free s i \<Longrightarrow> lift (s[dummy/i]) i = s"
  by (induct s arbitrary: i dummy) simp_all

subsection \<open>Confluence of \<open>eta\<close>\<close>

lemma square_eta: "square eta eta (eta^==) (eta^==)"
  apply (unfold square_def id_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule eta.induct)
     apply (slowsimp intro: subst_not_free eta_subst free_eta [THEN iffD1])
    apply safe
       prefer 5
       apply (blast intro!: eta_subst intro: free_eta [THEN iffD1])
      apply blast+
  done

theorem eta_confluent: "confluent eta"
  apply (rule square_eta [THEN square_reflcl_confluent])
  done

subsection \<open>Congruence rules for \<open>eta\<^sup>*\<close>\<close>

lemma rtrancl_eta_Abs: "s \<rightarrow>\<^sub>\<eta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<eta>\<^sup>* Abs s'"
  by (induct set: rtranclp)
    (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_eta_AppL: "s \<rightarrow>\<^sub>\<eta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<eta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp)
    (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_eta_AppR: "t \<rightarrow>\<^sub>\<eta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<eta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_eta_App:
    "[| s \<rightarrow>\<^sub>\<eta>\<^sup>* s'; t \<rightarrow>\<^sub>\<eta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<eta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_eta_AppL rtrancl_eta_AppR intro: rtranclp_trans)

subsection \<open>Commutation of \<open>beta\<close> and \<open>eta\<close>\<close>

lemma free_beta:
    "s \<rightarrow>\<^sub>\<beta> t ==> free t i \<Longrightarrow> free s i"
  by (induct arbitrary: i set: beta) auto

lemma beta_subst [intro]: "s \<rightarrow>\<^sub>\<beta> t ==> s[u/i] \<rightarrow>\<^sub>\<beta> t[u/i]"
  by (induct arbitrary: u i set: beta) (simp_all add: subst_subst [symmetric])

lemma subst_Var_Suc [simp]: "t[Var i/i] = t[Var(i)/i + 1]"
  by (induct t arbitrary: i) (auto elim!: linorder_neqE simp: subst_Var)

lemma eta_lift [simp]: "s \<rightarrow>\<^sub>\<eta> t ==> lift s i \<rightarrow>\<^sub>\<eta> lift t i"
  by (induct arbitrary: i set: eta) simp_all

lemma rtrancl_eta_subst: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> u[s/i] \<rightarrow>\<^sub>\<eta>\<^sup>* u[t/i]"
  apply (induct u arbitrary: s t i)
    apply (simp_all add: subst_Var)
    apply blast
   apply (blast intro: rtrancl_eta_App)
  apply (blast intro!: rtrancl_eta_Abs eta_lift)
  done

lemma rtrancl_eta_subst':
  fixes s t :: dB
  assumes eta: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t"
  shows "s[u/i] \<rightarrow>\<^sub>\<eta>\<^sup>* t[u/i]" using eta
  by induct (iprover intro: eta_subst)+

lemma rtrancl_eta_subst'':
  fixes s t :: dB
  assumes eta: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t"
  shows "u[s/i] \<rightarrow>\<^sub>\<eta>\<^sup>* u[t/i]" using eta
  by induct (iprover intro: rtrancl_eta_subst rtranclp_trans)+

lemma square_beta_eta: "square beta eta (eta^**) (beta^==)"
  apply (unfold square_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule beta.induct)
     apply (slowsimp intro: rtrancl_eta_subst eta_subst)
    apply (blast intro: rtrancl_eta_AppL)
   apply (blast intro: rtrancl_eta_AppR)
  apply simp
  apply (slowsimp intro: rtrancl_eta_Abs free_beta
    iff del: dB.distinct simp: dB.distinct)    (*23 seconds?*)
  done

lemma confluent_beta_eta: "confluent (sup beta eta)"
  apply (assumption |
    rule square_rtrancl_reflcl_commute confluent_Un
      beta_confluent eta_confluent square_beta_eta)+
  done

subsection \<open>Implicit definition of \<open>eta\<close>\<close>

text \<open>@{term "Abs (lift s 0 \<degree> Var 0) \<rightarrow>\<^sub>\<eta> s"}\<close>

lemma not_free_iff_lifted:
    "(\<not> free s i) = (\<exists>t. s = lift t i)"
  apply (induct s arbitrary: i)
    apply simp
    apply (rule iffI)
     apply (erule linorder_neqE)
      apply (rename_tac nat a, rule_tac x = "Var nat" in exI)
      apply simp
     apply (rename_tac nat a, rule_tac x = "Var (nat - 1)" in exI)
     apply simp
    apply clarify
    apply (rule notE)
     prefer 2
     apply assumption
    apply (erule thin_rl)
    apply (case_tac t)
      apply simp
     apply simp
    apply simp
   apply simp
   apply (erule thin_rl)
   apply (erule thin_rl)
   apply (rule iffI)
    apply (elim conjE exE)
    apply (rename_tac u1 u2)
    apply (rule_tac x = "u1 \<degree> u2" in exI)
    apply simp
   apply (erule exE)
   apply (erule rev_mp)
   apply (case_tac t)
     apply simp
    apply simp
    apply blast
   apply simp
  apply simp
  apply (erule thin_rl)
  apply (rule iffI)
   apply (erule exE)
   apply (rule_tac x = "Abs t" in exI)
   apply simp
  apply (erule exE)
  apply (erule rev_mp)
  apply (case_tac t)
    apply simp
   apply simp
  apply simp
  apply blast
  done

theorem explicit_is_implicit:
  "(\<forall>s u. (\<not> free s 0) --> R (Abs (s \<degree> Var 0)) (s[u/0])) =
    (\<forall>s. R (Abs (lift s 0 \<degree> Var 0)) s)"
  by (auto simp add: not_free_iff_lifted)

subsection \<open>Eta-postponement theorem\<close>

text \<open>
  Based on a paper proof due to Andreas Abel.
  Unlike the proof by Masako Takahashi @{cite "Takahashi-IandC"}, it does not
  use parallel eta reduction, which only seems to complicate matters unnecessarily.
\<close>

theorem eta_case:
  fixes s :: dB
  assumes free: "\<not> free s 0"
  and s: "s[dummy/0] => u"
  shows "\<exists>t'. Abs (s \<degree> Var 0) => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u"
proof -
  from s have "lift (s[dummy/0]) 0 => lift u 0" by (simp del: lift_subst)
  with free have "s => lift u 0" by (simp add: lift_subst_dummy del: lift_subst)
  hence "Abs (s \<degree> Var 0) => Abs (lift u 0 \<degree> Var 0)" by simp
  moreover have "\<not> free (lift u 0) 0" by simp
  hence "Abs (lift u 0 \<degree> Var 0) \<rightarrow>\<^sub>\<eta> lift u 0[dummy/0]"
    by (rule eta.eta)
  hence "Abs (lift u 0 \<degree> Var 0) \<rightarrow>\<^sub>\<eta>\<^sup>* u" by simp
  ultimately show ?thesis by iprover
qed

theorem eta_par_beta:
  assumes st: "s \<rightarrow>\<^sub>\<eta> t"
  and tu: "t => u"
  shows "\<exists>t'. s => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u" using tu st
proof (induct arbitrary: s)
  case (var n)
  thus ?case by (iprover intro: par_beta_refl)
next
  case (abs s' t)
  note abs' = this
  from \<open>s \<rightarrow>\<^sub>\<eta> Abs s'\<close> show ?case
  proof cases
    case (eta s'' dummy)
    from abs have "Abs s' => Abs t" by simp
    with eta have "s''[dummy/0] => Abs t" by simp
    with \<open>\<not> free s'' 0\<close> have "\<exists>t'. Abs (s'' \<degree> Var 0) => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* Abs t"
      by (rule eta_case)
    with eta show ?thesis by simp
  next
    case (abs r)
    from \<open>r \<rightarrow>\<^sub>\<eta> s'\<close>
    obtain t' where r: "r => t'" and t': "t' \<rightarrow>\<^sub>\<eta>\<^sup>* t" by (iprover dest: abs')
    from r have "Abs r => Abs t'" ..
    moreover from t' have "Abs t' \<rightarrow>\<^sub>\<eta>\<^sup>* Abs t" by (rule rtrancl_eta_Abs)
    ultimately show ?thesis using abs by simp iprover
  qed
next
  case (app u u' t t')
  from \<open>s \<rightarrow>\<^sub>\<eta> u \<degree> t\<close> show ?case
  proof cases
    case (eta s' dummy)
    from app have "u \<degree> t => u' \<degree> t'" by simp
    with eta have "s'[dummy/0] => u' \<degree> t'" by simp
    with \<open>\<not> free s' 0\<close> have "\<exists>r. Abs (s' \<degree> Var 0) => r \<and> r \<rightarrow>\<^sub>\<eta>\<^sup>* u' \<degree> t'"
      by (rule eta_case)
    with eta show ?thesis by simp
  next
    case (appL s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> u\<close>
    obtain r where s': "s' => r" and r: "r \<rightarrow>\<^sub>\<eta>\<^sup>* u'" by (iprover dest: app)
    from s' and app have "s' \<degree> t => r \<degree> t'" by simp
    moreover from r have "r \<degree> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u' \<degree> t'" by (simp add: rtrancl_eta_AppL)
    ultimately show ?thesis using appL by simp iprover
  next
    case (appR s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> t\<close>
    obtain r where s': "s' => r" and r: "r \<rightarrow>\<^sub>\<eta>\<^sup>* t'" by (iprover dest: app)
    from s' and app have "u \<degree> s' => u' \<degree> r" by simp
    moreover from r have "u' \<degree> r \<rightarrow>\<^sub>\<eta>\<^sup>* u' \<degree> t'" by (simp add: rtrancl_eta_AppR)
    ultimately show ?thesis using appR by simp iprover
  qed
next
  case (beta u u' t t')
  from \<open>s \<rightarrow>\<^sub>\<eta> Abs u \<degree> t\<close> show ?case
  proof cases
    case (eta s' dummy)
    from beta have "Abs u \<degree> t => u'[t'/0]" by simp
    with eta have "s'[dummy/0] => u'[t'/0]" by simp
    with \<open>\<not> free s' 0\<close> have "\<exists>r. Abs (s' \<degree> Var 0) => r \<and> r \<rightarrow>\<^sub>\<eta>\<^sup>* u'[t'/0]"
      by (rule eta_case)
    with eta show ?thesis by simp
  next
    case (appL s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> Abs u\<close> show ?thesis
    proof cases
      case (eta s'' dummy)
      have "Abs (lift u 1) = lift (Abs u) 0" by simp
      also from eta have "\<dots> = s''" by (simp add: lift_subst_dummy del: lift_subst)
      finally have s: "s = Abs (Abs (lift u 1) \<degree> Var 0) \<degree> t" using appL and eta by simp
      from beta have "lift u 1 => lift u' 1" by simp
      hence "Abs (lift u 1) \<degree> Var 0 => lift u' 1[Var 0/0]"
        using par_beta.var ..
      hence "Abs (Abs (lift u 1) \<degree> Var 0) \<degree> t => lift u' 1[Var 0/0][t'/0]"
        using \<open>t => t'\<close> ..
      with s have "s => u'[t'/0]" by simp
      thus ?thesis by iprover
    next
      case (abs r)
      from \<open>r \<rightarrow>\<^sub>\<eta> u\<close>
      obtain r'' where r: "r => r''" and r'': "r'' \<rightarrow>\<^sub>\<eta>\<^sup>* u'" by (iprover dest: beta)
      from r and beta have "Abs r \<degree> t => r''[t'/0]" by simp
      moreover from r'' have "r''[t'/0] \<rightarrow>\<^sub>\<eta>\<^sup>* u'[t'/0]"
        by (rule rtrancl_eta_subst')
      ultimately show ?thesis using abs and appL by simp iprover
    qed
  next
    case (appR s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> t\<close>
    obtain r where s': "s' => r" and r: "r \<rightarrow>\<^sub>\<eta>\<^sup>* t'" by (iprover dest: beta)
    from s' and beta have "Abs u \<degree> s' => u'[r/0]" by simp
    moreover from r have "u'[r/0] \<rightarrow>\<^sub>\<eta>\<^sup>* u'[t'/0]"
      by (rule rtrancl_eta_subst'')
    ultimately show ?thesis using appR by simp iprover
  qed
qed

theorem eta_postponement':
  assumes eta: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t" and beta: "t => u"
  shows "\<exists>t'. s => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u" using eta beta
proof (induct arbitrary: u)
  case base
  thus ?case by blast
next
  case (step s' s'' s''')
  then obtain t' where s': "s' => t'" and t': "t' \<rightarrow>\<^sub>\<eta>\<^sup>* s'''"
    by (auto dest: eta_par_beta)
  from s' obtain t'' where s: "s => t''" and t'': "t'' \<rightarrow>\<^sub>\<eta>\<^sup>* t'" using step
    by blast
  from t'' and t' have "t'' \<rightarrow>\<^sub>\<eta>\<^sup>* s'''" by (rule rtranclp_trans)
  with s show ?case by iprover
qed

theorem eta_postponement:
  assumes "(sup beta eta)\<^sup>*\<^sup>* s t"
  shows "(beta\<^sup>*\<^sup>* OO eta\<^sup>*\<^sup>*) s t" using assms
proof induct
  case base
  show ?case by blast
next
  case (step s' s'')
  from step(3) obtain t' where s: "s \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and t': "t' \<rightarrow>\<^sub>\<eta>\<^sup>* s'" by blast
  from step(2) show ?case
  proof
    assume "s' \<rightarrow>\<^sub>\<beta> s''"
    with beta_subset_par_beta have "s' => s''" ..
    with t' obtain t'' where st: "t' => t''" and tu: "t'' \<rightarrow>\<^sub>\<eta>\<^sup>* s''"
      by (auto dest: eta_postponement')
    from par_beta_subset_beta st have "t' \<rightarrow>\<^sub>\<beta>\<^sup>* t''" ..
    with s have "s \<rightarrow>\<^sub>\<beta>\<^sup>* t''" by (rule rtranclp_trans)
    thus ?thesis using tu ..
  next
    assume "s' \<rightarrow>\<^sub>\<eta> s''"
    with t' have "t' \<rightarrow>\<^sub>\<eta>\<^sup>* s''" ..
    with s show ?thesis ..
  qed
qed

end


theory Single_Step_Demo
imports Main
begin

text{* "thm" is a command that displays one or more named theorems: *}
thm conjI impI iffI notI

text{* Instantiation of theorems: "of" *}

text{* Positional: *}
thm conjI[of "A" "B"]
thm conjI[of "A"]
thm conjI[of _ "B"]

text{* By name: *}
thm conjI[where ?Q = "B"]

text{* Composition of theorems: OF *}

thm refl[of "a"]
thm conjI[OF refl[of "a"] refl[of "b"]]
thm conjI[OF refl[of "a"]]
thm conjI[OF _ refl[of "b"]]

text{* A simple backward proof: *}
lemma "\<lbrakk> A; B \<rbrakk> \<Longrightarrow> A \<and> B"
apply(rule conjI)
apply assumption
apply assumption
done

text{* Teaching blast new intro rules: *}

thm le_trans

lemma "\<lbrakk> (a::nat) \<le> b; b \<le> c; c \<le> d \<rbrakk> \<Longrightarrow> a \<le> d"
by(blast intro: le_trans)

end


section \<open>Transferring Theorems Between Graph Libraries\<close>
theory TA_Graph_Library_Adaptor
  imports TA_Graphs "../Graph_Theory/More_Graph_Theory"
begin

no_notation funcset (infixr "\<rightarrow>" 60)

subsection \<open>Miscellaneous\<close>

lemma (in -) pair_in_pair_set_iff:
  "(a, b) \<in> {(x, y). P x y} \<longleftrightarrow> P a b"
  by auto

subsection \<open>From \<open>Graph_Theory\<close> to \<open>Graphs\<close>\<close>

context pre_digraph
begin

definition "E \<equiv> \<lambda>x y. (x, y) \<in> arcs_ends G"

interpretation Graph_Defs E .

lemma dominates_iff:
  "u \<rightarrow>\<^bsub>G\<^esub> v \<longleftrightarrow> E u v"
  unfolding E_def by simp

lemma reachable1_iff:
  "u \<rightarrow>\<^sup>+\<^bsub>G\<^esub> v \<longleftrightarrow> reaches1 u v"
  unfolding tranclp_unfold E_def by simp

end

context wf_digraph
begin

interpretation Graph_Defs E .

lemma reachable_iff:
  "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v \<longleftrightarrow> reaches u v" if "u \<in> verts G"
  apply (rule iffI)
  subgoal premises prems
    using prems unfolding reachable_def by induction (auto simp: dominates_iff)
  subgoal premises prems
    using prems by induction
      (auto 4 3 simp: that dominates_iff[symmetric] reachable_def intro: rtrancl_on_into_rtrancl_on)
  done

lemma vwalk_iff:
  "vwalk (u # xs) G \<longleftrightarrow> steps (u # xs)" if "u \<in> verts G"
  apply (rule iffI)
   apply (induction rule: vwalk_induct; auto simp: dominates_iff)
  subgoal premises prems
    using prems that by (induction "u # xs" arbitrary: u xs; simp add: adj_in_verts(2) dominates_iff)
  done

lemmas graph_convs1 = reachable_iff reachable1_iff vwalk_iff

end

context dag
begin

sublocale graph: DAG E
  by standard (auto simp: graph_convs1 intro: acyclic)

\<comment> \<open>Transferring a theorem: every DAG has a topological numbering\<close>
lemma topological_numbering:
  fixes S assumes "finite S"
  shows "\<exists>f :: _ \<Rightarrow> nat. inj_on f S \<and> (\<forall>x \<in> S. \<forall>y \<in> S. x \<rightarrow> y \<longrightarrow> f x < f y)"
  using graph.topological_numbering[OF assms] unfolding dominates_iff .

end

sublocale fin_digraph \<subseteq> graph: Finite_Graph E
  by standard (auto intro!: finite_subset[OF _ finite_verts] simp: E_def Graph_Defs.vertices_def)

sublocale fin_dag \<subseteq> graph: Finite_DAG E ..

subsection \<open>From \<open>Graphs\<close> to \<open>Graph_Theory\<close>\<close>

context Graph_Defs
begin

definition "G = \<lparr>verts = UNIV, arcs = {(a, b). E a b}, tail = fst, head = snd\<rparr>"

definition "G\<^sub>p = \<lparr>pverts = UNIV, parcs = {(a, b). E a b}\<rparr>"

lemma G_pair_conv:
  "with_proj G\<^sub>p = G"
  unfolding G\<^sub>p_def G_def with_proj_def by simp

sublocale digraph: nomulti_digraph G
  by standard (auto simp: G_def arc_to_ends_def)

sublocale pdigraph: pair_wf_digraph G\<^sub>p
  using G_pair_conv digraph.wf_digraph_axioms wf_digraph_wp_iff by metis

lemma arc_to_ends_eq[simp]:
  "arc_to_ends G = id"
  by (auto simp add: G_def arc_to_ends_def)

lemma arcs_ends_eq[simp]:
  "arcs_ends G = {(a, b). E a b}"
  unfolding arcs_ends_def arc_to_ends_eq by (simp add: G_def)

lemma dominates_iff[simp]:
  "u \<rightarrow>\<^bsub>G\<^esub> v \<longleftrightarrow> E u v"
  by simp

lemma verts_eq[simp]:
  "verts G = UNIV"
  unfolding G_def by simp

lemma reachable_iff:
  "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v \<longleftrightarrow> u \<rightarrow>* v"
  apply (simp only: reachable_def arcs_ends_eq verts_eq)
  apply (rule iffI)
  subgoal premises prems
    using prems by induction auto
  subgoal premises prems
    using prems by induction (auto intro: rtrancl_on_into_rtrancl_on)
  done

lemma reachable1_iff:
  "u \<rightarrow>\<^sup>+\<^bsub>G\<^esub> v \<longleftrightarrow> u \<rightarrow>\<^sup>+ v"
  by (simp only: arcs_ends_eq pair_in_pair_set_iff tranclp_unfold)

lemma vwalk_iff:
  "vwalk xs G \<longleftrightarrow> steps xs"
  apply (rule iffI)
   apply (induction rule: vwalk_induct; auto)
  apply (induction rule: steps.induct; auto)
  done

lemmas graph_convs2 = reachable_iff reachable1_iff vwalk_iff

\<comment> \<open>Transferring a theorem (@{thm digraph.reachable_vpath_conv}):\<close>
lemma reachable_path_conv:
  "u \<rightarrow>* v \<longleftrightarrow> (\<exists>p. steps p \<and> distinct p \<and> hd p = u \<and> last p = v)"
  unfolding graph_convs2[symmetric] by (simp add: digraph.reachable_vpath_conv vpath_def)

end

context Subgraph_Defs
begin

definition "G' = \<lparr>verts = UNIV, arcs = {(a, b). E' a b}, tail = fst, head = snd\<rparr>"

definition "G\<^sub>p' = \<lparr>pverts = UNIV, parcs = {(a, b). E' a b}\<rparr>"

lemma G'_pair_conv:
  "with_proj G\<^sub>p' = G'"
  unfolding G\<^sub>p'_def G'_def with_proj_def by simp

sublocale digraph_sub: wf_digraph G'
  unfolding wf_digraph_def G'_def by simp

sublocale pdigraph_sub: pair_wf_digraph G\<^sub>p'
  using G'_pair_conv digraph_sub.wf_digraph_axioms wf_digraph_wp_iff by metis

lemma verts_eq[simp]:
  "verts G' = UNIV"
  unfolding G'_def by simp

end

context Subgraph
begin

lemma subgraph:
  "subgraph G' G.G"
  unfolding subgraph_def
  apply (intro conjI)
  subgoal
    by simp
  subgoal
    by (auto simp: G.G_def G'_def)
  subgoal
    by (simp add: G.digraph.wf_digraph_axioms)
  subgoal
    by (simp add: digraph_sub.wf_digraph_axioms)
  subgoal
    by (simp add: compatible_def G.G_def G'_def)
  done

lemma spanning:
  "spanning G' G.G"
  unfolding spanning_def by (simp add: subgraph)

lemma G'_eq:
  "G'.G = G'"
  by (auto simp: Graph_Defs.G_def G'_def)

lemmas subgraph_convs = G'.graph_convs2[unfolded G'_eq]

end

context Subgraph_Node_Defs
begin

\<comment> \<open>Node-induced subgraph. Compare with @{term G'}.\<close>
definition "G\<^sub>n = \<lparr>verts = {x. V x}, arcs = {(a, b). E' a b}, tail = fst, head = snd\<rparr>"

sublocale digraph_nodes: wf_digraph G\<^sub>n
  unfolding wf_digraph_def G\<^sub>n_def E'_def by simp

lemma verts_eq[simp]:
  "verts G\<^sub>n = {x. V x}"
  unfolding G\<^sub>n_def by simp

lemma arcs_eq[simp]:
  "arcs G\<^sub>n = arcs G'"
  unfolding G\<^sub>n_def G'_def by simp

lemma subgraph_dominatesI:
  "a \<rightarrow>\<^bsub>G\<^sub>n\<^esub> b" if "a \<rightarrow> b" "V a" "V b"
  using that by (intro digraph_nodes.dominatesI) (auto simp: G\<^sub>n_def arc_to_ends_def E'_def)

lemma arcs_ends_eq:
  "arcs_ends G\<^sub>n = arcs_ends G'"
  unfolding G\<^sub>n_def G'_def E'_def arcs_ends_def arc_to_ends_def by simp

lemma subgraph_nodes':
  "subgraph G\<^sub>n G'"
  unfolding subgraph_def
  apply (intro conjI)
  subgoal
    by simp
  subgoal
    by simp
  subgoal
    by (simp add: digraph_sub.wf_digraph_axioms)
  subgoal
    by (simp add: digraph_nodes.wf_digraph_axioms)
  subgoal
    by (simp add: compatible_def G'_def G\<^sub>n_def)
  done

lemma subgraph_nodes:
  "subgraph G\<^sub>n G"
  by (rule subgraph_nodes' subgraph subgraph_trans)+

lemma induced_subgraph:
  "induced_subgraph G\<^sub>n G"
  unfolding induced_subgraph_def by (intro conjI subgraph_nodes) (auto simp: G\<^sub>n_def G_def E'_def)

\<comment> \<open>The notions of walks in the two versions of node-induced subgraphs are not equivalent
for empty paths, thus this is the only valid ``standard'' conversion theorem between paths:\<close>
lemma reachable1_iff:
  "u \<rightarrow>\<^sup>+\<^bsub>G\<^sub>n\<^esub> v \<longleftrightarrow> u \<rightarrow>\<^sup>+\<^bsub>G'\<^esub> v"
  unfolding arcs_ends_eq ..

lemma dominates_iff:
  "u \<rightarrow>\<^bsub>G\<^sub>n\<^esub> v \<longleftrightarrow> E' u v"
  unfolding G\<^sub>n_def arcs_ends_def arc_to_ends_def E'_def by simp

lemma subgraph_vwalk_iff:
  "vwalk (v # vs) G\<^sub>n \<longleftrightarrow> G'.steps (v # vs)" if "V v"
  apply (rule iffI)
   apply (induction rule: vwalk_induct; auto simp: dominates_iff; fail)
  subgoal premises prems
    using prems that
    by (induction "v # vs" arbitrary: v vs rule: G'.steps.induct; auto simp: dominates_iff E'_def)
  done

lemma subgraph_reaches_iff:
  "u \<rightarrow>\<^sup>*\<^bsub>G\<^sub>n\<^esub> v \<longleftrightarrow> G'.reaches u v" if "V u"
  by (simp add: that G'.reaches_steps_iff2 digraph_nodes.reachable_vwalk_conv2 subgraph_vwalk_iff)

lemma subgraph_reaches1_iff:
  "u \<rightarrow>\<^sup>+\<^bsub>G\<^sub>n\<^esub> v \<longleftrightarrow> G'.reaches1 u v"
  unfolding reachable1_iff subgraph_convs ..

end

context Graph_Invariant
begin

lemma reachable_iff:
  "u \<rightarrow>\<^sup>*\<^bsub>G\<^sub>n\<^esub> v \<longleftrightarrow> u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v" if "P u"
  using that by (simp add: graph_convs2 subgraph_reaches_iff invariant_reaches_iff)

lemma reachable1_iff:
  "u \<rightarrow>\<^sup>+\<^bsub>G\<^sub>n\<^esub> v \<longleftrightarrow> u \<rightarrow>\<^sup>+\<^bsub>G\<^esub> v" if "P u"
  unfolding subgraph_reaches1_iff invariant_reaches1_iff[OF that] graph_convs2 ..

lemma vwalk_iff:
  "vwalk (u # vs) G\<^sub>n \<longleftrightarrow> vwalk (u # vs) G" if "P u"
  using that by (simp add: subgraph_vwalk_iff invariant_steps_iff graph_convs2)

end

subsection \<open>Application: Topological Numberings on the SCCs of a Digraph\<close>

context fin_digraph
begin

interpretation scc_digraph: fin_dag scc_graph
  by (rule scc_digraphI)

definition
  "scc_num \<equiv> SOME f :: (_ \<Rightarrow> nat).
    inj_on f sccs_verts \<and> (\<forall>x\<in>sccs_verts. \<forall>y\<in>sccs_verts. x \<rightarrow>\<^bsub>scc_graph\<^esub> y \<longrightarrow> f x < f y)"

lemma
  shows scc_num_inj: "inj_on scc_num sccs_verts" (is ?thesis1)
    and scc_num_topological:
    "\<forall>x\<in>sccs_verts. \<forall>y\<in>sccs_verts. x \<rightarrow>\<^bsub>scc_graph\<^esub> y \<longrightarrow> scc_num x < scc_num y" (is ?thesis2)
proof -
  from scc_digraph.topological_numbering[OF finite_sccs_verts] have "?thesis1 \<and> ?thesis2"
    unfolding scc_num_def by (rule someI_ex)
  then show ?thesis1 and ?thesis2
    by auto
qed

end

context Finite_Graph
begin

interpretation Graph_Invariant
  where E = E and P = "\<lambda>x. x \<in> vertices"
  by standard (auto simp: vertices_def)

interpretation digraph_nodes: fin_digraph G\<^sub>n
  apply standard
  subgoal finite_verts
    by (simp add: Subgraph_Node_Defs.G\<^sub>n_def finite_graph)
  subgoal
    by (rule finite_subset[where B = "verts G\<^sub>n \<times> verts G\<^sub>n"])
       (auto simp: G'_def E'_def G\<^sub>n_def finite_graph)
  done

definition
  "is_max_scc S \<equiv>
  S \<subseteq> vertices \<and> S \<noteq> {} \<and> (\<forall>u \<in> S. \<forall>v \<in> S. u \<rightarrow>* v) \<and> (\<forall>u \<in> S. \<forall>v. v \<notin> S \<longrightarrow> \<not>u \<rightarrow>* v \<or> \<not>v \<rightarrow>* u)"

lemma is_max_scc_iff:
  "is_max_scc S \<longleftrightarrow> S \<in> digraph_nodes.sccs_verts"
proof (rule iffI)
  assume "is_max_scc S"
  then show "S \<in> digraph_nodes.sccs_verts"
    unfolding is_max_scc_def digraph_nodes.sccs_verts_def
    by (clarsimp, safe) (auto simp: reachable_iff graph_convs2 invariant_reaches)
next
  assume "S \<in> digraph_nodes.sccs_verts"
  then have "S \<subseteq> vertices"
    using digraph_nodes.sccs_verts_subsets by auto
  then show "is_max_scc S"
    using \<open>S \<in> _\<close> unfolding is_max_scc_def digraph_nodes.sccs_verts_def
    by (auto simp: Graph_Defs.reachable_iff in_mono invariant_reaches reachable_iff)
qed

lemma max_sccI:
  assumes "a \<in> vertices"
  obtains A where "is_max_scc A" "a \<in> A"
  subgoal premises that
    using assms
    by (intro that[of "{b. a \<rightarrow>* b \<and> b \<rightarrow>* a}"])
       (auto intro: invariant_reaches simp: is_max_scc_def, (meson rtranclp_trans)+)
       \<comment> \<open>XXX: graph automation\<close>
  done

lemma is_max_scc_disjoint:
  assumes "is_max_scc V" "is_max_scc W" "V \<noteq> W"
  shows "V \<inter> W = {}"
  using assms unfolding is_max_scc_iff by (rule digraph_nodes.sccs_verts_disjoint)

definition
  "edge V W \<equiv> \<exists>a \<in> V. \<exists>b \<in> W. V \<noteq> W \<and> E a b"

definition
  "scc_num \<equiv> SOME f :: (_ \<Rightarrow> nat).
    inj_on f {V. is_max_scc V} \<and> (\<forall>V. \<forall>W. is_max_scc V \<and> is_max_scc W \<and> edge V W \<longrightarrow> f V < f W)"

interpretation scc_digraph: fin_dag digraph_nodes.scc_graph
  by (rule digraph_nodes.scc_digraphI)

lemma edge_iff:
  "edge x y \<longleftrightarrow> x \<rightarrow>\<^bsub>digraph_nodes.scc_graph\<^esub> y"
  if "x \<in> digraph_nodes.sccs_verts" "y \<in> digraph_nodes.sccs_verts"
  unfolding edge_def
  apply rule
  subgoal
    using that unfolding digraph_nodes.scc_graph_def arcs_ends_def arc_to_ends_def
    unfolding G\<^sub>n_def G'_def E'_def by (auto simp add: vertices_def)
  using subgraph_nodes
  by (auto 4 3 dest!: digraph.adj_mono[rotated] elim!: digraph_nodes.scc_graph_edgeE)

lemma
  shows scc_num_inj: "inj_on scc_num {V. is_max_scc V}" (is ?thesis1)
    and scc_num_topological:
    "\<forall>V. \<forall>W. is_max_scc V \<and> is_max_scc W \<and> edge V W \<longrightarrow> scc_num V < scc_num W" (is ?thesis2)
proof -
  let ?P = "\<lambda>f :: (_ \<Rightarrow> nat).
    inj_on f {V. is_max_scc V} \<and> (\<forall>V. \<forall>W. is_max_scc V \<and> is_max_scc W \<and> edge V W \<longrightarrow> f V < f W)"
  from digraph_nodes.scc_num_inj digraph_nodes.scc_num_topological have "?thesis1 \<and> ?thesis2"
    unfolding scc_num_def by - (rule someI[where P = ?P], auto simp: is_max_scc_iff edge_iff)
  then show ?thesis1 and ?thesis2
    by auto
qed

end

end


section \<open>Maybe monad\<close>

theory Maybe_Monad
imports Monad_Zero_Plus
begin

subsection \<open>Type definition\<close>

tycondef 'a\<cdot>maybe = Nothing | Just (lazy "'a")

lemma coerce_maybe_abs [simp]: "coerce\<cdot>(maybe_abs\<cdot>x) = maybe_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: maybe_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_maybe)
done

lemma coerce_Nothing [simp]: "coerce\<cdot>Nothing = Nothing"
unfolding Nothing_def by simp

lemma coerce_Just [simp]: "coerce\<cdot>(Just\<cdot>x) = Just\<cdot>(coerce\<cdot>x)"
unfolding Just_def by simp

lemma fmapU_maybe_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>maybe) = \<bottom>"
  "fmapU\<cdot>f\<cdot>Nothing = Nothing"
  "fmapU\<cdot>f\<cdot>(Just\<cdot>x) = Just\<cdot>(f\<cdot>x)"
unfolding fmapU_maybe_def maybe_map_def fix_const
apply simp
apply (simp add: Nothing_def)
apply (simp add: Just_def)
done

subsection \<open>Class instance proofs\<close>

instance maybe :: "functor"
apply standard
apply (induct_tac xs rule: maybe.induct, simp_all)
done

instantiation maybe :: "{functor_zero_plus, monad_zero}"
begin

fixrec plusU_maybe :: "udom\<cdot>maybe \<rightarrow> udom\<cdot>maybe \<rightarrow> udom\<cdot>maybe"
  where "plusU_maybe\<cdot>Nothing\<cdot>ys = ys"
  | "plusU_maybe\<cdot>(Just\<cdot>x)\<cdot>ys = Just\<cdot>x"

lemma plusU_maybe_strict [simp]: "plusU\<cdot>\<bottom>\<cdot>ys = (\<bottom>::udom\<cdot>maybe)"
by fixrec_simp

fixrec bindU_maybe :: "udom\<cdot>maybe \<rightarrow> (udom \<rightarrow> udom\<cdot>maybe) \<rightarrow> udom\<cdot>maybe"
  where "bindU_maybe\<cdot>Nothing\<cdot>k = Nothing"
  | "bindU_maybe\<cdot>(Just\<cdot>x)\<cdot>k = k\<cdot>x"

lemma bindU_maybe_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>maybe)"
by fixrec_simp

definition zeroU_maybe_def:
  "zeroU = Nothing"

definition returnU_maybe_def:
  "returnU = Just"

lemma plusU_Nothing_right: "plusU\<cdot>xs\<cdot>Nothing = xs"
by (induct xs rule: maybe.induct) simp_all

lemma bindU_plusU_maybe:
  fixes xs ys :: "udom\<cdot>maybe" shows
  "bindU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>f = plusU\<cdot>(bindU\<cdot>xs\<cdot>f)\<cdot>(bindU\<cdot>ys\<cdot>f)"
apply (induct xs rule: maybe.induct)
apply simp_all
oops

instance proof
  fix x :: "udom"
  fix f :: "udom \<rightarrow> udom"
  fix h k :: "udom \<rightarrow> udom\<cdot>maybe"
  fix xs ys zs :: "udom\<cdot>maybe"
  show "fmapU\<cdot>f\<cdot>xs = bindU\<cdot>xs\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct xs rule: maybe.induct, simp_all add: returnU_maybe_def)
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>k = k\<cdot>x"
    by (simp add: returnU_maybe_def plusU_Nothing_right)
  show "bindU\<cdot>(bindU\<cdot>xs\<cdot>h)\<cdot>k = bindU\<cdot>xs\<cdot>(\<Lambda> x. bindU\<cdot>(h\<cdot>x)\<cdot>k)"
    by (induct xs rule: maybe.induct) simp_all
  show "plusU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>zs = plusU\<cdot>xs\<cdot>(plusU\<cdot>ys\<cdot>zs)"
    by (induct xs rule: maybe.induct) simp_all
  show "bindU\<cdot>zeroU\<cdot>k = zeroU"
    by (simp add: zeroU_maybe_def)
  show "fmapU\<cdot>f\<cdot>(plusU\<cdot>xs\<cdot>ys) = plusU\<cdot>(fmapU\<cdot>f\<cdot>xs)\<cdot>(fmapU\<cdot>f\<cdot>ys)"
    by (induct xs rule: maybe.induct) simp_all
  show "fmapU\<cdot>f\<cdot>zeroU = (zeroU :: udom\<cdot>maybe)"
    by (simp add: zeroU_maybe_def)
  show "plusU\<cdot>zeroU\<cdot>xs = xs"
    by (simp add: zeroU_maybe_def)
  show "plusU\<cdot>xs\<cdot>zeroU = xs"
    by (simp add: zeroU_maybe_def plusU_Nothing_right)
qed

end

subsection \<open>Transfer properties to polymorphic versions\<close>

lemma fmap_maybe_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>maybe) = \<bottom>"
  "fmap\<cdot>f\<cdot>Nothing = Nothing"
  "fmap\<cdot>f\<cdot>(Just\<cdot>x) = Just\<cdot>(f\<cdot>x)"
unfolding fmap_def by simp_all

lemma fplus_maybe_simps [simp]:
  "fplus\<cdot>(\<bottom>::'a\<cdot>maybe)\<cdot>ys = \<bottom>"
  "fplus\<cdot>Nothing\<cdot>ys = ys"
  "fplus\<cdot>(Just\<cdot>x)\<cdot>ys = Just\<cdot>x"
unfolding fplus_def by simp_all

lemma fplus_Nothing_right [simp]:
  "fplus\<cdot>m\<cdot>Nothing = m"
by (simp add: fplus_def plusU_Nothing_right)

lemma bind_maybe_simps [simp]:
  "bind\<cdot>(\<bottom>::'a\<cdot>maybe)\<cdot>f = \<bottom>"
  "bind\<cdot>Nothing\<cdot>f = Nothing"
  "bind\<cdot>(Just\<cdot>x)\<cdot>f = f\<cdot>x"
unfolding bind_def fplus_def by simp_all

lemma return_maybe_def: "return = Just"
unfolding return_def returnU_maybe_def
by (simp add: coerce_cfun cfcomp1 eta_cfun)

lemma mzero_maybe_def: "mzero = Nothing"
unfolding mzero_def zeroU_maybe_def
by simp

lemma join_maybe_simps [simp]:
  "join\<cdot>(\<bottom>::'a\<cdot>maybe\<cdot>maybe) = \<bottom>"
  "join\<cdot>Nothing = Nothing"
  "join\<cdot>(Just\<cdot>xs) = xs"
unfolding join_def by simp_all

subsection \<open>Maybe is not in \<open>monad_plus\<close>\<close>

text \<open>
  The \<open>maybe\<close> type does not satisfy the law \<open>bind_mplus\<close>.
\<close>

lemma maybe_counterexample1:
  "\<lbrakk>a = Just\<cdot>x; b = \<bottom>; k\<cdot>x = Nothing\<rbrakk>
    \<Longrightarrow> fplus\<cdot>a\<cdot>b \<bind> k \<noteq> fplus\<cdot>(a \<bind> k)\<cdot>(b \<bind> k)"
by simp

lemma maybe_counterexample2:
  "\<lbrakk>a = Just\<cdot>x; b = Just\<cdot>y; k\<cdot>x = Nothing; k\<cdot>y = Just\<cdot>z\<rbrakk>
    \<Longrightarrow> fplus\<cdot>a\<cdot>b \<bind> k \<noteq> fplus\<cdot>(a \<bind> k)\<cdot>(b \<bind> k)"
by simp

end