(*  Title:       Reachability implemented using while-loops
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

theory Accessible
imports Main Workset
begin

subsection \<open> accessible\<close>

text \<open> Let's define the set of value that are accessible/reachable from
 a given value using a binary relation. \<close>
definition accessible where
  "accessible R ws \<equiv> R\<^sup>* `` ws"

lemma accessible_empty [simp] :
  "accessible R {} = {}" by (simp add: accessible_def)

lemma accessible_union :
  "accessible R (ws \<union> ws') =
   accessible R ws \<union> accessible R ws'"
unfolding accessible_def by (rule Image_Un)

lemma accessible_Union :
  "accessible R (\<Union> wss) = \<Union> (accessible R ` wss)"
by (auto simp add: accessible_def)

lemma accessible_insert :
  "accessible R (insert x ws) =
   {y. (x, y) \<in> R\<^sup>*} \<union> accessible R ws"
by (auto simp add: accessible_def)

lemma accessible_eq_empty [simp] :
   "(accessible R ws = {}) \<longleftrightarrow> (ws = {})"
unfolding accessible_def by auto

lemma accessible_mono :
  "ws \<subseteq> ws' \<Longrightarrow> (accessible R ws \<subseteq> accessible R ws')"
unfolding accessible_def by auto

lemma accessible_subset_ws :
  "ws \<subseteq> accessible R ws"
by (auto simp add: subset_iff accessible_def)

lemma accessible_insert2 :
  "accessible R (insert x ws) =
   insert x (accessible R (ws \<union> {y. (x, y) \<in> R}))"
apply (auto simp add: accessible_def Image_iff Bex_def)
  apply (metis converse_rtranclE)
apply (metis converse_rtrancl_into_rtrancl)
done

lemma accessible_subset_R_ws_gen :
assumes ws_S: "ws \<subseteq> S"
    and R_S: "\<And>x y. x \<in> S \<and> (x, y) \<in> R \<Longrightarrow> y \<in> S"
shows "accessible R ws \<subseteq> S"
proof -
  have "\<And>x y. \<lbrakk>(x, y) \<in> R\<^sup>*; x \<in> S\<rbrakk> \<Longrightarrow> y \<in> S"
  proof -
    fix x y
    show "\<lbrakk>(x, y) \<in> R\<^sup>*; x \<in> S\<rbrakk> \<Longrightarrow> y \<in> S"
      apply (induct rule: converse_rtrancl_induct)
      apply simp
      apply (metis R_S)
    done
  qed
  thus ?thesis
    unfolding accessible_def
    using ws_S
    by auto
qed

lemma accessible_subset_R_ws: "accessible R ws \<subseteq> snd ` R \<union> ws"
unfolding accessible_def
by (auto simp add: image_iff Bex_def, metis rtranclE)

lemma accessible_finite___args_finite :
assumes fin_R: "finite R"
    and fin_ws: "finite ws"
shows "finite (accessible R ws)"
proof -
  have acc_subset: "accessible R ws \<subseteq> snd ` R \<union> ws"
    by (simp add: accessible_subset_R_ws)

  have "finite (snd ` R \<union> ws)"
    by (simp add: fin_ws fin_R)
  with acc_subset show ?thesis by (metis finite_subset)
qed

lemma accessible_accessible_idempot :
   "(accessible R (accessible R ws)) = accessible R ws"
by (auto simp add: accessible_def Image_iff Bex_def,
    metis rtrancl_trans)

lemma accessible_subset_accessible :
   "accessible R ws1 \<subseteq> accessible R ws2 \<longleftrightarrow>
    ws1 \<subseteq> accessible R ws2"
unfolding accessible_def
by (auto simp add: accessible_def Image_iff Bex_def subset_iff,
    metis rtrancl_trans)

definition accessible_restrict where
  "accessible_restrict R rs ws \<equiv>
   rs \<union> accessible (R - (rs \<times> UNIV)) ws"

lemma accessible_restrict_empty :
  "accessible_restrict R {} ws = accessible R ws"
  by (simp add: accessible_restrict_def)

lemma accessible_restrict_final [simp] :
  "accessible_restrict R rs {} = rs"
  by (simp add: accessible_restrict_def)

lemma accessible_restrict_insert_in :
  "x \<in> rs \<Longrightarrow>
   accessible_restrict R rs (insert x ws) =
   accessible_restrict R rs ws"
unfolding accessible_restrict_def
by (auto simp add: accessible_insert2)

lemma accessible_restrict_diff_rs :
  "accessible_restrict R rs ws =
   accessible_restrict R rs (ws - rs)"
proof -
  { fix x y
    have "\<lbrakk>(x, y) \<in> (R - rs \<times> UNIV)\<^sup>*;y \<notin> rs\<rbrakk> \<Longrightarrow> x \<notin> rs"
    by (erule converse_rtranclE, simp_all)
  }
  thus ?thesis
    unfolding accessible_def accessible_restrict_def Image_def Bex_def
    by auto
qed

lemma accessible_restrict_insert_nin :
  "x \<notin> rs \<Longrightarrow>
   accessible_restrict R rs (insert x ws) =
   accessible_restrict R (insert x rs) (ws \<union> {y. (x, y) \<in> R})"
proof -
  assume x_nin_rs: "x \<notin> rs"
  obtain R_res where R_res_def: "R_res = (\<lambda>rs. (R - (rs \<times> UNIV)))"
    by blast

  have "accessible (R_res (insert x rs)) (ws \<union> {y. (x, y) \<in> R}) =
        accessible (R_res rs) (ws \<union> {y. (x, y) \<in> R})"
        (is "?acc1 = ?acc2")
  proof (intro set_eqI iffI)
    fix e
    assume e_in_acc1: "e \<in> ?acc1"

    have "R_res (insert x rs) \<subseteq> R_res rs" unfolding R_res_def by force
    from rtrancl_mono[OF this] e_in_acc1
      show "e \<in> ?acc2"
      unfolding accessible_def
      by auto
  next
    fix e
    let ?ws' = "ws \<union> {y. (x, y) \<in> R}"

    have ind_part: "\<And>y. \<lbrakk>(y, e) \<in> (R_res rs)\<^sup>*; y \<in> ?ws'\<rbrakk> \<Longrightarrow>
                         \<exists>y'. y' \<in> ?ws' \<and> (y', e) \<in> (R_res (insert x rs))\<^sup>*"
    proof -
      fix y
      show "\<lbrakk>(y, e) \<in> (R_res rs)\<^sup>*; y \<in> ?ws'\<rbrakk> \<Longrightarrow>
             \<exists>y'. y' \<in> ?ws' \<and> (y', e) \<in> (R_res (insert x rs))\<^sup>*"
      proof (induct rule: rtrancl_induct)
        case base thus ?case by auto
      next
        case (step y2 z)
        note y2_z_in_R_res = step(2)
        note ind_hyp = step(3)[OF step(4)]

        show "\<exists>y'. y' \<in> ?ws' \<and> (y', z) \<in> (R_res (insert x rs))\<^sup>*"
        proof (cases "(y2, z) \<in> (R_res (insert x rs))")
          case True with ind_hyp show ?thesis by auto
        next
          case False
          hence "(x, z) \<in> R" using y2_z_in_R_res unfolding R_res_def
            by simp
          hence "z \<in> ?ws'" by simp
          thus ?thesis by auto
        qed
      qed
    qed

    assume e_in_acc2: "e \<in> ?acc2"
    with ind_part show "e \<in> ?acc1"
      by (auto simp add: accessible_def)
  qed

  with x_nin_rs show
   "accessible_restrict R rs (insert x ws) =
    accessible_restrict R (insert x rs) (ws \<union> {y. (x, y) \<in> R})"
    unfolding accessible_restrict_def R_res_def
    by (simp add: accessible_insert2)
qed

lemmas accessible_restrict_insert =
       accessible_restrict_insert_nin accessible_restrict_insert_in

lemma accessible_restrict_union :
  "accessible_restrict R rs (ws \<union> ws') =
   (accessible_restrict R rs ws) \<union> (accessible_restrict R rs ws')"
  unfolding accessible_restrict_def
  by (auto simp add: accessible_union)

lemma accessible_restrict_Union :
  "wss \<noteq> {} \<Longrightarrow>
   accessible_restrict R rs (\<Union> wss) = (\<Union>ws \<in> wss. (accessible_restrict R rs ws))"
  unfolding accessible_restrict_def
  by (simp add: accessible_Union)

lemma accessible_restrict_subset_ws :
  "ws \<subseteq> accessible_restrict R rs ws"
unfolding accessible_restrict_def
using accessible_subset_ws [of ws]
by fast

subsection \<open> Define a new order \<close>

definition bounded_superset_rel where
  "bounded_superset_rel S \<equiv>
   {(x, y). (y \<subset> x \<and> x \<subseteq> S)}"

lemma wf_bounded_superset_rel [simp] :
fixes S :: "'a set"
assumes fin_S: "finite S"
shows "wf (bounded_superset_rel S)"
proof -
  have "bounded_superset_rel S \<subseteq> measure (\<lambda>s. card (S - s))"
  proof
    fix xy :: "'a set \<times> 'a set"
    obtain x y where xy_eq: "xy = (x, y)" by (cases xy, blast)

    assume "xy \<in> bounded_superset_rel S"
    hence "y \<subset> x \<and> x \<subseteq> S" unfolding bounded_superset_rel_def xy_eq
      by simp
    hence "S - x \<subset> S - y" by auto

    hence "card (S - x) < card (S - y)"
      using psubset_card_mono finite_Diff fin_S
      by metis
    thus "xy \<in> measure (\<lambda>s. card (S - s))"
      using xy_eq
      by simp
  qed
  thus ?thesis
    using wf_measure wf_subset
    by metis
qed

subsection \<open> Implementation of Accessible \<close>

text \<open> Now let's implement the algorithm using lists \<close>

definition accessible_worklist_invar where
"accessible_worklist_invar exit R rs S \<equiv> (\<lambda>s.
(rs \<subseteq> snd (fst s)) \<and>
(fst (fst s) = (\<exists>e \<in> (snd (fst s) - rs). exit e)) \<and>
(S = accessible_restrict R (snd (fst s)) (set (snd s))))"

definition accessible_worklist where
  "accessible_worklist exit R rs wl =
   WORKLISTIT (accessible_worklist_invar exit R rs (accessible_restrict R rs (set wl)))
    (\<lambda>s. \<not> (fst s))
    (\<lambda>s e.
       if (e \<in> snd s) then
         (RETURN (s, []))
       else
         do {
           N \<leftarrow> SPEC (\<lambda>wl. set wl = {y. (e,y) \<in> R});
           RETURN ((exit e, insert e (snd s)), N)
         }
     ) ((False, rs), wl)"

lemma accessible_worklist_thm :
fixes R :: "('e \<times> 'e) set" and rs wl
defines "S \<equiv> (accessible_restrict R rs (set wl))"
assumes fin_S: "finite S"
shows "accessible_worklist exit R rs wl \<le>
       SPEC (\<lambda>((ex, rs'), wl').
            (accessible_restrict R rs' (set wl') = S) \<and>
            (ex \<longleftrightarrow> (\<exists>e \<in> rs'-rs. exit e)) \<and> (\<not>ex \<longrightarrow> wl' = []))"
unfolding accessible_worklist_def S_def[symmetric]
proof (rule WORKLISTIT_rule [where R = "inv_image (bounded_superset_rel S) snd"])
  show "accessible_worklist_invar exit R rs S ((False, rs), wl)"
    unfolding accessible_worklist_invar_def S_def
    by simp
next
  show "wf (inv_image (bounded_superset_rel S) snd)"
    using fin_S wf_bounded_superset_rel by simp
next
  fix s
  assume invar: "accessible_worklist_invar exit R rs S (s, [])"
  obtain ex rs' where s_eq[simp]: "s = (ex, rs')" by fastforce

  from invar
  show "(\<lambda>((ex, rs'), wl').
            accessible_restrict R rs' (set wl') = S \<and>
            ex = (\<exists>e\<in>rs' - rs. exit e) \<and> (\<not> ex \<longrightarrow> wl' = []))
         (s, [])"
    unfolding accessible_worklist_invar_def
    by simp
next
  fix s wl
  assume invar: "accessible_worklist_invar exit R rs S (s, wl)"
  assume "\<not> (\<not> fst s)"
  obtain ex rs' where s_eq[simp]: "s = (ex, rs')" by fastforce

  from `\<not>(\<not> fst s)` have "ex = True" by simp

  with invar show "(\<lambda>((ex, rs'), wl').
           accessible_restrict R rs' (set wl') = S \<and>
           ex = (\<exists>e\<in>rs' - rs. exit e) \<and> (\<not> ex \<longrightarrow> wl' = []))
        (s, wl)"
    unfolding accessible_worklist_invar_def
    by simp
next
  fix s wl e
  assume invar: "accessible_worklist_invar exit R rs S (s, e # wl)"
  assume "(\<not> fst s)"
  obtain ex rs' where s_eq[simp]: "s = (ex, rs')" by fastforce

  from `\<not>(fst s)` have not_ex: "ex = False" by simp

  show "(if e \<in> snd s then RETURN (s, [])
        else SPEC (\<lambda>wl. set wl = {y. (e, y) \<in> R}) \<bind>
             (\<lambda>N. RETURN ((exit e, insert e (snd s)), N))) \<le> SPEC
          (\<lambda>s'N.
              accessible_worklist_invar exit R rs S
               (fst s'N, snd s'N @ wl) \<and>
              ((fst s'N, s) \<in> inv_image (bounded_superset_rel S) snd \<or>
               s'N = (s, [])))"
  proof (cases "e \<in> rs'")
    case True note e_in_rs' = this
    with invar have
      "accessible_worklist_invar exit R rs S ((ex, rs'), wl)"
      unfolding accessible_worklist_invar_def workbag_update_def
      by (simp add: accessible_restrict_insert_in)
    with e_in_rs' show ?thesis by simp
  next
    case False note e_nin_rs' = this

    have "S = accessible_restrict R rs' (set (e # wl))" using invar
      unfolding accessible_worklist_invar_def by simp
    moreover
    have "rs' \<subset> insert e rs'" using e_nin_rs' by auto
    moreover
    have "rs' \<subseteq> accessible_restrict R rs' (set (e # wl))" by (simp add: accessible_restrict_def)
    moreover
    have "e \<in> accessible_restrict R rs' (set (e # wl))"
      using accessible_restrict_subset_ws [of "set (e # wl)" R rs']
      by (simp add: subset_iff)
    ultimately have in_R: "(insert e rs', rs') \<in> bounded_superset_rel S"
      unfolding bounded_superset_rel_def
      by simp

    { fix N
      assume N_eq: "set N = {y. (e, y) \<in> R}"

      with invar
      have "accessible_worklist_invar exit R rs S
            ((exit e, insert e rs'), N @ wl)"
        unfolding accessible_worklist_invar_def workbag_update_def
        apply (simp add: accessible_restrict_insert_nin e_nin_rs' Bex_def not_ex subset_iff)
        apply (metis e_nin_rs' Un_commute)
      done
    } note invar' = this

    from e_nin_rs' in_R invar'
    show ?thesis
      by (simp add: subset_iff image_iff pw_le_iff refine_pw_simps)
  qed
qed

end


(*  Title:      HOL/Computational_Algebra/Fraction_Field.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section\<open>A formalization of the fraction field of any integral domain;
         generalization of theory Rat from int to any integral domain\<close>

theory Fraction_Field
imports Main
begin

subsection \<open>General fractions construction\<close>

subsubsection \<open>Construction of the type of fractions\<close>

context idom begin

definition fractrel :: "'a \<times> 'a \<Rightarrow> 'a * 'a \<Rightarrow> bool" where
  "fractrel = (\<lambda>x y. snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x)"

lemma fractrel_iff [simp]:
  "fractrel x y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"
  by (simp add: fractrel_def)

lemma symp_fractrel: "symp fractrel"
  by (simp add: symp_def)

lemma transp_fractrel: "transp fractrel"
proof (rule transpI, unfold split_paired_all)
  fix a b a' b' a'' b'' :: 'a
  assume A: "fractrel (a, b) (a', b')"
  assume B: "fractrel (a', b') (a'', b'')"
  have "b' * (a * b'') = b'' * (a * b')" by (simp add: ac_simps)
  also from A have "a * b' = a' * b" by auto
  also have "b'' * (a' * b) = b * (a' * b'')" by (simp add: ac_simps)
  also from B have "a' * b'' = a'' * b'" by auto
  also have "b * (a'' * b') = b' * (a'' * b)" by (simp add: ac_simps)
  finally have "b' * (a * b'') = b' * (a'' * b)" .
  moreover from B have "b' \<noteq> 0" by auto
  ultimately have "a * b'' = a'' * b" by simp
  with A B show "fractrel (a, b) (a'', b'')" by auto
qed

lemma part_equivp_fractrel: "part_equivp fractrel"
using _ symp_fractrel transp_fractrel
by(rule part_equivpI)(rule exI[where x="(0, 1)"]; simp)

end

quotient_type (overloaded) 'a fract = "'a :: idom \<times> 'a" / partial: "fractrel"
by(rule part_equivp_fractrel)

subsubsection \<open>Representation and basic operations\<close>

lift_definition Fract :: "'a :: idom \<Rightarrow> 'a \<Rightarrow> 'a fract"
  is "\<lambda>a b. if b = 0 then (0, 1) else (a, b)"
  by simp

lemma Fract_cases [cases type: fract]:
  obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0"
by transfer simp

lemma Fract_induct [case_names Fract, induct type: fract]:
  "(\<And>a b. b \<noteq> 0 \<Longrightarrow> P (Fract a b)) \<Longrightarrow> P q"
  by (cases q) simp

lemma eq_fract:
  shows "\<And>a b c d. b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b = Fract c d \<longleftrightarrow> a * d = c * b"
    and "\<And>a. Fract a 0 = Fract 0 1"
    and "\<And>a c. Fract 0 a = Fract 0 c"
by(transfer; simp)+

instantiation fract :: (idom) comm_ring_1
begin

lift_definition zero_fract :: "'a fract" is "(0, 1)" by simp

lemma Zero_fract_def: "0 = Fract 0 1"
by transfer simp

lift_definition one_fract :: "'a fract" is "(1, 1)" by simp

lemma One_fract_def: "1 = Fract 1 1"
by transfer simp

lift_definition plus_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract"
  is "\<lambda>q r. (fst q * snd r + fst r * snd q, snd q * snd r)"
by(auto simp add: algebra_simps)

lemma add_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b + Fract c d = Fract (a * d + c * b) (b * d)"
by transfer simp

lift_definition uminus_fract :: "'a fract \<Rightarrow> 'a fract"
  is "\<lambda>x. (- fst x, snd x)"
by simp

lemma minus_fract [simp]:
  fixes a b :: "'a::idom"
  shows "- Fract a b = Fract (- a) b"
by transfer simp

lemma minus_fract_cancel [simp]: "Fract (- a) (- b) = Fract a b"
  by (cases "b = 0") (simp_all add: eq_fract)

definition diff_fract_def: "q - r = q + - (r::'a fract)"

lemma diff_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
  by (simp add: diff_fract_def)

lift_definition times_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract"
  is "\<lambda>q r. (fst q * fst r, snd q * snd r)"
by(simp add: algebra_simps)

lemma mult_fract [simp]: "Fract (a::'a::idom) b * Fract c d = Fract (a * c) (b * d)"
by transfer simp

lemma mult_fract_cancel:
  "c \<noteq> 0 \<Longrightarrow> Fract (c * a) (c * b) = Fract a b"
by transfer simp

instance
proof
  fix q r s :: "'a fract"
  show "(q * r) * s = q * (r * s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q * r = r * q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "1 * q = q"
    by (cases q) (simp add: One_fract_def eq_fract)
  show "(q + r) + s = q + (r + s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q + r = r + q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "0 + q = q"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "- q + q = 0"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "q - r = q + - r"
    by (cases q, cases r) (simp add: eq_fract)
  show "(q + r) * s = q * s + r * s"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "(0::'a fract) \<noteq> 1"
    by (simp add: Zero_fract_def One_fract_def eq_fract)
qed

end

lemma of_nat_fract: "of_nat k = Fract (of_nat k) 1"
  by (induct k) (simp_all add: Zero_fract_def One_fract_def)

lemma Fract_of_nat_eq: "Fract (of_nat k) 1 = of_nat k"
  by (rule of_nat_fract [symmetric])

lemma fract_collapse:
  "Fract 0 k = 0"
  "Fract 1 1 = 1"
  "Fract k 0 = 0"
by(transfer; simp)+

lemma fract_expand:
  "0 = Fract 0 1"
  "1 = Fract 1 1"
  by (simp_all add: fract_collapse)

lemma Fract_cases_nonzero:
  obtains (Fract) a b where "q = Fract a b" and "b \<noteq> 0" and "a \<noteq> 0"
    | (0) "q = 0"
proof (cases "q = 0")
  case True
  then show thesis using 0 by auto
next
  case False
  then obtain a b where "q = Fract a b" and "b \<noteq> 0" by (cases q) auto
  with False have "0 \<noteq> Fract a b" by simp
  with \<open>b \<noteq> 0\<close> have "a \<noteq> 0" by (simp add: Zero_fract_def eq_fract)
  with Fract \<open>q = Fract a b\<close> \<open>b \<noteq> 0\<close> show thesis by auto
qed

subsubsection \<open>The field of rational numbers\<close>

context idom
begin

subclass ring_no_zero_divisors ..

end

instantiation fract :: (idom) field
begin

lift_definition inverse_fract :: "'a fract \<Rightarrow> 'a fract"
  is "\<lambda>x. if fst x = 0 then (0, 1) else (snd x, fst x)"
by(auto simp add: algebra_simps)

lemma inverse_fract [simp]: "inverse (Fract a b) = Fract (b::'a::idom) a"
by transfer simp

definition divide_fract_def: "q div r = q * inverse (r:: 'a fract)"

lemma divide_fract [simp]: "Fract a b div Fract c d = Fract (a * d) (b * c)"
  by (simp add: divide_fract_def)

instance
proof
  fix q :: "'a fract"
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by (cases q rule: Fract_cases_nonzero)
      (simp_all add: fract_expand eq_fract mult.commute)
next
  fix q r :: "'a fract"
  show "q div r = q * inverse r" by (simp add: divide_fract_def)
next
  show "inverse 0 = (0:: 'a fract)"
    by (simp add: fract_expand) (simp add: fract_collapse)
qed

end

subsubsection \<open>The ordered field of fractions over an ordered idom\<close>

instantiation fract :: (linordered_idom) linorder
begin

lemma less_eq_fract_respect:
  fixes a b a' b' c d c' d' :: 'a
  assumes neq: "b \<noteq> 0"  "b' \<noteq> 0"  "d \<noteq> 0"  "d' \<noteq> 0"
  assumes eq1: "a * b' = a' * b"
  assumes eq2: "c * d' = c' * d"
  shows "((a * d) * (b * d) \<le> (c * b) * (b * d)) \<longleftrightarrow> ((a' * d') * (b' * d') \<le> (c' * b') * (b' * d'))"
proof -
  let ?le = "\<lambda>a b c d. ((a * d) * (b * d) \<le> (c * b) * (b * d))"
  {
    fix a b c d x :: 'a
    assume x: "x \<noteq> 0"
    have "?le a b c d = ?le (a * x) (b * x) c d"
    proof -
      from x have "0 < x * x"
        by (auto simp add: zero_less_mult_iff)
      then have "?le a b c d =
          ((a * d) * (b * d) * (x * x) \<le> (c * b) * (b * d) * (x * x))"
        by (simp add: mult_le_cancel_right)
      also have "... = ?le (a * x) (b * x) c d"
        by (simp add: ac_simps)
      finally show ?thesis .
    qed
  } note le_factor = this

  let ?D = "b * d" and ?D' = "b' * d'"
  from neq have D: "?D \<noteq> 0" by simp
  from neq have "?D' \<noteq> 0" by simp
  then have "?le a b c d = ?le (a * ?D') (b * ?D') c d"
    by (rule le_factor)
  also have "... = ((a * b') * ?D * ?D' * d * d' \<le> (c * d') * ?D * ?D' * b * b')"
    by (simp add: ac_simps)
  also have "... = ((a' * b) * ?D * ?D' * d * d' \<le> (c' * d) * ?D * ?D' * b * b')"
    by (simp only: eq1 eq2)
  also have "... = ?le (a' * ?D) (b' * ?D) c' d'"
    by (simp add: ac_simps)
  also from D have "... = ?le a' b' c' d'"
    by (rule le_factor [symmetric])
  finally show "?le a b c d = ?le a' b' c' d'" .
qed

lift_definition less_eq_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> bool"
  is "\<lambda>q r. (fst q * snd r) * (snd q * snd r) \<le> (fst r * snd q) * (snd q * snd r)"
by (clarsimp simp add: less_eq_fract_respect)

definition less_fract_def: "z < (w::'a fract) \<longleftrightarrow> z \<le> w \<and> \<not> w \<le> z"

lemma le_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
  by transfer simp

lemma less_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
  by (simp add: less_fract_def less_le_not_le ac_simps)

instance
proof
  fix q r s :: "'a fract"
  assume "q \<le> r" and "r \<le> s"
  then show "q \<le> s"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract e f"
    show "Fract a b \<le> Fract e f"
    proof -
      from neq obtain bb: "0 < b * b" and dd: "0 < d * d" and ff: "0 < f * f"
        by (auto simp add: zero_less_mult_iff linorder_neq_iff)
      have "(a * d) * (b * d) * (f * f) \<le> (c * b) * (b * d) * (f * f)"
      proof -
        from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
          by simp
        with ff show ?thesis by (simp add: mult_le_cancel_right)
      qed
      also have "... = (c * f) * (d * f) * (b * b)"
        by (simp only: ac_simps)
      also have "... \<le> (e * d) * (d * f) * (b * b)"
      proof -
        from neq 2 have "(c * f) * (d * f) \<le> (e * d) * (d * f)"
          by simp
        with bb show ?thesis by (simp add: mult_le_cancel_right)
      qed
      finally have "(a * f) * (b * f) * (d * d) \<le> e * b * (b * f) * (d * d)"
        by (simp only: ac_simps)
      with dd have "(a * f) * (b * f) \<le> (e * b) * (b * f)"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by simp
    qed
  qed
next
  fix q r :: "'a fract"
  assume "q \<le> r" and "r \<le> q"
  then show "q = r"
  proof (induct q, induct r)
    fix a b c d :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract a b"
    show "Fract a b = Fract c d"
    proof -
      from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      also have "... \<le> (a * d) * (b * d)"
      proof -
        from neq 2 have "(c * b) * (d * b) \<le> (a * d) * (d * b)"
          by simp
        then show ?thesis by (simp only: ac_simps)
      qed
      finally have "(a * d) * (b * d) = (c * b) * (b * d)" .
      moreover from neq have "b * d \<noteq> 0" by simp
      ultimately have "a * d = c * b" by simp
      with neq show ?thesis by (simp add: eq_fract)
    qed
  qed
next
  fix q r :: "'a fract"
  show "q \<le> q"
    by (induct q) simp
  show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
    by (simp only: less_fract_def)
  show "q \<le> r \<or> r \<le> q"
    by (induct q, induct r)
       (simp add: mult.commute, rule linorder_linear)
qed

end

instantiation fract :: (linordered_idom) linordered_field
begin

definition abs_fract_def2:
  "\<bar>q\<bar> = (if q < 0 then -q else (q::'a fract))"

definition sgn_fract_def:
  "sgn (q::'a fract) = (if q = 0 then 0 else if 0 < q then 1 else - 1)"

theorem abs_fract [simp]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
  unfolding abs_fract_def2 not_le [symmetric]
  by transfer (auto simp add: zero_less_mult_iff le_less)

instance proof
  fix q r s :: "'a fract"
  assume "q \<le> r"
  then show "s + q \<le> s + r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b \<le> Fract c d"
    show "Fract e f + Fract a b \<le> Fract e f + Fract c d"
    proof -
      let ?F = "f * f" from neq have F: "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      from neq le have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      with F have "(a * d) * (b * d) * ?F * ?F \<le> (c * b) * (b * d) * ?F * ?F"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by (simp add: field_simps)
    qed
  qed
next
  fix q r s :: "'a fract"
  assume "q < r" and "0 < s"
  then show "s * q < s * r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b < Fract c d"
    assume gt: "0 < Fract e f"
    show "Fract e f * Fract a b < Fract e f * Fract c d"
    proof -
      let ?E = "e * f" and ?F = "f * f"
      from neq gt have "0 < ?E"
        by (auto simp add: Zero_fract_def order_less_le eq_fract)
      moreover from neq have "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      moreover from neq le have "(a * d) * (b * d) < (c * b) * (b * d)"
        by simp
      ultimately have "(a * d) * (b * d) * ?E * ?F < (c * b) * (b * d) * ?E * ?F"
        by (simp add: mult_less_cancel_right)
      with neq show ?thesis
        by (simp add: ac_simps)
    qed
  qed
qed (fact sgn_fract_def abs_fract_def2)+

end

instantiation fract :: (linordered_idom) distrib_lattice
begin

definition inf_fract_def:
  "(inf :: 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = min"

definition sup_fract_def:
  "(sup :: 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = max"

instance
  by standard (simp_all add: inf_fract_def sup_fract_def max_min_distrib2)

end

lemma fract_induct_pos [case_names Fract]:
  fixes P :: "'a::linordered_idom fract \<Rightarrow> bool"
  assumes step: "\<And>a b. 0 < b \<Longrightarrow> P (Fract a b)"
  shows "P q"
proof (cases q)
  case (Fract a b)
  {
    fix a b :: 'a
    assume b: "b < 0"
    have "P (Fract a b)"
    proof -
      from b have "0 < - b" by simp
      then have "P (Fract (- a) (- b))"
        by (rule step)
      then show "P (Fract a b)"
        by (simp add: order_less_imp_not_eq [OF b])
    qed
  }
  with Fract show "P q"
    by (auto simp add: linorder_neq_iff step)
qed

lemma zero_less_Fract_iff: "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
  by (auto simp add: Zero_fract_def zero_less_mult_iff)

lemma Fract_less_zero_iff: "0 < b \<Longrightarrow> Fract a b < 0 \<longleftrightarrow> a < 0"
  by (auto simp add: Zero_fract_def mult_less_0_iff)

lemma zero_le_Fract_iff: "0 < b \<Longrightarrow> 0 \<le> Fract a b \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: Zero_fract_def zero_le_mult_iff)

lemma Fract_le_zero_iff: "0 < b \<Longrightarrow> Fract a b \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (auto simp add: Zero_fract_def mult_le_0_iff)

lemma one_less_Fract_iff: "0 < b \<Longrightarrow> 1 < Fract a b \<longleftrightarrow> b < a"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma Fract_less_one_iff: "0 < b \<Longrightarrow> Fract a b < 1 \<longleftrightarrow> a < b"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma one_le_Fract_iff: "0 < b \<Longrightarrow> 1 \<le> Fract a b \<longleftrightarrow> b \<le> a"
  by (auto simp add: One_fract_def mult_le_cancel_right)

lemma Fract_le_one_iff: "0 < b \<Longrightarrow> Fract a b \<le> 1 \<longleftrightarrow> a \<le> b"
  by (auto simp add: One_fract_def mult_le_cancel_right)

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>(More) Boolean Algebra\<close>

theory More_Boolean_Algebra
  imports Main
begin

subsection \<open>Laws of Boolean Algebra\<close>

text \<open>The following laws of Boolean algebra support relational proofs. We
might add laws for the binary minus since that would make certain theorems look
more nicely. These are currently not so well supported.\<close>

context boolean_algebra
begin

no_notation
  times (infixl "\<cdot>" 70)
  and plus (infixl "+" 65)
  and Groups.zero_class.zero ("0")
  and Groups.one_class.one ("1")

notation
  inf (infixl "\<cdot>" 70)
  and sup (infixl "+" 65)
  and bot ("0")
  and top ("1")

lemma meet_assoc: "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
by (metis inf_assoc)

lemma aux4 [simp]: "x \<cdot> y + x \<cdot> -y = x"
by (metis inf_sup_distrib1 inf_top_right sup_compl_top)

lemma aux4_comm [simp]: "x \<cdot> -y + x \<cdot> y = x"
by (metis aux4 sup.commute)

lemma aux6 [simp]: "(x + y) \<cdot> -x = y \<cdot> -x"
by (metis inf_compl_bot inf_sup_distrib2 sup_bot_left)

lemma aux6_var [simp]: "(-x + y) \<cdot> x = x \<cdot> y"
by (metis compl_inf_bot inf_commute inf_sup_distrib2 sup_bot_left)

lemma aux9 [simp]: "x + -x \<cdot> y = x + y"
by (metis aux4 aux6 inf.commute inf_sup_absorb)

lemma join_iso: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
by (metis eq_refl sup_mono)

lemma join_isol: "x \<le> y \<Longrightarrow> z + x \<le> z + y"
by (metis join_iso sup.commute)

lemma join_double_iso: "x \<le> y \<Longrightarrow> w + x + z \<le> w + y + z"
by (metis le_iff_inf sup_inf_distrib1 sup_inf_distrib2)

lemma comp_anti: "x \<le> y \<longleftrightarrow> -y \<le> -x"
by (metis compl_le_swap2 double_compl)

lemma meet_iso: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
by (metis eq_refl inf_mono)

lemma meet_isor: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
by (metis inf.commute meet_iso)

lemma meet_double_iso: "x \<le> y \<Longrightarrow> w \<cdot> x \<cdot> z \<le> w \<cdot> y \<cdot> z"
by (metis meet_iso meet_isor)

lemma de_morgan_3 [simp]: "-(-x \<cdot> -y) = x + y"
by (metis compl_sup double_compl)

lemma subdist_2_var: "x + y \<cdot> z \<le> x + y"
by (metis eq_refl inf_le1 sup_mono)

lemma dist_alt: "\<lbrakk>x + z = y + z; x \<cdot> z = y \<cdot> z\<rbrakk> \<Longrightarrow> x = y"
by (metis aux4 aux6 sup.commute)

text \<open>Finally we prove the Galois connections for complementation.\<close>

lemma galois_aux: "x \<cdot> y = 0 \<longleftrightarrow> x \<le> -y"
by (metis aux6 compl_sup double_compl inf.commute le_iff_inf sup_bot_right sup_compl_top)

lemma galois_aux2: "x \<cdot> -y = 0 \<longleftrightarrow> x \<le> y"
by (metis double_compl galois_aux)

lemma galois_1: "x \<cdot> -y \<le> z \<longleftrightarrow> x \<le> y + z"
apply (rule iffI)
 apply (metis inf_le2 join_iso le_iff_sup le_supE join_isol aux4)
apply (metis meet_iso aux6 le_infE)
done

lemma galois_aux3: "x + y = 1 \<longleftrightarrow> -x \<le> y"
by (metis galois_1 inf_top_left top_unique)

lemma galois_aux4: "-x + y = 1 \<longleftrightarrow> x \<le> y"
by (metis double_compl galois_aux3)

subsection \<open>Boolean Algebras with Operators\<close>

text \<open>We follow J\'onsson and Tarski to define pairs of conjugate functions
on Boolean algebras. We also consider material from Maddux's article. This
gives rise to a Galois connection and the notion of Boolean algebras with
operators.

We do not explicitly define families of functions over Boolean algebras as a
type class.

This development should certainly be expanded do deal with complete Boolean
algebras one the one hand and other lattices on the other hand.

Boolean algebras with operators and their variants can be applied in various
ways. The prime example are relation algebras. The modular laws, for instance,
can be derived by instantiation. Other applications are antidomain semirings
where modal operators satisfy conjugations and Galois connections, and algebras
of predicate transformers.\<close>

text\<open>We define conjugation as a predicate which holds if a pair of functions
are conjugates.\<close>

definition is_conjugation :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "is_conjugation f g \<equiv> (\<forall>x y . f x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> g y = 0)"

text \<open>We now prove the standard lemmas. First we show that conjugation is
symmetric and that conjugates are uniqely defined.\<close>

lemma is_conjugation_sym: "is_conjugation f g \<longleftrightarrow> is_conjugation g f"
by (metis inf.commute is_conjugation_def)

text \<open>Next we show that conjugates give rise to adjoints in a Galois
connection.\<close>

lemma conj_galois_1:
  assumes "is_conjugation f g"
  shows "f x \<le> y \<longleftrightarrow> x \<le> -g (-y)"
by (metis assms is_conjugation_def double_compl galois_aux)

lemma conj_galois_2:
  assumes "is_conjugation f g"
  shows "g x \<le> y \<longleftrightarrow> x \<le> -f (-y)"
by (metis assms is_conjugation_sym conj_galois_1)

text \<open>Now we prove some of the standard properties of adjoints and
conjugates. In fact, conjugate functions even distribute over all existing
suprema. We display the next proof in detail because it is elegant.\<close>

lemma f_pre_additive:
  assumes "is_conjugation f g"
  shows "f (x + y) \<le> z \<longleftrightarrow> f x + f y \<le> z"
proof -
  have "f (x + y) \<le> z \<longleftrightarrow> x + y \<le> -g (-z)"
    by (metis assms conj_galois_1)
  also have "... \<longleftrightarrow> x \<le> -g (-z) \<and> y \<le> -g (-z)"
    by (metis le_sup_iff)
  also have "... \<longleftrightarrow> f x \<le> z \<and> f y \<le> z"
    by (metis assms conj_galois_1)
  thus ?thesis
    by (metis le_sup_iff calculation)
qed

lemma f_additive:
  assumes "is_conjugation f g"
  shows "f (sup x y) = sup (f x) (f y)"
by (metis assms eq_iff f_pre_additive)

lemma g_pre_additive:
  assumes "is_conjugation f g"
  shows "g (sup x y) \<le> z \<longleftrightarrow> sup (g x) (g y) \<le> z"
by (metis assms is_conjugation_sym f_pre_additive)

lemma g_additive:
  assumes "is_conjugation f g"
  shows "g (sup x y) = sup (g x) (g y)"
by (metis assms is_conjugation_sym f_additive)

text \<open>Additivity of adjoints obviously implies their isotonicity.\<close>

lemma f_iso:
  assumes "is_conjugation f g"
  shows "x \<le> y \<longrightarrow> f x \<le> f y"
by (metis assms f_additive le_iff_sup)

lemma g_iso:
  assumes "is_conjugation f g"
  shows "x \<le> y \<longrightarrow> g x \<le> g y"
by (metis assms is_conjugation_sym f_iso)

lemma f_subdist:
  assumes "is_conjugation f g"
  shows "f (x \<cdot> y) \<le> f x"
by (metis assms f_iso inf_le1)

lemma g_subdist:
  assumes "is_conjugation f g"
  shows "g (x \<cdot> y) \<le> g x"
by (metis assms g_iso inf_le1)

text \<open>Next we prove cancellation and strictness laws.\<close>

lemma cancellation_1:
  assumes "is_conjugation f g"
  shows "f (-g x) \<le> -x"
by (metis assms conj_galois_1 double_compl eq_refl)

lemma cancellation_2:
  assumes "is_conjugation f g"
  shows "g (-f x) \<le> -x"
by (metis assms is_conjugation_sym cancellation_1)

lemma f_strict:
  assumes "is_conjugation f g"
  shows "f 0 = 0"
by (metis assms inf.idem inf_bot_left is_conjugation_def)

lemma g_strict:
  assumes "is_conjugation f g"
  shows "g 0 = 0"
by (metis assms is_conjugation_sym f_strict)

text \<open>The following variants of modular laws have more concrete counterparts
in relation algebra.\<close>

lemma modular_1_aux:
  assumes "is_conjugation f g"
  shows "f (x \<cdot> -g y) \<cdot> y = 0"
by (metis assms galois_aux inf_le2 is_conjugation_def)

lemma modular_2_aux:
  assumes "is_conjugation f g"
  shows "g (x \<cdot> -f y) \<cdot> y = 0"
by (metis assms is_conjugation_sym modular_1_aux)

lemma modular_1:
  assumes "is_conjugation f g"
  shows "f x \<cdot> y = f (x \<cdot> g y) \<cdot> y"
proof -
  have "f x \<cdot> y = f (x \<cdot> g y + x \<cdot> -g y) \<cdot> y"
    by (metis aux4)
  hence "f x \<cdot> y = (f (x \<cdot> g y) + f (x \<cdot> -g y)) \<cdot> y"
    by (metis assms f_additive)
  hence "f x \<cdot> y = f (x \<cdot> g y) \<cdot> y + f (x \<cdot> -g y) \<cdot> y"
    by (metis inf.commute inf_sup_distrib1)
  thus ?thesis
    by (metis assms modular_1_aux sup_bot_right)
qed

lemma modular_2:
  assumes "is_conjugation f g"
  shows "g x \<cdot> y = g (x \<cdot> f y) \<cdot> y"
by (metis assms is_conjugation_sym modular_1)

lemma conjugate_eq_aux:
  "is_conjugation f g \<Longrightarrow> f (x \<cdot> -g y) \<le> f x \<cdot> -y"
  by (metis f_subdist galois_aux le_inf_iff modular_1_aux)

lemma conjugate_eq:
  "is_conjugation f g \<longleftrightarrow> (\<forall>x y. f (x \<cdot> -g y) \<le> f x \<cdot> -y \<and> g (y \<cdot> -f x) \<le> g y \<cdot> -x)"
    (is "?l \<longleftrightarrow> ?r")
proof
  assume ?l thus ?r
    by (metis is_conjugation_sym conjugate_eq_aux)
next
  assume r: ?r
  have "\<forall>x y. f x \<cdot> y = 0 \<longrightarrow> x \<cdot> g y = 0"
    by (metis aux4 inf.left_commute inf_absorb1 inf_compl_bot inf_left_idem sup_bot_left r)
  hence "\<forall>x y. x \<cdot> g y = 0 \<longleftrightarrow> f x \<cdot> y = 0"
    by (metis aux4 inf.commute inf.left_commute inf_absorb1 inf_compl_bot sup_commute sup_inf_absorb r)
  thus "is_conjugation f g"
    by (metis is_conjugation_def)
qed

lemma conjugation_prop1: "is_conjugation f g \<Longrightarrow> f y \<cdot> z \<le> f (y \<cdot> g z)"
by (metis le_infE modular_1 order_refl)

lemma conjugation_prop2: "is_conjugation f g \<Longrightarrow> g z \<cdot> y \<le> g (z \<cdot> f y)"
by (metis is_conjugation_sym conjugation_prop1)

end (* boolean_algebra *)

end


header {*  Predicate Transformers Semantics of Invariant Diagrams  *}

theory Diagram
imports Hoare
begin

text {*
This theory introduces the concept of a transition diagram and proves
a number of Hoare total corectness rules for these diagrams. As before
the diagrams are introduced using their predicate transformer semantics.

A transition diagram $D$ is a function from pairs of indexes to predicate
transformers: $D:I\times I \to (\mathit{State}\ \mathit{set}\to \mathit{State}\ \mathit{set})$, or more
general $D:I\times I \to \mathit{Ptran}$, where $\mathit{Ptran}$ is a complete lattice. The elements
of $I$ are called situations and intuitively a diagram is executed starting
in a situation $i\in I$ by choosing a transition $D (i,j)$ which is enabled
and continuing similarly from $j$ if there are enabled trasitions. The
execution of a diagram stops when there are no more transitions enabled or
when it fails.

The semantics of a transition diagram is an indexed predicate transformer
($I\to \mathit{State}\ \mathit{set}$).
If $Q:I\to \mathit{State}\ \mathit{set}$ is an indexed predicate, then $p = \mathit{pt}\ D\ Q\ i$ is a
weakest predicate such that if the executution of $D$ starts in a state
$s\in p$ from situation $i$, then it terminates, and if it terminates
in situation $j$ and state $s'$, then $s'\in Q \  j$.

We introduce first the indexed predicate transformer $\mathit{step}\ D$ of executing
one step of diagram $D$. The predicate $step\ D\ Q\ i$ is true for those
states $s$ from which the execution of one step of $D$ starting in situation
$i$ ends in one of the situations $j$ such that $Q \, j$ is true.

*}

definition
  "step D Q i = (INF j . D (i, j) (Q j) :: _ :: complete_lattice)"

definition
  "dmono D = (\<forall> ij . mono (D ij))"

lemma dmono_mono [simp]: "dmono D \<Longrightarrow> mono (D ij)"
  by (simp add: dmono_def)

theorem mono_step [simp]:
  "dmono D \<Longrightarrow> mono (step D)"
  apply (simp add: dmono_def mono_def le_fun_def step_def Inf_fun_def)
  apply auto
  apply (rule INF_greatest)
  apply auto
  apply (rule_tac y = "D(xa, j) (x j)" in order_trans)
  apply auto
  apply (rule INF_lower)
  by auto

text {*
The indexed predicate transformer of a transition diagram is defined as the least
fixpoint of the unfolding of the execution of the diagram. The indexed predicate
transformer $dgr\ D\ U$ is the choice between executing one step of $D$ follwed by
$U$ ($(\mathit{step}\ D)\circ U$) or skip if no transion of $D$ is enabled
($\mathit{assume}\ \neg \mathit{grd} (\mathit{step}\ D)$).
*}

definition
  "dgr D U = ((step D) o U) \<sqinter> [.-(grd (step D)).]"

theorem mono_mono_dgr [simp]: "dmono D \<Longrightarrow> mono_mono (dgr D)"
  apply (simp add: mono_mono_def mono_def)
  apply safe
  apply (simp_all add: dgr_def)
  apply (simp_all add: le_fun_def inf_fun_def)
  apply safe
  apply (rule_tac y = "(step D (x xa) xb)" in order_trans)
  apply simp_all
  apply (case_tac "mono (step D)")
  apply (simp add: mono_def)
  apply (simp add: le_fun_def)
  apply simp
  apply (rule_tac y = "(step D (f x) xa)" in order_trans)
  apply simp_all
  apply (case_tac "mono (step D)")
  apply (simp add: mono_def)
  apply (simp_all add: le_fun_def)
  apply (rule_tac y = "(assume (- grd (step D)) x xa)" in order_trans)
  apply simp_all
  apply (case_tac "mono (assume (- grd (step D)))")
  apply (simp add: mono_def le_fun_def)
  by simp

definition
  "pt D = lfp (dgr D)"

text {*
If $U$ is an indexed predicate transformer and if $P, Q:I\to \mathit{State} \ \mathit{set}$
are indexed predicates, then the meaning of the Hoare triple defined earlier,
$\models P \{ | U | \} Q$, is that if
we start $U$ in a state $s$ from a situation $i$ such that $s\in P\, i$,
then U terminates, and if it terminates in $s'$ and situation $j$, then
$s'\in Q\ j$ is true.

Next theorem shows that in a diagram all transitions are correct
if and only if $\mathit{step}\ D$ is correct.
*}

theorem hoare_step:
  "(\<forall> i j . \<Turnstile> (P i) {| D(i,j) |} (Q j) ) = (\<Turnstile> P {| step D |} Q)"
  apply safe
  apply (simp add: le_fun_def Hoare_def step_def)
  apply safe
  apply (rule INF_greatest)
  apply auto
  apply (simp add: le_fun_def Hoare_def step_def)
  apply (erule_tac x = i in allE)
  apply (rule_tac y = "INF j. D(i, j) (Q j)" in order_trans)
  apply auto
  apply (rule INF_lower)
  by auto

text {*
Next theorem provides the first proof rule for total correctnes of transition
diagrams. If all transitions are correct and if a global variant decreases
on every transition then the diagram is correct and it terminates. The variant
must decrease according to a well founded and transitive relation.
*}

theorem hoare_diagram:
  "dmono D \<Longrightarrow> (\<forall> w i j . \<Turnstile> X w i  {| D(i,j) |} Sup_less X w j) \<Longrightarrow>
    \<Turnstile> (Sup (range X)) {| pt D |} (Sup(range X) \<sqinter> -(grd (step D)))"
  apply (simp add: hoare_step pt_def del: Sup_image_eq)
  apply (rule hoare_fixpoint)
  apply auto
  apply (simp add: dgr_def)
  apply (simp add: hoare_choice)
  apply safe
  apply (simp add: hoare_sequential)
  apply auto
  apply (simp add: hoare_assume)
  apply (rule le_infI1)
  by (rule SUP_upper, auto)

text{*
This theorem is a more general form of the more familiar form with a variant $t$
which must decrease. If we take $X\ w\ i = (Y \ i \land t\ i = w)$, then the
second hypothesis of the theorem above becomes
$\models Y \ i \land t\ i = w \{| D(i,j) |\} Y \ i \land t \ i < w$. However,
the more general form of the theorem is needed, because
in data refinements, the form $Y\ i \land t\ i = w$ cannot be preserved.
*}

text {*
The drawback of this theorem is that the variant must be decreased on every
transitions which may be too cumbersome for practical applications. A similar
situation occur when introducing proof rules for mutually recursive procedures.
There the straightforward generalization of the proof rule of a recursive procedure
to mutually recursive procedures suffers of a similar problem. We would need
to prove that the variant decreases before every recursive call. Nipkow
\cite{nipkow:2002} has introduced a rule for mutually recursive procedures
in which the variant is required to decrease only in a sequence of recursive
calls before calling again a procedure in this sequence. We introduce a
similar proof rule in which the variant depends also on the situation
indexes.
*}

locale DiagramTermination =
  fixes pair:: "'a \<Rightarrow> 'b \<Rightarrow> ('c::well_founded_transitive)"
begin

definition
  "SUP_L_P X u i = (SUP v:{v. pair v i < u}. X v i :: _ :: complete_lattice)"

definition
  "SUP_LE_P X u i = (SUP v:{v. pair v i \<le> u}. X v i :: _ :: complete_lattice)"

lemma SUP_L_P_upper:
  "pair v i < u \<Longrightarrow> P v i \<le> SUP_L_P P u i"
  by (auto simp add: SUP_L_P_def intro: SUP_upper)

lemma SUP_L_P_least:
  "(!! v . pair v i < u \<Longrightarrow> P v i \<le> Q) \<Longrightarrow> SUP_L_P P u i \<le> Q"
  by (simp add: SUP_L_P_def, rule SUP_least, auto)

lemma SUP_LE_P_upper:
  "pair v i \<le> u \<Longrightarrow> P v i \<le> SUP_LE_P P u i"
  by (auto simp add: SUP_LE_P_def intro: SUP_upper)

lemma SUP_LE_P_least:
  "(!! v . pair v i \<le> u \<Longrightarrow> P v i \<le> Q) \<Longrightarrow> SUP_LE_P P u i \<le> Q"
  by (simp add: SUP_LE_P_def, rule SUP_least, auto)

lemma SUP_SUP_L [simp]: "Sup (range (SUP_LE_P X)) = Sup (range X)"
  apply (simp add: fun_eq_iff Sup_fun_def, clarify)
  apply (rule antisym)
  apply (rule SUP_least)
  unfolding comp_def
  apply (rule SUP_LE_P_least)
  apply (rule SUP_upper, simp)
  apply (rule SUP_least)
  apply (rule_tac y = "SUP_LE_P X (pair xa x) x" in  order_trans)
  apply (rule SUP_LE_P_upper, simp)
  by (rule SUP_upper, simp)

lemma SUP_L_SUP_LE_P [simp]: "Sup_less (SUP_LE_P X) = SUP_L_P X"
  apply (rule antisym)
  apply (subst le_fun_def, safe)
  apply (rule Sup_less_least)
  apply (subst le_fun_def, safe)
  apply (rule SUP_LE_P_least)
  apply (rule SUP_L_P_upper, simp)
  apply (simp add: le_fun_def, safe)
  apply (rule SUP_L_P_least)
  apply (rule_tac y = "SUP_LE_P X (pair v xa) xa" in order_trans)
  apply (rule SUP_LE_P_upper, simp)
  apply (cut_tac P = "SUP_LE_P X" in Sup_less_upper)
  by (simp, simp add: le_fun_def)

end

theorem (in DiagramTermination) hoare_diagram2:
  "dmono D \<Longrightarrow> (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<Longrightarrow>
    \<Turnstile> (Sup (range X)) {| pt D |} ((Sup (range  X)) \<sqinter> (-(grd (step D))))"
  apply (frule_tac X = "SUP_LE_P X" in hoare_diagram)
  apply (auto simp del: Sup_image_eq)
  apply (simp add: SUP_LE_P_def)
  apply (unfold SUP_def hoare_Sup [THEN sym])
  apply auto
  apply (rule_tac Q = "SUP_L_P X (pair p i) j" in hoare_mono)
  apply auto
  apply (rule SUP_L_P_least)
  apply (rule SUP_L_P_upper)
  apply (rule order_trans3)
  by auto

lemma mono_pt [simp]: "dmono D \<Longrightarrow> mono (pt D)"
  apply (drule mono_mono_dgr)
  by (simp add: pt_def)

theorem (in DiagramTermination) hoare_diagram3:
  "dmono D \<Longrightarrow>
     (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<Longrightarrow>
      P \<le> Sup (range X) \<Longrightarrow>  ((Sup (range X)) \<sqinter> (-(grd (step D)))) \<le> Q \<Longrightarrow>
      \<Turnstile> P {| pt D |} Q"
  apply (rule hoare_mono)
  apply auto
  apply (rule hoare_pre)
  apply (auto simp add: SUP_def simp del: Sup_image_eq)
  apply (rule hoare_diagram2)
  by auto

text{*
The following definition introduces the concept of correct Hoare triples for diagrams.
*}

definition (in DiagramTermination)
  Hoare_dgr :: "('b \<Rightarrow> ('u::{complete_distrib_lattice, boolean_algebra})) \<Rightarrow> ('b \<times> 'b \<Rightarrow> 'u \<Rightarrow> 'u) \<Rightarrow> ('b \<Rightarrow> 'u) \<Rightarrow> bool" ("\<turnstile> (_){| _ |}(_) "
  [0,0,900] 900) where
  "\<turnstile> P {| D |} Q \<equiv> (\<exists> X . (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<and>
       P = Sup (range X) \<and> Q = ((Sup (range  X)) \<sqinter> (-(grd (step D)))))"

definition (in DiagramTermination)
  Hoare_dgr1 :: "('b \<Rightarrow> ('u::{complete_distrib_lattice, boolean_algebra})) \<Rightarrow> ('b \<times> 'b \<Rightarrow> 'u \<Rightarrow> 'u) \<Rightarrow> ('b \<Rightarrow> 'u) \<Rightarrow> bool" ("\<turnstile>1 (_){| _ |}(_) "
  [0,0,900] 900) where
  "\<turnstile>1 P {| D |} Q \<equiv> (\<exists> X . (\<forall> u i j . \<Turnstile> X u i  {| D(i, j) |} SUP_L_P X (pair u i) j) \<and>
      P \<le> Sup (range X) \<and> ((Sup (range X)) \<sqinter> (-(grd (step D)))) \<le> Q)"

theorem (in DiagramTermination) hoare_dgr_correctness:
  "dmono D \<Longrightarrow> (\<turnstile> P {| D |} Q) \<Longrightarrow> (\<Turnstile> P {| pt D |} Q)"
  apply (simp add: Hoare_dgr_def)
  apply safe
  apply (rule hoare_diagram3)
  by auto

theorem  (in DiagramTermination) hoare_dgr_correctness1:
  "dmono D \<Longrightarrow> (\<turnstile>1 P {| D |} Q) \<Longrightarrow> (\<Turnstile> P {| pt D |} Q)"
  apply (simp add: Hoare_dgr1_def)
  apply safe
  apply (rule hoare_diagram3)
  by auto

definition
  "dgr_demonic Q ij = [:Q ij:]"

theorem dgr_demonic_mono[simp]:
  "dmono (dgr_demonic Q)"
  by (simp add: dmono_def dgr_demonic_def)

definition
  "dangelic R Q i = angelic (R i) (Q i)"

lemma  grd_dgr:
  "((grd (step D) i)::('a::complete_boolean_algebra)) = \<Squnion> {P . \<exists> j . P = grd (D(i,j))}"
  apply (simp add: grd_def step_def)
  apply (unfold step_def INF_def uminus_Inf)
  apply (case_tac "(uminus ` range (\<lambda>j\<Colon>'b. D (i, j) \<bottom>)) = {P\<Colon>'a. \<exists>j\<Colon>'b. P = - D (i, j) \<bottom>}")
  apply auto
  done

lemma  grd_dgr_set:
  "((grd (step D) i)::('a set)) = Union {P . \<exists> j . P = grd (D(i,j))}"
  by (simp add: grd_dgr)

lemma not_grd_dgr [simp]: "(a \<in> (- grd (step D) i)) = (\<forall> j . a \<notin> grd (D(i,j)))"
 apply (simp add: grd_dgr)
  by auto

lemma not_grd_dgr2 [simp]: "a \<notin> (grd (step D) i) = (\<forall> j . a \<notin> grd (D(i,j)))"
  apply (subst not_grd_dgr [THEN sym])
  by simp
end


theory ex2_02 imports Main
begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc (add m n)"

fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0" |
"double (Suc m) = Suc (Suc (double m))"

theorem add_assoc: "add (add m n) p = add m (add n p)"
apply(induction m)
apply auto
done

lemma add_zero[simp]: "add m 0 = m"
apply(induction m)
apply auto
done

lemma add_suc[simp]: "add m (Suc n) = Suc(add m n)"
apply(induction m)
apply auto
done

theorem add_comm: "add m n = add n m"
apply(induction m)
apply auto
done

theorem add_double: "double m = add m m"
apply (induction m)
apply auto
done

end


(*  Title:      HOL/Library/Boolean_Algebra.thy
    Author:     Brian Huffman
*)

section {* Boolean Algebras *}

theory Boolean_Algebra
imports Main
begin

locale boolean =
  fixes conj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<sqinter>" 70)
  fixes disj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<squnion>" 65)
  fixes compl :: "'a \<Rightarrow> 'a" ("\<sim> _" [81] 80)
  fixes zero :: "'a" ("\<zero>")
  fixes one  :: "'a" ("\<one>")
  assumes conj_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  assumes disj_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  assumes conj_commute: "x \<sqinter> y = y \<sqinter> x"
  assumes disj_commute: "x \<squnion> y = y \<squnion> x"
  assumes conj_disj_distrib: "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
  assumes disj_conj_distrib: "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  assumes conj_one_right [simp]: "x \<sqinter> \<one> = x"
  assumes disj_zero_right [simp]: "x \<squnion> \<zero> = x"
  assumes conj_cancel_right [simp]: "x \<sqinter> \<sim> x = \<zero>"
  assumes disj_cancel_right [simp]: "x \<squnion> \<sim> x = \<one>"
begin

sublocale conj!: abel_semigroup conj proof
qed (fact conj_assoc conj_commute)+

sublocale disj!: abel_semigroup disj proof
qed (fact disj_assoc disj_commute)+

lemmas conj_left_commute = conj.left_commute

lemmas disj_left_commute = disj.left_commute

lemmas conj_ac = conj.assoc conj.commute conj.left_commute
lemmas disj_ac = disj.assoc disj.commute disj.left_commute

lemma dual: "boolean disj conj compl one zero"
apply (rule boolean.intro)
apply (rule disj_assoc)
apply (rule conj_assoc)
apply (rule disj_commute)
apply (rule conj_commute)
apply (rule disj_conj_distrib)
apply (rule conj_disj_distrib)
apply (rule disj_zero_right)
apply (rule conj_one_right)
apply (rule disj_cancel_right)
apply (rule conj_cancel_right)
done

subsection {* Complement *}

lemma complement_unique:
  assumes 1: "a \<sqinter> x = \<zero>"
  assumes 2: "a \<squnion> x = \<one>"
  assumes 3: "a \<sqinter> y = \<zero>"
  assumes 4: "a \<squnion> y = \<one>"
  shows "x = y"
proof -
  have "(a \<sqinter> x) \<squnion> (x \<sqinter> y) = (a \<sqinter> y) \<squnion> (x \<sqinter> y)" using 1 3 by simp
  hence "(x \<sqinter> a) \<squnion> (x \<sqinter> y) = (y \<sqinter> a) \<squnion> (y \<sqinter> x)" using conj_commute by simp
  hence "x \<sqinter> (a \<squnion> y) = y \<sqinter> (a \<squnion> x)" using conj_disj_distrib by simp
  hence "x \<sqinter> \<one> = y \<sqinter> \<one>" using 2 4 by simp
  thus "x = y" using conj_one_right by simp
qed

lemma compl_unique: "\<lbrakk>x \<sqinter> y = \<zero>; x \<squnion> y = \<one>\<rbrakk> \<Longrightarrow> \<sim> x = y"
by (rule complement_unique [OF conj_cancel_right disj_cancel_right])

lemma double_compl [simp]: "\<sim> (\<sim> x) = x"
proof (rule compl_unique)
  from conj_cancel_right show "\<sim> x \<sqinter> x = \<zero>" by (simp only: conj_commute)
  from disj_cancel_right show "\<sim> x \<squnion> x = \<one>" by (simp only: disj_commute)
qed

lemma compl_eq_compl_iff [simp]: "(\<sim> x = \<sim> y) = (x = y)"
by (rule inj_eq [OF inj_on_inverseI], rule double_compl)

subsection {* Conjunction *}

lemma conj_absorb [simp]: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> x = (x \<sqinter> x) \<squnion> \<zero>" using disj_zero_right by simp
  also have "... = (x \<sqinter> x) \<squnion> (x \<sqinter> \<sim> x)" using conj_cancel_right by simp
  also have "... = x \<sqinter> (x \<squnion> \<sim> x)" using conj_disj_distrib by (simp only:)
  also have "... = x \<sqinter> \<one>" using disj_cancel_right by simp
  also have "... = x" using conj_one_right by simp
  finally show ?thesis .
qed

lemma conj_zero_right [simp]: "x \<sqinter> \<zero> = \<zero>"
proof -
  have "x \<sqinter> \<zero> = x \<sqinter> (x \<sqinter> \<sim> x)" using conj_cancel_right by simp
  also have "... = (x \<sqinter> x) \<sqinter> \<sim> x" using conj_assoc by (simp only:)
  also have "... = x \<sqinter> \<sim> x" using conj_absorb by simp
  also have "... = \<zero>" using conj_cancel_right by simp
  finally show ?thesis .
qed

lemma compl_one [simp]: "\<sim> \<one> = \<zero>"
by (rule compl_unique [OF conj_zero_right disj_zero_right])

lemma conj_zero_left [simp]: "\<zero> \<sqinter> x = \<zero>"
by (subst conj_commute) (rule conj_zero_right)

lemma conj_one_left [simp]: "\<one> \<sqinter> x = x"
by (subst conj_commute) (rule conj_one_right)

lemma conj_cancel_left [simp]: "\<sim> x \<sqinter> x = \<zero>"
by (subst conj_commute) (rule conj_cancel_right)

lemma conj_left_absorb [simp]: "x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
by (simp only: conj_assoc [symmetric] conj_absorb)

lemma conj_disj_distrib2:
  "(y \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
by (simp only: conj_commute conj_disj_distrib)

lemmas conj_disj_distribs =
   conj_disj_distrib conj_disj_distrib2

subsection {* Disjunction *}

lemma disj_absorb [simp]: "x \<squnion> x = x"
by (rule boolean.conj_absorb [OF dual])

lemma disj_one_right [simp]: "x \<squnion> \<one> = \<one>"
by (rule boolean.conj_zero_right [OF dual])

lemma compl_zero [simp]: "\<sim> \<zero> = \<one>"
by (rule boolean.compl_one [OF dual])

lemma disj_zero_left [simp]: "\<zero> \<squnion> x = x"
by (rule boolean.conj_one_left [OF dual])

lemma disj_one_left [simp]: "\<one> \<squnion> x = \<one>"
by (rule boolean.conj_zero_left [OF dual])

lemma disj_cancel_left [simp]: "\<sim> x \<squnion> x = \<one>"
by (rule boolean.conj_cancel_left [OF dual])

lemma disj_left_absorb [simp]: "x \<squnion> (x \<squnion> y) = x \<squnion> y"
by (rule boolean.conj_left_absorb [OF dual])

lemma disj_conj_distrib2:
  "(y \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
by (rule boolean.conj_disj_distrib2 [OF dual])

lemmas disj_conj_distribs =
   disj_conj_distrib disj_conj_distrib2

subsection {* De Morgan's Laws *}

lemma de_Morgan_conj [simp]: "\<sim> (x \<sqinter> y) = \<sim> x \<squnion> \<sim> y"
proof (rule compl_unique)
  have "(x \<sqinter> y) \<sqinter> (\<sim> x \<squnion> \<sim> y) = ((x \<sqinter> y) \<sqinter> \<sim> x) \<squnion> ((x \<sqinter> y) \<sqinter> \<sim> y)"
    by (rule conj_disj_distrib)
  also have "... = (y \<sqinter> (x \<sqinter> \<sim> x)) \<squnion> (x \<sqinter> (y \<sqinter> \<sim> y))"
    by (simp only: conj_ac)
  finally show "(x \<sqinter> y) \<sqinter> (\<sim> x \<squnion> \<sim> y) = \<zero>"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_right)
next
  have "(x \<sqinter> y) \<squnion> (\<sim> x \<squnion> \<sim> y) = (x \<squnion> (\<sim> x \<squnion> \<sim> y)) \<sqinter> (y \<squnion> (\<sim> x \<squnion> \<sim> y))"
    by (rule disj_conj_distrib2)
  also have "... = (\<sim> y \<squnion> (x \<squnion> \<sim> x)) \<sqinter> (\<sim> x \<squnion> (y \<squnion> \<sim> y))"
    by (simp only: disj_ac)
  finally show "(x \<sqinter> y) \<squnion> (\<sim> x \<squnion> \<sim> y) = \<one>"
    by (simp only: disj_cancel_right disj_one_right conj_one_right)
qed

lemma de_Morgan_disj [simp]: "\<sim> (x \<squnion> y) = \<sim> x \<sqinter> \<sim> y"
by (rule boolean.de_Morgan_conj [OF dual])

end

subsection {* Symmetric Difference *}

locale boolean_xor = boolean +
  fixes xor :: "'a => 'a => 'a"  (infixr "\<oplus>" 65)
  assumes xor_def: "x \<oplus> y = (x \<sqinter> \<sim> y) \<squnion> (\<sim> x \<sqinter> y)"
begin

sublocale xor!: abel_semigroup xor proof
  fix x y z :: 'a
  let ?t = "(x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> \<sim> y \<sqinter> \<sim> z) \<squnion>
            (\<sim> x \<sqinter> y \<sqinter> \<sim> z) \<squnion> (\<sim> x \<sqinter> \<sim> y \<sqinter> z)"
  have "?t \<squnion> (z \<sqinter> x \<sqinter> \<sim> x) \<squnion> (z \<sqinter> y \<sqinter> \<sim> y) =
        ?t \<squnion> (x \<sqinter> y \<sqinter> \<sim> y) \<squnion> (x \<sqinter> z \<sqinter> \<sim> z)"
    by (simp only: conj_cancel_right conj_zero_right)
  thus "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
    apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
    apply (simp only: conj_disj_distribs conj_ac disj_ac)
    done
  show "x \<oplus> y = y \<oplus> x"
    by (simp only: xor_def conj_commute disj_commute)
qed

lemmas xor_assoc = xor.assoc
lemmas xor_commute = xor.commute
lemmas xor_left_commute = xor.left_commute

lemmas xor_ac = xor.assoc xor.commute xor.left_commute

lemma xor_def2:
  "x \<oplus> y = (x \<squnion> y) \<sqinter> (\<sim> x \<squnion> \<sim> y)"
by (simp only: xor_def conj_disj_distribs
               disj_ac conj_ac conj_cancel_right disj_zero_left)

lemma xor_zero_right [simp]: "x \<oplus> \<zero> = x"
by (simp only: xor_def compl_zero conj_one_right conj_zero_right disj_zero_right)

lemma xor_zero_left [simp]: "\<zero> \<oplus> x = x"
by (subst xor_commute) (rule xor_zero_right)

lemma xor_one_right [simp]: "x \<oplus> \<one> = \<sim> x"
by (simp only: xor_def compl_one conj_zero_right conj_one_right disj_zero_left)

lemma xor_one_left [simp]: "\<one> \<oplus> x = \<sim> x"
by (subst xor_commute) (rule xor_one_right)

lemma xor_self [simp]: "x \<oplus> x = \<zero>"
by (simp only: xor_def conj_cancel_right conj_cancel_left disj_zero_right)

lemma xor_left_self [simp]: "x \<oplus> (x \<oplus> y) = y"
by (simp only: xor_assoc [symmetric] xor_self xor_zero_left)

lemma xor_compl_left [simp]: "\<sim> x \<oplus> y = \<sim> (x \<oplus> y)"
apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
apply (simp only: conj_disj_distribs)
apply (simp only: conj_cancel_right conj_cancel_left)
apply (simp only: disj_zero_left disj_zero_right)
apply (simp only: disj_ac conj_ac)
done

lemma xor_compl_right [simp]: "x \<oplus> \<sim> y = \<sim> (x \<oplus> y)"
apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
apply (simp only: conj_disj_distribs)
apply (simp only: conj_cancel_right conj_cancel_left)
apply (simp only: disj_zero_left disj_zero_right)
apply (simp only: disj_ac conj_ac)
done

lemma xor_cancel_right: "x \<oplus> \<sim> x = \<one>"
by (simp only: xor_compl_right xor_self compl_zero)

lemma xor_cancel_left: "\<sim> x \<oplus> x = \<one>"
by (simp only: xor_compl_left xor_self compl_zero)

lemma conj_xor_distrib: "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
proof -
  have "(x \<sqinter> y \<sqinter> \<sim> z) \<squnion> (x \<sqinter> \<sim> y \<sqinter> z) =
        (y \<sqinter> x \<sqinter> \<sim> x) \<squnion> (z \<sqinter> x \<sqinter> \<sim> x) \<squnion> (x \<sqinter> y \<sqinter> \<sim> z) \<squnion> (x \<sqinter> \<sim> y \<sqinter> z)"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_left)
  thus "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
    by (simp (no_asm_use) only:
        xor_def de_Morgan_disj de_Morgan_conj double_compl
        conj_disj_distribs conj_ac disj_ac)
qed

lemma conj_xor_distrib2:
  "(y \<oplus> z) \<sqinter> x = (y \<sqinter> x) \<oplus> (z \<sqinter> x)"
proof -
  have "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
    by (rule conj_xor_distrib)
  thus "(y \<oplus> z) \<sqinter> x = (y \<sqinter> x) \<oplus> (z \<sqinter> x)"
    by (simp only: conj_commute)
qed

lemmas conj_xor_distribs =
   conj_xor_distrib conj_xor_distrib2

end

end


theory VDMOrderExample
imports VDMToolkit
begin

record R =
  x :: nat
  y :: nat

definition
  R_eq :: "R \<Rightarrow> R \<Rightarrow> bool" (infix "=\<^sub>R" 50)
  where
  [simp]: "r1 =\<^sub>R r2 \<equiv> (x r1) = (x r2)"

definition
  R_ord :: "R \<Rightarrow> R \<Rightarrow> bool" (infix "<\<^sub>R" 50)
  where
  [simp]: "r1 <\<^sub>R r2 \<equiv> (x r1) < (x r2) \<or> ((x r1) = (x r2) \<and> (y r1) < (y r2))"

definition
  R_tord :: "R \<Rightarrow> R \<Rightarrow> bool" (infix "\<le>\<^sub>R" 50)
  where
  [simp]: "r1 \<le>\<^sub>R r2 \<equiv> r1 <\<^sub>R r2 \<or> R_eq r1 r2"

lemma vdm_ord_irrefl: "\<forall> r . \<not> r <\<^sub>R r"
  by simp

lemma vdm_ord_trans: "\<forall> r1 r2 r3 . r1 <\<^sub>R r2 \<and> r2 <\<^sub>R r3 \<longrightarrow> r1 <\<^sub>R r3"
  by fastforce

lemma vdm_ord_asym: "\<forall> x y . x <\<^sub>R y \<longrightarrow> \<not> y <\<^sub>R x"
  by simp

lemma vdm_ord_implies_totality:
  "\<forall> x y z . \<not> x <\<^sub>R x \<and> (x <\<^sub>R y \<and> y <\<^sub>R z \<longrightarrow> x <\<^sub>R z) \<and> (x <\<^sub>R y \<longrightarrow> \<not> y <\<^sub>R x) \<longrightarrow> x \<le>\<^sub>R y \<or> y \<le>\<^sub>R x"
  by (safe, simp_all)

lemma vdm_ord_total:
  "\<forall> x y z . x \<le>\<^sub>R y \<or> y \<le>\<^sub>R x"
  by (safe, simp_all)

lemma PO2:
  "\<forall> r . r =\<^sub>R r"
  "\<forall> r1 r2 . r1 =\<^sub>R r2 \<longrightarrow> r2 =\<^sub>R r1"
  \<open>\<forall> r1 r2 r3 . r1 =\<^sub>R r2 \<and> r2 =\<^sub>R r3 \<longrightarrow> r1 =\<^sub>R r3\<close>
  by simp_all

lemma PO4:
  \<open>\<forall> r . \<not> r <\<^sub>R r\<close>
  \<open>\<forall> r1 r2 r3 . r1 <\<^sub>R r2 \<and> r2 <\<^sub>R r3 \<longrightarrow> r1 <\<^sub>R r3\<close>
  by fastforce+

lemma PO5:
  \<open>\<forall> r1 r2 . r1 \<le>\<^sub>R r2 \<or> r2 \<le>\<^sub>R r1\<close>
  by force

end


theory Logic
imports Main
begin

(* In Isabelle, Prop in Coq is just a type 'bool', then things are much easier *)

section {* Logic *}
subsection {* Propositions *}

term "3 = 3"
  (* \<Longrightarrow> "3 = 3" :: "bool" *)
term "\<forall>(n :: nat). n = 2"
  (* \<Longrightarrow> "\<forall>n. n = 2" :: "bool" *)

subsection {* Proofs and Evidence *}

lemma silly: "0 * 3 = (0 :: nat)" by simp
thm silly
  (* \<Longrightarrow> 0 * 3 = 0 *)

subsubsection {* Implications are functions *}

lemma silly_implication: "(1 + 1) = 2 \<longrightarrow> 0 * 3 = (0 :: nat)" by simp
thm silly_implication
  (* \<Longrightarrow> 1 + 1 = 2 \<longrightarrow> 0 * 3 = 0 *)

subsubsection {* Defining Propositions *}

subsection {* Conjunction (Logical "and") *}

(*
Inductive and (P Q : Prop) : Prop :=
  conj : P \<rightarrow> Q \<rightarrow> (and P Q).
*)

value "\<lambda>x y. x \<and> y"
  (* \<Longrightarrow> "_" :: "bool \<Rightarrow> bool \<Rightarrow> bool" *)

subsubsection {* "Introducing" Conjuctions *}

theorem and_example: "((0 :: nat) = 0) \<and> ((4 :: nat) = 2 * 2)" by simp

subsubsection {* "Eliminating" conjunctions *}

theorem proj1: "\<forall>p q. p \<and> q \<longrightarrow> p" by simp

(* Exercise: 1 star, optional (proj2) *)

theorem proj2: "\<forall>p q. p \<and> q \<longrightarrow> q" by simp
theorem and_commut: "\<forall>p q. p \<and> q \<longrightarrow> q \<and> p" by simp

(* Exercise: 2 stars (and_assoc) *)

theorem and_assoc: "\<forall>p q r. p \<and> (q \<and> r) \<longrightarrow> (p \<and> q) \<and> r" by simp

subsection {* Iff *}

no_notation
  iff (infixr "\<longleftrightarrow>" 25)

abbreviation iff (infixr "\<longleftrightarrow>" 25) where
  "iff p q \<equiv> (p \<longrightarrow> q) \<and> (q \<longrightarrow> p)"

theorem iff_implies: "\<forall>p q. (p \<longleftrightarrow> q) \<longrightarrow> p \<longrightarrow> q" by simp
theorem iff_sym: "\<forall>p q. (p \<longleftrightarrow> q) \<longrightarrow> (q \<longleftrightarrow> p)" by simp

(* Exercise: 1 star, optional (iff_properties) *)

theorem iff_refl: "\<forall>p. p \<longleftrightarrow> p" by simp
theorem iff_trans: "\<forall>p q r. (p \<longleftrightarrow> q) \<longrightarrow> (q \<longleftrightarrow> r) \<longrightarrow> (p \<longleftrightarrow> r)" by fastforce

subsection {* Disjunction (Logical "or") *}
subsubsection {* Implementing Disjunction *}

(*
Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.
*)

thm "disjI1"
  (* ?P \<Longrightarrow> ?P \<or> ?Q *)
thm "disjI2"
  (* ?Q \<Longrightarrow> ?P \<or> ?Q *)

theorem or_commut: "\<forall>p q. p \<or> q \<longrightarrow> q \<or> p" by simp
theorem or_distributes_over_and_1: "\<forall>p q r. p \<or> (q \<and> r) \<longrightarrow> (p \<or> q) \<and> (p \<or> r)" by simp

(* Exercise: 2 stars (or_distributes_over_and_2) *)
theorem or_distributes_over_and_2: "\<forall>p q r. (p \<or> q) \<and> (p \<or> r) \<longrightarrow> p \<or> (q \<and> r)" by auto

(* Exercise: 1 star, optional (or_distributes_over_and) *)
theorem or_distributes_over_and : "\<forall>P Q R. P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)" by auto

subsubsection {* Relating \<and> and \<or> with andb and orb (advanced) *}

theorem andb_prop: "\<forall>b c. b \<and> c = True \<longrightarrow> b = True \<and> c = True" by simp
theorem andb_true_intro: "\<forall>b c. b = True \<and> c = True \<longrightarrow> b \<and> c" by simp

(* Exercise: 2 stars, optional (bool_prop) *)
theorem andb_false: "\<forall>b c. b \<and> c = False \<longrightarrow> b = False \<or> c = False" by simp
theorem orb_prop: "\<forall>b c. b \<or> c = True \<longrightarrow> b = True \<or> c = True" by simp
theorem orb_false_elim: "\<forall>b c. (b \<or> c) = False \<longrightarrow> b = False \<and> c = False" by simp

subsection {* Falsehood *}

(* Inductive False : Prop := . *)

theorem False_implies_nonsense: "False \<longrightarrow> 2 + 2 = 5" by simp
theorem ex_falso_quodlibet: "\<forall>p. False \<longrightarrow> p" by simp

subsubsection {* Truth *}

(* Exercise: 2 stars, advanced (True) *)

subsection {* Negation *}

(* Definition not (P:Prop) := P \<rightarrow> False. *)

term "\<lambda>x. \<not> x"
  (* \<Longrightarrow> "Not" :: "bool \<Rightarrow> bool" *)

theorem not_False: "\<not> False" by simp
theorem contradiction_implies_anything: "\<forall>p q. (p \<and> \<not> p) \<longrightarrow> q" by simp
theorem double_neg: "\<forall>p. p \<longrightarrow> ~~ p" by simp

(* Exercise: 2 stars, advanced (double_neg_inf) *)
(* Exercise: 2 stars (contrapositive) *)

theorem contrapositive: "\<forall>p q. (p \<longrightarrow> q) \<longrightarrow> (\<not> q \<longrightarrow> \<not> p)" by auto

(* Exercise: 1 star (not_both_true_and_false) *)

theorem "\<not> (p \<and> \<not> p)" by simp

(* Exercise: 1 star, advanced (informal_not_PNP) *)

subsubsection {* Constructive logic *}

theorem classis_double_neg: "~~ p \<longrightarrow> p" by simp

(* Exercise: 5 stars, advanced, optional (classical_axioms) *)

abbreviation "peirce \<equiv> \<forall>p q. ((p \<longrightarrow> q) \<longrightarrow> p) \<longrightarrow> p"
abbreviation "classic \<equiv> \<forall>p. ~~p \<longrightarrow> p"
abbreviation "excluded_middle \<equiv> \<forall>p. p \<or> \<not> p"
abbreviation "de_morgan_not_and_not \<equiv> \<forall>p q. \<not> (\<not> p \<and> \<not> q) \<longrightarrow> p \<or> q"
abbreviation "implies_to_or \<equiv> \<forall>p q. (p \<longrightarrow> q) \<longrightarrow> (\<not> p \<or> q)"

(* Exercise: 3 stars (excluded_middle_irrefutable) *)

theorem excluded_middle_irrefutable: "\<forall>p. \<not> \<not> (p \<or> \<not> p)" by simp

subsubsection {* Inequality *}

theorem not_false_then_true: "\<forall>b. b \<noteq> False \<longrightarrow> b = True" by simp

(* Exercise: 2 stars (false_beq_nat) *)

theorem false_beq_nat: "\<forall>n m. n \<noteq> m \<longrightarrow> n = m = False" by simp

(* Exercise: 2 stars, optional (beq_nat_false) *)

theorem beq_nat_false: "\<forall>n m. n = m = False \<longrightarrow> n \<noteq> m" by simp

end


theory Chapter4
  imports Main
begin

(* Ex 4.1 *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
  "set Tip = {}"
| "set (Node l a r) = set l \<union> {a} \<union> set r"

(* fun ord :: "int tree \<Rightarrow> bool" where
  "ord Tip = True"
| "ord (Node l a r) =
*)

lemma "\<forall>x. \<exists>y. x = y"
  by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto

lemma "\<lbrakk> \<forall>xs \<in> A. \<exists>ys. xs = ys @ ys; us \<in> A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n + n"
  by fastforce

lemma "\<lbrakk> \<forall>x y. T x y \<or> T y x;
        \<forall>x y. A x y \<and> A y x \<longrightarrow> x = y;
        \<forall>x y. T x y \<longrightarrow> A x y \<rbrakk>
        \<Longrightarrow> \<forall>x y. A x y \<longrightarrow> T x y"
  by blast

lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
  sledgehammer
  using append_eq_append_conv by blast

lemma "\<lbrakk> (a::nat) \<le> x + b; 2 * x < c \<rbrakk> \<Longrightarrow> 2 * a + 1 \<le> 2 * b + c"
  by arith

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

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

lemma "Suc (Suc (Suc a)) \<le> b \<Longrightarrow> a \<le> b"
  by (blast dest: Suc_leD)

inductive ev :: "nat \<Rightarrow> bool" where
  ev0: "ev 0"
| evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
  "evn 0 = True"
| "evn (Suc 0) = False"
| "evn (Suc (Suc n)) = evn n"

lemma "ev (Suc (Suc (Suc (Suc 0))))"
  apply (rule evSS)
  apply (rule evSS)
  apply (rule ev0)
  done

lemma "ev m \<Longrightarrow> evn m"
  apply (induction rule: ev.induct)
by simp_all

lemma "evn n \<Longrightarrow> ev n"
  apply (induction n rule: evn.induct)
  apply (simp_all add: ev0 evSS)
done

declare ev.intros[simp,intro]

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl: "star r x x"
| step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
  apply assumption
  apply (metis step)
done

(* Ex 4.2 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
  emp: "palindrome []"
| singleton: "palindrome [a]"
| multi: "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule: palindrome.induct)
  apply simp_all
done

(* Ex 4.5 *)
datatype alpha = a | b

inductive S  where
  empty: "S []"
| betw: "S w \<Longrightarrow> S (a # w @ [b])"
| conc : "S w1 \<Longrightarrow> S w2 \<Longrightarrow> S (w1 @ w2)"

inductive T where
  empty: "T []"
| betw_conc: "T w1 \<Longrightarrow> T w2 \<Longrightarrow> T (w1 @ a # w2 @ [b])"

lemma T_S:  "T w \<Longrightarrow> S w"
  apply (induct rule: T.induct)
  apply (rule S.empty)
  apply (metis S.conc S.betw)
done

axiomatization where
T_app: "T w1 \<Longrightarrow> T w2 \<Longrightarrow> T (w1 @ w2)"

lemma S_T: "S w \<Longrightarrow> T w"
  apply (induct rule: S.induct)
  apply (rule T.empty)
  using T.simps append.left_neutral apply blast
  apply (simp add: T_app)
done

theorem S_T_eq: "S w = T w"
  apply auto
  apply (rule S_T, assumption)
  apply (rule T_S, assumption)
done


theory tut03
imports Main "~~/src/HOL/IMP/ASM" "~~/src/HOL/IMP/AExp"
begin

inductive odd :: "nat \<Rightarrow> bool" where
odd1:  "odd 1"
 | odd_add: "odd n \<Longrightarrow> odd (n+2)"

thm odd1 odd_add

inductive is_aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
  N: "is_aval (N n) s n"
| V: "is_aval (V x) s (s x)"
| P: "\<lbrakk> is_aval a1 s v1; is_aval a2 s v2 \<rbrakk>
  \<Longrightarrow> is_aval (Plus a1 a2) s (v1+v2)"

lemma "is_aval (Plus (N 2) (Plus (V x) (N 3))) s (2+(s x + 3))"
  apply (rule N V P)
  apply (rule N V P)
  apply (rule N V P)
  apply (rule N V P)
  apply (rule N V P)
  (* or apply (intro is_aval.intros) *)
  (* or apply (rule is_aval.intros)+ *)
  (* or apply (rule N V P)+ *)
  done

notepad begin
  fix a b c d e f g h :: int
  assume "a=b"
  also assume "b < c+d+e+f+g+h"
  also assume "... \<le> d"
  also assume "d = e"
  finally have "a < e" .
end

lemma "is_aval a s v \<longleftrightarrow> aval a s = v"
proof
  assume "is_aval a s v"
  (*thus "aval a s = v" by induction auto*)

  thus "aval a s = v"
  proof induction
    print_cases
    case (N n s) show ?case by simp
      thm aval.simps
  next
    case (V x s) show ?case by simp
  next
    case (P a1 s v1 a2 v2)
    have "aval (Plus a1 a2) s = aval a1 s + aval a2 s" by simp
    also from P.IH have "\<dots> = v1 + v2" by simp
    finally show ?case .
  qed
next
  assume "aval a s = v" thus "is_aval a s v"
  proof (induction a arbitrary: v)
    case (N v) thus ?case by (simp add: is_aval.N)
  next
    case (V x) thus ?case
      by (auto simp add: is_aval.V)
  next
    case (Plus a1 a2)
    from Plus.prems have 1: "v = aval a1 s + aval a2 s"
      by simp

      thm Plus.IH
    show ?case
      unfolding 1
      apply (rule is_aval.P)
      thm Plus.IH
      apply (rule Plus.IH, simp)
      apply (rule Plus.IH, simp)
      done
  qed
    (*by (induction a arbitrary: v) (auto intro: N V P)*)
qed

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk  =  Some (n # stk)" |
"exec1 (LOAD x) s stk  =  Some (s(x) # stk)" |
"exec1  ADD _ (a#b#stk)  =  Some ((a+b)#stk)" |
"exec1  ADD _ _  =  None"

text_raw{*}%endsnip*}

text_raw{*\snip{ASMexecdef}{1}{2}{% *}
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk = (
  case exec1 i s stk of
    Some stk \<Rightarrow> exec is s stk
  | None \<Rightarrow> None)"

lemma exec_append:
  "exec (is1@is2) s stk = (
    case exec is1 s stk of
      Some stk \<Rightarrow> exec is2 s stk
    | None \<Rightarrow> None)"
apply(induction is1 arbitrary: stk)
apply (auto split: option.split)
done

lemma "exec (comp a) s stk = Some (aval a s # stk)"
  apply (induction a arbitrary: stk)
  apply (auto simp add: exec_append)
  done

end


theory Exp
  imports Main
begin
section \<open>Aexp\<close>
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V v) s = s v" |
"aval (Plus e1 e2) s = aval e1 s + aval e2 s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x. 0)"
value "aval (Plus (V ''x'') (V ''y'')) ((\<lambda>u. 0) (''x'' := 7, ''y'' := 3))"

text \<open>A little syntax magic to write larger states compactly:\<close>

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2 :: int))"
  by auto

value "aval (Plus (V ''x'') (V ''y'')) ((<> (''x'' := 7)) (''y'' := 3))"
value "aval (Plus (V ''x'') (V ''y'')) <''x'' := 7, ''y'' := 3>"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V v) = V v" |
"asimp_const (Plus e1 e2) =
  (case (asimp_const e1, asimp_const e2) of
    (N n1, N n2) \<Rightarrow> N (n1 + n2) |
    (x1, x2)     \<Rightarrow> Plus x1 x2)"

lemma "aval (asimp_const a) s = aval a s"
  apply(induct a)
  by (auto split: aexp.split)

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N n1) (N n2) = N (n1 + n2)" |
"plus (N n1) e = (if n1=0 then e else Plus (N n1) e)" |
"plus e (N n2) = (if n2=0 then e else Plus e (N n2))" |
"plus e1 e2 = Plus e1 e2"

lemma aval_plus:
  "aval (plus e1 e2) s = aval e1 s + aval e2 s"
  apply(induction e1 e2 rule: plus.induct)
  by simp_all

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V v) = V v" |
"asimp (Plus e1 e2) = plus (asimp e1) (asimp e2)"

lemma aval_simp[simp]:
  "aval (asimp a) s = aval a s"
  apply (induct a)
  apply simp_all
  by (simp add: aval_plus)

section \<open>Bexp\<close>
datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

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

text \<open>some test of bexp\<close>
value "bval (Bc True) (\<lambda>x. 0)"
value "bval (Not (Bc True)) (\<lambda>x. 0)"
value "bval (And (Bc True) (Bc False)) (\<lambda>x. 0)"
value "bval (And (Bc True) (Bc True)) (\<lambda>x. 0)"
value "bval (Less (N 1) (N 0)) (\<lambda>x. 0)"
value "bval (Less (N 0) (N 1)) (\<lambda>x. 0)"

subsection \<open>Constant Folding\<close>
fun "not" :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

lemma bval_not[simp]:
  "bval (not b) s = (\<not> (bval b s))"
  apply (induct b)
  by auto

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

lemma bval_and[simp]:
  "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
  apply (induction b1 b2 rule: and.induct)
  by auto

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

lemma bval_or:
  "bval (or b1 b2) s = (bval b1 s \<or> bval b2 s)"
  apply (induction b1 b2 rule: or.induct)
  by auto

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

lemma bval_less[simp]:
  "bval (less a1 a2) s = (aval a1 s < aval a2 s)"
  apply (induction a1 a2 rule: less.induct)
  by auto

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

lemma bsimp_eq:
  "bval (bsimp b) s = bval b s"
  apply (induct b rule: bsimp.induct)
  by simp_all

end


theory Chapter4
  imports Main
begin

-- "Chapter 4"

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall> A. \<exists> a. A = f a" by (simp add: surj_def)
  from 1 have 2: "\<exists> a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists> a. {x. x \<notin> f x} = f a" by auto
  from this show False by blast
qed

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> a. {x. x \<notin> f x} = f a" by auto
  thus False by blast
qed

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows False
proof -
  have "\<exists> a. {x. x \<notin> f x} = f a" using s by auto
  thus False by blast
qed

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> a. {x. x \<notin> f x} = f a" by auto
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus False by blast
qed

-- "Exercise 4.1"

lemma
  assumes T: "\<forall> x y. T x y \<or> T y x"
  and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall> x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
proof (rule ccontr)
  assume "\<not> T x y"
  from this T have "T y x" by blast
  from this TA have "A y x" by blast
  from A this `A x y` have "x = y" by blast
  from this `T y x` have "T x y" by blast
  from this `\<not> T x y` show False by blast
qed

find_theorems "(EX x . _) \<or> (EX y . _)"
find_theorems "(_ = _) \<Longrightarrow> (_ = _)"
find_theorems "?a \<Longrightarrow> ?a \<or> ?b"
thm even_two_times_div_two
thm length_drop

lemma
  "  (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
   \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof -
  obtain zs where zs: "zs = drop (length xs - length xs div 2) xs" by simp
  obtain ys where ys: "ys = take (length xs - length xs div 2) xs" by simp
  show ?thesis proof cases
    assume even: "even (length xs)"
    from zs ys have concat: "xs = ys @ zs" by simp
    from concat have sum: "length xs = length ys + length zs" by simp
    from zs even sum have length: "length ys = length zs"
      by (metis add_diff_cancel_right' even_two_times_div_two length_drop mult_2)
    from concat length show ?thesis by auto
  next
    assume odd: "odd (length xs)"
    from zs ys have concat: "xs = ys @ zs" by simp
    from concat have sum: "length xs = length ys + length zs" by simp
    from zs odd sum have length: "length ys = length zs + 1"
      using odd_ex_decrement by fastforce
    from concat length show ?thesis by auto
  qed
qed

inductive ev where
  ev0: "ev 0" |
  evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma "~ ev (Suc (Suc (Suc 0)))" (is "\<not> ?P")
proof
  assume P: "?P"
  hence "ev (Suc 0)" by cases
  thus False by cases
qed

lemma assumes a: "ev (Suc (Suc n))" shows "ev n"
proof -
  from a show "ev n" by cases
qed

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  thus False proof cases
    case evSS
    thus False proof cases qed
  qed
qed

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  star_refl: "star r x x" |
  star_step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  iter_refl: "iter r 0 x x" |
  iter_step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case (iter_refl r x)
  show "star r x x" by (rule star_refl)
next
  case (iter_step r x y n z)
  assume xy: "r x y"
  assume yz: "star r y z"
  show "star r x z" by (rule star_step[OF xy yz])
qed

fun elems where
  "elems [] = {}" |
  "elems (x # xs) = insert x (elems xs)"

lemma "\<exists> x. x = 1" proof - show "\<exists> x. x = 1" proof show "1 = 1" by rule qed qed
thm exI

lemma "\<exists> x. x = 1" by (simp add: exI[of _ 1])

lemma "x \<in> elems xs \<Longrightarrow> \<exists> ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
  case Nil
  assume "x \<in> elems []"
  then have False by simp
  then show ?case by safe
next
  case (Cons a xs)
  assume ind: "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
  assume elem: "x \<in> elems (a # xs)"
  show ?case proof cases
    assume eq: "x = a"
    obtain ys :: "'a list" where ys: "ys = []" by simp
    obtain zs where zs: "zs = xs" by simp
    have "a # xs = ys @ x # zs \<and> x \<notin> elems ys" by (simp add: ys zs eq)
    thus ?case by auto
  next
    assume neq: "x \<noteq> a"
    with elem have "x \<in> elems xs" by simp
    with ind have "\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys" (is "\<exists> ys. ?P ys") by simp
    then obtain ys where "?P ys" by blast
    with neq show "\<exists>ys zs. a # xs = ys @ x # zs \<and> x \<notin> elems ys"
      using Cons_eq_appendI by force
  qed
qed

datatype alpha = a | b

function balanced where
  balanced_nil: "balanced 0 [] = True" |
  balanced_a: "balanced n (a # xs) = balanced (Suc n) xs" |
  balanced_b: "balanced (Suc n) (b # xs) = balanced n xs" |
  unbalanced_a: "balanced (Suc _) [] = False" |
  unbalanced_b: "balanced 0 (b # _) = False"
  by (pat_completeness, auto)
termination by lexicographic_order

inductive S where
  S_empty: "S []" |
  S_match: "S x \<Longrightarrow> S (a # x @ [b])" |
  S_concat: "S x \<Longrightarrow> S y \<Longrightarrow> S (x @ y)"

lemma append_split: "length cs < length as \<Longrightarrow> as @ bs = cs @ ds \<Longrightarrow> \<exists>es. as = cs @ es"
  by (metis add_diff_inverse_nat append_Nil2 append_eq_append_conv_if
            drop_all length_drop less_imp_not_less)

lemma S_insert: "S (x @ y) \<Longrightarrow> S (x @ [a, b] @ y)"
proof (induction "x @ y" arbitrary: x y rule: S.induct)
  fix x y :: "alpha list"
  assume "[] = x @ y"
  then have "x = [] \<and> y = []" by simp
  then show "S (x @ [a, b] @ y)" using S_empty S_match by force
next
  fix z x y
  assume IH: "S z" "\<And>x y. z = x @ y \<Longrightarrow> S (x @ [a, b] @ y)"
  assume as: "a # z @ [b] = x @ y"
  show "S (x @ [a, b] @ y)" proof (cases; cases)
    assume "x = []" "y = []"
    then show ?thesis using as by simp
  next
    assume "x = []" "y \<noteq> []"
    then show ?thesis using as IH by (metis S_concat S_empty S_match append_Nil)
  next
    assume "x \<noteq> []" "y = []"
    then show ?thesis using as IH by (metis S_concat S_empty S_match append_Nil append_Nil2)
  next
    assume not_empty: "x \<noteq> []" "y \<noteq> []"
    obtain xx where xx: "x = a # xx" using not_empty as by (metis append_eq_Cons_conv)
    obtain yy where yy: "y = yy @ [b]" using not_empty as
      by (metis last.simps last_appendR snoc_eq_iff_butlast)
    have "S (xx @ [a, b] @ yy)" using xx yy IH as by simp
    then show ?thesis using xx yy by (metis S.simps append.assoc append_Cons)
  qed
next
  fix u v x y
  assume IHu: "S u" "\<And>x y. u = x @ y \<Longrightarrow> S (x @ [a, b] @ y)"
  assume IHv: "S v" "\<And>x y. v = x @ y \<Longrightarrow> S (x @ [a, b] @ y)"
  assume as: "u @ v = x @ y"
  show "S (x @ [a, b] @ y)" proof cases
    assume "length x < length u"
    then obtain w where w: "u = x @ w" using append_split as by blast
    then have "S (x @ [a, b] @ w)" using IHu by blast
    then have "S ((x @ [a, b] @ w) @ v)" using IHv S_concat by blast
    then show "S (x @ [a, b] @ y)" using as w by simp
  next
    assume "~ length x < length u"
    then obtain w where w: "v = w @ y" using as
      by (metis append_eq_append_conv_if le_imp_less_Suc less_antisym)
    then have "S (w @ [a, b] @ y)" using IHv by blast
    then have "S (u @ (w @ [a, b] @ y))" using IHu S_concat by blast
    then show "S (x @ [a, b] @ y)" using as w by force
  qed
qed

lemma balanced_wrap: "balanced n w \<Longrightarrow> balanced (Suc n) (w @ [b])"
  by (induction n w rule: balanced.induct; simp)

lemma balanced_concat: "balanced n x \<Longrightarrow> balanced 0 y \<Longrightarrow> balanced n (x @ y)"
  by (induction n x rule: balanced.induct; simp)

lemma replicate_split: "m < n \<Longrightarrow> replicate n x = replicate m x @ replicate (n - m) x"
  by (metis add_diff_inverse_nat less_imp_not_less replicate_add)

theorem "balanced n w = S (replicate n a @ w)" (is "?L = ?R")
proof
  show "?L \<Longrightarrow> ?R" proof (induction n w rule: balanced.induct)
    fix n xs
    assume IH: "balanced (Suc n) xs \<Longrightarrow> S (replicate (Suc n) a @ xs)"
    assume "balanced n (a # xs)"
    then show "S (replicate n a @ a # xs)" using IH
      by (simp add: replicate_app_Cons_same)
  next
    fix n xs
    assume IH: "balanced n xs \<Longrightarrow> S (replicate n a @ xs)"
    assume "balanced (Suc n) (b # xs)"
    then show "S (replicate (Suc n) a @ b # xs)" using IH S_insert
      by (metis balanced_b append.assoc append_Cons append_Nil2 append_eq_append_conv_if replicate_Suc replicate_append_same)
  next
    fix n
    assume "balanced (Suc n) []"
    then show "S (replicate (Suc n) a @ [])" by simp
  next
    fix xs
    assume "balanced 0 (b # xs)"
    then show "S (replicate 0 a @ b # xs)" by simp
  next
    show "S (replicate 0 a @ [])" using S_empty by simp
  qed
next
  show "?R \<Longrightarrow> ?L"
  proof (induction "replicate n a @ w" arbitrary: n w rule: S.induct)
    fix n w
    assume "[] = replicate n a @ w"
    then have "w = [] \<and> n = 0" by simp
    then show "balanced n w" by simp
  next
    fix x n w
    assume IH: "S x" "\<And>n w. x = replicate n a @ w \<Longrightarrow> balanced n w"
    assume as: "a # x @ [b] = replicate n a @ w"
    show "balanced n w" proof (cases n)
      assume "n = 0"
      have "balanced 0 x" using IH by simp
      then show "balanced n w" using \<open>n=0\<close> balanced_wrap as by force
    next
      fix m
      assume m: "n = Suc m"
      then obtain y where y: "y @ [b] = w" using as
        by (metis (mono_tags) alpha.distinct(1) append_butlast_last_id append_is_Nil_conv
                  last_ConsR last_append last_snoc list.discI replicate_append_same)
      then have "x = replicate m a @ y" using m as by force
      then have "balanced m y" using IH by blast
      then show "balanced n w" using m y balanced_wrap by blast
    qed
  next
    fix n w x y
    assume IHx: "S x" "\<And>n w. x = replicate n a @ w \<Longrightarrow> balanced n w"
    assume IHy: "S y" "\<And>n w. y = replicate n a @ w \<Longrightarrow> balanced n w"
    assume as: "x @ y = replicate n a @ w"
    show "balanced n w" proof cases
      assume "x = []"
      then show "balanced n w" using IHy as by simp
    next
      assume x_not_nil: "x \<noteq> []"
      show "balanced n w" proof cases
        assume "n > length x"
        then have "x @ y = replicate (length x) a @ replicate (n - length x) a @ w"
          using as replicate_split by simp
        then have "x = replicate (length x) a" by simp
        then have False using x_not_nil IHx
          by (metis unbalanced_a Nitpick.size_list_simp(2) append_Nil2)
        then show "balanced n w" by fast
      next
        assume small_n: "\<not> length x < n"
        then obtain z where z: "x = replicate n a @ z" using as append_split
          by (metis append_Nil2 append_eq_append_conv_if length_replicate linorder_neqE_nat)
        then have left: "balanced n z" using IHx by blast
        have right: "balanced 0 y" using IHy by simp
        have w: "w = z @ y" using z as by simp
        from left right w show "balanced n w" using balanced_concat by simp
      qed
    qed
  qed
qed


header{*Basics needed*}

theory PerfectBasics
imports Main "~~/src/HOL/Number_Theory/Primes" "~~/src/HOL/Algebra/Exponent"
begin

lemma setsum_mono2_nat: "finite (B::nat set) \<Longrightarrow> A <= B \<Longrightarrow> \<Sum> A <= \<Sum> B"
by (auto simp add: setsum_mono2)

lemma seteq_imp_setsumeq: "A=B ==> \<Sum> A = \<Sum> B" by simp

lemma exp_is_max_div:
   assumes m0:"m>0" and p: "prime p"
   shows "~ p dvd (m div (p^(exponent p m)))"
proof (rule ccontr)
 assume "~ ~ p dvd (m div (p^(exponent p m)))"
 hence a:"p dvd (m div (p^(exponent p m)))" by auto
 from m0 have "p^(exponent p m) dvd m" by (auto simp add: power_exponent_dvd)
 with a have "p*(p^exponent p m) dvd m"
   by (metis (full_types) div_dvd_div div_mult_self2_is_id dvd_triv_right neq0_conv p
      zero_less_prime_power)
 with p have "m=0" by (auto simp add: power_Suc_exponent_Not_dvd)
 with m0 show "False" by auto
qed

lemma coprime_exponent:
  assumes p:"prime p" and m:"m>0"
  shows "coprime p (m div (p^(exponent p m)))"
proof (rule ccontr)
  assume " ~ coprime p (m div p ^ exponent p m)"
  hence "EX q. prime q & q dvd p & q dvd (m div (p^(exponent p m)))"
    by (metis dvd.dual_order.refl p prime_imp_coprime_nat)
  hence "EX q. q = p & q dvd (m div (p^(exponent p m)))"
    by (metis one_not_prime_nat p prime_nat_def)
  hence  "EX q. p dvd (m div (p^(exponent p m)))" by auto
  hence "p dvd (m div (p^(exponent p m)))" by auto
  with p m show "False" by (auto simp add: exp_is_max_div)
qed

lemma add_mult_distrib_three: "(x::nat)*(a+b+c)=x*a+x*b+x*c"
proof -
  have "(x::nat)*(a+b+c) = x*((a+b)+c)" by auto
  hence "x*(a+b+c) = x*(a+b)+x*c" by (metis add_mult_distrib2 add.commute add.left_commute)
  thus "x*(a+b+c) = x*a+x*b+x*c" by (metis add_mult_distrib2 add.commute add.left_commute)
qed

lemma nat_interval_minus_zero: "{0..Suc n} = {0} Un {Suc 0..Suc n}" by auto
lemma nat_interval_minus_zero2:
 assumes "n>0"
 shows "{0..n} = {0} Un {Suc 0..n}" by (auto simp add: nat_interval_minus_zero)

theorem simplify_sum_of_powers: "(x - 1::nat) * (\<Sum>i=0 .. n . x^i)  = x^(n + 1) - 1" (is "?l = ?r")
proof (cases)
  assume "n = 0"
  thus "?l = x^(n+1) - 1" by auto
  next
  assume "n~=0"
  hence n0: "n>0" by auto
  have "?l  = (x::nat)*(\<Sum>i=0 .. n . x^i) - (\<Sum>i=0 .. n . x^i)"
    by (metis diff_mult_distrib nat_mult_1)
  also have "... = (\<Sum>i=0 .. n . x^(Suc i))    - (\<Sum>i=0 .. n . x^i)"
    by (simp add: setsum_right_distrib)
  also have "... = (\<Sum>i=Suc 0 .. Suc n . x^i)  - (\<Sum>i=0 .. n . x^i)"
    by (metis setsum_shift_bounds_cl_Suc_ivl)
  also with n0
  have "... = ((\<Sum>i=Suc 0 .. n. x^i)+x^(Suc n)) - (x^0 + (\<Sum>i=Suc 0 .. n. x^i))"
    by (auto simp add: setsum.union_disjoint nat_interval_minus_zero2)
  finally show "?thesis" by auto
qed

end


theory properties
  imports "../TBAs/closure_algebra"
begin

(**We investigate some well known topological properties of sets drawing upon closure algebras.*)

(**Sets with an empty interior are called boundary.*)
definition boundary ("boundary[_]")
  where "boundary[\<C>] A \<equiv> \<I>[\<C>] A \<approx> \<^bold>\<bottom>"

(**Boundary sets can be equivalently defined as the fixed points of the border operator.*)
lemma boundary_def2: "Cl_2 \<C> \<Longrightarrow> boundary[\<C>] = Br[\<C>]" by (simp add: Br_Iempty boundary_def ext)

(**Sets whose closure is the whole domain are called dense.*)
definition dense ("dense[_]")
  where "dense[\<C>] A \<equiv> \<C> A \<approx> \<^bold>\<top>"

(**A set is dense iff its complement is boundary.*)
lemma dense_def2: "dense[\<C>] A = boundary[\<C>] (\<^bold>\<midarrow>A)" unfolding dense_def boundary_def by (simp add: bottom_def compl_def op_dual_def setequ_char top_def)
(**Dense sets can be equivalently defined as the fixed points of the dual-border operator.*)
lemma dense_def3: "Cl_2 \<C> \<Longrightarrow> dense[\<C>] = fp (\<B>[\<C>])\<^sup>d" by (metis (full_types) boundary_def2 dense_def2 fp3 fp_d op_equal_equ setequ_char setequ_equ)

(**Sets whose closure is a boundary set are called nowhere-dense.*)
definition nowhereDense ("nowhereDense[_]")
  where "nowhereDense[\<C>] A \<equiv> boundary[\<C>] (\<C> A)"

(**For closed sets the properties of boundary and nowhere-dense collapse.*)
lemma Cl_bnd_nwdn: "\<forall>A. Cl[\<C>] A \<longrightarrow> boundary[\<C>] A = nowhereDense[\<C>] A" by (simp add: fixpoint_pred_def nowhereDense_def setequ_equ)

(**Let us introduce a definition for the sets mentioned above (nowhere-dense and closed).*)
definition nowhereDenseCl ("nowhereDenseCl[_]")
  where "nowhereDenseCl[\<C>] A \<equiv> nowhereDense[\<C>] A \<and> Cl[\<C>] A"

(**A set is nowhere-dense and closed iff its complement is dense and open.*)
lemma nowhereDenseCl_def2: "nowhereDenseCl[\<C>] A = (dense[\<C>] (\<^bold>\<midarrow>A) \<and> Op[\<C>] (\<^bold>\<midarrow>A))" by (metis BA_dn Cl_bnd_nwdn OpCldual dense_def2 nowhereDenseCl_def)
(**Nowhere-dense closed sets can be equivalently defined as the fixed points of the frontier operator.*)
lemma nowhereDenseCl_def3: "Cl_2 \<C> \<Longrightarrow> nowhereDenseCl[\<C>] = Fr[\<C>]" using Cl_bnd_nwdn Fr_ClBr boundary_def2 nowhereDenseCl_def by fastforce

end