section {*FUNCTION\_\_FRESH*}
theory
  FUNCTION__FRESH

imports
  PRJ_12_02__ENTRY

begin

lemma infinite_symbol_set: "
  inj_on f (UNIV::nat set)
  \<Longrightarrow> f ` (UNIV::nat set) \<subseteq> (UNIV::'a DT_symbol set)
  \<Longrightarrow> \<not> (finite (UNIV:: ('a DT_symbol) set))"
  apply (metis finite_vimageI infinite_UNIV_nat vimage_UNIV)
  done

lemma inj_on_exists: "
  finite A
  \<Longrightarrow> \<exists>f::'x \<Rightarrow> 'a DT_symbol. inj_on f A"
  apply(rule_tac
      B = "(UNIV::'a DT_symbol set)"
      in inj_on_from_infinite_set)
   apply(force)
  apply(rule_tac
      f = "cons_symbol_nat"
      in infinite_symbol_set)
   apply(simp add: inj_on_def)
  apply(force)
  done

theorem SOME_injective_is_injective: "
  finite A
  \<Longrightarrow> inj_on (SOME f::'x\<Rightarrow>'a DT_symbol. inj_on f A) A"
  apply(subgoal_tac "\<exists>f::'x \<Rightarrow> 'a DT_symbol. inj_on f A")
   prefer 2
   apply(rule inj_on_exists)
   apply(force)
  apply(clarsimp)
  apply(rename_tac f)(*strict*)
  apply(rule_tac
      P = "\<lambda>f. inj_on f A"
      in someI_ex)
  apply(rule_tac
      x = "f"
      in exI)
  apply(force)
  done

theorem exists_SOME_injective_is_injective: "
  finite A
  \<Longrightarrow> \<exists>f. inj_on f A \<and> f = (SOME f::'x\<Rightarrow>'a DT_symbol. inj_on f A)"
  apply(rule_tac
      x = "(SOME f::'x\<Rightarrow>'a DT_symbol. inj_on f A)"
      in exI)
  apply(clarsimp)
  apply(rule SOME_injective_is_injective)
  apply(force)
  done

lemma symbol_annotate_makesInfinite: "
  \<not> (finite {cons_symbol_nat n | n. True})"
  apply(case_tac "\<not>(finite {cons_symbol_nat n| n. True})")
   apply(clarsimp)
   apply(subgoal_tac "False")
    apply(clarify)
   apply(force)
  apply(subgoal_tac "finite ((\<lambda>n. cons_symbol_nat n) -` ({cons_symbol_nat n |n. True}))")
   apply(force)
  apply(rule Finite_Set.finite_vimageI)
   apply(force)
  apply(rule injI)
  apply(rename_tac x y)(*strict*)
  apply(clarsimp)
  done

lemma new_elem_exists: "
  finite Q
  \<Longrightarrow> \<exists>n. cons_symbol_nat n \<notin> Q"
  apply(case_tac "\<exists>n. cons_symbol_nat n \<notin> Q")
   apply(clarsimp)
  apply(subgoal_tac "False")
   apply(auto)
  apply(subgoal_tac "\<not>(finite Q)")
   apply(clarsimp)
  apply(rule_tac
      A = "{cons_symbol_nat n| n. True}"
      in notFinite_subset)
   apply(metis symbol_annotate_makesInfinite)
  apply(auto)
  done

lemma F_FRESH__recursive_termination: "
  finite Q
  \<Longrightarrow> F_FRESH__recursive_dom (Q, n)"
  apply(subgoal_tac "\<exists>m. cons_symbol_nat m \<notin> (Q\<union>{cons_symbol_nat k| k. k < n})")
   prefer 2
   apply(rule_tac new_elem_exists)
   apply(clarsimp)
  apply(clarsimp)
  apply(rename_tac m)(*strict*)
  apply(rename_tac k)
  apply(rename_tac k)(*strict*)
  apply(rule_tac
      TERM_ARGS_TEST = "\<lambda>(Q,n). finite Q \<and> cons_symbol_nat k \<notin> Q \<and> \<not>k < n"
      and RECURSIVE_COND = "\<lambda>(Q,n). (cons_symbol_nat n)\<in> Q"
      and MODIFY_ARGS_FOR_REC_CALL = "\<lambda>(Q,n). (Q,Suc n)"
      and MEASURE = "\<lambda>(Q,n). (Suc k) - n"
      in partial_termination_wf)
      apply(rename_tac k)(*strict*)
      apply(auto)
    apply(rename_tac k a b)(*strict*)
    apply(subgoal_tac "b = k")
     apply(rename_tac k a b)(*strict*)
     apply(clarsimp)
    apply(rename_tac k a b)(*strict*)
    apply(arith)
   apply(rename_tac k a b)(*strict*)
   apply(thin_tac "finite Q")
   apply(thin_tac "cons_symbol_nat k \<notin> Q")
   apply(thin_tac "\<not> k < b")
   apply(rule_tac F_FRESH__recursive.domintros)
   apply(blast)
  apply(rule_tac F_FRESH__recursive.domintros)
  apply(force)
  done

lemma F_FRESH__recursive_is_F_FRESH__recursive: "
  finite Q
  \<Longrightarrow> F_FRESH__recursive Q n \<notin> Q"
  apply(subgoal_tac "\<exists>m. cons_symbol_nat m \<notin> (Q\<union>{cons_symbol_nat k| k. k < n})")
   prefer 2
   apply(rule_tac new_elem_exists)
   defer
   apply(erule exE)
   apply(rename_tac m)(*strict*)
   apply(rename_tac k)
   apply(rename_tac k)(*strict*)
   apply(subgoal_tac "(\<lambda>(Q,n). F_FRESH__recursive Q n \<notin> Q)(Q,n)")
    apply(rename_tac k)(*strict*)
    apply(force)
   apply(rename_tac k)(*strict*)
   apply(rule_tac
      TERM_ARGS_TEST = "\<lambda>(Q,n). finite Q \<and> cons_symbol_nat k \<notin> Q \<and> \<not>k < n"
      and RECURSIVE_COND = "\<lambda>(Q,n). (cons_symbol_nat n)\<in> Q"
      and MODIFY_ARGS_FOR_REC_CALL = "\<lambda>(Q,n). (Q,Suc n)"
      and MEASURE = "\<lambda>(Q,n). (Suc k) - n"
      and TERM_FUN = "\<lambda>(Q,n). F_FRESH__recursive Q n \<notin> Q"
      and y = "(Q,n)"
      in partial_termination_wf)
       apply(rename_tac k)(*strict*)
       apply(auto)
    apply(rename_tac k a b)(*strict*)
    apply(subgoal_tac "b = k")
     apply(rename_tac k a b)(*strict*)
     apply(clarsimp)
    apply(rename_tac k a b)(*strict*)
    apply(arith)
   apply(rename_tac k a b)(*strict*)
   apply(thin_tac "finite Q")
   apply(thin_tac "\<not> k < n")
   defer
   apply(rename_tac k a b)(*strict*)
   apply(thin_tac "finite Q")
   apply(thin_tac "cons_symbol_nat k \<notin> Q")
   apply(thin_tac "\<not> k < n")
   apply(rename_tac Q n)
   apply(rename_tac k Q n)(*strict*)
   apply(subgoal_tac "F_FRESH__recursive Q n \<notin> Q")
    apply(rename_tac k Q n)(*strict*)
    apply(blast)
   apply(rename_tac k Q n)(*strict*)
   apply(rule_tac
      t = "F_FRESH__recursive Q n"
      and s = "(if cons_symbol_nat n \<notin> Q then cons_symbol_nat n else F_FRESH__recursive Q (Suc n))"
      in ssubst)
    apply(rename_tac k Q n)(*strict*)
    apply(rule F_FRESH__recursive.psimps)
    apply(rule F_FRESH__recursive_termination)
    apply(blast)
   apply(rename_tac k Q n)(*strict*)
   apply(clarsimp)
  apply(thin_tac "cons_symbol_nat k \<notin> Q")
  apply(rename_tac k Q n)(*strict*)
  apply(subgoal_tac "F_FRESH__recursive Q n \<notin> Q")
   apply(rename_tac k Q n)(*strict*)
   apply(blast)
  apply(rename_tac k Q n)(*strict*)
  apply(rule_tac
      t = "F_FRESH__recursive Q n"
      and s = "(if cons_symbol_nat n \<notin> Q then cons_symbol_nat n else F_FRESH__recursive Q (Suc n))"
      in ssubst)
   apply(rename_tac k Q n)(*strict*)
   apply(rule F_FRESH__recursive.psimps)
   apply(rule F_FRESH__recursive_termination)
   apply(blast)
  apply(rename_tac k Q n)(*strict*)
  apply(clarsimp)
  done

theorem F_FRESH_is_fresh: "
  finite Q
  \<Longrightarrow> F_FRESH Q \<notin> Q"
  apply(simp add: F_FRESH_def)
  apply(metis F_FRESH__recursive_is_F_FRESH__recursive)
  done

end


theory T30
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Semantics
  imports Main
begin

section \<open>Semantics\<close>

text \<open>
Define the small-step semantics for a simple While language.
\<close>

subsection \<open> Syntax \<close>

datatype 'a Stmt =
  Skip
  | Basic "'a"
  | Seq "'a Stmt" "'a Stmt" (infixr ";;" 80)
  | Choice "'a Stmt" "'a Stmt" (infixr "\<sqinter>" 150)
  | Loop "'a Stmt" ("_*" [100] 150)
  | Parallel "'a Stmt" "'a Stmt"  (infixr "||" 150)

subsection \<open> Semantics \<close>

inductive_set prog :: "('a Stmt \<times> 'a \<times> 'a Stmt) set"
  and prog_abv :: "'a Stmt \<Rightarrow> 'a \<Rightarrow> 'a Stmt \<Rightarrow> bool"
  ("_ \<mapsto>\<^sub>_ _" [11,0,0] 70)
  where
  "c \<mapsto>\<^sub>\<alpha> c' \<equiv> (c, \<alpha>, c') \<in> prog" |
  act[intro]:  "Basic \<alpha> \<mapsto>\<^sub>\<alpha> Skip" |
  seq[intro]:  "c\<^sub>1 \<mapsto>\<^sub>\<alpha> c\<^sub>1' \<Longrightarrow> c\<^sub>1 ;; c\<^sub>2 \<mapsto>\<^sub>\<alpha> c\<^sub>1' ;; c\<^sub>2" |
  par1[intro]: "c\<^sub>1 \<mapsto>\<^sub>\<alpha> c\<^sub>1' \<Longrightarrow> c\<^sub>1 || c\<^sub>2 \<mapsto>\<^sub>\<alpha> c\<^sub>1' || c\<^sub>2" |
  par2[intro]: "c\<^sub>2 \<mapsto>\<^sub>\<alpha> c\<^sub>2' \<Longrightarrow> c\<^sub>1 || c\<^sub>2 \<mapsto>\<^sub>\<alpha> c\<^sub>1 || c\<^sub>2'"

fun unroll
  where "unroll 0 c = Skip" | "unroll (Suc n) c = c ;; unroll n c"

inductive_set rw :: "('a Stmt \<times> 'a Stmt) set"
  and rw_abv :: "'a Stmt \<Rightarrow> 'a Stmt \<Rightarrow> bool"
  ("_ \<leadsto> _" [11,0] 70)
  where
  "c \<leadsto> c' \<equiv> (c, c') \<in> rw" |
  seq[intro]:   "c\<^sub>1 \<leadsto> c\<^sub>1' \<Longrightarrow> c\<^sub>1 ;; c\<^sub>2 \<leadsto> c\<^sub>1' ;; c\<^sub>2" |
  seqE[intro]:  "Skip ;; c\<^sub>1 \<leadsto> c\<^sub>1" |
  left[intro]:  "c\<^sub>1 \<sqinter> c\<^sub>2 \<leadsto> c\<^sub>1" |
  right[intro]: "c\<^sub>1 \<sqinter> c\<^sub>2 \<leadsto> c\<^sub>2" |
  loop[intro]:  "c* \<leadsto> unroll n c" |
  par1[intro]:  "c\<^sub>1 \<leadsto> c\<^sub>1' \<Longrightarrow> c\<^sub>1 || c\<^sub>2 \<leadsto> c\<^sub>1' || c\<^sub>2" |
  par2[intro]:  "c\<^sub>2 \<leadsto> c\<^sub>2' \<Longrightarrow> c\<^sub>1 || c\<^sub>2 \<leadsto> c\<^sub>1 || c\<^sub>2'" |
  parE1[intro]: "Skip || c \<leadsto> c" |
  parE2[intro]: "c || Skip \<leadsto> c"

subsection \<open>Elimination Properties\<close>

lemma prog_skipE [elim]:
  assumes "Skip \<mapsto>\<^sub>\<alpha> c"
  obtains "False"
  using assms by (blast elim: prog.cases)

lemma rw_skipE [elim]:
  assumes "Skip \<leadsto> c"
  obtains "False"
  using assms by (blast elim: rw.cases)

lemma prog_actE [elim]:
  assumes "Basic \<alpha> \<mapsto>\<^sub>\<beta> c"
  obtains "\<beta> = \<alpha>" "c = Skip"
  using assms by (blast elim: prog.cases)

lemma rw_actE [elim]:
  assumes "Basic \<alpha> \<leadsto> c"
  obtains "False"
  using assms by (blast elim: rw.cases)

lemma prog_seqE [elim]:
  assumes "c\<^sub>1 ;; c\<^sub>2 \<mapsto>\<^sub>\<alpha> c\<^sub>3"
  obtains c\<^sub>1' where "c\<^sub>1 \<mapsto>\<^sub>\<alpha> c\<^sub>1'" "c\<^sub>3 = c\<^sub>1' ;; c\<^sub>2"
  using assms by (blast elim: prog.cases)

lemma rw_seqE [elim]:
  assumes "c\<^sub>1 ;; c\<^sub>2 \<leadsto> c\<^sub>3"
  obtains c\<^sub>1' where "c\<^sub>1 \<leadsto> c\<^sub>1'" "c\<^sub>3 = c\<^sub>1' ;; c\<^sub>2" | "c\<^sub>1 = Skip" "c\<^sub>2 = c\<^sub>3"
  using assms by (blast elim: rw.cases)

lemma prog_choiceE [elim]:
  assumes "c\<^sub>1 \<sqinter> c\<^sub>2 \<mapsto>\<^sub>\<alpha> c\<^sub>3"
  obtains "False"
  using assms by (blast elim: prog.cases)

lemma rw_choiceE [elim]:
  assumes "c\<^sub>1 \<sqinter> c\<^sub>2 \<leadsto> c\<^sub>3"
  obtains (left) "c\<^sub>1 = c\<^sub>3" | (right) "c\<^sub>2 = c\<^sub>3"
  using assms by (blast elim: rw.cases)

lemma prog_loopE [elim]:
  assumes "c\<^sub>1* \<mapsto>\<^sub>\<beta> c\<^sub>2"
  obtains "False"
  using assms by (blast elim: prog.cases)

lemma rw_loopE [elim]:
  assumes "c\<^sub>1* \<leadsto> c\<^sub>2"
  obtains n where "c\<^sub>2 = unroll n c\<^sub>1"
  using assms by (blast elim: rw.cases)

lemma prog_parE [elim]:
  assumes "c\<^sub>1 || c\<^sub>2 \<mapsto>\<^sub>\<beta> c\<^sub>3"
  obtains (par1) c\<^sub>1' where "c\<^sub>1 \<mapsto>\<^sub>\<beta> c\<^sub>1'" "c\<^sub>3 = c\<^sub>1' || c\<^sub>2" |
          (par2) c\<^sub>2' where "c\<^sub>2 \<mapsto>\<^sub>\<beta> c\<^sub>2'" "c\<^sub>3 = c\<^sub>1 || c\<^sub>2'"
  using assms by (blast elim: prog.cases)

lemma rw_parE [elim]:
  assumes "c\<^sub>1 || c\<^sub>2 \<leadsto> c\<^sub>3"
  obtains (par1) c\<^sub>1' where "c\<^sub>1 \<leadsto> c\<^sub>1'" "c\<^sub>3 = c\<^sub>1' || c\<^sub>2" |
          (par2) c\<^sub>2' where "c\<^sub>2 \<leadsto> c\<^sub>2'" "c\<^sub>3 = c\<^sub>1 || c\<^sub>2'" |
          (par1E) "c\<^sub>1 = Skip" "c\<^sub>3 = c\<^sub>2" |
          (par2E) "c\<^sub>2 = Skip" "c\<^sub>3 = c\<^sub>1"
  using assms by (blast elim: rw.cases)

end


(* Author: Gerwin Klein, Tobias Nipkow *)

theory Big_Step imports Com begin

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

text{* An automatic example: *}

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text {* This proof is automatic. *}

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

text {*
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
*}
text_raw{*\snip{BigStepDetLong}{0}{2}{% *}
theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  -- "the only interesting case, @{text WhileTrue}:"
  fix b c s s\<^sub>1 t t'
  -- "The assumptions of the rule:"
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  -- {* Ind.Hyp; note the @{text"\<And>"} because of arbitrary: *}
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  -- "Premise of implication:"
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with `bval b s` obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ -- "prove the rest automatically"
text_raw{*}%endsnip*}

end


(* Title: PRF_UPF_IND_CCA.thy
  Author: Andreas Lochbihler, ETH Zurich
  Author: S. Reza Sefidgar, ETH Zurich *)

subsection \<open>IND-CCA from a PRF and an unpredictable function\<close>

theory PRF_UPF_IND_CCA
imports
  Pseudo_Random_Function
  CryptHOL.List_Bits
  Unpredictable_Function
  IND_CCA2_sym
  CryptHOL.Negligible
begin

text \<open>Formalisation of Shoup's construction of an IND-CCA secure cipher from a PRF and an unpredictable function \cite[\S 7]{Shoup2004IACR}.\<close>

type_synonym bitstring = "bool list"

locale simple_cipher =
  PRF: "prf" prf_key_gen prf_fun "spmf_of_set (nlists UNIV prf_clen)" +
  UPF: upf upf_key_gen upf_fun
  for prf_key_gen :: "'prf_key spmf"
  and prf_fun :: "'prf_key \<Rightarrow> bitstring \<Rightarrow> bitstring"
  and prf_domain :: "bitstring set"
  and prf_range :: "bitstring set"
  and prf_dlen :: nat
  and prf_clen :: nat
  and upf_key_gen :: "'upf_key spmf"
  and upf_fun :: "'upf_key \<Rightarrow> bitstring \<Rightarrow> 'hash"
  +
  assumes prf_domain_finite: "finite prf_domain"
  assumes prf_domain_nonempty: "prf_domain \<noteq> {}"
  assumes prf_domain_length:  "x \<in> prf_domain \<Longrightarrow> length x = prf_dlen"
  assumes prf_codomain_length:
    "\<lbrakk> key_prf \<in> set_spmf prf_key_gen; m \<in> prf_domain \<rbrakk> \<Longrightarrow> length (prf_fun key_prf m) = prf_clen"
  assumes prf_key_gen_lossless: "lossless_spmf prf_key_gen"
  assumes upf_key_gen_lossless: "lossless_spmf upf_key_gen"
begin

type_synonym 'hash' cipher_text = "bitstring \<times> bitstring \<times> 'hash'"

definition key_gen :: "('prf_key \<times> 'upf_key) spmf" where
 "key_gen = do {
   k_prf \<leftarrow> prf_key_gen;
   k_upf :: 'upf_key \<leftarrow> upf_key_gen;
   return_spmf (k_prf, k_upf)
 }"

lemma lossless_key_gen [simp]: "lossless_spmf key_gen"
  by(simp add: key_gen_def prf_key_gen_lossless upf_key_gen_lossless)

fun encrypt :: "('prf_key \<times> 'upf_key) \<Rightarrow> bitstring \<Rightarrow> 'hash cipher_text spmf"
where
  "encrypt (k_prf, k_upf) m = do {
    x \<leftarrow> spmf_of_set prf_domain;
    let c = prf_fun k_prf x [\<oplus>] m;
    let t = upf_fun k_upf (x @ c);
    return_spmf ((x, c, t))
  }"

lemma lossless_encrypt [simp]: "lossless_spmf (encrypt k m)"
  by (cases k) (simp add: Let_def prf_domain_nonempty prf_domain_finite split: bool.split)

fun decrypt :: "('prf_key \<times> 'upf_key) \<Rightarrow> 'hash cipher_text \<Rightarrow> bitstring option"
where
  "decrypt (k_prf, k_upf) (x, c, t) = (
    if upf_fun k_upf (x @ c) = t \<and> length x = prf_dlen then
      Some (prf_fun k_prf x [\<oplus>] c)
    else
      None
  )"

lemma cipher_correct:
  "\<lbrakk> k \<in> set_spmf key_gen; length m = prf_clen \<rbrakk>
  \<Longrightarrow> encrypt k m \<bind> (\<lambda>c. return_spmf (decrypt k c)) = return_spmf (Some m)"
by (cases k) (simp add: prf_domain_nonempty prf_domain_finite prf_domain_length
  prf_codomain_length key_gen_def bind_eq_return_spmf Let_def)

declare encrypt.simps[simp del]

sublocale ind_cca: ind_cca key_gen encrypt decrypt "\<lambda>m. length m = prf_clen" .
interpretation ind_cca': ind_cca key_gen encrypt "\<lambda> _ _. None" "\<lambda>m. length m = prf_clen" .

definition intercept_upf_enc
  :: "'prf_key \<Rightarrow> bool \<Rightarrow> 'hash cipher_text set \<times> 'hash cipher_text set \<Rightarrow> bitstring \<times> bitstring
  \<Rightarrow> ('hash cipher_text option \<times> ('hash cipher_text set \<times> 'hash cipher_text set),
     bitstring + (bitstring \<times> 'hash), 'hash + unit) gpv"
where
  "intercept_upf_enc k b = (\<lambda>(L, D) (m1, m0).
    (case (length m1 = prf_clen \<and> length m0 = prf_clen) of
      False \<Rightarrow> Done (None, L, D)
    | True \<Rightarrow> do {
        x \<leftarrow> lift_spmf (spmf_of_set prf_domain);
        let c = prf_fun k x [\<oplus>] (if b then m1 else m0);
        t \<leftarrow> Pause (Inl (x @ c)) Done;
        Done ((Some (x, c, projl t)), (insert (x, c, projl t) L, D))
      }))"

definition intercept_upf_dec
  :: "'hash cipher_text set \<times> 'hash cipher_text set \<Rightarrow> 'hash cipher_text
  \<Rightarrow> (bitstring option \<times> ('hash cipher_text set \<times> 'hash cipher_text set),
     bitstring + (bitstring \<times> 'hash), 'hash + unit) gpv"
where
  "intercept_upf_dec = (\<lambda>(L, D) (x, c, t).
    if (x, c, t) \<in> L \<or> length x \<noteq> prf_dlen then Done (None, (L, D)) else do {
      Pause (Inr (x @ c, t)) Done;
      Done (None, (L, insert (x, c, t) D))
    })"

definition intercept_upf ::
  "'prf_key \<Rightarrow> bool \<Rightarrow> 'hash cipher_text set \<times> 'hash cipher_text set \<Rightarrow> bitstring \<times> bitstring + 'hash cipher_text
  \<Rightarrow> (('hash cipher_text option + bitstring option) \<times> ('hash cipher_text set \<times> 'hash cipher_text set),
     bitstring + (bitstring \<times> 'hash), 'hash + unit) gpv"
where
  "intercept_upf k b = plus_intercept (intercept_upf_enc k b) intercept_upf_dec"

lemma intercept_upf_simps [simp]:
  "intercept_upf k b (L, D) (Inr (x, c, t)) =
    (if (x, c, t) \<in> L \<or> length x \<noteq> prf_dlen then Done (Inr None, (L, D)) else do {
      Pause (Inr (x @ c, t)) Done;
      Done (Inr None, (L, insert (x, c, t) D))
    })"
  "intercept_upf k b (L, D) (Inl (m1, m0)) =
    (case (length m1 = prf_clen \<and> length m0 = prf_clen) of
      False \<Rightarrow> Done (Inl None, L, D)
    | True \<Rightarrow> do {
        x \<leftarrow> lift_spmf (spmf_of_set prf_domain);
        let c = prf_fun k x [\<oplus>] (if b then m1 else m0);
        t \<leftarrow> Pause (Inl (x @ c)) Done;
        Done (Inl (Some (x, c, projl t)), (insert (x, c, projl t) L, D))
      })"
   by(simp_all add: intercept_upf_def intercept_upf_dec_def intercept_upf_enc_def o_def map_gpv_bind_gpv gpv.map_id Let_def split!: bool.split)

lemma interaction_bounded_by_upf_enc_Inr [interaction_bound]:
  "interaction_bounded_by (Not \<circ> isl) (intercept_upf_enc k b LD mm) 0"
unfolding intercept_upf_enc_def case_prod_app
by(interaction_bound, clarsimp simp add: SUP_constant bot_enat_def split: prod.split)

lemma interaction_bounded_by_upf_dec_Inr [interaction_bound]:
  "interaction_bounded_by (Not \<circ> isl) (intercept_upf_dec LD c) 1"
unfolding intercept_upf_dec_def case_prod_app
by(interaction_bound, clarsimp simp add: SUP_constant split: prod.split)

lemma interaction_bounded_by_intercept_upf_Inr [interaction_bound]:
  "interaction_bounded_by (Not \<circ> isl) (intercept_upf k b LD x) 1"
unfolding intercept_upf_def
by interaction_bound(simp add: split_def one_enat_def SUP_le_iff split: sum.split)

lemma interaction_bounded_by_intercept_upf_Inl [interaction_bound]:
  "isl x \<Longrightarrow> interaction_bounded_by (Not \<circ> isl) (intercept_upf k b LD x) 0"
unfolding intercept_upf_def case_prod_app
by interaction_bound(auto split: sum.split)

lemma lossless_intercept_upf_enc [simp]: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf_enc k b LD mm)"
by(simp add: intercept_upf_enc_def split_beta prf_domain_finite prf_domain_nonempty Let_def split: bool.split)

lemma lossless_intercept_upf_dec [simp]: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf_dec LD mm)"
by(simp add: intercept_upf_dec_def split_beta)

lemma lossless_intercept_upf [simp]: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf k b LD x)"
by(cases x)(simp_all add: intercept_upf_def)

lemma results_gpv_intercept_upf [simp]: "results_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf k b LD x) \<subseteq> responses_\<I> (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) x \<times> UNIV"
by(cases x)(auto simp add: intercept_upf_def)

definition reduction_upf :: "(bitstring, 'hash cipher_text) ind_cca.adversary
  \<Rightarrow> (bitstring, 'hash) UPF.adversary"
where "reduction_upf \<A> = do {
    k \<leftarrow> lift_spmf prf_key_gen;
    b \<leftarrow> lift_spmf coin_spmf;
    (_, (L, D)) \<leftarrow> inline (intercept_upf k b) \<A> ({}, {});
    Done () }"

lemma lossless_reduction_upf [simp]:
  "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A> \<Longrightarrow> lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (reduction_upf \<A>)"
by(auto simp add: reduction_upf_def prf_key_gen_lossless intro: lossless_inline del: subsetI)

context includes lifting_syntax begin

lemma round_1:
  assumes "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  shows "\<bar>spmf (ind_cca.game \<A>) True - spmf (ind_cca'.game \<A>) True\<bar> \<le> UPF.advantage (reduction_upf \<A>)"
proof -
  define oracle_decrypt0' where "oracle_decrypt0' \<equiv> (\<lambda>key (bad, L) (x', c', t'). return_spmf (
      if (x', c', t') \<in> L \<or> length x' \<noteq> prf_dlen then (None, (bad, L))
      else (decrypt key (x', c', t'), (bad \<or> upf_fun (snd key) (x' @ c') = t', L))))"
  have oracle_decrypt0'_simps:
    "oracle_decrypt0' key (bad, L) (x', c', t') = return_spmf (
       if (x', c', t') \<in> L \<or> length x' \<noteq> prf_dlen then (None, (bad, L))
       else (decrypt key (x', c', t'), (bad \<or> upf_fun (snd key) (x' @ c') = t', L)))"
    for key L bad x' c' t' by(simp add: oracle_decrypt0'_def)
  have lossless_oracle_decrypt0' [simp]: "lossless_spmf (oracle_decrypt0' k Lbad c)" for k Lbad c
    by(simp add: oracle_decrypt0'_def split_def)
  have callee_invariant_oracle_decrypt0' [simp]: "callee_invariant (oracle_decrypt0' k) fst" for k
    by (unfold_locales) (auto simp add: oracle_decrypt0'_def split: if_split_asm)

  define oracle_decrypt1'
    where "oracle_decrypt1' = (\<lambda>(key :: 'prf_key \<times> 'upf_key) (bad, L) (x', c', t').
      return_spmf (None :: bitstring option,
        (bad \<or> upf_fun (snd key) (x' @ c') = t' \<and> (x', c', t') \<notin> L \<and> length x' = prf_dlen), L))"
  have oracle_decrypt1'_simps:
    "oracle_decrypt1' key (bad, L) (x', c', t') =
    return_spmf (None,
      (bad \<or> upf_fun (snd key) (x' @ c') = t' \<and> (x', c', t') \<notin> L \<and> length x' = prf_dlen, L))"
    for key L bad x' c' t' by(simp add: oracle_decrypt1'_def)
  have lossless_oracle_decrypt1' [simp]: "lossless_spmf (oracle_decrypt1' k Lbad c)" for k Lbad c
    by(simp add: oracle_decrypt1'_def split_def)
  have callee_invariant_oracle_decrypt1' [simp]: "callee_invariant (oracle_decrypt1' k) fst" for k
    by (unfold_locales) (auto simp add: oracle_decrypt1'_def)

  define game01'
    where "game01' = (\<lambda>(decrypt :: 'prf_key \<times> 'upf_key \<Rightarrow> (bitstring \<times> bitstring \<times> 'hash, bitstring option, bool \<times> (bitstring \<times> bitstring \<times> 'hash) set) callee) \<A>. do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', (bad', L')) \<leftarrow> exec_gpv (\<dagger>(ind_cca.oracle_encrypt key b) \<oplus>\<^sub>O decrypt key) \<A> (False, {});
    return_spmf (b = b', bad') })"
  let ?game0' = "game01' oracle_decrypt0'"
  let ?game1' = "game01' oracle_decrypt1'"

  have game0'_eq: "ind_cca.game \<A> = map_spmf fst (?game0' \<A>)" (is ?game0)
    and game1'_eq: "ind_cca'.game \<A> = map_spmf fst (?game1' \<A>)" (is ?game1)
  proof -
    let ?S = "rel_prod2 (=)"
    define initial where "initial = (False, {} :: 'hash cipher_text set)"
    have [transfer_rule]: "?S {} initial" by(simp add: initial_def)

    have [transfer_rule]:
      "((=) ===> ?S ===> (=) ===> rel_spmf (rel_prod (=) ?S))
       ind_cca.oracle_decrypt oracle_decrypt0'"
      unfolding ind_cca.oracle_decrypt_def[abs_def] oracle_decrypt0'_def[abs_def]
      by(simp add: rel_spmf_return_spmf1 rel_fun_def)

    have [transfer_rule]:
      "((=) ===> ?S ===> (=) ===> rel_spmf (rel_prod (=) ?S))
       ind_cca'.oracle_decrypt oracle_decrypt1'"
      unfolding ind_cca'.oracle_decrypt_def[abs_def] oracle_decrypt1'_def[abs_def]
      by (simp add: rel_spmf_return_spmf1 rel_fun_def)

    note [transfer_rule] = extend_state_oracle_transfer
    show ?game0 ?game1 unfolding game01'_def ind_cca.game_def ind_cca'.game_def initial_def[symmetric]
      by (simp_all add: map_spmf_bind_spmf o_def split_def) transfer_prover+
  qed

  have *: "rel_spmf (\<lambda>(b'1, (bad1, L1)) (b'2, (bad2, L2)). bad1 = bad2 \<and> (\<not> bad2 \<longrightarrow> b'1 = b'2))
         (exec_gpv (\<dagger>(ind_cca.oracle_encrypt k b) \<oplus>\<^sub>O oracle_decrypt1' k) \<A> (False, {}))
         (exec_gpv (\<dagger>(ind_cca.oracle_encrypt k b) \<oplus>\<^sub>O oracle_decrypt0' k) \<A> (False, {}))"
    for k b
    by (cases k; rule exec_gpv_oracle_bisim_bad[where X="(=)" and ?bad1.0=fst and ?bad2.0=fst and \<I> = "\<I>_full \<oplus>\<^sub>\<I> \<I>_full"])
       (auto intro: rel_spmf_reflI callee_invariant_extend_state_oracle_const' simp add: spmf_rel_map1 spmf_rel_map2 oracle_decrypt0'_simps oracle_decrypt1'_simps assms split: plus_oracle_split)
    \<comment> \<open>We cannot get rid of the losslessness assumption on @{term \<A>} in this step, because if it
      were not, then the bad event might still occur, but the adversary does not terminate in
      the case of @{term "?game1'"}. Thus, the reduction does not terminate either, but it cannot
      detect whether the bad event has happened. So the advantage in the UPF game could be lower than
      the probability of the bad event, if the adversary is not lossless.\<close>
  have "\<bar>measure (measure_spmf (?game1' \<A>)) {(b, bad). b} - measure (measure_spmf (?game0' \<A>)) {(b, bad). b}\<bar>
     \<le> measure (measure_spmf (?game1' \<A>)) {(b, bad). bad}"
    by (rule fundamental_lemma[where ?bad2.0=snd])(auto intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF *] simp add: game01'_def)
  also have "\<dots> = spmf (map_spmf snd (?game1' \<A>)) True"
    by (simp add: spmf_conv_measure_spmf measure_map_spmf split_def vimage_def)
  also have "map_spmf snd (?game1' \<A>) = UPF.game (reduction_upf \<A>)"
  proof -
    note [split del] = if_split
    have "map_spmf (\<lambda>x. fst (snd x)) (exec_gpv (\<dagger>(ind_cca.oracle_encrypt (k_prf, k_upf) b) \<oplus>\<^sub>O oracle_decrypt1' (k_prf, k_upf)) \<A> (False, {})) =
        map_spmf (\<lambda>x. fst (snd x)) (exec_gpv (UPF.oracle k_upf) (inline (intercept_upf k_prf b) \<A> ({}, {})) (False, {}))"
      (is "map_spmf ?fl ?lhs = map_spmf ?fr ?rhs" is "map_spmf _ (exec_gpv ?oracle_normal _ ?init_normal) = _")
      for k_prf k_upf b
    proof(rule map_spmf_eq_map_spmfI)
      define oracle_intercept
        where [simp]: "oracle_intercept = (\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, s', s))
         (exec_gpv (UPF.oracle k_upf) (intercept_upf k_prf b s' y) s))"
      let ?I = "(\<lambda>((L, D), (flg, Li)).
          (\<forall>(x, c, t) \<in> L. upf_fun k_upf (x @ c) = t \<and> length x = prf_dlen) \<and>
          (\<forall>e\<in>Li. \<exists>(x,c,_) \<in> L. e = x @ c) \<and>
          ((\<exists>(x, c, t) \<in> D. upf_fun k_upf (x @ c) = t) \<longleftrightarrow> flg))"
      interpret callee_invariant_on oracle_intercept "?I" \<I>_full
        apply(unfold_locales)
        subgoal for s x y s'
          apply(cases s; cases s'; cases x)
           apply(clarsimp simp add: set_spmf_of_set_finite[OF prf_domain_finite]
                UPF.oracle_hash_def prf_domain_length exec_gpv_bind Let_def split: bool.splits)
          apply(force simp add: exec_gpv_bind UPF.oracle_flag_def split: if_split_asm)
          done
        subgoal by simp
        done

      define S :: "bool \<times> 'hash cipher_text set \<Rightarrow> ('hash cipher_text set \<times> 'hash cipher_text set) \<times>  bool \<times> bitstring set \<Rightarrow> bool"
        where "S = (\<lambda>(bad, L1) ((L2, D), _). bad = (\<exists>(x, c, t)\<in>D. upf_fun k_upf (x @ c) = t) \<and> L1 = L2) \<upharpoonleft> (\<lambda>_. True) \<otimes> ?I"
      define initial :: "('hash cipher_text set \<times> 'hash cipher_text set) \<times>  bool \<times> bitstring set"
        where "initial = (({}, {}), (False, {}))"
      have [transfer_rule]: "S ?init_normal initial" by(simp add: S_def initial_def)
      have [transfer_rule]: "(S ===> (=) ===> rel_spmf (rel_prod (=) S)) ?oracle_normal oracle_intercept"
        unfolding S_def
        by(rule callee_invariant_restrict_relp, unfold_locales)
          (auto simp add: rel_fun_def bind_spmf_of_set prf_domain_finite prf_domain_nonempty bind_spmf_pmf_assoc bind_assoc_pmf bind_return_pmf spmf_rel_map exec_gpv_bind Let_def ind_cca.oracle_encrypt_def oracle_decrypt1'_def encrypt.simps UPF.oracle_hash_def UPF.oracle_flag_def bind_map_spmf o_def split: plus_oracle_split bool.split if_split intro!: rel_spmf_bind_reflI rel_pmf_bind_reflI)
      have "rel_spmf (rel_prod (=) S) ?lhs (exec_gpv oracle_intercept \<A> initial)"
        by(transfer_prover)
      then show "rel_spmf (\<lambda>x y. ?fl x = ?fr y) ?lhs ?rhs"
        by(auto simp add: S_def exec_gpv_inline spmf_rel_map initial_def elim: rel_spmf_mono)
    qed
    then show ?thesis including monad_normalisation
      by(auto simp add: reduction_upf_def UPF.game_def game01'_def key_gen_def map_spmf_conv_bind_spmf split_def exec_gpv_bind intro!: bind_spmf_cong[OF refl])
  qed
  finally show ?thesis using game0'_eq game1'_eq
    by (auto simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def fst_def UPF.advantage_def)
qed

definition oracle_encrypt2 ::
  "('prf_key \<times> 'upf_key) \<Rightarrow> bool \<Rightarrow> (bitstring, bitstring) PRF.dict \<Rightarrow> bitstring \<times> bitstring
    \<Rightarrow> ('hash cipher_text option \<times> (bitstring, bitstring) PRF.dict) spmf"
where
  "oracle_encrypt2 = (\<lambda>(k_prf, k_upf) b D (msg1, msg0). (case (length msg1 = prf_clen \<and> length msg0 = prf_clen) of
      False \<Rightarrow> return_spmf (None, D)
    | True \<Rightarrow> do {
        x \<leftarrow> spmf_of_set prf_domain;
        P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
        let p = (case D x of Some r \<Rightarrow> r | None \<Rightarrow> P);
        let c = p [\<oplus>] (if b then msg1 else msg0);
        let t = upf_fun k_upf (x @ c);
        return_spmf (Some (x, c, t), D(x \<mapsto> p))
      }))"

definition oracle_decrypt2:: "('prf_key \<times> 'upf_key) \<Rightarrow> ('hash cipher_text, bitstring option, 'state) callee"
where "oracle_decrypt2 = (\<lambda>key D cipher. return_spmf (None, D))"

lemma lossless_oracle_decrypt2 [simp]: "lossless_spmf (oracle_decrypt2 k Dbad c)"
  by(simp add: oracle_decrypt2_def split_def)

lemma callee_invariant_oracle_decrypt2 [simp]: "callee_invariant (oracle_decrypt2 key) fst"
  by (unfold_locales) (auto simp add: oracle_decrypt2_def split: if_split_asm)

lemma oracle_decrypt2_parametric [transfer_rule]:
  "(rel_prod P U ===> S ===> rel_prod (=) (rel_prod (=) H) ===> rel_spmf (rel_prod (=) S))
   oracle_decrypt2 oracle_decrypt2"
  unfolding oracle_decrypt2_def split_def relator_eq[symmetric] by transfer_prover

definition game2 :: "(bitstring, 'hash cipher_text) ind_cca.adversary \<Rightarrow> bool spmf"
where
  "game2 \<A> \<equiv> do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', D) \<leftarrow> exec_gpv
      (oracle_encrypt2 key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> Map_empty;
    return_spmf (b = b')
  }"

fun intercept_prf ::
  "'upf_key \<Rightarrow> bool \<Rightarrow> unit \<Rightarrow> (bitstring \<times> bitstring) + 'hash cipher_text
  \<Rightarrow> (('hash cipher_text option + bitstring option) \<times> unit, bitstring, bitstring) gpv"
where
  "intercept_prf _ _ _ (Inr _) = Done (Inr None, ())"
| "intercept_prf k b _ (Inl (m1, m0)) = (case (length m1) = prf_clen \<and> (length m0) = prf_clen of
      False \<Rightarrow> Done (Inl None, ())
    | True \<Rightarrow> do {
        x \<leftarrow> lift_spmf (spmf_of_set prf_domain);
        p \<leftarrow> Pause x Done;
        let c = p [\<oplus>] (if b then m1 else m0);
        let t = upf_fun k (x @ c);
        Done (Inl (Some (x, c, t)), ())
      })"

definition reduction_prf
  :: "(bitstring, 'hash cipher_text) ind_cca.adversary \<Rightarrow> (bitstring, bitstring) PRF.adversary"
where
 "reduction_prf \<A> = do {
   k \<leftarrow> lift_spmf upf_key_gen;
   b \<leftarrow> lift_spmf coin_spmf;
   (b', _) \<leftarrow> inline (intercept_prf k b) \<A> ();
   Done (b' = b)
 }"

lemma round_2: "\<bar>spmf (ind_cca'.game \<A>) True - spmf (game2 \<A>) True\<bar> = PRF.advantage (reduction_prf \<A>)"
proof -
  define oracle_encrypt1''
    where "oracle_encrypt1'' = (\<lambda>(k_prf, k_upf) b (_ :: unit) (msg1, msg0).
      case length msg1 = prf_clen \<and> length msg0 = prf_clen of
        False \<Rightarrow> return_spmf (None, ())
      | True \<Rightarrow> do {
          x \<leftarrow> spmf_of_set prf_domain;
          let p = prf_fun k_prf x;
          let c = p [\<oplus>] (if b then msg1 else msg0);
          let t = upf_fun k_upf (x @ c);
          return_spmf (Some (x, c, t), ())})"
  define game1'' where "game1'' = do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', D) \<leftarrow> exec_gpv (oracle_encrypt1'' key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> ();
    return_spmf (b = b')}"

  have "ind_cca'.game \<A> = game1''"
  proof -
    define S where "S = (\<lambda>(L :: 'hash cipher_text set) (D :: unit). True)"
    have [transfer_rule]: "S {} ()" by (simp add: S_def)
    have [transfer_rule]:
      "((=) ===> (=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
       ind_cca'.oracle_encrypt oracle_encrypt1''"
      unfolding ind_cca'.oracle_encrypt_def[abs_def] oracle_encrypt1''_def[abs_def]
      by (auto simp add: rel_fun_def Let_def S_def encrypt.simps prf_domain_finite prf_domain_nonempty intro: rel_spmf_bind_reflI rel_pmf_bind_reflI split: bool.split)
    have [transfer_rule]:
      "((=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
       ind_cca'.oracle_decrypt oracle_decrypt2"
      unfolding ind_cca'.oracle_decrypt_def[abs_def] oracle_decrypt2_def[abs_def]
      by(auto simp add: rel_fun_def)
    show ?thesis unfolding ind_cca'.game_def game1''_def by transfer_prover
  qed

  also have "\<dots> = PRF.game_0 (reduction_prf \<A>)"
  proof -
    { fix k_prf k_upf b
      define oracle_normal
        where "oracle_normal = oracle_encrypt1'' (k_prf, k_upf) b \<oplus>\<^sub>O oracle_decrypt2 (k_prf, k_upf)"
      define oracle_intercept
        where "oracle_intercept = (\<lambda>(s', s :: unit) y. map_spmf (\<lambda>((x, s'), s). (x, s', s)) (exec_gpv (PRF.prf_oracle k_prf) (intercept_prf k_upf b s' y) ()))"
      define initial where "initial = ()"
      define S where "S = (\<lambda>(s2 :: unit, _ :: unit) (s1 :: unit). True)"
      have [transfer_rule]: "S ((), ()) initial" by(simp add: S_def initial_def)
      have [transfer_rule]: "(S ===> (=) ===> rel_spmf (rel_prod (=) S)) oracle_intercept oracle_normal"
        unfolding oracle_normal_def oracle_intercept_def
        by(auto split: bool.split plus_oracle_split simp add: S_def rel_fun_def exec_gpv_bind PRF.prf_oracle_def oracle_encrypt1''_def Let_def map_spmf_conv_bind_spmf oracle_decrypt2_def intro!: rel_spmf_bind_reflI rel_spmf_reflI)
      have "map_spmf (\<lambda>x. b = fst x) (exec_gpv oracle_normal \<A> initial) =
        map_spmf (\<lambda>x. b = fst (fst x)) (exec_gpv (PRF.prf_oracle k_prf) (inline (intercept_prf k_upf b) \<A> ()) ())"
        by(transfer fixing: b \<A> prf_fun k_prf prf_domain prf_clen upf_fun k_upf)
          (auto simp add: map_spmf_eq_map_spmf_iff exec_gpv_inline spmf_rel_map oracle_intercept_def split_def intro: rel_spmf_reflI) }
    then show ?thesis unfolding game1''_def PRF.game_0_def key_gen_def reduction_prf_def
      by (auto simp add: exec_gpv_bind_lift_spmf exec_gpv_bind map_spmf_conv_bind_spmf split_def eq_commute intro!: bind_spmf_cong[OF refl])
  qed
  also have "game2 \<A> = PRF.game_1 (reduction_prf \<A>)"
  proof -
    note [split del] = if_split
    { fix k_upf b k_prf
      define oracle2
        where "oracle2 = oracle_encrypt2 (k_prf, k_upf) b \<oplus>\<^sub>O oracle_decrypt2 (k_prf, k_upf)"
      define oracle_intercept
        where "oracle_intercept = (\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, s', s)) (exec_gpv PRF.random_oracle (intercept_prf k_upf b s' y) s))"
      define S
        where "S = (\<lambda>(s2 :: unit, s2') (s1 :: (bitstring, bitstring) PRF.dict). s2' = s1)"

      have [transfer_rule]: "S ((), Map_empty) Map_empty" by(simp add: S_def)
      have [transfer_rule]: "(S ===> (=) ===> rel_spmf (rel_prod (=) S)) oracle_intercept oracle2"
        unfolding oracle2_def oracle_intercept_def
        by(auto split: bool.split plus_oracle_split option.split simp add: S_def rel_fun_def exec_gpv_bind PRF.random_oracle_def oracle_encrypt2_def Let_def map_spmf_conv_bind_spmf oracle_decrypt2_def rel_spmf_return_spmf1 fun_upd_idem intro!: rel_spmf_bind_reflI rel_spmf_reflI)

      have [symmetric]: "map_spmf (\<lambda>x. b = fst (fst x)) (exec_gpv (PRF.random_oracle) (inline (intercept_prf k_upf b) \<A> ()) Map.empty) =
        map_spmf (\<lambda>x. b = fst x) (exec_gpv oracle2 \<A> Map_empty)"
        by(transfer fixing: b prf_clen prf_domain upf_fun k_upf \<A> k_prf)
          (simp add: exec_gpv_inline map_spmf_conv_bind_spmf[symmetric] spmf.map_comp o_def split_def oracle_intercept_def) }
    then show ?thesis
      unfolding game2_def PRF.game_1_def key_gen_def reduction_prf_def
      by (clarsimp simp add: exec_gpv_bind_lift_spmf exec_gpv_bind map_spmf_conv_bind_spmf split_def bind_spmf_const prf_key_gen_lossless lossless_weight_spmfD eq_commute)
  qed
  ultimately show ?thesis by(simp add: PRF.advantage_def)
qed

definition oracle_encrypt3 ::
   "('prf_key \<times> 'upf_key) \<Rightarrow> bool \<Rightarrow> (bool \<times> (bitstring, bitstring) PRF.dict) \<Rightarrow>
    bitstring \<times> bitstring \<Rightarrow> ('hash cipher_text option \<times> (bool \<times> (bitstring, bitstring) PRF.dict)) spmf"
where
  "oracle_encrypt3 = (\<lambda>(k_prf, k_upf) b (bad, D) (msg1, msg0).
    (case (length msg1 = prf_clen \<and> length msg0 = prf_clen) of
      False \<Rightarrow> return_spmf (None, (bad, D))
    | True \<Rightarrow> do {
        x \<leftarrow> spmf_of_set prf_domain;
        P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
        let (p, F) = (case D x of Some r \<Rightarrow> (P, True) | None \<Rightarrow> (P, False));
        let c = p [\<oplus>] (if b then msg1 else msg0);
        let t = upf_fun k_upf (x @ c);
        return_spmf (Some (x, c, t), (bad \<or> F, D(x \<mapsto> p)))
      }))"

lemma lossless_oracle_encrypt3 [simp]:
  "lossless_spmf (oracle_encrypt3 k b D m10) "
  by (cases m10) (simp add: oracle_encrypt3_def prf_domain_nonempty prf_domain_finite
    split_def Let_def split: bool.splits)

lemma callee_invariant_oracle_encrypt3 [simp]: "callee_invariant (oracle_encrypt3 key b) fst"
  by (unfold_locales) (auto simp add: oracle_encrypt3_def split_def Let_def split: bool.splits)

definition game3 :: "(bitstring, 'hash cipher_text) ind_cca.adversary \<Rightarrow> (bool \<times> bool) spmf"
where
  "game3 \<A> \<equiv> do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', (bad, D)) \<leftarrow> exec_gpv (oracle_encrypt3 key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty);
    return_spmf (b = b', bad)
  }"

lemma round_3:
  assumes "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  shows "\<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - spmf (game2 \<A>) True\<bar>
          \<le> measure (measure_spmf (game3 \<A>)) {(b, bad). bad}"
proof -
  define oracle_encrypt2'
    where "oracle_encrypt2' = (\<lambda>(k_prf :: 'prf_key, k_upf) b (bad, D) (msg1, msg0).
      case length msg1 = prf_clen \<and> length msg0 = prf_clen of
        False \<Rightarrow> return_spmf (None, (bad, D))
      | True \<Rightarrow> do {
          x \<leftarrow> spmf_of_set prf_domain;
          P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
          let (p, F) = (case D x of Some r \<Rightarrow> (r, True) | None \<Rightarrow> (P, False));
          let c = p [\<oplus>] (if b then msg1 else msg0);
          let t = upf_fun k_upf (x @ c);
          return_spmf (Some (x, c, t), (bad \<or> F, D(x \<mapsto> p)))
        })"

  have [simp]: "lossless_spmf (oracle_encrypt2' key b D msg10) " for key b D msg10
    by (cases msg10) (simp add: oracle_encrypt2'_def prf_domain_nonempty prf_domain_finite
      split_def Let_def split: bool.split)
  have [simp]: "callee_invariant (oracle_encrypt2' key b) fst" for key b
    by (unfold_locales) (auto simp add: oracle_encrypt2'_def split_def Let_def split: bool.splits)

  define game2'
    where "game2' = (\<lambda>\<A>. do {
      key \<leftarrow> key_gen;
      b \<leftarrow> coin_spmf;
      (b', (bad, D)) \<leftarrow> exec_gpv (oracle_encrypt2' key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty);
      return_spmf (b = b', bad)})"

  have game2'_eq: "game2 \<A> = map_spmf fst (game2' \<A>)"
  proof -
    define S where "S = (\<lambda>(D1 :: (bitstring, bitstring) PRF.dict) (bad :: bool, D2). D1 = D2)"
    have [transfer_rule, simp]: "S Map_empty (b, Map_empty)" for b by (simp add: S_def)

    have [transfer_rule]: "((=) ===> (=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
      oracle_encrypt2 oracle_encrypt2'"
      unfolding oracle_encrypt2_def[abs_def] oracle_encrypt2'_def[abs_def]
      by (auto simp add: rel_fun_def Let_def split_def S_def
           intro!: rel_spmf_bind_reflI split: bool.split option.split)
    have [transfer_rule]: "((=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
      oracle_decrypt2 oracle_decrypt2"
      by(auto simp add: rel_fun_def oracle_decrypt2_def)

    show ?thesis unfolding game2_def game2'_def
      by (simp add: map_spmf_bind_spmf o_def split_def Map_empty_def[symmetric] del: Map_empty_def)
         transfer_prover
  qed
  moreover have *: "rel_spmf (\<lambda>(b'1, bad1, L1) (b'2, bad2, L2). (bad1 \<longleftrightarrow> bad2) \<and> (\<not> bad2 \<longrightarrow> b'1 \<longleftrightarrow> b'2))
    (exec_gpv (oracle_encrypt3 key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty))
    (exec_gpv (oracle_encrypt2' key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty))"
    for key b
    apply(rule exec_gpv_oracle_bisim_bad[where X="(=)" and X_bad = "\<lambda>_ _. True" and ?bad1.0=fst and ?bad2.0=fst and \<I>="\<I>_full \<oplus>\<^sub>\<I> \<I>_full"])
    apply(simp_all add: assms)
    apply(auto simp add: assms spmf_rel_map Let_def oracle_encrypt2'_def oracle_encrypt3_def split: plus_oracle_split prod.split bool.split option.split intro!: rel_spmf_bind_reflI rel_spmf_reflI)
    done
  have "\<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - measure (measure_spmf (game2' \<A>)) {(b, bad). b}\<bar> \<le>
    measure (measure_spmf (game3 \<A>)) {(b, bad). bad}"
    unfolding game2'_def game3_def
    by(rule fundamental_lemma[where ?bad2.0=snd])(intro rel_spmf_bind_reflI rel_spmf_bindI[OF *]; clarsimp)
  ultimately show ?thesis by(simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def fst_def)
qed

lemma round_4:
  assumes "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  shows "map_spmf fst (game3 \<A>) = coin_spmf"
proof -
  define oracle_encrypt4
    where "oracle_encrypt4 = (\<lambda>(k_prf :: 'prf_key, k_upf) (s :: unit) (msg1 :: bitstring, msg0 :: bitstring).
      case length msg1 = prf_clen \<and> length msg0 = prf_clen of
        False \<Rightarrow> return_spmf (None, s)
      | True \<Rightarrow> do {
          x \<leftarrow> spmf_of_set prf_domain;
          P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
          let c = P;
          let t = upf_fun k_upf (x @ c);
          return_spmf (Some (x, c, t), s) })"

  have [simp]: "lossless_spmf (oracle_encrypt4 k s msg10)" for k s msg10
    by (cases msg10) (simp add: oracle_encrypt4_def prf_domain_finite prf_domain_nonempty
      split_def Let_def split: bool.splits)

  define game4 where "game4 = (\<lambda>\<A>. do {
    key \<leftarrow> key_gen;
    (b', _) \<leftarrow> exec_gpv (oracle_encrypt4 key \<oplus>\<^sub>O oracle_decrypt2 key) \<A> ();
    map_spmf ((=) b') coin_spmf})"

  have "map_spmf fst (game3 \<A>) = game4 \<A>"
  proof -
    note [split del] = if_split
    define S where "S = (\<lambda>(_ :: unit) (_ :: bool \<times> (bitstring, bitstring) PRF.dict). True)"
    define initial3 where "initial3 = (False, Map.empty :: (bitstring, bitstring) PRF.dict)"
    have [transfer_rule]: "S () initial3" by(simp add: S_def)
    have [transfer_rule]: "((=) ===> (=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
       (\<lambda>key b. oracle_encrypt4 key) oracle_encrypt3"
    proof(intro rel_funI; hypsubst)
      fix key unit msg10 b Dbad
      have "map_spmf fst (oracle_encrypt4 key () msg10) = map_spmf fst (oracle_encrypt3 key b Dbad msg10)"
        unfolding oracle_encrypt3_def oracle_encrypt4_def
        apply (clarsimp simp add: map_spmf_conv_bind_spmf Let_def split: bool.split prod.split; rule conjI; clarsimp)
        apply (rewrite in "\<hole> = _" one_time_pad[symmetric, where xs="if b then fst msg10 else snd msg10"])
         apply(simp split: if_split)
        apply(simp add: bind_map_spmf o_def option.case_distrib case_option_collapse xor_list_commute split_def cong del: option.case_cong_weak if_weak_cong)
        done
      then show "rel_spmf (rel_prod (=) S) (oracle_encrypt4 key unit msg10) (oracle_encrypt3 key b Dbad msg10)"
        by(auto simp add: spmf_rel_eq[symmetric] spmf_rel_map S_def elim: rel_spmf_mono)
    qed

    show ?thesis
      unfolding game3_def game4_def including monad_normalisation
      by (simp add: map_spmf_bind_spmf o_def split_def map_spmf_conv_bind_spmf initial3_def[symmetric] eq_commute)
         transfer_prover
  qed
  also have "\<dots> = coin_spmf"
    by(simp add: map_eq_const_coin_spmf game4_def bind_spmf_const split_def lossless_exec_gpv[OF assms] lossless_weight_spmfD)
  finally  show ?thesis .
qed

lemma game3_bad:
  assumes "interaction_bounded_by isl \<A> q"
  shows "measure (measure_spmf (game3 \<A>)) {(b, bad). bad} \<le> q / card prf_domain * q"
proof -
  have "measure (measure_spmf (game3 \<A>)) {(b, bad). bad} = spmf (map_spmf snd (game3 \<A>)) True"
    by (simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def snd_def)
  also
  have "spmf (map_spmf (fst \<circ> snd) (exec_gpv (oracle_encrypt3 k b \<oplus>\<^sub>O oracle_decrypt2 k) \<A> (False, Map.empty))) True \<le> q / card prf_domain * q"
    (is "spmf (map_spmf _ (exec_gpv ?oracle _ _)) _ \<le>  _")
    if k: "k \<in> set_spmf key_gen" for k b
  proof(rule callee_invariant_on.interaction_bounded_by'_exec_gpv_bad_count)
    obtain k_prf k_upf where k: "k = (k_prf, k_upf)" by(cases k)
    let ?I = "\<lambda>(bad, D). finite (dom D) \<and> dom D \<subseteq> prf_domain"
    have "callee_invariant (oracle_encrypt3 k b) ?I"
      by unfold_locales(clarsimp simp add: prf_domain_finite oracle_encrypt3_def Let_def split_def split: bool.splits)+
    moreover have "callee_invariant (oracle_decrypt2 k) ?I"
      by unfold_locales (clarsimp simp add: prf_domain_finite oracle_decrypt2_def)+
    ultimately show "callee_invariant ?oracle ?I" by simp

    let ?count = "\<lambda>(bad, D). card (dom D)"
    show "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (?oracle s x); ?I s; isl x \<rbrakk> \<Longrightarrow> ?count s' \<le> Suc (?count s)"
      by(clarsimp simp add: isl_def oracle_encrypt3_def split_def Let_def card_insert_if split: bool.splits)
    show "\<lbrakk> (y, s') \<in> set_spmf (?oracle s x); ?I s; \<not> isl x \<rbrakk> \<Longrightarrow> ?count s' \<le> ?count s" for s x y s'
      by(cases x)(simp_all add: oracle_decrypt2_def)
    show "spmf (map_spmf (fst \<circ> snd) (?oracle s' x)) True \<le> q / card prf_domain"
      if I: "?I s'" and bad: "\<not> fst s'" and count: "?count s' < q + ?count (False, Map.empty)"
      and x: "isl x"
      for s' x
    proof -
      obtain bad D where s' [simp]: "s' = (bad, D)" by(cases s')
      from x obtain m1 m0 where x [simp]: "x = Inl (m1, m0)" by(auto elim: islE)
      have *: "(case D x of None \<Rightarrow> False | Some x \<Rightarrow> True) \<longleftrightarrow> x \<in> dom D" for x
        by(auto split: option.split)
      show ?thesis
      proof(cases "length m1 = prf_clen \<and> length m0 = prf_clen")
        case True
        with bad
        have "spmf (map_spmf (fst \<circ> snd) (?oracle s' x)) True = pmf (bernoulli_pmf (card (dom D \<inter> prf_domain) / card prf_domain)) True"
          by(simp add: spmf.map_comp o_def oracle_encrypt3_def k * bool.case_distrib[where h="\<lambda>p. spmf (map_spmf _ p) _"] option.case_distrib[where h=snd] map_spmf_bind_spmf Let_def split_beta bind_spmf_const cong: bool.case_cong option.case_cong split del: if_split split: bool.split)
            (simp add: map_spmf_conv_bind_spmf[symmetric] map_mem_spmf_of_set prf_domain_finite prf_domain_nonempty)
        also have "\<dots> = card (dom D \<inter> prf_domain) / card prf_domain"
          by(rule pmf_bernoulli_True)(auto simp add: field_simps prf_domain_finite prf_domain_nonempty card_gt_0_iff card_mono)
        also have "dom D \<inter> prf_domain = dom D" using I by auto
        also have "card (dom D) \<le> q" using count by simp
        finally show ?thesis by(simp add: divide_right_mono o_def)
      next
        case False
        thus ?thesis using bad
          by(auto simp add: spmf.map_comp o_def oracle_encrypt3_def k split: bool.split)
      qed
    qed
  qed(auto split: plus_oracle_split_asm simp add: oracle_decrypt2_def assms)
  then have "spmf (map_spmf snd (game3 \<A>)) True \<le> q / card prf_domain * q"
    by(auto 4 3 simp add: game3_def map_spmf_bind_spmf o_def split_def map_spmf_conv_bind_spmf intro: spmf_bind_leI)
  finally show ?thesis .
qed

theorem security:
  assumes lossless: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  and bound: "interaction_bounded_by isl \<A> q"
  shows "ind_cca.advantage \<A> \<le>
    PRF.advantage (reduction_prf \<A>) + UPF.advantage (reduction_upf \<A>) +
    real q / real (card prf_domain) * real q" (is "?LHS \<le> _")
proof -
  have "?LHS \<le> \<bar>spmf (ind_cca.game \<A>) True - spmf (ind_cca'.game \<A>) True\<bar> + \<bar>spmf (ind_cca'.game \<A>) True - 1 / 2\<bar>"
    (is "_ \<le> ?round1 + ?rest") using abs_triangle_ineq by(simp add: ind_cca.advantage_def)
  also have "?round1 \<le> UPF.advantage (reduction_upf \<A>)"
    using lossless by(rule round_1)
  also have "?rest \<le> \<bar>spmf (ind_cca'.game \<A>) True - spmf (game2 \<A>) True\<bar> + \<bar>spmf (game2 \<A>) True - 1 / 2\<bar>"
    (is "_ \<le> ?round2 + ?rest") using abs_triangle_ineq by simp
  also have "?round2 = PRF.advantage (reduction_prf \<A>)" by(rule round_2)
  also have "?rest \<le> \<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - spmf (game2 \<A>) True\<bar> +
       \<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - 1 / 2\<bar>"
    (is "_ \<le> ?round3 + _") using abs_triangle_ineq by simp
  also have "?round3 \<le> measure (measure_spmf (game3 \<A>)) {(b, bad). bad}"
    using round_3[OF lossless] .
  also have "\<dots> \<le> q / card prf_domain * q" using bound by(rule game3_bad)
  also have "measure (measure_spmf (game3 \<A>)) {(b, bad). b} = spmf coin_spmf True"
    using round_4[OF lossless, symmetric]
    by(simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def fst_def)
  also have "\<bar>\<dots> - 1 / 2\<bar> = 0" by(simp add: spmf_of_set)
  finally show ?thesis by(simp)
qed

theorem security1:
  assumes lossless: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  assumes q: "interaction_bounded_by isl \<A> q"
  and q': "interaction_bounded_by (Not \<circ> isl) \<A> q'"
  shows "ind_cca.advantage \<A> \<le>
    PRF.advantage (reduction_prf \<A>) +
    UPF.advantage1 (guessing_many_one.reduction q' (\<lambda>_. reduction_upf \<A>) ()) * q' +
    real q * real q / real (card prf_domain)"
proof -
  have "ind_cca.advantage \<A> \<le>
    PRF.advantage (reduction_prf \<A>) + UPF.advantage (reduction_upf \<A>) +
    real q / real (card prf_domain) * real q"
    using lossless q by(rule security)
  also note q'[interaction_bound]
  have "interaction_bounded_by (Not \<circ> isl) (reduction_upf \<A>) q'"
    unfolding reduction_upf_def by(interaction_bound)(simp_all add: SUP_le_iff)
  then have "UPF.advantage (reduction_upf \<A>) \<le> UPF.advantage1 (guessing_many_one.reduction q' (\<lambda>_. reduction_upf \<A>) ()) * q'"
    by(rule UPF.advantage_advantage1)
  finally show ?thesis by(simp)
qed

end

end

locale simple_cipher' =
  fixes prf_key_gen :: "security \<Rightarrow> 'prf_key spmf"
  and prf_fun :: "security \<Rightarrow> 'prf_key \<Rightarrow> bitstring \<Rightarrow> bitstring"
  and prf_domain :: "security \<Rightarrow> bitstring set"
  and prf_range :: "security \<Rightarrow> bitstring set"
  and prf_dlen :: "security \<Rightarrow> nat"
  and prf_clen :: "security \<Rightarrow> nat"
  and upf_key_gen :: "security \<Rightarrow> 'upf_key spmf"
  and upf_fun :: "security \<Rightarrow> 'upf_key \<Rightarrow> bitstring \<Rightarrow> 'hash"
  assumes simple_cipher: "\<And>\<eta>. simple_cipher (prf_key_gen \<eta>) (prf_fun \<eta>) (prf_domain \<eta>) (prf_dlen \<eta>) (prf_clen \<eta>) (upf_key_gen \<eta>)"
begin

sublocale simple_cipher
  "prf_key_gen \<eta>" "prf_fun \<eta>" "prf_domain \<eta>" "prf_range \<eta>" "prf_dlen \<eta>" "prf_clen \<eta>" "upf_key_gen \<eta>" "upf_fun \<eta>"
  for \<eta>
by(rule simple_cipher)

theorem security_asymptotic:
  fixes q q' :: "security \<Rightarrow> nat"
  assumes lossless: "\<And>\<eta>. lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (\<A> \<eta>)"
  and bound: "\<And>\<eta>. interaction_bounded_by isl (\<A> \<eta>) (q \<eta>)"
  and bound': "\<And>\<eta>. interaction_bounded_by (Not \<circ> isl) (\<A> \<eta>) (q' \<eta>)"
  and [negligible_intros]:
    "polynomial q'" "polynomial q"
    "negligible (\<lambda>\<eta>. PRF.advantage \<eta> (reduction_prf \<eta> (\<A> \<eta>)))"
    "negligible (\<lambda>\<eta>. UPF.advantage1 \<eta> (guessing_many_one.reduction (q' \<eta>) (\<lambda>_. reduction_upf \<eta> (\<A> \<eta>)) ()))"
    "negligible (\<lambda>\<eta>. 1 / card (prf_domain \<eta>))"
  shows "negligible (\<lambda>\<eta>. ind_cca.advantage \<eta> (\<A> \<eta>))"
proof -
  have "negligible (\<lambda>\<eta>. PRF.advantage \<eta> (reduction_prf \<eta> (\<A> \<eta>)) +
    UPF.advantage1 \<eta> (guessing_many_one.reduction (q' \<eta>) (\<lambda>_. reduction_upf \<eta> (\<A> \<eta>)) ()) * q' \<eta> +
    real (q \<eta>) / real (card (prf_domain \<eta>)) * real (q \<eta>))"
    by(rule negligible_intros)+
  thus ?thesis by(rule negligible_le)(simp add: security1[OF lossless bound bound'] ind_cca.advantage_nonneg)
qed

end

end


header "Assertions"

theory Assertions
imports "Tools/Imperative_HOL_Add" "Tools/Syntax_Match" "Tools/Sep_Misc"
begin

subsection {* Partial Heaps *}
text {*
  A partial heap is modeled by a heap and a set of valid addresses, with the
  side condition that the valid addresses have to be within the limit of the
  heap. This modeling is somewhat strange for separation logic, however, it
  allows us to solve some technical problems related to definition of
  Hoare triples, that will be detailed later.
*}
type_synonym pheap = "heap \<times> addr set"

text {* Predicate that expresses that the address set of a partial heap is
  within the heap's limit.
*}
fun in_range :: "(heap \<times> addr set) \<Rightarrow> bool"
  where "in_range (h,as) \<longleftrightarrow> (\<forall>a\<in>as. a < lim h)"

declare in_range.simps[simp del]

lemma in_range_empty[simp, intro!]: "in_range (h,{})"
  by (auto simp: in_range.simps)

lemma in_range_dist_union[simp]:
  "in_range (h,as \<union> as') \<longleftrightarrow> in_range (h,as) \<and> in_range (h,as')"
  by (auto simp: in_range.simps)

lemma in_range_subset:
  "\<lbrakk>as \<subseteq> as'; in_range (h,as')\<rbrakk> \<Longrightarrow> in_range (h,as)"
  by (auto simp: in_range.simps)

text {* Relation that holds if two heaps are identical on a given
  address range*}
definition relH :: "addr set \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> bool"
  where "relH as h h' \<equiv>
  in_range (h,as)
  \<and> in_range (h',as)
  \<and> (\<forall>t. \<forall>a \<in> as.
        refs h t a = refs h' t a
      \<and> arrays h t a = arrays h' t a
    )"

lemma relH_in_rangeI:
  assumes "relH as h h'"
  shows "in_range (h,as)" and "in_range (h',as)"
  using assms unfolding relH_def by auto

text "Reflexivity"
lemma relH_refl: "in_range (h,as) \<Longrightarrow> relH as h h"
  unfolding relH_def by simp

text "Symmetry"
lemma relH_sym: "relH as h h' \<Longrightarrow> relH as h' h"
  unfolding relH_def
  by auto

text "Transitivity"
lemma relH_trans[trans]: "\<lbrakk>relH as h1 h2; relH as h2 h3\<rbrakk> \<Longrightarrow> relH as h1 h3"
  unfolding relH_def
  by auto

lemma relH_dist_union[simp]:
  "relH (as\<union>as') h h' \<longleftrightarrow> relH as h h' \<and> relH as' h h'"
  unfolding relH_def
  by auto

lemma relH_subset:
  assumes "relH bs h h'"
  assumes "as \<subseteq> bs"
  shows "relH as h h'"
  using assms unfolding relH_def by (auto intro: in_range_subset)

lemma relH_ref:
  assumes "relH as h h'"
  assumes "addr_of_ref r \<in> as"
  shows "Ref.get h r = Ref.get h' r"
  using assms unfolding relH_def Ref.get_def by auto

lemma relH_array:
  assumes "relH as h h'"
  assumes "addr_of_array r \<in> as"
  shows "Array.get h r = Array.get h' r"
  using assms unfolding relH_def Array.get_def by auto

lemma relH_set_ref: "\<lbrakk> addr_of_ref r \<notin> as; in_range (h,as)\<rbrakk>
  \<Longrightarrow> relH as h (Ref.set r x h)"
  unfolding relH_def Ref.set_def
  by (auto simp: in_range.simps)

lemma relH_set_array: "\<lbrakk>addr_of_array r \<notin> as; in_range (h,as)\<rbrakk>
  \<Longrightarrow> relH as h (Array.set r x h)"
  unfolding relH_def Array.set_def
  by (auto simp: in_range.simps)

subsection {* Assertions *}
text {*
  Assertions are predicates on partial heaps, that fulfill a well-formedness
  condition called properness: They only depend on the part of the heap
  by the address set, and must be false for partial heaps that are not in range.
*}
type_synonym assn_raw = "pheap \<Rightarrow> bool"

definition proper :: "assn_raw \<Rightarrow> bool" where
  "proper P \<equiv> \<forall>h h' as. (P (h,as) \<longrightarrow> in_range (h,as))
    \<and> (P (h,as) \<and> relH as h h' \<and> in_range (h',as) \<longrightarrow> P (h',as))"

lemma properI[intro?]:
  assumes "\<And>as h. P (h,as) \<Longrightarrow> in_range (h,as)"
  assumes "\<And>as h h'.
    \<lbrakk>P (h,as); relH as h h'; in_range (h',as)\<rbrakk> \<Longrightarrow> P (h',as)"
  shows "proper P"
  unfolding proper_def using assms by blast

lemma properD1:
  assumes "proper P"
  assumes "P (h,as)"
  shows "in_range (h,as)"
  using assms unfolding proper_def by blast

lemma properD2:
  assumes "proper P"
  assumes "P (h,as)"
  assumes "relH as h h'"
  assumes "in_range (h',as)"
  shows "P (h',as)"
  using assms unfolding proper_def by blast

lemmas properD = properD1 properD2

lemma proper_iff:
  assumes "proper P"
  assumes "relH as h h'"
  assumes "in_range (h',as)"
  shows "P (h,as) \<longleftrightarrow> P (h',as)"
  using assms
  by (metis properD2 relH_in_rangeI(1) relH_sym)

text {* We encapsulate assertions in their own type *}
typedef assn = "Collect proper"
  apply simp
  unfolding proper_def
  by fastforce

lemmas [simp] = Rep_assn_inverse Rep_assn_inject
lemmas [simp, intro!] = Rep_assn[unfolded mem_Collect_eq]

lemma Abs_assn_eqI[intro?]:
  "(\<And>h. P h = Rep_assn Pr h) \<Longrightarrow> Abs_assn P = Pr"
  "(\<And>h. P h = Rep_assn Pr h) \<Longrightarrow> Pr = Abs_assn P"
  by (metis Rep_assn_inverse predicate1I xt1(5))+

abbreviation models :: "pheap \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Turnstile>" 50)
  where "h\<Turnstile>P \<equiv> Rep_assn P h"

lemma models_in_range: "h\<Turnstile>P \<Longrightarrow> in_range h"
  apply (cases h)
  by (metis mem_Collect_eq Rep_assn properD1)

subsubsection {* Empty Partial Heap*}
text {* The empty partial heap satisfies some special properties.
  We set up a simplification that tries to rewrite it to the standard
  empty partial heap @{text "h\<^sub>\<bottom>"}*}
abbreviation h_bot ("h\<^sub>\<bottom>") where "h\<^sub>\<bottom> \<equiv> (undefined,{})"
lemma mod_h_bot_indep: "(h,{})\<Turnstile>P \<longleftrightarrow> (h',{})\<Turnstile>P"
  by (metis mem_Collect_eq Rep_assn emptyE in_range_empty
    proper_iff relH_def)

lemma mod_h_bot_normalize[simp]:
  "syntax_fo_nomatch undefined h \<Longrightarrow> (h,{})\<Turnstile>P \<longleftrightarrow> h\<^sub>\<bottom> \<Turnstile> P"
  using mod_h_bot_indep[where h'=undefined] by simp

text {* Properness, lifted to the assertion type. *}
lemma mod_relH: "relH as h h' \<Longrightarrow> (h,as)\<Turnstile>P \<longleftrightarrow> (h',as)\<Turnstile>P"
  by (metis mem_Collect_eq Rep_assn proper_iff relH_in_rangeI(2))

subsection {* Connectives *}
text {*
  We define several operations on assertions, and instantiate some type classes.
*}

subsubsection {* Empty Heap and Separation Conjunction *}
text {* The assertion that describes the empty heap, and the separation
  conjunction form a commutative monoid: *}
instantiation assn :: one begin
  fun one_assn_raw :: "pheap \<Rightarrow> bool"
    where "one_assn_raw (h,as) \<longleftrightarrow> as={}"

  lemma one_assn_proper[intro!,simp]: "proper one_assn_raw"
    by (auto intro!: properI)

  definition one_assn :: assn where "1 \<equiv> Abs_assn one_assn_raw"
  instance ..
end

abbreviation one_assn::assn ("emp") where "one_assn \<equiv> 1"

instantiation assn :: times begin
  fun times_assn_raw :: "assn_raw \<Rightarrow> assn_raw \<Rightarrow> assn_raw" where
    "times_assn_raw P Q (h,as)
    = (\<exists>as1 as2. as=as1\<union>as2 \<and> as1\<inter>as2={}
        \<and> P (h,as1) \<and> Q (h,as2))"

  lemma times_assn_proper[intro!,simp]:
    "proper P \<Longrightarrow> proper Q \<Longrightarrow> proper (times_assn_raw P Q)"
    apply (rule properI)
    apply (auto dest: properD1) []
    apply clarsimp
    apply (drule (3) properD2)
    apply (drule (3) properD2)
    apply blast
    done

  definition times_assn where "P*Q \<equiv>
    Abs_assn (times_assn_raw (Rep_assn P) (Rep_assn Q))"

  instance ..
end

lemma star_assnI:
  assumes "(h,as)\<Turnstile>P" and "(h,as')\<Turnstile>Q" and "as\<inter>as'={}"
  shows "(h,as\<union>as')\<Turnstile>P*Q"
  using assms unfolding times_assn_def
  by (auto simp: Abs_assn_inverse)

instantiation assn :: comm_monoid_mult begin
  lemma assn_one_left: "1*P = (P::assn)"
    unfolding one_assn_def times_assn_def
    apply (rule)
    apply (auto simp: Abs_assn_inverse)
    done

  lemma assn_times_comm: "P*Q = Q*(P::assn)"
    unfolding times_assn_def
    apply rule
    apply (fastforce simp add: Abs_assn_inverse Un_ac)
    done

  lemma assn_times_assoc: "(P*Q)*R = P*(Q*(R::assn))"
    unfolding times_assn_def
    apply rule
    apply (auto simp: Abs_assn_inverse)
    apply (rule_tac x="as1\<union>as1a" in exI)
    apply (rule_tac x="as2a" in exI)
    apply (auto simp add: Un_ac) []

    apply (rule_tac x="as1a" in exI)
    apply (rule_tac x="as2a\<union>as2" in exI)
    apply (fastforce simp add: Un_ac) []
    done

  instance
    apply default
    apply (rule assn_times_assoc)
    apply (rule assn_times_comm)
    apply (rule assn_one_left)
    done

end

subsubsection {* Magic Wand *}
fun wand_raw :: "assn_raw \<Rightarrow> assn_raw \<Rightarrow> assn_raw" where
  "wand_raw P Q (h,as) \<longleftrightarrow> in_range (h,as)
  \<and> (\<forall>h' as'. as\<inter>as'={} \<and> relH as h h' \<and> in_range (h',as)
    \<and> P (h',as')
    \<longrightarrow> Q (h',as\<union>as'))"

lemma wand_proper[simp, intro!]: "proper (wand_raw P Q)"
  apply (rule properI)
  apply simp
  apply (auto dest: relH_trans)
  done

definition
  wand_assn :: "assn \<Rightarrow> assn \<Rightarrow> assn" (infixl "-*" 56)
  where "P-*Q \<equiv> Abs_assn (wand_raw (Rep_assn P) (Rep_assn Q))"

lemma wand_assnI:
  assumes "in_range (h,as)"
  assumes "\<And>h' as'. \<lbrakk>
    as \<inter> as' = {};
    relH as h h';
    in_range (h',as);
    (h',as')\<Turnstile>Q
  \<rbrakk> \<Longrightarrow> (h',as\<union>as') \<Turnstile> R"
  shows "(h,as) \<Turnstile> Q -* R"
  using assms
  unfolding wand_assn_def
  apply (auto simp: Abs_assn_inverse)
  done

subsubsection {* Boolean Algebra on Assertions *}
instantiation assn :: boolean_algebra begin
  definition top_assn where "top \<equiv> Abs_assn in_range"
  definition bot_assn where "bot \<equiv> Abs_assn (\<lambda>_. False)"
  definition sup_assn where "sup P Q \<equiv> Abs_assn (\<lambda>h. h\<Turnstile>P \<or> h\<Turnstile>Q)"
  definition inf_assn where "inf P Q \<equiv> Abs_assn (\<lambda>h. h\<Turnstile>P \<and> h\<Turnstile>Q)"
  definition uminus_assn where
    "-P \<equiv> Abs_assn (\<lambda>h. in_range h \<and> \<not>h\<Turnstile>P)"

  lemma bool_assn_proper[simp, intro!]:
    "proper in_range"
    "proper (\<lambda>_. False)"
    "proper P \<Longrightarrow> proper Q \<Longrightarrow> proper (\<lambda>h. P h \<or> Q h)"
    "proper P \<Longrightarrow> proper Q \<Longrightarrow> proper (\<lambda>h. P h \<and> Q h)"
    "proper P \<Longrightarrow> proper (\<lambda>h. in_range h \<and> \<not>P h)"
    apply (auto
      intro!: properI
      intro: relH_in_rangeI
      dest: properD1
      simp: proper_iff)
    done

  text {* (And, Or, True, False, Not) are a Boolean algebra.
    Due to idiosyncrasies of the Isabelle/HOL class setup, we have to
    also define a difference and an ordering: *}
  definition less_eq_assn where
  [simp]: "(a::assn) \<le> b \<equiv> a = inf a b"

  definition less_assn where
  [simp]: "(a::assn) < b \<equiv> a \<le> b \<and> a\<noteq>b"

  definition minus_assn where
  [simp]: "(a::assn) - b \<equiv> inf a (-b)"

  instance
    apply default
    unfolding
      top_assn_def bot_assn_def sup_assn_def inf_assn_def uminus_assn_def
      less_eq_assn_def less_assn_def minus_assn_def
    apply (auto
      simp: Abs_assn_inverse conj_commute conj_ac
      intro: Abs_assn_eqI models_in_range)
    apply rule
    apply (metis (mono_tags) Abs_assn_inverse[unfolded mem_Collect_eq]
      Rep_assn[unfolded mem_Collect_eq] bool_assn_proper(4))
    apply rule
    apply (metis (mono_tags)
      Abs_assn_inverse[unfolded mem_Collect_eq]
      Rep_assn[unfolded mem_Collect_eq] bool_assn_proper(4))
    apply rule
    apply (simp add: Abs_assn_inverse)
    apply (metis (mono_tags)
      Abs_assn_inverse[unfolded mem_Collect_eq]
      Rep_assn[unfolded mem_Collect_eq] bool_assn_proper(4))
    done

end

text {* We give the operations some more standard names *}
abbreviation top_assn::assn ("true") where "top_assn \<equiv> top"
abbreviation bot_assn::assn ("false") where "bot_assn \<equiv> bot"
abbreviation sup_assn::"assn\<Rightarrow>assn\<Rightarrow>assn" (infixr "\<or>\<^sub>A" 61)
  where "sup_assn \<equiv> sup"
abbreviation inf_assn::"assn\<Rightarrow>assn\<Rightarrow>assn" (infixr "\<and>\<^sub>A" 62)
  where "inf_assn \<equiv> inf"
abbreviation uminus_assn::"assn \<Rightarrow> assn" ("\<not>\<^sub>A _" [81] 80)
  where "uminus_assn \<equiv> uminus"

text {* Now we prove some relations between the Boolean algebra operations
  and the (empty heap,separation conjunction) monoid *}
lemma star_false_left[simp]: "false * P = false"
  unfolding times_assn_def bot_assn_def
  apply rule
  apply (auto simp add: Abs_assn_inverse)
  done

lemma star_false_right[simp]: "P * false = false"
  using star_false_left by (simp add: assn_times_comm)

lemmas star_false = star_false_left star_false_right

subsubsection {* Existential Quantification *}
definition ex_assn :: "('a \<Rightarrow> assn) \<Rightarrow> assn" (binder "\<exists>\<^sub>A" 11)
  where "(\<exists>\<^sub>Ax. P x) \<equiv> Abs_assn (\<lambda>h. \<exists>x. h\<Turnstile>P x)"

lemma ex_assn_proper[simp, intro!]:
  "(\<And>x. proper (P x)) \<Longrightarrow> proper (\<lambda>h. \<exists>x. P x h)"
  by (auto intro!: properI dest: properD1 simp: proper_iff)

lemma ex_assn_const[simp]: "(\<exists>\<^sub>Ax. c) = c"
  unfolding ex_assn_def by auto

lemma ex_one_point_gen:
  "\<lbrakk>\<And>h x. h\<Turnstile>P x \<Longrightarrow> x=v\<rbrakk> \<Longrightarrow> (\<exists>\<^sub>Ax. P x) = (P v)"
  unfolding ex_assn_def
  apply rule
  apply auto
  done

lemma ex_distrib_star: "(\<exists>\<^sub>Ax. P x * Q) = (\<exists>\<^sub>Ax. P x) * Q"
  unfolding ex_assn_def times_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma ex_distrib_and: "(\<exists>\<^sub>Ax. P x \<and>\<^sub>A Q) = (\<exists>\<^sub>Ax. P x) \<and>\<^sub>A Q"
  unfolding ex_assn_def inf_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  done

lemma ex_distrib_or: "(\<exists>\<^sub>Ax. P x \<or>\<^sub>A Q) = (\<exists>\<^sub>Ax. P x) \<or>\<^sub>A Q"
  unfolding ex_assn_def sup_assn_def
  apply rule
  apply (auto simp add: Abs_assn_inverse)
  done

lemma ex_join_or: "(\<exists>\<^sub>Ax. P x \<or>\<^sub>A (\<exists>\<^sub>Ax. Q x)) = (\<exists>\<^sub>Ax. P x \<or>\<^sub>A Q x)"
  unfolding ex_assn_def sup_assn_def
  apply rule
  apply (auto simp add: Abs_assn_inverse)
  done

subsubsection {* Pure Assertions *}
text {* Pure assertions do not depend on any heap content. *}
fun pure_assn_raw where "pure_assn_raw b (h,as) \<longleftrightarrow> as={} \<and> b"
definition pure_assn :: "bool \<Rightarrow> assn" ("\<up>") where
  "\<up>b \<equiv> Abs_assn (pure_assn_raw b)"

lemma pure_assn_proper[simp, intro!]: "proper (pure_assn_raw b)"
  by (auto intro!: properI intro: relH_in_rangeI)

lemma pure_true[simp]: "\<up>True = emp"
  unfolding pure_assn_def one_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  apply (auto)
  done

lemma pure_false[simp]: "\<up>False = false"
  unfolding pure_assn_def bot_assn_def
  apply rule
  apply (auto simp: Abs_assn_inverse)
  done

lemma merge_pure_star[simp]:
  "\<up>a * \<up>b = \<up>(a\<and>b)"
  unfolding times_assn_def
  apply rule
  unfolding pure_assn_def
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma merge_true_star[simp]: "true*true = true"
  unfolding times_assn_def top_assn_def
  apply rule
  apply (simp add: Abs_assn_inverse)
  apply (fastforce simp: in_range.simps)
  done

lemma merge_pure_and[simp]:
  "\<up>a \<and>\<^sub>A \<up>b = \<up>(a\<and>b)"
  unfolding inf_assn_def
  apply rule
  unfolding pure_assn_def
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

lemma merge_pure_or[simp]:
  "\<up>a \<or>\<^sub>A \<up>b = \<up>(a\<or>b)"
  unfolding sup_assn_def
  apply rule
  unfolding pure_assn_def
  apply (simp add: Abs_assn_inverse)
  apply fastforce
  done

subsubsection {* Pointers *}
text {* In Imperative HOL, we have to distinguish between pointers to single
  values and pointers to arrays. For both, we define assertions that
  describe the part of the heap that a pointer points to. *}
fun sngr_assn_raw :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> assn_raw" where
  "sngr_assn_raw r x (h,as) \<longleftrightarrow> Ref.get h r = x \<and> as = {addr_of_ref r} \<and>
  addr_of_ref r < lim h"

lemma sngr_assn_proper[simp, intro!]: "proper (sngr_assn_raw r x)"
  apply (auto intro!: properI simp: relH_ref)
  apply (simp add: in_range.simps)
  apply (auto simp add: in_range.simps dest: relH_in_rangeI)
  done

definition sngr_assn :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> assn" (infix "\<mapsto>\<^sub>r" 82)
  where "r\<mapsto>\<^sub>rx \<equiv> Abs_assn (sngr_assn_raw r x)"

fun snga_assn_raw :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> assn_raw"
  where "snga_assn_raw r x (h,as)
  \<longleftrightarrow> Array.get h r = x \<and> as = {addr_of_array r}
      \<and> addr_of_array r < lim h"

lemma snga_assn_proper[simp, intro!]: "proper (snga_assn_raw r x)"
  apply (auto intro!: properI simp: relH_array)
  apply (simp add: in_range.simps)
  apply (auto simp add: in_range.simps dest: relH_in_rangeI)
  done

definition
  snga_assn :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> assn" (infix "\<mapsto>\<^sub>a" 82)
  where "r\<mapsto>\<^sub>aa \<equiv> Abs_assn (snga_assn_raw r a)"

text {* Two disjoint parts of the heap cannot be pointed to by the
  same pointer*}
lemma sngr_same_false[simp]:
  "p \<mapsto>\<^sub>r x * p \<mapsto>\<^sub>r y = false"
  unfolding times_assn_def bot_assn_def sngr_assn_def
  apply rule
  apply (auto simp: Abs_assn_inverse)
  done

lemma snga_same_false[simp]:
  "p \<mapsto>\<^sub>a x * p \<mapsto>\<^sub>a y = false"
  unfolding times_assn_def bot_assn_def snga_assn_def
  apply rule
  apply (auto simp: Abs_assn_inverse)
  done

subsection {* Properties of the Models-Predicate *}
lemma mod_true[simp]: "h\<Turnstile>true \<longleftrightarrow> in_range h"
  unfolding top_assn_def by (simp add: Abs_assn_inverse)
lemma mod_false[simp]: "\<not> h\<Turnstile>false"
  unfolding bot_assn_def by (simp add: Abs_assn_inverse)

lemma mod_emp: "h\<Turnstile>emp \<longleftrightarrow> snd h = {}"
  unfolding one_assn_def by (cases h) (simp add: Abs_assn_inverse)

lemma mod_emp_simp[simp]: "(h,{})\<Turnstile>emp"
  by (simp add: mod_emp)

lemma mod_pure[simp]: "h\<Turnstile>\<up>b \<longleftrightarrow> snd h = {} \<and> b"
  unfolding pure_assn_def
  apply (cases h)
  apply (auto simp add: Abs_assn_inverse)
  done

lemma mod_ex_dist[simp]: "h\<Turnstile>(\<exists>\<^sub>Ax. P x) \<longleftrightarrow> (\<exists>x. h\<Turnstile>P x)"
  unfolding ex_assn_def by (auto simp: Abs_assn_inverse)

lemma mod_exI: "\<exists>x. h\<Turnstile>P x \<Longrightarrow> h\<Turnstile>(\<exists>\<^sub>Ax. P x)"
  by (auto simp: mod_ex_dist)
lemma mod_exE: assumes "h\<Turnstile>(\<exists>\<^sub>Ax. P x)" obtains x where "h\<Turnstile>P x"
  using assms by (auto simp: mod_ex_dist)

(* Not declared as simp, to not interfere with precision.
  TODO: Perhaps define own connector for precision claims?
*)
lemma mod_and_dist: "h\<Turnstile>P\<and>\<^sub>AQ \<longleftrightarrow> h\<Turnstile>P \<and> h\<Turnstile>Q"
  unfolding inf_assn_def by (simp add: Abs_assn_inverse)

lemma mod_or_dist[simp]: "h\<Turnstile>P\<or>\<^sub>AQ \<longleftrightarrow> h\<Turnstile>P \<or> h\<Turnstile>Q"
  unfolding sup_assn_def by (simp add: Abs_assn_inverse)

lemma mod_not_dist[simp]: "h\<Turnstile>(\<not>\<^sub>AP) \<longleftrightarrow> in_range h \<and> \<not> h\<Turnstile>P"
  unfolding uminus_assn_def by (simp add: Abs_assn_inverse)

lemma mod_pure_star_dist[simp]: "h\<Turnstile>P*\<up>b \<longleftrightarrow> h\<Turnstile>P \<and> b"
  by (metis (full_types) mod_false mult_1_right pure_false
    pure_true star_false_right)

lemmas mod_dist = mod_pure mod_pure_star_dist mod_ex_dist mod_and_dist
  mod_or_dist mod_not_dist

lemma mod_star_trueI: "h\<Turnstile>P \<Longrightarrow> h\<Turnstile>P*true"
  unfolding times_assn_def top_assn_def
  apply (simp add: Abs_assn_inverse)
  apply (cases h)
  apply auto
  done

lemma mod_star_trueE': assumes "h\<Turnstile>P*true" obtains h' where
  "fst h' = fst h" and "snd h' \<subseteq> snd h" and "h'\<Turnstile>P"
  using assms
  unfolding times_assn_def top_assn_def
  apply (cases h)
  apply (fastforce simp add: Abs_assn_inverse)
  done

lemma mod_star_trueE: assumes "h\<Turnstile>P*true" obtains h' where "h'\<Turnstile>P"
  using assms by (blast elim: mod_star_trueE')

lemma mod_h_bot_iff[simp]:
  "(h,{}) \<Turnstile> \<up>b \<longleftrightarrow> b"
  "(h,{}) \<Turnstile> true"
  "(h,{}) \<Turnstile> p\<mapsto>\<^sub>rx \<longleftrightarrow> False"
  "(h,{}) \<Turnstile> q\<mapsto>\<^sub>ay \<longleftrightarrow> False"
  "(h,{}) \<Turnstile> P*Q \<longleftrightarrow> ((h,{}) \<Turnstile> P) \<and> ((h,{}) \<Turnstile> Q)"
  "(h,{}) \<Turnstile> P\<and>\<^sub>AQ \<longleftrightarrow> ((h,{}) \<Turnstile> P) \<and> ((h,{}) \<Turnstile> Q)"
  "(h,{}) \<Turnstile> P\<or>\<^sub>AQ \<longleftrightarrow> ((h,{}) \<Turnstile> P) \<or> ((h,{}) \<Turnstile> Q)"
  "(h,{}) \<Turnstile> (\<exists>\<^sub>Ax. R x) \<longleftrightarrow> (\<exists>x. (h,{}) \<Turnstile> R x)"
  apply (simp add: pure_assn_def Abs_assn_inverse)
  apply simp
  apply (simp add: sngr_assn_def Abs_assn_inverse)
  apply (simp add: snga_assn_def Abs_assn_inverse)
  apply (simp add: times_assn_def Abs_assn_inverse)
  apply (simp add: inf_assn_def Abs_assn_inverse)
  apply (simp add: sup_assn_def Abs_assn_inverse)
  apply (simp add: ex_assn_def Abs_assn_inverse)
  done

subsection {* Entailment *}
definition entails :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infix "\<Longrightarrow>\<^sub>A" 10)
  where "P \<Longrightarrow>\<^sub>A Q \<equiv> \<forall>h. h\<Turnstile>P \<longrightarrow> h\<Turnstile>Q"

lemma entailsI:
  assumes "\<And>h. h\<Turnstile>P \<Longrightarrow> h\<Turnstile>Q"
  shows "P \<Longrightarrow>\<^sub>A Q"
  using assms unfolding entails_def by auto

lemma entailsD:
  assumes "P \<Longrightarrow>\<^sub>A Q"
  assumes "h\<Turnstile>P"
  shows "h\<Turnstile>Q"
  using assms unfolding entails_def by blast

subsubsection {* Properties *}
lemma ent_fwd:
  assumes "h\<Turnstile>P"
  assumes "P \<Longrightarrow>\<^sub>A Q"
  shows "h\<Turnstile>Q" using assms(2,1) by (rule entailsD)

lemma ent_refl[simp]: "P \<Longrightarrow>\<^sub>A P"
  by (auto simp: entailsI)

lemma ent_trans[trans]: "\<lbrakk> P \<Longrightarrow>\<^sub>A Q; Q \<Longrightarrow>\<^sub>AR \<rbrakk> \<Longrightarrow> P \<Longrightarrow>\<^sub>A R"
  by (auto intro: entailsI dest: entailsD)

lemma ent_iffI:
  assumes "A\<Longrightarrow>\<^sub>AB"
  assumes "B\<Longrightarrow>\<^sub>AA"
  shows "A=B"
  apply (subst Rep_assn_inject[symmetric])
  apply (rule ext)
  using assms unfolding entails_def
  by blast

lemma ent_false[simp]: "false \<Longrightarrow>\<^sub>A P"
  by (auto intro: entailsI)
lemma ent_true[simp]: "P \<Longrightarrow>\<^sub>A true"
  by (auto intro!: entailsI simp: models_in_range)

lemma ent_false_iff[simp]: "(P \<Longrightarrow>\<^sub>A false) \<longleftrightarrow> (\<forall>h. \<not>h\<Turnstile>P)"
  unfolding entails_def
  by auto

lemma ent_pure_pre_iff[simp]: "(P*\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto simp add: mod_dist)

lemma ent_pure_pre_iff_sng[simp]:
  "(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A Q))"
  using ent_pure_pre_iff[where P=emp]
  by simp

lemma ent_pure_post_iff[simp]:
  "(P \<Longrightarrow>\<^sub>A Q*\<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto simp add: mod_dist)

lemma ent_pure_post_iff_sng[simp]:
  "(P \<Longrightarrow>\<^sub>A \<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A emp))"
  using ent_pure_post_iff[where Q=emp]
  by simp

lemma ent_ex_preI: "(\<And>x. P x \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> \<exists>\<^sub>Ax. P x \<Longrightarrow>\<^sub>A Q"
  unfolding entails_def ex_assn_def
  by (auto simp: Abs_assn_inverse)

lemma ent_ex_postI: "(P \<Longrightarrow>\<^sub>A Q x) \<Longrightarrow> P \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. Q x"
  unfolding entails_def ex_assn_def
  by (auto simp: Abs_assn_inverse)

lemma ent_mp: "(P * (P -* Q)) \<Longrightarrow>\<^sub>A Q"
  apply (rule entailsI)
  unfolding times_assn_def wand_assn_def
  apply (clarsimp simp add: Abs_assn_inverse)
  apply (drule_tac x="a" in spec)
  apply (drule_tac x="as1" in spec)
  apply (auto simp: Un_ac relH_refl)
  done

lemma ent_star_mono: "\<lbrakk> P \<Longrightarrow>\<^sub>A P'; Q \<Longrightarrow>\<^sub>A Q'\<rbrakk> \<Longrightarrow> P*Q \<Longrightarrow>\<^sub>A P'*Q'"
  unfolding entails_def times_assn_def
  apply (simp add: Abs_assn_inverse)
  apply metis
  done

lemma ent_wandI:
  assumes IMP: "Q*P \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A (Q -* R)"
  unfolding entails_def
  apply clarsimp
  apply (rule wand_assnI)
  apply (blast intro: models_in_range)
proof -
  fix h as h' as'
  assume "(h,as)\<Turnstile>P"
    and "as\<inter>as'={}"
    and "relH as h h'"
    and "in_range (h',as)"
    and "(h',as') \<Turnstile> Q"

  from `(h,as)\<Turnstile>P` and `relH as h h'` have "(h',as)\<Turnstile>P"
    by (simp add: mod_relH)
  with `(h',as') \<Turnstile> Q` and `as\<inter>as'={}` have "(h',as\<union>as')\<Turnstile>Q*P"
    by (metis star_assnI Int_commute Un_commute)
  with IMP show "(h',as\<union>as') \<Turnstile> R" by (blast dest: ent_fwd)
qed

lemma ent_disjI1:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjI2:
  assumes "P \<or>\<^sub>A Q \<Longrightarrow>\<^sub>A R"
  shows "Q \<Longrightarrow>\<^sub>A R" using assms unfolding entails_def by simp

lemma ent_disjE: "\<lbrakk> A\<Longrightarrow>\<^sub>AC; B\<Longrightarrow>\<^sub>AC \<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>AC"
  unfolding entails_def by auto

lemma ent_conjE1: "\<lbrakk>A\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)
lemma ent_conjE2: "\<lbrakk>B\<Longrightarrow>\<^sub>AC\<rbrakk> \<Longrightarrow> A\<and>\<^sub>AB\<Longrightarrow>\<^sub>AC"
  unfolding entails_def by (auto simp: mod_and_dist)

subsection {* Precision *}
text {*
  Precision rules describe that parts of an assertion may depend only on the
  underlying heap. For example, the data where a pointer points to is the same
  for the same heap.
*}
text {* Precision rules should have the form:
  @{text [display] "\<forall>x y. (h\<Turnstile>(P x * F1) \<and>\<^sub>A (P y * F2)) \<longrightarrow> x=y"}*}
definition "precise R \<equiv> \<forall>a a' h p F F'.
  h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<longrightarrow> a = a'"

lemma preciseI[intro?]:
  assumes "\<And>a a' h p F F'. h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F' \<Longrightarrow> a = a'"
  shows "precise R"
  using assms unfolding precise_def by blast

lemma preciseD:
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F \<and>\<^sub>A R a' p * F'"
  shows "a=a'"
  using assms unfolding precise_def by blast

lemma preciseD':
  assumes "precise R"
  assumes "h \<Turnstile> R a p * F"
  assumes "h \<Turnstile> R a' p * F'"
  shows "a=a'"
  apply (rule preciseD)
  apply (rule assms)
  apply (simp only: mod_and_dist)
  apply (blast intro: assms)
  done

lemma sngr_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>rx)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  unfolding sngr_assn_def times_assn_def
  apply (simp add: Abs_assn_inverse)
  apply auto
  done

lemma snga_prec: "precise (\<lambda>x p. p\<mapsto>\<^sub>ax)"
  apply rule
  apply (clarsimp simp: mod_and_dist)
  unfolding snga_assn_def times_assn_def
  apply (simp add: Abs_assn_inverse)
  apply auto
  done

end