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

section\<open>Weak Safety Properties\<close>

theory Constrains
imports UNITY
begin

consts traces :: "[i, i] \<Rightarrow> i"
  (* Initial states and program \<Rightarrow> (final state, reversed trace to it)...
      the domain may also be state*list(state) *)
inductive
  domains
     "traces(init, acts)" <=
         "(init \<union> (\<Union>act\<in>acts. field(act)))*list(\<Union>act\<in>acts. field(act))"
  intros
         (*Initial trace is empty*)
    Init: "s: init \<Longrightarrow> <s,[]> \<in> traces(init,acts)"

    Acts: "\<lbrakk>act:acts;  \<langle>s,evs\<rangle> \<in> traces(init,acts);  <s,s'>: act\<rbrakk>
           \<Longrightarrow> <s', Cons(s,evs)> \<in> traces(init, acts)"

  type_intros list.intros UnI1 UnI2 UN_I fieldI2 fieldI1

consts reachable :: "i\<Rightarrow>i"
inductive
  domains
  "reachable(F)" \<subseteq> "Init(F) \<union> (\<Union>act\<in>Acts(F). field(act))"
  intros
    Init: "s:Init(F) \<Longrightarrow> s:reachable(F)"

    Acts: "\<lbrakk>act: Acts(F);  s:reachable(F);  <s,s'>: act\<rbrakk>
           \<Longrightarrow> s':reachable(F)"

  type_intros UnI1 UnI2 fieldI2 UN_I

definition
  Constrains :: "[i,i] \<Rightarrow> i"  (infixl \<open>Co\<close> 60)  where
  "A Co B \<equiv> {F:program. F:(reachable(F) \<inter> A) co B}"

definition
  op_Unless  :: "[i, i] \<Rightarrow> i"  (infixl \<open>Unless\<close> 60)  where
  "A Unless B \<equiv> (A-B) Co (A \<union> B)"

definition
  Stable     :: "i \<Rightarrow> i"  where
  "Stable(A) \<equiv> A Co A"

definition
  (*Always is the weak form of "invariant"*)
  Always :: "i \<Rightarrow> i"  where
  "Always(A) \<equiv> initially(A) \<inter> Stable(A)"

(*** traces and reachable ***)

lemma reachable_type: "reachable(F) \<subseteq> state"
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in reachable.dom_subset, blast)
done

lemma st_set_reachable: "st_set(reachable(F))"
  unfolding st_set_def
apply (rule reachable_type)
done
declare st_set_reachable [iff]

lemma reachable_Int_state: "reachable(F) \<inter> state = reachable(F)"
by (cut_tac reachable_type, auto)
declare reachable_Int_state [iff]

lemma state_Int_reachable: "state \<inter> reachable(F) = reachable(F)"
by (cut_tac reachable_type, auto)
declare state_Int_reachable [iff]

lemma reachable_equiv_traces:
"F \<in> program \<Longrightarrow> reachable(F)={s \<in> state. \<exists>evs. \<langle>s,evs\<rangle>:traces(Init(F), Acts(F))}"
apply (rule equalityI, safe)
apply (blast dest: reachable_type [THEN subsetD])
apply (erule_tac [2] traces.induct)
apply (erule reachable.induct)
apply (blast intro: reachable.intros traces.intros)+
done

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

lemma stable_reachable: "\<lbrakk>F \<in> program; G \<in> program;
    Acts(G) \<subseteq> Acts(F)\<rbrakk> \<Longrightarrow> G \<in> stable(reachable(F))"
apply (blast intro: stableI constrainsI st_setI
             reachable_type [THEN subsetD] reachable.intros)
done

declare stable_reachable [intro!]
declare stable_reachable [simp]

(*The set of all reachable states is an invariant...*)
lemma invariant_reachable:
   "F \<in> program \<Longrightarrow> F \<in> invariant(reachable(F))"
  unfolding invariant_def initially_def
apply (blast intro: reachable_type [THEN subsetD] reachable.intros)
done

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

(*** Co ***)

lemma constrains_reachable_Int: "F \<in> B co B'\<Longrightarrow>F:(reachable(F) \<inter> B) co (reachable(F) \<inter> B')"
apply (frule constrains_type [THEN subsetD])
apply (frule stable_reachable [OF _ _ subset_refl])
apply (simp_all add: stable_def constrains_Int)
done

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

lemmas Constrains_def2 = Constrains_eq_constrains [THEN eq_reflection]

lemma constrains_imp_Constrains: "F \<in> A co A' \<Longrightarrow> F \<in> A Co A'"
  unfolding Constrains_def
apply (blast intro: constrains_weaken_L dest: constrainsD2)
done

lemma ConstrainsI:
    "\<lbrakk>\<And>act s s'. \<lbrakk>act \<in> Acts(F); <s,s'>:act; s \<in> A\<rbrakk> \<Longrightarrow> s':A';
       F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> A Co A'"
apply (auto simp add: Constrains_def constrains_def st_set_def)
apply (blast dest: reachable_type [THEN subsetD])
done

lemma Constrains_type:
 "A Co B \<subseteq> program"
apply (unfold Constrains_def, blast)
done

lemma Constrains_empty: "F \<in> 0 Co B \<longleftrightarrow> F \<in> program"
by (auto dest: Constrains_type [THEN subsetD]
            intro: constrains_imp_Constrains)
declare Constrains_empty [iff]

lemma Constrains_state: "F \<in> A Co state \<longleftrightarrow> F \<in> program"
  unfolding Constrains_def
apply (auto dest: Constrains_type [THEN subsetD] intro: constrains_imp_Constrains)
done
declare Constrains_state [iff]

lemma Constrains_weaken_R:
        "\<lbrakk>F \<in> A Co A'; A'<=B'\<rbrakk> \<Longrightarrow> F \<in> A Co B'"
  unfolding Constrains_def2
apply (blast intro: constrains_weaken_R)
done

lemma Constrains_weaken_L:
    "\<lbrakk>F \<in> A Co A'; B<=A\<rbrakk> \<Longrightarrow> F \<in> B Co A'"
  unfolding Constrains_def2
apply (blast intro: constrains_weaken_L st_set_subset)
done

lemma Constrains_weaken:
   "\<lbrakk>F \<in> A Co A'; B<=A; A'<=B'\<rbrakk> \<Longrightarrow> F \<in> B Co B'"
  unfolding Constrains_def2
apply (blast intro: constrains_weaken st_set_subset)
done

(** Union **)
lemma Constrains_Un:
    "\<lbrakk>F \<in> A Co A'; F \<in> B Co B'\<rbrakk> \<Longrightarrow> F \<in> (A \<union> B) Co (A' \<union> B')"
apply (unfold Constrains_def2, auto)
apply (simp add: Int_Un_distrib)
apply (blast intro: constrains_Un)
done

lemma Constrains_UN:
    "\<lbrakk>(\<And>i. i \<in> I\<Longrightarrow>F \<in> A(i) Co A'(i)); F \<in> program\<rbrakk>
     \<Longrightarrow> F:(\<Union>i \<in> I. A(i)) Co (\<Union>i \<in> I. A'(i))"
by (auto intro: constrains_UN simp del: UN_simps
         simp add: Constrains_def2 Int_UN_distrib)

(** Intersection **)

lemma Constrains_Int:
    "\<lbrakk>F \<in> A Co A'; F \<in> B Co B'\<rbrakk>\<Longrightarrow> F:(A \<inter> B) Co (A' \<inter> B')"
  unfolding Constrains_def
apply (subgoal_tac "reachable (F) \<inter> (A \<inter> B) = (reachable (F) \<inter> A) \<inter> (reachable (F) \<inter> B) ")
apply (auto intro: constrains_Int)
done

lemma Constrains_INT:
    "\<lbrakk>(\<And>i. i \<in> I \<Longrightarrow>F \<in> A(i) Co A'(i)); F \<in> program\<rbrakk>
     \<Longrightarrow> F:(\<Inter>i \<in> I. A(i)) Co (\<Inter>i \<in> I. A'(i))"
apply (simp (no_asm_simp) del: INT_simps add: Constrains_def INT_extend_simps)
apply (rule constrains_INT)
apply (auto simp add: Constrains_def)
done

lemma Constrains_imp_subset: "F \<in> A Co A' \<Longrightarrow> reachable(F) \<inter> A \<subseteq> A'"
  unfolding Constrains_def
apply (blast dest: constrains_imp_subset)
done

lemma Constrains_trans:
 "\<lbrakk>F \<in> A Co B; F \<in> B Co C\<rbrakk> \<Longrightarrow> F \<in> A Co C"
  unfolding Constrains_def2
apply (blast intro: constrains_trans constrains_weaken)
done

lemma Constrains_cancel:
"\<lbrakk>F \<in> A Co (A' \<union> B); F \<in> B Co B'\<rbrakk> \<Longrightarrow> F \<in> A Co (A' \<union> B')"
  unfolding Constrains_def2
apply (simp (no_asm_use) add: Int_Un_distrib)
apply (blast intro: constrains_cancel)
done

(*** Stable ***)
(* Useful because there's no Stable_weaken.  [Tanja Vos] *)

lemma stable_imp_Stable:
"F \<in> stable(A) \<Longrightarrow> F \<in> Stable(A)"

  unfolding stable_def Stable_def
apply (erule constrains_imp_Constrains)
done

lemma Stable_eq: "\<lbrakk>F \<in> Stable(A); A = B\<rbrakk> \<Longrightarrow> F \<in> Stable(B)"
by blast

lemma Stable_eq_stable:
"F \<in> Stable(A) \<longleftrightarrow>  (F \<in> stable(reachable(F) \<inter> A))"
apply (auto dest: constrainsD2 simp add: Stable_def stable_def Constrains_def2)
done

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

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

lemma Stable_Un:
    "\<lbrakk>F \<in> Stable(A); F \<in> Stable(A')\<rbrakk> \<Longrightarrow> F \<in> Stable(A \<union> A')"
  unfolding Stable_def
apply (blast intro: Constrains_Un)
done

lemma Stable_Int:
    "\<lbrakk>F \<in> Stable(A); F \<in> Stable(A')\<rbrakk> \<Longrightarrow> F \<in> Stable (A \<inter> A')"
  unfolding Stable_def
apply (blast intro: Constrains_Int)
done

lemma Stable_Constrains_Un:
    "\<lbrakk>F \<in> Stable(C); F \<in> A Co (C \<union> A')\<rbrakk>
     \<Longrightarrow> F \<in> (C \<union> A) Co (C \<union> A')"
  unfolding Stable_def
apply (blast intro: Constrains_Un [THEN Constrains_weaken_R])
done

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

lemma Stable_UN:
    "\<lbrakk>(\<And>i. i \<in> I \<Longrightarrow> F \<in> Stable(A(i))); F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> Stable (\<Union>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_UN)
done

lemma Stable_INT:
    "\<lbrakk>(\<And>i. i \<in> I \<Longrightarrow> F \<in> Stable(A(i))); F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> Stable (\<Inter>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_INT)
done

lemma Stable_reachable: "F \<in> program \<Longrightarrow>F \<in> Stable (reachable(F))"
apply (simp (no_asm_simp) add: Stable_eq_stable Int_absorb)
done

lemma Stable_type: "Stable(A) \<subseteq> program"
  unfolding Stable_def
apply (rule Constrains_type)
done

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

lemma Elimination:
    "\<lbrakk>\<forall>m \<in> M. F \<in> ({s \<in> A. x(s) = m}) Co (B(m)); F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> ({s \<in> A. x(s):M}) Co (\<Union>m \<in> M. B(m))"
apply (unfold Constrains_def, auto)
apply (rule_tac A1 = "reachable (F) \<inter> A"
        in UNITY.elimination [THEN constrains_weaken_L])
apply (auto intro: constrains_weaken_L)
done

(* As above, but for the special case of A=state *)
lemma Elimination2:
 "\<lbrakk>\<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} Co B(m); F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> {s \<in> state. x(s):M} Co (\<Union>m \<in> M. B(m))"
apply (blast intro: Elimination)
done

(** Unless **)

lemma Unless_type: "A Unless B <=program"
  unfolding op_Unless_def
apply (rule Constrains_type)
done

(*** Specialized laws for handling Always ***)

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

lemma AlwaysI:
"\<lbrakk>Init(F)<=A;  F \<in> Stable(A)\<rbrakk> \<Longrightarrow> F \<in> Always(A)"

  unfolding Always_def initially_def
apply (frule Stable_type [THEN subsetD], auto)
done

lemma AlwaysD: "F \<in> Always(A) \<Longrightarrow> Init(F)<=A \<and> F \<in> Stable(A)"
by (simp add: Always_def initially_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) \<Longrightarrow> reachable(F) \<subseteq> A"
apply (simp (no_asm_use) add: Stable_def Constrains_def constrains_def Always_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

lemma invariant_imp_Always:
     "F \<in> invariant(A) \<Longrightarrow> F \<in> Always(A)"
  unfolding 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 \<in> program. F \<in> invariant(reachable(F) \<inter> A)}"
apply (simp (no_asm) add: Always_def invariant_def Stable_def Constrains_def2 stable_def initially_def)
apply (rule equalityI, auto)
apply (blast intro: reachable.intros reachable_type)
done

(*the RHS is the traditional definition of the "always" operator*)
lemma Always_eq_includes_reachable: "Always(A) = {F \<in> program. reachable(F) \<subseteq> A}"
apply (rule equalityI, safe)
apply (auto dest: invariant_includes_reachable
   simp add: subset_Int_iff invariant_reachable Always_eq_invariant_reachable)
done

lemma Always_type: "Always(A) \<subseteq> program"
by (unfold Always_def initially_def, auto)

lemma Always_state_eq: "Always(state) = program"
apply (rule equalityI)
apply (auto dest: Always_type [THEN subsetD] reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)
done
declare Always_state_eq [simp]

lemma state_AlwaysI: "F \<in> program \<Longrightarrow> F \<in> Always(state)"
by (auto dest: reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)

lemma Always_eq_UN_invariant: "st_set(A) \<Longrightarrow> Always(A) = (\<Union>I \<in> Pow(A). invariant(I))"
apply (simp (no_asm) add: Always_eq_includes_reachable)
apply (rule equalityI, auto)
apply (blast intro: invariantI rev_subsetD [OF _ Init_into_reachable]
                    rev_subsetD [OF _ invariant_includes_reachable]
             dest: invariant_type [THEN subsetD])+
done

lemma Always_weaken: "\<lbrakk>F \<in> Always(A); A \<subseteq> B\<rbrakk> \<Longrightarrow> F \<in> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(*** "Co" rules involving Always ***)
lemmas Int_absorb2 = subset_Int_iff [unfolded iff_def, THEN conjunct1, THEN mp]

lemma Always_Constrains_pre: "F \<in> Always(I) \<Longrightarrow> (F:(I \<inter> A) Co A') \<longleftrightarrow> (F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_def Int_assoc [symmetric])
done

lemma Always_Constrains_post: "F \<in> Always(I) \<Longrightarrow> (F \<in> A Co (I \<inter> A')) \<longleftrightarrow>(F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_eq_constrains Int_assoc [symmetric])
done

lemma Always_ConstrainsI: "\<lbrakk>F \<in> Always(I);  F \<in> (I \<inter> A) Co A'\<rbrakk> \<Longrightarrow> F \<in> A Co A'"
by (blast intro: Always_Constrains_pre [THEN iffD1])

(* \<lbrakk>F \<in> Always(I);  F \<in> A Co A'\<rbrakk> \<Longrightarrow> F \<in> A Co (I \<inter> A') *)
lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]

(*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
lemma Always_Constrains_weaken:
"\<lbrakk>F \<in> Always(C); F \<in> A Co A'; C \<inter> B<=A; C \<inter> A'<=B'\<rbrakk>\<Longrightarrow>F \<in> B Co B'"
apply (rule Always_ConstrainsI)
apply (drule_tac [2] Always_ConstrainsD, simp_all)
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)

(* the premise i \<in> I is need since \<Inter>is formally not defined for I=0 *)
lemma Always_INT_distrib: "i \<in> I\<Longrightarrow>Always(\<Inter>i \<in> I. A(i)) = (\<Inter>i \<in> I. Always(A(i)))"
apply (rule equalityI)
apply (auto simp add: Inter_iff Always_eq_includes_reachable)
done

lemma Always_Int_I: "\<lbrakk>F \<in> Always(A);  F \<in> Always(B)\<rbrakk> \<Longrightarrow> F \<in> Always(A \<inter> B)"
apply (simp (no_asm_simp) add: Always_Int_distrib)
done

(*Allows a kind of "implication introduction"*)
lemma Always_Diff_Un_eq: "\<lbrakk>F \<in> Always(A)\<rbrakk> \<Longrightarrow> (F \<in> Always(C-A \<union> B)) \<longleftrightarrow> (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

(*To allow expansion of the program's definition when appropriate*)
named_theorems program "program definitions"

ML
\<open>
(*Combines two invariance ASSUMPTIONS into one.  USEFUL??*)
fun Always_Int_tac ctxt =
  dresolve_tac ctxt @{thms Always_Int_I} THEN'
  assume_tac ctxt THEN'
  eresolve_tac ctxt @{thms Always_thin};

(*Combines a list of invariance THEOREMS into one.*)
val Always_Int_rule = foldr1 (fn (th1,th2) => [th1,th2] MRS @{thm Always_Int_I});

(*proves "co" properties when the program is specified*)

fun constrains_tac ctxt =
   SELECT_GOAL
      (EVERY [REPEAT (Always_Int_tac ctxt 1),
              REPEAT (eresolve_tac ctxt @{thms Always_ConstrainsI} 1
                      ORELSE
                      resolve_tac ctxt [@{thm StableI}, @{thm stableI},
                                   @{thm constrains_imp_Constrains}] 1),
              resolve_tac ctxt @{thms constrainsI} 1,
              (* Three subgoals *)
              rewrite_goal_tac ctxt [@{thm st_set_def}] 3,
              REPEAT (force_tac ctxt 2),
              full_simp_tac (ctxt addsimps (Named_Theorems.get ctxt \<^named_theorems>\<open>program\<close>)) 1,
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (eresolve_tac ctxt @{thms disjE})),
              ALLGOALS (clarify_tac ctxt),
              ALLGOALS (asm_full_simp_tac ctxt),
              ALLGOALS (clarify_tac ctxt)]);

(*For proving invariants*)
fun always_tac ctxt i =
  resolve_tac ctxt @{thms AlwaysI} i THEN
  force_tac ctxt i
  THEN constrains_tac ctxt i;
\<close>

method_setup safety = \<open>
  Scan.succeed (SIMPLE_METHOD' o constrains_tac)\<close>
  "for proving safety properties"

method_setup always = \<open>
  Scan.succeed (SIMPLE_METHOD' o always_tac)\<close>
  "for proving invariants"

end


(*  Title:      HOL/Library/Code_Abstract_Char.thy
    Author:     Florian Haftmann, TU Muenchen
    Author:     René Thiemann, UIBK
*)

theory Code_Abstract_Char
  imports
    Main
    "HOL-Library.Char_ord"
begin

definition Chr :: \<open>integer \<Rightarrow> char\<close>
  where [simp]: \<open>Chr = char_of\<close>

lemma char_of_integer_of_char [code abstype]:
  \<open>Chr (integer_of_char c) = c\<close>
  by (simp add: integer_of_char_def)

lemma char_of_integer_code [code]:
  \<open>integer_of_char (char_of_integer k) = (if 0 \<le> k \<and> k < 256 then k else k mod 256)\<close>
  by (simp add: integer_of_char_def char_of_integer_def integer_eq_iff integer_less_eq_iff integer_less_iff)

lemma of_char_code [code]:
  \<open>of_char c = of_nat (nat_of_integer (integer_of_char c))\<close>
proof -
  have \<open>int_of_integer (of_char c) = of_char c\<close>
    by (cases c) simp
  then show ?thesis
    by (simp add: integer_of_char_def nat_of_integer_def of_nat_of_char)
qed

definition byte :: \<open>bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> integer\<close>
  where [simp]: \<open>byte b0 b1 b2 b3 b4 b5 b6 b7 = horner_sum of_bool 2 [b0, b1, b2, b3, b4, b5, b6, b7]\<close>

lemma byte_code [code]:
  \<open>byte b0 b1 b2 b3 b4 b5 b6 b7 = (
    let
      s0 = if b0 then 1 else 0;
      s1 = if b1 then s0 + 2 else s0;
      s2 = if b2 then s1 + 4 else s1;
      s3 = if b3 then s2 + 8 else s2;
      s4 = if b4 then s3 + 16 else s3;
      s5 = if b5 then s4 + 32 else s4;
      s6 = if b6 then s5 + 64 else s5;
      s7 = if b7 then s6 + 128 else s6
    in s7)\<close>
  by simp

lemma Char_code [code]:
  \<open>integer_of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) = byte b0 b1 b2 b3 b4 b5 b6 b7\<close>
  by (simp add: integer_of_char_def)

lemma digit_0_code [code]:
  \<open>digit0 c \<longleftrightarrow> bit (integer_of_char c) 0\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_1_code [code]:
  \<open>digit1 c \<longleftrightarrow> bit (integer_of_char c) 1\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_2_code [code]:
  \<open>digit2 c \<longleftrightarrow> bit (integer_of_char c) 2\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_3_code [code]:
  \<open>digit3 c \<longleftrightarrow> bit (integer_of_char c) 3\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_4_code [code]:
  \<open>digit4 c \<longleftrightarrow> bit (integer_of_char c) 4\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_5_code [code]:
  \<open>digit5 c \<longleftrightarrow> bit (integer_of_char c) 5\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_6_code [code]:
  \<open>digit6 c \<longleftrightarrow> bit (integer_of_char c) 6\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma digit_7_code [code]:
  \<open>digit7 c \<longleftrightarrow> bit (integer_of_char c) 7\<close>
  by (cases c) (simp add: integer_of_char_def)

lemma case_char_code [code]:
  \<open>case_char f c = f (digit0 c) (digit1 c) (digit2 c) (digit3 c) (digit4 c) (digit5 c) (digit6 c) (digit7 c)\<close>
  by (fact char.case_eq_if)

lemma rec_char_code [code]:
  \<open>rec_char f c = f (digit0 c) (digit1 c) (digit2 c) (digit3 c) (digit4 c) (digit5 c) (digit6 c) (digit7 c)\<close>
  by (cases c) simp

lemma char_of_code [code]:
  \<open>integer_of_char (char_of a) =
    byte (bit a 0) (bit a 1) (bit a 2) (bit a 3) (bit a 4) (bit a 5) (bit a 6) (bit a 7)\<close>
  by (simp add: char_of_def integer_of_char_def)

lemma ascii_of_code [code]:
  \<open>integer_of_char (String.ascii_of c) = (let k = integer_of_char c in if k < 128 then k else k - 128)\<close>
proof (cases \<open>of_char c < (128 :: integer)\<close>)
  case True
  moreover have \<open>(of_nat 0 :: integer) \<le> of_nat (of_char c)\<close>
    by simp
  then have \<open>(0 :: integer) \<le> of_char c\<close>
    by (simp only: of_nat_0 of_nat_of_char)
  ultimately show ?thesis
    by (simp add: Let_def integer_of_char_def take_bit_eq_mod integer_eq_iff integer_less_eq_iff integer_less_iff)
next
  case False
  then have \<open>(128 :: integer) \<le> of_char c\<close>
    by simp
  moreover have \<open>of_nat (of_char c) < (of_nat 256 :: integer)\<close>
    by (simp only: of_nat_less_iff) simp
  then have \<open>of_char c < (256 :: integer)\<close>
    by (simp add: of_nat_of_char)
  moreover define k :: integer where \<open>k = of_char c - 128\<close>
  then have \<open>of_char c = k + 128\<close>
    by simp
  ultimately show ?thesis
    by (simp add: Let_def integer_of_char_def take_bit_eq_mod integer_eq_iff integer_less_eq_iff integer_less_iff)
qed

lemma equal_char_code [code]:
  \<open>HOL.equal c d \<longleftrightarrow> integer_of_char c = integer_of_char d\<close>
  by (simp add: integer_of_char_def equal)

lemma less_eq_char_code [code]:
  \<open>c \<le> d \<longleftrightarrow> integer_of_char c \<le> integer_of_char d\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof -
  have \<open>?P \<longleftrightarrow> of_nat (of_char c) \<le> (of_nat (of_char d) :: integer)\<close>
    by (simp add: less_eq_char_def)
  also have \<open>\<dots> \<longleftrightarrow> ?Q\<close>
    by (simp add: of_nat_of_char integer_of_char_def)
  finally show ?thesis .
qed

lemma less_char_code [code]:
  \<open>c < d \<longleftrightarrow> integer_of_char c < integer_of_char d\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof -
  have \<open>?P \<longleftrightarrow> of_nat (of_char c) < (of_nat (of_char d) :: integer)\<close>
    by (simp add: less_char_def)
  also have \<open>\<dots> \<longleftrightarrow> ?Q\<close>
    by (simp add: of_nat_of_char integer_of_char_def)
  finally show ?thesis .
qed

lemma absdef_simps:
  \<open>horner_sum of_bool 2 [] = (0 :: integer)\<close>
  \<open>horner_sum of_bool 2 (False # bs) = (0 :: integer) \<longleftrightarrow> horner_sum of_bool 2 bs = (0 :: integer)\<close>
  \<open>horner_sum of_bool 2 (True # bs) = (1 :: integer) \<longleftrightarrow> horner_sum of_bool 2 bs = (0 :: integer)\<close>
  \<open>horner_sum of_bool 2 (False # bs) = (numeral (Num.Bit0 n) :: integer) \<longleftrightarrow> horner_sum of_bool 2 bs = (numeral n :: integer)\<close>
  \<open>horner_sum of_bool 2 (True # bs) = (numeral (Num.Bit1 n) :: integer) \<longleftrightarrow> horner_sum of_bool 2 bs = (numeral n :: integer)\<close>
  by auto (auto simp only: numeral_Bit0 [of n] numeral_Bit1 [of n] mult_2 [symmetric] add.commute [of _ 1] add.left_cancel mult_cancel_left)

local_setup \<open>
  let
    val simps = @{thms absdef_simps integer_of_char_def of_char_Char numeral_One}
    fun prove_eqn lthy n lhs def_eqn =
      let
        val eqn = (HOLogic.mk_Trueprop o HOLogic.mk_eq)
          (\<^term>\<open>integer_of_char\<close> $ lhs, HOLogic.mk_number \<^typ>\<open>integer\<close> n)
      in
        Goal.prove_future lthy [] [] eqn (fn {context = ctxt, ...} =>
          unfold_tac ctxt (def_eqn :: simps))
      end
    fun define n =
      let
        val s = "Char_" ^ String_Syntax.hex n;
        val b = Binding.name s;
        val b_def = Thm.def_binding b;
        val b_code = Binding.name (s ^ "_code");
      in
        Local_Theory.define ((b, Mixfix.NoSyn),
          ((Binding.empty, []), HOLogic.mk_char n))
        #-> (fn (lhs, (_, raw_def_eqn)) =>
          Local_Theory.note ((b_def, @{attributes [code_abbrev]}), [HOLogic.mk_obj_eq raw_def_eqn])
          #-> (fn (_, [def_eqn]) => `(fn lthy => prove_eqn lthy n lhs def_eqn))
          #-> (fn raw_code_eqn => Local_Theory.note ((b_code, []), [raw_code_eqn]))
          #-> (fn (_, [code_eqn]) => Code.declare_abstract_eqn code_eqn))
      end
  in
    fold define (0 upto 255)
  end
\<close>

code_identifier
  code_module Code_Abstract_Char \<rightharpoonup>
    (SML) Str and (OCaml) Str and (Haskell) Str and (Scala) Str

end


(* Author: Tobias Nipkow *)

subsection "Backward Analysis of Expressions"

theory Abs_Int2
imports Abs_Int1
begin

instantiation prod :: (order,order) order
begin

definition "less_eq_prod p1 p2 = (fst p1 \<le> fst p2 \<and> snd p1 \<le> snd p2)"
definition "less_prod p1 p2 = (p1 \<le> p2 \<and> \<not> p2 \<le> (p1::'a*'b))"

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_prod_def)
next
  case 2 show ?case by(simp add: less_eq_prod_def)
next
  case 3 thus ?case unfolding less_eq_prod_def by(metis order_trans)
next
  case 4 thus ?case by(simp add: less_eq_prod_def)(metis eq_iff surjective_pairing)
qed

end

subsubsection "Extended Framework"

subclass (in bounded_lattice) semilattice_sup_top ..

locale Val_lattice_gamma = Gamma_semilattice where \<gamma> = \<gamma>
  for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set" +
assumes inter_gamma_subset_gamma_inf:
  "\<gamma> a1 \<inter> \<gamma> a2 \<subseteq> \<gamma>(a1 \<sqinter> a2)"
and gamma_bot[simp]: "\<gamma> \<bottom> = {}"
begin

lemma in_gamma_inf: "x \<in> \<gamma> a1 \<Longrightarrow> x \<in> \<gamma> a2 \<Longrightarrow> x \<in> \<gamma>(a1 \<sqinter> a2)"
by (metis IntI inter_gamma_subset_gamma_inf subsetD)

lemma gamma_inf: "\<gamma>(a1 \<sqinter> a2) = \<gamma> a1 \<inter> \<gamma> a2"
by(rule equalityI[OF _ inter_gamma_subset_gamma_inf])
  (metis inf_le1 inf_le2 le_inf_iff mono_gamma)

end

locale Val_inv = Val_lattice_gamma where \<gamma> = \<gamma>
   for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set" +
fixes test_num' :: "val \<Rightarrow> 'av \<Rightarrow> bool"
and inv_plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av \<Rightarrow> 'av * 'av"
and inv_less' :: "bool \<Rightarrow> 'av \<Rightarrow> 'av \<Rightarrow> 'av * 'av"
assumes test_num': "test_num' i a = (i \<in> \<gamma> a)"
and inv_plus': "inv_plus' a a1 a2 = (a\<^sub>1',a\<^sub>2') \<Longrightarrow>
  i1 \<in> \<gamma> a1 \<Longrightarrow> i2 \<in> \<gamma> a2 \<Longrightarrow> i1+i2 \<in> \<gamma> a \<Longrightarrow> i1 \<in> \<gamma> a\<^sub>1' \<and> i2 \<in> \<gamma> a\<^sub>2'"
and inv_less': "inv_less' (i1<i2) a1 a2 = (a\<^sub>1',a\<^sub>2') \<Longrightarrow>
  i1 \<in> \<gamma> a1 \<Longrightarrow> i2 \<in> \<gamma> a2 \<Longrightarrow> i1 \<in> \<gamma> a\<^sub>1' \<and> i2 \<in> \<gamma> a\<^sub>2'"

locale Abs_Int_inv = Val_inv where \<gamma> = \<gamma>
  for \<gamma> :: "'av::bounded_lattice \<Rightarrow> val set"
begin

lemma in_gamma_sup_UpI:
  "s \<in> \<gamma>\<^sub>o S1 \<or> s \<in> \<gamma>\<^sub>o S2 \<Longrightarrow> s \<in> \<gamma>\<^sub>o(S1 \<squnion> S2)"
by (metis (opaque_lifting, no_types) sup_ge1 sup_ge2 mono_gamma_o subsetD)

fun aval'' :: "aexp \<Rightarrow> 'av st option \<Rightarrow> 'av" where
"aval'' e None = \<bottom>" |
"aval'' e (Some S) = aval' e S"

lemma aval''_correct: "s \<in> \<gamma>\<^sub>o S \<Longrightarrow> aval a s \<in> \<gamma>(aval'' a S)"
by(cases S)(auto simp add: aval'_correct split: option.splits)

subsubsection "Backward analysis"

fun inv_aval' :: "aexp \<Rightarrow> 'av \<Rightarrow> 'av st option \<Rightarrow> 'av st option" where
"inv_aval' (N n) a S = (if test_num' n a then S else None)" |
"inv_aval' (V x) a S = (case S of None \<Rightarrow> None | Some S \<Rightarrow>
  let a' = fun S x \<sqinter> a in
  if a' = \<bottom> then None else Some(update S x a'))" |
"inv_aval' (Plus e1 e2) a S =
 (let (a1,a2) = inv_plus' a (aval'' e1 S) (aval'' e2 S)
  in inv_aval' e1 a1 (inv_aval' e2 a2 S))"

text\<open>The test for \<^const>\<open>bot\<close> in the \<^const>\<open>V\<close>-case is important: \<^const>\<open>bot\<close> indicates that a variable has no possible values, i.e.\ that the current
program point is unreachable. But then the abstract state should collapse to
\<^const>\<open>None\<close>. Put differently, we maintain the invariant that in an abstract
state of the form \<^term>\<open>Some s\<close>, all variables are mapped to non-\<^const>\<open>bot\<close> values. Otherwise the (pointwise) sup of two abstract states, one of
which contains \<^const>\<open>bot\<close> values, may produce too large a result, thus
making the analysis less precise.\<close>

fun inv_bval' :: "bexp \<Rightarrow> bool \<Rightarrow> 'av st option \<Rightarrow> 'av st option" where
"inv_bval' (Bc v) res S = (if v=res then S else None)" |
"inv_bval' (Not b) res S = inv_bval' b (\<not> res) S" |
"inv_bval' (And b1 b2) res S =
  (if res then inv_bval' b1 True (inv_bval' b2 True S)
   else inv_bval' b1 False S \<squnion> inv_bval' b2 False S)" |
"inv_bval' (Less e1 e2) res S =
  (let (a1,a2) = inv_less' res (aval'' e1 S) (aval'' e2 S)
   in inv_aval' e1 a1 (inv_aval' e2 a2 S))"

lemma inv_aval'_correct: "s \<in> \<gamma>\<^sub>o S \<Longrightarrow> aval e s \<in> \<gamma> a \<Longrightarrow> s \<in> \<gamma>\<^sub>o (inv_aval' e a S)"
proof(induction e arbitrary: a S)
  case N thus ?case by simp (metis test_num')
next
  case (V x)
  obtain S' where "S = Some S'" and "s \<in> \<gamma>\<^sub>s S'" using \<open>s \<in> \<gamma>\<^sub>o S\<close>
    by(auto simp: in_gamma_option_iff)
  moreover hence "s x \<in> \<gamma> (fun S' x)"
    by(simp add: \<gamma>_st_def)
  moreover have "s x \<in> \<gamma> a" using V(2) by simp
  ultimately show ?case
    by(simp add: Let_def \<gamma>_st_def)
      (metis mono_gamma emptyE in_gamma_inf gamma_bot subset_empty)
next
  case (Plus e1 e2) thus ?case
    using inv_plus'[OF _ aval''_correct aval''_correct]
    by (auto split: prod.split)
qed

lemma inv_bval'_correct: "s \<in> \<gamma>\<^sub>o S \<Longrightarrow> bv = bval b s \<Longrightarrow> s \<in> \<gamma>\<^sub>o(inv_bval' b bv S)"
proof(induction b arbitrary: S bv)
  case Bc thus ?case by simp
next
  case (Not b) thus ?case by simp
next
  case (And b1 b2) thus ?case
    by simp (metis And(1) And(2) in_gamma_sup_UpI)
next
  case (Less e1 e2) thus ?case
    apply hypsubst_thin
    apply (auto split: prod.split)
    apply (metis (lifting) inv_aval'_correct aval''_correct inv_less')
    done
qed

definition "step' = Step
  (\<lambda>x e S. case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S)))
  (\<lambda>b S. inv_bval' b True S)"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI c = pfp (step' \<top>) (bot c)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(simp add: step'_def)

lemma top_on_inv_aval': "\<lbrakk> top_on_opt S X;  vars e \<subseteq> -X \<rbrakk> \<Longrightarrow> top_on_opt (inv_aval' e a S) X"
by(induction e arbitrary: a S) (auto simp: Let_def split: option.splits prod.split)

lemma top_on_inv_bval': "\<lbrakk>top_on_opt S X; vars b \<subseteq> -X\<rbrakk> \<Longrightarrow> top_on_opt (inv_bval' b r S) X"
by(induction b arbitrary: r S) (auto simp: top_on_inv_aval' top_on_sup split: prod.split)

lemma top_on_step': "top_on_acom C (- vars C) \<Longrightarrow> top_on_acom (step' \<top> C) (- vars C)"
unfolding step'_def
by(rule top_on_Step)
  (auto simp add: top_on_top top_on_inv_bval' split: option.split)

subsubsection "Correctness"

lemma step_step': "step (\<gamma>\<^sub>o S) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' S C)"
unfolding step_def step'_def
by(rule gamma_Step_subcomm)
  (auto simp: intro!: aval'_correct inv_bval'_correct in_gamma_update split: option.splits)

lemma AI_correct: "AI c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_def)
  assume 1: "pfp (step' \<top>) (bot c) = Some C"
  have pfp': "step' \<top> C \<le> C" by(rule pfp_pfp[OF 1])
  have 2: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"  \<comment> \<open>transfer the pfp'\<close>
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c (step' \<top> C)" by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C" by (metis mono_gamma_c[OF pfp'])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp[OF _ 1] step'_def)
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 2])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

subsubsection "Monotonicity"

locale Abs_Int_inv_mono = Abs_Int_inv +
assumes mono_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> plus' a1 a2 \<le> plus' b1 b2"
and mono_inv_plus': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow> r \<le> r' \<Longrightarrow>
  inv_plus' r a1 a2 \<le> inv_plus' r' b1 b2"
and mono_inv_less': "a1 \<le> b1 \<Longrightarrow> a2 \<le> b2 \<Longrightarrow>
  inv_less' bv a1 a2 \<le> inv_less' bv b1 b2"
begin

lemma mono_aval':
  "S1 \<le> S2 \<Longrightarrow> aval' e S1 \<le> aval' e S2"
by(induction e) (auto simp: mono_plus' mono_fun)

lemma mono_aval'':
  "S1 \<le> S2 \<Longrightarrow> aval'' e S1 \<le> aval'' e S2"
apply(cases S1)
 apply simp
apply(cases S2)
 apply simp
by (simp add: mono_aval')

lemma mono_inv_aval': "r1 \<le> r2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> inv_aval' e r1 S1 \<le> inv_aval' e r2 S2"
apply(induction e arbitrary: r1 r2 S1 S2)
   apply(auto simp: test_num' Let_def inf_mono split: option.splits prod.splits)
   apply (metis mono_gamma subsetD)
  apply (metis le_bot inf_mono le_st_iff)
 apply (metis inf_mono mono_update le_st_iff)
apply(metis mono_aval'' mono_inv_plus'[simplified less_eq_prod_def] fst_conv snd_conv)
done

lemma mono_inv_bval': "S1 \<le> S2 \<Longrightarrow> inv_bval' b bv S1 \<le> inv_bval' b bv S2"
apply(induction b arbitrary: bv S1 S2)
   apply(simp)
  apply(simp)
 apply simp
 apply(metis order_trans[OF _ sup_ge1] order_trans[OF _ sup_ge2])
apply (simp split: prod.splits)
apply(metis mono_aval'' mono_inv_aval' mono_inv_less'[simplified less_eq_prod_def] fst_conv snd_conv)
done

theorem mono_step': "S1 \<le> S2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> step' S1 C1 \<le> step' S2 C2"
unfolding step'_def
by(rule mono2_Step) (auto simp: mono_aval' mono_inv_bval' split: option.split)

lemma mono_step'_top: "C1 \<le> C2 \<Longrightarrow> step' \<top> C1 \<le> step' \<top> C2"
by (metis mono_step' order_refl)

end

end


(* simple_bisim.thy *)
(* William Mansky *)
(* Proof of correctness for reordering by bisimulation. *)

theory simple_bisim
imports simple_opt "AFP/JinjaThreads/Framework/Bisimulation"
begin

definition trsys_of_tCFG where
"trsys_of_tCFG CFGs step_rel obs C l C' \<equiv> step_rel CFGs C C' \<and> dom l = obs \<and>
 (\<forall>x\<in>obs. fst C' x = update_map (fst C) l x)"

locale tCFG_bisim = bisimulation where trsys1 = "trsys_of_tCFG CFGs step_rel obs"
 and trsys2 = "trsys_of_tCFG CFGs' step_rel obs" for CFGs CFGs' step_rel obs
(* Prove: if bisim, then bisim for any subset of obs *)

definition "reorder_bisim_rel CFGs CFGs' t n2 x1 e1 x2 e2 C C' \<equiv>
 snd C = snd C' \<and> reorder_sim_rel t n2 x1 e1 x2 e2 (snd C) (fst C') (fst C) \<and>
 TRANS_simple.reachable CFGs C \<and> TRANS_simple.reachable CFGs' C'"

context TRANS_simple begin

lemma reorder_bisim: "\<lbrakk>Some CFGs' = action_list_sf reorder_actions \<sigma> CFGs; part_matches \<sigma> \<tau>;
 side_cond_sf reorder_sc \<sigma> CFGs; \<sigma> ''t'' = OThread t; \<sigma> ''n2'' = ONode n2; \<sigma> ''x1'' = OExpr (Var x1);
 \<sigma> ''e1'' = OExpr e1; \<sigma> ''x2'' = OExpr (Var x2); \<sigma> ''e2'' = OExpr e2\<rbrakk> \<Longrightarrow>
 tCFG_bisim (reorder_bisim_rel CFGs CFGs' t n2 x1 e1 x2 e2) (op =) CFGs CFGs' step (UNIV - {x1, x2})"
apply (subgoal_tac "CFGs' \<in> trans_sf reorder \<tau> CFGs")
apply (subgoal_tac "TRANS_simple CFGs'")
defer
apply (simp add: TRANS_simple_def TRANS_basics_def)
apply (erule reorder_preserves_tCFGs)
apply (simp add: reorder_def, force)
apply unfold_locales
apply (clarsimp simp add: trsys_of_tCFG_def reorder_bisim_rel_def)
apply (frule reorder_simulates_step2, simp_all, clarsimp)
apply (rule_tac x=env' in exI, simp)
apply (frule reachable_step, simp+)
apply (frule TRANS_simple.reachable_step, simp+, clarsimp)
apply ((erule step.cases)+, clarsimp)
apply (clarsimp simp add: reorder_sim_rel_def)
apply (rule ccontr, erule_tac x=x in ballE, simp_all)
apply (clarsimp split: if_splits)
apply ((erule_tac x=x in allE)+, clarsimp)+
apply (clarsimp simp add: trsys_of_tCFG_def reorder_bisim_rel_def)
apply (frule reorder_simulates_step1, simp_all, clarsimp)
apply (rule_tac x=env' in exI, simp)
apply (frule reachable_step, simp+)
apply (frule TRANS_simple.reachable_step, simp+, clarsimp)
apply ((erule step.cases)+, clarsimp)
apply (clarsimp simp add: reorder_sim_rel_def)
apply (rule ccontr, erule_tac x=x in ballE, simp_all)
apply (clarsimp split: if_splits)
apply ((erule_tac x=x in allE)+, clarsimp)
apply (drule_tac s="update_map env change_map x" in sym, simp)
apply (drule_tac ?m1.0=tl2 and m'=enva in update_same_x, simp+)
apply ((erule_tac x=x in allE)+, clarsimp)+
done

(* By lemmas in bisimulation, this implies that for each (possibly infinite) run in the original
   program, there exists an observationally equivalent run in the new system and vice versa. *)

end

end


(* D. Fuenmayor and A. Steen, August 2021 *)
(* This file contains the verification of meta-theoretical connections of extension-based semanticss.
   Auxiliary references:
 [BCG 2011] Baroni, P., M. Caminada and M. Giacomin, An introduction to argumentation semantics,
            Knowledge Engineering Review (2011)
*)
theory "ext-relationships"
  imports "extensions-simpl" "ext-simpl-properties"
begin

(************************************************************************)
(* Inclusion relations as summary: Figure 12 of [BCG2011]
   All verified. The non-inclusion of the inverse directions has been checked
   with Nitpick in every case.  *)
(************************************************************************)

lemma stage_implies_cf_ext: \<open>stageExt AF S \<Longrightarrow> conflictfreeExt AF S\<close>
  by (simp add: maximal_def stageExt_def)

lemma admissible_implies_cf_ext: \<open>admissibleExt AF S \<Longrightarrow> conflictfreeExt AF S\<close>
  by (simp add: admissibleExt_def)

lemma complete_implies_admissible_ext: \<open>completeExt AF S \<Longrightarrow> admissibleExt AF S\<close>
  by (simp add: completeExt_def)

lemma grounded_implies_complete_ext: \<open>groundedExt AF S \<Longrightarrow> completeExt AF S\<close>
  by (simp add: groundedExt_def minimal_def)

declare [[smt_oracle]] (*TODO does not work without oracle-mode...yet*)
lemma ideal_implies_complete_ext: \<open>idealExt2 AF S \<Longrightarrow> completeExt AF S\<close>
  unfolding idealExt2_def idealSet_def maximal_def preferredExt_def completeExt_def admissibleExt_def conflictfreeExt_def
  using eq_id_iff \<F>_mono MONO_def defends_def by (smt (cvc4))

lemma preferred_implies_complete_ext: \<open>preferredExt AF S \<Longrightarrow> completeExt AF S\<close>
  by (simp add: maximal_def preferredExt_def)

lemma stable_implies_stage_ext: \<open>stableExt AF S \<Longrightarrow> stageExt AF S\<close>
  by (simp add: greatestMax greatest_def stableExt_def stageExt_def)

lemma semistable_implies_preferred_ext: \<open>semistableExt AF S \<Longrightarrow> preferredExt AF S\<close>
  unfolding semistableExt_def preferredExt_def maximal_def range_def
  by (smt (verit, ccfv_threshold) admissible_implies_cf_ext complete_implies_admissible_ext conflictfreeExt_def id_apply plusset_def)

lemma stable_implies_semistable_ext: \<open>stableExt AF S \<Longrightarrow> semistableExt AF S\<close>
  by (smt (verit) range_def admissibleExt_def completeExt_def conflictfreeExt_def defends_def greatestMax greatest_def plusset_def semistableExt_def stableExt_def)

end


section \<open>Deterministic Monad\<close>
theory Refine_Det
imports
  "HOL-Library.Monad_Syntax"
  "Generic/RefineG_Assert"
  "Generic/RefineG_While"
begin

subsection \<open>Deterministic Result Lattice\<close>
text \<open>
  We define the flat complete lattice of deterministic program results:
\<close>
(* TODO: Library/Quickcheck_Types.thy:flat_complete_lattice provides
  an isomorphic contruction. *)
datatype 'a dres =
  dSUCCEEDi   \<comment> \<open>No result\<close>
| dFAILi      \<comment> \<open>Failure\<close>
| dRETURN 'a  \<comment> \<open>Regular result\<close>

instantiation dres :: (type) complete_lattice
begin
  definition "top_dres \<equiv> dFAILi"
  definition "bot_dres \<equiv> dSUCCEEDi"
  fun sup_dres where
    "sup dFAILi _ = dFAILi" |
    "sup _ dFAILi = dFAILi" |
    "sup (dRETURN a) (dRETURN b) = (if a=b then dRETURN b else dFAILi)" |
    "sup dSUCCEEDi x = x" |
    "sup x dSUCCEEDi = x"

  lemma sup_dres_addsimps[simp]:
    "sup x dFAILi = dFAILi"
    "sup x dSUCCEEDi = x"
    apply (case_tac [!] x)
    apply simp_all
    done

  fun inf_dres where
    "inf dFAILi x = x" |
    "inf x dFAILi = x" |
    "inf (dRETURN a) (dRETURN b) = (if a=b then dRETURN b else dSUCCEEDi)" |
    "inf dSUCCEEDi _ = dSUCCEEDi" |
    "inf _ dSUCCEEDi = dSUCCEEDi"

  lemma inf_dres_addsimps[simp]:
    "inf x dSUCCEEDi = dSUCCEEDi"
    "inf dSUCCEEDi x = dSUCCEEDi"
    "inf x dFAILi = x"
    "inf (dRETURN v) x \<noteq> dFAILi"
    apply (case_tac [!] x)
    apply simp_all
    done

  definition "Sup_dres S \<equiv>
    if S\<subseteq>{dSUCCEEDi} then dSUCCEEDi
    else if dFAILi\<in>S then dFAILi
    else if \<exists>a b. a\<noteq>b \<and> dRETURN a\<in>S \<and> dRETURN b\<in>S then dFAILi
    else dRETURN (THE x. dRETURN x \<in> S)"

  definition "Inf_dres S \<equiv>
    if S\<subseteq>{dFAILi} then dFAILi
    else if dSUCCEEDi\<in>S then dSUCCEEDi
    else if \<exists>a b. a\<noteq>b \<and> dRETURN a\<in>S \<and> dRETURN b\<in>S then dSUCCEEDi
    else dRETURN (THE x. dRETURN x \<in> S)"

  fun less_eq_dres where
    "less_eq_dres dSUCCEEDi _ \<longleftrightarrow> True" |
    "less_eq_dres _ dFAILi \<longleftrightarrow> True" |
    "less_eq_dres (dRETURN (a::'a)) (dRETURN b) \<longleftrightarrow> a=b" |
    "less_eq_dres _ _ \<longleftrightarrow> False"

  definition less_dres where "less_dres (a::'a dres) b \<longleftrightarrow> a\<le>b \<and> \<not> b\<le>a"

  lemma less_eq_dres_split_conv:
    "a\<le>b \<longleftrightarrow> (case (a,b) of
        (dSUCCEEDi,_) \<Rightarrow> True
      | (_,dFAILi) \<Rightarrow> True
      | (dRETURN (a::'a), dRETURN b) \<Rightarrow> a=b
      | _ \<Rightarrow> False
    )"
    by (auto split: dres.split)

  lemma inf_dres_split_conv:
    "inf a b = (case (a,b) of
      (dFAILi,x) \<Rightarrow> x
    | (x,dFAILi) \<Rightarrow> x
    | (dRETURN a, dRETURN b) \<Rightarrow> (if a=b then dRETURN b else dSUCCEEDi)
    | _ \<Rightarrow> dSUCCEEDi)"
    by (auto split: dres.split)

  lemma sup_dres_split_conv:
    "sup a b = (case (a,b) of
      (dSUCCEEDi,x) \<Rightarrow> x
    | (x,dSUCCEEDi) \<Rightarrow> x
    | (dRETURN a, dRETURN b) \<Rightarrow> (if a=b then dRETURN b else dFAILi)
    | _ \<Rightarrow> dFAILi)"
    by (auto split: dres.split)

  instance
    apply intro_classes
    supply less_eq_dres_split_conv[simp] less_dres_def[simp] dres.splits[split]
    supply inf_dres_split_conv[simp] sup_dres_split_conv[simp] if_splits[split]
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by auto
    subgoal by (auto simp: Inf_dres_def)
    subgoal for A z
      apply (clarsimp simp: Inf_dres_def; safe)
      subgoal by force
      subgoal by force
      subgoal premises prems
        using prems(2-) apply (drule_tac prems(1)) apply (drule_tac prems(1))
        apply (auto)
        done
      subgoal premises prems
        using prems(2-) apply (frule_tac prems(1))
        by (auto; metis the_equality)
      done
    subgoal by (auto simp: Sup_dres_def; metis the_equality)
    subgoal
      apply (clarsimp simp: Sup_dres_def; safe)
      apply force
      apply force
      subgoal premises prems
        using prems(2-)
        apply (drule_tac prems(1))
        apply (drule_tac prems(1))
        apply (drule_tac prems(1))
        apply (auto)
        done
      apply force
      subgoal premises prems
        using prems(2-) apply (frule_tac prems(1))
        by (auto; metis the_equality)
      done
    subgoal by (auto simp: Inf_dres_def top_dres_def)
    subgoal by (auto simp: Sup_dres_def bot_dres_def)
    done

end

abbreviation "dSUCCEED \<equiv> (bot::'a dres)"
abbreviation "dFAIL \<equiv> (top::'a dres)"

lemma dres_cases[cases type, case_names dSUCCEED dRETURN dFAIL]:
  obtains "x=dSUCCEED" | r where "x=dRETURN r" | "x=dFAIL"
  unfolding bot_dres_def top_dres_def by (cases x) auto

lemmas [simp] = dres.case(1,2)[folded top_dres_def bot_dres_def]

lemma dres_order_simps[simp]:
  "x\<le>dSUCCEED \<longleftrightarrow> x=dSUCCEED"
  "dFAIL\<le>x \<longleftrightarrow> x=dFAIL"
  "dRETURN r \<noteq> dFAIL"
  "dRETURN r \<noteq> dSUCCEED"
  "dFAIL \<noteq> dRETURN r"
  "dSUCCEED \<noteq> dRETURN r"
  "dFAIL\<noteq>dSUCCEED"
  "dSUCCEED\<noteq>dFAIL"
  "x=y \<Longrightarrow> inf (dRETURN x) (dRETURN y) = dRETURN y"
  "x\<noteq>y \<Longrightarrow> inf (dRETURN x) (dRETURN y) = dSUCCEED"
  "x=y \<Longrightarrow> sup (dRETURN x) (dRETURN y) = dRETURN y"
  "x\<noteq>y \<Longrightarrow> sup (dRETURN x) (dRETURN y) = dFAIL"
  apply (simp_all add: bot_unique top_unique)
  apply (simp_all add: bot_dres_def top_dres_def)
  done

lemma dres_Sup_cases:
  obtains "S\<subseteq>{dSUCCEED}" and "Sup S = dSUCCEED"
  | "dFAIL\<in>S" and "Sup S = dFAIL"
  | a b where "a\<noteq>b" "dRETURN a\<in>S" "dRETURN b\<in>S" "dFAIL\<notin>S" "Sup S = dFAIL"
  | a where "S \<subseteq> {dSUCCEED, dRETURN a}" "dRETURN a\<in>S" "Sup S = dRETURN a"
proof -
  show ?thesis
    apply (cases "S\<subseteq>{dSUCCEED}")
    apply (rule that(1), assumption)
    apply (simp add: Sup_dres_def bot_dres_def)

    apply (cases "dFAIL\<in>S")
    apply (rule that(2), assumption)
    apply (simp add: Sup_dres_def bot_dres_def top_dres_def)

    apply (cases "\<exists>a b. a\<noteq>b \<and> dRETURN a\<in>S \<and> dRETURN b\<in>S")
    apply (elim exE conjE)
    apply (rule that(3), assumption+)
    apply (auto simp add: Sup_dres_def bot_dres_def top_dres_def) []

    apply simp
    apply (cases "\<exists>a. dRETURN a \<in> S")
    apply (elim exE)
    apply (rule_tac a=a in that(4)) []
    apply auto [] apply (case_tac xa, auto) []
    apply auto []
    apply (auto simp add: Sup_dres_def bot_dres_def top_dres_def) []

    apply auto apply (case_tac x, auto) []
    done
qed

lemma dres_Inf_cases:
  obtains "S\<subseteq>{dFAIL}" and "Inf S = dFAIL"
  | "dSUCCEED\<in>S" and "Inf S = dSUCCEED"
  | a b where "a\<noteq>b" "dRETURN a\<in>S" "dRETURN b\<in>S" "dSUCCEED\<notin>S" "Inf S = dSUCCEED"
  | a where "S \<subseteq> {dFAIL, dRETURN a}" "dRETURN a\<in>S" "Inf S = dRETURN a"
proof -
  show ?thesis
    apply (cases "S\<subseteq>{dFAIL}")
    apply (rule that(1), assumption)
    apply (simp add: Inf_dres_def top_dres_def)

    apply (cases "dSUCCEED\<in>S")
    apply (rule that(2), assumption)
    apply (simp add: Inf_dres_def bot_dres_def top_dres_def)

    apply (cases "\<exists>a b. a\<noteq>b \<and> dRETURN a\<in>S \<and> dRETURN b\<in>S")
    apply (elim exE conjE)
    apply (rule that(3), assumption+)
    apply (auto simp add: Inf_dres_def bot_dres_def top_dres_def) []

    apply simp
    apply (cases "\<exists>a. dRETURN a \<in> S")
    apply (elim exE)
    apply (rule_tac a=a in that(4)) []
    apply auto [] apply (case_tac xa, auto) []
    apply auto []
    apply (auto simp add: Inf_dres_def bot_dres_def top_dres_def) []

    apply auto apply (case_tac x, auto) []
    done
qed

lemma dres_chain_eq_res:
  "is_chain M \<Longrightarrow>
    dRETURN r \<in> M \<Longrightarrow> dRETURN s \<in> M \<Longrightarrow> r=s"
  by (metis chainD less_eq_dres.simps(4))

lemma dres_Sup_chain_cases:
  assumes CHAIN: "is_chain M"
  obtains "M \<subseteq> {dSUCCEED}" "Sup M = dSUCCEED"
  | r where "M \<subseteq> {dSUCCEED,dRETURN r}" "dRETURN r\<in>M" "Sup M = dRETURN r"
  | "dFAIL\<in>M" "Sup M = dFAIL"
  apply (rule dres_Sup_cases[of M])
  using dres_chain_eq_res[OF CHAIN]
  by auto

lemma dres_Inf_chain_cases:
  assumes CHAIN: "is_chain M"
  obtains "M \<subseteq> {dFAIL}" "Inf M = dFAIL"
  | r where "M \<subseteq> {dFAIL,dRETURN r}" "dRETURN r\<in>M" "Inf M = dRETURN r"
  | "dSUCCEED\<in>M" "Inf M = dSUCCEED"
  apply (rule dres_Inf_cases[of M])
  using dres_chain_eq_res[OF CHAIN]
  by auto

lemma dres_internal_simps[simp]:
  "dSUCCEEDi = dSUCCEED"
  "dFAILi = dFAIL"
  unfolding top_dres_def bot_dres_def by auto

subsubsection \<open>Monad Operations\<close>
function dbind where
  "dbind dFAIL _ = dFAIL"
| "dbind dSUCCEED _ = dSUCCEED"
| "dbind (dRETURN x) f = f x"
  unfolding bot_dres_def top_dres_def
  by pat_completeness auto
termination by lexicographic_order

adhoc_overloading
  Monad_Syntax.bind dbind

lemma dres_monad3[simp]: "dbind (dbind M f) g = dbind M (\<lambda>x. dbind (f x) g)"
  apply (cases M)
  apply auto
  done

lemmas dres_monad_laws = dres_monad1 dres_monad2 dres_monad3

lemma dbind_mono[refine_mono]:
  "\<lbrakk> M \<le> M'; \<And>x. dRETURN x \<le> M \<Longrightarrow> f x \<le> f' x \<rbrakk> \<Longrightarrow> dbind M f \<le> dbind M' f'"
  "\<lbrakk> flat_ge M M'; \<And>x. flat_ge (f x) (f' x) \<rbrakk> \<Longrightarrow> flat_ge (dbind M f) (dbind M' f')"
  apply (cases M, simp_all)
  apply (cases M', simp_all)
  apply (cases M, simp_all add: flat_ord_def)
  apply (cases M', simp_all)
  done

lemma dbind_mono1[simp, intro!]: "mono dbind"
  apply (rule monoI)
  apply (rule le_funI)
  apply (rule dbind_mono)
  by auto

lemma dbind_mono2[simp, intro!]: "mono (dbind M)"
  apply (rule monoI)
  apply (rule dbind_mono)
  by (auto dest: le_funD)

lemma dr_mono_bind:
  assumes MA: "mono A" and MB: "\<And>s. mono (B s)"
  shows "mono (\<lambda>F s. dbind (A F s) (\<lambda>s'. B s F s'))"
  apply (rule monoI)
  apply (rule le_funI)
  apply (rule dbind_mono)
  apply (auto dest: monoD[OF MA, THEN le_funD]) []
  apply (auto dest: monoD[OF MB, THEN le_funD]) []
  done

lemma dr_mono_bind': "mono (\<lambda>F s. dbind (f s) F)"
  apply rule
  apply (rule le_funI)
  apply (rule dbind_mono)
  apply (auto dest: le_funD)
  done

(* TODO: Replace by monotonicity prover! *)
lemmas dr_mono = mono_if dr_mono_bind dr_mono_bind' mono_const mono_id

lemma [refine_mono]:
  "dbind dSUCCEED f = dSUCCEED"
  "dbind dFAIL f = dFAIL"
  by (simp_all)

definition "dASSERT \<equiv> iASSERT dRETURN"
definition "dASSUME \<equiv> iASSUME dRETURN"
interpretation dres_assert: generic_Assert dbind dRETURN dASSERT dASSUME
  apply unfold_locales
  by (auto simp: dASSERT_def dASSUME_def)

definition "dWHILEIT \<equiv> iWHILEIT dbind dRETURN"
definition "dWHILEI \<equiv> iWHILEI dbind dRETURN"
definition "dWHILET \<equiv> iWHILET dbind dRETURN"
definition "dWHILE \<equiv> iWHILE dbind dRETURN"

interpretation dres_while: generic_WHILE dbind dRETURN
  dWHILEIT dWHILEI dWHILET dWHILE
  apply unfold_locales
  apply (auto simp: dWHILEIT_def dWHILEI_def dWHILET_def dWHILE_def)
  apply refine_mono+
  done

lemmas [code] =
  dres_while.WHILEIT_unfold
  dres_while.WHILEI_unfold
  dres_while.WHILET_unfold
  dres_while.WHILE_unfold

text \<open>
  Syntactic criteria to prove \<open>s \<noteq> dSUCCEED\<close>
\<close>
lemma dres_ne_bot_basic[refine_transfer]:
  "dFAIL \<noteq> dSUCCEED"
  "\<And>x. dRETURN x \<noteq> dSUCCEED"
  "\<And>m f. \<lbrakk> m\<noteq>dSUCCEED; \<And>x. f x \<noteq> dSUCCEED \<rbrakk> \<Longrightarrow> dbind m f \<noteq> dSUCCEED"
  "\<And>\<Phi>. dASSERT \<Phi> \<noteq> dSUCCEED"
  "\<And>b m1 m2. \<lbrakk> m1\<noteq>dSUCCEED; m2\<noteq>dSUCCEED \<rbrakk> \<Longrightarrow> If b m1 m2 \<noteq> dSUCCEED"
  "\<And>x f. \<lbrakk> \<And>x. f x\<noteq>dSUCCEED \<rbrakk> \<Longrightarrow> Let x f \<noteq> dSUCCEED"
  "\<And>g p. \<lbrakk> \<And>x1 x2. g x1 x2 \<noteq> dSUCCEED \<rbrakk> \<Longrightarrow> case_prod g p \<noteq> dSUCCEED"
  "\<And>fn fs x.
    \<lbrakk> fn\<noteq>dSUCCEED; \<And>v. fs v \<noteq> dSUCCEED \<rbrakk> \<Longrightarrow> case_option fn fs x \<noteq> dSUCCEED"
  "\<And>fn fc x.
    \<lbrakk> fn\<noteq>dSUCCEED; \<And>x xs. fc x xs \<noteq> dSUCCEED \<rbrakk> \<Longrightarrow> case_list fn fc x \<noteq> dSUCCEED"
  apply (auto split: prod.split option.split list.split)
  apply (case_tac m, auto) []
  apply (case_tac \<Phi>, auto) []
  done

lemma dres_ne_bot_RECT[refine_transfer]:
  assumes A: "\<And>f x. \<lbrakk> \<And>x. f x \<noteq> dSUCCEED \<rbrakk> \<Longrightarrow> B f x \<noteq> dSUCCEED"
  shows "RECT B x \<noteq> dSUCCEED"
  unfolding RECT_def
  apply (split if_split)
  apply (intro impI conjI)
  apply simp_all

  apply (rule flatf_fp_induct_pointwise[where pre="\<lambda>_ _. True" and B=B and b=top and post="\<lambda>_ _ m. m\<noteq>dSUCCEED"])
  apply (simp_all add: trimonoD A)
  done

lemma dres_ne_bot_dWHILEIT[refine_transfer]:
  assumes "\<And>x. f x \<noteq> dSUCCEED"
  shows "dWHILEIT I b f s \<noteq> dSUCCEED" using assms
  unfolding dWHILEIT_def iWHILEIT_def WHILEI_body_def
  apply refine_transfer
  done

lemma dres_ne_bot_dWHILET[refine_transfer]:
  assumes "\<And>x. f x \<noteq> dSUCCEED"
  shows "dWHILET b f s \<noteq> dSUCCEED" using assms
  unfolding dWHILET_def iWHILET_def iWHILEIT_def WHILEI_body_def
  apply refine_transfer
  done

end


(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory System_S0 imports System_L1 begin

text \<open>System S1 from Boleslaw Sobocinski: Note on a Problem of Paul Barnays (1955) \<close>

text \<open>Derivations are taken from the above paper\<close>

inductive S0 (\<open>\<SS>\<^sub>0\<close>) where
  S0_MP: \<open>\<SS>\<^sub>0 q\<close> if \<open>\<SS>\<^sub>0 p\<close> and \<open>\<SS>\<^sub>0 (p \<rightarrow> q)\<close> |
  S0_1:  \<open>\<SS>\<^sub>0 (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> (s \<rightarrow> p))))\<close> |
  S0_2:  \<open>\<SS>\<^sub>0 ((\<sim> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close> |
  S0_3:  \<open>\<SS>\<^sub>0 (((\<sim> p) \<rightarrow> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close>

lemma S0_4: \<open>\<SS>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> (r \<rightarrow> q)))\<close>
  using S0_1 S0_2 S0_3 S0_MP by metis

lemma S0_5: \<open>\<SS>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> (p \<rightarrow> (r \<rightarrow> q))))\<close>
  using S0_4 S0_MP by metis

lemma S0_6: \<open>\<SS>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> (v \<rightarrow> (s \<rightarrow> (p \<rightarrow> (r \<rightarrow> q)))))\<close>
  using S0_4 S0_5 S0_MP by metis

lemma S0_7: \<open>\<SS>\<^sub>0 ((s \<rightarrow> (p \<rightarrow> q)) \<rightarrow> (s \<rightarrow> (p \<rightarrow> (r \<rightarrow> q))))\<close>
  using S0_2 S0_3 S0_6 S0_MP by metis

lemma S0_8: \<open>\<SS>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> (s \<rightarrow> (r \<rightarrow> q))))\<close>
  using S0_4 S0_7 S0_MP by metis

lemma S0_9: \<open>\<SS>\<^sub>0 ((\<sim> q) \<rightarrow> (s \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r))))\<close>
  using S0_2 S0_4 S0_MP by metis

lemma S0_10: \<open>\<SS>\<^sub>0 (q \<rightarrow> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (p \<rightarrow> r)))\<close>
  using S0_3 S0_8 S0_9 S0_MP by metis

lemma S0_11: \<open>\<SS>\<^sub>0 ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using S0_10 S0_MP by metis

lemma S0_12: \<open>\<SS>\<^sub>0 (p \<rightarrow> (r \<rightarrow> (s \<rightarrow> p)))\<close>
  using S0_1 S0_11 S0_MP by metis

lemma S0_13: \<open>\<SS>\<^sub>0 (p \<rightarrow> (s \<rightarrow> p))\<close>
  using S0_11 S0_12 S0_MP by metis

lemma S0_14: \<open>\<SS>\<^sub>0 (p \<rightarrow> p)\<close>
  using S0_11 S0_13 S0_MP by metis

lemma S0_15: \<open>\<SS>\<^sub>0 (p \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> (r \<rightarrow> q))))\<close>
  using S0_8 S0_11 S0_MP by metis

lemma S0_16: \<open>\<SS>\<^sub>0 ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using S0_3 S0_9 S0_15 S0_MP by metis

lemma S0_17: \<open>\<SS>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using S0_11 S0_16 S0_MP by metis

lemma S0_18: \<open>\<SS>\<^sub>0 (((\<sim> p) \<rightarrow> p) \<rightarrow> p)\<close>
  using S0_3 S0_11 S0_14 S0_17 S0_MP by metis

lemma S0_19: \<open>\<SS>\<^sub>0 ((\<sim> p) \<rightarrow> (p \<rightarrow> q))\<close>
  using S0_2 S0_11 S0_14 S0_18 S0_MP by metis

lemma S0_20: \<open>\<SS>\<^sub>0 (p \<rightarrow> ((\<sim> p) \<rightarrow> q))\<close>
  using S0_11 S0_19 S0_MP by metis

theorem S0_if_L1: \<open>\<SS>\<^sub>0 p\<close> if \<open>\<turnstile> p\<close> using that
  by (induct) (metis S0.intros(1), metis S0_17, metis S0_18, metis S0_20)

theorem S0_soundness: \<open>\<SS>\<^sub>0 p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: S0.induct) auto

theorem S0_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<SS>\<^sub>0 p\<close>
  using S0_if_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<SS>\<^sub>0 p\<close>
  unfolding valid_def using S0_soundness S0_completeness by blast

lemmas S0 = S0.intros main

end


theory weird_nat_mul3acc_assoc2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!!
     (x1 :: Nat) (x2 :: Nat) (x3acc :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (mul3acc (mul3acc x1 x2 x3acc) x4 x5) =
       (mul3acc x1 (mul3acc x2 x3acc x4) x5)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Hoare
  imports Semantics
begin

definition ht :: "'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a pred \<Rightarrow> bool" ("(3\<turnstile> _/ (2_)/ _)" [100, 55, 100] 50) where
  "\<turnstile> p F q \<longleftrightarrow> p \<le> F q"

lemma hl_seq: "mono F \<Longrightarrow> \<turnstile> p F r \<Longrightarrow> \<turnstile> r G q \<Longrightarrow> \<turnstile> p F; G q"
  by (auto simp: ht_def mono_def)

lemma hl_sup: "mono F \<Longrightarrow> p \<le> (F :: 'a predT) q \<Longrightarrow> p \<le> F r \<Longrightarrow> p \<le> F (q \<squnion> r)"
  by (metis mono_sup order_trans sup_ge2)

lemma hl_skip: "p \<le> q \<Longrightarrow> \<turnstile> p skip q"
  by (auto simp: ht_def)

lemma hl_if: "\<turnstile> (p \<sqinter> b) F q \<Longrightarrow> \<turnstile> (p - b) G q \<Longrightarrow> \<turnstile> p (if_comm b F G) q"
  by (auto simp: ht_def if_comm_def)

lemma hl_weaken: "mono F \<Longrightarrow> q \<le> q' \<Longrightarrow> \<turnstile> p F q \<Longrightarrow> \<turnstile> p F q'"
  by (auto simp: ht_def mono_def)

lemma hl_strenthen: "p' \<le> p \<Longrightarrow> \<turnstile> p F q \<Longrightarrow> \<turnstile> p' F q"
  by (auto simp: ht_def)

lemma iteration: "p \<le> F q \<Longrightarrow> p \<le> (F\<^sup>\<star>) q"
  oops

lemma hl_pow: "mono F \<Longrightarrow> p \<le> F p \<Longrightarrow> pow F i p \<le> F (pow F i p)"
  apply (induct i)
  apply (auto simp: pow_zero pow_suc)
  by (metis mono_def predicate1D)

lemma hl_iteration: "mono F \<Longrightarrow> p \<le> F p \<Longrightarrow> p \<le> (F\<^sup>\<star>) p"
  apply (simp add: iteration_def)
  apply (rule INF_greatest)
  apply auto
  apply (induct_tac i)
  apply (auto simp: pow_zero pow_suc)
  by (metis hl_pow predicate1D)

lemma hl_while': "mono x \<Longrightarrow> (i \<sqinter> b) \<le> x i \<Longrightarrow> i \<le> ((\<lceil>b\<rceil> \<circ> x)\<^sup>\<star>) i"
  apply (rule hl_iteration)
  apply (auto simp: mono_def)
done

lemma mono_bx: "mono x \<Longrightarrow> mono ((\<lceil>b\<rceil> \<circ> x)\<^sup>\<star>)"
  apply (rule mono_iteration)
  apply (rule mono_seq)
  apply (rule mono_pred)
by simp

lemma hl_while: "mono x \<Longrightarrow> p \<le> i \<Longrightarrow> i - b \<le> q \<Longrightarrow> (i \<sqinter> b) \<le> x i \<Longrightarrow> \<turnstile> p (while_inv_comm b i x) q"
  apply (rule hl_weaken)
  apply (unfold while_inv_comm_def)
  apply (rule mono_seq)
  apply (rule mono_iteration)
  apply (rule mono_seq)
  apply (rule mono_pred)
  apply simp
  apply (rule mono_pred)
  apply assumption
  apply (rule hl_strenthen)
  apply assumption
  apply (unfold ht_def while_inv_comm_def)
  apply (subst comp_apply)
  apply (rule order_trans)
  apply (rule hl_while')
  apply assumption
  apply assumption
  apply (rule monoE[of "(\<lceil>b\<rceil> \<circ> x)\<^sup>\<star>" i "\<lceil>- b\<rceil> (i - b)"])
  apply (rule mono_bx)
  apply (auto intro: mono_def)
done

lemma sl_frame: "local F \<Longrightarrow> \<turnstile> p F q \<Longrightarrow> \<turnstile> (p * r) F (q * r)"
proof (simp add: local_def ht_def)
  assume assm: "\<forall>x y. F x * y \<le> F (x * y)" "p \<le> F q"
  hence "p * r \<le> F q * r"
    by (metis Semantics.Sup.qisor)
  thus "p * r \<le> F (q * r)" using assm
    by auto
qed

lemma hl_assign: "P \<le> Q[` |m| /`x] \<Longrightarrow> \<turnstile> P (`x := ` |m| ) Q"
  by (auto simp: ht_def)

lemma sl_assign: "(\<And>s h. P (s, h) \<Longrightarrow> Q (s, h(p \<mapsto> q))) \<Longrightarrow> \<turnstile> P (@p := q) Q"
  by (auto simp: ht_def)

lemma sl_mutation_local: "\<turnstile> \<lbrace>e \<mapsto> - \<rbrace> @e := e' \<lbrace> e \<mapsto> e' \<rbrace>"
  by (auto simp: ht_def ex_singleton_def is_singleton_def)

lemma sl_mutation_local': "\<turnstile> \<lbrace>e \<mapsto> e'' \<rbrace> @e := e' \<lbrace> e \<mapsto> e' \<rbrace>"
  by (auto simp: ht_def is_singleton_def)

lemma sl_mutation_global: "\<turnstile> (\<lbrace>e \<mapsto> - \<rbrace> * r) @e := e' (\<lbrace> e \<mapsto> e' \<rbrace> * r)"
  apply (rule sl_frame)
  apply (rule local_mutation)
  by (rule sl_mutation_local)

lemma sl_mutation_backwards: "\<turnstile> (\<lbrace>e \<mapsto> - \<rbrace> * (\<lbrace> e \<mapsto> e' \<rbrace> -* p)) @e := e' p"
  apply (rule hl_weaken)
  prefer 3
  apply (rule sl_mutation_global)
  apply (rule mono_mutation)
  by (rule sep_impl_annil1)

lemma sl_cons_local: "stable_var v_update v \<Longrightarrow> \<turnstile> emp (`v := cons e) \<lbrace> `v \<mapsto> e \<rbrace>"
  by (auto simp add: ht_def emp_def new_comm_def is_singleton_def Let_def stable_var_def)

lemma sl_cons_global: "stable_var v_update v \<Longrightarrow> \<turnstile> r (`v := cons e) (\<lbrace> `v \<mapsto> e \<rbrace> * r)"
  apply (subst mult.left_neutral[symmetric])
  apply (rule sl_frame)
  apply (rule local_cons)
  by (rule sl_cons_local)

lemma sl_dispose_local: "\<turnstile> \<lbrace> e \<mapsto> - \<rbrace> dispose e emp"
  by (auto simp: emp_def dispose_comm_def ht_def ex_singleton_def is_singleton_def)

lemma sl_dispose_global: "\<turnstile> (\<lbrace>e \<mapsto> -\<rbrace> * r) dispose e r"
  apply (subst mult.left_neutral[symmetric]) back back back
  apply (rule sl_frame)
  apply (rule local_dispose)
  by (rule sl_dispose_local)

ML {*

val hoare_step_tac =
  FIRST' [
      rtac @{thm sl_frame},
      rtac @{thm local_mutation},
      rtac @{thm sl_mutation_local'},
      rtac @{thm order_refl},
      rtac @{thm mono_seq},
      rtac @{thm mono_assign},
      rtac @{thm mono_mutation},
      rtac @{thm mono_dispose},
      rtac @{thm hl_assign},
      rtac @{thm sl_assign},
      rtac @{thm sl_mutation_global},
      rtac @{thm hl_if},
      rtac @{thm hl_skip},
      rtac @{thm hl_seq},
      rtac @{thm hl_while}
    ]

val hoare_tac = REPEAT_ALL_NEW (CHANGED o hoare_step_tac)

*}

method_setup hoare_simp = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD (
    ALLGOALS (asm_full_simp_tac ctxt)
    THEN ALLGOALS hoare_tac
    THEN ALLGOALS (asm_full_simp_tac ctxt)
  ))
*}

method_setup hoare_step = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD (
    ALLGOALS hoare_step_tac
  ))
*}

method_setup hoare = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD (
    ALLGOALS hoare_tac
  ))
*}
end


theory SimpleCake
imports "$HIPSTER_HOME/IsaHipster"
begin

datatype Slice = Cream | Marzipan

datatype Cake = SwedishPiece Slice | BigPiece Slice Cake

fun merge :: "Cake \<Rightarrow> Cake \<Rightarrow> Cake"
where
  "merge (SwedishPiece slice) cake = BigPiece slice cake"
| "merge (BigPiece slice cake1) cake2 = BigPiece slice (merge cake1 cake2)"

hipster merge
lemma lemma_a [thy_expl]: "merge (merge x2 y2) z2 = merge x2 (merge y2 z2)"
by (hipster_induct_simp_metis SimpleCake.merge.simps)

fun like :: "Slice \<Rightarrow> bool"
where
   "like Cream = False"
  |"like Marzipan = True"

fun dummyAnd :: "bool \<Rightarrow> bool \<Rightarrow> bool"
where
  "dummyAnd a b = (a \<and> b)"

fun isTasty :: "Cake \<Rightarrow> bool"
where
  "isTasty (SwedishPiece slice) = like slice"
 |"isTasty (BigPiece slice cake) = (like slice \<and> isTasty cake)"

ML\<open>Syntax.read_prop @{context} "HOL.conj a b = HOL.conj b a"\<close>

hipster merge isTasty HOL.conj
lemma lemma_aa [thy_expl]: "dummyAnd (isTasty x2) (isTasty y2) = isTasty (merge x2 y2)"
by (hipster_induct_simp_metis SimpleCake.dummyAnd.simps SimpleCake.merge.simps SimpleCake.isTasty.simps)

end


section {* Example 3.8 *}

theory Ex2
imports "../LCF"
begin

axiomatization
  P     :: "'a \<Rightarrow> tr" and
  F     :: "'b \<Rightarrow> 'b" and
  G     :: "'a \<Rightarrow> 'a" and
  H     :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and
  K     :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b)"
where
  F_strict:     "F(UU) = UU" and
  K:            "K = (\<lambda>h x y. P(x) \<Rightarrow> y | F(h(G(x),y)))" and
  H:            "H = FIX(K)"

declare F_strict [simp] K [simp]

lemma example: "\<forall>x. F(H(x::'a,y::'b)) = H(x,F(y))"
  apply (simplesubst H)
  apply (induct "K:: ('a\<Rightarrow>'b\<Rightarrow>'b) \<Rightarrow> ('a\<Rightarrow>'b\<Rightarrow>'b)")
  apply simp
  apply (simp split: COND_cases_iff)
  done

end


(*  Title:      HOL/HOLCF/IOA/ex/TrivEx2.thy
    Author:     Olaf Müller
*)

section \<open>Trivial Abstraction Example with fairness\<close>

theory TrivEx2
imports "../Abstraction"
begin

datatype action = INC

definition
  C_asig :: "action signature" where
  "C_asig = ({},{INC},{})"
definition
  C_trans :: "(action, nat)transition set" where
  "C_trans =
   {tr. let s = fst(tr);
            t = snd(snd(tr))
        in case fst(snd(tr))
        of
        INC       => t = Suc(s)}"
definition
  C_ioa :: "(action, nat)ioa" where
  "C_ioa = (C_asig, {0}, C_trans,{},{})"
definition
  C_live_ioa :: "(action, nat)live_ioa" where
  "C_live_ioa = (C_ioa, WF C_ioa {INC})"

definition
  A_asig :: "action signature" where
  "A_asig = ({},{INC},{})"
definition
  A_trans :: "(action, bool)transition set" where
  "A_trans =
   {tr. let s = fst(tr);
            t = snd(snd(tr))
        in case fst(snd(tr))
        of
        INC       => t = True}"
definition
  A_ioa :: "(action, bool)ioa" where
  "A_ioa = (A_asig, {False}, A_trans,{},{})"
definition
  A_live_ioa :: "(action, bool)live_ioa" where
  "A_live_ioa = (A_ioa, WF A_ioa {INC})"

definition
  h_abs :: "nat => bool" where
  "h_abs n = (n~=0)"

axiomatization where
  MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (\<diamond>\<box>\<langle>%(b,a,c). b\<rangle>)"

lemma h_abs_is_abstraction:
"is_abstraction h_abs C_ioa A_ioa"
apply (unfold is_abstraction_def)
apply (rule conjI)
txt \<open>start states\<close>
apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
txt \<open>step case\<close>
apply (rule allI)+
apply (rule imp_conj_lemma)
apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
apply (induct_tac "a")
apply (simp (no_asm) add: h_abs_def)
done

lemma Enabled_implication:
    "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
  apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
    C_trans_def trans_of_def)
  apply auto
  done

lemma h_abs_is_liveabstraction:
"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
apply (unfold is_live_abstraction_def)
apply auto
txt \<open>is_abstraction\<close>
apply (rule h_abs_is_abstraction)
txt \<open>temp_weakening\<close>
apply abstraction
apply (erule Enabled_implication)
done

lemma TrivEx2_abstraction:
  "validLIOA C_live_ioa (\<diamond>\<box>\<langle>%(n,a,m). n~=0\<rangle>)"
apply (unfold C_live_ioa_def)
apply (rule AbsRuleT2)
apply (rule h_abs_is_liveabstraction)
apply (rule MC_result)
apply abstraction
apply (simp add: h_abs_def)
done

end


section\<open>Simple Firewall Semantics\<close>
theory SimpleFw_Semantics
imports SimpleFw_Syntax
        "../IP_Addresses/IP_Address"
        "../IP_Addresses/Prefix_Match"
begin

  fun simple_match_ip :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word \<Rightarrow> bool" where
    "simple_match_ip (base, len) p_ip \<longleftrightarrow> p_ip \<in> ipset_from_cidr base len"

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval_simple_match_ip_set:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval ip) = {d. simple_match_ip ip d}"
    proof -
      { fix s and d :: "'a::len word \<times> nat"
        from wordinterval_to_set_ipcidr_tuple_to_wordinterval have
          "s \<in> wordinterval_to_set (ipcidr_tuple_to_wordinterval d) \<longleftrightarrow> simple_match_ip d s"
        by(cases d) auto
      } thus ?thesis by blast
    qed

  --"by the way, the words do not wrap around"
  lemma "{(253::8 word) .. 8} = {}" by simp

  fun simple_match_port :: "(16 word \<times> 16 word) \<Rightarrow> 16 word \<Rightarrow> bool" where
    "simple_match_port (s,e) p_p \<longleftrightarrow> p_p \<in> {s..e}"

  fun simple_matches :: "'i::len simple_match \<Rightarrow> ('i, 'a) simple_packet_scheme \<Rightarrow> bool" where
    "simple_matches m p \<longleftrightarrow>
      (match_iface (iiface m) (p_iiface p)) \<and>
      (match_iface (oiface m) (p_oiface p)) \<and>
      (simple_match_ip (src m) (p_src p)) \<and>
      (simple_match_ip (dst m) (p_dst p)) \<and>
      (match_proto (proto m) (p_proto p)) \<and>
      (simple_match_port (sports m) (p_sport p)) \<and>
      (simple_match_port (dports m) (p_dport p))"

  text\<open>The semantics of a simple firewall: just iterate over the rules sequentially\<close>
  fun simple_fw :: "'i::len simple_rule list \<Rightarrow> ('i, 'a) simple_packet_scheme \<Rightarrow> state" where
    "simple_fw [] _ = Undecided" |
    "simple_fw ((SimpleRule m Accept)#rs) p = (if simple_matches m p then Decision FinalAllow else simple_fw rs p)" |
    "simple_fw ((SimpleRule m Drop)#rs) p = (if simple_matches m p then Decision FinalDeny else simple_fw rs p)"

  fun simple_fw_alt where
    "simple_fw_alt [] _ = Undecided" |
    "simple_fw_alt (r#rs) p = (if simple_matches (match_sel r) p then
    	(case action_sel r of Accept \<Rightarrow> Decision FinalAllow | Drop \<Rightarrow> Decision FinalDeny) else simple_fw_alt rs p)"

  lemma simple_fw_alt: "simple_fw r p = simple_fw_alt r p" by(induction rule: simple_fw.induct) simp_all

  definition simple_match_any :: "'i::len simple_match" where
    "simple_match_any \<equiv> \<lparr>iiface=ifaceAny, oiface=ifaceAny, src=(0,0), dst=(0,0), proto=ProtoAny, sports=(0,65535), dports=(0,65535) \<rparr>"
  lemma simple_match_any: "simple_matches simple_match_any p"
    proof -
      have "(65535::16 word) = max_word" by(simp add: max_word_def)
      thus ?thesis by(simp add: simple_match_any_def ipset_from_cidr_0 match_ifaceAny)
    qed

  text\<open>we specify only one empty port range\<close>
  definition simple_match_none :: "'i::len simple_match" where
    "simple_match_none \<equiv>
      \<lparr>iiface=ifaceAny, oiface=ifaceAny, src=(1,0), dst=(0,0),
       proto=ProtoAny, sports=(1,0), dports=(0,65535) \<rparr>"
  lemma simple_match_none: "\<not> simple_matches simple_match_none p"
    proof -
      show ?thesis by(simp add: simple_match_none_def)
    qed

  fun empty_match :: "'i::len simple_match \<Rightarrow> bool" where
    "empty_match \<lparr>iiface=_, oiface=_, src=_, dst=_, proto=_,
                  sports=(sps1, sps2), dports=(dps1, dps2) \<rparr> \<longleftrightarrow> (sps1 > sps2) \<or> (dps1 > dps2)"

  lemma empty_match: "empty_match m \<longleftrightarrow> (\<forall>(p::('i::len, 'a) simple_packet_scheme). \<not> simple_matches m p)"
    proof
      assume "empty_match m"
      thus "\<forall>p. \<not> simple_matches m p" by(cases m) fastforce
    next
      assume assm: "\<forall>(p::('i::len, 'a) simple_packet_scheme). \<not> simple_matches m p"
      obtain iif oif sip dip protocol sps1 sps2 dps1 dps2 where m:
        "m = \<lparr>iiface = iif, oiface = oif, src = sip, dst = dip, proto = protocol, sports = (sps1, sps2), dports = (dps1, dps2)\<rparr>"
          by(cases m) force

      show "empty_match m"
        proof(simp add: m)
          let ?x="\<lambda>p. dps1 \<le> p_dport p \<longrightarrow> p_sport p \<le> sps2 \<longrightarrow> sps1 \<le> p_sport p \<longrightarrow>
              match_proto protocol (p_proto p) \<longrightarrow> simple_match_ip dip (p_dst p) \<longrightarrow> simple_match_ip sip (p_src p) \<longrightarrow>
              match_iface oif (p_oiface p) \<longrightarrow> match_iface iif (p_iiface p) \<longrightarrow> \<not> p_dport p \<le> dps2"
          from assm have nomatch: "\<forall>(p::('i::len, 'a) simple_packet_scheme). ?x p" by(simp add: m)
          { fix ips::"'i::len word \<times> nat"
            have "a \<in> ipset_from_cidr a n" for a::"'i::len word" and n
              using ipset_from_cidr_lowest by auto
            hence "simple_match_ip ips (fst ips)" by(cases ips) simp
          } note ips=this
          have proto: "match_proto protocol (case protocol of ProtoAny \<Rightarrow> TCP | Proto p \<Rightarrow> p)"
            by(simp split: protocol.split)
          { fix ifce
            have " match_iface ifce (iface_sel ifce)"
            by(cases ifce) (simp add: match_iface_refl)
          } note ifaces=this
          { fix p::"('i, 'a) simple_packet_scheme"
            from nomatch have "?x p" by blast
          } note pkt1=this
          obtain p::"('i, 'a) simple_packet_scheme" where [simp]:
			  "p_iiface p = iface_sel iif"
			  "p_oiface p = iface_sel oif"
			  "p_src p = fst sip"
			  "p_dst p = fst dip"
			  "p_proto p = (case protocol of ProtoAny \<Rightarrow> TCP | Proto p \<Rightarrow> p)"
			  "p_sport p = sps1"
			  "p_dport p = dps1"
			  by (meson simple_packet.select_convs)
          note pkt=pkt1[of p, simplified]
          from pkt ips proto ifaces have " sps1 \<le> sps2 \<longrightarrow> \<not> dps1 \<le> dps2" by blast
          thus "sps2 < sps1 \<or> dps2 < dps1" by fastforce
      qed
  qed

  lemma nomatch: "\<not> simple_matches m p \<Longrightarrow> simple_fw (SimpleRule m a # rs) p = simple_fw rs p"
    by(cases a, simp_all del: simple_matches.simps)

subsection\<open>Simple Ports\<close>
  fun simpl_ports_conjunct :: "(16 word \<times> 16 word) \<Rightarrow> (16 word \<times> 16 word) \<Rightarrow> (16 word \<times> 16 word)" where
    "simpl_ports_conjunct (p1s, p1e) (p2s, p2e) = (max p1s p2s, min p1e p2e)"

  lemma "{(p1s:: 16 word) .. p1e} \<inter> {p2s .. p2e} = {max p1s p2s .. min p1e p2e}" by(simp)

  lemma simple_match_port_code[code] :"simple_match_port (s,e) p_p = (s \<le> p_p \<and> p_p \<le> e)" by simp

  lemma simple_match_port_UNIV: "{p. simple_match_port (s,e) p} = UNIV \<longleftrightarrow> (s = 0 \<and> e = max_word)"
    apply(simp)
    apply(rule)
     apply(case_tac "s = 0")
      using antisym_conv apply blast
     using word_le_0_iff apply blast
    using word_zero_le by blast

subsection\<open>Simple IPs\<close>
  lemma simple_match_ip_conjunct:
    fixes ip1 :: "'i::len word \<times> nat"
    shows "simple_match_ip ip1 p_ip \<and> simple_match_ip ip2 p_ip \<longleftrightarrow>
            (case ipcidr_conjunct ip1 ip2 of None \<Rightarrow> False | Some ipx \<Rightarrow> simple_match_ip ipx p_ip)"
  proof -
  {
    fix b1 m1 b2 m2
    have "simple_match_ip (b1, m1) p_ip \<and> simple_match_ip (b2, m2) p_ip \<longleftrightarrow>
          p_ip \<in> ipset_from_cidr b1 m1 \<inter> ipset_from_cidr b2 m2"
    by simp
    also have "\<dots> \<longleftrightarrow> p_ip \<in> (case ipcidr_conjunct (b1, m1) (b2, m2) of None \<Rightarrow> {} | Some (bx, mx) \<Rightarrow> ipset_from_cidr bx mx)"
      using ipcidr_conjunct_correct by blast
    also have "\<dots> \<longleftrightarrow> (case ipcidr_conjunct (b1, m1) (b2, m2) of None \<Rightarrow> False | Some ipx \<Rightarrow> simple_match_ip ipx p_ip)"
      by(simp split: option.split)
    finally have "simple_match_ip (b1, m1) p_ip \<and> simple_match_ip (b2, m2) p_ip \<longleftrightarrow>
         (case ipcidr_conjunct (b1, m1) (b2, m2) of None \<Rightarrow> False | Some ipx \<Rightarrow> simple_match_ip ipx p_ip)" .
   } thus ?thesis by(cases ip1, cases ip2, simp)
  qed

  declare simple_matches.simps[simp del]

subsection\<open>Merging Simple Matches\<close>
  text\<open>@{typ "'i::len simple_match"} @{text \<and>} @{typ "'i::len simple_match"}\<close>

  fun simple_match_and :: "'i::len simple_match \<Rightarrow> 'i simple_match \<Rightarrow> 'i simple_match option" where
    "simple_match_and \<lparr>iiface=iif1, oiface=oif1, src=sip1, dst=dip1, proto=p1, sports=sps1, dports=dps1 \<rparr>
                      \<lparr>iiface=iif2, oiface=oif2, src=sip2, dst=dip2, proto=p2, sports=sps2, dports=dps2 \<rparr> =
      (case ipcidr_conjunct sip1 sip2 of None \<Rightarrow> None | Some sip \<Rightarrow>
      (case ipcidr_conjunct dip1 dip2 of None \<Rightarrow> None | Some dip \<Rightarrow>
      (case iface_conjunct iif1 iif2 of None \<Rightarrow> None | Some iif \<Rightarrow>
      (case iface_conjunct oif1 oif2 of None \<Rightarrow> None | Some oif \<Rightarrow>
      (case simple_proto_conjunct p1 p2 of None \<Rightarrow> None | Some p \<Rightarrow>
      Some \<lparr>iiface=iif, oiface=oif, src=sip, dst=dip, proto=p,
            sports=simpl_ports_conjunct sps1 sps2, dports=simpl_ports_conjunct dps1 dps2 \<rparr>)))))"

  lemma simple_match_and_correct: "simple_matches m1 p \<and> simple_matches m2 p \<longleftrightarrow>
    (case simple_match_and m1 m2 of None \<Rightarrow> False | Some m \<Rightarrow> simple_matches m p)"
    proof -
      obtain iif1 oif1 sip1 dip1 p1 sps1 dps1 where m1:
        "m1 = \<lparr>iiface=iif1, oiface=oif1, src=sip1, dst=dip1, proto=p1, sports=sps1, dports=dps1 \<rparr>" by(cases m1, blast)
      obtain iif2 oif2 sip2 dip2 p2 sps2 dps2 where m2:
        "m2 = \<lparr>iiface=iif2, oiface=oif2, src=sip2, dst=dip2, proto=p2, sports=sps2, dports=dps2 \<rparr>" by(cases m2, blast)

      have sip_None: "ipcidr_conjunct sip1 sip2 = None \<Longrightarrow> \<not> simple_match_ip sip1 (p_src p) \<or> \<not> simple_match_ip sip2 (p_src p)"
        using simple_match_ip_conjunct[of sip1 "p_src p" sip2] by simp
      have dip_None: "ipcidr_conjunct dip1 dip2 = None \<Longrightarrow> \<not> simple_match_ip dip1 (p_dst p) \<or> \<not> simple_match_ip dip2 (p_dst p)"
        using simple_match_ip_conjunct[of dip1 "p_dst p" dip2] by simp
      have sip_Some: "\<And>ip. ipcidr_conjunct sip1 sip2 = Some ip \<Longrightarrow>
        simple_match_ip ip (p_src p) \<longleftrightarrow> simple_match_ip sip1 (p_src p) \<and> simple_match_ip sip2 (p_src p)"
        using simple_match_ip_conjunct[of sip1 "p_src p" sip2] by simp
      have dip_Some: "\<And>ip. ipcidr_conjunct dip1 dip2 = Some ip \<Longrightarrow>
        simple_match_ip ip (p_dst p) \<longleftrightarrow> simple_match_ip dip1 (p_dst p) \<and> simple_match_ip dip2 (p_dst p)"
        using simple_match_ip_conjunct[of dip1 "p_dst p" dip2] by simp

      have iiface_None: "iface_conjunct iif1 iif2 = None \<Longrightarrow> \<not> match_iface iif1 (p_iiface p) \<or> \<not> match_iface iif2 (p_iiface p)"
        using iface_conjunct[of iif1 "(p_iiface p)" iif2] by simp
      have oiface_None: "iface_conjunct oif1 oif2 = None \<Longrightarrow> \<not> match_iface oif1 (p_oiface p) \<or> \<not> match_iface oif2 (p_oiface p)"
        using iface_conjunct[of oif1 "(p_oiface p)" oif2] by simp
      have iiface_Some: "\<And>iface. iface_conjunct iif1 iif2 = Some iface \<Longrightarrow>
        match_iface iface (p_iiface p) \<longleftrightarrow> match_iface iif1 (p_iiface p) \<and> match_iface iif2 (p_iiface p)"
        using iface_conjunct[of iif1 "(p_iiface p)" iif2] by simp
      have oiface_Some: "\<And>iface. iface_conjunct oif1 oif2 = Some iface \<Longrightarrow>
        match_iface iface (p_oiface p) \<longleftrightarrow> match_iface oif1 (p_oiface p) \<and> match_iface oif2 (p_oiface p)"
        using iface_conjunct[of oif1 "(p_oiface p)" oif2] by simp

      have proto_None: "simple_proto_conjunct p1 p2 = None \<Longrightarrow> \<not> match_proto p1 (p_proto p) \<or> \<not> match_proto p2 (p_proto p)"
        using simple_proto_conjunct_correct[of p1 "(p_proto p)" p2] by simp
      have proto_Some: "\<And>proto. simple_proto_conjunct p1 p2 = Some proto \<Longrightarrow>
        match_proto proto (p_proto p) \<longleftrightarrow> match_proto p1 (p_proto p) \<and> match_proto p2 (p_proto p)"
        using simple_proto_conjunct_correct[of p1 "(p_proto p)" p2] by simp

      have case_Some: "\<And>m. Some m = simple_match_and m1 m2 \<Longrightarrow>
       (simple_matches m1 p \<and> simple_matches m2 p) \<longleftrightarrow> simple_matches m p"
       apply(simp add: m1 m2 simple_matches.simps split: option.split_asm)
       using simple_ports_conjunct_correct by(blast dest: sip_Some dip_Some iiface_Some oiface_Some proto_Some)
      have case_None: "simple_match_and m1 m2 = None \<Longrightarrow> \<not> (simple_matches m1 p \<and> simple_matches m2 p)"
       apply(simp add: m1 m2 simple_matches.simps split: option.split_asm)
           apply(blast dest: sip_None dip_None iiface_None oiface_None proto_None)+
       done
      from case_Some case_None show ?thesis by(cases "simple_match_and m1 m2") simp_all
   qed

  lemma simple_match_and_SomeD: "simple_match_and m1 m2 = Some m \<Longrightarrow>
    simple_matches m p \<longleftrightarrow> (simple_matches m1 p \<and> simple_matches m2 p)"
    by(simp add: simple_match_and_correct)
  lemma simple_match_and_NoneD: "simple_match_and m1 m2 = None \<Longrightarrow>
    \<not>(simple_matches m1 p \<and> simple_matches m2 p)"
    by(simp add: simple_match_and_correct)
  lemma simple_matches_andD: "simple_matches m1 p \<Longrightarrow> simple_matches m2 p \<Longrightarrow>
    \<exists>m. simple_match_and m1 m2 = Some m \<and> simple_matches m p"
    by (meson option.exhaust_sel simple_match_and_NoneD simple_match_and_SomeD)

subsection\<open>Further Properties of a Simple Firewall\<close>
  fun has_default_policy :: "'i::len simple_rule list \<Rightarrow> bool" where
    "has_default_policy [] = False" |
    "has_default_policy [(SimpleRule m _)] = (m = simple_match_any)" |
    "has_default_policy (_#rs) = has_default_policy rs"

  lemma has_default_policy: "has_default_policy rs \<Longrightarrow>
    simple_fw rs p = Decision FinalAllow \<or> simple_fw rs p = Decision FinalDeny"
    proof(induction rs rule: has_default_policy.induct)
    case 1 thus ?case by (simp)
    next
    case (2 m a) thus ?case by(cases a) (simp_all add: simple_match_any)
    next
    case (3 r1 r2 rs)
      from 3 obtain a m where "r1 = SimpleRule m a" by (cases r1) simp
      with 3 show ?case by (cases a) simp_all
    qed

  lemma has_default_policy_fst: "has_default_policy rs \<Longrightarrow> has_default_policy (r#rs)"
   apply(cases r, rename_tac m a, simp)
   apply(cases rs)
    by(simp_all)

  text\<open>We can stop after a default rule (a rule which matches anything) is observed.\<close>
  fun cut_off_after_match_any :: "'i::len simple_rule list \<Rightarrow> 'i simple_rule list" where
    "cut_off_after_match_any [] = []" |
    "cut_off_after_match_any (SimpleRule m a # rs) =
      (if m = simple_match_any then [SimpleRule m a] else SimpleRule m a # cut_off_after_match_any rs)"

  lemma cut_off_after_match_any: "simple_fw (cut_off_after_match_any rs) p = simple_fw rs p"
    apply(induction rs p rule: simple_fw.induct)
      by(simp add: simple_match_any)+

  lemma simple_fw_not_matches_removeAll: "\<not> simple_matches m p \<Longrightarrow>
    simple_fw (removeAll (SimpleRule m a) rs) p = simple_fw rs p"
    apply(induction rs p rule: simple_fw.induct)
      apply(simp)
     apply(simp_all)
     apply blast+
    done

subsection\<open>Reality check: Validity of Simple Matches\<close>
  text\<open>While it is possible to construct a @{text "simple_fw"} expression that only matches a source
  or destination port, such a match is not meaningful, as the presence of the port information is
  dependent on the protocol. Thus, a match for a port should always include the match for a protocol.
  Additionally, prefixes should be zero on bits beyond the prefix length.
  \<close>

  definition "valid_prefix_fw m = valid_prefix (uncurry PrefixMatch m)"

  lemma ipcidr_conjunct_valid:
    "\<lbrakk>valid_prefix_fw p1; valid_prefix_fw p2; ipcidr_conjunct p1 p2 = Some p\<rbrakk> \<Longrightarrow> valid_prefix_fw p"
    unfolding valid_prefix_fw_def
    by(cases p; cases p1; cases p2) (simp add: ipcidr_conjunct.simps split: if_splits)

  definition simple_match_valid :: "('i::len, 'a) simple_match_scheme \<Rightarrow> bool" where
    "simple_match_valid m \<equiv>
    ({p. simple_match_port (sports m) p} \<noteq> UNIV \<or> {p. simple_match_port (dports m) p} \<noteq> UNIV \<longrightarrow>
        proto m \<in> Proto `{TCP, UDP, L4_Protocol.SCTP}) \<and>
    valid_prefix_fw (src m) \<and> valid_prefix_fw (dst m)"

  lemma simple_match_valid_alt[code_unfold]: "simple_match_valid = (\<lambda> m.
    (let c = (\<lambda>(s,e). (s \<noteq> 0 \<or> e \<noteq> max_word)) in (
    if c (sports m) \<or> c (dports m) then proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP else True)) \<and>
  valid_prefix_fw (src m) \<and> valid_prefix_fw (dst m))"
  proof -
    have simple_match_valid_alt_hlp1: "{p. simple_match_port x p} \<noteq> UNIV \<longleftrightarrow> (case x of (s,e) \<Rightarrow> s \<noteq> 0 \<or> e \<noteq> max_word)"
      for x using simple_match_port_UNIV by auto
    have simple_match_valid_alt_hlp2: "{p. simple_match_port x p} \<noteq> {} \<longleftrightarrow> (case x of (s,e) \<Rightarrow> s \<le> e)" for x by auto
    show ?thesis
      unfolding fun_eq_iff
      unfolding simple_match_valid_def Let_def
      unfolding simple_match_valid_alt_hlp1 simple_match_valid_alt_hlp2
      apply(clarify, rename_tac m, case_tac "sports m"; case_tac "dports m"; case_tac "proto m")
       by auto
  qed

  text\<open>Example:\<close>
  context
  begin
    private definition "example_simple_match1 \<equiv>
      \<lparr>iiface = Iface ''+'', oiface = Iface ''+'', src = (0::32 word, 0), dst = (0, 0),
       proto = Proto TCP, sports = (0, 1024), dports = (0, 1024)\<rparr>"

    lemma "simple_fw [SimpleRule example_simple_match1 Drop]
      \<lparr>p_iiface = '''', p_oiface = '''',  p_src = (1::32 word), p_dst = 2, p_proto = TCP, p_sport = 8,
       p_dport = 9, p_tcp_flags = {}, p_payload = ''''\<rparr> =
        Decision FinalDeny" by eval

    private definition "example_simple_match2 \<equiv> example_simple_match1\<lparr> proto := ProtoAny \<rparr>"
    text\<open>Thus, @{text "example_simple_match1"} is valid, but if we set its protocol match to any, it isn't anymore\<close>
    private lemma "simple_match_valid example_simple_match1" by eval
    private lemma "\<not> simple_match_valid example_simple_match2" by eval
  end

  lemma simple_match_and_valid:
    fixes m1 :: "'i::len simple_match"
    assumes mv: "simple_match_valid m1" "simple_match_valid m2"
    assumes mj: "simple_match_and m1 m2 = Some m"
    shows "simple_match_valid m"
  proof -
    have simpl_ports_conjunct_not_UNIV:
    "Collect (simple_match_port x) \<noteq> UNIV \<Longrightarrow>
      x = simpl_ports_conjunct p1 p2 \<Longrightarrow>
      Collect (simple_match_port p1) \<noteq> UNIV \<or> Collect (simple_match_port p2) \<noteq> UNIV"
    for x p1 p2 by (metis Collect_cong mem_Collect_eq simple_ports_conjunct_correct)

    (* prefix validity. That's simple. *)
    have "valid_prefix_fw (src m1)" "valid_prefix_fw (src m2)" "valid_prefix_fw (dst m1)" "valid_prefix_fw (dst m2)"
      using mv unfolding simple_match_valid_alt by simp_all
    moreover have "ipcidr_conjunct (src m1) (src m2) = Some (src m)"
                  "ipcidr_conjunct (dst m1) (dst m2) = Some (dst m)"
      using mj by(cases m1; cases m2; cases m; simp split: option.splits)+
    ultimately have pv: "valid_prefix_fw (src m)" "valid_prefix_fw (dst m)"
      using ipcidr_conjunct_valid by blast+

    (* now for the source ports\<dots> *)
    def nmu \<equiv> "\<lambda>ps. {p. simple_match_port ps p} \<noteq> UNIV"
    have "simpl_ports_conjunct (sports m1) (sports m2) = (sports m)" (is "?ph1 sports")
      using mj by(cases m1; cases m2; cases m; simp split: option.splits)
    hence sp: "nmu (sports m) \<longrightarrow> nmu (sports m1) \<or> nmu (sports m2)"
      (is "?ph2 sports")
      unfolding nmu_def using simpl_ports_conjunct_not_UNIV by metis

    (* dst ports: mutatis mutandem *)
    have "?ph1 dports" using mj by(cases m1; cases m2; cases m; simp split: option.splits)
    hence dp: "?ph2 dports" unfolding nmu_def using simpl_ports_conjunct_not_UNIV by metis

    (* And an argument for the protocol. *)
    def php \<equiv> "\<lambda>mr :: 'i simple_match. proto mr \<in> Proto ` {TCP, UDP, L4_Protocol.SCTP}"
    have pcj: "simple_proto_conjunct (proto m1) (proto m2) = Some (proto m)"
      using mj by(cases m1; cases m2; cases m; simp split: option.splits)
    hence p: "php m1 \<Longrightarrow> php m"
             "php m2 \<Longrightarrow> php m"
      using conjunctProtoD conjunctProtoD2 pcj unfolding php_def by auto

    (* Since I'm trying to trick the simplifier with these defs, I need these as explicit statements: *)
    have "\<And>mx. simple_match_valid mx \<Longrightarrow> nmu (sports mx) \<or> nmu (dports mx) \<Longrightarrow> php mx"
      unfolding nmu_def php_def simple_match_valid_def by blast
    hence mps: "nmu (sports m1) \<Longrightarrow> php m1" "nmu (dports m1) \<Longrightarrow> php m1"
               "nmu (sports m2) \<Longrightarrow> php m2" "nmu (dports m2) \<Longrightarrow> php m2" using mv by blast+

    have pa: "nmu (sports m) \<or> nmu (dports m) \<longrightarrow> php m"
    (*  apply(intro impI)
      apply(elim disjE)
      apply(drule sp[THEN mp])
      apply(elim disjE)
      apply(drule mps)
      apply(elim p; fail) *)
      using sp dp mps p by fast

    show ?thesis
      unfolding simple_match_valid_def
      using pv pa[unfolded nmu_def php_def] by blast
  qed

  definition "simple_fw_valid \<equiv> list_all (simple_match_valid \<circ> match_sel)"

text{*The simple firewall does not care about tcp flags, payload, or any other packet extensions.*}
lemma simple_matches_extended_packet:
      "simple_matches m
        \<lparr>p_iiface = iifce,
         oiface = oifce,
         p_src = s, dst = d,
         p_proto = prot,
         p_sport = sport, p_dport = dport,
         tcp_flags = tcp_flags, p_payload = payload1\<rparr>
        \<longleftrightarrow>
       simple_matches m
        \<lparr>p_iiface = iifce,
         oiface = oifce,
         p_src = s, p_dst = d,
         p_proto = prot,
         p_sport = sport, p_dport = dport,
         p_tcp_flags = tcp_flags2, p_payload = payload2, \<dots> = aux\<rparr>
        "
  by(simp add: simple_matches.simps)
end


theory weird_nat_mul3_rrot
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S y2) z = S (add3 Z y2 z)"
| "add3 (S x2) y z = S (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
"mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3 (S (Z)) (S (Z)) (S (S x5)) =
     S (add3
          (mul3 Z Z (S x5))
          (add3 (mul3 (S Z) Z (S x5)) (mul3 Z (S Z) (S x5)) (mul3 Z Z (S Z)))
          (add3 Z Z (S x5)))"
| "mul3 (S (Z)) (S (S x6)) (S x4) =
     S (add3
          (mul3 Z (S x6) x4)
          (add3
             (mul3 (S Z) (S x6) x4) (mul3 Z (S Z) x4) (mul3 Z (S x6) (S Z)))
          (add3 Z (S x6) x4))"
| "mul3 (S (S x7)) (S x3) (S x4) =
     S (add3
          (mul3 (S x7) x3 x4)
          (add3
             (mul3 (S Z) x3 x4) (mul3 (S x7) (S Z) x4) (mul3 (S x7) x3 (S Z)))
          (add3 (S x7) x3 x4))"

(*hipster add3 mul3 *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) . (mul3 x y z) = (mul3 z x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end