header {* Circus actions *}

theory Circus_Actions
imports "~~/src/HOL/HOLCF/HOLCF" CSP_Processes
begin

text {* In this section, we introduce definitions for Circus actions with
some useful theorems and lemmas. *}

default_sort type

subsection {* Definitions *}

text {* The Circus actions type is defined as the set of all the CSP healthy reactive processes. *}

typedef ('\<theta>::"ev_eq",'\<sigma>)  "action" = "{p::('\<theta>,'\<sigma>) relation_rp. is_CSP_process p}"
    morphisms relation_of action_of
proof -
   have "R (false \<turnstile> true) \<in> {p :: ('\<theta>,'\<sigma>) relation_rp. is_CSP_process p}"
        by (auto intro: rd_is_CSP)
   thus ?thesis by auto
qed

print_theorems

text {* The type-definition introduces a new type by stating a set. In our case,
 it is the set of reactive processes that satisfy the healthiness-conditions
 for CSP-processes, isomorphic to the new type.
 Technically, this construct introduces two constants (morphisms) definitions $relation\_of$
 and $action\_of$ as well as the usual axioms expressing the bijection @{thm relation_of_inverse}
 and @{thm action_of_inverse}.*}

lemma relation_of_CSP: "is_CSP_process (relation_of x)"
proof -
have "(relation_of x) :{p. is_CSP_process p}" by (rule relation_of)
then show "is_CSP_process (relation_of x)" ..
qed

lemma relation_of_CSP1: "(relation_of x) is CSP1 healthy"
by (rule CSP_is_CSP1[OF relation_of_CSP])

lemma relation_of_CSP2: "(relation_of x) is CSP2 healthy"
by (rule CSP_is_CSP2[OF relation_of_CSP])

lemma relation_of_R: "(relation_of x) is R healthy"
by (rule CSP_is_R[OF relation_of_CSP])

subsection {* Proofs *}

text {* In the following, Circus actions are proved to be an instance of the $Complete\_Lattice$ class. *}

lemma relation_of_spec_f_f:
"\<forall>a b. (relation_of y \<longrightarrow> relation_of x) (a, b) \<Longrightarrow>
           (relation_of y)\<^isup>f\<^isub>f (a\<lparr>tr := []\<rparr>, b) \<Longrightarrow>
                      (relation_of x)\<^isup>f\<^isub>f (a\<lparr>tr := []\<rparr>, b)"
by (auto simp: spec_def)

lemma relation_of_spec_t_f:
"\<forall>a b. (relation_of y \<longrightarrow> relation_of x) (a, b) \<Longrightarrow>
           (relation_of y)\<^isup>t\<^isub>f (a\<lparr>tr := []\<rparr>, b) \<Longrightarrow>
                     (relation_of x)\<^isup>t\<^isub>f (a\<lparr>tr := []\<rparr>, b)"
by (auto simp: spec_def)

instantiation "action"::(ev_eq, type) below
begin
definition ref_def : "P \<sqsubseteq> Q \<equiv> [(relation_of Q) \<longrightarrow> (relation_of P)]"
instance ..
end

instance "action" :: (ev_eq, type) po
proof
  fix x y z::"('a, 'b) action"
  {
    show "x \<sqsubseteq> x" by (simp add: ref_def utp_defs)
  next
    assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" then show " x \<sqsubseteq> z"
      by (simp add: ref_def utp_defs)
  next
    assume A:"x \<sqsubseteq> y" and B:"y \<sqsubseteq> x" then show " x = y"
      by (auto simp add: ref_def relation_of_inject[symmetric] fun_eq_iff)
  }
qed

instantiation "action"  ::  (ev_eq, type) lattice
begin

definition inf_action : "(inf P Q \<equiv> action_of ((relation_of P) \<sqinter> (relation_of Q)))"
definition sup_action : "(sup P Q \<equiv> action_of ((relation_of P) \<squnion> (relation_of Q)))"
definition less_eq_action : "(less_eq (P::('a, 'b) action) Q \<equiv> P \<sqsubseteq> Q)"
definition less_action : "(less (P::('a, 'b) action) Q \<equiv> P \<sqsubseteq> Q \<and> \<not> Q \<sqsubseteq> P)"

instance
proof
  fix x y z::"('a, 'b) action"
  {
    show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
      by (simp add: less_action less_eq_action)
  next
    show "(x \<le> x)" by (simp add: less_eq_action)
  next
    assume "x \<le> y" and "y \<le> z"
    then show " x \<le> z"
      by (simp add: less_eq_action ref_def utp_defs)
  next
    assume "x \<le> y" and "y \<le> x"
    then show " x = y"
      by (auto simp add: less_eq_action ref_def relation_of_inject[symmetric] utp_defs)
  next
    show "inf x y \<le> x"
      apply (auto simp add: less_eq_action inf_action ref_def
        csp_defs design_defs rp_defs)
      apply (subst action_of_inverse, simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (simp_all add: CSP_join)
      apply (simp add: utp_defs)
      done
  next
    show "inf x y \<le> y"
      apply (auto simp add: less_eq_action inf_action ref_def csp_defs)
      apply (subst action_of_inverse, simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (simp_all add: CSP_join)
      apply (simp add: utp_defs)
      done
  next
    assume "x \<le> y" and "x \<le> z"
    then show "x \<le> inf y z"
      apply (auto simp add: less_eq_action inf_action ref_def impl_def csp_defs)
      apply (erule_tac x="a" in allE, erule_tac x="a" in allE)
      apply (erule_tac x="b" in allE)+
      apply (subst (asm) action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="z"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_join)
      done
  next
    show "x \<le> sup x y"
      apply (auto simp add: less_eq_action sup_action ref_def
         impl_def csp_defs)
      apply (subst (asm) action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_meet)
      done
  next
    show "y \<le> sup x y"
      apply (auto simp add: less_eq_action sup_action ref_def
         impl_def csp_defs)
      apply (subst (asm) action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_meet)
      done
  next
    assume "y \<le> x" and "z \<le> x"
    then show "sup y z \<le> x"
      apply (auto simp add: less_eq_action sup_action ref_def  impl_def csp_defs)
      apply (erule_tac x="a" in allE)
      apply (erule_tac x="a" in allE)
      apply (erule_tac x="b" in allE)+
      apply (subst action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="z"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_meet)
      done
  }
qed

end

lemma bot_is_action: "R (false \<turnstile> true) \<in> {p. is_CSP_process p}"
  by (auto intro: rd_is_CSP)

lemma bot_eq_true: "R (false \<turnstile> true) = R true"
  by (auto simp: fun_eq_iff design_defs rp_defs split: cond_splits)

instantiation "action"  ::  (ev_eq, type) bounded_lattice
begin

definition bot_action : "(bot::('a, 'b) action) \<equiv> action_of (R(false \<turnstile> true))"
definition top_action : "(top::('a, 'b) action) \<equiv> action_of (R(true \<turnstile> false))"

instance
proof
  fix x::"('a, 'b) action"
  {
    show "bot \<le> x"
      unfolding bot_action
      apply (auto simp add: less_action less_eq_action ref_def bot_action)
      apply (subst action_of_inverse) apply (rule bot_is_action)
      apply (subst bot_eq_true)
      apply (subst (asm) CSP_is_rd)
      apply (rule relation_of_CSP)
      apply (auto simp add: csp_defs rp_defs fun_eq_iff split: cond_splits)
      done
  next
    show "x \<le> top"
      apply (auto simp add: less_action less_eq_action ref_def top_action)
      apply (subst (asm) action_of_inverse)
      apply (simp)
      apply (rule rd_is_CSP)
      apply auto
      apply (subst action_of_cases[where x=x], simp_all)
      apply (subst action_of_inverse, simp_all)
      apply (subst CSP_is_rd[where P=y], simp_all)
      apply (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits)
      done
  }
qed

end

lemma relation_of_top: "relation_of top = R(true \<turnstile> false)"
  apply (simp add: top_action)
  apply (subst action_of_inverse)
  apply (simp)
  apply (rule rd_is_CSP)
  apply (auto simp add: utp_defs design_defs rp_defs)
  done

lemma relation_of_bot: "relation_of bot = R true"
  apply (simp add: bot_action)
  apply (subst action_of_inverse)
  apply (simp add: bot_is_action[simplified], rule bot_eq_true)
  done

lemma non_emptyE: assumes "A \<noteq> {}" obtains x where "x : A"
  using assms by (auto simp add: ex_in_conv [symmetric])

lemma CSP1_Inf:
assumes *:"A \<noteq> {}"
shows "(\<Sqinter> relation_of ` A) is CSP1 healthy"
proof -
  have "(\<Sqinter> relation_of ` A) = CSP1 (\<Sqinter> relation_of ` A)"
  proof
    fix P
    note * then
    show "(P \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) = CSP1 (\<lambda>Aa. Aa \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) P"
    apply (intro iffI)
    apply (simp_all add: csp_defs)
    apply (rule disj_introC, simp)
    apply (erule disj_elim, simp_all)
    apply (cases P, simp_all)
    apply (erule non_emptyE)
    apply (rule_tac x="Collect (relation_of x)" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="(relation_of x)" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (auto simp add: csp_defs prefixeq_def design_defs rp_defs fun_eq_iff split: cond_splits)
    done
  qed
  then show "(\<Sqinter> relation_of ` A) is CSP1 healthy" by (simp add: design_defs)
qed

lemma CSP2_Inf:
assumes *:"A \<noteq> {}"
shows "(\<Sqinter> relation_of ` A) is CSP2 healthy"
proof -
  have "(\<Sqinter> relation_of ` A) = CSP2 (\<Sqinter> relation_of ` A)"
  proof
    fix P
    note * then
    show "(P \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) = CSP2 (\<lambda>Aa. Aa \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) P"
    apply (intro iffI)
    apply (simp_all add: csp_defs)
    apply (cases P, simp_all)
    apply (erule exE)
    apply (rule_tac b=b in comp_intro, simp_all)
    apply (rule_tac x=x in exI, simp)
    apply (erule comp_elim, simp_all)
    apply (erule exE | erule conjE)+
    apply (simp_all)
    apply (rule_tac x="Collect Pa" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="Pa" in exI, simp)
    apply (erule Set.imageE, simp add: relation_of)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
    apply (auto simp add: csp_defs rp_defs prefixeq_def design_defs fun_eq_iff split: cond_splits)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := True\<rparr> = c\<lparr>tr := zs, ok := True\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := True\<rparr> = c\<lparr>tr := zs, ok := True\<rparr>", auto)
    done
  qed
  then show "(\<Sqinter> relation_of ` A) is CSP2 healthy" by (simp add: design_defs)
qed

lemma R_Inf:
assumes *:"A \<noteq> {}"
shows "(\<Sqinter> relation_of ` A) is R healthy"
proof -
  have "(\<Sqinter> relation_of ` A) = R (\<Sqinter> relation_of ` A)"
  proof
    fix P
    show "(P \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) = R (\<lambda>Aa. Aa \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) P"
    apply (cases P, simp_all)
    apply (rule)
    apply (simp_all add: csp_defs rp_defs split: cond_splits)
    apply (erule exE)
    apply (erule exE | erule conjE)+
    apply (simp_all)
    apply (erule Set.imageE, simp add: relation_of)
    apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefixeq_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (rule_tac x="x" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="relation_of xa" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefixeq_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (insert *)
    apply (erule non_emptyE)
    apply (rule_tac x="Collect (relation_of x)" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="(relation_of x)" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefixeq_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (erule exE | erule conjE)+
    apply (simp_all)
    apply (erule Set.imageE, simp add: relation_of)
    apply (rule_tac x="x" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="(relation_of xa)" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefixeq_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefixeq_def design_defs rp_defs fun_eq_iff split: cond_splits)
    done
  qed
  then show "(\<Sqinter> relation_of ` A) is R healthy" by (simp add: design_defs)
qed

lemma CSP_Inf:
  assumes "A \<noteq> {}"
  shows "is_CSP_process (\<Sqinter> relation_of ` A)"
  unfolding is_CSP_process_def
  using assms CSP1_Inf CSP2_Inf R_Inf
  by auto

lemma Inf_is_action: "A \<noteq> {} \<Longrightarrow> \<Sqinter> relation_of ` A \<in> {p. is_CSP_process p}"
  by (auto dest!: CSP_Inf)

lemma CSP1_Sup: "A \<noteq> {} \<Longrightarrow> (\<Squnion> relation_of ` A) is CSP1 healthy"
  apply (auto simp add: design_defs csp_defs fun_eq_iff)
  apply (subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs prefixeq_def design_defs rp_defs split: cond_splits)
done

lemma CSP2_Sup: "A \<noteq> {} \<Longrightarrow> (\<Squnion> relation_of ` A) is CSP2 healthy"
  apply (simp add: design_defs csp_defs fun_eq_iff)
  apply (rule allI)+
  apply (rule)
  apply (rule_tac b=b in comp_intro, simp_all)
  apply (erule comp_elim, simp_all)
  apply (rule allI)
  apply (erule_tac x=x in allE)
  apply (rule impI)
  apply (case_tac "(\<exists>P. x = Collect P & P \<in> relation_of ` A)", simp_all)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (auto simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := True\<rparr> = c\<lparr>tr := tr c - tr aa, ok := True\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := True\<rparr> = c\<lparr>tr := tr c - tr aa, ok := True\<rparr>", simp_all)
done

lemma R_Sup: "A \<noteq> {} \<Longrightarrow> (\<Squnion> relation_of ` A) is R healthy"
  apply (simp add: rp_defs design_defs csp_defs fun_eq_iff)
  apply (rule allI)+
  apply (rule)
  apply (simp split: cond_splits)
  apply (case_tac "wait a", simp_all)
  apply (erule non_emptyE)
  apply (erule_tac x="Collect (relation_of x)" in allE, simp_all)
  apply (case_tac "relation_of x (a, b)", simp_all)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule_tac x="(relation_of x)" in allE, simp_all)
  apply (rule conjI)
  apply (rule allI)
  apply (erule_tac x=x in allE)
  apply (rule impI)
  apply (case_tac "(\<exists>P. x = Collect P & P \<in> relation_of ` A)", simp_all)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule non_emptyE)
  apply (erule_tac x="Collect (relation_of x)" in allE, simp_all)
  apply (case_tac "relation_of x (a, b)", simp_all)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule_tac x="(relation_of x)" in allE, simp_all)
  apply (simp split: cond_splits)
  apply (rule allI)
  apply (rule impI)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (rule allI)
  apply (rule impI)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (erule_tac x="x" in allE, simp_all)
  apply (case_tac "relation_of xa (a\<lparr>tr := []\<rparr>, b\<lparr>tr := tr b - tr a\<rparr>)", simp_all)
  apply (subst (asm) CSP_is_rd) back back back
  apply (simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule_tac x="P" in allE, simp_all)
done

lemma CSP_Sup: "A \<noteq> {} \<Longrightarrow> is_CSP_process (\<Squnion> relation_of ` A)"
  unfolding is_CSP_process_def using CSP1_Sup CSP2_Sup R_Sup by auto

lemma Sup_is_action: "A \<noteq> {} \<Longrightarrow> \<Squnion> relation_of ` A \<in> {p. is_CSP_process p}"
  by (auto dest!: CSP_Sup)

lemma relation_of_Sup:
  "A \<noteq> {} \<Longrightarrow> relation_of (action_of \<Squnion> relation_of ` A) = \<Squnion> relation_of ` A"
  by (auto simp: action_of_inverse dest!: Sup_is_action)

instantiation "action"  ::  (ev_eq, type) complete_lattice
begin

definition Sup_action :
"(Sup (S:: ('a, 'b) action set) \<equiv> if S={} then bot else action_of \<Squnion> (relation_of ` S))"
definition Inf_action :
"(Inf (S:: ('a, 'b) action set) \<equiv> if S={} then top else action_of \<Sqinter> (relation_of ` S))"

instance
proof
  fix A::"('a, 'b) action set" and z::"('a, 'b) action"
  {
    fix x::"('a, 'b) action"
    assume "x \<in> A"
    then show "Inf A \<le> x"
      apply (auto simp add: less_action less_eq_action Inf_action ref_def)
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Inf_is_action[simplified])
      done
  } note rule1 = this
  {
    assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
    show "z \<le> Inf A"
    proof (cases "A = {}")
      case True
      then show ?thesis by (simp add: Inf_action)
    next
      case False
      show ?thesis
        using *
        apply (auto simp add: Inf_action)
        using `A \<noteq> {}`
        apply (simp add: less_eq_action Inf_action ref_def)
        apply (subst (asm) action_of_inverse)
        apply (subst (asm) ex_in_conv[symmetric])
        apply (erule exE)
        apply (auto intro: Inf_is_action[simplified])
        done
    qed
  }{
    fix x::"('a, 'b) action"
    assume "x \<in> A"
    then show "x \<le> (Sup A)"
      apply (auto simp add: less_action less_eq_action Sup_action ref_def)
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Sup_is_action[simplified])
      done
  } note rule2 = this
  {
    assume "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
    then show "Sup A \<le> z"
      apply (auto simp add: Sup_action)
      apply atomize
      apply (case_tac "A = {}", simp_all)
      apply (insert rule2)
      apply (auto simp add: less_action less_eq_action Sup_action ref_def)
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Sup_is_action[simplified])
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Sup_is_action[simplified])
      done
  }
  { show "Inf ({}::('a, 'b) action set) = top" by(simp add:Inf_action) }
  { show "Sup ({}::('a, 'b) action set) = bot" by(simp add:Sup_action) }
qed

end

end


(*<*)
theory Code_Double
  imports IEEE_Floating_Point.IEEE_Properties
    "HOL-Library.Code_Target_Int"
    Containers.Collection_Eq
    Containers.Collection_Order
begin
(*>*)

section \<open>Code adaptation for IEEE double-precision floats\<close>

subsection \<open>copysign\<close>

lift_definition copysign :: "('e, 'f) float \<Rightarrow> ('e, 'f) float \<Rightarrow> ('e, 'f) float" is
  "\<lambda>(_, e::'e word, f::'f word) (s::1 word, _, _). (s, e, f)" .

subsection \<open>Additional lemmas about generic floats\<close>

lemma is_nan_some_nan[simp]: "is_nan (some_nan :: ('e, 'f) float)"
  unfolding some_nan_def
  by (rule someI[where x="Abs_float (0, - 1 :: 'e word, 1)"])
    (auto simp add: is_nan_def exponent_def fraction_def emax_def Abs_float_inverse[simplified])

lemma not_is_nan_0[simp]: "\<not> is_nan 0"
  unfolding is_nan_def by (simp add: zero_simps)

lemma not_is_nan_1[simp]: "\<not> is_nan 1"
  unfolding is_nan_def by transfer simp

lemma is_nan_plus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x + y)"
  unfolding plus_float_def fadd_def by auto

lemma is_nan_minus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x - y)"
  unfolding minus_float_def fsub_def by auto

lemma is_nan_times: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x * y)"
  unfolding times_float_def fmul_def by auto

lemma is_nan_divide: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x / y)"
  unfolding divide_float_def fdiv_def by auto

lemma is_nan_float_sqrt: "is_nan x \<Longrightarrow> is_nan (float_sqrt x)"
  unfolding float_sqrt_def fsqrt_def by simp

lemma nan_fcompare: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare x y = Und"
  unfolding fcompare_def by simp

lemma nan_not_less: "is_nan x \<or> is_nan y \<Longrightarrow> \<not> x < y"
  unfolding less_float_def flt_def fcompare_def by simp

lemma nan_not_zero: "is_nan x \<Longrightarrow> \<not> is_zero x"
  unfolding is_nan_def is_zero_def by simp

lemma nan_not_infinity: "is_nan x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_nan_def is_infinity_def by simp

lemma zero_not_infinity: "is_zero x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_zero_def is_infinity_def by simp

lemma zero_not_nan: "is_zero x \<Longrightarrow> \<not> is_nan x"
  unfolding is_zero_def is_nan_def by simp

lemma minus_one_power_one_word: "(-1 :: real) ^ unat (x :: 1 word) = (if unat x = 0 then 1 else -1)"
proof -
  have "unat x = 0 \<or> unat x = 1"
    using le_SucE[OF unat_one_word_le] by auto
  then show ?thesis by auto
qed

definition valofn :: "('e, 'f) float \<Rightarrow> real" where
  "valofn x = (2^exponent x / 2^bias TYPE(('e, 'f) float)) *
      (1 + real (fraction x) / 2^LENGTH('f))"

definition valofd :: "('e, 'f) float \<Rightarrow> real" where
  "valofd x = (2 / 2^bias TYPE(('e, 'f) float)) * (real (fraction x) / 2^LENGTH('f))"

lemma valof_alt: "valof x = (if exponent x = 0 then
    if sign x = 0 then valofd x else - valofd x
  else if sign x = 0 then valofn x else - valofn x)"
  unfolding valofn_def valofd_def
  by transfer (auto simp: minus_one_power_one_word unat_eq_0 field_simps)

lemma fraction_less_2p: "fraction (x :: ('e, 'f) float) < 2^LENGTH('f)"
  by transfer auto

lemma valofn_ge_0: "0 \<le> valofn x"
  unfolding valofn_def by simp

lemma valofn_ge_2p: "2^exponent (x :: ('e, 'f) float) / 2^bias TYPE(('e, 'f) float) \<le> valofn x"
  unfolding valofn_def by (simp add: field_simps)

lemma valofn_less_2p:
  fixes x :: "('e, 'f) float"
  assumes "exponent x < e"
  shows "valofn x < 2^e / 2^bias TYPE(('e, 'f) float)"
proof -
  have "1 + real (fraction x) / 2^LENGTH('f) < 2"
    by (simp add: fraction_less_2p)
  then have "valofn x < (2^exponent x / 2^bias TYPE(('e, 'f) float)) * 2"
    unfolding valofn_def by (simp add: field_simps)
  also have "... \<le> 2^e / 2^bias TYPE(('e, 'f) float)"
    using assms by (auto simp: less_eq_Suc_le field_simps elim: order_trans[rotated, OF exp_less])
  finally show ?thesis .
qed

lemma valofd_ge_0: "0 \<le> valofd x"
  unfolding valofd_def by simp

lemma valofd_less_2p: "valofd (x :: ('e, 'f) float) < 2 / 2^bias TYPE(('e, 'f) float)"
  unfolding valofd_def
  by (simp add: fraction_less_2p field_simps)

lemma valofn_le_imp_exponent_le:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x \<le> valofn y"
  shows "exponent x \<le> exponent y"
proof (rule ccontr)
  assume "\<not> exponent x \<le> exponent y"
  then have "valofn y < 2^exponent x / 2^bias TYPE(('e, 'f) float)"
    using valofn_less_2p[of y] by auto
  also have "... \<le> valofn x" by (rule valofn_ge_2p)
  finally show False using assms by simp
qed

lemma valofn_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x = valofn y"
  shows "exponent x = exponent y" "fraction x = fraction y"
proof -
  from assms show "exponent x = exponent y"
    by (auto intro!: antisym valofn_le_imp_exponent_le)
  with assms show "fraction x = fraction y"
    unfolding valofn_def by (simp add: field_simps)
qed

lemma valofd_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofd x = valofd y"
  shows "fraction x = fraction y"
  using assms unfolding valofd_def by (simp add: field_simps)

lemma is_zero_valof_conv: "is_zero x \<longleftrightarrow> valof x = 0"
  unfolding is_zero_def valof_alt
  using valofn_ge_2p[of x] by (auto simp: valofd_def field_simps dest: order.antisym)

lemma valofd_neq_valofn:
  fixes x y :: "('e, 'f) float"
  assumes "exponent y \<noteq> 0"
  shows "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x"
proof -
  have "valofd x < 2 / 2^bias TYPE(('e, 'f) float)" by (rule valofd_less_2p)
  also have "... \<le> 2 ^ IEEE.exponent y / 2 ^ bias TYPE(('e, 'f) IEEE.float)"
    using assms by (simp add: self_le_power field_simps)
  also have "... \<le> valofn y" by (rule valofn_ge_2p)
  finally show "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x" by simp_all
qed

lemma sign_gt_0_conv: "0 < sign x \<longleftrightarrow> sign x = 1"
  by (cases x rule: sign_cases) simp_all

lemma valof_eq:
  assumes "\<not> is_zero x \<or> \<not> is_zero y"
  shows "valof x = valof y \<longleftrightarrow> x = y"
proof
  assume *: "valof x = valof y"
  with assms have "valof y \<noteq> 0" by (simp add: is_zero_valof_conv)
  with * show "x = y"
    unfolding valof_alt
    using valofd_ge_0[of x] valofd_ge_0[of y] valofn_ge_0[of x] valofn_ge_0[of y]
    by (auto simp: valofd_neq_valofn sign_gt_0_conv split: if_splits
        intro!: float_eqI elim: valofn_eq valofd_eq)
qed simp

lemma zero_fcompare: "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> fcompare x y = ccode.Eq"
  unfolding fcompare_def by (simp add: zero_not_infinity zero_not_nan is_zero_valof_conv)

subsection \<open>Doubles with a unified NaN value\<close>

quotient_type double = "(11, 52) float" / "\<lambda>x y. is_nan x \<and> is_nan y \<or> x = y"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation double :: "{zero, one, plus, minus, uminus, times, ord}"
begin

lift_definition zero_double :: "double" is "0" .
lift_definition one_double :: "double" is "1" .

lift_definition plus_double :: "double \<Rightarrow> double \<Rightarrow> double" is plus
  by (auto simp: is_nan_plus)

lift_definition minus_double :: "double \<Rightarrow> double \<Rightarrow> double" is minus
  by (auto simp: is_nan_minus)

lift_definition uminus_double :: "double \<Rightarrow> double" is uminus
  by auto

lift_definition times_double :: "double \<Rightarrow> double \<Rightarrow> double" is times
  by (auto simp: is_nan_times)

lift_definition less_eq_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(\<le>)"
  by (auto simp: nan_not_le)

lift_definition less_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(<)"
  by (auto simp: nan_not_less)

instance ..

end

instantiation double :: inverse
begin

lift_definition divide_double :: "double \<Rightarrow> double \<Rightarrow> double" is divide
  by (auto simp: is_nan_divide)

definition inverse_double :: "double \<Rightarrow> double" where
  "inverse_double x = 1 div x"

instance ..

end

lift_definition sqrt_double :: "double \<Rightarrow> double" is float_sqrt
  by (auto simp: is_nan_float_sqrt)

no_notation plus_infinity ("\<infinity>")

lift_definition infinity :: "double" is plus_infinity .

lift_definition nan :: "double" is some_nan .

lift_definition is_zero :: "double \<Rightarrow> bool" is IEEE.is_zero
  by (auto simp: nan_not_zero)

lift_definition is_infinite :: "double \<Rightarrow> bool" is IEEE.is_infinity
  by (auto simp: nan_not_infinity)

lift_definition is_nan :: "double \<Rightarrow> bool" is IEEE.is_nan
  by auto

lemma is_nan_conv: "is_nan x \<longleftrightarrow> x = nan"
  by transfer auto

lift_definition copysign_double :: "double \<Rightarrow> double \<Rightarrow> double" is
  "\<lambda>x y. if IEEE.is_nan y then some_nan else copysign x y"
  by auto

text \<open>Note: @{const copysign_double} deviates from the IEEE standard in cases where
  the second argument is a NaN.\<close>

lift_definition fcompare_double :: "double \<Rightarrow> double \<Rightarrow> ccode" is fcompare
  by (auto simp: nan_fcompare)

lemma nan_fcompare_double: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare_double x y = Und"
  by transfer (rule nan_fcompare)

consts compare_double :: "double \<Rightarrow> double \<Rightarrow> integer"

specification (compare_double)
  compare_double_less: "compare_double x y < 0 \<longleftrightarrow> is_nan x \<and> \<not> is_nan y \<or> fcompare_double x y = ccode.Lt"
  compare_double_eq: "compare_double x y = 0 \<longleftrightarrow> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Eq"
  compare_double_greater: "compare_double x y > 0 \<longleftrightarrow> \<not> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Gt"
  by (rule exI[where x="\<lambda>x y. if is_nan x then if is_nan y then 0 else -1
    else if is_nan y then 1 else (case fcompare_double x y of ccode.Eq \<Rightarrow> 0 | ccode.Lt \<Rightarrow> -1 | ccode.Gt \<Rightarrow> 1)"],
        transfer, auto simp: fcompare_def)

lemmas compare_double_simps = compare_double_less compare_double_eq compare_double_greater

lemma compare_double_le_0: "compare_double x y \<le> 0 \<longleftrightarrow>
  is_nan x \<or> fcompare_double x y \<in> {ccode.Eq, ccode.Lt}"
  by (rule linorder_cases[of "compare_double x y" 0]; simp)
    (auto simp: compare_double_simps nan_fcompare_double)

lift_definition double_of_integer :: "integer \<Rightarrow> double" is
  "\<lambda>x. zerosign 0 (intround To_nearest (int_of_integer x))" .

definition double_of_int where [code del]: "double_of_int x = double_of_integer (integer_of_int x)"

lift_definition integer_of_double :: "double \<Rightarrow> integer" is
  "\<lambda>x. if IEEE.is_nan x \<or> IEEE.is_infinity x then undefined
     else integer_of_int \<lfloor>valof (intround float_To_zero (valof x) :: (11, 52) float)\<rfloor>"
  by auto

definition int_of_double: "int_of_double x = int_of_integer (integer_of_double x)"

subsection \<open>Linear ordering\<close>

definition lcompare_double :: "double \<Rightarrow> double \<Rightarrow> integer" where
  "lcompare_double x y = (if is_zero x \<and> is_zero y then
      compare_double (copysign_double 1 x) (copysign_double 1 y)
    else compare_double x y)"

lemma fcompare_double_swap: "fcompare_double x y = ccode.Gt \<longleftrightarrow> fcompare_double y x = ccode.Lt"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_refl: "\<not> is_nan x \<Longrightarrow> fcompare_double x x = ccode.Eq"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_Eq1: "fcompare_double x y = ccode.Eq \<Longrightarrow> fcompare_double y z = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Eq2: "fcompare_double y z = ccode.Eq \<Longrightarrow> fcompare_double x y = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Lt_trans: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y z = ccode.Lt \<Longrightarrow> fcompare_double x z = ccode.Lt"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_eq: "\<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> fcompare_double x y = ccode.Eq \<Longrightarrow> x = y"
  by transfer (auto simp: fcompare_def valof_eq IEEE.is_infinity_def split: if_splits intro!: float_eqI)

lemma fcompare_double_Lt_asym: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y x = ccode.Lt \<Longrightarrow> False"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma compare_double_swap: "0 < compare_double x y \<longleftrightarrow> compare_double y x < 0"
  by (auto simp: compare_double_simps fcompare_double_swap)

lemma compare_double_refl: "compare_double x x = 0"
  by (auto simp: compare_double_eq intro!: fcompare_double_refl)

lemma compare_double_trans: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y z \<le> 0 \<Longrightarrow> compare_double x z \<le> 0"
  by (fastforce simp: compare_double_le_0 nan_fcompare_double
      dest: fcompare_double_Eq1 fcompare_double_Eq2 fcompare_double_Lt_trans)

lemma compare_double_antisym: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y x \<le> 0 \<Longrightarrow>
  \<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> x = y"
  unfolding compare_double_le_0
  by (auto simp: nan_fcompare_double is_nan_conv
      intro: fcompare_double_eq fcompare_double_eq[symmetric]
      dest: fcompare_double_Lt_asym)

lemma zero_compare_double_copysign: "compare_double (copysign_double 1 x) (copysign_double 1 y) \<le> 0 \<Longrightarrow>
  is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> compare_double x y \<le> 0"
  unfolding compare_double_le_0
  by transfer (auto simp: nan_not_zero zero_fcompare split: if_splits)

lemma is_zero_double_cases: "is_zero x \<Longrightarrow> (x = 0 \<Longrightarrow> P) \<Longrightarrow> (x = -0 \<Longrightarrow> P) \<Longrightarrow> P"
  by transfer (auto elim!: is_zero_cases)

lemma copysign_1_0[simp]: "copysign_double 1 0 = 1" "copysign_double 1 (-0) = -1"
  by (transfer, simp, transfer, auto)+

lemma is_zero_uminus_double[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
  by transfer simp

lemma not_is_zero_one_double[simp]: "\<not> is_zero 1"
  by (transfer, unfold IEEE.is_zero_def, transfer, simp)

lemma uminus_one_neq_one_double[simp]: "- 1 \<noteq> (1 :: double)"
  by (transfer, transfer, simp)

definition lle_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lle_double x y \<longleftrightarrow> lcompare_double x y \<le> 0"

definition lless_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lless_double x y \<longleftrightarrow> lcompare_double x y < 0"

lemma lcompare_double_ge_0: "lcompare_double x y \<ge> 0 \<longleftrightarrow> lle_double y x"
  unfolding lle_double_def lcompare_double_def
  using compare_double_swap not_less by auto

lemma lcompare_double_gt_0: "lcompare_double x y > 0 \<longleftrightarrow> lless_double y x"
  unfolding lless_double_def lcompare_double_def
  using compare_double_swap by auto

lemma lcompare_double_eq_0: "lcompare_double x y = 0 \<longleftrightarrow> x = y"
proof
  assume *: "lcompare_double x y = 0"
  show "x = y" proof (cases "is_zero x \<and> is_zero y")
    case True
    with * show ?thesis
      by (fastforce simp: lcompare_double_def compare_double_simps is_nan_conv
          elim: is_zero_double_cases dest!: fcompare_double_eq[rotated])
  next
    case False
    with * show ?thesis
      by (auto simp: lcompare_double_def linorder_not_less[symmetric] compare_double_swap
          intro!: compare_double_antisym)
  qed
next
  assume "x = y"
  then show "lcompare_double x y = 0"
    by (simp add: lcompare_double_def compare_double_refl)
qed

lemmas lcompare_double_0_folds = lle_double_def[symmetric] lless_double_def[symmetric]
  lcompare_double_ge_0 lcompare_double_gt_0 lcompare_double_eq_0

interpretation double_linorder: linorder lle_double lless_double
proof
  fix x y z :: double
  show "lless_double x y \<longleftrightarrow> lle_double x y \<and> \<not> lle_double y x"
    unfolding lless_double_def lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
  show "lle_double x x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_refl)
  show "lle_double x z" if "lle_double x y" and "lle_double y z"
    using that
    by (auto 0 3 simp: lle_double_def lcompare_double_def not_le compare_double_swap
        split: if_splits dest: compare_double_trans zero_compare_double_copysign
        zero_compare_double_copysign[OF less_imp_le] compare_double_antisym)
  show "x = y" if "lle_double x y" and "lle_double y x"
  proof (cases "is_zero x \<and> is_zero y")
    case True
    with that show ?thesis
      by (auto 0 3 simp: lle_double_def lcompare_double_def elim: is_zero_double_cases
          dest!: compare_double_antisym)
  next
    case False
    with that show ?thesis
      by (auto simp: lle_double_def lcompare_double_def elim!: compare_double_antisym)
  qed
  show "lle_double x y \<or> lle_double y x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
qed

instantiation double :: equal
begin

definition equal_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "equal_double x y \<longleftrightarrow> lcompare_double x y = 0"

instance by intro_classes (simp add: equal_double_def lcompare_double_eq_0)

end

derive (eq) ceq double

definition comparator_double :: "double comparator" where
  "comparator_double x y = (let c = lcompare_double x y in
    if c = 0 then order.Eq else if c < 0 then order.Lt else order.Gt)"

lemma comparator_double: "comparator comparator_double"
  unfolding comparator_double_def
  by (auto simp: lcompare_double_0_folds split: if_splits intro!: comparator.intro)

local_setup \<open>
  Comparator_Generator.register_foreign_comparator @{typ double}
    @{term comparator_double}
    @{thm comparator_double}
\<close>

derive ccompare double

subsubsection \<open>Code setup\<close>

declare [[code drop:
      "0 :: double"
      "1 :: double"
      "plus :: double \<Rightarrow> _"
      "minus :: double \<Rightarrow> _"
      "uminus :: double \<Rightarrow> _"
      "times :: double \<Rightarrow> _"
      "less_eq :: double \<Rightarrow> _"
      "less :: double \<Rightarrow> _"
      "divide :: double \<Rightarrow> _"
      sqrt_double infinity nan is_zero is_infinite is_nan copysign_double fcompare_double
      double_of_integer integer_of_double
      ]]

code_printing
  code_module FloatUtil \<rightharpoonup> (OCaml)
\<open>module FloatUtil : sig
  val iszero : float -> bool
  val isinfinite : float -> bool
  val isnan : float -> bool
  val copysign : float -> float -> float
  val compare : float -> float -> Z.t
end = struct
  let iszero x = (Pervasives.classify_float x = Pervasives.FP_zero);;
  let isinfinite x = (Pervasives.classify_float x = Pervasives.FP_infinite);;
  let isnan x = (Pervasives.classify_float x = Pervasives.FP_nan);;
  let copysign x y = if isnan y then Pervasives.nan else Pervasives.copysign x y;;
  let compare x y = Z.of_int (Pervasives.compare x y);;
end;;\<close>

code_reserved OCaml Pervasives FloatUtil

code_printing
  type_constructor double \<rightharpoonup> (OCaml) "float"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Pervasives.(~-.)"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Pervasives.(+.)"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Pervasives.( *. )"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Pervasives.('/.)"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Pervasives.(-.)"
  | constant "0 :: double" \<rightharpoonup> (OCaml) "0.0"
  | constant "1 :: double" \<rightharpoonup> (OCaml) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Pervasives.(<=)"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Pervasives.(<)"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Pervasives.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (OCaml) "Pervasives.infinity"
  | constant "nan :: double" \<rightharpoonup> (OCaml) "Pervasives.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isnan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "FloatUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "FloatUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (OCaml) "Z.to'_float"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "Z.of'_float"

hide_const (open) fcompare_double

(*<*)
end
(*>*)


(*  Title:      HOL/Examples/Coherent.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Marc Bezem, Institutt for Informatikk, Universitetet i Bergen
*)

section \<open>Coherent Logic Problems\<close>

theory Coherent
imports MainRLT
begin

subsection \<open>Equivalence of two versions of Pappus' Axiom\<close>

no_notation
  comp (infixl "o" 55) and
  relcomp (infixr "O" 75)

lemma p1p2:
  assumes "col a b c l \<and> col d e f m"
    and "col b f g n \<and> col c e g o"
    and "col b d h p \<and> col a e h q"
    and "col c d i r \<and> col a f i s"
    and "el n o \<Longrightarrow> goal"
    and "el p q \<Longrightarrow> goal"
    and "el s r \<Longrightarrow> goal"
    and "\<And>A. el A A \<Longrightarrow> pl g A \<Longrightarrow> pl h A \<Longrightarrow> pl i A \<Longrightarrow> goal"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl A D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl B D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl C D"
    and "\<And>A B. pl A B \<Longrightarrow> ep A A"
    and "\<And>A B. ep A B \<Longrightarrow> ep B A"
    and "\<And>A B C. ep A B \<Longrightarrow> ep B C \<Longrightarrow> ep A C"
    and "\<And>A B. pl A B \<Longrightarrow> el B B"
    and "\<And>A B. el A B \<Longrightarrow> el B A"
    and "\<And>A B C. el A B \<Longrightarrow> el B C \<Longrightarrow> el A C"
    and "\<And>A B C. ep A B \<Longrightarrow> pl B C \<Longrightarrow> pl A C"
    and "\<And>A B C. pl A B \<Longrightarrow> el B C \<Longrightarrow> pl A C"
    and "\<And>A B C D E F G H I J K L M N O P Q.
           col A B C D \<Longrightarrow> col E F G H \<Longrightarrow> col B G I J \<Longrightarrow> col C F I K \<Longrightarrow>
           col B E L M \<Longrightarrow> col A F L N \<Longrightarrow> col C E O P \<Longrightarrow> col A G O Q \<Longrightarrow>
           (\<exists> R. col I L O R) \<or> pl A H \<or> pl B H \<or> pl C H \<or> pl E D \<or> pl F D \<or> pl G D"
    and "\<And>A B C D. pl A B \<Longrightarrow> pl A C \<Longrightarrow> pl D B \<Longrightarrow> pl D C \<Longrightarrow> ep A D \<or> el B C"
    and "\<And>A B. ep A A \<Longrightarrow> ep B B \<Longrightarrow> \<exists>C. pl A C \<and> pl B C"
  shows goal using assms
  by coherent

lemma p2p1:
  assumes "col a b c l \<and> col d e f m"
    and "col b f g n \<and> col c e g o"
    and "col b d h p \<and> col a e h q"
    and "col c d i r \<and> col a f i s"
    and "pl a m \<Longrightarrow> goal"
    and "pl b m \<Longrightarrow> goal"
    and "pl c m \<Longrightarrow> goal"
    and "pl d l \<Longrightarrow> goal"
    and "pl e l \<Longrightarrow> goal"
    and "pl f l \<Longrightarrow> goal"
    and "\<And>A. pl g A \<Longrightarrow> pl h A \<Longrightarrow> pl i A \<Longrightarrow> goal"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl A D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl B D"
    and "\<And>A B C D. col A B C D \<Longrightarrow> pl C D"
    and "\<And>A B. pl A B \<Longrightarrow> ep A A"
    and "\<And>A B. ep A B \<Longrightarrow> ep B A"
    and "\<And>A B C. ep A B \<Longrightarrow> ep B C \<Longrightarrow> ep A C"
    and "\<And>A B. pl A B \<Longrightarrow> el B B"
    and "\<And>A B. el A B \<Longrightarrow> el B A"
    and "\<And>A B C. el A B \<Longrightarrow> el B C \<Longrightarrow> el A C"
    and "\<And>A B C. ep A B \<Longrightarrow> pl B C \<Longrightarrow> pl A C"
    and "\<And>A B C. pl A B \<Longrightarrow> el B C \<Longrightarrow> pl A C"
    and "\<And>A B C D E F G H I J K L M N O P Q.
           col A B C J \<Longrightarrow> col D E F K \<Longrightarrow> col B F G L \<Longrightarrow> col C E G M \<Longrightarrow>
           col B D H N \<Longrightarrow> col A E H O \<Longrightarrow> col C D I P \<Longrightarrow> col A F I Q \<Longrightarrow>
           (\<exists> R. col G H I R) \<or> el L M \<or> el N O \<or> el P Q"
    and "\<And>A B C D. pl C A \<Longrightarrow> pl C B \<Longrightarrow> pl D A \<Longrightarrow> pl D B \<Longrightarrow> ep C D \<or> el A B"
    and "\<And>A B C. ep A A \<Longrightarrow> ep B B \<Longrightarrow> \<exists>C. pl A C \<and> pl B C"
  shows goal using assms
  by coherent

subsection \<open>Preservation of the Diamond Property under reflexive closure\<close>

lemma diamond:
  assumes "reflexive_rewrite a b" "reflexive_rewrite a c"
    and "\<And>A. reflexive_rewrite b A \<Longrightarrow> reflexive_rewrite c A \<Longrightarrow> goal"
    and "\<And>A. equalish A A"
    and "\<And>A B. equalish A B \<Longrightarrow> equalish B A"
    and "\<And>A B C. equalish A B \<Longrightarrow> reflexive_rewrite B C \<Longrightarrow> reflexive_rewrite A C"
    and "\<And>A B. equalish A B \<Longrightarrow> reflexive_rewrite A B"
    and "\<And>A B. rewrite A B \<Longrightarrow> reflexive_rewrite A B"
    and "\<And>A B. reflexive_rewrite A B \<Longrightarrow> equalish A B \<or> rewrite A B"
    and "\<And>A B C. rewrite A B \<Longrightarrow> rewrite A C \<Longrightarrow> \<exists>D. rewrite B D \<and> rewrite C D"
  shows goal using assms
  by coherent

end


(*
    Author:      David Sanan
    Maintainer:  David Sanan, sanan at ntu edu sg
    License:     LGPL
*)

(*  Title:      Sep_Prod_Instance.thy
    Author:     David Sanan, NTU

Copyright (C) 2015-2016 David Sanan
Some rights reserved, NTU
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
theory Sep_Prod_Instance
imports Separation_Algebra.Sep_Heap_Instance "Separata.Separata"
begin
section{* Product of Separation Algebras Instantiation *}

instantiation prod::(sep_algebra,sep_algebra) sep_algebra
begin
definition zero_prod_def: "0 \<equiv> (0,0)"
definition plus_prod_def: "p1 + p2 \<equiv> ((fst p1) + (fst p2),(snd p1) + (snd p2))"
definition sep_disj_prod_def: "sep_disj p1 p2 \<equiv> ((fst p1) ## (fst p2) \<and> (snd p1) ## (snd p2))"

instance
  apply standard
        apply (simp add: sep_disj_prod_def zero_prod_def)
       apply (simp add: sep_disj_commute sep_disj_prod_def)
      apply (simp add: zero_prod_def  plus_prod_def)
     apply (simp add: plus_prod_def sep_disj_prod_def sep_disj_commute sep_add_commute)
    apply (simp add: plus_prod_def sep_add_assoc sep_disj_prod_def)
   apply (simp add: sep_disj_prod_def plus_prod_def )
   apply (fastforce intro:sep_disj_addD1)
  apply (simp add: sep_disj_prod_def prod_def plus_prod_def sep_disj_addI1)
  done
end

instantiation prod::(heap_sep_algebra, heap_sep_algebra) heap_sep_algebra
begin
  instance
   proof
    fix x :: "'a \<times> 'b" and z :: "'a \<times> 'b" and y :: "'a \<times> 'b"
    assume a1: "x + z = y + z"
    assume a2: "x ## z"
    assume a3: "y ## z"
    have f4: "fst x + fst z = fst y + fst z \<and> snd x + snd z = snd y + snd z"
      using a1 by (simp add: plus_prod_def)
    have f5: "\<forall>p pa. p ## pa = ((fst p::'a) ## fst pa \<and> (snd p::'b) ## snd pa)"
      using sep_disj_prod_def by blast
    hence f6: "fst x = fst y"
      using f4 a3 a2 by (meson sep_add_cancel)
    have "snd x = snd y"
      using f5 f4 a3 a2 by (meson sep_add_cancel)
    thus "x = y"
      using f6 by (simp add: prod_eq_iff)
  next
     fix x:: "'a \<times> 'b"
     assume "x##x"
     thus "x=0"
      by (metis sep_add_disj sep_disj_prod_def surjective_pairing zero_prod_def)
   next
     fix a :: "'a \<times> 'b" and b :: "'a \<times> 'b" and c :: "'a \<times> 'b" and d :: "'a \<times> 'b" and w :: "'a \<times> 'b"
     assume wab:"a + b = w" and wcd:"c + d = w" and  abdis:"a ## b" and cddis:"c ## d"
     then obtain a1 a2 b1 b2 c1 c2 d1 d2 w1 w2 where
       a:"a= (a1,a2)" and
       b:"b= (b1,b2)" and
       c:"c= (c1,c2)" and
       d:"d= (d1,d2)" and
       e:"w= (w1,w2)" by fastforce
     have "\<exists>e1 f1 g1 h1. a1=e1+f1 \<and> b1 = g1 + h1 \<and> c1=e1+g1 \<and> d1 = f1+h1 \<and>
         e1##f1 \<and> g1##h1 \<and> e1##g1 \<and> f1##h1"
     using wab wcd abdis cddis a b c d e
       unfolding plus_prod_def sep_disj_prod_def
       using sep_add_cross_split
       by fastforce
     also have "\<exists>e2 f2 g2 h2. a2=e2+f2 \<and> b2 = g2 + h2 \<and> c2=e2+g2 \<and> d2 = f2+h2 \<and>
         e2##f2 \<and> g2##h2 \<and> e2##g2 \<and> f2##h2"
       using wab wcd abdis cddis a b c d e
       unfolding plus_prod_def sep_disj_prod_def
       using sep_add_cross_split
       by fastforce
     ultimately show  "\<exists> e f g h. e + f = a \<and> g + h = b \<and> e + g = c \<and> f + h = d \<and>
                  e ## f \<and> g ## h \<and> e ## g \<and> f ## h"
     using  a b c d e
       unfolding plus_prod_def sep_disj_prod_def
       by fastforce
    next
      fix x :: "'a \<times> 'b" and y :: "'a \<times> 'b"
      assume "x+y=0" and
             "x##y"
      thus "x=0"
      proof -
        have f1: "(fst x + fst y, snd x + snd y) = 0"
          by (metis (full_types) \<open>x + y = 0\<close> plus_prod_def)
        then have f2: "fst x = 0"
          by (metis (no_types) \<open>x ## y\<close> fst_conv sep_add_ind_unit sep_disj_prod_def zero_prod_def)
        have "snd x + snd y = 0"
          using f1 by (metis snd_conv zero_prod_def)
        then show ?thesis
          using f2 by (metis (no_types) \<open>x ## y\<close> fst_conv plus_prod_def sep_add_ind_unit sep_add_zero sep_disj_prod_def snd_conv zero_prod_def)
      qed
    next
      fix x :: "'a \<times> 'b" and y :: "'a \<times> 'b" and z :: "'a \<times> 'b"
      assume "x ## y" and "y ## z" and "x ## z"
      then have "x ## (fst y + fst z, snd y + snd z)"
          by (metis \<open>x ## y\<close> \<open>x ## z\<close> \<open>y ## z\<close> disj_dstri fst_conv sep_disj_prod_def snd_conv)
      thus "x ## y + z" by (metis plus_prod_def)
  qed
end

lemma fst_fst_dist:"fst (fst x + fst y) = fst (fst x) + fst (fst y)"
by (simp add: plus_prod_def)

lemma fst_snd_dist:"fst (snd x + snd y) = fst (snd x) + fst (snd y)"
by (simp add: plus_prod_def)

lemma snd_fst_dist:"snd (fst x + fst y) = snd (fst x) + snd (fst y)"
by (simp add: plus_prod_def)

lemma snd_snd_dist:"snd (snd x + snd y) = snd (snd x) + snd (snd y)"
by (simp add: plus_prod_def)

lemma dis_sep:"(\<sigma>1, \<sigma>2) = (x1',x2') + (x1'',x2'') \<and>
       (x1',x2') ## (x1'',x2'') \<Longrightarrow>
       \<sigma>1 =(x1'+ x1'') \<and> x1' ## x1'' \<and> x2' ## x2''
      \<and> \<sigma>2 =(x2'+ x2'')"
by (simp add: plus_prod_def sep_disj_prod_def)

lemma substate_prod: "\<sigma>1 \<preceq> \<sigma>1' \<and> \<sigma>2 \<preceq> \<sigma>2' \<Longrightarrow> (\<sigma>1,\<sigma>2)  \<preceq>  (\<sigma>1',\<sigma>2')"
proof -
  assume a1:"\<sigma>1 \<preceq> \<sigma>1' \<and> \<sigma>2 \<preceq> \<sigma>2'"
  then obtain x where sub_x:"\<sigma>1 ## x \<and> \<sigma>1 + x = \<sigma>1'" using sep_substate_def by blast
  with a1 obtain y where sub_y:"\<sigma>2 ## y \<and> \<sigma>2 + y = \<sigma>2'" using sep_substate_def by blast
  have dis_12:"(\<sigma>1,\<sigma>2)##(x,y)" using sub_x sub_y  by (simp add: sep_disj_prod_def)
  have union_12:"(\<sigma>1',\<sigma>2') = (\<sigma>1,\<sigma>2)+(x,y)" using  sub_x sub_y  by (simp add: plus_prod_def)
  show "(\<sigma>1,\<sigma>2) \<preceq> (\<sigma>1',\<sigma>2')" using sep_substate_def dis_12 union_12 by auto
qed

lemma disj_sep_substate:
  "(\<sigma>1,\<sigma>'\<triangleright>\<sigma>1') \<and> (\<sigma>2,\<sigma>''\<triangleright>\<sigma>2')  \<Longrightarrow>
   (\<sigma>1,\<sigma>2)  \<preceq>  (\<sigma>1',\<sigma>2')"
proof-
assume a1:"(\<sigma>1,\<sigma>'\<triangleright>\<sigma>1') \<and> (\<sigma>2,\<sigma>''\<triangleright>\<sigma>2')"
  thus "(\<sigma>1,\<sigma>2)  \<preceq>  (\<sigma>1',\<sigma>2')"
    by (metis substate_prod tern_rel_def sep_substate_disj_add)
qed

lemma sep_tran_disjoint_split:
    "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
     (\<sigma>1',\<sigma>2') = (((fst (fst x) + fst (fst y) + fst \<sigma>'),snd (fst x) + snd (fst y) + snd \<sigma>'),
                   fst (snd x) + fst (snd y) + fst \<sigma>'', snd (snd x) + snd (snd y) + snd \<sigma>'')"
proof-
  assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:"\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and> fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
  then show "(\<sigma>1',\<sigma>2') =(((fst (fst x) + fst (fst y) + fst \<sigma>'),snd (fst x) + snd (fst y) + snd \<sigma>'),
                   fst (snd x) + fst (snd y) + fst \<sigma>'', snd (snd x) + snd (snd y) + snd \<sigma>'')"
    by (simp add: descomp_sigma plus_prod_def tern_rel_def)
qed

lemma sep_tran_disjoint_disj1:
   "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
    (fst (fst x + fst y) ##  fst \<sigma>')
    \<and> (snd (fst x + fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x + snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x + snd y)) ##  snd \<sigma>'')
   "
proof -
 assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:
       "\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and>
        fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
 then show " (fst (fst x + fst y) ##  fst \<sigma>')
    \<and> (snd (fst x + fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x + snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x + snd y)) ##  snd \<sigma>'')
   "
  by (simp add: descomp_sigma sep_disj_prod_def tern_rel_def)
qed

lemma sep_tran_disjoint_disj:
   "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
    (fst (fst x) ##  fst \<sigma>') \<and> (fst (fst y) ## fst \<sigma>')
    \<and> (snd (fst x) ##  snd \<sigma>') \<and> (snd (fst y) ##  snd \<sigma>')
   \<and> (fst (snd x) ##  fst \<sigma>'') \<and> (fst (snd y) ## fst \<sigma>'')
   \<and> (snd (snd x) ##  snd \<sigma>'') \<and> (snd (snd y) ## snd \<sigma>'')
   "
proof -
 assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:
       "\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and>
        fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  then have sep_comp:"fst (fst x)## fst (fst y) \<and> snd (fst x) ## snd (fst y) \<and>
             fst (snd x)## fst (snd y) \<and> snd (snd x) ## snd (snd y)"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
  then have  " (fst (fst x + fst y) ##  fst \<sigma>')
    \<and> (snd (fst x + fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x + snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x + snd y)) ##  snd \<sigma>'')
   " using a1 a2 sep_tran_disjoint_disj1 by blast
  then have disjall:" ((fst (fst x)) + (fst (fst y)) ##  fst \<sigma>')
    \<and> (snd (fst x) + snd( fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x) + fst (snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x) + snd (snd y)) ##  snd \<sigma>'')
   " by (simp add: plus_prod_def)
 then show "(fst (fst x) ##  fst \<sigma>') \<and> (fst (fst y) ## fst \<sigma>')
    \<and> (snd (fst x) ##  snd \<sigma>') \<and> (snd (fst y) ##  snd \<sigma>')
   \<and> (fst (snd x) ##  fst \<sigma>'') \<and> (fst (snd y) ## fst \<sigma>'')
   \<and> (snd (snd x) ##  snd \<sigma>'') \<and> (snd (snd y) ## snd \<sigma>'')"
       using sep_comp sep_add_disjD by metis
qed

lemma disj_union_dist1: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2') \<Longrightarrow>
                        ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright> (\<sigma>1',\<sigma>2'))"
unfolding tern_rel_def
by (simp add: plus_prod_def sep_disj_prod_def)

lemma disj_union_dist2: "((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright> (\<sigma>1',\<sigma>2')) \<Longrightarrow>
                         (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
unfolding tern_rel_def
by (simp add: plus_prod_def sep_disj_prod_def)

lemma disj_union_dist: "((\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')) =
                        ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright> (\<sigma>1',\<sigma>2'))"
using disj_union_dist1 disj_union_dist2 by blast

lemma sep_tran_eq_y':
    "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
     \<exists>x' y'. (x' , y' \<triangleright> (\<sigma>1',\<sigma>2')) \<and> (fst y'=snd y')"
proof-
  assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:"\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and> fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
  then have "(( fst x + fst y), \<sigma>'\<triangleright> \<sigma>1') \<and> ((snd x + snd y), \<sigma>''\<triangleright> \<sigma>2')"
  using descomp_sigma by auto
  have descomp_sigma1':"fst \<sigma>1' = fst \<sigma>1 + fst \<sigma>' \<and>
                            snd \<sigma>1' = snd \<sigma>1 + snd \<sigma>' \<and>
                            fst \<sigma>1 ## fst \<sigma>' \<and> snd \<sigma>1 ## snd \<sigma>'" using a2
    by (auto simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
   have descomp_sigma1':"fst \<sigma>2' = fst \<sigma>2 + fst \<sigma>'' \<and>
                            snd \<sigma>2' = snd \<sigma>2 + snd \<sigma>'' \<and>
                            fst \<sigma>2 ## fst \<sigma>'' \<and> snd \<sigma>2 ## snd \<sigma>''"
    using a2
    by (auto simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  then show "\<exists>x' y'. (x' , y'\<triangleright>(\<sigma>1',\<sigma>2'))  \<and> (fst y'=snd y')"
    by (metis (no_types) eq_fst_iff eq_snd_iff sep_add_zero tern_rel_def sep_disj_zero zero_prod_def)
qed

lemma sep_dis_con_eq:
  "x ## y \<and> (h::('a::sep_algebra, 'a::sep_algebra)prod) = x + y \<Longrightarrow>
   x' ## y' \<and> h = x' + y' \<Longrightarrow>
   x+y=x'+y'"
by simp

(*
instantiation prod::(heap_sep_algebra_labelled_sequents, heap_sep_algebra_labelled_sequents) heap_sep_algebra_labelled_sequents
begin
instance proof qed
end
*)

instantiation set:: (type) zero
begin
  definition zero_set_def: "0 \<equiv> {}"
  instance ..
end

instantiation set:: (type) sep_algebra
begin
  definition
  plus_set_def: "m1 + m2 \<equiv> m1 \<union> m2"

definition
  sep_disj_set_def: "sep_disj m1 m2 \<equiv> m1 \<inter> m2 = {}"
instance
  apply standard
  by (auto simp add: sep_disj_set_def  zero_set_def plus_set_def)
end

instantiation set :: (type) opt
begin
  definition none_def [simp]: "none \<equiv> {}"
  instance ..
end

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Traces
imports Main
begin
(*>*)

section{* Traces *}

text{*

A \emph{trace} is a non-empty sequence of states. This custom type has
the advantage over the standard HOL list type of providing a more
suitable induction rule. We use these to give a semantics to
knowledge-based programs in \S\ref{sec:kbps-theory-kbps-semantics}.

*}

datatype 's Trace = tInit "'s"
                  | tStep "'s Trace" "'s" (infixl "\<leadsto>" 65)

fun tFirst :: "'s Trace \<Rightarrow> 's" where
    "tFirst (tInit s) = s"
  | "tFirst (t \<leadsto> s) = tFirst t"

fun tLast :: "'s Trace \<Rightarrow> 's" where
    "tLast (tInit s) = s"
  | "tLast (t \<leadsto> s) = s"
(*<*)

lemma tLast_tInit_comp[simp]: "tLast \<circ> tInit = id"
  by (rule ext) simp
(*>*)

text{*

We provide a few of the standard list operations: @{term "tLength"},
@{term "tMap"} and @{term "tZip"}. Our later ease hinges on taking the
length of a trace to be zero-based.

*}

fun tLength :: "'s Trace \<Rightarrow> nat" where
    "tLength (tInit s) = 0"
  | "tLength (t \<leadsto> s) = 1 + tLength t"

(*<*)
lemma tLength_0_conv:
  "(tLength t = 0) \<longleftrightarrow> (\<exists>s. t = tInit s)"
  by (cases t) simp_all

lemma tLength_g0_conv:
  "(tLength t > 0) \<longleftrightarrow> (\<exists>s t'. t = t' \<leadsto> s \<and> tLength t = Suc (tLength t'))"
  by (cases t) simp_all

lemma tLength_Suc:
  "tLength t = Suc n \<Longrightarrow> (\<exists>s t'. t = t' \<leadsto> s \<and> tLength t' = n)"
  by (cases t) simp_all

lemma trace_induct2[consumes 1, case_names tInit tStep]:
  assumes tLen: "tLength t = tLength t'"
      and tI: "\<And>s s'. P (tInit s) (tInit s')"
      and tS: "\<And>s s' t t'. \<lbrakk> tLength t = tLength t'; P t t' \<rbrakk>
               \<Longrightarrow> P (t \<leadsto> s) (t' \<leadsto> s')"
  shows "P t t'"
using tLen
proof (induct t arbitrary: t')
  case (tInit s t') with tI show ?case by (auto iff: tLength_0_conv)
next
  case (tStep t s t') with tS show ?case by (cases t') simp_all
qed
(*>*)

fun tMap where
  "tMap f (tInit x) = tInit (f x)"
| "tMap f (xs \<leadsto> x) = tMap f xs \<leadsto> f x"

(*<*)
lemma tLength_tMap[iff]: "tLength (tMap f t) = tLength t"
  by (induct t) simp_all

lemma tMap_is_tInit[iff]: "(tMap f t = tInit s) \<longleftrightarrow> (\<exists>s'. t = tInit s' \<and> f s' = s)"
  by (cases t) simp_all

lemma tInit_is_tMap[iff]: "(tInit s = tMap f t) \<longleftrightarrow> (\<exists>s'. t = tInit s' \<and> f s' = s)"
  by (cases t) auto

lemma tStep_is_tMap_conv[iff]:
 "(tp \<leadsto> s = tMap f t) \<longleftrightarrow> (\<exists>tp' s'. t = tp' \<leadsto> s' \<and> s = f s' \<and> tp = tMap f tp')"
  by (cases t) auto

lemma tMap_is_tStep_conv[iff]:
 "(tMap f t = tp \<leadsto> s) \<longleftrightarrow> (\<exists>tp' s'. t = tp' \<leadsto> s' \<and> s = f s' \<and> tMap f tp' = tp)"
  by (cases t) auto

lemma tMap_eq_imp_tLength_eq:
  assumes "tMap f t = tMap f' t'"
  shows "tLength t = tLength t'"
using assms
proof (induct t arbitrary: t')
  case (tStep tp s t')
  then obtain tp' s' where t': "t' = tp' \<leadsto> s'" by fastforce
  moreover with tStep have "tLength tp' = tLength tp" by simp
  with t' show ?case by simp
qed auto

lemma tMap_tFirst[iff]:
  "tFirst (tMap f t) = f (tFirst t)"
  by (induct t) simp_all

lemma tMap_tLast[iff]:
  "tLast (tMap f t) = f (tLast t)"
  by (induct t) simp_all

lemma tMap_tFirst_inv:
  assumes M: "tMap f t = tMap f' t'"
  shows "f (tFirst t) = f' (tFirst t')"
proof -
  from M have L: "tLength t = tLength t'" by (rule tMap_eq_imp_tLength_eq)
  from L M show ?thesis by (induct rule: trace_induct2, simp_all)
qed

lemma tMap_tLast_inv:
  assumes M: "tMap f t = tMap f' t'"
  shows "f (tLast t) = f' (tLast t')"
proof -
  from M have L: "tLength t = tLength t'" by (rule tMap_eq_imp_tLength_eq)
  from L M show ?thesis by (induct rule: trace_induct2, simp_all)
qed
(*>*)

fun tZip where
  "tZip f (tInit x) (tInit y) = tInit (f x y)"
| "tZip f (xs \<leadsto> x) (ys \<leadsto> y) = tZip f xs ys \<leadsto> f x y"
(*<*)

lemma tLength_tZip[iff]: "tLength xs = tLength ys \<Longrightarrow> tLength (tZip f xs ys) = tLength xs"
  by (induct rule: trace_induct2) simp_all

(*>*)
(*<*)
end
(*>*)


theory prop_42
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  (*hipster take *)
  theorem x0 :
    "(take (S n) (Cons2 x xs)) = (Cons2 x (take n xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory CategoryNaturalNumbers imports Category
begin

typedef natCat = "UNIV::(nat\<times>nat) set" by auto

(*(Abs_natCat ((snd (Rep_natCat b)), (fst (Rep_natCat a))))"*)

axiomatization where
natCatEx1: "E (a::natCat) \<longleftrightarrow> fst (Rep_natCat a) \<ge> snd (Rep_natCat a)" and
natCatEx2: "\<not>(E (Abs_natCat (0::nat,1::nat)))"

lemma "True" nitpick[satisfy, card natCat = 4] oops

instantiation natCat :: category
begin

lift_definition domain_natCat::"natCat\<Rightarrow>natCat" is
"\<lambda>x::natCat. if E x then Abs_natCat((snd (Rep_natCat x), snd (Rep_natCat x)))
                      else (Abs_natCat (0::nat,1::nat))"
  done

lift_definition codomain_natCat::"natCat\<Rightarrow>natCat" is
"\<lambda>x::natCat. if E x then Abs_natCat((fst (Rep_natCat x), fst (Rep_natCat x)))
                      else(Abs_natCat (0::nat,1::nat))"
  done

lift_definition composition_natCat::"natCat\<Rightarrow>natCat\<Rightarrow>natCat" is
"\<lambda>y x. if E x \<and> E y \<and> snd (Rep_natCat y) = fst (Rep_natCat x)
    then (Abs_natCat ((snd (Rep_natCat y)), (fst (Rep_natCat x))))
      else Abs_natCat (0,1)"
  done

instance
proof
  fix x y z :: natCat

  show "E x \<^bold>\<leftarrow> E (dom x)"
    apply(transfer)
    using natCatEx2 by auto

  show "E x \<^bold>\<leftarrow> E (cod x)"
    apply(transfer)
    using natCatEx2 by auto

  show "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y"
    apply(transfer)
    by (smt Abs_natCat_inverse UNIV_I natCatEx2 prod.inject)

  show "x \<cdot> (y \<cdot> z) \<cong> (x \<cdot> y) \<cdot> z"
    apply(transfer)
    sorry

  show "x \<cdot> (dom x) \<cong> x"
    apply(transfer)
    sorry

  show "(cod y) \<cdot> y \<cong> y"
    apply(transfer)
    sorry
qed

end
end


theory SeCaV_Solutions imports SeCaV begin

section \<open>Exercise 1\<close>

proposition \<open>p a \<longrightarrow> (\<exists>x. p x)\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Pre 0 [Fun 0 []]) (Exi (Pre 0 [Var 0]))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 []]),
      Exi (Pre 0 [Var 0])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Exi (Pre 0 [Var 0]),
      Neg (Pre 0 [Fun 0 []])
    ]
    \<close>
    using that by simp
  with GammaExi have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 []],
      Neg (Pre 0 [Fun 0 []])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 2\<close>

proposition \<open>(\<forall>x y. p x y) \<longrightarrow> (\<forall>x. p x x)\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Uni (Uni (Pre 0 [Var 1, Var 0]))) (Uni (Pre 0 [Var 0, Var 0]))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Uni (Pre 0 [Var 1, Var 0]))),
      Uni (Pre 0 [Var 0, Var 0])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Uni (Pre 0 [Var 0, Var 0]),
      Neg (Uni (Uni (Pre 0 [Var 1, Var 0])))
    ]
    \<close>
    using that by simp
  with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 [], Fun 0 []],
      Neg (Uni (Uni (Pre 0 [Var 1, Var 0])))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Uni (Pre 0 [Var 1, Var 0]))),
      Pre 0 [Fun 0 [], Fun 0 []]
    ]
    \<close>
    using that by simp
  with GammaUni[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 [], Fun 0 []]),
      Pre 0 [Fun 0 [], Fun 0 []]
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 [], Fun 0 []],
      Neg (Pre 0 [Fun 0 [], Fun 0 []])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 3\<close>

proposition \<open>(\<forall>x. p x) \<or> (\<forall>x. q x) \<longrightarrow> (\<forall>x. p x \<or> q x)\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp
      (Dis (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
      (Uni (Dis (Pre 0 [Var 0]) (Pre 1 [Var 0])))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Dis (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0]))),
      Uni (Dis (Pre 0 [Var 0]) (Pre 1 [Var 0]))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Uni (Dis (Pre 0 [Var 0]) (Pre 1 [Var 0])),
      Neg (Dis (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close>
    using that by simp
  with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
      Dis (Pre 0 [Fun 0 []]) (Pre 1 [Fun 0 []]),
      Neg (Dis (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close>
    using that by simp
  with AlphaDis have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 []],
      Pre 1 [Fun 0 []],
      Neg (Dis (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0])))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Neg (Dis (Uni (Pre 0 [Var 0])) (Uni (Pre 1 [Var 0]))),
      Pre 0 [Fun 0 []],
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with BetaDis have ?thesis if \<open>\<tturnstile>
    [
      Neg (Uni (Pre 0 [Var 0])),
      Pre 0 [Fun 0 []],
      Pre 1 [Fun 0 []]
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg (Uni (Pre 1 [Var 0])),
      Pre 0 [Fun 0 []],
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with GammaUni have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 []]),
      Pre 0 [Fun 0 []],
      Pre 1 [Fun 0 []]
    ]
    \<close> and \<open>\<tturnstile>
    [
      Neg (Pre 1 [Fun 0 []]),
      Pre 0 [Fun 0 []],
      Pre 1 [Fun 0 []]
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0 []],
      Neg (Pre 0 [Fun 0 []])
    ]
    \<close> and \<open>\<tturnstile>
    [
      Pre 1 [Fun 0 []],
      Neg (Pre 1 [Fun 0 []])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 4\<close>

proposition \<open>\<exists>x. \<forall>y. p x \<longrightarrow> p y\<close> by metis

lemma \<open>\<tturnstile>
  [
    Exi (Uni (Imp (Pre 0 [Var 1]) (Pre 0 [Var 0])))
  ]
  \<close>
proof -
  from Ext have ?thesis if \<open>\<tturnstile>
    [
      Exi (Uni (Imp (Pre 0 [Var 1]) (Pre 0 [Var 0]))),
      Exi (Uni (Imp (Pre 0 [Var 1]) (Pre 0 [Var 0])))
    ]
    \<close>
    using that by simp
  with GammaExi[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
      Uni (Imp (Pre 0 [Fun 0 []]) (Pre 0 [Var 0])),
      Exi (Uni (Imp (Pre 0 [Var 1]) (Pre 0 [Var 0])))
    ]
    \<close>
    using that by simp
  with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
      Imp (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []]),
      Exi (Uni (Imp (Pre 0 [Var 1]) (Pre 0 [Var 0])))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Exi (Uni (Imp (Pre 0 [Var 1]) (Pre 0 [Var 0]))),
      Imp (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with GammaExi[where t=\<open>Fun 1 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
      Uni (Imp (Pre 0 [Fun 1 []]) (Pre 0 [Var 0])),
      Imp (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
      Imp (Pre 0 [Fun 1 []]) (Pre 0 [Fun 2 []]),
      Imp (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 1 []]),
      Pre 0 [Fun 2 []],
      Imp (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp (Pre 0 [Fun 0 []]) (Pre 0 [Fun 1 []]),
      Neg (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 []]),
      Pre 0 [Fun 1 []],
      Neg (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 1 []],
      Neg (Pre 0 [Fun 1 []])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

section \<open>Exercise 5\<close>

proposition \<open>p a \<and> (p a \<longrightarrow> (\<forall>x. p x)) \<longrightarrow> (\<forall>x. p x)\<close> by metis

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

end


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

Weak safety relations: restricted to the set of reachable states.
*)

section\<open>Weak Safety\<close>

theory Constrains imports UNITY begin

  (*Initial states and program => (final state, reversed trace to it)...
    Arguments MUST be curried in an inductive definition*)

inductive_set
  traces :: "['a set, ('a * 'a)set set] => ('a * 'a list) set"
  for init :: "'a set" and acts :: "('a * 'a)set set"
  where
         (*Initial trace is empty*)
    Init:  "s \<in> init ==> (s,[]) \<in> traces init acts"

  | Acts:  "[| act \<in> acts;  (s,evs) \<in> traces init acts;  (s,s') \<in> act |]
            ==> (s', s#evs) \<in> traces init acts"

inductive_set
  reachable :: "'a program => 'a set"
  for F :: "'a program"
  where
    Init:  "s \<in> Init F ==> s \<in> reachable F"

  | Acts:  "[| act \<in> Acts F;  s \<in> reachable F;  (s,s') \<in> act |]
            ==> s' \<in> reachable F"

definition Constrains :: "['a set, 'a set] => 'a program set" (infixl "Co" 60) where
    "A Co B == {F. F \<in> (reachable F \<inter> A)  co  B}"

definition Unless  :: "['a set, 'a set] => 'a program set" (infixl "Unless" 60) where
    "A Unless B == (A-B) Co (A \<union> B)"

definition Stable     :: "'a set => 'a program set" where
    "Stable A == A Co A"

  (*Always is the weak form of "invariant"*)
definition Always :: "'a set => 'a program set" where
    "Always A == {F. Init F \<subseteq> A} \<inter> Stable A"

  (*Polymorphic in both states and the meaning of \<le> *)
definition Increasing :: "['a => 'b::{order}] => 'a program set" where
    "Increasing f == \<Inter>z. Stable {s. z \<le> f s}"

subsection\<open>traces and reachable\<close>

lemma reachable_equiv_traces:
     "reachable F = {s. \<exists>evs. (s,evs) \<in> traces (Init F) (Acts F)}"
apply safe
apply (erule_tac [2] traces.induct)
apply (erule reachable.induct)
apply (blast intro: reachable.intros traces.intros)+
done

lemma Init_subset_reachable: "Init F \<subseteq> reachable F"
by (blast intro: reachable.intros)

lemma stable_reachable [intro!,simp]:
     "Acts G \<subseteq> Acts F ==> G \<in> stable (reachable F)"
by (blast intro: stableI constrainsI reachable.intros)

(*The set of all reachable states is an invariant...*)
lemma invariant_reachable: "F \<in> invariant (reachable F)"
apply (simp add: invariant_def)
apply (blast intro: reachable.intros)
done

(*...in fact the strongest invariant!*)
lemma invariant_includes_reachable: "F \<in> invariant A ==> reachable F \<subseteq> A"
apply (simp add: stable_def constrains_def invariant_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

subsection\<open>Co\<close>

(*F \<in> B co B' ==> F \<in> (reachable F \<inter> B) co (reachable F \<inter> B')*)
lemmas constrains_reachable_Int =
    subset_refl [THEN stable_reachable [unfolded stable_def], THEN constrains_Int]

(*Resembles the previous definition of Constrains*)
lemma Constrains_eq_constrains:
     "A Co B = {F. F \<in> (reachable F  \<inter>  A) co (reachable F  \<inter>  B)}"
apply (unfold Constrains_def)
apply (blast dest: constrains_reachable_Int intro: constrains_weaken)
done

lemma constrains_imp_Constrains: "F \<in> A co A' ==> F \<in> A Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L)
done

lemma stable_imp_Stable: "F \<in> stable A ==> F \<in> Stable A"
apply (unfold stable_def Stable_def)
apply (erule constrains_imp_Constrains)
done

lemma ConstrainsI:
    "(!!act s s'. [| act \<in> Acts F;  (s,s') \<in> act;  s \<in> A |] ==> s' \<in> A')
     ==> F \<in> A Co A'"
apply (rule constrains_imp_Constrains)
apply (blast intro: constrainsI)
done

lemma Constrains_empty [iff]: "F \<in> {} Co B"
by (unfold Constrains_def constrains_def, blast)

lemma Constrains_UNIV [iff]: "F \<in> A Co UNIV"
by (blast intro: ConstrainsI)

lemma Constrains_weaken_R:
    "[| F \<in> A Co A'; A'<=B' |] ==> F \<in> A Co B'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_R)
done

lemma Constrains_weaken_L:
    "[| F \<in> A Co A'; B \<subseteq> A |] ==> F \<in> B Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L)
done

lemma Constrains_weaken:
   "[| F \<in> A Co A'; B \<subseteq> A; A'<=B' |] ==> F \<in> B Co B'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken)
done

(** Union **)

lemma Constrains_Un:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<union> B) Co (A' \<union> B')"
apply (unfold Constrains_def)
apply (blast intro: constrains_Un [THEN constrains_weaken])
done

lemma Constrains_UN:
  assumes Co: "!!i. i \<in> I ==> F \<in> (A i) Co (A' i)"
  shows "F \<in> (\<Union>i \<in> I. A i) Co (\<Union>i \<in> I. A' i)"
apply (unfold Constrains_def)
apply (rule CollectI)
apply (rule Co [unfolded Constrains_def, THEN CollectD, THEN constrains_UN,
                THEN constrains_weaken],   auto)
done

(** Intersection **)

lemma Constrains_Int:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<inter> B) Co (A' \<inter> B')"
apply (unfold Constrains_def)
apply (blast intro: constrains_Int [THEN constrains_weaken])
done

lemma Constrains_INT:
  assumes Co: "!!i. i \<in> I ==> F \<in> (A i) Co (A' i)"
  shows "F \<in> (\<Inter>i \<in> I. A i) Co (\<Inter>i \<in> I. A' i)"
apply (unfold Constrains_def)
apply (rule CollectI)
apply (rule Co [unfolded Constrains_def, THEN CollectD, THEN constrains_INT,
                THEN constrains_weaken],   auto)
done

lemma Constrains_imp_subset: "F \<in> A Co A' ==> reachable F \<inter> A \<subseteq> A'"
by (simp add: constrains_imp_subset Constrains_def)

lemma Constrains_trans: "[| F \<in> A Co B; F \<in> B Co C |] ==> F \<in> A Co C"
apply (simp add: Constrains_eq_constrains)
apply (blast intro: constrains_trans constrains_weaken)
done

lemma Constrains_cancel:
     "[| F \<in> A Co (A' \<union> B); F \<in> B Co B' |] ==> F \<in> A Co (A' \<union> B')"
apply (simp add: Constrains_eq_constrains constrains_def)
apply best
done

subsection\<open>Stable\<close>

(*Useful because there's no Stable_weaken.  [Tanja Vos]*)
lemma Stable_eq: "[| F \<in> Stable A; A = B |] ==> F \<in> Stable B"
by blast

lemma Stable_eq_stable: "(F \<in> Stable A) = (F \<in> stable (reachable F \<inter> A))"
by (simp add: Stable_def Constrains_eq_constrains stable_def)

lemma StableI: "F \<in> A Co A ==> F \<in> Stable A"
by (unfold Stable_def, assumption)

lemma StableD: "F \<in> Stable A ==> F \<in> A Co A"
by (unfold Stable_def, assumption)

lemma Stable_Un:
    "[| F \<in> Stable A; F \<in> Stable A' |] ==> F \<in> Stable (A \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un)
done

lemma Stable_Int:
    "[| F \<in> Stable A; F \<in> Stable A' |] ==> F \<in> Stable (A \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int)
done

lemma Stable_Constrains_Un:
    "[| F \<in> Stable C; F \<in> A Co (C \<union> A') |]
     ==> F \<in> (C \<union> A) Co (C \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un [THEN Constrains_weaken])
done

lemma Stable_Constrains_Int:
    "[| F \<in> Stable C; F \<in> (C \<inter> A) Co A' |]
     ==> F \<in> (C \<inter> A) Co (C \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int [THEN Constrains_weaken])
done

lemma Stable_UN:
    "(!!i. i \<in> I ==> F \<in> Stable (A i)) ==> F \<in> Stable (\<Union>i \<in> I. A i)"
by (simp add: Stable_def Constrains_UN)

lemma Stable_INT:
    "(!!i. i \<in> I ==> F \<in> Stable (A i)) ==> F \<in> Stable (\<Inter>i \<in> I. A i)"
by (simp add: Stable_def Constrains_INT)

lemma Stable_reachable: "F \<in> Stable (reachable F)"
by (simp add: Stable_eq_stable)

subsection\<open>Increasing\<close>

lemma IncreasingD:
     "F \<in> Increasing f ==> F \<in> Stable {s. x \<le> f s}"
by (unfold Increasing_def, blast)

lemma mono_Increasing_o:
     "mono g ==> Increasing f \<subseteq> Increasing (g o f)"
apply (simp add: Increasing_def Stable_def Constrains_def stable_def
                 constrains_def)
apply (blast intro: monoD order_trans)
done

lemma strict_IncreasingD:
     "!!z::nat. F \<in> Increasing f ==> F \<in> Stable {s. z < f s}"
by (simp add: Increasing_def Suc_le_eq [symmetric])

lemma increasing_imp_Increasing:
     "F \<in> increasing f ==> F \<in> Increasing f"
apply (unfold increasing_def Increasing_def)
apply (blast intro: stable_imp_Stable)
done

lemmas Increasing_constant = increasing_constant [THEN increasing_imp_Increasing, iff]

subsection\<open>The Elimination Theorem\<close>

(*The "free" m has become universally quantified! Should the premise be !!m
instead of \<forall>m ?  Would make it harder to use in forward proof.*)

lemma Elimination:
    "[| \<forall>m. F \<in> {s. s x = m} Co (B m) |]
     ==> F \<in> {s. s x \<in> M} Co (\<Union>m \<in> M. B m)"
by (unfold Constrains_def constrains_def, blast)

(*As above, but for the trivial case of a one-variable state, in which the
  state is identified with its one variable.*)
lemma Elimination_sing:
    "(\<forall>m. F \<in> {m} Co (B m)) ==> F \<in> M Co (\<Union>m \<in> M. B m)"
by (unfold Constrains_def constrains_def, blast)

subsection\<open>Specialized laws for handling Always\<close>

(** Natural deduction rules for "Always A" **)

lemma AlwaysI: "[| Init F \<subseteq> A;  F \<in> Stable A |] ==> F \<in> Always A"
by (simp add: Always_def)

lemma AlwaysD: "F \<in> Always A ==> Init F \<subseteq> A & F \<in> Stable A"
by (simp add: Always_def)

lemmas AlwaysE = AlwaysD [THEN conjE]
lemmas Always_imp_Stable = AlwaysD [THEN conjunct2]

(*The set of all reachable states is Always*)
lemma Always_includes_reachable: "F \<in> Always A ==> reachable F \<subseteq> A"
apply (simp add: Stable_def Constrains_def constrains_def Always_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

lemma invariant_imp_Always:
     "F \<in> invariant A ==> F \<in> Always A"
apply (unfold Always_def invariant_def Stable_def stable_def)
apply (blast intro: constrains_imp_Constrains)
done

lemmas Always_reachable = invariant_reachable [THEN invariant_imp_Always]

lemma Always_eq_invariant_reachable:
     "Always A = {F. F \<in> invariant (reachable F \<inter> A)}"
apply (simp add: Always_def invariant_def Stable_def Constrains_eq_constrains
                 stable_def)
apply (blast intro: reachable.intros)
done

(*the RHS is the traditional definition of the "always" operator*)
lemma Always_eq_includes_reachable: "Always A = {F. reachable F \<subseteq> A}"
by (auto dest: invariant_includes_reachable simp add: Int_absorb2 invariant_reachable Always_eq_invariant_reachable)

lemma Always_UNIV_eq [simp]: "Always UNIV = UNIV"
by (auto simp add: Always_eq_includes_reachable)

lemma UNIV_AlwaysI: "UNIV \<subseteq> A ==> F \<in> Always A"
by (auto simp add: Always_eq_includes_reachable)

lemma Always_eq_UN_invariant: "Always A = (\<Union>I \<in> Pow A. invariant I)"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: invariantI Init_subset_reachable [THEN subsetD]
                    invariant_includes_reachable [THEN subsetD])
done

lemma Always_weaken: "[| F \<in> Always A; A \<subseteq> B |] ==> F \<in> Always B"
by (auto simp add: Always_eq_includes_reachable)

subsection\<open>"Co" rules involving Always\<close>

lemma Always_Constrains_pre:
     "F \<in> Always INV ==> (F \<in> (INV \<inter> A) Co A') = (F \<in> A Co A')"
by (simp add: Always_includes_reachable [THEN Int_absorb2] Constrains_def
              Int_assoc [symmetric])

lemma Always_Constrains_post:
     "F \<in> Always INV ==> (F \<in> A Co (INV \<inter> A')) = (F \<in> A Co A')"
by (simp add: Always_includes_reachable [THEN Int_absorb2]
              Constrains_eq_constrains Int_assoc [symmetric])

(* [| F \<in> Always INV;  F \<in> (INV \<inter> A) Co A' |] ==> F \<in> A Co A' *)
lemmas Always_ConstrainsI = Always_Constrains_pre [THEN iffD1]

(* [| F \<in> Always INV;  F \<in> A Co A' |] ==> F \<in> A Co (INV \<inter> A') *)
lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]

(*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
lemma Always_Constrains_weaken:
     "[| F \<in> Always C;  F \<in> A Co A';
         C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B Co B'"
apply (rule Always_ConstrainsI, assumption)
apply (drule Always_ConstrainsD, assumption)
apply (blast intro: Constrains_weaken)
done

(** Conjoining Always properties **)

lemma Always_Int_distrib: "Always (A \<inter> B) = Always A \<inter> Always B"
by (auto simp add: Always_eq_includes_reachable)

lemma Always_INT_distrib: "Always (\<Inter>(A ` I)) = (\<Inter>i \<in> I. Always (A i))"
by (auto simp add: Always_eq_includes_reachable)

lemma Always_Int_I:
     "[| F \<in> Always A;  F \<in> Always B |] ==> F \<in> Always (A \<inter> B)"
by (simp add: Always_Int_distrib)

(*Allows a kind of "implication introduction"*)
lemma Always_Compl_Un_eq:
     "F \<in> Always A ==> (F \<in> Always (-A \<union> B)) = (F \<in> Always B)"
by (auto simp add: Always_eq_includes_reachable)

(*Delete the nearest invariance assumption (which will be the second one
  used by Always_Int_I) *)
lemmas Always_thin = thin_rl [of "F \<in> Always A"] for F A

subsection\<open>Totalize\<close>

lemma reachable_imp_reachable_tot:
      "s \<in> reachable F ==> s \<in> reachable (totalize F)"
apply (erule reachable.induct)
 apply (rule reachable.Init)
 apply simp
apply (rule_tac act = "totalize_act act" in reachable.Acts)
apply (auto simp add: totalize_act_def)
done

lemma reachable_tot_imp_reachable:
      "s \<in> reachable (totalize F) ==> s \<in> reachable F"
apply (erule reachable.induct)
 apply (rule reachable.Init, simp)
apply (force simp add: totalize_act_def intro: reachable.Acts)
done

lemma reachable_tot_eq [simp]: "reachable (totalize F) = reachable F"
by (blast intro: reachable_imp_reachable_tot reachable_tot_imp_reachable)

lemma totalize_Constrains_iff [simp]: "(totalize F \<in> A Co B) = (F \<in> A Co B)"
by (simp add: Constrains_def)

lemma totalize_Stable_iff [simp]: "(totalize F \<in> Stable A) = (F \<in> Stable A)"
by (simp add: Stable_def)

lemma totalize_Always_iff [simp]: "(totalize F \<in> Always A) = (F \<in> Always A)"
by (simp add: Always_def)

end