theory MoreCoq
imports Main
begin

section {* MoreCoq *}
subsection {* The apply Tactic *}

theorem silly1: "\<forall>n m l p. n = m \<longrightarrow> [n,l] = [n,p] \<longrightarrow> [n,l] = [m,p]"
by simp

theorem silly2: "\<forall>n m l p. n = m \<longrightarrow> (\<forall>q r. q = r \<longrightarrow> [q,l] = [r,p]) \<longrightarrow> [n,l] = [m,p]"
by simp

theorem silly2a: "\<forall>n m. (n,n) = (m,m) \<longrightarrow> (\<forall>q r. (q,q) = (r,r) \<longrightarrow> [q] = [r]) \<longrightarrow> [n] = [m]"
by simp

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

fun evenb where "evenb n = (n mod 2 = 0)"
fun oddb where "oddb n = (n mod 2 = 1)"

theorem silly_ex: "(\<forall>(n :: nat). evenb n = True \<longrightarrow> oddb (Suc n) = True) \<longrightarrow> evenb (3 :: nat) = True \<longrightarrow> oddb 4 = True" by simp
theorem silly3_firsttry: "\<forall>(n :: nat). True = (n = 5) \<longrightarrow> (Suc (Suc n)) = 7 = True" by simp
theorem silly3: "\<forall>(n :: nat). True = (n = 5) \<longrightarrow> (Suc (Suc n)) = 7 = True" by simp

(* Exercise: 3 stars (apply_exercise1) *)

theorem rev_exercise1: "\<forall>l l' :: nat list. l = rev l' \<longrightarrow> l' = rev l" by simp

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

subsection {* The apply ... with ... Tactic *}

lemma trans_eq_example: "\<forall>a b c d e f :: nat. [a,b] = [c,d] \<longrightarrow> [c,d] = [e,f] \<longrightarrow> [a,b] = [e,f]" by simp
theorem trans_eq: "\<forall>n m o'. n = m \<longrightarrow> m = o' \<longrightarrow> n = o'" by simp
lemma trans_eq_example': "\<forall>a b c d e f :: nat. [a,b] = [c,d] \<longrightarrow> [c,d] = [e,f] \<longrightarrow> [a,b] = [e,f]"
by auto

(* Exercise: 3 stars, optional (apply_with_exercise) *)

fun minustwo where "minustwo n = n - 2"
lemma trans_eq_exercise: "\<forall>n m o' p :: nat. m = (minustwo o') \<longrightarrow> (n + p) = m \<longrightarrow> (n + p) = (minustwo o')" by simp

subsection {* The inversion tactic *}

theorem eq_add_S: "\<forall>n m :: nat. Suc n = Suc m \<longrightarrow> n = m" by simp
theorem silly4: "\<forall>n m :: nat. [n] = [m] \<longrightarrow> n = m" by simp
theorem silly5: "\<forall>n m o' :: nat. [n,m] = [o',o'] \<longrightarrow> [n] = [m]" by simp

(* cut *)

end


(* Author: Tobias Nipkow *)

section "AVL Tree Implementation of Maps"

theory AVL_Map
imports
  AVL_Set
  Lookup2
begin

fun update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) avl_tree \<Rightarrow> ('a*'b) avl_tree" where
"update x y Leaf = Node 1 Leaf (x,y) Leaf" |
"update x y (Node h l (a,b) r) = (case cmp x a of
   EQ \<Rightarrow> Node h l (x,y) r |
   LT \<Rightarrow> balL (update x y l) (a,b) r |
   GT \<Rightarrow> balR l (a,b) (update x y r))"

fun delete :: "'a::linorder \<Rightarrow> ('a*'b) avl_tree \<Rightarrow> ('a*'b) avl_tree" where
"delete _ Leaf = Leaf" |
"delete x (Node h l (a,b) r) = (case cmp x a of
   EQ \<Rightarrow> del_root (Node h l (a,b) r) |
   LT \<Rightarrow> balR (delete x l) (a,b) r |
   GT \<Rightarrow> balL l (a,b) (delete x r))"

subsection {* Functional Correctness Proofs *}

theorem inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by (induct t) (auto simp: upd_list_simps inorder_balL inorder_balR)

theorem inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder (delete x t) = del_list x (inorder t)"
by(induction t)
  (auto simp: del_list_simps inorder_balL inorder_balR
     inorder_del_root inorder_del_maxD split: prod.splits)

interpretation Map_by_Ordered
where empty = Leaf and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed auto

end


theory PartialFunctions
  imports Main
begin

type_synonym ('a,'b) pfunc = \<open>'a \<Rightarrow> 'b option\<close> (infixl \<open>\<mapsto>\<close> 55)

definition id_on :: \<open>'a set \<Rightarrow> 'a \<mapsto> 'a\<close> where
  \<open>id_on X x \<equiv> if x \<in> X then Some x else None\<close>

definition map_inv :: \<open>('a \<mapsto> 'b) \<Rightarrow> 'b \<mapsto> 'a\<close> where
  \<open>map_inv f x \<equiv>
      if x \<in> ran f then Some (inv_into (dom f) f (Some x)) else None\<close>

abbreviation minj :: \<open>('a \<mapsto> 'b) \<Rightarrow> bool\<close> where
  \<open>minj f \<equiv> inj_on f (dom f)\<close>

lemma id_on_eq_I1: \<open>x \<in> X \<Longrightarrow> id_on X x = Some x\<close>
  by (auto simp: id_on_def)

lemma id_on_eq_I2: \<open>x \<notin> X \<Longrightarrow> id_on X x = None\<close>
  by (auto simp: id_on_def)

lemma id_on_eq_cases[cases pred]:
  assumes \<open>id_on X x = y\<close>
  obtains (none) \<open>x \<notin> X\<close> \<open>y = None\<close> |
          (some) \<open>x \<in> X\<close> \<open>y = Some x\<close>
  using assms
  by (cases \<open>x \<in> X\<close> ; auto simp: id_on_def)

lemma id_on_comp_left:
  assumes \<open>ran f \<subseteq> X\<close>
  shows \<open>id_on X \<circ>\<^sub>m f = f\<close>
  apply (intro ext ; simp add: map_comp_def id_on_def)
  using assms
  by (metis id_on_def option.case_eq_if option.exhaust_sel ranI subsetD)

lemma id_on_comp_right:
  assumes \<open>dom f \<subseteq> X\<close>
  shows \<open>f \<circ>\<^sub>m id_on X = f\<close>
  apply (intro ext ; simp add: map_comp_def id_on_def)
  using assms
  by (metis domIff subsetD)

lemma id_on_dom[simp]: \<open>dom (id_on X) = X\<close>
  by (auto simp: id_on_def dom_def)

lemma id_on_ran[simp]: \<open>ran (id_on X) = X\<close>
  by (auto simp: id_on_def ran_def)

lemma id_on_unique:
  fixes f :: \<open>'a \<Rightarrow> 'a option\<close>
  assumes \<open>ran f = dom f\<close>
          \<open>\<And>g :: 'a \<Rightarrow> 'a option. ran g \<subseteq> dom f \<Longrightarrow> f \<circ>\<^sub>m g = g\<close>
          \<open>\<And>g :: 'a \<Rightarrow> 'a option. ran f \<subseteq> dom g \<Longrightarrow> g \<circ>\<^sub>m f = g\<close>
  shows \<open>f = id_on (dom f)\<close>
proof -
  have f_inj: \<open>inj_on f (dom f)\<close>
  proof (rule ccontr)
    assume \<open>\<not> inj_on f (dom f)\<close>
    then obtain x y
      where A: \<open>x \<in> dom f\<close> \<open>y \<in> dom f\<close>
               \<open>x \<noteq> y\<close> \<open>f x = f y\<close>
      by (meson inj_onI)
    then consider \<open>f x \<noteq> Some x\<close> | \<open>f y \<noteq> Some y\<close>
      by fastforce
    then obtain z where z: \<open>z \<in> dom f\<close> \<open>f z \<noteq> Some z\<close>
      using A by metis
    have B: \<open>f \<circ>\<^sub>m id_on (dom f) \<noteq> id_on (dom f)\<close>
    proof
      assume \<open>f \<circ>\<^sub>m id_on (dom f) = id_on (dom f)\<close>
      then have \<open>(f \<circ>\<^sub>m id_on (dom f)) z = id_on (dom f) z\<close> by simp
      then have \<open>f z = id_on (dom f) z\<close>
        using id_on_comp_right[of f \<open>dom f\<close>] by simp
      then have \<open>f z = Some z\<close>
        using \<open>z \<in> dom f\<close> id_on_eq_I1 by simp
      then show False using \<open>f z \<noteq> Some z\<close> by simp
    qed
    have \<open>f \<circ>\<^sub>m id_on (dom f) = id_on (dom f)\<close>
      by (intro assms(2) ; simp?)
    then show False using B by simp
  qed
  then have inv_left: \<open>inv_into (dom f) f (f x) = x\<close> if \<open>x \<in> dom f\<close> for x
    using inv_into_f_f f_inj that by metis
  define g where
      \<open>g x \<equiv> if x \<in> dom f then Some (inv_into (dom f) f (Some x)) else None\<close>
    for x
  have not_in_dom_none: \<open>x \<notin> dom f \<Longrightarrow> f x = None\<close> for x
    by auto
  have R1: \<open>g \<circ>\<^sub>m f = id_on (dom f)\<close>
    apply (intro ext ; simp add: g_def map_comp_def)
    subgoal for x
      apply (cases \<open>x \<in> dom f\<close>)
      subgoal premises x_in_dom
        using x_in_dom apply (simp add: dom_def id_on_def)
        apply (elim exE ; simp add: g_def ; auto)
        subgoal premises P for y z
          by (intro inv_left[of x,simplified P(1)] x_in_dom)
        subgoal premises P for y
          using x_in_dom
          by (metis P assms(1) domD ranI)
        done
      subgoal premises x_not_in_dom
        by (simp add: not_in_dom_none[OF x_not_in_dom]
                       id_on_def x_not_in_dom)
      done
    done
  have R2: \<open>ran f \<subseteq> dom g\<close>
    by (simp add: assms(1) domI g_def subset_iff)
  have \<open>g = id_on (dom f)\<close>
    using R1 assms(3)[OF R2] by simp
  then have R3: \<open>id_on (dom f) \<circ>\<^sub>m f = id_on (dom f)\<close>
    using R1 by simp
  have R4: \<open>id_on (dom f) \<circ>\<^sub>m f = f\<close>
    using id_on_comp_left[of f \<open>dom f\<close>] assms(1) by simp
  then show \<open>f = id_on (dom f)\<close> using R3 by simp
qed

lemma id_on_minj[intro!,simp]: \<open>minj (id_on X)\<close>
  by (intro inj_onI ; simp ; simp add: id_on_def)

lemma id_on_inj_on[intro!,simp]: \<open>inj_on (id_on X) X\<close>
  by (intro inj_onI ; simp add: id_on_def)

lemma map_inv_id_on[simp]: \<open>map_inv (id_on X) = id_on X\<close>
  apply (intro ext ; simp add: map_inv_def id_on_def; safe)
  subgoal for x
    by (intro inv_into_f_f[of \<open>id_on X\<close> \<open>X\<close>,of x,simplified id_on_eq_I1]
          ; simp)
  done

lemma map_inv_id_on_comp[simp]: \<open>map_inv \<circ> id_on = id_on\<close>
  by auto

lemma map_image_eq_ran[simp]: \<open>f ` dom f = Some ` ran f\<close>
  apply (intro set_eqI iffI ; (elim imageE)?)
  subgoal for x y
    apply (simp add: dom_def ran_def; elim exE ; hypsubst_thin ; simp)
    by (intro imageI ; simp ; blast)
  subgoal for x y
    apply (simp add: ran_def ; elim exE ; hypsubst_thin)
    subgoal for z
      by (intro rev_image_eqI[of z] ; (simp add: dom_def)?)
    done
  done

lemma minj_to_bijI[intro!]:
  assumes \<open>minj f\<close>
  shows \<open>bij_betw f (dom f) (Some ` ran f)\<close>
  using assms inj_on_imp_bij_betw[of f \<open>dom f\<close>]
  by simp

lemma minj_to_bij_iff[simp]:
  \<open>bij_betw f (dom f) (Some ` ran f) \<longleftrightarrow> minj f\<close>
  apply auto
  using bij_betw_imp_inj_on by blast

lemma map_comp_in_dom_eq: \<open>x \<in> dom f \<Longrightarrow> (g \<circ>\<^sub>m f) x = g (the (f x))\<close>
  by (auto simp: map_comp_def)

lemma map_comp_not_in_dom_eq: \<open>x \<notin> dom f \<Longrightarrow> (g \<circ>\<^sub>m f) x = None\<close>
  by (simp add: map_comp_def dom_def)

lemmas map_comp_simps = map_comp_in_dom_eq map_comp_not_in_dom_eq

lemma inj_on_the[intro!,simp]: \<open>inj_on the (Some ` UNIV)\<close>
  by (intro inj_onI ; (elim imageE)? ; simp)

lemma id_on_univ_eq_some[simp]: \<open>id_on UNIV = Some\<close>
  by (auto simp: id_on_def)

lemma id_on_comp_int[simp]: \<open>id_on X \<circ>\<^sub>m id_on Y = id_on (X \<inter> Y)\<close>
  by (intro ext ; simp add: id_on_def map_comp_def)

lemma the_some_inv: \<open>inv_into (Some ` UNIV) the = Some\<close>
  apply (intro ext)
  by (intro inv_into_f_eq inj_on_the ; simp)

lemma Some_UNIV_eq: \<open>Some ` UNIV = UNIV - {None}\<close>
  apply (auto)
  using notin_range_Some by blast

lemma map_in_on_cases[cases pred]:
  assumes \<open>inj_on f X\<close>
  obtains (subset_dom) \<open>X \<subseteq> dom f\<close> |
          (unique_out) x where \<open>x \<notin> dom f\<close> \<open>x \<in> X\<close> \<open>X - {x} \<subseteq> dom f\<close>
proof -
  have T1: \<open>\<exists>!x. x \<notin> dom f \<and> x \<in> X \<and> X - {x} \<subseteq> dom f\<close> if as: \<open>\<not> X \<subseteq> dom f\<close>
  proof -
    obtain x where A: \<open>x \<in> X\<close> \<open>x \<notin> dom f\<close>
      using as by blast
    have fx[simp]: \<open>f x = None\<close> using A(2) by auto
    have X_eq: \<open>X = insert x (X \<inter> dom f)\<close>
    proof (safe ; (simp add: A(1))?)
      fix y
      assume B: \<open>y \<in> X\<close> \<open>y \<noteq> x\<close>
      show \<open>\<exists>z. f y = Some z\<close>
      proof (rule ccontr ; simp)
        assume \<open>f y = None\<close>
        then have \<open>f x = f y\<close> by simp
        then have \<open>y = x\<close> using A(1) B(1) assms inj_onD by metis
        then show False using B(2) by simp
      qed
    qed
    have R1: \<open>X - {x} \<subseteq> dom f\<close>
      apply (subst X_eq)
      by (intro subsetI ; simp)
    have R2: \<open>\<exists>z. f y = Some z\<close>
      if B: \<open>y \<noteq> x\<close> \<open>y \<in> X\<close> \<open>X - {y} \<subseteq> dom f\<close> for y
    proof -
      have \<open>y \<in> dom f\<close> using X_eq B(1,2) by blast
      then show ?thesis by blast
    qed

    show ?thesis
      by (intro ex1I[of _ x] ; (simp add: A R1)? ; safe
          ; (metis R2)?)
  qed
  show ?thesis
    using T1 that by meson
qed

lemma dom_comp_subset: \<open>dom (g \<circ>\<^sub>m f) \<subseteq> dom f\<close>
  apply (auto simp: map_comp_def)
  subgoal for x y
    by (cases \<open>f x\<close> ; simp)
  done

lemma \<open>inj_on (g \<circ>\<^sub>m f) X \<longleftrightarrow> inj_on f X \<and> inj_on g (the ` f ` X)\<close>
proof (auto)
  show \<open>inj_on f X\<close> if as: \<open>inj_on (g \<circ>\<^sub>m f) X\<close>
  proof
    fix x y
    assume A: \<open>x \<in> X\<close> \<open>y \<in> X\<close> \<open>f x = f y\<close>
    have y_dom_x_dom[simp]: \<open>y \<in> dom (g \<circ>\<^sub>m f) \<longleftrightarrow> x \<in> dom (g \<circ>\<^sub>m f)\<close>
      using A(3) by (cases \<open>f x\<close> ; cases \<open>f y\<close> ; simp add: dom_def)
    have R: \<open>x = y\<close> if as1: \<open>x \<in> dom (g \<circ>\<^sub>m f)\<close>
    proof -
      obtain C: \<open>x \<in> dom f\<close> \<open>y \<in> dom f\<close>
        using as1 y_dom_x_dom dom_comp_subset[of g f] by blast
      have D1: \<open>(g \<circ>\<^sub>m f) x = g (the (f x))\<close>
        using C(1) map_comp_in_dom_eq by force
      have D2: \<open>(g \<circ>\<^sub>m f) y = g (the (f y))\<close>
        using C(2) map_comp_in_dom_eq by force
      then have \<open>(g \<circ>\<^sub>m f) x = (g \<circ>\<^sub>m f) y\<close> using D1 A(3) by simp
      then show \<open>x = y\<close> using as inj_onD A by metis
    qed
    show  \<open>x = y\<close>
      using as
    proof (cases)
      case subset_dom
      then show \<open>x = y\<close>
         using subsetD R A(1) by metis
    next
      case (unique_out z)
      { fix q
        assume \<open>q \<in> X\<close>
        then consider (outlier) \<open>q = z\<close> | (inside) \<open>q \<in> dom (g \<circ>\<^sub>m f)\<close>
          by (metis as domIff inj_on_eq_iff unique_out(1) unique_out(2))
      }
      note inX_cases[consumes 1,case_names outlier inside,cases set] = this
      show ?thesis
        apply (insert \<open>x \<in> X\<close> ; cases x rule: inX_cases ;
               insert \<open>y \<in> X\<close> ; cases y rule: inX_cases ; (simp add: A unique_out)?)
        subgoal using unique_out(1) y_dom_x_dom by metis
        using R by metis
    qed
  qed
  show \<open>inj_on g (the ` f ` X)\<close> if as: \<open>inj_on (g \<circ>\<^sub>m f) X\<close>
  proof (intro inj_onI ; elim imageE ; simp ; hypsubst_thin
        ; rename_tac x y)
    fix x y
    assume A: \<open>g (the (f x)) = g (the (f y))\<close> \<open>x \<in> X\<close> \<open>y \<in> X\<close>
    have \<open>(g \<circ>\<^sub>m f) x = g (the (f x))\<close>
      using map_comp_in_dom_eq A(2) by simp
    show \<open>the (f x) = the (f y)\<close>
    using as   proof (cases)
    case subset_dom
    show ?thesis
    proof (intro inj_onI ; elim imageE ; simp ; hypsubst_thin
        ; rename_tac x y)
      fix x y
      assume as: \<open>g (the (f x)) = g (the (f y))\<close> \<open>x \<in> X\<close> \<open>y \<in> X\<close>
      then obtain x\<^sub>1 y\<^sub>1 where A: \<open>f x\<^sub>1 = Some x\<close> \<open>f y\<^sub>1 = Some y\<close>
        by (auto simp: ran_def)
      then obtain B: \<open>x\<^sub>1 \<in> dom f\<close> \<open>y\<^sub>1 \<in> dom f\<close> by auto
      then obtain C: \<open>x\<^sub>1 \<in> dom (g \<circ>\<^sub>m f)\<close> \<open>y\<^sub>1 \<in> dom (g \<circ>\<^sub>m f)\<close>
        using A
      show \<open>x = y\<close> sorry
    qed

  next
    case (unique_out x)
    then show ?thesis sorry
  qed

    fix x y
    assume A: \<open>x \<in> ran f\<close> \<open>y \<in> ran f\<close> \<open>g x = g y\<close>
    show  \<open>x = y\<close>  sorry
  qed
  show \<open>inj_on (g \<circ>\<^sub>m f) X\<close> if as: \<open>inj_on f X\<close> \<open>inj_on g (ran f)\<close>
  proof
    fix x y
    assume A: \<open>x \<in> X\<close> \<open>y \<in> X\<close> \<open>(g \<circ>\<^sub>m f) x = (g \<circ>\<^sub>m f) y\<close>
    show  \<open>x = y\<close>  sorry
  qed
qed

lemma map_comp_inj_on:

  assumes \<open>inj_on f X\<close> \<open>inj_on g Y\<close> \<open>dom g \<subseteq> ran f\<close>
  shows \<open>minj (g \<circ>\<^sub>m f)\<close>
  using assms(3) apply (intro inj_onI ; simp)
proof -
  define h where \<open>h = g \<circ> the \<circ> f\<close>
  have A: \<open>(g \<circ>\<^sub>m f) x = (g \<circ> the \<circ> f) x\<close> if as: \<open>x \<in> dom f\<close> for x
    apply (simp add: map_comp_def)
    apply (cases \<open>f x\<close> ; simp)
    using as by blast
  have \<open>inj_on (g \<circ> the \<circ> f) (dom f)\<close>
    apply (intro comp_inj_on assms)
    oops

end


(*  Title:      HOL/BNF_Wellorder_Relation.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order relations as needed by bounded natural functors.
*)

section \<open>Well-Order Relations as Needed by Bounded Natural Functors\<close>

theory BNF_Wellorder_Relation
imports Order_Relation
begin

text\<open>In this section, we develop basic concepts and results pertaining
to well-order relations.  Note that we consider well-order relations
as {\em non-strict relations},
i.e., as containing the diagonals of their fields.\<close>

locale wo_rel =
  fixes r :: "'a rel"
  assumes WELL: "Well_order r"
begin

text\<open>The following context encompasses all this section. In other words,
for the whole section, we consider a fixed well-order relation \<^term>\<open>r\<close>.\<close>

(* context wo_rel  *)

abbreviation under where "under \<equiv> Order_Relation.under r"
abbreviation underS where "underS \<equiv> Order_Relation.underS r"
abbreviation Under where "Under \<equiv> Order_Relation.Under r"
abbreviation UnderS where "UnderS \<equiv> Order_Relation.UnderS r"
abbreviation above where "above \<equiv> Order_Relation.above r"
abbreviation aboveS where "aboveS \<equiv> Order_Relation.aboveS r"
abbreviation Above where "Above \<equiv> Order_Relation.Above r"
abbreviation AboveS where "AboveS \<equiv> Order_Relation.AboveS r"
abbreviation ofilter where "ofilter \<equiv> Order_Relation.ofilter r"
lemmas ofilter_def = Order_Relation.ofilter_def[of r]

subsection \<open>Auxiliaries\<close>

lemma REFL: "Refl r"
using WELL order_on_defs[of _ r] by auto

lemma TRANS: "trans r"
using WELL order_on_defs[of _ r] by auto

lemma ANTISYM: "antisym r"
using WELL order_on_defs[of _ r] by auto

lemma TOTAL: "Total r"
using WELL order_on_defs[of _ r] by auto

lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force

lemma LIN: "Linear_order r"
using WELL well_order_on_def[of _ r] by auto

lemma WF: "wf (r - Id)"
using WELL well_order_on_def[of _ r] by auto

lemma cases_Total:
"\<And> phi a b. \<lbrakk>{a,b} <= Field r; ((a,b) \<in> r \<Longrightarrow> phi a b); ((b,a) \<in> r \<Longrightarrow> phi a b)\<rbrakk>
             \<Longrightarrow> phi a b"
using TOTALS by auto

lemma cases_Total3:
"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (b,a) \<in> r - Id \<Longrightarrow> phi a b);
              (a = b \<Longrightarrow> phi a b)\<rbrakk>  \<Longrightarrow> phi a b"
using TOTALS by auto

subsection \<open>Well-founded induction and recursion adapted to non-strict well-order relations\<close>

text\<open>Here we provide induction and recursion principles specific to {\em non-strict}
well-order relations.
Although minor variations of those for well-founded relations, they will be useful
for doing away with the tediousness of
having to take out the diagonal each time in order to switch to a well-founded relation.\<close>

lemma well_order_induct:
assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
shows "P a"
proof-
  have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
  using IND by blast
  thus "P a" using WF wf_induct[of "r - Id" P a] by blast
qed

definition
worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
"worec F \<equiv> wfrec (r - Id) F"

definition
adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
where
"adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"

lemma worec_fixpoint:
assumes ADM: "adm_wo H"
shows "worec H = H (worec H)"
proof-
  let ?rS = "r - Id"
  have "adm_wf (r - Id) H"
  unfolding adm_wf_def
  using ADM adm_wo_def[of H] underS_def[of r] by auto
  hence "wfrec ?rS H = H (wfrec ?rS H)"
  using WF wfrec_fixpoint[of ?rS H] by simp
  thus ?thesis unfolding worec_def .
qed

subsection \<open>The notions of maximum, minimum, supremum, successor and order filter\<close>

text\<open>
We define the successor {\em of a set}, and not of an element (the latter is of course
a particular case).  Also, we define the maximum {\em of two elements}, \<open>max2\<close>,
and the minimum {\em of a set}, \<open>minim\<close> -- we chose these variants since we
consider them the most useful for well-orders.  The minimum is defined in terms of the
auxiliary relational operator \<open>isMinim\<close>.  Then, supremum and successor are
defined in terms of minimum as expected.
The minimum is only meaningful for non-empty sets, and the successor is only
meaningful for sets for which strict upper bounds exist.
Order filters for well-orders are also known as ``initial segments".\<close>

definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where "max2 a b \<equiv> if (a,b) \<in> r then b else a"

definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"

definition minim :: "'a set \<Rightarrow> 'a"
where "minim A \<equiv> THE b. isMinim A b"

definition supr :: "'a set \<Rightarrow> 'a"
where "supr A \<equiv> minim (Above A)"

definition suc :: "'a set \<Rightarrow> 'a"
where "suc A \<equiv> minim (AboveS A)"

subsubsection \<open>Properties of max2\<close>

lemma max2_greater_among:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
proof-
  {assume "(a,b) \<in> r"
   hence ?thesis using max2_def assms REFL refl_on_def
   by (auto simp add: refl_on_def)
  }
  moreover
  {assume "a = b"
   hence "(a,b) \<in> r" using REFL  assms
   by (auto simp add: refl_on_def)
  }
  moreover
  {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
   hence "(a,b) \<notin> r" using ANTISYM
   by (auto simp add: antisym_def)
   hence ?thesis using * max2_def assms REFL refl_on_def
   by (auto simp add: refl_on_def)
  }
  ultimately show ?thesis using assms TOTAL
  total_on_def[of "Field r" r] by blast
qed

lemma max2_greater:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
using assms by (auto simp add: max2_greater_among)

lemma max2_among:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "max2 a b \<in> {a, b}"
using assms max2_greater_among[of a b] by simp

lemma max2_equals1:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(max2 a b = a) = ((b,a) \<in> r)"
using assms ANTISYM unfolding antisym_def using TOTALS
by(auto simp add: max2_def max2_among)

lemma max2_equals2:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(max2 a b = b) = ((a,b) \<in> r)"
using assms ANTISYM unfolding antisym_def using TOTALS
unfolding max2_def by auto

lemma in_notinI:
assumes "(j,i) \<notin> r \<or> j = i" and "i \<in> Field r" and "j \<in> Field r"
shows "(i,j) \<in> r" using assms max2_def max2_greater_among by fastforce

subsubsection \<open>Existence and uniqueness for isMinim and well-definedness of minim\<close>

lemma isMinim_unique:
assumes MINIM: "isMinim B a" and MINIM': "isMinim B a'"
shows "a = a'"
proof-
  {have "a \<in> B"
   using MINIM isMinim_def by simp
   hence "(a',a) \<in> r"
   using MINIM' isMinim_def by simp
  }
  moreover
  {have "a' \<in> B"
   using MINIM' isMinim_def by simp
   hence "(a,a') \<in> r"
   using MINIM isMinim_def by simp
  }
  ultimately
  show ?thesis using ANTISYM antisym_def[of r] by blast
qed

lemma Well_order_isMinim_exists:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "\<exists>b. isMinim B b"
proof-
  from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
    *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
  have "\<forall>b'. b' \<in> B \<longrightarrow> (b, b') \<in> r"
  proof
    fix b'
    show "b' \<in> B \<longrightarrow> (b, b') \<in> r"
    proof
      assume As: "b' \<in> B"
      hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
      from As  * have "b' = b \<or> (b',b) \<notin> r" by auto
      moreover have "b' = b \<Longrightarrow> (b, b') \<in> r"
        using ** REFL by (auto simp add: refl_on_def)
      moreover have "b' \<noteq> b \<and> (b',b) \<notin> r \<Longrightarrow> (b,b') \<in> r"
         using ** TOTAL by (auto simp add: total_on_def)
      ultimately show "(b,b') \<in> r" by blast
    qed
  qed
  then have "isMinim B b"
    unfolding isMinim_def using * by auto
  then show ?thesis
    by auto
qed

lemma minim_isMinim:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "isMinim B (minim B)"
proof-
  let ?phi = "(\<lambda> b. isMinim B b)"
  from assms Well_order_isMinim_exists
  obtain b where *: "?phi b" by blast
  moreover
  have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
  using isMinim_unique * by auto
  ultimately show ?thesis
  unfolding minim_def using theI[of ?phi b] by blast
qed

subsubsection\<open>Properties of minim\<close>

lemma minim_in:
assumes "B \<le> Field r" and "B \<noteq> {}"
shows "minim B \<in> B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by simp
  thus ?thesis by (simp add: isMinim_def)
qed

lemma minim_inField:
assumes "B \<le> Field r" and "B \<noteq> {}"
shows "minim B \<in> Field r"
proof-
  have "minim B \<in> B" using assms by (simp add: minim_in)
  thus ?thesis using assms by blast
qed

lemma minim_least:
assumes  SUB: "B \<le> Field r" and IN: "b \<in> B"
shows "(minim B, b) \<in> r"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  thus ?thesis by (auto simp add: isMinim_def IN)
qed

lemma equals_minim:
assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
        LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
shows "a = minim B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  moreover have "isMinim B a" using IN LEAST isMinim_def by auto
  ultimately show ?thesis
  using isMinim_unique by auto
qed

subsubsection\<open>Properties of successor\<close>

lemma suc_AboveS:
assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
shows "suc B \<in> AboveS B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r] by auto
  thus "minim (AboveS B) \<in> AboveS B"
  using assms by (simp add: minim_in)
qed

lemma suc_greater:
assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and
        IN: "b \<in> B"
shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
proof-
  from assms suc_AboveS
  have "suc B \<in> AboveS B" by simp
  with IN AboveS_def[of r] show ?thesis by simp
qed

lemma suc_least_AboveS:
assumes ABOVES: "a \<in> AboveS B"
shows "(suc B,a) \<in> r"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r] by auto
  thus "(minim (AboveS B),a) \<in> r"
  using assms minim_least by simp
qed

lemma suc_inField:
assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
shows "suc B \<in> Field r"
proof-
  have "suc B \<in> AboveS B" using suc_AboveS assms by simp
  thus ?thesis
  using assms AboveS_Field[of r] by auto
qed

lemma equals_suc_AboveS:
assumes SUB: "B \<le> Field r" and ABV: "a \<in> AboveS B" and
        MINIM: "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
shows "a = suc B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r B] by auto
  thus "a = minim (AboveS B)"
  using assms equals_minim
  by simp
qed

lemma suc_underS:
assumes IN: "a \<in> Field r"
shows "a = suc (underS a)"
proof-
  have "underS a \<le> Field r"
  using underS_Field[of r] by auto
  moreover
  have "a \<in> AboveS (underS a)"
  using in_AboveS_underS IN by fast
  moreover
  have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
  proof(clarify)
    fix a'
    assume *: "a' \<in> AboveS (underS a)"
    hence **: "a' \<in> Field r"
    using AboveS_Field by fast
    {assume "(a,a') \<notin> r"
     hence "a' = a \<or> (a',a) \<in> r"
     using TOTAL IN ** by (auto simp add: total_on_def)
     moreover
     {assume "a' = a"
      hence "(a,a') \<in> r"
      using REFL IN ** by (auto simp add: refl_on_def)
     }
     moreover
     {assume "a' \<noteq> a \<and> (a',a) \<in> r"
      hence "a' \<in> underS a"
      unfolding underS_def by simp
      hence "a' \<notin> AboveS (underS a)"
      using AboveS_disjoint by fast
      with * have False by simp
     }
     ultimately have "(a,a') \<in> r" by blast
    }
    thus  "(a, a') \<in> r" by blast
  qed
  ultimately show ?thesis
  using equals_suc_AboveS by auto
qed

subsubsection \<open>Properties of order filters\<close>

lemma under_ofilter:
"ofilter (under a)"
proof -
  have "\<And>aa x. (aa, a) \<in> r \<Longrightarrow> (x, aa) \<in> r \<Longrightarrow> (x, a) \<in> r"
  proof -
    fix aa x
    assume "(aa,a) \<in> r" "(x,aa) \<in> r"
    then show "(x,a) \<in> r"
      using TRANS trans_def[of r] by blast
  qed
  then show ?thesis unfolding ofilter_def under_def
    by (auto simp add: Field_def)
qed

lemma underS_ofilter:
"ofilter (underS a)"
  unfolding ofilter_def underS_def under_def
proof safe
  fix aa assume "(a, aa) \<in> r" "(aa, a) \<in> r" and DIFF: "aa \<noteq> a"
  thus False
  using ANTISYM antisym_def[of r] by blast
next
  fix aa x
  assume "(aa,a) \<in> r" "aa \<noteq> a" "(x,aa) \<in> r"
  thus "(x,a) \<in> r"
    using TRANS trans_def[of r] by blast
next
  fix x
  assume "x \<noteq> a" and "(x, a) \<in> r"
  then show "x \<in> Field r"
    unfolding Field_def
    by auto
qed

lemma Field_ofilter:
"ofilter (Field r)"
by(unfold ofilter_def under_def, auto simp add: Field_def)

lemma ofilter_underS_Field:
"ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
proof
  assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
  thus "ofilter A"
  by (auto simp: underS_ofilter Field_ofilter)
next
  assume *: "ofilter A"
  let ?One = "(\<exists>a\<in>Field r. A = underS a)"
  let ?Two = "(A = Field r)"
  show "?One \<or> ?Two"
  proof(cases ?Two)
    let ?B = "(Field r) - A"
    let ?a = "minim ?B"
    assume "A \<noteq> Field r"
    moreover have "A \<le> Field r" using * ofilter_def by simp
    ultimately have 1: "?B \<noteq> {}" by blast
    hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
    have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
    hence 4: "?a \<notin> A" by blast
    have 5: "A \<le> Field r" using * ofilter_def by auto
    (*  *)
    moreover
    have "A = underS ?a"
    proof
      show "A \<le> underS ?a"
      proof
        fix x assume **: "x \<in> A"
        hence 11: "x \<in> Field r" using 5 by auto
        have 12: "x \<noteq> ?a" using 4 ** by auto
        have 13: "under x \<le> A" using * ofilter_def ** by auto
        {assume "(x,?a) \<notin> r"
         hence "(?a,x) \<in> r"
         using TOTAL total_on_def[of "Field r" r]
               2 4 11 12 by auto
         hence "?a \<in> under x" using under_def[of r] by auto
         hence "?a \<in> A" using ** 13 by blast
         with 4 have False by simp
        }
        then have "(x,?a) \<in> r" by blast
        thus "x \<in> underS ?a"
          unfolding underS_def by (auto simp add: 12)
      qed
    next
      show "underS ?a \<le> A"
      proof
        fix x
        assume **: "x \<in> underS ?a"
        hence 11: "x \<in> Field r"
         using Field_def unfolding underS_def by fastforce
         {assume "x \<notin> A"
          hence "x \<in> ?B" using 11 by auto
          hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
          hence False
          using ANTISYM antisym_def[of r] ** unfolding underS_def by auto
         }
        thus "x \<in> A" by blast
      qed
    qed
    ultimately have ?One using 2 by blast
    thus ?thesis by simp
  next
    assume "A = Field r"
    then show ?thesis
      by simp
  qed
qed

lemma ofilter_UNION:
"(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union>i \<in> I. A i)"
unfolding ofilter_def by blast

lemma ofilter_under_UNION:
assumes "ofilter A"
shows "A = (\<Union>a \<in> A. under a)"
proof
  have "\<forall>a \<in> A. under a \<le> A"
  using assms ofilter_def by auto
  thus "(\<Union>a \<in> A. under a) \<le> A" by blast
next
  have "\<forall>a \<in> A. a \<in> under a"
  using REFL Refl_under_in[of r] assms ofilter_def[of A] by blast
  thus "A \<le> (\<Union>a \<in> A. under a)" by blast
qed

subsubsection\<open>Other properties\<close>

lemma ofilter_linord:
assumes OF1: "ofilter A" and OF2: "ofilter B"
shows "A \<le> B \<or> B \<le> A"
proof(cases "A = Field r")
  assume Case1: "A = Field r"
  hence "B \<le> A" using OF2 ofilter_def by auto
  thus ?thesis by simp
next
  assume Case2: "A \<noteq> Field r"
  with ofilter_underS_Field OF1 obtain a where
  1: "a \<in> Field r \<and> A = underS a" by auto
  show ?thesis
  proof(cases "B = Field r")
    assume Case21: "B = Field r"
    hence "A \<le> B" using OF1 ofilter_def by auto
    thus ?thesis by simp
  next
    assume Case22: "B \<noteq> Field r"
    with ofilter_underS_Field OF2 obtain b where
    2: "b \<in> Field r \<and> B = underS b" by auto
    have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
    using 1 2 TOTAL total_on_def[of _ r] by auto
    moreover
    {assume "a = b" with 1 2 have ?thesis by auto
    }
    moreover
    {assume "(a,b) \<in> r"
     with underS_incr[of r] TRANS ANTISYM 1 2
     have "A \<le> B" by auto
     hence ?thesis by auto
    }
    moreover
     {assume "(b,a) \<in> r"
     with underS_incr[of r] TRANS ANTISYM 1 2
     have "B \<le> A" by auto
     hence ?thesis by auto
    }
    ultimately show ?thesis by blast
  qed
qed

lemma ofilter_AboveS_Field:
assumes "ofilter A"
shows "A \<union> (AboveS A) = Field r"
proof
  show "A \<union> (AboveS A) \<le> Field r"
  using assms ofilter_def AboveS_Field[of r] by auto
next
  {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
   {fix y assume ***: "y \<in> A"
    with ** have 1: "y \<noteq> x" by auto
    {assume "(y,x) \<notin> r"
     moreover
     have "y \<in> Field r" using assms ofilter_def *** by auto
     ultimately have "(x,y) \<in> r"
     using 1 * TOTAL total_on_def[of _ r] by auto
     with *** assms ofilter_def under_def[of r] have "x \<in> A" by auto
     with ** have False by contradiction
    }
    hence "(y,x) \<in> r" by blast
    with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
   }
   with * have "x \<in> AboveS A" unfolding AboveS_def by auto
  }
  thus "Field r \<le> A \<union> (AboveS A)" by blast
qed

lemma suc_ofilter_in:
assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
        REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
shows "b \<in> A"
proof-
  have *: "suc A \<in> Field r \<and> b \<in> Field r"
  using WELL REL well_order_on_domain[of "Field r"] by auto
  {assume **: "b \<notin> A"
   hence "b \<in> AboveS A"
   using OF * ofilter_AboveS_Field by auto
   hence "(suc A, b) \<in> r"
   using suc_least_AboveS by auto
   hence False using REL DIFF ANTISYM *
   by (auto simp add: antisym_def)
  }
  thus ?thesis by blast
qed

end (* context wo_rel *)

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
recently described verification components. Notice that this is an exact copy of
the file @{text HS_VC_MKA_Examples}, meaning our components are truly modular and
we can choose either a relational or predicate transformer semantics.\<close>

theory HS_VC_MKA_Examples_ndfun
  imports HS_VC_MKA_ndfun

begin

subsubsection\<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t
  else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified by providing dynamics. \<close>

lemma pendulum_dyn:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (EVOL \<phi> G T) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by simp

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (simp add: local_flow.wp_g_ode_subset[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection\<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assignment that
flips the velocity. That is, we model it as a completely elastic collision with the ground. We use
@{text "s$1"} to represent the ball's height and @{text "s$2"} for its velocity. We prove that the
ball remains above ground and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma bouncing_ball_inv:
  fixes h::real
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow> \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le>
  wp
    (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)
  ) \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all, force simp: bb_real_arith)
  by (rule wp_g_odei) (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
    by (simp add: monoid_mult_class.power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v))" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((EVOL (\<phi> g) (\<lambda>s. 0 \<le> s$1) T);
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  by (rule wp_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((x\<acute>= (\<lambda>t. f g) & (\<lambda> s. s$1 \<ge> 0) on (\<lambda>s. UNIV) UNIV @ 0);
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all add: local_flow.wp_g_ode_subset[OF local_flow_ball])
  by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection\<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp_all add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.wp_g_ode_subset[OF local_flow_temp]

lemma thermostat:
  assumes "a > 0" and "0 < Tmin" and "Tmax < L"
  shows "\<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0\<rceil> \<le> wp
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f a 0 & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a))
    ELSE (x\<acute>= f a L & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a))) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1)))
  \<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax\<rceil>"
  apply(rule wp_loopI, simp_all add: fbox_temp_dyn[OF assms(1)])
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(3), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,2), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

subsubsection \<open> Tank \<close>

text \<open> A controller turns a water pump on and off to keep the level of water @{text "h"} in a tank
within an acceptable range @{text "hmin \<le> h \<le> hmax"}. Just like in the previous example, after
each intervention, the controller registers the current level of water and resets its chronometer,
then it changes the status of the water pump accordingly. The level of water grows linearly
@{text "h' = k"} at a rate of @{text "k = c\<^sub>i-c\<^sub>o"} if the pump is on, and at a rate of
@{text "k = -c\<^sub>o"} if the pump is off. We use @{term "1::4"} to denote the tank's level of water,
@{term "2::4"} is time as measured by the controller's chronometer, @{term "3::4"} is the
level of water measured by the chronometer, and @{term "4::4"} states whether the pump is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the controller keeps the level of
water between @{text "hmin"} and @{text "hmax"}. \<close>

abbreviation tank_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f k s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then k else 0))"

abbreviation tank_flow :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> k \<tau> s \<equiv> (\<chi> i. if i = 1 then k * \<tau> + s$1 else
  (if i = 2 then \<tau> + s$2 else s$i))"

abbreviation tank_guard :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Hm k s \<equiv> s$2 \<le> (Hm - s$3)/k"

abbreviation tank_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I hmin hmax s \<equiv> hmin \<le> s$1 \<and> s$1 \<le> hmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("dI")
  where "dI hmin hmax k s \<equiv> s$1 = k * s$2 + s$3 \<and> 0 \<le> s$2 \<and>
    hmin \<le> s$3 \<and> s$3 \<le> hmax \<and> (s$4 =0 \<or> s$4 = 1)"

lemma local_flow_tank: "local_flow (f k) UNIV UNIV (\<phi> k)"
  apply (unfold_locales, unfold local_lipschitz_def lipschitz_on_def, simp_all, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
  apply(simp add: dist_norm norm_vec_def L2_set_def, unfold UNIV_4)
  by (auto intro!: poly_derivatives simp: vec_eq_iff)

lemma tank_arith:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - ((hmin - y) / c\<^sub>o) \<Longrightarrow>  hmin \<le> y - c\<^sub>o * \<tau>"
    and "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> (hmax - y) / (c\<^sub>i - c\<^sub>o) \<Longrightarrow>  (c\<^sub>i - c\<^sub>o) * \<tau> + y \<le> hmax"
    and "hmin \<le> y \<Longrightarrow> hmin \<le> (c\<^sub>i - c\<^sub>o) * \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o * \<tau> \<le> hmax"
  apply(simp_all add: field_simps le_divide_eq assms)
  using assms apply (meson add_mono less_eq_real_def mult_left_mono)
  using assms by (meson add_increasing2 less_eq_real_def mult_nonneg_nonneg)

lemma tank_flow:
  assumes "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<lceil>\<lambda>s. I hmin hmax s\<rceil> \<le> wp
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f (c\<^sub>i-c\<^sub>o) & (G hmax (c\<^sub>i-c\<^sub>o)))
     ELSE (x\<acute>= f (-c\<^sub>o) & (G hmin (-c\<^sub>o)))) ) INV I hmin hmax)
  \<lceil>\<lambda>s. I hmin hmax s\<rceil>"
  apply(rule wp_loopI, simp_all add: local_flow.wp_g_ode_subset[OF local_flow_tank])
  using assms tank_arith[OF _ assms] by auto

no_notation tank_vec_field ("f")
        and tank_flow ("\<phi>")
        and tank_loop_inv ("I")
        and tank_diff_inv ("dI")
        and tank_guard ("G")

end


(* Author: Tobias Nipkow *)

subsection "True Liveness Analysis"

theory Live_True
imports "HOL-Library.While_Combinator" Vars Big_Step
begin

subsubsection "Analysis"

fun L :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"L SKIP X = X" |
"L (x ::= a) X = (if x \<in> X then vars a \<union> (X - {x}) else X)" |
"L (c\<^sub>1;; c\<^sub>2) X = L c\<^sub>1 (L c\<^sub>2 X)" |
"L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> L c\<^sub>1 X \<union> L c\<^sub>2 X" |
"L (WHILE b DO c) X = lfp(\<lambda>Y. vars b \<union> X \<union> L c Y)"

lemma L_mono: "mono (L c)"
proof-
  have "X \<subseteq> Y \<Longrightarrow> L c X \<subseteq> L c Y" for X Y
  proof(induction c arbitrary: X Y)
    case (While b c)
    show ?case
    proof(simp, rule lfp_mono)
      fix Z show "vars b \<union> X \<union> L c Z \<subseteq> vars b \<union> Y \<union> L c Z"
        using While by auto
    qed
  next
    case If thus ?case by(auto simp: subset_iff)
  qed auto
  thus ?thesis by(rule monoI)
qed

lemma mono_union_L:
  "mono (\<lambda>Y. X \<union> L c Y)"
by (metis (no_types) L_mono mono_def order_eq_iff set_eq_subset sup_mono)

lemma L_While_unfold:
  "L (WHILE b DO c) X = vars b \<union> X \<union> L c (L (WHILE b DO c) X)"
by(metis lfp_unfold[OF mono_union_L] L.simps(5))

lemma L_While_pfp: "L c (L (WHILE b DO c) X) \<subseteq> L (WHILE b DO c) X"
using L_While_unfold by blast

lemma L_While_vars: "vars b \<subseteq> L (WHILE b DO c) X"
using L_While_unfold by blast

lemma L_While_X: "X \<subseteq> L (WHILE b DO c) X"
using L_While_unfold by blast

text\<open>Disable \<open>L WHILE\<close> equation and reason only with \<open>L WHILE\<close> constraints:\<close>
declare L.simps(5)[simp del]

subsubsection "Correctness"

theorem L_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq c1 s1 s2 c2 s3 X t1)
  from Seq.IH(1) Seq.prems obtain t2 where
    t12: "(c1, t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X"
    by simp blast
  from Seq.IH(2)[OF s2t2] obtain t3 where
    t23: "(c2, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using t12 t23 s3t3 by auto
next
  case (IfTrue b s c1 s' c2)
  hence "s = t on vars b" and "s = t on L c1 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  from IfTrue.IH[OF \<open>s = t on L c1 X\<close>] obtain t' where
    "(c1, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using \<open>bval b t\<close> by auto
next
  case (IfFalse b s c2 s' c1)
  hence "s = t on vars b" "s = t on L c2 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  from IfFalse.IH[OF \<open>s = t on L c2 X\<close>] obtain t' where
    "(c2, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using \<open>~bval b t\<close> by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  thus ?case using WhileFalse.prems L_While_X[of X b c] by auto
next
  case (WhileTrue b s1 c s2 s3 X t1)
  let ?w = "WHILE b DO c"
  from \<open>bval b s1\<close> WhileTrue.prems have "bval b t1"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  have "s1 = t1 on L c (L ?w X)" using  L_While_pfp WhileTrue.prems
    by (blast)
  from WhileTrue.IH(1)[OF this] obtain t2 where
    "(c, t1) \<Rightarrow> t2" "s2 = t2 on L ?w X" by auto
  from WhileTrue.IH(2)[OF this(2)] obtain t3 where "(?w,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with \<open>bval b t1\<close> \<open>(c, t1) \<Rightarrow> t2\<close> show ?case by auto
qed

subsubsection "Executability"

lemma L_subset_vars: "L c X \<subseteq> rvars c \<union> X"
proof(induction c arbitrary: X)
  case (While b c)
  have "lfp(\<lambda>Y. vars b \<union> X \<union> L c Y) \<subseteq> vars b \<union> rvars c \<union> X"
    using While.IH[of "vars b \<union> rvars c \<union> X"]
    by (auto intro!: lfp_lowerbound)
  thus ?case by (simp add: L.simps(5))
qed auto

text\<open>Make \<^const>\<open>L\<close> executable by replacing \<^const>\<open>lfp\<close> with the \<^const>\<open>while\<close> combinator from theory \<^theory>\<open>HOL-Library.While_Combinator\<close>. The \<^const>\<open>while\<close>
combinator obeys the recursion equation
@{thm[display] While_Combinator.while_unfold[no_vars]}
and is thus executable.\<close>

lemma L_While: fixes b c X
assumes "finite X" defines "f == \<lambda>Y. vars b \<union> X \<union> L c Y"
shows "L (WHILE b DO c) X = while (\<lambda>Y. f Y \<noteq> Y) f {}" (is "_ = ?r")
proof -
  let ?V = "vars b \<union> rvars c \<union> X"
  have "lfp f = ?r"
  proof(rule lfp_while[where C = "?V"])
    show "mono f" by(simp add: f_def mono_union_L)
  next
    fix Y show "Y \<subseteq> ?V \<Longrightarrow> f Y \<subseteq> ?V"
      unfolding f_def using L_subset_vars[of c] by blast
  next
    show "finite ?V" using \<open>finite X\<close> by simp
  qed
  thus ?thesis by (simp add: f_def L.simps(5))
qed

lemma L_While_let: "finite X \<Longrightarrow> L (WHILE b DO c) X =
  (let f = (\<lambda>Y. vars b \<union> X \<union> L c Y)
   in while (\<lambda>Y. f Y \<noteq> Y) f {})"
by(simp add: L_While)

lemma L_While_set: "L (WHILE b DO c) (set xs) =
  (let f = (\<lambda>Y. vars b \<union> set xs \<union> L c Y)
   in while (\<lambda>Y. f Y \<noteq> Y) f {})"
by(rule L_While_let, simp)

text\<open>Replace the equation for \<open>L (WHILE \<dots>)\<close> by the executable @{thm[source] L_While_set}:\<close>
lemmas [code] = L.simps(1-4) L_While_set
text\<open>Sorry, this syntax is odd.\<close>

text\<open>A test:\<close>
lemma "(let b = Less (N 0) (V ''y''); c = ''y'' ::= V ''x'';; ''x'' ::= V ''z''
  in L (WHILE b DO c) {''y''}) = {''x'', ''y'', ''z''}"
by eval

subsubsection "Limiting the number of iterations"

text\<open>The final parameter is the default value:\<close>

fun iter :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter f 0 p d = d" |
"iter f (Suc n) p d = (if f p = p then p else iter f n (f p) d)"

text\<open>A version of \<^const>\<open>L\<close> with a bounded number of iterations (here: 2)
in the WHILE case:\<close>

fun Lb :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"Lb SKIP X = X" |
"Lb (x ::= a) X = (if x \<in> X then X - {x} \<union> vars a else X)" |
"Lb (c\<^sub>1;; c\<^sub>2) X = (Lb c\<^sub>1 \<circ> Lb c\<^sub>2) X" |
"Lb (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> Lb c\<^sub>1 X \<union> Lb c\<^sub>2 X" |
"Lb (WHILE b DO c) X = iter (\<lambda>A. vars b \<union> X \<union> Lb c A) 2 {} (vars b \<union> rvars c \<union> X)"

text\<open>\<^const>\<open>Lb\<close> (and \<^const>\<open>iter\<close>) is not monotone!\<close>
lemma "let w = WHILE Bc False DO (''x'' ::= V ''y'';; ''z'' ::= V ''x'')
  in \<not> (Lb w {''z''} \<subseteq> Lb w {''y'',''z''})"
by eval

lemma lfp_subset_iter:
  "\<lbrakk> mono f; !!X. f X \<subseteq> f' X; lfp f \<subseteq> D \<rbrakk> \<Longrightarrow> lfp f \<subseteq> iter f' n A D"
proof(induction n arbitrary: A)
  case 0 thus ?case by simp
next
  case Suc thus ?case by simp (metis lfp_lowerbound)
qed

lemma "L c X \<subseteq> Lb c X"
proof(induction c arbitrary: X)
  case (While b c)
  let ?f  = "\<lambda>A. vars b \<union> X \<union> L  c A"
  let ?fb = "\<lambda>A. vars b \<union> X \<union> Lb c A"
  show ?case
  proof (simp add: L.simps(5), rule lfp_subset_iter[OF mono_union_L])
    show "!!X. ?f X \<subseteq> ?fb X" using While.IH by blast
    show "lfp ?f \<subseteq> vars b \<union> rvars c \<union> X"
      by (metis (full_types) L.simps(5) L_subset_vars rvars.simps(5))
  qed
next
  case Seq thus ?case by simp (metis (full_types) L_mono monoD subset_trans)
qed auto

end


theory ValuesFSet
  imports Main Lambda "HOL-Library.FSet"
begin

datatype val = VNat nat | VFun "(val \<times> val) fset"

type_synonym func = "(val \<times> val) fset"

inductive val_le :: "val \<Rightarrow> val \<Rightarrow> bool" (infix "\<sqsubseteq>" 52) where
  vnat_le[intro!]: "(VNat n) \<sqsubseteq> (VNat n)" |
  vfun_le[intro!]: "fset t1 \<subseteq> fset t2 \<Longrightarrow> (VFun t1) \<sqsubseteq> (VFun t2)"

type_synonym env = "((name \<times> val) list)"

definition env_le :: "env \<Rightarrow> env \<Rightarrow> bool" (infix "\<sqsubseteq>" 52) where
  "\<rho> \<sqsubseteq> \<rho>' \<equiv> \<forall> x v. lookup \<rho> x = Some v \<longrightarrow> (\<exists> v'. lookup \<rho>' x = Some v' \<and> v \<sqsubseteq> v')"

definition env_eq :: "env \<Rightarrow> env \<Rightarrow> bool" (infix "\<approx>" 50) where
  "\<rho> \<approx> \<rho>' \<equiv> (\<forall> x. lookup \<rho> x = lookup \<rho>' x)"

fun vadd :: "(val \<times> nat) \<times> (val \<times> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "vadd ((_,v),(_,u)) r = v + u + r"

primrec vsize :: "val \<Rightarrow> nat" where
"vsize (VNat n) = 1" |
"vsize (VFun t) = 1 + ffold vadd 0
                            (fimage (map_prod (\<lambda> v. (v,vsize v)) (\<lambda> v. (v,vsize v))) t)"

abbreviation vprod_size :: "val \<times> val \<Rightarrow> (val \<times> nat) \<times> (val \<times> nat)" where
  "vprod_size \<equiv> map_prod (\<lambda> v. (v,vsize v)) (\<lambda> v. (v,vsize v))"

abbreviation fsize :: "func \<Rightarrow> nat" where
  "fsize t \<equiv> 1 + ffold vadd 0 (fimage vprod_size t)"

interpretation vadd_vprod: comp_fun_commute "vadd \<circ> vprod_size"
  unfolding comp_fun_commute_def by auto

lemma vprod_size_inj: "inj_on vprod_size (fset A)"
  unfolding inj_on_def by auto

lemma fsize_def2: "fsize t = 1 + ffold (vadd \<circ> vprod_size) 0 t"
  using vprod_size_inj[of t] ffold_fimage[of vprod_size t vadd 0] by simp

lemma fsize_finsert_in[simp]:
  assumes v12_t: "(v1,v2) |\<in>| t" shows "fsize (finsert (v1,v2) t) = fsize t"
proof -
  from v12_t have "finsert (v1,v2) t = t" by auto
  from this show ?thesis by simp
qed

lemma fsize_finsert_notin[simp]:
  assumes v12_t: "(v1,v2) |\<notin>| t"
  shows "fsize (finsert (v1,v2) t) = vsize v1 + vsize v2 + fsize t"
proof -
  let ?f = "vadd \<circ> vprod_size"
  have "fsize (finsert (v1,v2) t) = 1 + ffold ?f 0 (finsert (v1,v2) t)"
    using fsize_def2[of "finsert (v1,v2) t"] by simp
  also from v12_t have "... = 1 + ?f (v1,v2) (ffold ?f 0 t)" by simp
  finally have "fsize (finsert (v1,v2) t) = 1 + ?f (v1,v2) (ffold ?f 0 t)" .
  from this show ?thesis using fsize_def2[of t] by simp
qed

end


(*
  Copyright (c) 2015--2019 by Clemens Ballarin
  This file is licensed under the 3-clause BSD license.
*)

theory Ring_Theory imports Group_Theory begin

no_notation plus (infixl "+" 65)
no_notation minus (infixl "-" 65)
no_notation uminus ("- _" [81] 80)
no_notation quotient (infixl "'/'/" 90)

section \<open>Rings\<close>

subsection \<open>Definition and Elementary Properties\<close>

text \<open>Def 2.1\<close>
text \<open>p 86, ll 20--28\<close>
locale ring = additive: abelian_group R "(+)" \<zero> + multiplicative: monoid R "(\<cdot>)" \<one>
  for R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>") +
  assumes distributive: "\<lbrakk> a \<in> R; b \<in> R; c \<in> R \<rbrakk> \<Longrightarrow> a \<cdot> (b + c) = a \<cdot> b + a \<cdot> c"
    "\<lbrakk> a \<in> R; b \<in> R; c \<in> R \<rbrakk> \<Longrightarrow> (b + c) \<cdot> a = b \<cdot> a + c \<cdot> a"
begin

text \<open>p 86, ll 20--28\<close>
notation additive.inverse ("- _" [66] 65)
abbreviation subtraction (infixl "-" 65) where "a - b \<equiv> a + (- b)"  (* or, alternatively, a definition *)

end (* ring *)

text \<open>p 87, ll 10--12\<close>
locale subring =
  additive: subgroup S R "(+)" \<zero> + multiplicative: submonoid S R "(\<cdot>)" \<one>
  for S and R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>")

context ring begin

text \<open>p 88, ll 26--28\<close>
lemma right_zero [simp]:
  assumes [simp]: "a \<in> R" shows "a \<cdot> \<zero> = \<zero>"
proof -
  have "a \<cdot> \<zero> = a \<cdot> (\<zero> + \<zero>)" by simp
  also have "\<dots> = a \<cdot> \<zero> + a \<cdot> \<zero>" by (simp add: distributive del: additive.left_unit additive.right_unit)
  finally have "a \<cdot> \<zero> - a \<cdot> \<zero> = a \<cdot> \<zero> + a \<cdot> \<zero> - a \<cdot> \<zero>" by simp
  then show ?thesis by (simp add: additive.associative del: additive.invertible_left_cancel)
qed

text \<open>p 88, l 29\<close>
lemma left_zero [simp]:
  assumes [simp]: "a \<in> R" shows "\<zero> \<cdot> a = \<zero>"
proof -
  have "\<zero> \<cdot> a = (\<zero> + \<zero>) \<cdot> a" by simp
  also have "\<dots> = \<zero> \<cdot> a + \<zero> \<cdot> a" by (simp add: distributive del: additive.left_unit additive.right_unit)
  finally have "\<zero> \<cdot> a - \<zero> \<cdot> a = \<zero> \<cdot> a + \<zero> \<cdot> a - \<zero> \<cdot> a" by simp
  then show ?thesis by (simp add: additive.associative del: additive.invertible_left_cancel)
qed

text \<open>p 88, ll 29--30; p 89, ll 1--2\<close>
lemma left_minus:
  assumes [simp]: "a \<in> R" "b \<in> R" shows "(- a) \<cdot> b = - a \<cdot> b"
proof -
  have "\<zero> = \<zero> \<cdot> b" by simp
  also have "\<dots> = (a - a) \<cdot> b" by simp
  also have "\<dots> = a \<cdot> b + (- a) \<cdot> b" by (simp add: distributive del: additive.invertible_right_inverse)
  finally have "- a \<cdot> b + \<zero> = - a \<cdot> b + a \<cdot> b + (- a) \<cdot> b" by (simp add: additive.associative del: additive.invertible_left_inverse)
  then show ?thesis by simp
qed

text \<open>p 89, l 3\<close>
lemma right_minus:
  assumes [simp]: "a \<in> R" "b \<in> R" shows "a \<cdot> (- b) = - a \<cdot> b"
proof -
  have "\<zero> = a \<cdot> \<zero>" by simp
  also have "\<dots> = a \<cdot> (b - b)" by simp
  also have "\<dots> = a \<cdot> b + a \<cdot> (- b)" by (simp add: distributive del: additive.invertible_right_inverse)
  finally have "- a \<cdot> b + \<zero> = - a \<cdot> b + a \<cdot> b + a \<cdot> (- b)" by (simp add: additive.associative del: additive.invertible_left_inverse)
  then show ?thesis by simp
qed

end (* ring *)

subsection \<open>Ideals, Quotient Rings\<close>

text \<open>p 101, ll 2--5\<close>
locale ring_congruence = ring +
  additive: group_congruence R "(+)" \<zero> E +
  multiplicative: monoid_congruence R "(\<cdot>)" \<one> E
  for E
begin

text \<open>p 101, ll 2--5\<close>
notation additive.quotient_composition (infixl "[+]" 65)
notation additive.quotient.inverse ("[-] _" [66] 65)
notation multiplicative.quotient_composition (infixl "[\<cdot>]" 70)

text \<open>p 101, ll 5--11\<close>
sublocale quotient: ring "R / E" "([+])" "([\<cdot>])" "additive.Class \<zero>" "additive.Class \<one>"
  by unfold_locales
    (auto simp: additive.Class_commutes_with_composition additive.associative additive.commutative
     multiplicative.Class_commutes_with_composition distributive elim!: additive.quotient_ClassE)

end (* ring_congruence *)

text \<open>p 101, ll 12--13\<close>
locale subgroup_of_additive_group_of_ring =
  additive: subgroup I R "(+)" \<zero> + ring R "(+)" "(\<cdot>)" \<zero> \<one>
  for I and R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>")
begin

text \<open>p 101, ll 13--14\<close>
definition "Ring_Congruence = {(a, b). a \<in> R \<and> b \<in> R \<and> a - b \<in> I}"

text \<open>p 101, ll 13--14\<close>
lemma Ring_CongruenceI: "\<lbrakk> a - b \<in> I; a \<in> R; b \<in> R \<rbrakk> \<Longrightarrow> (a, b) \<in> Ring_Congruence"
  using Ring_Congruence_def by blast

text \<open>p 101, ll 13--14\<close>
lemma Ring_CongruenceD: "(a, b) \<in> Ring_Congruence \<Longrightarrow> a - b \<in> I"
  using Ring_Congruence_def by blast

text \<open>
  Jacobson's definition of ring congruence deviates from that of group congruence; this complicates
  the proof.
\<close>
text \<open>p 101, ll 12--14\<close>
sublocale additive: subgroup_of_abelian_group I R "(+)" \<zero>  (* implies normal_subgroup *)
  rewrites additive_congruence: "additive.Congruence = Ring_Congruence"
proof -
  show "subgroup_of_abelian_group I R (+) \<zero>"
    using additive.commutative additive.invertible_right_inverse2 by unfold_locales auto
  then interpret additive: subgroup_of_abelian_group I R "(+)" \<zero> .
  {
    fix a b
    assume [simp]: "a \<in> R" "b \<in> R"
    have "a - b \<in> I \<longleftrightarrow> - (a - b) \<in> I" by auto
    also have "\<dots> \<longleftrightarrow> - a + b \<in> I" by (simp add: additive.commutative additive.inverse_composition_commute)
    finally have "a - b \<in> I \<longleftrightarrow> - a + b \<in> I" .
  }
  then show "additive.Congruence = Ring_Congruence"
    unfolding additive.Congruence_def Ring_Congruence_def by auto
qed

text \<open>p 101, l 14\<close>
notation additive.Left_Coset (infixl "+|" 65)

end (* subgroup_of_additive_group_of_ring *)

text \<open>Def 2.2\<close>
text \<open>p 101, ll 21--22\<close>
locale ideal = subgroup_of_additive_group_of_ring +
  assumes ideal: "\<lbrakk> a \<in> R; b \<in> I \<rbrakk> \<Longrightarrow> a \<cdot> b \<in> I" "\<lbrakk> a \<in> R; b \<in> I \<rbrakk> \<Longrightarrow> b \<cdot> a \<in> I"

context subgroup_of_additive_group_of_ring begin

text \<open>p 101, ll 14--17\<close>
theorem multiplicative_congruence_implies_ideal:
  assumes "monoid_congruence R (\<cdot>) \<one> Ring_Congruence"
  shows "ideal I R (+) (\<cdot>) \<zero> \<one>"
proof -
  interpret multiplicative: monoid_congruence R "(\<cdot>)" \<one> Ring_Congruence by fact
  show ?thesis
  proof
    fix a b
    assume [simp]: "a \<in> R" "b \<in> I"
    have congs: "(a, a) \<in> Ring_Congruence" "(b, \<zero>) \<in> Ring_Congruence"
      by (auto simp: additive.ClassD additive.Class_unit_normal_subgroup)
    from congs have "(a \<cdot> b, \<zero>) \<in> Ring_Congruence" using multiplicative.cong by fastforce
    then show "a \<cdot> b \<in> I" using additive.Class_unit_normal_subgroup by blast
    from congs have "(b \<cdot> a, \<zero>) \<in> Ring_Congruence" using multiplicative.cong by fastforce
    then show "b \<cdot> a \<in> I"  using additive.Class_unit_normal_subgroup by blast
  qed
qed

end (* subgroup_of_additive_group_of_ring *)

context ideal begin

text \<open>p 101, ll 17--20\<close>
theorem multiplicative_congruence [intro]:
  assumes a: "(a, a') \<in> Ring_Congruence" and b: "(b, b') \<in> Ring_Congruence"
  shows "(a \<cdot> b, a' \<cdot> b') \<in> Ring_Congruence"
proof -
  note Ring_CongruenceI [intro] Ring_CongruenceD [dest]
  from a b have [simp]: "a \<in> R" "a' \<in> R" "b \<in> R" "b' \<in> R" by auto
  from a have [simp]: "a - a' \<in> I" ..
  have "a \<cdot> b - a' \<cdot> b = (a - a') \<cdot> b" by (simp add: distributive left_minus)
  also have "\<dots> \<in> I" by (simp add: ideal)
  finally have ab: "a \<cdot> b - a' \<cdot> b \<in> I" .  \<comment> \<open>ll 18--19\<close>
  from b have [simp]: "b - b' \<in> I" ..
  have "a' \<cdot> b - a' \<cdot> b' = a' \<cdot> (b - b')" by (simp add: distributive right_minus)
  also have "\<dots> \<in> I" by (simp add: ideal)
  finally have a'b': "a' \<cdot> b - a' \<cdot> b' \<in> I" .  \<comment> \<open>l 19\<close>
  have "a \<cdot> b - a' \<cdot> b' = (a \<cdot> b - a' \<cdot> b) + (a' \<cdot> b - a' \<cdot> b')"
    by (simp add: additive.associative) (simp add: additive.associative [symmetric])
  also have "\<dots> \<in> I" using ab a'b' by simp
  finally show "(a \<cdot> b, a' \<cdot> b') \<in> Ring_Congruence" by auto  \<comment> \<open>ll 19--20\<close>
qed

text \<open>p 101, ll 23--24\<close>
sublocale ring_congruence where E = Ring_Congruence by unfold_locales rule

end (* ideal *)

context ring begin

text \<open>Pulled out of @{locale ideal} to achieve standard notation.\<close>
text \<open>p 101, ll 24--26\<close>
abbreviation Quotient_Ring (infixl "'/'/" 75)
  where "S // I \<equiv> S / (subgroup_of_additive_group_of_ring.Ring_Congruence I R (+) \<zero>)"

end (* ring *)

text \<open>p 101, ll 24--26\<close>
locale quotient_ring = ideal begin

text \<open>p 101, ll 24--26\<close>
sublocale quotient: ring "R // I" "([+])" "([\<cdot>])" "additive.Class \<zero>" "additive.Class \<one>" ..

text \<open>p 101, l 26\<close>
lemmas Left_Coset = additive.Left_CosetE

text \<open>Equation 17 (1)\<close>
text \<open>p 101, l 28\<close>
lemmas quotient_addition = additive.factor_composition

text \<open>Equation 17 (2)\<close>
text \<open>p 101, l 29\<close>
theorem quotient_multiplication [simp]:
  "\<lbrakk> a \<in> R; b \<in> R \<rbrakk> \<Longrightarrow> (a +| I) [\<cdot>] (b +| I) = a \<cdot> b +| I"
  using multiplicative.Class_commutes_with_composition additive.Class_is_Left_Coset by auto

text \<open>p 101, l 30\<close>
lemmas quotient_zero = additive.factor_unit
lemmas quotient_negative = additive.factor_inverse

end (* quotient_ring *)

subsection \<open>Homomorphisms of Rings.  Basic Theorems\<close>

text \<open>Def 2.3\<close>
text \<open>p 106, ll 7--9\<close>
locale ring_homomorphism =
  map \<eta> R R' + source: ring R "(+)" "(\<cdot>)" \<zero> \<one> + target: ring R' "(+')" "(\<cdot>')" "\<zero>'" "\<one>'" +
  additive: group_homomorphism \<eta> R "(+)" \<zero> R' "(+')" "\<zero>'" +
  multiplicative: monoid_homomorphism \<eta> R "(\<cdot>)" \<one> R' "(\<cdot>')" "\<one>'"
  for \<eta>
    and R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>")
    and R' and addition' (infixl "+''" 65) and multiplication' (infixl "\<cdot>''" 70) and zero' ("\<zero>''") and unit' ("\<one>''")

text \<open>p 106, l 17\<close>
locale ring_epimorphism = ring_homomorphism + surjective_map \<eta> R R'

text \<open>p 106, ll 14--18\<close>
sublocale quotient_ring \<subseteq> natural: ring_epimorphism
  where \<eta> = additive.Class and R' = "R // I" and addition' = "([+])" and multiplication' =  "([\<cdot>])"
    and zero' = "additive.Class \<zero>" and unit' = "additive.Class \<one>"
  ..

context ring_homomorphism begin

text \<open>
  Jacobson reasons via @{term "a - b \<in> additive.Ker"} being a congruence; we prefer the direct proof,
  since it is very simple.
\<close>
text \<open>p 106, ll 19--21\<close>
sublocale kernel: ideal where I = additive.Ker
  by unfold_locales (auto simp: additive.Ker_image multiplicative.commutes_with_composition)

end (* ring_homomorphism *)

text \<open>p 106, l 22\<close>
locale ring_monomorphism = ring_homomorphism + injective_map \<eta> R R'

context ring_homomorphism begin

text \<open>p 106, ll 21--23\<close>
theorem ring_monomorphism_iff_kernel_unit:
  "ring_monomorphism \<eta> R (+) (\<cdot>) \<zero> \<one> R' (+') (\<cdot>') \<zero>' \<one>' \<longleftrightarrow> additive.Ker = {\<zero>}" (is "?monom \<longleftrightarrow> ?ker")
proof
  assume ?monom then interpret ring_monomorphism . show ?ker by (simp add: additive.injective_iff_kernel_unit [symmetric])
next
  assume ?ker then show ?monom by unfold_locales (simp add: additive.injective_iff_kernel_unit)
qed

end (* ring_homomorphism *)

text \<open>p 106, ll 23--25\<close>
sublocale ring_homomorphism \<subseteq> image: subring "\<eta> ` R" R' "(+')" "(\<cdot>')" "\<zero>'" "\<one>'" ..

text \<open>p 106, ll 26--27\<close>
locale ideal_in_kernel =
  ring_homomorphism + contained: ideal I R "(+)" "(\<cdot>)" \<zero> \<one> for I +
  assumes subset: "I \<subseteq> additive.Ker"
begin

text \<open>p 106, ll 26--27\<close>
notation contained.additive.quotient_composition (infixl "[+]" 65)
notation contained.multiplicative.quotient_composition (infixl "[\<cdot>]" 70)

text \<open>Provides @{text additive.induced}, which Jacobson calls $\bar{\eta}$.\<close>
text \<open>p 106, l 30\<close>
sublocale additive: normal_subgroup_in_kernel \<eta> R "(+)" \<zero> R' "(+')" "\<zero>'" I
  rewrites "normal_subgroup.Congruence I R addition zero = contained.Ring_Congruence"
  by unfold_locales (rule subset contained.additive_congruence)+

text \<open>Only the multiplicative part needs some work.\<close>
text \<open>p 106, ll 27--30\<close>
sublocale induced: ring_homomorphism additive.induced "R // I" "([+])" "([\<cdot>])" "contained.additive.Class \<zero>" "contained.additive.Class \<one>"
  using contained.multiplicative.Class_commutes_with_composition
  by unfold_locales
    (auto elim!: contained.additive.Left_CosetE simp: contained.additive.Class_is_Left_Coset multiplicative.commutes_with_composition multiplicative.commutes_with_unit)

text \<open>p 106, l 30; p 107, ll 1--3\<close>
text \<open>
  @{term additive.induced} denotes Jacobson's $\bar{\eta}$.  We have the commutativity of the diagram, where
  @{term additive.induced} is unique: @{thm [display] additive.factorization} @{thm [display] additive.uniqueness}
\<close>

end (* ideal_in_kernel *)

text \<open>Fundamental Theorem of Homomorphisms of Rings\<close>

text \<open>p 107, l 6\<close>
locale ring_homomorphism_fundamental = ring_homomorphism begin

text \<open>p 107, l 6\<close>
notation kernel.additive.quotient_composition (infixl "[+]" 65)
notation kernel.multiplicative.quotient_composition (infixl "[\<cdot>]" 70)

text \<open>p 107, l 6\<close>
sublocale ideal_in_kernel where I = additive.Ker by unfold_locales rule

text \<open>p 107, ll 8--9\<close>
sublocale natural: ring_epimorphism
  where \<eta> = kernel.additive.Class and R' = "R // additive.Ker"
    and addition' = "kernel.additive.quotient_composition"
    and multiplication' = "kernel.multiplicative.quotient_composition"
    and zero' = "kernel.additive.Class \<zero>" and unit' = "kernel.additive.Class \<one>"
  ..

text \<open>p 107, l 9\<close>
sublocale induced: ring_monomorphism
  where \<eta> = additive.induced and R = "R // additive.Ker"
    and addition = "kernel.additive.quotient_composition"
    and multiplication = "kernel.multiplicative.quotient_composition"
    and zero = "kernel.additive.Class \<zero>" and unit = "kernel.additive.Class \<one>"
  by unfold_locales (simp add: additive.induced_inj_on)

end (* ring_homomorphism_fundamental *)

text \<open>p 107, l 11\<close>
locale ring_isomorphism = ring_homomorphism + bijective_map \<eta> R R' begin

text \<open>p 107, l 11\<close>
sublocale ring_monomorphism ..
sublocale ring_epimorphism ..

text \<open>p 107, l 11\<close>
lemma inverse_ring_isomorphism:
  "ring_isomorphism (restrict (inv_into R \<eta>) R') R' (+') (\<cdot>') \<zero>' \<one>' R (+) (\<cdot>) \<zero> \<one>"
  using additive.commutes_with_composition [symmetric] additive.commutes_with_unit
    multiplicative.commutes_with_composition [symmetric] multiplicative.commutes_with_unit surjective
  by unfold_locales auto

end (* ring_isomorphsim *)

text \<open>p 107, l 11\<close>
definition isomorphic_as_rings (infixl "\<cong>\<^sub>R" 50)
  where "\<R> \<cong>\<^sub>R \<R>' \<longleftrightarrow> (let (R, addition, multiplication, zero, unit) = \<R>; (R', addition', multiplication', zero', unit') = \<R>' in
  (\<exists>\<eta>. ring_isomorphism \<eta> R addition multiplication zero unit R' addition' multiplication' zero' unit'))"

text \<open>p 107, l 11\<close>
lemma isomorphic_as_rings_symmetric:
  "(R, addition, multiplication, zero, unit) \<cong>\<^sub>R (R', addition', multiplication', zero', unit') \<Longrightarrow>
   (R', addition', multiplication', zero', unit') \<cong>\<^sub>R (R, addition, multiplication, zero, unit)"
  by (simp add: isomorphic_as_rings_def) (meson ring_isomorphism.inverse_ring_isomorphism)

context ring_homomorphism begin

text \<open>Corollary\<close>
text \<open>p 107, ll 11--12\<close>
theorem image_is_isomorphic_to_quotient_ring:
  "\<exists>K add mult zero one. ideal K R (+) (\<cdot>) \<zero> \<one> \<and> (\<eta> ` R, (+'), (\<cdot>'), \<zero>', \<one>') \<cong>\<^sub>R (R // K, add, mult, zero, one)"
proof -
  interpret image: ring_homomorphism_fundamental where R' = "\<eta> ` R"
    by unfold_locales (auto simp: target.additive.commutative additive.commutes_with_composition
      multiplicative.commutes_with_composition target.distributive multiplicative.commutes_with_unit)
  have "ring_isomorphism image.additive.induced (R // additive.Ker) ([+]) ([\<cdot>]) (kernel.additive.Class \<zero>) (kernel.additive.Class \<one>) (\<eta> ` R) (+') (\<cdot>') \<zero>' \<one>'"
    by unfold_locales (simp add: image.additive.induced_image bij_betw_def)
  then have "(\<eta> ` R, (+'), (\<cdot>'), \<zero>', \<one>') \<cong>\<^sub>R (R // additive.Ker, ([+]), ([\<cdot>]), kernel.additive.Class \<zero>, kernel.additive.Class \<one>)"
    by (simp add: isomorphic_as_rings_def) (meson ring_isomorphism.inverse_ring_isomorphism)
  moreover have "ideal additive.Ker R (+) (\<cdot>) \<zero> \<one>" ..
  ultimately show ?thesis by blast
qed

end (* ring_homomorphism *)

end


(*  Title:      HOL/UNITY/Comp/Handshake.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Handshake Protocol

From Misra, "Asynchronous Compositions of Programs", Section 5.3.2
*)

theory Handshake imports "../UNITY_Main" begin

record state =
  BB :: bool
  NF :: nat
  NG :: nat

definition
  (*F's program*)
  cmdF :: "(state*state) set"
  where "cmdF = {(s,s'). s' = s (|NF:= Suc(NF s), BB:=False|) & BB s}"

definition
  F :: "state program"
  where "F = mk_total_program ({s. NF s = 0 & BB s}, {cmdF}, UNIV)"

definition
  (*G's program*)
  cmdG :: "(state*state) set"
  where "cmdG = {(s,s'). s' = s (|NG:= Suc(NG s), BB:=True|) & ~ BB s}"

definition
  G :: "state program"
  where "G = mk_total_program ({s. NG s = 0 & BB s}, {cmdG}, UNIV)"

definition
  (*the joint invariant*)
  invFG :: "state set"
  where "invFG = {s. NG s <= NF s & NF s <= Suc (NG s) & (BB s = (NF s = NG s))}"

declare F_def [THEN def_prg_Init, simp]
        G_def [THEN def_prg_Init, simp]

        cmdF_def [THEN def_act_simp, simp]
        cmdG_def [THEN def_act_simp, simp]

        invFG_def [THEN def_set_simp, simp]

lemma invFG: "(F \<squnion> G) \<in> Always invFG"
apply (rule AlwaysI)
apply force
apply (rule constrains_imp_Constrains [THEN StableI])
apply auto
 apply (unfold F_def, safety)
apply (unfold G_def, safety)
done

lemma lemma2_1: "(F \<squnion> G) \<in> ({s. NF s = k} - {s. BB s}) LeadsTo
                              ({s. NF s = k} Int {s. BB s})"
apply (rule stable_Join_ensures1[THEN leadsTo_Basis, THEN leadsTo_imp_LeadsTo])
 apply (unfold F_def, safety)
apply (unfold G_def, ensures_tac "cmdG")
done

lemma lemma2_2: "(F \<squnion> G) \<in> ({s. NF s = k} Int {s. BB s}) LeadsTo
                              {s. k < NF s}"
apply (rule stable_Join_ensures2[THEN leadsTo_Basis, THEN leadsTo_imp_LeadsTo])
 apply (unfold F_def, ensures_tac "cmdF")
apply (unfold G_def, safety)
done

lemma progress: "(F \<squnion> G) \<in> UNIV LeadsTo {s. m < NF s}"
apply (rule LeadsTo_weaken_R)
apply (rule_tac f = "NF" and l = "Suc m" and B = "{}"
       in GreaterThan_bounded_induct)
(*The inductive step is (F \<squnion> G) : {x. NF x = ma} LeadsTo {x. ma < NF x}*)
apply (auto intro!: lemma2_1 lemma2_2
            intro: LeadsTo_Trans LeadsTo_Diff simp add: vimage_def)
done

end