(* ---------------------------------------------------------------------------- *)
section \<open>Introduction\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>The complex plane or some of its parts (e.g., the unit disc or the upper half plane) are often
taken as the domain in which models of various geometries (both Euclidean and non-Euclidean ones)
are formalized. The complex plane gives simpler and more compact formulas than the Cartesian plane.
Within complex plane is easier to describe geometric objects and perform the calculations (usually
shedding some new light on the subject). We give a formalization of the extended complex
plane (given both as a complex projective space and as the Riemann sphere), its objects (points,
circles and lines), and its transformations (Möbius transformations).\<close>

(* ---------------------------------------------------------------------------- *)
section \<open>Related work\<close>
(* ---------------------------------------------------------------------------- *)

text\<open>During the last decade, there have been many results in formalizing
geometry in proof-assistants. Parts of Hilbert’s seminal book
,,Foundations of Geometry'' \cite{hilbert} have been formalized both
in Coq and Isabelle/Isar.  Formalization of first two groups of axioms
in Coq, in an intuitionistic setting was done by Dehlinger et
al. \cite{hilbert-coq}. First formalization in Isabelle/HOL was done
by Fleuriot and Meikele \cite{hilbert-isabelle}, and some further
developments were made in master thesis of Scott \cite{hilbert-scott}.
Large fragments of Tarski's geometry \cite{tarski} have been
formalized in Coq by Narboux et al. \cite{narboux-tarski}. Within Coq,
there are also formalizations of von Plato’s constructive geometry by
Kahn \cite{vonPlato,von-plato-formalization}, French high school
geometry by Guilhot \cite{guilhot} and ruler and compass geometry by
Duprat \cite{duprat2008}, etc.

In our previous work \cite{petrovic2012formalizing}, we have already
formally investigated a Cartesian model of Euclidean geometry.
\<close>

(* ---------------------------------------------------------------------------- *)
section \<open>Background theories\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>In this section we introduce some basic mathematical notions and prove some lemmas needed in the rest of our
formalization. We describe:

    \<^item> trigonometric functions,

    \<^item> complex numbers,

    \<^item> systems of two and three linear equations with two unknowns (over arbitrary fields),

    \<^item> quadratic equations (over real and complex numbers), systems of quadratic and real
      equations, and systems of two quadratic equations,

    \<^item> two-dimensional vectors and matrices over complex numbers.
\<close>

(* -------------------------------------------------------------------------- *)
subsection \<open>Library Additions for Trigonometric Functions\<close>
(* -------------------------------------------------------------------------- *)

theory More_Transcendental
  imports Complex_Main
begin

text \<open>Additional properties of @{term sin} and @{term cos} functions that are later used in proving
conjectures for argument of complex number.\<close>

text \<open>Sign of trigonometric functions on some characteristic intervals.\<close>

lemma cos_lt_zero_on_pi2_pi [simp]:
  assumes "x > pi/2" and "x \<le> pi"
  shows "cos x < 0"
  using cos_gt_zero_pi[of "pi - x"] assms
  by simp

text \<open>Value of trigonometric functions in points $k\pi$ and $\frac{\pi}{2} + k\pi$.\<close>

lemma sin_kpi [simp]:
  fixes k::int
  shows "sin (k * pi) = 0"
  by (simp add: sin_zero_iff_int2)

lemma cos_odd_kpi [simp]:
  fixes k::int
  assumes "odd k"
  shows "cos (k * pi) = -1"
proof (cases "k \<ge> 0")
  case True
  hence "odd (nat k)"
    using  \<open>odd k\<close>
    by (auto simp add: even_nat_iff)
  thus ?thesis
    using \<open>k \<ge> 0\<close> cos_npi[of "nat k"]
    by auto
next
  case False
  hence "-k \<ge> 0" "odd (nat (-k))"
    using \<open>odd k\<close>
    by (auto simp add: even_nat_iff)
  thus ?thesis
    using cos_npi[of "nat (-k)"]
    by auto
qed

lemma cos_even_kpi [simp]:
  fixes k::int
  assumes "even k"
  shows "cos (k * pi) = 1"
proof (cases "k \<ge> 0")
  case True
  hence "even (nat k)"
    using  \<open>even k\<close>
    by (simp add: even_nat_iff)
  thus ?thesis
    using \<open>k \<ge> 0\<close> cos_npi[of "nat k"]
    by auto
next
  case False
  hence "-k \<ge> 0" "even (nat (-k))"
    using \<open>even k\<close>
    by (auto simp add: even_nat_iff)
  thus ?thesis
    using  cos_npi[of "nat (-k)"]
    by auto
qed

lemma sin_pi2_plus_odd_kpi [simp]:
  fixes k::int
  assumes "odd k"
  shows "sin (pi / 2 + k * pi) = -1"
  using assms
  by (simp add: sin_add)

lemma sin_pi2_plus_even_kpi [simp]:
  fixes k::int
  assumes "even k"
  shows "sin (pi / 2 + k * pi) = 1"
  using assms
  by (simp add: sin_add)

text \<open>Solving trigonometric equations and systems with special values (0, 1, or -1) of sine and cosine functions\<close>

lemma cos_0_iff_canon:
  assumes "cos \<phi> = 0" and "-pi < \<phi>" and "\<phi> \<le> pi"
  shows "\<phi> = pi/2 \<or> \<phi> = -pi/2"
proof-
  obtain k::int where "odd k" "\<phi> = k * pi/2"
    using cos_zero_iff_int[of \<phi>] assms(1)
    by auto
  thus ?thesis
  proof (cases "k > 1 \<or> k < -1")
    case True
    hence "k \<ge> 3 \<or> k \<le> -3"
      using \<open>odd k\<close>
      by (smt dvd_refl even_minus)
    hence "\<phi> \<ge> 3*pi/2 \<or> \<phi> \<le> -3*pi/2"
      using mult_right_mono[of k "-3" "pi / 2"]
      using \<open>\<phi> = k * pi/2\<close>
      by auto
    thus ?thesis
      using \<open>- pi < \<phi>\<close> \<open>\<phi> \<le> pi\<close>
      by auto
  next
    case False
    hence "k = -1 \<or> k = 0 \<or> k = 1"
      by auto
    hence "k = -1 \<or> k = 1"
      using \<open>odd k\<close>
      by auto
    thus ?thesis
      using \<open>\<phi> = k * pi/2\<close>
      by auto
  qed
qed

lemma sin_0_iff_canon:
  assumes "sin \<phi> = 0" and "-pi < \<phi>" and "\<phi> \<le> pi"
  shows "\<phi> = 0 \<or> \<phi> = pi"
proof-
  obtain k::int where "even k" "\<phi> = k * pi/2"
    using sin_zero_iff_int[of \<phi>] assms(1)
    by auto
  thus ?thesis
  proof (cases "k > 2 \<or> k < 0")
    case True
    hence "k \<ge> 4 \<or> k \<le> -2"
      using \<open>even k\<close>
      by (smt evenE)
    hence "\<phi> \<ge> 2*pi \<or> \<phi> \<le> -pi"
    proof
      assume "4 \<le> k"
      hence "4 * pi/2 \<le> \<phi>"
        using mult_right_mono[of "4" "k" "pi/2"]
        by (subst \<open>\<phi> = k * pi/2\<close>) auto
      thus ?thesis
        by simp
    next
      assume "k \<le> -2"
      hence "-2*pi/2 \<ge> \<phi>"
        using mult_right_mono[of "k" "-2" "pi/2"]
        by (subst \<open>\<phi> = k * pi/2\<close>, auto)
      thus ?thesis
        by simp
    qed
    thus ?thesis
      using \<open>- pi < \<phi>\<close> \<open>\<phi> \<le> pi\<close>
      by auto
  next
    case False
    hence "k = 0 \<or> k = 1 \<or> k = 2"
      by auto
    hence "k = 0 \<or> k = 2"
      using \<open>even k\<close>
      by auto
    thus ?thesis
      using \<open>\<phi> = k * pi/2\<close>
      by auto
  qed
qed

lemma cos0_sin1:
  assumes "cos \<phi> = 0" and "sin \<phi> = 1"
  shows "\<exists> k::int. \<phi> = pi/2 + 2*k*pi"
proof-
  from \<open>cos \<phi> = 0\<close>
  obtain k::int where "odd k" "\<phi> = k * (pi / 2)"
    using cos_zero_iff_int[of "\<phi>"]
    by auto
  then obtain k'::int where "k = 2*k' + 1"
    using oddE by blast
  hence "\<phi> = pi/2 + (k' * pi)"
    using \<open>\<phi> = k * (pi / 2)\<close>
    by (auto simp add: field_simps)
  hence "even k'"
    using \<open>sin \<phi> = 1\<close> sin_pi2_plus_odd_kpi[of k']
    by auto
  thus ?thesis
    using \<open>\<phi> = pi /2 + (k' * pi)\<close>
    unfolding even_iff_mod_2_eq_zero
    by auto
qed

lemma cos1_sin0:
  assumes "cos \<phi> = 1" and "sin \<phi> = 0"
  shows "\<exists> k::int. \<phi> = 2*k*pi"
proof-
  from \<open>sin \<phi> = 0\<close>
  obtain k::int where "even k" "\<phi> = k * (pi / 2)"
    using sin_zero_iff_int[of "\<phi>"]
    by auto
  then obtain k'::int where "k = 2*k'"
    using evenE by blast
  hence "\<phi> = k' * pi"
    using \<open>\<phi> = k * (pi / 2)\<close>
    by (auto simp add: field_simps)
  hence "even k'"
    using \<open>cos \<phi> = 1\<close> cos_odd_kpi[of k']
    by auto
  thus ?thesis
    using \<open>\<phi> = k' * pi\<close>
    using assms(1) cos_one_2pi_int by auto
qed

(* TODO: add lemmas for cos = -1, sin = 0 and cos = 0, sin = -1 *)

text \<open>Sine is injective on $[-\frac{\pi}{2}, \frac{\pi}{2}]$\<close>

lemma sin_inj:
  assumes "-pi/2 \<le> \<alpha> \<and> \<alpha> \<le> pi/2" and "-pi/2 \<le> \<alpha>' \<and> \<alpha>' \<le> pi/2"
  assumes "\<alpha> \<noteq> \<alpha>'"
  shows "sin \<alpha> \<noteq> sin \<alpha>'"
  using assms
  using sin_monotone_2pi[of \<alpha> \<alpha>'] sin_monotone_2pi[of \<alpha>' \<alpha>]
  by (cases "\<alpha> < \<alpha>'") auto

text \<open>Periodicity of trigonometric functions\<close>

text \<open>The following are available in HOL-Decision\_Procs.Approximation\_Bounds, but we want to avoid
that dependency\<close>

lemma sin_periodic_nat [simp]:
  fixes n :: nat
  shows "sin (x + n * (2 * pi)) = sin x"
proof (induct n arbitrary: x)
  case (Suc n)
  have split_pi_off: "x + (Suc n) * (2 * pi) = (x + n * (2 * pi)) + 2 * pi"
    unfolding Suc_eq_plus1  distrib_right
    by (auto simp add: field_simps)
  show ?case unfolding split_pi_off using Suc by auto
qed auto

lemma sin_periodic_int [simp]:
  fixes i :: int
  shows "sin (x + i * (2 * pi)) = sin x"
proof(cases "0 \<le> i")
  case True
  thus ?thesis
    using sin_periodic_nat[of x "nat i"]
    by auto
next
  case False hence i_nat: "i = - real (nat (-i))" by auto
  have "sin x = sin (x + i * (2 * pi) - i * (2 * pi))" by auto
  also have "\<dots> = sin (x + i * (2 * pi))"
    unfolding i_nat mult_minus_left diff_minus_eq_add by (rule sin_periodic_nat)
  finally show ?thesis by auto
qed

lemma cos_periodic_int [simp]:
  fixes i :: int
  shows "cos (x + i * (2 * pi)) = cos x"
proof(cases "0 \<le> i")
  case True
  thus ?thesis
    using cos_periodic_nat[of x "nat i"]
    by auto
next
  case False hence i_nat: "i = - real (nat (-i))" by auto
  have "cos x = cos (x + i * (2 * pi) - i * (2 * pi))" by auto
  also have "\<dots> = cos (x + i * (2 * pi))"
    unfolding i_nat mult_minus_left diff_minus_eq_add by (rule cos_periodic_nat)
  finally show ?thesis by auto
qed

text \<open>Values of both sine and cosine are repeated only after multiples of $2\cdot \pi$\<close>

lemma sin_cos_eq:
  fixes a b :: real
  assumes "cos a = cos b" and "sin a = sin b"
  shows "\<exists> k::int. a - b = 2*k*pi"
proof-
  from assms have "sin (a - b) = 0" "cos (a - b) = 1"
    using sin_diff[of a b] cos_diff[of a b]
    by auto
  thus ?thesis
    using cos1_sin0
    by auto
qed

text \<open>The following two lemmas are consequences of surjectivity of cosine for the range $[-1, 1]$.\<close>

lemma ex_cos_eq:
  assumes "-pi/2 \<le> \<alpha> \<and> \<alpha> \<le> pi/2"
  assumes "a \<ge> 0" and "a < 1"
  shows "\<exists> \<alpha>'. -pi/2 \<le> \<alpha>' \<and> \<alpha>' \<le> pi/2 \<and> \<alpha>' \<noteq> \<alpha> \<and> cos (\<alpha> - \<alpha>') = a"
proof-
  have "arccos a > 0" "arccos a \<le> pi/2"
    using \<open>a \<ge> 0\<close> \<open>a < 1\<close>
    using arccos_lt_bounded arccos_le_pi2
    by auto

  show ?thesis
  proof (cases "\<alpha> - arccos a \<ge> - pi/2")
    case True
    thus ?thesis
      using assms \<open>arccos a > 0\<close> \<open>arccos a \<le> pi/2\<close>
      by (rule_tac x = "\<alpha> - arccos a" in exI) auto
  next
    case False
    thus ?thesis
      using assms \<open>arccos a > 0\<close> \<open>arccos a \<le> pi/2\<close>
      by (rule_tac x = "\<alpha> + arccos a" in exI) auto
  qed
qed

lemma ex_cos_gt:
  assumes "-pi/2 \<le> \<alpha> \<and> \<alpha> \<le> pi/2"
  assumes "a < 1"
  shows "\<exists> \<alpha>'. -pi/2 \<le> \<alpha>' \<and> \<alpha>' \<le> pi/2 \<and> \<alpha>' \<noteq> \<alpha> \<and> cos (\<alpha> - \<alpha>') > a"
proof-
  have "\<exists> a'. a' \<ge> 0 \<and> a' > a \<and> a' < 1"
    using \<open>a < 1\<close>
    using divide_strict_right_mono[of "2*a + (1 - a)" 2 2]
    by (rule_tac x="if a < 0 then 0 else a + (1-a)/2" in exI) (auto simp add: field_simps)
  then obtain a' where "a' \<ge> 0" "a' > a" "a' < 1"
    by auto
  thus ?thesis
    using ex_cos_eq[of \<alpha> a'] assms
    by auto
qed

text \<open>The function @{term atan2} is a generalization of @{term arctan} that takes a pair of coordinates
of non-zero points returns its angle in the range $[-\pi, \pi)$.\<close>

definition atan2 where
  "atan2 y x =
    (if x > 0 then arctan (y/x)
     else if x < 0 then
          if y > 0 then arctan (y/x) + pi else arctan (y/x) - pi
     else
          if y > 0 then pi/2 else if y < 0 then -pi/2 else 0)"

lemma atan2_bounded:
  shows "-pi \<le> atan2 y x \<and> atan2 y x < pi"
  using arctan_bounded[of "y/x"] zero_le_arctan_iff[of "y/x"] arctan_le_zero_iff[of "y/x"] zero_less_arctan_iff[of "y/x"] arctan_less_zero_iff[of "y/x"]
  using divide_neg_neg[of y x] divide_neg_pos[of y x] divide_pos_pos[of y x]  divide_pos_neg[of y x]
  unfolding atan2_def
  by (simp (no_asm_simp)) auto

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Set_F_cms
imports Set_F CSP.RS
begin

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*********************************************************
                 Restriction in Set_F
 *********************************************************)

(* Isabelle 2009-1
instance setF :: (type) ms0
by (intro_classes)
*)

definition
  restF      :: "'a setF => nat => 'a failure set" ("_ restF _" [84,900] 84)
  where
 restF_def :
   "F restF n == {(s, X) |s X. (s, X) :f F &
                  (lengtht s < n |
                   lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s'))}"

definition
  LimitF     :: "'a setF infinite_seq => 'a failure set"
  where
  LimitF_def :
   "LimitF Fs == {(s, X) |s X.
           ((s, X) :f Fs (Suc (lengtht s)) |
            (s, X) :f Fs (lengtht s) & (EX s'. s = s' ^^^ <Tick> & noTick s'))}"

definition
  Limit_setF :: "'a setF infinite_seq => 'a setF"
  where
  Limit_setF_def :
   "Limit_setF Fs == Abs_setF (LimitF Fs)"

(* isabelle 2009-2 *)

instantiation setF :: (type) rs0
begin

definition
  rest_setF_def : "F .|. n == Abs_setF (F restF n)"

  instance ..

end

(* isabelle 2009-1
defs (overloaded)
  rest_setF_def : "F .|. n == Abs_setF (F restF n)"
*)

(*--------------------------------------------------------*
 |  The reason why restF deals specially with [Tick]      |
 |  can be found in the proof of lemma "restFpair_T3_F4"  |
 |  in Domain_F_cms.thy.                                  |
 *--------------------------------------------------------*)

(*********************************************************
              Lemmas (Restriction in Set_F)
 *********************************************************)

(*** restF_def in setF ***)

lemma restF_in[simp] : "F restF n : setF"
apply (simp add: restF_def)
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)
apply (elim conjE)
apply (rule memF_F2)
by (simp_all)

(*********************************************************
                     .|. on setF
 *********************************************************)

lemma rest_setF_iff: "F .|. n =
                  {f. EX s X. f = (s, X) & (s, X) :f F &
                  (lengtht s < n |
                   lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s'))}f"
apply (simp add: rest_setF_def)
apply (subgoal_tac
    "{(s, X).
     (s, X) :f F &
     (lengtht s < n |
      lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s'))} : setF")
apply (simp add: Abs_setF_inject)
apply (simp add: restF_def)
apply (insert restF_in[simplified restF_def])
apply (auto)
done

lemma in_rest_setF: "(s, X) :f F .|. n =
                 ((s, X) :f F &
                (lengtht s < n |
                 lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s')))"
apply (simp add: memF_def rest_setF_def)
apply (simp add: Abs_setF_inverse)
apply (simp add: memF_def restF_def)
done

lemma rest_setF_eq_iff:
   "(F .|. n = E .|. m) =
    (ALL s X.
         ((s, X) :f F &
          (lengtht s < n |
           lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s')))
       = ((s, X) :f E &
          (lengtht s < m |
           lengtht s = m & (EX s'. s = s' ^^^ <Tick> & noTick s'))))"
apply (simp add: rest_setF_def Abs_setF_inject)
apply (simp add: restF_def)
by (auto)

(*** F .|. = E .|. --> F = E ***)

lemma rest_setF_eq:
  "[| (s, X) :f F ; F restF Suc (lengtht s) =
                    E restF Suc (lengtht s) |]
   ==> (s, X) :f E"
by (auto simp add: restF_def)

(*********************************************************
                     SetF --> RS
 *********************************************************)

(*******************************
        zero_eq_rs_setF
 *******************************)

(*** (contra) restF 0 ***)

lemma contra_zero_setF: "(F::'a setF) restF n ~= {} ==> 0 < n"
apply (simp add: restF_def)
apply (elim conjE exE)
apply (erule disjE)
apply (simp)

apply (elim conjE exE)
by (simp)

(*** restF 0 ***)

lemma zero_setF: "(F::'a setF) restF 0 = {}"
apply (insert contra_zero_setF[of F 0])
apply (case_tac "F restF 0 = {}")
by (simp_all)

(*** zero_eq_rs_setF ***)

lemma zero_rs_setF: "(F::'a setF) .|. 0 = {}f"
apply (simp add: rest_setF_def empF_def Abs_setF_inject)
apply (simp add: zero_setF)
done

lemma zero_eq_rs_setF: "(F::'a setF) .|. 0 = E .|. 0"
by (simp add: zero_rs_setF)

(*******************************
         min_rs_setF
 *******************************)

lemma min_rs_setF:
  "((F::'a setF) .|. m) .|. n = F .|. (min m n)"
apply (simp add: rest_setF_eq_iff)
apply (simp add: in_rest_setF)
apply (intro allI)
apply (rule iffI)

apply (elim conjE exE disjE)
apply (simp_all add: min_is)
apply (rule_tac x="s'" in exI, simp)+

apply (elim conjE exE disjE)
apply (simp_all)

apply (case_tac "m < n")
apply (simp add: min_is)
apply (rule_tac x="s'" in exI, simp)

apply (case_tac "m = n")
apply (simp add: min_is)
apply (rule_tac x="s'" in exI, simp)

apply (case_tac "n < m")
apply (simp add: min_is)
apply (rule_tac x="s'" in exI, simp)

by (force)

(*******************************
        diff_rs_setF
 *******************************)

(*** contra <= ***)

lemma contra_diff_rs_setF_left:
  "(ALL n. (F::'a setF) .|. n = E .|. n) ==> F <= E"
apply (simp add: rest_setF_eq_iff)
apply (rule subsetFI)
apply (drule_tac x="Suc (lengtht s)" in spec)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
by (simp)

(*** contra = ***)

lemma contra_diff_rs_setF:
  "(ALL n. (F::'a setF) .|. n = E .|. n) ==> F = E"
apply (rule order_antisym)
by (simp_all add: contra_diff_rs_setF_left)

(*** diff_rs_setF ***)

lemma diff_rs_setF:
  "(F::'a setF) ~= E ==> (EX (n::nat). F .|. n ~= E .|. n)"
apply (erule contrapos_np)
apply (rule contra_diff_rs_setF)
by (simp)

(***************************************************************
                        setF ==> RS
 ***************************************************************)

instance setF :: (type) rs
apply (intro_classes)
apply (simp add: zero_eq_rs_setF)
apply (simp add: min_rs_setF)
apply (simp add: diff_rs_setF)
done

(************************************************************
                        setF ==> MS
 ************************************************************)

instantiation setF :: (type) ms0
begin

definition
  setF_distance_def:
     "distance (FF::('a setF * 'a setF)) = distance_rs FF"
  instance ..
end

instance setF :: (type) ms
apply (intro_classes)
apply (simp_all add: setF_distance_def)
apply (simp add: diagonal_rs)
apply (simp add: symmetry_rs)
apply (simp add: triangle_inequality_rs)
done

(************************************************************
                 i.e.  setF ==> MS & RS
 ************************************************************)

instance setF :: (type) ms_rs
apply (intro_classes)
apply (simp add: setF_distance_def)
done

(***********************************************************
                      lemmas (Limit)
 ***********************************************************)

(*** normal_seq lemma ***)

lemma normal_seq_setF_less:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht s < n |]
   ==> ((s,X) :f Fs (Suc (lengtht s))) = ((s,X) :f Fs n)"
apply (simp add: normal_def)
apply (drule_tac x="Suc (lengtht s)" in spec)
apply (drule_tac x="n" in spec)
apply (simp add: to_distance_rs)
apply (simp add: distance_rs_le_1[THEN sym])
apply (simp add: min_is)

apply (simp add: rest_setF_eq_iff)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
by (simp)

lemma normal_seq_setF_less_only_if:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht s < n ;
      (s,X) :f Fs (Suc (lengtht s)) |]
   ==> ((s,X) :f Fs n)"
by (simp add: normal_seq_setF_less)

(*** normal_seq lemma (Tick)***)

lemma normal_seq_setF_Tick:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht (s' ^^^ <Tick>) <= n ;
      noTick s' |]
   ==> ((s' ^^^ <Tick>,X) :f Fs (lengtht (s' ^^^ <Tick>))) =
       ((s' ^^^ <Tick>,X) :f Fs n)"
apply (simp add: normal_def)
apply (drule_tac x="lengtht (s' ^^^ <Tick>)" in spec)
apply (drule_tac x="n" in spec)
apply (simp add: to_distance_rs)
apply (simp add: distance_rs_le_1[THEN sym])
apply (simp add: min_is)

apply (simp add: rest_setF_eq_iff)
apply (drule_tac x="s' ^^^ <Tick>" in spec)
apply (drule_tac x="X" in spec)
apply (simp)

apply (rule)
 apply (erule iffE)
 apply (drule mp)
 apply (rule conjI)
 apply (simp)
 apply (simp)
 apply (rule_tac x="s'" in exI)
 apply (simp)
 apply (simp)

 apply (erule iffE)
 apply (rotate_tac -1)
 apply (drule mp)
 apply (rule conjI)
 apply (simp)
 apply (simp)
 apply (rule_tac x="s'" in exI)
 apply (simp)
 apply (simp)
done

lemma normal_seq_setF_Tick_only_if:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht (s' ^^^ <Tick>) <= n ;
      (s' ^^^ <Tick>,X) :f Fs (lengtht (s' ^^^ <Tick>)) ; noTick s' |]
   ==> ((s' ^^^ <Tick>,X) :f Fs n)"
by (simp only: normal_seq_setF_Tick)

lemma normal_seq_setF_Tick_only_ifE:
  "[| (s' ^^^ <Tick>,X) :f Fs n ;
      normal (Fs::'a setF infinite_seq) ; lengtht (s' ^^^ <Tick>) <= n ; noTick s' ;
      (s' ^^^ <Tick>,X) :f Fs (lengtht (s' ^^^ <Tick>)) ==> R |]
   ==> R"
by (simp only: normal_seq_setF_Tick)

(*** LimitF_def in setF ***)

lemma LimitF_in[simp]:
  "LimitF (Fs::'a setF infinite_seq) : setF"
apply (simp add: LimitF_def)
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)
apply (erule conjE)
apply (erule disjE)

apply (rule disjI1)
apply (rule memF_F2)
apply (simp_all)

apply (elim conjE exE)
apply (rule disjI2)
apply (rule memF_F2)
apply (simp_all)
done

(*** Limit_setF_memF ***)

lemma Limit_setF_memF:
  "((s, X) :f Limit_setF Fs) =
   ((s, X) :f Fs (Suc (lengtht s)) |
    (s, X) :f Fs (lengtht s) & (EX s'. s = s' ^^^ <Tick> & noTick s'))"
apply (simp add: Limit_setF_def memF_def)
apply (simp add: Abs_setF_inverse)
apply (simp add: LimitF_def memF_def)
done

(*** Limit_setF lemma ***)

lemma Limit_setF_Limit_lm:
  "normal (Fs::'a setF infinite_seq)
   ==> (ALL n. (Limit_setF Fs) .|. n = (Fs n) .|. n)"
apply (simp add: rest_setF_eq_iff)
apply (intro allI)
apply (simp add: Limit_setF_memF)
apply (rule iffI)

(* => *)
apply (elim conjE disjE)
apply (simp_all add: normal_seq_setF_less)

apply (elim conjE exE)
apply (simp)
apply (erule normal_seq_setF_Tick_only_ifE)
apply (simp_all)

apply (elim conjE exE)
apply (simp)
apply (rule normal_seq_setF_Tick_only_if)
apply (simp_all)

(* <= *)
apply (elim conjE disjE)
apply (simp add: normal_seq_setF_less)
apply (simp)
done

(*** (normal) Fs converges to (Limit_setF Fs) ***)

lemma Limit_setF_Limit:
  "normal (Fs::'a setF infinite_seq) ==> Fs convergeTo (Limit_setF Fs)"
by (simp add: to_distance_rs Limit_setF_Limit_lm rest_Limit)

(*** (cauchy) Fs converges to (Limit_setF NF Fs) ***)

lemma cauchy_Limit_setF_Limit:
  "cauchy (Fs::'a setF infinite_seq) ==> Fs convergeTo (Limit_setF (NF Fs))"
apply (simp add: normal_form_seq_same_Limit)
apply (simp add: Limit_setF_Limit normal_form_seq_normal)
done

(************************************
    SetF --> Complete Metric Space
 ************************************)

lemma setF_cms:
  "cauchy (Fs::'a setF infinite_seq) ==> (EX F. Fs convergeTo F)"
apply (rule_tac x="Limit_setF (NF Fs)" in exI)
by (simp add: cauchy_Limit_setF_Limit)

(************************************************************
                   setF ==> CMS and RS
 ************************************************************)

instance setF :: (type) cms
apply (intro_classes)
by (simp add: setF_cms)

instance setF :: (type) cms_rs
by (intro_classes)

(*** (normal) Limit Fs = Limit_setF Fs ***)

lemma Limit_setF_Limit_eq:
  "normal (Fs::'a setF infinite_seq) ==> Limit Fs = Limit_setF Fs"
apply (insert unique_convergence[of Fs "Limit Fs" "Limit_setF Fs"])
by (simp add:  Limit_setF_Limit Limit_is normal_cauchy)

(*----------------------------------------------------------*
 |                                                          |
 |                       cms rs order                       |
 |                                                          |
 *----------------------------------------------------------*)

instance setF :: (type) ms_rs_order0
apply (intro_classes)
done

instance setF :: (type) ms_rs_order
apply (intro_classes)
apply (intro allI)
apply (rule iffI)
apply (simp add: rest_setF_def)
apply (simp add: subsetF_def)
apply (simp add: Abs_setF_inverse)
apply (fold subsetF_def)
apply (rule)
apply (drule_tac x="Suc (lengtht s)" in spec)
apply (simp add: restF_def)
apply (erule subsetE)
apply (simp)

apply (intro allI)
apply (simp add: rest_setF_def)
apply (simp add: subsetF_def)
apply (simp add: Abs_setF_inverse)
apply (fold subsetF_def)
apply (rule)
apply (simp add: restF_def)
apply (force)
done

instance setF :: (type) cms_rs_order
by (intro_classes)

(*----------------------------------------------------------*
 |                                                          |
 |  i.e. lemma "continuous_rs (Ref_fun (S::'a setF))"       |
 |       by (simp add: continuous_rs_Ref_fun)               |
 |                                                          |
 |  see RS.thy                                              |
 |                                                          |
 *----------------------------------------------------------*)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


theory ArityAnalysisImplSafe
imports ArityAnalysisFixProps ArityAnalysisImpl
begin

interpretation EdomArityAnalysis Aexp by default (rule Aexp_edom')

lemma Aexp_lam_simp[simp]: "Aexp (Lam [x]. e) \<cdot> n = env_delete x (Aexp e \<cdot> (pred \<cdot> n))"
proof-
  have "Aexp (Lam [x]. e) \<cdot> n = Aexp e\<cdot>(pred\<cdot>n) f|` (fv e - {x})" by simp
  also have "... = env_delete x (Aexp e\<cdot>(pred\<cdot>n)) f|` (fv e - {x})" by simp
  also have "\<dots> = env_delete x (Aexp e\<cdot>(pred\<cdot>n))"
     by (rule env_restr_useless) (auto dest: set_mp[OF Aexp_edom])
  finally show ?thesis.
qed
declare Aexp.simps(2)[simp del]

lemma Aexp_let_simp[simp]: "Aexp (Terms.Let \<Gamma> e) \<cdot> n = Afix \<Gamma>\<cdot>(Aexp e\<cdot>n \<squnion> thunks_AE \<Gamma>) f|` (- domA \<Gamma>)"
proof-
  have "Aexp (Terms.Let \<Gamma> e) \<cdot> n  = Afix \<Gamma>\<cdot>(Aexp e\<cdot>n \<squnion> thunks_AE \<Gamma>) f|` fv (Terms.Let \<Gamma> e)" by simp
  also have "\<dots> = Afix \<Gamma>\<cdot>(Aexp e\<cdot>n \<squnion> thunks_AE \<Gamma>) f|` (- domA \<Gamma>) f|` fv (Terms.Let \<Gamma> e)" by auto (metis Diff_eq Diff_idemp)
  also have "\<dots> = Afix \<Gamma>\<cdot>(Aexp e\<cdot>n \<squnion> thunks_AE \<Gamma>) f|` (- domA \<Gamma>)"
     by (rule env_restr_useless)
        (auto dest!: set_mp[OF Aexp_edom] set_mp[OF Afix_edom] set_mp[OF edom_thunks_AE])
  finally show ?thesis.
qed
declare Aexp.simps(4)[simp del]

lemma Aexp_restr_subst:
  assumes "x \<notin> S" and "y \<notin> S"
  shows "(Aexp e[x::=y]\<cdot>a) f|` S = (Aexp e\<cdot>a) f|` S"
using assms
proof (nominal_induct e avoiding: x y  arbitrary: a  S rule: exp_strong_induct_set)
  case (Var v)
  thus ?case by auto
next
  case (App e v)
  thus ?case by (auto simp add: env_restr_join simp del: fun_meet_simp)
next
  case (Lam v e)
  thus ?case
  by (auto simp add: env_restr_join env_delete_env_restr_swap[symmetric]  simp del: fun_meet_simp)
next
  case (Let \<Gamma> e)
  hence "x \<notin> domA \<Gamma> " and "y \<notin> domA \<Gamma>"
    by (metis (erased, hide_lams) bn_subst domA_not_fresh fresh_def fresh_star_at_base fresh_star_def obtain_fresh subst_is_fresh(2))+

  note this[simp] Let(1,2)[simp]

  from Let
  have "Afix \<Gamma>[x::h=y]\<cdot>(Aexp e[x::=y]\<cdot>a \<squnion> thunks_AE \<Gamma>) f|` (S \<union> domA \<Gamma>) = Afix \<Gamma>\<cdot>(Aexp e\<cdot>a \<squnion> thunks_AE \<Gamma>) f|` (S \<union> domA \<Gamma>)"
    apply (auto simp add: fresh_star_Pair)
    apply (subst Afix_restr_subst')
    apply auto[1]
    apply auto[3]
    apply (simp add: env_restr_join)
    apply (subst Afix_restr) back
    apply auto[1]
    apply (simp add: env_restr_join)
    done
  thus ?case using Let(1,2) by (auto simp add: fresh_star_Pair elim:env_restr_eq_subset[rotated])
next
  case (IfThenElse \<Gamma> e)
  then show ?case by (auto simp add: env_restr_join simp del: fun_meet_simp)
qed auto

interpretation ArityAnalysisSafe Aexp
  by default (simp_all add:Aexp_restr_subst)
(*
  fix \<pi>
  show "\<pi> \<bullet> Aexp = Aexp"
    by (rule fun_eqvtI[OF Aexp.eqvt])
next
*)

definition Aheap where
  "Aheap \<Gamma> e = (\<Lambda> a. (Afix \<Gamma> \<cdot> (Aexp e\<cdot>a \<squnion> thunks_AE \<Gamma>) f|` domA \<Gamma>))"

lemma Aheap_eqvt'[eqvt]:
  "\<pi> \<bullet> (Aheap \<Gamma> e) = Aheap (\<pi> \<bullet> \<Gamma>) (\<pi> \<bullet> e)"
  unfolding Aheap_def
  apply perm_simp
  apply (subst Abs_cfun_eqvt)
  apply simp
  apply rule
  done

interpretation ArityAnalysisLetSafe Aexp Aheap
proof default
  fix \<pi> show "\<pi> \<bullet> Aheap = Aheap"
    by perm_simp rule
next
  fix \<Gamma> e a
  show "edom (Aheap \<Gamma> e\<cdot>a) \<subseteq> domA \<Gamma>"
   unfolding Aheap_def by simp
next
  fix x y :: var and \<Gamma> :: heap and e :: exp
  assume assms: "x \<notin> domA \<Gamma>"  "y \<notin> domA \<Gamma>"
  show "Aheap \<Gamma>[x::h=y] e[x::=y] = Aheap \<Gamma> e"
    apply (rule cfun_eqI)
    unfolding Aheap_def
    apply simp
    apply (subst Afix_restr_subst[OF assms subset_refl])
    apply (subst Afix_restr[OF  subset_refl]) back
    apply (simp add: env_restr_join)
    apply (subst Aexp_restr_subst[OF assms])
    apply rule
    done
next
  fix \<Gamma> e a
  show "ABinds \<Gamma>\<cdot>(Aheap \<Gamma> e\<cdot>a) \<squnion> Aexp e\<cdot>a \<sqsubseteq> Aheap \<Gamma> e\<cdot>a \<squnion> Aexp (Let \<Gamma> e)\<cdot>a"
    by (auto simp add: Aheap_def join_below_iff env_restr_join2 Compl_partition intro:  below_trans[OF _ Afix_above_arg])
qed

interpretation ArityAnalysisLetSafeNoCard Aexp Aheap
proof default
  fix x \<Gamma> e a
  assume "x \<in> thunks \<Gamma>"
  hence "up\<cdot>0 \<sqsubseteq> thunks_AE \<Gamma> x" by (metis  thunks_AE_def up_zero_top)
  also have "thunks_AE \<Gamma> \<sqsubseteq> Real_Aexp e\<cdot>a \<squnion> thunks_AE \<Gamma>"
    by simp
  also have "\<dots> \<sqsubseteq> Afix \<Gamma>\<cdot>(Real_Aexp e\<cdot>a \<squnion> thunks_AE \<Gamma>)"
    by (rule Afix_above_arg)
  also have "(Afix \<Gamma>\<cdot>(Real_Aexp e\<cdot>a \<squnion> thunks_AE \<Gamma>)) x = (Aheap \<Gamma> e\<cdot>a) x"
    using set_mp[OF thunks_domA `x \<in> thunks \<Gamma>`] by (simp add: Aheap_def)
  finally
  have "up\<cdot>0 \<sqsubseteq> (Aheap \<Gamma> e\<cdot>a) x" by this simp_all
  thus "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>0" by (metis Arity_above_up_top)
qed

end


(*  Title:      HOL/Metis_Examples/Clausification.thy
    Author:     Jasmin Blanchette, TU Muenchen

Example that exercises Metis's Clausifier.
*)

section {* Example that Exercises Metis's Clausifier *}

theory Clausification
imports Complex_Main
begin

text {* Definitional CNF for facts *}

declare [[meson_max_clauses = 10]]

axiomatization q :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
qax: "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"

declare [[metis_new_skolem = false]]

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis (full_types) qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis (full_types) qax)

declare [[metis_new_skolem]]

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis (full_types) qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis (full_types) qax)

declare [[meson_max_clauses = 60]]

axiomatization r :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
rax: "(r 0 0 \<and> r 0 1 \<and> r 0 2 \<and> r 0 3) \<or>
      (r 1 0 \<and> r 1 1 \<and> r 1 2 \<and> r 1 3) \<or>
      (r 2 0 \<and> r 2 1 \<and> r 2 2 \<and> r 2 3) \<or>
      (r 3 0 \<and> r 3 1 \<and> r 3 2 \<and> r 3 3)"

declare [[metis_new_skolem = false]]

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis rax)

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis (full_types) rax)

declare [[metis_new_skolem]]

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis rax)

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis (full_types) rax)

lemma "(r 0 0 \<and> r 0 1 \<and> r 0 2 \<and> r 0 3) \<or>
       (r 1 0 \<and> r 1 1 \<and> r 1 2 \<and> r 1 3) \<or>
       (r 2 0 \<and> r 2 1 \<and> r 2 2 \<and> r 2 3) \<or>
       (r 3 0 \<and> r 3 1 \<and> r 3 2 \<and> r 3 3)"
by (metis rax)

lemma "(r 0 0 \<and> r 0 1 \<and> r 0 2 \<and> r 0 3) \<or>
       (r 1 0 \<and> r 1 1 \<and> r 1 2 \<and> r 1 3) \<or>
       (r 2 0 \<and> r 2 1 \<and> r 2 2 \<and> r 2 3) \<or>
       (r 3 0 \<and> r 3 1 \<and> r 3 2 \<and> r 3 3)"
by (metis (full_types) rax)

text {* Definitional CNF for goal *}

axiomatization p :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
pax: "\<exists>b. \<forall>a. (p b a \<and> p 0 0 \<and> p 1 a) \<or> (p 0 1 \<and> p 1 0 \<and> p a b)"

declare [[metis_new_skolem = false]]

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis pax)

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis (full_types) pax)

declare [[metis_new_skolem]]

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis pax)

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis (full_types) pax)

text {* New Skolemizer *}

declare [[metis_new_skolem]]

lemma
  fixes x :: real
  assumes fn_le: "!!n. f n \<le> x" and 1: "f ----> lim f"
  shows "lim f \<le> x"
by (metis 1 LIMSEQ_le_const2 fn_le)

definition
  bounded :: "'a::metric_space set \<Rightarrow> bool" where
  "bounded S \<longleftrightarrow> (\<exists>x eee. \<forall>y\<in>S. dist x y \<le> eee)"

lemma "bounded T \<Longrightarrow> S \<subseteq> T ==> bounded S"
by (metis bounded_def subset_eq)

lemma
  assumes a: "Quotient R Abs Rep T"
  shows "symp R"
using a unfolding Quotient_def using sympI
by (metis (full_types))

lemma
  "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
   (\<exists>ys x zs. xs = ys @ x # zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"
by (metis split_list_last_prop[where P = P] in_set_conv_decomp)

lemma ex_tl: "EX ys. tl ys = xs"
using list.sel(3) by fast

lemma "(\<exists>ys\<Colon>nat list. tl ys = xs) \<and> (\<exists>bs\<Colon>int list. tl bs = as)"
by (metis ex_tl)

end


(*  Title:       Implementing field extensions of the form Q[sqrt(b)]
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
section \<open>Auxiliary lemmas which might be moved into the Isabelle distribution.\<close>

theory Real_Impl_Auxiliary
imports
  "HOL-Computational_Algebra.Primes"
begin

lemma multiplicity_prime:
  assumes p: "prime (i :: nat)" and ji: "j \<noteq> i"
  shows "multiplicity j i = 0"
  using assms
  by (metis dvd_refl prime_nat_iff multiplicity_eq_zero_iff
        multiplicity_unit_left multiplicity_zero)

end


theory Rule
  imports Morphism
begin

record ('v\<^sub>1,'e\<^sub>1,'v\<^sub>2,'e\<^sub>2,'v\<^sub>3,'e\<^sub>3,'l,'m) pre_rule =
  lhs    :: "('v\<^sub>1,'e\<^sub>1,'l,'m) pre_graph"
  interf :: "('v\<^sub>2,'e\<^sub>2,'l,'m) pre_graph"
  rhs    :: "('v\<^sub>3,'e\<^sub>3,'l,'m) pre_graph"

locale rule =
  k: injective_morphism "interf r" "lhs r" b +
  r: injective_morphism "interf r" "rhs r" b'
  for r :: "('v\<^sub>1::countable,'e\<^sub>1::countable,'v\<^sub>2::countable,'e\<^sub>2::countable,'v\<^sub>3::countable,'e\<^sub>3::countable,'l,'m) pre_rule" and b b'
begin
(*
lemma lhs_morph_impl_interf:
  assumes g: \<open>injective_morphism (lhs r) G g\<close>
  shows \<open>injective_morphism (interf r) G g\<close>
proof -
  interpret g: injective_morphism \<open>lhs r\<close> G g
    using g by assumption

  show ?thesis
  proof
    show \<open>\<^bsub>g\<^esub>\<^sub>E e \<in> E\<^bsub>G\<^esub>\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that
      sledgehammer
      by (simp add: g.morph_edge_range k.edges_g_in_h)
  next
    show \<open>\<^bsub>g\<^esub>\<^sub>V v \<in> V\<^bsub>G\<^esub>\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using that
      by (simp add: g.morph_node_range k.nodes_g_in_h)
  next
    show \<open>\<^bsub>g\<^esub>\<^sub>V (s\<^bsub>interf r\<^esub> e) = s\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that g.source_preserve k.source_preserve k.edges_g_in_h
      by simp
  next
    show \<open>\<^bsub>g\<^esub>\<^sub>V (t\<^bsub>interf r\<^esub> e) = t\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that g.target_preserve k.target_preserve k.edges_g_in_h
      by simp
  next
    show \<open>l\<^bsub>interf r\<^esub> v = l\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using that k.nodes_g_in_h
      by (simp add: g.label_preserve k.label_preserve)
  next
    show \<open>m\<^bsub>interf r\<^esub> e = m\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that k.edges_g_in_h
      by (simp add: g.mark_preserve k.mark_preserve)
  next
    show \<open>inj_on \<^bsub>g\<^esub>\<^sub>V V\<^bsub>interf r\<^esub>\<close>
      using inj_on_subset[OF g.inj_nodes] k.subset_nodes
      by simp
  next
    show \<open>inj_on \<^bsub>g\<^esub>\<^sub>E E\<^bsub>interf r\<^esub>\<close>
      using inj_on_subset[OF g.inj_edges] k.subset_edges
      by simp
  qed
qed

lemma rhs_morph_impl_interf:
  assumes g: \<open>injective_morphism (rhs r) G g\<close>
  shows \<open>injective_morphism (interf r) G g\<close>
proof -
  interpret g: injective_morphism \<open>rhs r\<close> G g
    using g by assumption

  show ?thesis
  proof
    show \<open>\<^bsub>g\<^esub>\<^sub>E e \<in> E\<^bsub>G\<^esub>\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that g.morph_edge_range r.edges_g_in_h
      by simp
  next
    show \<open>\<^bsub>g\<^esub>\<^sub>V v \<in> V\<^bsub>G\<^esub>\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using that g.morph_node_range r.nodes_g_in_h
      by blast
  next
    show \<open>\<^bsub>g\<^esub>\<^sub>V (s\<^bsub>interf r\<^esub> e) = s\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that g.source_preserve k.source_preserve
      using r.edges_g_in_h r.source_preserve by force
  next
    show \<open>\<^bsub>g\<^esub>\<^sub>V (t\<^bsub>interf r\<^esub> e) = t\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that g.target_preserve k.target_preserve
      using r.edges_g_in_h r.target_preserve by auto
  next
    show \<open>l\<^bsub>interf r\<^esub> v = l\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using that g.label_preserve k.label_preserve r.label_preserve
      using r.nodes_g_in_h by auto
  next
    show \<open>m\<^bsub>interf r\<^esub> e = m\<^bsub>G\<^esub> (\<^bsub>g\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that g.mark_preserve k.mark_preserve
      using r.edges_g_in_h r.mark_preserve by auto
  next
    show \<open>inj_on \<^bsub>g\<^esub>\<^sub>V V\<^bsub>interf r\<^esub>\<close>
      using inj_on_subset[OF g.inj_nodes] r.subset_nodes
      by simp
  next
    show \<open>inj_on \<^bsub>g\<^esub>\<^sub>E E\<^bsub>interf r\<^esub>\<close>
      using inj_on_subset[OF g.inj_edges] r.subset_edges
      by simp
  qed
qed

 *)
end

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Late_Sim
  imports Late_Semantics1 Rel
begin

definition derivative :: "pi \<Rightarrow> pi \<Rightarrow> subject \<Rightarrow> name \<Rightarrow> (pi \<times> pi) set \<Rightarrow> bool" where
  "derivative P Q a x Rel \<equiv> case a of InputS b \<Rightarrow> (\<forall>u. (P[x::=u], Q[x::=u]) \<in> Rel)
                                    | BoundOutputS b \<Rightarrow> (P, Q) \<in> Rel"

definition simulation :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" ("_ \<leadsto>[_] _" [80, 80, 80] 80) where
  "P \<leadsto>[Rel] Q \<equiv> (\<forall>a x Q'. Q \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> Q' \<and> x \<sharp> P \<longrightarrow> (\<exists>P'. P \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> derivative P' Q' a x Rel)) \<and>
                 (\<forall>\<alpha> Q'. Q \<longmapsto>\<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

  assumes "P \<leadsto>[A] P'"
  and     "A \<subseteq> B"

  shows "P \<leadsto>[B] P'"
using assms
apply(auto simp add: simulation_def derivative_def)
by(case_tac a) fastforce+

lemma derivativeMonotonic:
  fixes A :: "(pi \<times> pi) set"
  and   B :: "(pi \<times> pi) set"
  and   P :: pi
  and   Q :: pi
  and   a :: subject
  and   x :: name

  assumes "derivative P Q a x A"
  and     "A \<subseteq> B"

  shows "derivative P Q a x B"
using assms
by(case_tac a, auto simp add: derivative_def)

lemma derivativeEqvtI:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: subject
  and   x    :: name
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes Der: "derivative P Q a x Rel"
  and     Eqvt: "eqvt Rel"

  shows "derivative (perm \<bullet> P) (perm \<bullet> Q) (perm \<bullet> a) (perm \<bullet> x) Rel"
using assms
apply(case_tac a, auto simp add: derivative_def)
apply(erule_tac x="rev perm \<bullet> u" in allE)
apply(drule_tac perm=perm in eqvtRelI)
apply(blast)
apply(force simp add: eqvt_subs name_per_rev)
by(force simp add: eqvt_def)

lemma derivativeEqvtI2:
  fixes P    :: pi
  and   Q    :: pi
  and   a    :: subject
  and   x    :: name
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes Der: "derivative P Q a x Rel"
  and     Eqvt: "eqvt Rel"

  shows "derivative (perm \<bullet> P) (perm \<bullet> Q) a (perm \<bullet> x) Rel"
using assms
apply(case_tac a, auto simp add: derivative_def)
apply(erule_tac x="rev perm \<bullet> u" in allE)
apply(drule_tac perm=perm in eqvtRelI)
apply(blast)
apply(force simp add: eqvt_subs name_per_rev)
by(force simp add: eqvt_def)

lemma freshUnit[simp]:
  fixes y :: name

  shows "y \<sharp> ()"
by(auto simp add: fresh_def supp_unit)

lemma simCasesCont[consumes 1, case_names Bound Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   C   :: "'a::fs_name"

  assumes Eqvt:  "eqvt Rel"
  and     Bound: "\<And>a x Q'. \<lbrakk>Q \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> Q'; x \<sharp> P; x \<sharp> Q; x \<sharp> a; x \<sharp> C\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> derivative P' Q' a x Rel"
  and     Free:  "\<And>\<alpha> Q'. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto>[Rel] Q"
using Free
proof(auto simp add: simulation_def)
  fix a x Q'
  assume "(x::name) \<sharp> P"
  assume Trans: "Q \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> Q'"

  obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> a" and "y \<sharp> C" and "y \<sharp> Q'" and "y \<noteq> x"
    by(generate_fresh "name") auto

  from Trans \<open>y \<sharp> Q'\<close> have "Q \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> [(x, y)] \<bullet> Q'" by(simp add: alphaBoundResidual)
  hence "\<exists>P'. P \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' ([(x, y)] \<bullet> Q') a y Rel"
    using \<open>y \<sharp> P\<close> \<open>y \<sharp> Q\<close> \<open>y \<sharp> a\<close> \<open>y \<sharp> C\<close>
    by(rule Bound)
  then obtain P' where PTrans: "P \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> P'" and PDer: "derivative P' ([(x, y)] \<bullet> Q') a y Rel"
    by blast

  from PTrans \<open>x \<sharp> P\<close> \<open>y \<noteq> x\<close> have "x \<sharp> P'" by(force intro: freshBoundDerivative)
  with PTrans have "P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> [(x, y)] \<bullet> P'" by(simp add: alphaBoundResidual name_swap)
  moreover have "derivative ([(x, y)] \<bullet> P') Q' a x Rel"
  proof -
    from PDer Eqvt have "derivative ([(x, y)] \<bullet> P') ([(x, y)] \<bullet> [(x, y)] \<bullet> Q') a ([(x, y)] \<bullet> y) Rel"
      by(rule derivativeEqvtI2)
    with \<open>y \<noteq> x\<close> show ?thesis by(simp add: name_calc)
  qed
  ultimately show "\<exists>P'. P \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> derivative P' Q' a x Rel" by blast
qed

lemma simCases[case_names Bound Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes Bound: "\<And>a y Q'. \<lbrakk>Q \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> Q'; y \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' Q' a y Rel"
  and     Free:  "\<And>\<alpha> Q'. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "P \<leadsto>[Rel] Q"
using assms
by(auto simp add: simulation_def)

lemma resSimCases[consumes 1, case_names BoundOutput BoundR FreeR]:
  fixes x   :: name
  and   P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   C   :: "'a::fs_name"

  assumes Eqvt:    "eqvt Rel"
  and     BoundO:  "\<And>Q' a. \<lbrakk>Q \<longmapsto>a[x] \<prec> Q'; a \<noteq> x\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto>a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     BR:      "\<And>Q' a y. \<lbrakk>Q \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> Q'; x \<sharp> a; x \<noteq> y; y \<sharp> C\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> P' \<and> derivative P' (<\<nu>x>Q') a y Rel"
  and     BF:      "\<And>Q' \<alpha>. \<lbrakk>Q \<longmapsto>\<alpha> \<prec> Q'; x \<sharp> \<alpha>\<rbrakk> \<Longrightarrow> \<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', <\<nu>x>Q') \<in> Rel"

  shows "P \<leadsto>[Rel] <\<nu>x>Q"
using Eqvt
proof(induct rule: simCasesCont[where C="(C, x, Q)"])
  case(Bound a y Q')
  have "y \<sharp> (C, x, Q)" by fact
  hence yFreshC: "y \<sharp> C" and yineqx: "y \<noteq> x" and "y \<sharp> Q"
    by(simp add: fresh_prod)+
  have "<\<nu>x>Q \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> Q'" by fact
  thus ?case using yineqx \<open>y \<sharp> Q\<close>
  proof(induct rule: resCasesB)
    case(cOpen a' Q')
    have "Q \<longmapsto>a'[x] \<prec> Q'" and "a' \<noteq> x" by fact+
    then obtain P' where PTrans: "P \<longmapsto>a'<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by(force dest: BoundO)

    from PTrans \<open>y \<sharp> P\<close> yineqx have "y \<sharp> P'" by(force dest: freshBoundDerivative)
    with PTrans have "P \<longmapsto>a'<\<nu>y> \<prec> ([(x, y)] \<bullet> P')" by(simp add: alphaBoundResidual)
    moreover from P'RelQ' Eqvt have "([(x, y)] \<bullet> P', [(x, y)] \<bullet> Q') \<in> Rel" by(auto simp add: eqvt_def)
    ultimately show ?case by(force simp add: derivative_def name_swap)
  next
    case(cRes Q')
    have "Q \<longmapsto>a\<guillemotleft>y\<guillemotright> \<prec> Q'" and "x \<sharp> a" by fact+
    with yineqx yFreshC show ?case by(force dest: BR)
  qed
next
  case(Free \<alpha> Q')
  have "<\<nu>x>Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  thus ?case
  proof(induct rule: resCasesF)
    case(cRes Q')
    have "Q \<longmapsto>\<alpha> \<prec> Q'" and "x \<sharp> \<alpha>" by fact+
    thus ?case by(rule BF)
  qed
qed

lemma simE:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   a   :: subject
  and   x   :: name
  and   Q'  :: pi

  assumes "P \<leadsto>[Rel] Q"

  shows "Q \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> P' \<and> (derivative P' Q' a x Rel)"
  and   "Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<longmapsto> \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
using assms by(simp add: simulation_def)+

lemma eqvtI:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes Sim: "P \<leadsto>[Rel] Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel': "eqvt Rel'"

  shows "(perm \<bullet> P) \<leadsto>[Rel'] (perm \<bullet> Q)"
proof(induct rule: simCases)
  case(Bound a y Q')
  have QTrans: "(perm \<bullet> Q) \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> Q'" and yFreshP: "y \<sharp> perm \<bullet> P" by fact+

  from QTrans have "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (a\<guillemotleft>y\<guillemotright> \<prec> Q')"
    by(rule transitions.eqvt)
  hence "Q \<longmapsto> (rev perm \<bullet> a)\<guillemotleft>(rev perm \<bullet> y)\<guillemotright> \<prec> (rev perm \<bullet> Q')"
    by(simp add: name_rev_per)
  moreover from yFreshP have "(rev perm \<bullet> y) \<sharp> P" by(simp add: name_fresh_left)
  ultimately have "\<exists>P'. P \<longmapsto> (rev perm \<bullet> a)\<guillemotleft>rev perm \<bullet> y\<guillemotright> \<prec> P' \<and> derivative P' (rev perm \<bullet> Q') (rev perm \<bullet> a) (rev perm \<bullet> y) Rel" using Sim
    by(force intro: simE)
  then obtain P' where PTrans: "P \<longmapsto> (rev perm \<bullet> a)\<guillemotleft>rev perm \<bullet> y\<guillemotright> \<prec> P'" and Pderivative: "derivative P' (rev perm \<bullet> Q') (rev perm \<bullet> a) (rev perm \<bullet> y) Rel" by blast

  from PTrans have "(perm \<bullet> P) \<longmapsto> perm \<bullet> ((rev perm \<bullet> a)\<guillemotleft>rev perm \<bullet> y\<guillemotright> \<prec> P')" by(rule transitions.eqvt)
  hence L1: "(perm \<bullet> P) \<longmapsto> a\<guillemotleft>y\<guillemotright> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
  from Pderivative RelRel' have "derivative P' (rev perm \<bullet> Q') (rev perm \<bullet> a) (rev perm \<bullet> y) Rel'"
    by(rule derivativeMonotonic)
  hence "derivative (perm \<bullet> P') (perm \<bullet> (rev perm \<bullet> Q')) (perm \<bullet> (rev perm \<bullet> a)) (perm \<bullet> (rev perm \<bullet> y)) Rel'" using EqvtRel'
    by(rule derivativeEqvtI)
  hence "derivative (perm \<bullet> P') Q' a y Rel'" by(simp add: name_per_rev)
  with L1 show ?case by blast
next
  case(Free \<alpha> Q')
  have "(perm \<bullet> Q) \<longmapsto> \<alpha> \<prec> Q'" by fact

  hence "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (\<alpha> \<prec> Q')"
    by(rule transitions.eqvt)
  hence "Q \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> (rev perm \<bullet> Q')"
    by(simp add: name_rev_per)
  with Sim have "\<exists>P'. P \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> P' \<and> (P', (rev perm \<bullet> Q')) \<in> Rel"
    by(force intro: simE)
  then obtain P' where PTrans: "P \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> P'" and PRel: "(P', (rev perm \<bullet> Q')) \<in> Rel"
    by blast

  from PTrans have "(perm \<bullet> P) \<longmapsto> perm \<bullet> ((rev perm \<bullet> \<alpha>)\<prec> P')" by(rule transitions.eqvt)
  hence L1: "(perm \<bullet> P) \<longmapsto> \<alpha> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
  from PRel EqvtRel' RelRel'  have "((perm \<bullet> P'), (perm \<bullet> (rev perm \<bullet> Q'))) \<in> Rel'"
    by(force intro: eqvtRelI)
  hence "((perm \<bullet> P'), Q') \<in> Rel'" by(simp add: name_per_rev)
  with L1 show "\<exists>P'. (perm \<bullet> P) \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel'" by blast
qed

lemma derivativeReflexive:
  fixes P   :: pi
  and   a   :: subject
  and   x   :: name
  and   Rel :: "(pi \<times> pi) set"

  assumes "Id \<subseteq> Rel"

  shows "derivative P P a x Rel"
using assms
apply(cases a)
by(auto simp add: derivative_def)
(*
lemma simActFreeCases[consumes 0, case_names Der]:
  fixes P   :: pi
  and   \<alpha>   :: freeRes
  and   Q'  :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes "\<exists>P'. P \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"

  shows "simAct P (\<alpha> \<prec> Q') P Rel"
using assms
by(simp add: simAct_def residualInject)
*)
(*****************Reflexivity and transitivity*********************)

lemma reflexive:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes "Id \<subseteq> Rel"

  shows "P \<leadsto>[Rel] P"
using assms
by(auto simp add: simulation_def derivativeReflexive)

  assumes PSimQ: "P \<leadsto>[Rel] Q"
  and     QSimR: "Q \<leadsto>[Rel'] R"
  and     Eqvt': "eqvt Rel''"
  and     Trans: "Rel O Rel' \<subseteq> Rel''"

  shows "P \<leadsto>[Rel''] R"
using Eqvt'
proof(induct rule: simCasesCont[where C=Q])
  case(Bound a x R')
  have RTrans: "R \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> R'" by fact

  from \<open>x \<sharp> Q\<close> QSimR RTrans obtain Q' where QTrans: "Q \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> Q'"
                                        and QDer: "derivative Q' R' a x Rel'"
    by(blast dest: simE)
  with QTrans \<open>x \<sharp> P\<close> PSimQ obtain P' where PTrans: "P \<longmapsto> a\<guillemotleft>x\<guillemotright> \<prec> P'"
                                        and PDer: "derivative P' Q' a x Rel"
    by(blast dest: simE)
  moreover from PDer QDer Trans have "derivative P' R' a x Rel''"
    by(cases a) (auto simp add: derivative_def)
  ultimately show ?case by blast
next
  case(Free \<alpha> R')
  have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
  with QSimR obtain Q' where QTrans: "Q \<longmapsto> \<alpha> \<prec> Q'"
                         and Q'RelR': "(Q', R') \<in> Rel'"
    by(blast dest: simE)
  from QTrans PSimQ obtain P' where PTrans: "P \<longmapsto> \<alpha> \<prec> P'"
                                and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: simE)
  from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
  with PTrans show ?case by blast
qed

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(* Title:   System_S
 * Description: High-level security model of the kernel.
 *)

(*
  Naming conventions:
  - Names of sets end with an `s'.
    Hence `rights', `caps', `states'.
    Try to avoid other names that end in `s'.
 *)

theory System_S
imports "Word_Lib.WordSetup"
begin

(* System entities: Definition of entities that constitute the system
 *)

type_synonym entity_id = word32 (* kernel objects - identified by a UID *)

datatype
  right = Read      (* Authorise reading of information *)
         | Write    (* Authorise writing of information *)
         | Take     (* Having sufficient authority to take a capability from another entity *)
         | Grant    (* Having sufficient authority to propagate a capability to another entity *)
         | Create   (* Confers the authority to create new entities *)
         | Store    (* Simulates CNodeCap - get caps of said entity *)

record cap =
  target :: entity_id      (* The entity over which it has control *)
  rights :: "right set"    (* The control it has over that entity  *)

datatype entity = Entity "cap set"
declare entity.splits [split]

type_synonym state = "entity_id \<Rightarrow> entity option"

type_synonym modify_state   = "state \<Rightarrow> state"
type_synonym modify_state_n = "state \<Rightarrow> state set"
type_synonym mask = "right set"

definition
  null_entity :: "entity" where
  "null_entity \<equiv> Entity {}"

definition
  all_rights :: "right set" where
  "all_rights \<equiv> UNIV"

lemma all_rights_def2:
  "all_rights = {Read, Write, Take, Grant, Create, Store}"
  apply (clarsimp simp: all_rights_def, rule, simp_all, rule, simp)
  apply (metis right.exhaust)
  done

definition
  entity_ids :: "state \<Rightarrow> entity_id set" where
  "entity_ids s \<equiv> dom s"

definition
  is_entity :: "state \<Rightarrow> entity_id \<Rightarrow> bool" where
  "is_entity s e \<equiv> s e \<noteq> None"

definition
  exist :: "state \<Rightarrow> cap \<Rightarrow> bool" where
  "exist s c \<equiv> is_entity s (target c)"

(* Manipulating entities. *)
definition
  direct_caps :: "entity \<Rightarrow> cap set"
where
  "direct_caps e \<equiv> case e of (Entity c) \<Rightarrow> c"

definition
  direct_caps_of :: "state \<Rightarrow> entity_id \<Rightarrow> cap set"
where
  "direct_caps_of s p \<equiv>
  case s p of
    None \<Rightarrow> {}
  | Some (Entity e) \<Rightarrow> e"

definition
  store_connected_direct :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "store_connected_direct s \<equiv> {(e\<^sub>x, e\<^sub>y). \<exists>cap. cap \<in> direct_caps_of s e\<^sub>x \<and>
                                               Store \<in> rights cap \<and>
                                               target cap = e\<^sub>y}"

definition
  store_connected :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "store_connected s \<equiv> (store_connected_direct s)^*"

definition
  (* returns all capabilities an entity has access to
    (via store or directly) *)
  caps_of :: "state \<Rightarrow> entity_id \<Rightarrow> cap set" where
  "caps_of s e  \<equiv> \<Union>(direct_caps_of s ` {e' . (e,e') \<in> store_connected s})"

lemma caps_rel:
  "caps_of s e = \<Union>(direct_caps_of s ` store_connected s `` {e})"
  by (simp add: caps_of_def Image_def)

definition  (* All the different capabilities of the system *)
  all_caps_of :: "state \<Rightarrow> cap set" where
  "all_caps_of s \<equiv> \<Union>e. direct_caps_of s e"

definition
  read_cap :: "entity_id \<Rightarrow> cap" where
  "read_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Read}\<rparr>"

definition
  write_cap :: "entity_id \<Rightarrow> cap" where
  "write_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Write}\<rparr>"

definition
  take_cap :: "entity_id \<Rightarrow> cap" where
  "take_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Take}\<rparr>"

definition
  grant_cap :: "entity_id \<Rightarrow> cap" where
  "grant_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Grant}\<rparr>"

definition
  create_cap :: "entity_id \<Rightarrow> cap" where
  "create_cap e\<^sub>x \<equiv> \<lparr>target = e\<^sub>x, rights = {Create}\<rparr>"

definition
  store_cap :: "entity_id \<Rightarrow> cap" where
  "store_cap e \<equiv> \<lparr>target = e, rights = {Store}\<rparr>"

definition
  full_cap :: "entity_id \<Rightarrow> cap" where
  "full_cap e \<equiv> \<lparr>target = e, rights = all_rights \<rparr>"

(* System operations: primitive kernel operations *)

datatype sysOPs =
    SysCreate entity_id cap cap
  | SysTake   entity_id cap cap mask
  | SysGrant  entity_id cap cap mask
  | SysCopy   entity_id cap cap mask
  | SysRemove entity_id cap cap
  | SysRemoveSet entity_id cap "cap set"
  | SysRevoke entity_id cap
  | SysDestroy entity_id cap

(* determine if an operation is allowed in the given state_s *)
primrec
  legal :: "sysOPs \<Rightarrow> state \<Rightarrow> bool"
where
  "legal (SysCreate e c\<^sub>1 c\<^sub>2) s = (is_entity s e \<and> is_entity s (target c\<^sub>1) \<and> \<not> (is_entity s (target c\<^sub>2)) \<and>
                                   {c\<^sub>1, c\<^sub>2} \<subseteq> caps_of s e \<and>
                                   Write \<in> rights c\<^sub>1 \<and> Store \<in> rights c\<^sub>1 \<and> Create \<in> rights c\<^sub>2)"

| "legal (SysTake  e c\<^sub>1 c\<^sub>2 r) s = (is_entity s e \<and>  is_entity s (target c\<^sub>1) \<and>
                                  c\<^sub>1 \<in> caps_of s e \<and> c\<^sub>2 \<in> caps_of s (target c\<^sub>1) \<and> Take \<in> rights c\<^sub>1)"

| "legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s = (is_entity s e \<and>  is_entity s (target c\<^sub>1) \<and>
                                  {c\<^sub>1,c\<^sub>2} \<subseteq> caps_of s e \<and> Grant \<in> rights c\<^sub>1)"

| "legal (SysCopy  e c\<^sub>1 c\<^sub>2 r) s   = (is_entity s e \<and>  is_entity s (target c\<^sub>1) \<and>
                                  {c\<^sub>1,c\<^sub>2} \<subseteq> caps_of s e \<and> Store \<in> rights c\<^sub>1)"

| "legal (SysRemove e c\<^sub>1 c\<^sub>2) s = (is_entity s e \<and> c\<^sub>1 \<in> caps_of s e)"

| "legal (SysRemoveSet e c C) s = (is_entity s e \<and> c \<in> caps_of s e)"

| "legal (SysRevoke e c) s = (is_entity s e \<and> c \<in> caps_of s e)"

| "legal (SysDestroy e c) s = (is_entity s e \<and> c \<in> caps_of s e \<and> {Create} = rights c \<and>
                              target c \<notin> target ` (all_caps_of s - {c}))"

(* Following functions define how each of the sysOPs modifies the
 * system state_s
 *)

definition
  diminish :: "right set \<Rightarrow> cap \<Rightarrow> cap" where
  "diminish R cap \<equiv> cap \<lparr> rights := rights cap \<inter> R \<rparr>"

definition
  createOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> modify_state" where
  "createOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity (insert (full_cap (target c\<^sub>2))
                                (direct_caps_of s (target c\<^sub>1))),
     target c\<^sub>2 \<mapsto> null_entity)"

lemma createOperation_def2:
  "createOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  let new_cap = \<lparr> target = target c\<^sub>2, rights = all_rights \<rparr>;
      newTarget = ({new_cap} \<union> direct_caps_of s (target c\<^sub>1) )
  in
  s (target c\<^sub>1 \<mapsto> Entity newTarget, target c\<^sub>2 \<mapsto> null_entity)"
  by (simp add: createOperation_def Let_def full_cap_def null_entity_def)

definition
  takeOperation :: "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "takeOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (e \<mapsto> Entity (insert (diminish R c\<^sub>2) (direct_caps_of s e)))"

lemma takeOperation_def2:
  "takeOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (e \<mapsto> Entity ({diminish R c\<^sub>2} \<union> direct_caps_of s e))"
  by (clarsimp simp: takeOperation_def caps_of_def)

definition
  grantOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "grantOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity (insert (diminish R c\<^sub>2) (direct_caps_of s (target c\<^sub>1)) )) "

lemma grantOperation_def2:
  "grantOperation e c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity ( {diminish R c\<^sub>2} \<union> direct_caps_of s (target c\<^sub>1)))"
  by (clarsimp simp: grantOperation_def caps_of_def)

definition
  copyOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "copyOperation sRef c\<^sub>1 c\<^sub>2 R s \<equiv>
  s (target c\<^sub>1 \<mapsto> Entity (insert (diminish R c\<^sub>2) (direct_caps_of s (target c\<^sub>1)))) "

definition
  removeOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap \<Rightarrow> modify_state" where
  "removeOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  if is_entity s (target c\<^sub>1)
  then
     s ((target c\<^sub>1) \<mapsto> Entity ((direct_caps_of s (target c\<^sub>1)) - {c\<^sub>2} ))
  else
     s"

lemma removeOperation_simpler:
  "removeOperation e c\<^sub>1 c\<^sub>2 s \<equiv>
  (case s (target c\<^sub>1) of
    None \<Rightarrow> s
  | Some (Entity caps) \<Rightarrow> s (target c\<^sub>1 \<mapsto> Entity (caps - {c\<^sub>2})))"
  by (rule eq_reflection, simp add: removeOperation_def is_entity_def direct_caps_of_def
                             split: if_split_asm option.splits)

definition
  removeSetOperation ::
  "entity_id \<Rightarrow> cap \<Rightarrow> cap set \<Rightarrow> modify_state" where
  "removeSetOperation e c C s \<equiv>
  if is_entity s (target c) then
   s ((target c) \<mapsto> Entity ((direct_caps_of s (target c)) - C ))
  else
   s"

lemma removeSetOperation_simpler:
  "removeSetOperation e c caps s \<equiv>
  (case s (target c) of
    None \<Rightarrow> s
  | Some (Entity caps') \<Rightarrow> s (target c \<mapsto> Entity (caps' - caps)))"
  by (auto simp: removeSetOperation_def is_entity_def direct_caps_of_def
         intro!: eq_reflection
          split: if_split_asm option.splits)

lemma removeSetOperation_fold_removeOperation:
  "removeSetOperation e c (set caps) s = fold (removeOperation e c) caps s"
  apply (subst foldr_fold [symmetric])
   apply (fastforce simp: removeOperation_def direct_caps_of_def is_entity_def)
  apply (rule sym)
  apply (induct caps)
   apply (fastforce simp: removeSetOperation_def removeOperation_def direct_caps_of_def is_entity_def)
  apply (fastforce simp: removeSetOperation_def removeOperation_def direct_caps_of_def is_entity_def)
  done

definition
  removeSetOfCaps :: "(entity_id \<Rightarrow> cap set) \<Rightarrow> modify_state"
where
  "removeSetOfCaps cap_map s \<equiv> \<lambda>e.
     if is_entity s e
     then Some (Entity ((direct_caps_of s e) - cap_map e ))
     else None"

definition
  caps_to_entity :: "entity_id \<Rightarrow> entity_id \<Rightarrow> state \<Rightarrow> cap set"
where
  "caps_to_entity e e' s \<equiv> {cap. cap \<in> direct_caps_of s e' \<and> target cap = e}"

definition
  revokeOperation :: "entity_id \<Rightarrow> cap \<Rightarrow> modify_state_n" where
  "revokeOperation e c s \<equiv>
    {s'. \<exists>cap_map. \<forall>e'. cap_map e' \<subseteq> caps_to_entity (target c) e' s \<and>
         s' = removeSetOfCaps cap_map s}"

definition
  destroyOperation :: "entity_id \<Rightarrow> cap \<Rightarrow> modify_state" where
  "destroyOperation e c s \<equiv> s(target c := None)"

(* Non deterministically executing system calls:
 * How we execute a single operation
 *)
primrec
  step' :: "sysOPs \<Rightarrow> modify_state_n"
where
  "step' (SysCreate    e c\<^sub>1 c\<^sub>2) s   = {createOperation e c\<^sub>1 c\<^sub>2 s}"
| "step' (SysTake      e c\<^sub>1 c\<^sub>2 R) s = {takeOperation  e c\<^sub>1 c\<^sub>2 R s}"
| "step' (SysGrant     e c\<^sub>1 c\<^sub>2 R) s = {grantOperation  e c\<^sub>1 c\<^sub>2 R s}"
| "step' (SysCopy      e c\<^sub>1 c\<^sub>2 R) s = {copyOperation e c\<^sub>1 c\<^sub>2 R s}"
| "step' (SysRemove    e c\<^sub>1 c\<^sub>2)   s = {removeOperation e c\<^sub>1 c\<^sub>2 s}"
| "step' (SysRemoveSet e c C)    s = {removeSetOperation e c C s}"
| "step' (SysRevoke    e c) s      =  revokeOperation e c s"
| "step' (SysDestroy   e c) s      = {destroyOperation e c s}"

(* single operation is allowed only if it is legal in the current state_s *)
definition
  step :: "sysOPs \<Rightarrow> modify_state_n" where
  "step cmd s \<equiv> if legal cmd s then (step' cmd s) \<union> {s} else {s}"

(* execution of a list of commands (from back of list)
 *)
primrec
  execute :: "sysOPs list \<Rightarrow> state \<Rightarrow> state set"
where
  "execute [] s = {s}"
| "execute (cmd#cmds) s = \<Union> (step cmd ` ( execute cmds s ))"

(***************************
 * Lemmas about the model. *
 ***************************)

lemma Int_all_rights [simp]: "c \<inter> all_rights = c"
  by (simp add: all_rights_def)

lemma is_entity_dom: "is_entity s e = (e \<in> dom s)"
  by (simp add: is_entity_def dom_def)

lemma is_entity_imp_not_None:
  "is_entity s e \<Longrightarrow> s e \<noteq> None"
  by (simp add: is_entity_def)

lemma store_connected_refl [simp]:
  "(e, e) \<in> store_connected s"
  by (simp add: store_connected_def)

lemma no_caps_of_imp_not_connected [rule_format]:
  "\<lbrakk>(e, x) \<in> store_connected s\<rbrakk>
  \<Longrightarrow> direct_caps_of s e = {} \<longrightarrow> x = e"
  apply (unfold store_connected_def)
  apply (erule rtrancl.induct)
   apply simp
  apply (clarsimp simp: store_connected_direct_def direct_caps_of_def)
  done

lemma no_direct_caps_of_no_caps_of:
  "(direct_caps_of s e = {}) = (caps_of s e = {})"
  apply (rule iffI)
   apply (clarsimp simp add: caps_of_def)
   apply (drule (1) no_caps_of_imp_not_connected)
   apply simp
  apply (clarsimp simp add: caps_of_def store_connected_def)
  done

lemma no_direct_caps_of_imp_no_caps_of:
  "direct_caps_of s e = {} \<Longrightarrow> caps_of s e = {}"
  by (rule no_direct_caps_of_no_caps_of [THEN iffD1])

lemma no_caps_of_imp_no_direct_caps_of:
  "caps_of s e = {} \<Longrightarrow> direct_caps_of s e = {}"
  by (rule no_direct_caps_of_no_caps_of [THEN iffD2])

lemma store_connected_direct_in_store_connected:
  "(x, y) \<in> store_connected_direct s \<Longrightarrow> (x, y) \<in> store_connected s"
  by (simp add: store_connected_def)

lemma no_diminish [simp]:
  "diminish all_rights c = c"
  by (simp add: diminish_def)

lemma no_diminish_image [simp]:
  "diminish all_rights ` C = C"
  by (fastforce)

lemma diminish_diminish [simp]:
  "diminish dimR2 (diminish dimR1 sc) = diminish (dimR1 \<inter> dimR2) sc"
  by (clarsimp simp add: diminish_def Int_assoc)

lemma diminish_range_diminish [simp]:
  "diminish dimR2 ` diminish dimR1 ` ssc = diminish (dimR1 \<inter> dimR2) ` ssc"
  apply (rule set_eqI)
  apply (rule iffI)
   apply (clarsimp)
  apply (clarsimp simp del: diminish_diminish simp add: diminish_diminish [symmetric])
  done

lemma execute_not_empty:
  "execute ops s \<noteq> {}"
  apply (induct ops)
   apply (simp)
  apply (simp add: step_def del: if_image_distrib, fast)
  done

lemma execute_append [intro]:
  "\<And> s s' s'' opsA. \<lbrakk> s'' \<in> execute opsA s; s' \<in> execute opsB s'' \<rbrakk> \<Longrightarrow> s' \<in> execute (opsB @ opsA) s"
  apply (induct opsB)
   apply (simp)
  apply (atomize)
  apply (clarsimp)
  apply (rule bexI)
   apply (assumption)
  by (drule spec | drule(1) mp)+

(* Lemma on caps *)

lemma heapAdd_read_cap [simp]:
  "target (read_cap e) = e"
  by (simp add: read_cap_def)

lemma rights_read_cap [simp]:
  "rights (read_cap e) = {Read}"
  by (simp add: read_cap_def)

lemma heapAdd_write_cap [simp]:
  "target (write_cap e) = e"
  by (simp add: write_cap_def)

lemma rights_write_cap [simp]:
  "rights (write_cap e) = {Write}"
  by (simp add: write_cap_def)

lemma heapAdd_take_cap [simp]:
  "target (take_cap e) = e"
  by (simp add: take_cap_def)

lemma rights_take_cap [simp]:
  "rights (take_cap e) = {Take}"
  by (simp add: take_cap_def)

lemma heapAdd_grant_cap [simp]:
  "target (grant_cap e) = e"
  by (simp add: grant_cap_def)

lemma rights_grant_cap [simp]:
  "rights (grant_cap e) = {Grant}"
  by (simp add: grant_cap_def)

lemma heapAdd_create_cap [simp]:
  "target (create_cap e) = e"
  by (simp add: create_cap_def)

lemma rights_create_cap [simp]:
  "rights (create_cap e) = {Create}"
  by (simp add: create_cap_def)

lemma heapAdd_store_cap [simp]:
  "target (store_cap e) = e"
  by (simp add: store_cap_def)

lemma rights_store_cap [simp]:
  "rights (store_cap e) = {Store}"
  by (simp add: store_cap_def)

lemma heapAdd_full_cap [simp]:
  "target (full_cap e) = e"
  by (simp add: full_cap_def)

lemma rights_full_cap [simp]:
  "rights (full_cap e) = all_rights"
  by (simp add: full_cap_def)

lemma entity_diminish [simp]:
  "target (diminish R c) = target c"
  by (simp add: diminish_def)

lemma rights_diminish [simp]:
  "rights (diminish R c) = rights c \<inter> R"
  by (simp add: diminish_def)

(* Lemmas on caps_of *)

lemma caps_of_imp_some_direct_cap:
  "c \<in> caps_of s e \<Longrightarrow> \<exists>e'. c \<in> direct_caps_of s e'"
  by (auto simp: caps_of_def)

lemma caps_of_imp_some_store_connected_direct_cap:
  "c \<in> caps_of s e \<Longrightarrow> \<exists>e'. (e, e') \<in> store_connected s \<and> c \<in> direct_caps_of s e'"
  by (auto simp: caps_of_def)

lemma direct_cap_in_cap:
  "c \<in> direct_caps_of s e \<Longrightarrow> c \<in> caps_of s e"
  by (auto simp: caps_of_def store_connected_def)

lemma all_caps_ofE [elim!]:
  "\<lbrakk> c \<in> all_caps_of s; \<And>e'. c \<in> direct_caps_of s e' \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (fastforce simp add: all_caps_of_def)

lemma all_caps_ofI [intro]:
  "c \<in> direct_caps_of s e' \<Longrightarrow> c \<in> all_caps_of s"
  by (fastforce simp add: all_caps_of_def)

(* Lemmas on entities *)

lemma entity_not_not_entity:
  "\<lbrakk>is_entity s e\<^sub>1; \<not> is_entity s e\<^sub>2\<rbrakk> \<Longrightarrow> e\<^sub>1 \<noteq> e\<^sub>2"
  by (auto simp: is_entity_def)

lemma no_direct_caps_of_in_nonEntity:
  "\<not> is_entity s e \<Longrightarrow> direct_caps_of s e = {}"
  by (auto simp: direct_caps_of_def is_entity_def split:option.splits)

lemma not_is_entity_imp_no_direct_caps_of:
  "\<not> is_entity s e \<Longrightarrow> caps_of s e = {}"
  by (drule no_direct_caps_of_in_nonEntity, erule no_direct_caps_of_imp_no_caps_of)

lemma direct_caps_of_imp_is_entity:
  "c \<in> direct_caps_of s e \<Longrightarrow> is_entity s e"
  by (auto intro: classical dest: no_direct_caps_of_in_nonEntity)

lemma caps_of_imp_is_entity:
  "c \<in> caps_of s e \<Longrightarrow> is_entity s e"
  by (auto intro: classical dest: not_is_entity_imp_no_direct_caps_of)

(* Lemmas on store_connected *)

lemma store_caps_of_store_connected_direct:
  "\<lbrakk>c \<in> direct_caps_of s e; Store \<in> rights c\<rbrakk>
  \<Longrightarrow> (e, target c) \<in> store_connected_direct s"
  by (fastforce simp: store_connected_direct_def)

lemma store_caps_store_connected:
  "\<lbrakk>c \<in> caps_of s e; Store \<in> rights c\<rbrakk> \<Longrightarrow> (e, target c) \<in> store_connected s"
  apply (clarsimp simp: store_connected_def caps_of_def)
  by (frule (1) store_caps_of_store_connected_direct, simp)

end


(*  Title:      HOL/Eisbach/Examples.thy
    Author:     Daniel Matichuk, NICTA/UNSW
*)

section \<open>Basic Eisbach examples\<close>

theory Examples
imports Main Eisbach_Tools
begin

subsection \<open>Basic methods\<close>

method my_intros = (rule conjI | rule impI)

lemma "P \<and> Q \<longrightarrow> Z \<and> X"
  apply my_intros+
  oops

method my_intros' uses intros = (rule conjI | rule impI | rule intros)

lemma "P \<and> Q \<longrightarrow> Z \<or> X"
  apply (my_intros' intros: disjI1)+
  oops

method my_spec for x :: 'a = (drule spec[where x="x"])

lemma "\<forall>x. P x \<Longrightarrow> P x"
  apply (my_spec x)
  apply assumption
  done

subsection \<open>Focusing and matching\<close>

method match_test =
  (match premises in U: "P x \<and> Q x" for P Q x \<Rightarrow>
    \<open>print_term P,
     print_term Q,
     print_term x,
     print_fact U\<close>)

lemma "\<And>x. P x \<and> Q x \<Longrightarrow> A x \<and> B x \<Longrightarrow> R x y \<Longrightarrow> True"
  apply match_test  \<comment> \<open>Valid match, but not quite what we were expecting..\<close>
  back  \<comment> \<open>Can backtrack over matches, exploring all bindings\<close>
  back
  back
  back
  back
  back  \<comment> \<open>Found the other conjunction\<close>
  back
  back
  back
  oops

text \<open>Use matching to avoid "improper" methods\<close>

lemma focus_test:
  shows "\<And>x. \<forall>x. P x \<Longrightarrow> P x"
  apply (my_spec "x :: 'a", assumption)?  \<comment> \<open>Wrong x\<close>
  apply (match conclusion in "P x" for x \<Rightarrow> \<open>my_spec x, assumption\<close>)
  done

text \<open>Matches are exclusive. Backtracking will not occur past a match\<close>

method match_test' =
  (match conclusion in
    "P \<and> Q" for P Q \<Rightarrow>
      \<open>print_term P, print_term Q, rule conjI[where P="P" and Q="Q"]; assumption\<close>
    \<bar> "H" for H \<Rightarrow> \<open>print_term H\<close>)

text \<open>Solves goal\<close>
lemma "P \<Longrightarrow> Q \<Longrightarrow> P \<and> Q"
  apply match_test'
  done

text \<open>Fall-through case never taken\<close>
lemma "P \<and> Q"
  apply match_test'?
  oops

lemma "P"
  apply match_test'
  oops

method my_spec_guess =
  (match conclusion in "P (x :: 'a)" for P x \<Rightarrow>
    \<open>drule spec[where x=x],
     print_term P,
     print_term x\<close>)

lemma "\<forall>x. P (x :: nat) \<Longrightarrow> Q (x :: nat)"
  apply my_spec_guess
  oops

method my_spec_guess2 =
  (match premises in U[thin]:"\<forall>x. P x \<longrightarrow> Q x" and U':"P x" for P Q x \<Rightarrow>
    \<open>insert spec[where x=x, OF U],
     print_term P,
     print_term Q\<close>)

lemma "\<forall>x. P x \<longrightarrow> Q x \<Longrightarrow> Q x \<Longrightarrow> Q x"
  apply my_spec_guess2?  \<comment> \<open>Fails. Note that both "P"s must match\<close>
  oops

lemma "\<forall>x. P x \<longrightarrow> Q x \<Longrightarrow> P x \<Longrightarrow> Q x"
  apply my_spec_guess2
  apply (erule mp)
  apply assumption
  done

subsection \<open>Higher-order methods\<close>

method higher_order_example for x methods meth =
  (cases x, meth, meth)

lemma
  assumes A: "x = Some a"
  shows "the x = a"
  by (higher_order_example x \<open>simp add: A\<close>)

subsection \<open>Recursion\<close>

method recursion_example for x :: bool =
  (print_term x,
     match (x) in "A \<and> B" for A B \<Rightarrow>
    \<open>print_term A,
     print_term B,
     recursion_example A,
     recursion_example B | -\<close>)

lemma "P"
  apply (recursion_example "(A \<and> D) \<and> (B \<and> C)")
  oops

subsection \<open>Solves combinator\<close>

lemma "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
  apply (solves \<open>rule conjI\<close>)?  \<comment> \<open>Doesn't solve the goal!\<close>
  apply (solves \<open>rule conjI, assumption, assumption\<close>)
  done

subsection \<open>Demo\<close>

named_theorems intros and elims and subst

method prop_solver declares intros elims subst =
  (assumption |
    rule intros | erule elims |
    subst subst | subst (asm) subst |
    (erule notE; solves prop_solver))+

lemmas [intros] =
  conjI
  impI
  disjCI
  iffI
  notI
lemmas [elims] =
  impCE
  conjE
  disjE

lemma "((A \<or> B) \<and> (A \<longrightarrow> C) \<and> (B \<longrightarrow> C)) \<longrightarrow> C"
  apply prop_solver
  done

method guess_all =
  (match premises in U[thin]:"\<forall>x. P (x :: 'a)" for P \<Rightarrow>
    \<open>match premises in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>
   | match conclusion in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>\<close>)

lemma "(\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> P y \<Longrightarrow> Q y"
  apply guess_all
  apply prop_solver
  done

lemma "(\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> P z \<Longrightarrow> P y \<Longrightarrow> Q y"
  apply (solves \<open>guess_all, prop_solver\<close>)  \<comment> \<open>Try it without solve\<close>
  done

method guess_ex =
  (match conclusion in
    "\<exists>x. P (x :: 'a)" for P \<Rightarrow>
      \<open>match premises in "?H (x :: 'a)" for x \<Rightarrow>
              \<open>rule exI[where x=x]\<close>\<close>)

lemma "P x \<Longrightarrow> \<exists>x. P x"
  apply guess_ex
  apply prop_solver
  done

method fol_solver =
  ((guess_ex | guess_all | prop_solver); solves fol_solver)

declare
  allI [intros]
  exE [elims]
  ex_simps [subst]
  all_simps [subst]

lemma "(\<forall>x. P x) \<and> (\<forall>x. Q x) \<Longrightarrow> (\<forall>x. P x \<and> Q x)"
  and  "\<exists>x. P x \<longrightarrow> (\<forall>x. P x)"
  and "(\<exists>x. \<forall>y. R x y) \<longrightarrow> (\<forall>y. \<exists>x. R x y)"
  by fol_solver+

text \<open>
  Eisbach_Tools provides the catch method, which catches run-time method
  errors. In this example the OF attribute throws an error when it can't
  compose H with A, forcing H to be re-bound to different members of imps
  until it succeeds.
\<close>

lemma
  assumes imps:  "A \<Longrightarrow> B" "A \<Longrightarrow> C" "B \<Longrightarrow> D"
  assumes A: "A"
  shows "B \<and> C"
  apply (rule conjI)
  apply ((match imps in H:"_ \<Longrightarrow> _" \<Rightarrow> \<open>catch \<open>rule H[OF A], print_fact H\<close> \<open>print_fact H, fail\<close>\<close>)+)
  done

text \<open>
  Eisbach_Tools provides the curry and uncurry attributes. This is useful
  when the number of premises of a thm isn't known statically. The pattern
  \<^term>\<open>P \<Longrightarrow> Q\<close> matches P against the major premise of a thm, and Q is the
  rest of the premises with the conclusion. If we first uncurry, then \<^term>\<open>P \<Longrightarrow> Q\<close> will match P with the conjunction of all the premises, and Q with
  the final conclusion of the rule.
\<close>

lemma
  assumes imps: "A \<Longrightarrow> B \<Longrightarrow> C" "D \<Longrightarrow> C" "E \<Longrightarrow> D \<Longrightarrow> A"
  shows "(A \<longrightarrow> B \<longrightarrow> C) \<and> (D \<longrightarrow> C)"
    by (match imps[uncurry] in H[curry]:"_ \<Longrightarrow> C" (cut, multi) \<Rightarrow>
                    \<open>match H in "E \<Longrightarrow> _" \<Rightarrow> fail
                                      \<bar> _ \<Rightarrow> \<open>simp add: H\<close>\<close>)

end