(*  Title:      ZF/UNITY/Guar.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Guarantees, etc.

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Revised by Sidi Ehmety on January 2001

Added \<in> Compatibility, weakest guarantees, etc.

and Weakest existential property,
from Charpentier and Chandy "Theorems about Composition",
Fifth International Conference on Mathematics of Program, 2000.

Theory ported from HOL.
*)

section\<open>The Chandy-Sanders Guarantees Operator\<close>

theory Guar imports Comp begin

(* To be moved to theory WFair???? *)
lemma leadsTo_Basis': "\<lbrakk>F \<in> A co A \<union> B; F \<in> transient(A); st_set(B)\<rbrakk> \<Longrightarrow> F \<in> A \<longmapsto> B"
apply (frule constrainsD2)
apply (drule_tac B = "A-B" in constrains_weaken_L, blast)
apply (drule_tac B = "A-B" in transient_strengthen, blast)
apply (blast intro: ensuresI [THEN leadsTo_Basis])
done

  (*Existential and Universal properties.  We formalize the two-program
    case, proving equivalence with Chandy and Sanders's n-ary definitions*)

definition
   ex_prop :: "i \<Rightarrow> o"  where
   "ex_prop(X) \<equiv> X<=program \<and>
    (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<in> X | G \<in> X \<longrightarrow> (F \<squnion> G) \<in> X)"

definition
  strict_ex_prop  :: "i \<Rightarrow> o"  where
  "strict_ex_prop(X) \<equiv> X<=program \<and>
   (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> (F \<in> X | G \<in> X) \<longleftrightarrow> (F \<squnion> G \<in> X))"

definition
  uv_prop  :: "i \<Rightarrow> o"  where
   "uv_prop(X) \<equiv> X<=program \<and>
    (SKIP \<in> X \<and> (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<in> X \<and> G \<in> X \<longrightarrow> (F \<squnion> G) \<in> X))"

definition
 strict_uv_prop  :: "i \<Rightarrow> o"  where
   "strict_uv_prop(X) \<equiv> X<=program \<and>
    (SKIP \<in> X \<and> (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow>(F \<in> X \<and> G \<in> X) \<longleftrightarrow> (F \<squnion> G \<in> X)))"

definition
  guar :: "[i, i] \<Rightarrow> i" (infixl \<open>guarantees\<close> 55)  where
              (*higher than membership, lower than Co*)
  "X guarantees Y \<equiv> {F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<squnion> G \<in> X \<longrightarrow> F \<squnion> G \<in> Y}"

definition
  (* Weakest guarantees *)
   wg :: "[i,i] \<Rightarrow> i"  where
  "wg(F,Y) \<equiv> \<Union>({X \<in> Pow(program). F:(X guarantees Y)})"

definition
  (* Weakest existential property stronger than X *)
   wx :: "i \<Rightarrow>i"  where
   "wx(X) \<equiv> \<Union>({Y \<in> Pow(program). Y<=X \<and> ex_prop(Y)})"

definition
  (*Ill-defined programs can arise through "\<squnion>"*)
  welldef :: i  where
  "welldef \<equiv> {F \<in> program. Init(F) \<noteq> 0}"

definition
  refines :: "[i, i, i] \<Rightarrow> o" (\<open>(3_ refines _ wrt _)\<close> [10,10,10] 10)  where
  "G refines F wrt X \<equiv>
   \<forall>H \<in> program. (F ok H  \<and> G ok H \<and> F \<squnion> H \<in> welldef \<inter> X)
    \<longrightarrow> (G \<squnion> H \<in> welldef \<inter> X)"

definition
  iso_refines :: "[i,i, i] \<Rightarrow> o"  (\<open>(3_ iso'_refines _ wrt _)\<close> [10,10,10] 10)  where
  "G iso_refines F wrt X \<equiv>  F \<in> welldef \<inter> X \<longrightarrow> G \<in> welldef \<inter> X"

(*** existential properties ***)

lemma ex_imp_subset_program: "ex_prop(X) \<Longrightarrow> X\<subseteq>program"
by (simp add: ex_prop_def)

lemma ex1 [rule_format]:
 "GG \<in> Fin(program)
  \<Longrightarrow> ex_prop(X) \<longrightarrow> GG \<inter> X\<noteq>0 \<longrightarrow> OK(GG, (\<lambda>G. G)) \<longrightarrow>(\<Squnion>G \<in> GG. G) \<in> X"
  unfolding ex_prop_def
apply (erule Fin_induct)
apply (simp_all add: OK_cons_iff)
apply (safe elim!: not_emptyE, auto)
done

lemma ex2 [rule_format]:
"X \<subseteq> program \<Longrightarrow>
 (\<forall>GG \<in> Fin(program). GG \<inter> X \<noteq> 0 \<longrightarrow> OK(GG,(\<lambda>G. G))\<longrightarrow>(\<Squnion>G \<in> GG. G) \<in> X)
   \<longrightarrow> ex_prop(X)"
apply (unfold ex_prop_def, clarify)
apply (drule_tac x = "{F,G}" in bspec)
apply (simp_all add: OK_iff_ok)
apply (auto intro: ok_sym)
done

(*Chandy \<and> Sanders take this as a definition*)

lemma ex_prop_finite:
     "ex_prop(X) \<longleftrightarrow> (X\<subseteq>program \<and>
  (\<forall>GG \<in> Fin(program). GG \<inter> X \<noteq> 0 \<and> OK(GG,(\<lambda>G. G))\<longrightarrow>(\<Squnion>G \<in> GG. G) \<in> X))"
apply auto
apply (blast intro: ex1 ex2 dest: ex_imp_subset_program)+
done

(* Equivalent definition of ex_prop given at the end of section 3*)
lemma ex_prop_equiv:
"ex_prop(X) \<longleftrightarrow>
  X\<subseteq>program \<and> (\<forall>G \<in> program. (G \<in> X \<longleftrightarrow> (\<forall>H \<in> program. (G component_of H) \<longrightarrow> H \<in> X)))"
apply (unfold ex_prop_def component_of_def, safe, force, force, blast)
apply (subst Join_commute)
apply (blast intro: ok_sym)
done

(*** universal properties ***)

lemma uv_imp_subset_program: "uv_prop(X)\<Longrightarrow> X\<subseteq>program"
  unfolding uv_prop_def
apply (simp (no_asm_simp))
done

lemma uv1 [rule_format]:
     "GG \<in> Fin(program) \<Longrightarrow>
      (uv_prop(X)\<longrightarrow> GG \<subseteq> X \<and> OK(GG, (\<lambda>G. G)) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X)"
  unfolding uv_prop_def
apply (erule Fin_induct)
apply (auto simp add: OK_cons_iff)
done

lemma uv2 [rule_format]:
     "X\<subseteq>program  \<Longrightarrow>
      (\<forall>GG \<in> Fin(program). GG \<subseteq> X \<and> OK(GG,(\<lambda>G. G)) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X)
      \<longrightarrow> uv_prop(X)"
apply (unfold uv_prop_def, auto)
apply (drule_tac x = 0 in bspec, simp+)
apply (drule_tac x = "{F,G}" in bspec, simp)
apply (force dest: ok_sym simp add: OK_iff_ok)
done

(*Chandy \<and> Sanders take this as a definition*)
lemma uv_prop_finite:
"uv_prop(X) \<longleftrightarrow> X\<subseteq>program \<and>
  (\<forall>GG \<in> Fin(program). GG \<subseteq> X \<and> OK(GG, \<lambda>G. G) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in>  X)"
apply auto
apply (blast dest: uv_imp_subset_program)
apply (blast intro: uv1)
apply (blast intro!: uv2 dest:)
done

(*** guarantees ***)
lemma guaranteesI:
     "\<lbrakk>(\<And>G. \<lbrakk>F ok G; F \<squnion> G \<in> X; G \<in> program\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> Y);
         F \<in> program\<rbrakk>
    \<Longrightarrow> F \<in> X guarantees Y"
by (simp add: guar_def component_def)

lemma guaranteesD:
     "\<lbrakk>F \<in> X guarantees Y;  F ok G;  F \<squnion> G \<in> X; G \<in> program\<rbrakk>
      \<Longrightarrow> F \<squnion> G \<in> Y"
by (simp add: guar_def component_def)

(*This version of guaranteesD matches more easily in the conclusion
  The major premise can no longer be  F\<subseteq>H since we need to reason about G*)

lemma component_guaranteesD:
     "\<lbrakk>F \<in> X guarantees Y;  F \<squnion> G = H;  H \<in> X;  F ok G; G \<in> program\<rbrakk>
      \<Longrightarrow> H \<in> Y"
by (simp add: guar_def, blast)

lemma guarantees_weaken:
     "\<lbrakk>F \<in> X guarantees X'; Y \<subseteq> X; X' \<subseteq> Y'\<rbrakk> \<Longrightarrow> F \<in> Y guarantees Y'"
by (simp add: guar_def, auto)

lemma subset_imp_guarantees_program:
     "X \<subseteq> Y \<Longrightarrow> X guarantees Y = program"
by (unfold guar_def, blast)

(*Equivalent to subset_imp_guarantees_UNIV but more intuitive*)
lemma subset_imp_guarantees:
     "\<lbrakk>X \<subseteq> Y; F \<in> program\<rbrakk> \<Longrightarrow> F \<in> X guarantees Y"
by (unfold guar_def, blast)

lemma component_of_Join1: "F ok G \<Longrightarrow> F component_of (F \<squnion> G)"
by (unfold component_of_def, blast)

lemma component_of_Join2: "F ok G \<Longrightarrow> G component_of (F \<squnion> G)"
apply (subst Join_commute)
apply (blast intro: ok_sym component_of_Join1)
done

(*Remark at end of section 4.1 *)
lemma ex_prop_imp:
     "ex_prop(Y) \<Longrightarrow> (Y = (program guarantees Y))"
apply (simp (no_asm_use) add: ex_prop_equiv guar_def component_of_def)
apply clarify
apply (rule equalityI, blast, safe)
apply (drule_tac x = x in bspec, assumption, force)
done

lemma guarantees_imp: "(Y = program guarantees Y) \<Longrightarrow> ex_prop(Y)"
  unfolding guar_def
apply (simp (no_asm_simp) add: ex_prop_equiv)
apply safe
apply (blast intro: elim: equalityE)
apply (simp_all (no_asm_use) add: component_of_def)
apply (force elim: equalityE)+
done

lemma ex_prop_equiv2: "(ex_prop(Y)) \<longleftrightarrow> (Y = program guarantees Y)"
by (blast intro: ex_prop_imp guarantees_imp)

(** Distributive laws.  Re-orient to perform miniscoping **)

lemma guarantees_UN_left:
     "i \<in> I \<Longrightarrow>(\<Union>i \<in> I. X(i)) guarantees Y = (\<Inter>i \<in> I. X(i) guarantees Y)"
  unfolding guar_def
apply (rule equalityI, safe)
 prefer 2 apply force
apply blast+
done

lemma guarantees_Un_left:
     "(X \<union> Y) guarantees Z = (X guarantees Z) \<inter> (Y guarantees Z)"
  unfolding guar_def
apply (rule equalityI, safe, blast+)
done

lemma guarantees_INT_right:
     "i \<in> I \<Longrightarrow> X guarantees (\<Inter>i \<in> I. Y(i)) = (\<Inter>i \<in> I. X guarantees Y(i))"
  unfolding guar_def
apply (rule equalityI, safe, blast+)
done

lemma guarantees_Int_right:
     "Z guarantees (X \<inter> Y) = (Z guarantees X) \<inter> (Z guarantees Y)"
by (unfold guar_def, blast)

lemma guarantees_Int_right_I:
     "\<lbrakk>F \<in> Z guarantees X;  F \<in> Z guarantees Y\<rbrakk>
     \<Longrightarrow> F \<in> Z guarantees (X \<inter> Y)"
by (simp (no_asm_simp) add: guarantees_Int_right)

lemma guarantees_INT_right_iff:
     "i \<in> I\<Longrightarrow> (F \<in> X guarantees (\<Inter>i \<in> I. Y(i))) \<longleftrightarrow>
      (\<forall>i \<in> I. F \<in> X guarantees Y(i))"
by (simp add: guarantees_INT_right INT_iff, blast)

lemma shunting: "(X guarantees Y) = (program guarantees ((program-X) \<union> Y))"
by (unfold guar_def, auto)

lemma contrapositive:
     "(X guarantees Y) = (program - Y) guarantees (program -X)"
by (unfold guar_def, blast)

(** The following two can be expressed using intersection and subset, which
    is more faithful to the text but looks cryptic.
**)

lemma combining1:
    "\<lbrakk>F \<in> V guarantees X;  F \<in> (X \<inter> Y) guarantees Z\<rbrakk>
     \<Longrightarrow> F \<in> (V \<inter> Y) guarantees Z"
by (unfold guar_def, blast)

lemma combining2:
    "\<lbrakk>F \<in> V guarantees (X \<union> Y);  F \<in> Y guarantees Z\<rbrakk>
     \<Longrightarrow> F \<in> V guarantees (X \<union> Z)"
by (unfold guar_def, blast)

(** The following two follow Chandy-Sanders, but the use of object-quantifiers
    does not suit Isabelle... **)

(*Premise should be (\<And>i. i \<in> I \<Longrightarrow> F \<in> X guarantees Y i) *)
lemma all_guarantees:
     "\<lbrakk>\<forall>i \<in> I. F \<in> X guarantees Y(i); i \<in> I\<rbrakk>
    \<Longrightarrow> F \<in> X guarantees (\<Inter>i \<in> I. Y(i))"
by (unfold guar_def, blast)

(*Premises should be \<lbrakk>F \<in> X guarantees Y i; i \<in> I\<rbrakk> *)
lemma ex_guarantees:
     "\<exists>i \<in> I. F \<in> X guarantees Y(i) \<Longrightarrow> F \<in> X guarantees (\<Union>i \<in> I. Y(i))"
by (unfold guar_def, blast)

(*** Additional guarantees laws, by lcp ***)

lemma guarantees_Join_Int:
    "\<lbrakk>F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G\<rbrakk>
     \<Longrightarrow> F \<squnion> G: (U \<inter> X) guarantees (V \<inter> Y)"

  unfolding guar_def
apply (simp (no_asm))
apply safe
apply (simp add: Join_assoc)
apply (subgoal_tac "F \<squnion> G \<squnion> Ga = G \<squnion> (F \<squnion> Ga) ")
apply (simp add: ok_commute)
apply (simp (no_asm_simp) add: Join_ac)
done

lemma guarantees_Join_Un:
    "\<lbrakk>F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G\<rbrakk>
     \<Longrightarrow> F \<squnion> G: (U \<union> X) guarantees (V \<union> Y)"
  unfolding guar_def
apply (simp (no_asm))
apply safe
apply (simp add: Join_assoc)
apply (subgoal_tac "F \<squnion> G \<squnion> Ga = G \<squnion> (F \<squnion> Ga) ")
apply (rotate_tac 4)
apply (drule_tac x = "F \<squnion> Ga" in bspec)
apply (simp (no_asm))
apply (force simp add: ok_commute)
apply (simp (no_asm_simp) add: Join_ac)
done

lemma guarantees_JOIN_INT:
     "\<lbrakk>\<forall>i \<in> I. F(i) \<in> X(i) guarantees Y(i);  OK(I,F); i \<in> I\<rbrakk>
      \<Longrightarrow> (\<Squnion>i \<in> I. F(i)) \<in> (\<Inter>i \<in> I. X(i)) guarantees (\<Inter>i \<in> I. Y(i))"
apply (unfold guar_def, safe)
 prefer 2 apply blast
apply (drule_tac x = xa in bspec)
apply (simp_all add: INT_iff, safe)
apply (drule_tac x = "(\<Squnion>x \<in> (I-{xa}) . F (x)) \<squnion> G" and A=program in bspec)
apply (auto intro: OK_imp_ok simp add: Join_assoc [symmetric] JOIN_Join_diff JOIN_absorb)
done

lemma guarantees_JOIN_UN:
    "\<lbrakk>\<forall>i \<in> I. F(i) \<in> X(i) guarantees Y(i);  OK(I,F)\<rbrakk>
     \<Longrightarrow> JOIN(I,F) \<in> (\<Union>i \<in> I. X(i)) guarantees (\<Union>i \<in> I. Y(i))"
apply (unfold guar_def, auto)
apply (drule_tac x = y in bspec, simp_all, safe)
apply (rename_tac G y)
apply (drule_tac x = "JOIN (I-{y}, F) \<squnion> G" and A=program in bspec)
apply (auto intro: OK_imp_ok simp add: Join_assoc [symmetric] JOIN_Join_diff JOIN_absorb)
done

(*** guarantees laws for breaking down the program, by lcp ***)

lemma guarantees_Join_I1:
     "\<lbrakk>F \<in> X guarantees Y;  F ok G\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> X guarantees Y"
apply (simp add: guar_def, safe)
apply (simp add: Join_assoc)
done

lemma guarantees_Join_I2:
     "\<lbrakk>G \<in> X guarantees Y;  F ok G\<rbrakk> \<Longrightarrow> F \<squnion> G \<in> X guarantees Y"
apply (simp add: Join_commute [of _ G] ok_commute [of _ G])
apply (blast intro: guarantees_Join_I1)
done

lemma guarantees_JOIN_I:
     "\<lbrakk>i \<in> I; F(i) \<in>  X guarantees Y;  OK(I,F)\<rbrakk>
      \<Longrightarrow> (\<Squnion>i \<in> I. F(i)) \<in> X guarantees Y"
apply (unfold guar_def, safe)
apply (drule_tac x = "JOIN (I-{i},F) \<squnion> G" in bspec)
apply (simp (no_asm))
apply (auto intro: OK_imp_ok simp add: JOIN_Join_diff Join_assoc [symmetric])
done

(*** well-definedness ***)

lemma Join_welldef_D1: "F \<squnion> G \<in> welldef \<Longrightarrow> programify(F) \<in>  welldef"
by (unfold welldef_def, auto)

lemma Join_welldef_D2: "F \<squnion> G \<in> welldef \<Longrightarrow> programify(G) \<in>  welldef"
by (unfold welldef_def, auto)

(*** refinement ***)

lemma refines_refl: "F refines F wrt X"
by (unfold refines_def, blast)

(* More results on guarantees, added by Sidi Ehmety from Chandy \<and> Sander, section 6 *)

lemma wg_type: "wg(F, X) \<subseteq> program"
by (unfold wg_def, auto)

lemma guarantees_type: "X guarantees Y \<subseteq> program"
by (unfold guar_def, auto)

lemma wgD2: "G \<in> wg(F, X) \<Longrightarrow> G \<in> program \<and> F \<in> program"
apply (unfold wg_def, auto)
apply (blast dest: guarantees_type [THEN subsetD])
done

lemma guarantees_equiv:
"(F \<in> X guarantees Y) \<longleftrightarrow>
   F \<in> program \<and> (\<forall>H \<in> program. H \<in> X \<longrightarrow> (F component_of H \<longrightarrow> H \<in> Y))"
by (unfold guar_def component_of_def, force)

lemma wg_weakest:
     "\<And>X. \<lbrakk>F \<in> (X guarantees Y); X \<subseteq> program\<rbrakk> \<Longrightarrow> X \<subseteq> wg(F,Y)"
by (unfold wg_def, auto)

lemma wg_guarantees: "F \<in> program \<Longrightarrow> F \<in> wg(F,Y) guarantees Y"
by (unfold wg_def guar_def, blast)

lemma wg_equiv:
     "H \<in> wg(F,X) \<longleftrightarrow>
      ((F component_of H \<longrightarrow> H \<in> X) \<and> F \<in> program \<and> H \<in> program)"
apply (simp add: wg_def guarantees_equiv)
apply (rule iffI, safe)
apply (rule_tac [4] x = "{H}" in bexI)
apply (rule_tac [3] x = "{H}" in bexI, blast+)
done

lemma component_of_wg:
    "F component_of H \<Longrightarrow> H \<in> wg(F,X) \<longleftrightarrow> (H \<in> X \<and> F \<in> program \<and> H \<in> program)"
by (simp (no_asm_simp) add: wg_equiv)

lemma wg_finite [rule_format]:
"\<forall>FF \<in> Fin(program). FF \<inter> X \<noteq> 0 \<longrightarrow> OK(FF, \<lambda>F. F)
   \<longrightarrow> (\<forall>F \<in> FF. ((\<Squnion>F \<in> FF. F) \<in>  wg(F,X)) \<longleftrightarrow> ((\<Squnion>F \<in> FF. F) \<in> X))"
apply clarify
apply (subgoal_tac "F component_of (\<Squnion>F \<in> FF. F) ")
apply (drule_tac X = X in component_of_wg)
apply (force dest!: Fin.dom_subset [THEN subsetD, THEN PowD])
apply (simp_all add: component_of_def)
apply (rule_tac x = "\<Squnion>F \<in> (FF-{F}) . F" in exI)
apply (auto intro: JOIN_Join_diff dest: ok_sym simp add: OK_iff_ok)
done

lemma wg_ex_prop:
     "ex_prop(X) \<Longrightarrow> (F \<in> X) \<longleftrightarrow> (\<forall>H \<in> program. H \<in> wg(F,X) \<and> F \<in> program)"
apply (simp (no_asm_use) add: ex_prop_equiv wg_equiv)
apply blast
done

(** From Charpentier and Chandy "Theorems About Composition" **)
(* Proposition 2 *)
lemma wx_subset: "wx(X)\<subseteq>X"
by (unfold wx_def, auto)

lemma wx_ex_prop: "ex_prop(wx(X))"
apply (simp (no_asm_use) add: ex_prop_def wx_def)
apply safe
apply blast
apply (rule_tac x=x in bexI, force, simp)+
done

lemma wx_weakest: "\<forall>Z. Z\<subseteq>program \<longrightarrow> Z\<subseteq> X \<longrightarrow> ex_prop(Z) \<longrightarrow> Z \<subseteq> wx(X)"
by (unfold wx_def, auto)

(* Proposition 6 *)
lemma wx'_ex_prop:
 "ex_prop({F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<squnion> G \<in> X})"
apply (unfold ex_prop_def, safe)
 apply (drule_tac x = "G \<squnion> Ga" in bspec)
  apply (simp (no_asm))
 apply (force simp add: Join_assoc)
apply (drule_tac x = "F \<squnion> Ga" in bspec)
 apply (simp (no_asm))
apply (simp (no_asm_use))
apply safe
 apply (simp (no_asm_simp) add: ok_commute)
apply (subgoal_tac "F \<squnion> G = G \<squnion> F")
 apply (simp (no_asm_simp) add: Join_assoc)
apply (simp (no_asm) add: Join_commute)
done

(* Equivalence with the other definition of wx *)

lemma wx_equiv:
     "wx(X) = {F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> (F \<squnion> G) \<in> X}"
  unfolding wx_def
apply (rule equalityI, safe, blast)
 apply (simp (no_asm_use) add: ex_prop_def)
apply blast
apply (rule_tac B = "{F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<squnion> G \<in> X}"
         in UnionI,
       safe)
apply (rule_tac [2] wx'_ex_prop)
apply (drule_tac x=SKIP in bspec, simp)+
apply auto
done

(* Propositions 7 to 11 are all about this second definition of wx. And
   by equivalence between the two definition, they are the same as the ones proved *)

(* Proposition 12 *)
(* Main result of the paper *)
lemma guarantees_wx_eq: "(X guarantees Y) = wx((program-X) \<union> Y)"
by (auto simp add: guar_def wx_equiv)

(*
{* Corollary, but this result has already been proved elsewhere *}
 "ex_prop(X guarantees Y)"
*)

(* Rules given in section 7 of Chandy and Sander's
    Reasoning About Program composition paper *)

lemma stable_guarantees_Always:
     "\<lbrakk>Init(F) \<subseteq> A; F \<in> program\<rbrakk> \<Longrightarrow> F \<in> stable(A) guarantees Always(A)"
apply (rule guaranteesI)
 prefer 2 apply assumption
apply (simp (no_asm) add: Join_commute)
apply (rule stable_Join_Always1)
apply (simp_all add: invariant_def)
apply (auto simp add: programify_def initially_def)
done

lemma constrains_guarantees_leadsTo:
     "\<lbrakk>F \<in> transient(A); st_set(B)\<rbrakk>
      \<Longrightarrow> F: (A co A \<union> B) guarantees (A \<longmapsto> (B-A))"
apply (rule guaranteesI)
 prefer 2 apply (blast dest: transient_type [THEN subsetD])
apply (rule leadsTo_Basis')
  apply (blast intro: constrains_weaken_R)
 apply (blast intro!: Join_transient_I1, blast)
done

end


section \<open>Frame Inference\<close>
theory Frame_Infer
imports "Sep_Algebra_Add" Basic_VCG
begin

subsection \<open>Separation Algebra Specific Setup of VCG\<close>
lemmas [vcg_prep_ext_rules] = pure_part_split_conj

subsection \<open>Entails Connective\<close>
definition "entails" :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> _ \<Rightarrow> _" (infix "\<turnstile>" 25) where "P \<turnstile> Q \<equiv> \<forall>s. P s \<longrightarrow> Q s"
lemma entails_refl[intro!,simp]: "P \<turnstile> P" by (simp add: entails_def)

lemma entails_false[simp, intro!]: "sep_false \<turnstile> Q" by (simp add: entails_def)
lemma entails_true[simp, intro!]: "P \<turnstile> sep_true" by (simp add: entails_def)

lemma entails_trans[trans]: "P \<turnstile> Q \<Longrightarrow> Q \<turnstile> R \<Longrightarrow> P \<turnstile> R"
  by (simp add: entails_def)

lemma entails_mp: "\<lbrakk>Q \<turnstile> Q'; P \<turnstile> Q \<and>* F\<rbrakk> \<Longrightarrow> P \<turnstile> Q' \<and>* F"
  apply (clarsimp simp: entails_def)
  using sep_conj_impl1 by blast

lemma conj_entails_mono: "P\<turnstile>P' \<Longrightarrow> Q\<turnstile>Q' \<Longrightarrow> P**Q \<turnstile> P'**Q'"
  apply (clarsimp simp: entails_def)
  using sep_conj_impl by blast

lemma entails_exI: "P\<turnstile>Q x \<Longrightarrow> P\<turnstile>(EXS x. Q x)"
  by (metis (mono_tags, lifting) entails_def)

lemma entails_pureI: "\<lbrakk>pure_part P \<Longrightarrow> P\<turnstile>Q\<rbrakk> \<Longrightarrow> P\<turnstile>Q"
  by (auto simp: entails_def intro: pure_partI)

lemma entails_lift_extract_simps:
  "(\<up>\<Phi> \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> \<box> \<turnstile> Q)"
  "(\<up>\<Phi>**P \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> P \<turnstile> Q)"
  unfolding entails_def
  by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma entails_eq_iff: "A=B \<longleftrightarrow> (A\<turnstile>B) \<and> (B\<turnstile>A)"
  unfolding entails_def by (auto)

lemma entails_eqI: "\<lbrakk> A\<turnstile>B; B\<turnstile>A \<rbrakk> \<Longrightarrow> A=B" by (simp add: entails_eq_iff)

definition "is_sep_red P' Q' P Q \<longleftrightarrow> (\<forall>Ps Qs. (P'**Ps\<turnstile>Q'**Qs) \<longrightarrow> (P**Ps\<turnstile>Q**Qs))"

lemma is_sep_redI: "\<lbrakk>\<And>Ps Qs. P'**Ps\<turnstile>Q'**Qs \<Longrightarrow> P**Ps\<turnstile>Q**Qs \<rbrakk> \<Longrightarrow> is_sep_red P' Q' P Q"
  unfolding is_sep_red_def by blast

lemma is_sep_redD: "\<lbrakk>is_sep_red P' Q' P Q; P'**Ps\<turnstile>Q'**Qs\<rbrakk> \<Longrightarrow> P**Ps\<turnstile>Q**Qs"
  unfolding is_sep_red_def by blast

subsection \<open>Tags for Frame Inference\<close>
definition "FRI_END \<equiv> \<box>"
definition "FRAME_INFER P Qs F \<equiv> P \<turnstile> Qs ** F"
lemmas fri_prems_cong = arg_cong[where f="\<lambda>P. FRAME_INFER P _ _"]
lemma fri_prems_cong_meta: "P\<equiv>P' \<Longrightarrow> FRAME_INFER P Q F \<equiv> FRAME_INFER P' Q F" by simp

lemmas fri_concls_cong = arg_cong[where f="\<lambda>P. FRAME_INFER _ P _"]

lemma fri_prepare: "FRAME_INFER Ps (Qs**FRI_END) F \<Longrightarrow> FRAME_INFER Ps Qs F"
  by (auto simp: FRI_END_def)

lemma fri_prepare_round: "FRAME_INFER (\<box>**Ps) Qs F \<Longrightarrow> FRAME_INFER Ps Qs F"
  by simp

lemma fri_end: (* Potential premises get solved by entails_refl. *)
  "Ps \<turnstile> F \<Longrightarrow> FRAME_INFER Ps FRI_END F"
  by (auto simp: FRAME_INFER_def FRI_END_def)

lemma fri_step_rl:
  assumes "P \<turnstile> Q"  (* Gets instantiated with frame_infer_rules *)
  assumes "FRAME_INFER Ps Qs F"
  shows "FRAME_INFER (P**Ps) (Q**Qs) F"
  using assms
  unfolding FRAME_INFER_def
  by (simp add: conj_entails_mono)

lemma fri_reduce_rl:
  assumes "is_sep_red P' Q' P Q"
  assumes "FRAME_INFER (P'**Ps) (Q'**Qs) F"
  shows "FRAME_INFER (P**Ps) (Q**Qs) F"
  using assms unfolding FRAME_INFER_def
  by (auto dest: is_sep_redD)

subsection \<open>Configurable Rule Sets\<close>
(*named_theorems fri_prepare_simps*)

named_simpset fri_prepare_simps = HOL_basic_ss_nomatch
named_simpset fri_prepare_precond_simps = HOL_basic_ss_nomatch

named_theorems fri_rules
named_theorems fri_red_rules

lemma fri_empty_concl_simp: "(\<box> ** FRI_END) = FRI_END" by simp

lemmas [named_ss fri_prepare_simps] = sep_conj_assoc sep_conj_empty sep_conj_empty' sep_conj_exists
declare entails_refl[fri_rules]

lemma fri_move_sep_true_forward[named_ss fri_prepare_simps]:
  "(sep_true ** sep_true) = sep_true"
  "(sep_true ** (sep_true**A)) = (sep_true ** A)"
  "NO_MATCH sep_true A \<Longrightarrow> (A ** sep_true) = (sep_true ** A)"
  "NO_MATCH sep_true A \<Longrightarrow> (A ** (sep_true ** B)) = (sep_true ** (A**B))"
  by (auto simp: sep_algebra_simps sep_conj_ac)

lemma fri_prepare_sep_true_concl[named_ss fri_prepare_simps]:
  "FRAME_INFER Ps (sep_true ** Q) \<box> = FRAME_INFER Ps Q sep_true"
  by (auto simp: FRAME_INFER_def sep_algebra_simps sep_conj_ac)

lemma fri_exI: "FRAME_INFER Ps (Qs x) F \<Longrightarrow> FRAME_INFER Ps (EXS x. Qs x) F"
  by (auto simp: FRAME_INFER_def sep_algebra_simps intro: entails_exI)

lemma fri_trueI: "FRAME_INFER Ps Qs sep_true \<Longrightarrow> FRAME_INFER (sep_true ** Ps) Qs sep_true"
  apply (simp add: FRAME_INFER_def sep_algebra_simps)
  by (smt entails_mp entails_refl fri_move_sep_true_forward(2) sep.mult_commute)

lemma fri_pureI: "\<lbrakk>P \<Longrightarrow> FRAME_INFER A Q F\<rbrakk> \<Longrightarrow> FRAME_INFER (\<up>P ** A) Q F"
  by (cases P) (auto simp: FRAME_INFER_def sep_algebra_simps)

lemmas [named_ss fri_prepare_precond_simps] = pred_lift_extract_simps
lemmas [named_ss fri_prepare_precond_simps cong] = fri_prems_cong

subsection \<open>ML Code\<close>

ML \<open>

  structure Frame_Infer = struct
    open VCG_Lib

    (**** Utilities *)

    val simp_ai_tac = simp_only_tac @{thms sep_conj_assoc sep_conj_empty sep_conj_empty'}
    val simp_a_tac = simp_only_tac @{thms sep_conj_assoc}

    val rewrite_a_conv = rewrite_only_conv @{thms sep_conj_assoc}
    val rewrite_ai_conv = rewrite_only_conv @{thms sep_conj_assoc sep_conj_empty sep_conj_empty'}

    (**** Rotation Tactic *)

    local
      fun eq_rotate1_tac ctxt = CONVERSION (Refine_Util.HOL_concl_conv (
          fn ctxt => Conv.arg1_conv (
            Conv.rewr_conv @{thm sep_conj_commute[THEN eq_reflection]}
            then_conv Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms sep_conj_assoc})
          )) ctxt)

      fun eq_rotateN_tac ctxt n = WITH_concl (fn
        @{mpat "Trueprop (?lhs = _)"} => let
          val nc = length (SepConj.break_sep_conj lhs)
          val n = n mod nc

          fun tc 0 = K all_tac
            | tc n = eq_rotate1_tac ctxt THEN' tc (n-1)

        in tc n end
      | _ => K no_tac
      )

      (*
      fun eq_rotateN_tac _ 0 = K all_tac
        | eq_rotateN_tac ctxt n = eq_rotate1_tac ctxt THEN' eq_rotateN_tac ctxt (n-1)
      *)

    in
      (*
        Takes a congruence rule of the form a=b \<Longrightarrow> h a = h b,
        then expects a subgoal of the form h (a\<^sub>1**...**a\<^sub>n), and produces
        a sequence of new subgoals h (...) corresponding to all rotations of the a\<^sub>is.
      *)
      fun rotations_tac cong_rls ctxt = let
        val cong_rls = map_filter (try (fn thm => @{thm iffD2} OF [thm])) cong_rls
      in
        resolve_tac ctxt cong_rls
        THEN'
        WITH_concl (
          fn @{mpat \<open>Trueprop (?lhs = _)\<close>} => let
              val n = length (SepConj.break_sep_conj lhs)
              fun tac n = eq_rotateN_tac ctxt n
              val tacs = map tac (0 upto n-1)
            in
              APPEND_LIST' tacs
            end
          |  _ => K no_tac
        )
        THEN'
        resolve_tac ctxt @{thms refl}
      end

      fun rotate_tac cong_rls ctxt n = let
        val cong_rls = map_filter (try (fn thm => @{thm iffD2} OF [thm])) cong_rls
      in
        resolve_tac ctxt cong_rls
        THEN' eq_rotateN_tac ctxt n
        THEN' resolve_tac ctxt @{thms refl}
      end

    end

    (**** Frame Inference Tactic *)
    fun start_tac ctxt =
            asm_simp_named_tac ctxt @{named_simpset fri_prepare_simps}
      THEN' asm_simp_named_tac ctxt @{named_simpset fri_prepare_precond_simps}
      THEN' REPEAT' (resolve_tac ctxt @{thms fri_exI fri_trueI fri_pureI})
      THEN' resolve_tac ctxt @{thms fri_prepare}
      THEN' simp_only_tac @{thms sep_conj_assoc fri_empty_concl_simp} ctxt

    fun end_tac ctxt =
      simp_ai_tac ctxt
      THEN' resolve_tac ctxt @{thms fri_end}
      THEN' resolve_tac ctxt @{thms entails_refl entails_true}

    fun start_round_tac ctxt =
      simp_ai_tac ctxt
      THEN' resolve_tac ctxt @{thms fri_prepare_round}
      THEN' simp_a_tac ctxt

    fun solve_round_thms ctxt = let
      val thms1 = Named_Theorems.get ctxt @{named_theorems fri_rules}
        |> map (fn thm => @{thm fri_step_rl} OF [thm])

      val thms2 = Named_Theorems.get ctxt @{named_theorems fri_red_rules}
        |> map (fn thm => @{thm fri_reduce_rl} OF [thm])
    in thms1@thms2 end

    fun solve_round_tac ctxt = let
      val thms = solve_round_thms ctxt
    in
      Basic_VCG.step_precond_tac ctxt (resolve_tac ctxt thms)
    end

    fun round_tac_aux ctxt =
      start_round_tac ctxt
      THEN' rotations_tac @{thms fri_prems_cong} ctxt
      THEN' solve_round_tac ctxt

    fun round_tac ctxt =
      round_tac_aux ctxt
      ORELSE' (CHANGED o asm_full_simp_tac ctxt ORELSE' round_tac_aux ctxt)

    fun infer_tac ctxt = start_tac ctxt THEN' REPEAT' (end_tac ctxt ORELSE' round_tac ctxt)

    (**** Debugging Tactics *)
    fun dbg_solve_round_tac ctxt = let
      val thms = solve_round_thms ctxt
    in
      Basic_VCG.step_precond_tac ctxt (resolve_tac ctxt thms)
      ORELSE' resolve_tac ctxt thms
    end

    fun dbg_round_tac_aux ctxt =
      start_round_tac ctxt
      THEN' rotations_tac @{thms fri_prems_cong} ctxt
      THEN' dbg_solve_round_tac ctxt

    fun dbg_round_tac ctxt =
      dbg_round_tac_aux ctxt
      ORELSE' (CHANGED o asm_full_simp_tac ctxt ORELSE' dbg_round_tac_aux ctxt)

  end
\<close>

subsubsection \<open>Methods\<close>
definition "FRAME P Q F \<equiv> P \<turnstile> Q ** F"
definition "ENTAILS P Q \<equiv> P \<turnstile> Q"
lemma ENTAILSD: "ENTAILS P Q \<Longrightarrow> P \<turnstile> Q" by (simp add: ENTAILS_def)

lemma fri_startI:
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q F\<rbrakk> \<Longrightarrow> FRAME P Q F"
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q \<box>\<rbrakk> \<Longrightarrow> ENTAILS P Q"
  unfolding FRAME_INFER_def FRAME_def ENTAILS_def
  by (auto intro: entails_pureI)

lemma fri_startI_extended:
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q F\<rbrakk> \<Longrightarrow> FRAME P Q F"
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q \<box>\<rbrakk> \<Longrightarrow> ENTAILS P Q"
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q \<box>\<rbrakk> \<Longrightarrow> P \<turnstile> Q"
  unfolding FRAME_INFER_def FRAME_def ENTAILS_def
  by (auto intro: entails_pureI)

method_setup fri_rotations =
  \<open>(Attrib.thms >> (fn cong_rls => fn ctxt => SIMPLE_METHOD' (Frame_Infer.rotations_tac cong_rls ctxt )))\<close>
  \<open>Generate sequence of rotations wrt. specified congruence rule\<close>

method_setup fri_rotate =
  \<open>(Attrib.thms -- Scan.lift (Scan.optional (Parse.$$$ ":" |-- Parse.int) 1) >>
    (fn (cong_rls,n) => fn ctxt => SIMPLE_METHOD' (Frame_Infer.rotate_tac cong_rls ctxt n)))\<close>
  \<open>Rotate left n steps wrt. specified congruence rule\<close>

method_setup fri_keep_aux =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (Frame_Infer.infer_tac ctxt)))\<close>
  \<open>Frame Inference, solve from left to right, as far as possible\<close>

method fri_keep = (rule fri_startI_extended)?; fri_keep_aux

method fri = fri_keep;fail

method_setup fri_dbg_step =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (Frame_Infer.dbg_round_tac ctxt)))\<close>
  \<open>Frame Inference, one round, keep unsolved goals\<close>

method_setup fri_dbg_end =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (Frame_Infer.end_tac ctxt)))\<close>
  \<open>Frame Inference, end inference\<close>

subsubsection \<open>Solver Setup\<close>

declaration \<open>
  K (Basic_VCG.add_solver (@{thms fri_startI},@{binding infer_frame},Frame_Infer.infer_tac))
\<close>

method_setup fri_dbg_start =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (TRY o resolve_tac ctxt @{thms fri_startI_extended} THEN' Frame_Infer.start_tac ctxt)))\<close>
  \<open>Frame Inference, start\<close>

subsection \<open>Solving Pure Assertions\<close>

lemma fri_pure_rl[fri_rules]: "PRECOND (SOLVE_DEFAULT_AUTO \<Phi>) \<Longrightarrow> \<box>\<turnstile>\<up>\<Phi>"
  by (auto simp: sep_algebra_simps vcg_tag_defs)

abbreviation pred_lift_ASM ("\<up>\<^sub>a_" [100] 100) where "\<up>\<^sub>a\<Phi> \<equiv> \<up>SOLVE_ASM \<Phi>"
abbreviation pred_lift_AUTO_DEFER ("\<up>\<^sub>d_" [100] 100) where "\<up>\<^sub>d\<Phi> \<equiv> \<up>SOLVE_AUTO_DEFER \<Phi>"
abbreviation pred_lift_AUTO ("\<up>\<^sub>!_" [100] 100) where "\<up>\<^sub>!\<Phi> \<equiv> \<up>SOLVE_AUTO \<Phi>"

subsection \<open>Extraction\<close>

text \<open>A transformer that applies a configurable set of simplification rules
  only to certrain parts of the subgoal, as specified by a configurable set of
  congruence rules. Afterwards, VCG normalization is performed.

  The envisaged use of this transformer is to process the
  postcondition of a Hoare-triple when it is transformed to the current symbolic state,
  extracting all pure content.
\<close>

named_theorems fri_extract_congs \<open>Congruence rules for extraction\<close>
named_theorems fri_extract_simps \<open>Simplification rules for extraction\<close>

lemmas fri_basic_extract_simps = pred_lift_move_merge_simps sep_conj_exists

definition EXTRACT :: "bool \<Rightarrow> bool" where [vcg_tag_defs]: "EXTRACT x \<equiv> x"
lemma
  EXTRACTI: "x \<Longrightarrow> EXTRACT x" and
  EXTRACTD: "EXTRACT x \<Longrightarrow> x"
  by (auto simp: vcg_tag_defs)

ML \<open>
  structure Fri_Extract = struct
    (* TODO: Move *)
    (* Conversion wrt. congruence rule. The rule must have the form a\<equiv>b \<Longrightarrow> c\<equiv>d. *)
    fun cong_rl_conv (conv:conv) rule ct = let
      val rule = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule;
      val lhs = Thm.cprop_of rule |> Thm.dest_implies |> snd |> Thm.dest_equals_lhs;
      val rule = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule;
      val rule =
        Thm.instantiate (Thm.match (lhs, ct)) rule
          handle Pattern.MATCH => raise CTERM ("cong_rl_conv", [lhs, ct]);

      val lhs' = Thm.cprop_of rule |> Thm.dest_implies |> fst |> Thm.dest_equals_lhs;

    in rule OF [conv lhs'] end

    fun cong_rls_conv conv rules =
      Conv.first_conv (map (cong_rl_conv conv) rules)

    fun extract_basic_tac ctxt thms = let
      val ctxt = Named_Simpsets.put @{named_simpset Main_ss} ctxt addsimps @{thms fri_basic_extract_simps} addsimps thms
      val cong_thms = Named_Theorems.get ctxt @{named_theorems fri_extract_congs}
    in
      CONVERSION (Conv.top_sweep_conv (fn ctxt => cong_rls_conv (Simplifier.rewrite ctxt) cong_thms) ctxt)
    end

    fun extract_tac ctxt thms =
      extract_basic_tac ctxt (
          Named_Theorems.get ctxt @{named_theorems fri_extract_simps}
        @ Named_Theorems.get ctxt @{named_theorems vcg_tag_defs}
        @ thms
        )

  end

\<close>

declaration \<open>
  let
  in K (I
  #> Basic_VCG.add_xformer (@{thms EXTRACTI},@{binding extract_xformer}, fn ctxt =>
        Fri_Extract.extract_tac ctxt []
        THEN' Basic_VCG.vcg_normalize_tac ctxt
      )
  ) end
\<close>

method_setup fri_extract_basic = \<open>Scan.lift (Args.mode "no_norm") -- Attrib.thms
  >> (fn (no_norm,thms) => fn ctxt => SIMPLE_METHOD' (
    Fri_Extract.extract_basic_tac ctxt thms
    THEN' (if no_norm then K all_tac else Basic_VCG.vcg_normalize_tac ctxt)
  ))\<close>
  \<open>Extraction of pure content, only basic rules\<close>

method_setup fri_extract = \<open>Scan.lift (Args.mode "no_norm") -- Attrib.thms
  >> (fn (no_norm,thms) => fn ctxt => SIMPLE_METHOD' (
    Fri_Extract.extract_tac ctxt thms
    THEN' (if no_norm then K all_tac else Basic_VCG.vcg_normalize_tac ctxt)
  ))\<close>
  \<open>Extraction of pure content\<close>

subsection \<open>Basic Methods\<close>

lemma entails_pre_cong: "A=B \<Longrightarrow> (A\<turnstile>C) = (B\<turnstile>C)" by simp
lemma entails_post_cong: "B=C \<Longrightarrow> (A\<turnstile>B) = (A\<turnstile>C)" by simp

thm conj_entails_mono

lemma sep_drule:
  "A \<turnstile> B \<Longrightarrow> B \<turnstile> Q \<Longrightarrow> A \<turnstile> Q"
  "A \<turnstile> B \<Longrightarrow> B**F \<turnstile> Q \<Longrightarrow> A**F \<turnstile> Q"
  apply (rule entails_trans; assumption)
  using entails_mp entails_trans by blast

lemma sep_rule:
  "A \<turnstile> B \<Longrightarrow> P \<turnstile> A \<Longrightarrow> P \<turnstile> B"
  "A \<turnstile> B \<Longrightarrow> P \<turnstile> A**F \<Longrightarrow> P \<turnstile> B**F"
  apply (rule entails_trans; assumption)
  using entails_mp entails_trans by blast

(* TODO/FIXME: Frame inference does not work the right way round for backwards reasoning *)
lemma sep_rule':
  assumes "Q\<^sub>1 \<turnstile> Q\<^sub>1'"
  assumes "FRAME_INFER Q Q\<^sub>1' F" (* ? *)
  assumes "P \<turnstile> Q\<^sub>1 ** F"
  shows "P \<turnstile> Q"
  oops

lemma sep_drule':
  assumes "P\<^sub>1 \<turnstile> P\<^sub>1'"
  assumes "FRAME_INFER P P\<^sub>1 F"
  assumes "P\<^sub>1' ** F \<turnstile> Q"
  shows "P \<turnstile> Q"
  using assms
  apply (auto simp: FRAME_INFER_def entails_def)
  using sep_conj_impl by blast

thm entails_trans

method_setup sep_drule = \<open>Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD' (let
  val thms0 = map_filter (try (fn thm => @{thm entails_trans} OF [thm])) thms
  val thms = map_product (fn a => try (fn b => a OF [b])) @{thms sep_drule'} thms
    |> map_filter I
 in
    resolve_tac ctxt thms0
  ORELSE'
    resolve_tac ctxt thms
    THEN' SOLVED' (Frame_Infer.infer_tac ctxt)
 end))\<close>

method_setup sep_drule_simple = \<open>Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD' (let
  val thms = map_product (fn a => try (fn b => a OF [b])) @{thms sep_drule} thms
    |> map_filter I
 in
  Frame_Infer.rotations_tac @{thms entails_pre_cong} ctxt
  THEN' resolve_tac ctxt thms
  THEN' Frame_Infer.simp_a_tac ctxt
 end))\<close>

method_setup sep_rule = \<open>Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD' (let
  val thms = map_product (fn a => try (fn b => a OF [b])) @{thms sep_rule} thms
    |> map_filter I
 in
  Frame_Infer.rotations_tac @{thms entails_post_cong} ctxt
  THEN' resolve_tac ctxt thms
  THEN' Frame_Infer.simp_a_tac ctxt
 end))\<close>

subsection \<open>Utilities\<close>
  lemma fri_red_img_is: "PRECOND (SOLVE_AUTO (k\<in>I)) \<Longrightarrow> is_sep_red (\<Union>*i\<in>I-{k}. P i) \<box> (\<Union>*i\<in>I. P i) (P k)"
    unfolding vcg_tag_defs apply (rule is_sep_redI)
    by (auto simp: conj_entails_mono sep_set_img_remove)

  lemma fri_red_img_si: "PRECOND (SOLVE_AUTO (k\<in>I)) \<Longrightarrow> is_sep_red \<box> (\<Union>*i\<in>I-{k}. P i) (P k) (\<Union>*i\<in>I. P i)"
    unfolding vcg_tag_defs apply (rule is_sep_redI)
    by (smt conj_entails_mono entails_refl sep.add.left_neutral sep.mult.left_commute sep.mult_commute sep_set_img_remove)

  lemma fri_red_img_ss: "PRECOND (SOLVE_AUTO (I\<inter>I' \<noteq> {})) \<Longrightarrow> is_sep_red (\<Union>*i\<in>I-I'. P i) (\<Union>*i\<in>I'-I. P i) (\<Union>*i\<in>I. P i) (\<Union>*i\<in>I'. P i)"
    unfolding vcg_tag_defs apply (rule is_sep_redI)
  proof -
    fix Ps Qs
    assume "I \<inter> I' \<noteq> {}"
    and A: "(\<Union>*i\<in>I - I'. P i) \<and>* Ps \<turnstile> (\<Union>*i\<in>I' - I. P i) \<and>* Qs"

    have DJ: "(I-I') \<inter> (I\<inter>I') = {}" "(I'-I) \<inter> (I\<inter>I') = {}" by auto
    have II: "(I-I') \<union> (I\<inter>I') = I" "(I'-I) \<union> (I\<inter>I') = I'"  by auto

    show "(\<Union>*i\<in>I. P i) \<and>* Ps \<turnstile> (\<Union>*i\<in>I'. P i) \<and>* Qs"
      unfolding sep_set_img_union[OF DJ(1), simplified II]
      unfolding sep_set_img_union[OF DJ(2), simplified II]
      by (smt A conj_entails_mono entails_def semigroup.assoc sep.mult.semigroup_axioms sep.mult_commute)
  qed

  lemmas fri_red_img = fri_red_img_is fri_red_img_si fri_red_img_ss

end


(*  Title:      Jinja/Common/Type.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 Technische Universitaet Muenchen
*)

header {* \isaheader{Jinja types} *}

theory Type imports Auxiliary begin

type_synonym cname = string -- "class names"
type_synonym mname = string -- "method name"
type_synonym vname = string -- "names for local/field variables"

definition Object :: cname
where
  "Object \<equiv> ''Object''"

definition this :: vname
where
  "this \<equiv> ''this''"

-- "types"
datatype ty
  = Void          -- "type of statements"
  | Boolean
  | Integer
  | NT            -- "null type"
  | Class cname   -- "class type"

definition is_refT :: "ty \<Rightarrow> bool"
where
  "is_refT T  \<equiv>  T = NT \<or> (\<exists>C. T = Class C)"

lemma [iff]: "is_refT(Class C)"
(*<*)by(simp add:is_refT_def)(*>*)

lemma refTE:
  "\<lbrakk>is_refT T; T = NT \<Longrightarrow> P; \<And>C. T = Class C \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
(*<*)by (auto simp add: is_refT_def)(*>*)

lemma not_refTE:
  "\<lbrakk> \<not>is_refT T; T = Void \<or> T = Boolean \<or> T = Integer \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
(*<*)by (cases T, auto simp add: is_refT_def)(*>*)

end


section \<open>Dictionary Construction\<close>

theory Introduction
imports Main
begin

subsection \<open>Introduction\<close>

text \<open>
 Isabelle's logic features \emph{type classes}~\<^cite>\<open>"haftmann2007typeclasses" and "wenzel1997typeclasses"\<close>.
 These are built into the kernel and are used extensively in theory developments.
 The existing \emph{code generator}, when targeting Standard ML, performs the well-known dictionary
 construction or \emph{dictionary translation}~\<^cite>\<open>"haftmann2010codegeneration"\<close>.
 This works by replacing type classes with records, instances with values, and occurrences with
 explicit parameters.

 Haftmann and Nipkow give a pen-and-paper correctness proof of this construction
 \cite[\<open>\<section>\<close>4.1]{haftmann2010codegeneration}, based on a notion of \emph{higher-order rewrite
 systems.}
 The resulting theorem then states that any well-typed term is reduction-equivalent before and after
 class elimination.
 In this work, the dictionary construction is performed in a certified fashion, that is, the
 equivalence is a theorem inside the logic.
\<close>

subsection \<open>Encoding classes\<close>

text \<open>
  The choice of representation of a dictionary itself is straightforward: We model it as a
  @{command datatype}, along with functions returning values of that type. The alternative here
  would have been to use the @{command record} package. The obvious advantage is that we could
  easily model subclass relationships through record inheritance. However, records do not support
  multiple inheritance. Since records offer no advantage over datatypes in that regard, we opted for
  the more modern @{command datatype} package.
\<close>

text \<open>Consider the following example:\<close>

class plus =
  fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"

text \<open>
  This will get translated to a @{command datatype} with a single constructor taking a single
  argument:
\<close>

datatype 'a dict_plus =
  mk_plus (param_plus: "'a \<Rightarrow> 'a \<Rightarrow> 'a")

text \<open>A function using the @{class plus} constraint:\<close>

definition double :: "'a::plus \<Rightarrow> 'a" where
"double x = plus x x"

definition double' :: "'a dict_plus \<Rightarrow> 'a \<Rightarrow> 'a" where
"double' dict x = param_plus dict x x"

subsection \<open>Encoding instances\<close>

text \<open>
  A more controversial design decision is how to represent dictionary certificates. For example,
  given a value of type @{typ "nat dict_plus"}, how do we know that this is a faithful representation
  of the @{class plus} instance for @{typ nat}?
\<close>

text \<open>
  \<^item> Florian Haftmann proposed a ``shallow encoding''. It works by exploiting the internal treatment
    of constants with sort constraints in the Isabelle kernel. Constants themselves do not carry
    sort constraints, only their definitional equations. The fact that a constant only appears with
    these constraints on the surface of the system is a feature of type inference.

    Instead, we can instruct the system to ignore these constraints. However, any attempt at
    ``hiding'' the constraints behind a type definition ultimately does not work: The nonemptiness
    proof requires a witness of a valid dictionary for an arbitrary, but fixed type @{typ 'a}, which
    is of course not possible (see \<open>\<section>\<close>\ref{sec:impossibility} for details).

  \<^item> The certificates contain the class axioms directly. For example, the @{class semigroup_add}
    class requires @{term "(a + b) + c = a + (b + c)"}.

    Translated into a definition, this would look as follows:

    @{term
      "cert_plus dict \<longleftrightarrow>
        (\<forall>a b c. param_plus dict (param_plus dict a b) c = param_plus dict a (param_plus dict b c))"}

    Proving that instances satisfy this certificate is trivial.

    However, the equality proof of \<open>f'\<close> and \<open>f\<close> is impossible: they are simply not equal in general.
    Nothing would prevent someone from defining an alternative dictionary using multiplication
    instead of addition and the certificate would still hold; but obviously functions using
    @{const plus} on numbers would expect addition.

    Intuitively, this makes sense: the above notion of ``certificate'' establishes no connection
    between original instantiation and newly-generated dictionaries.

    Instead of proving equality, one would have to ``lift'' all existing theorems over the old
    constants to the new constants.

  \<^item> In order for equality between new and old constants to hold, the certificate needs to capture
    that the dictionary corresponds exactly to the class constants. This is achieved by the
    representation below.
    It literally states that the fields of the dictionary are equal to the class constants.
    The condition of the resulting equation can only be instantiated with dictionaries corresponding
    to existing class instances. This constitutes a \<^emph>\<open>closed world\<close> assumption, i.e., callers of
    generated code may not invent own instantiations.
\<close>

definition cert_plus :: "'a::plus dict_plus \<Rightarrow> bool" where
"cert_plus dict \<longleftrightarrow> (param_plus dict = plus)"

text \<open>
  Based on that definition, we can prove that @{const double} and @{const double'} are equivalent:
\<close>

lemma "cert_plus dict \<Longrightarrow> double' dict = double"
unfolding cert_plus_def double'_def double_def
by auto

text \<open>
  An unconditional equation can be obtained by specializing the theorem to a ground type and
  supplying a valid dictionary.
\<close>

subsection \<open>Implementation\<close>

text \<open>
  When translating a constant \<open>f\<close>, we use existing mechanisms in Isabelle to obtain its
  \<^emph>\<open>code graph\<close>. The graph contains the code equations of all transitive dependencies (i.e.,
  other constants) of \<open>f\<close>. In general, we have to re-define each of these dependencies. For that,
  we use the internal interface of the @{command function} package and feed it the code equations
  after performing the dictionary construction. In the standard case, where the user has not
  performed a custom code setup, the resulting function looks similar to its original definition.
  But the user may have also changed the implementation of a function significantly afterwards.
  This imposes some restrictions:

  \<^item> The new constant needs to be proven terminating. We apply some heuristics to transfer the
    original termination proof to the new definition. This only works when the termination condition
    does not rely on class axioms. (See \<open>\<section>\<close>\ref{sec:termination} for details.)
  \<^item> Pattern matching must be performed on datatypes, instead of the more general
    @{command code_datatype}s.
  \<^item> The set of code equations must be exhaustive and non-overlapping.
\<close>

end


theory Proof_5_26
  imports Proofs_5
begin

abbreviation s where "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value \<equiv>
(toEnv
   (setPstate
     (setVarBool
       (setVarBool (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) up'
         DOWN')
       down' DOWN')
     ERROR Ctrl'emergency))"

theorem proof_5_26: "VC26 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC26_def inv5_def R5_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
   apply((drule conjE)+)
                      prefer 31
                      apply assumption
                     prefer 30
                      apply assumption
                      prefer 29
                      apply assumption
                      prefer 28
                      apply assumption
                      prefer 27
                      apply assumption
                      prefer 26
                      apply assumption
                      prefer 25
                      apply assumption
                      prefer 24
                      apply assumption
                      prefer 23
                      apply assumption
                      prefer 22
                      apply assumption
                      prefer 21
                      apply assumption
                      prefer 20
                      apply assumption
                     prefer 19
                     apply assumption
                    prefer 18
                    apply assumption
                   prefer 17
                   apply assumption
                  prefer 16
                  apply assumption
                 prefer 15
                 apply assumption
                prefer 14
                apply assumption
               prefer 13
               apply assumption
              prefer 12
              apply assumption
             prefer 11
             apply assumption
            prefer 10
            apply assumption
           prefer 9
           apply assumption
          prefer 8
          apply assumption
         prefer 7
         apply assumption
        prefer 6
        apply assumption
       prefer 5
       apply assumption
      prefer 4
      apply assumption
     prefer 3
     apply assumption
    prefer 2
    apply assumption
  subgoal premises prems for s1 s2
    apply(rule disjE[OF le_imp_less_or_eq[OF prems(13)]])
    apply(rule cut_rl[of " \<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4  s0 \<and>
         toEnvNum s2 s4 \<le> ERROR \<and>
         getVarBool s4 up' = DOWN' \<and>
         getVarBool s4 down' = DOWN' \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 up' = UP' \<or> getVarBool s3 down' = UP')"])
      apply(drule exE)
       prefer 2
       apply assumption
    subgoal for s4
      apply(rule exI[of _ s4])
      by simp
    using prems(2) prems(4) prems(6) prems(8) prems(9) prems(11) prems(15) prems(16) apply -[1]
     apply(drule allE[of _ s1])
      prefer 2
      apply assumption
     apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply(simp split: if_splits)
    apply(rule cut_rl[of "\<forall> s5. toEnvP s5 \<and> substate s2 s5 \<and> substate s5
 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) \<longrightarrow>
 pred5 s1 s2
 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) s5"])
     apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply(drule impE)
       prefer 3
       apply assumption
    using prems(4,8) substate_refl apply fast
     apply(simp only: pred5_def)
     apply(drule impE)
       prefer 3
       apply assumption
    using prems(2)  prems(4) prems(6) prems(8) prems(9) prems(15) prems(16) substate_refl substate_trans substate_antisym
      apply blast
      apply blast
      apply(rule allI)
    subgoal premises toEnvNums2s for s5
      apply(induction rule: state_down_ind)
      using prems(8) apply simp
      apply(simp only: pred5_def)
       apply(rule impI)
       apply((drule conjE)+)
                 prefer 12
                  apply assumption
                 prefer 11
                 apply assumption
                prefer 10
                apply assumption
               prefer 9
               apply assumption
              prefer 8
              apply assumption
             prefer 7
             apply assumption
            prefer 6
            apply assumption
           prefer 5
           apply assumption
          prefer 4
          apply assumption
         prefer 3
         apply assumption
        prefer 2
        apply assumption

       apply(rule exI[of _ "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"])
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
      using substate_trans substate_antisym apply blast

      subgoal for s5
        apply(simp only: pred5_def)
        apply(rule impI)
        apply(cases "getVarBool (predEnv s5) up' = False  \<and> getVarBool (predEnv s5) down' = False")
       apply(rule exI[of _ "predEnv s5"])
       apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
        apply blast
       apply(rule conjI)
      using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) "]
        apply force
       apply(rule conjI)
        apply fast
       apply(rule conjI)
        apply fast
      using substate_antisym apply fast
      apply(drule impE)
        apply(((rule conjI),blast)+)
      using substate_eq_or_predEnv apply blast
      prefer 2
       apply assumption
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
       apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        apply((drule conjE)+)
                          prefer 20
                           apply assumption
                          prefer 19
                          apply assumption
                         prefer 18
                         apply assumption
                        prefer 17
                        apply assumption
                       prefer 16
                       apply assumption
                      prefer 15
                      apply assumption
                     prefer 14
                     apply assumption
                    prefer 13
                    apply assumption
                   prefer 12
                   apply assumption
                  prefer 11
                  apply assumption
                 prefer 10
                 apply assumption
                prefer 9
                apply assumption
               prefer 8
               apply assumption
              prefer 7
              apply assumption
             prefer 6
             apply assumption
            prefer 5
            apply assumption
           prefer 4
           apply assumption
          prefer 3
          apply assumption
         prefer 2
         apply assumption
        using predEnv_substate_imp_eq_or_substate by blast
      done
    done
  done


(*
    Title:      Code_Set.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section "Code set"

theory Code_Set
imports
  "HOL-Library.Code_Cardinality"
begin

text\<open>The following setup could help to get code generation for List.coset,
  but it neither works correctly it complains that code
  equations for remove are missed, even when List.coset should be rewritten
  to an enum:\<close>

declare minus_coset_filter [code del]
declare remove_code(2) [code del]
declare insert_code(2) [code del]
declare inter_coset_fold [code del]
declare compl_coset[code del]
declare Code_Cardinality.card'_code(2)[code del]

code_datatype set

text\<open>The following code equation could be useful to avoid the problem of
  code generation for List.coset []:\<close>

text\<open>Now the following examples work:\<close>

value "UNIV::bool set"
value "List.coset ([]::bool list)"
value "UNIV::Enum.finite_2 set"
value "List.coset ([]::Enum.finite_2 list)"
value "List.coset ([]::Enum.finite_5 list)"

end