theory ttt
  imports Main
begin
  (*theory begin*)
theorem "P \<longrightarrow> P"
proof
  assume 1: "P"
  show "P" by (rule 1)
qed

lemma "((P \<longrightarrow> Q) \<and> P) \<Longrightarrow> Q"
proof-
  show "((P \<longrightarrow> Q) \<and> P) \<Longrightarrow> Q" by auto
qed

theorem "((P \<longrightarrow> Q) \<and> P) \<Longrightarrow> Q"
  sledgehammer
  by simp

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_list_return_2
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) y2 = y2"
| "x (cons2 z2 xs) y2 = cons2 z2 (x xs y2)"

fun y :: "'a list => ('a => 'b list) => 'b list" where
"y (nil2) y2 = nil2"
| "y (cons2 z2 xs) y2 = x (y2 z2) (y xs y2)"

fun return :: "'a => 'a list" where
"return z = cons2 z (nil2)"

theorem property0 :
  "((y xs (% (z :: 'a) => return z)) = xs)"
  oops

end


theory Proofs3
  imports Requirements VCTheoryLemmas
begin

definition inv3 where "inv3 s \<equiv> R3 s \<and> extraInv s"

theorem proof_3_1: "VC1 inv3 s0"
  apply(unfold VC1_def inv3_def R3_def extraInv_def)
  by auto

theorem proof_3_2: "VC2 R3 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC2_def inv3_def R3_def extraInv_def)
  by auto

theorem proof_3_370: "VC370 R3 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC370_def inv3_def R3_def extraInv_def)
  by auto

end


theory Wiring
imports RubyType
begin

definition Id :: "i \<Rightarrow> i" where
  "Id(A) == spread({xy:A*A. EX x. xy = <x, x>})"

definition lwir :: "[i, i] \<Rightarrow> i" where
  "lwir(A, C) == spread({ab:A*(A*(C*C)). EX a c. ab = <a, <a, <c, c>>>})"

definition rwir :: "[i, i] \<Rightarrow> i" where
  "rwir(A, C) == spread({ab:(A*(A*C))*C. EX b c. ab = <<c, <c, b>>, b>})"

definition reorg :: "[i, i, i] \<Rightarrow> i" where
  "reorg(A, B, C) == spread({ab:((A*B)*C)*(A*(B*C)).
    EX a b c. ab = <<<a,b>,c>,<a, <b, c>>>})"

definition cross :: "[i, i] \<Rightarrow> i" where
  "cross(A, B) == spread({ab:((A*B)*(B*A)). EX a b. ab = <<a,b>, <b,a>>})"

definition p1 :: "[i, i] \<Rightarrow> i" where
  "p1(A, B) == spread({ab:(A*B)*A. EX a b. ab = <<a,b>, a>})"

definition p2 :: "[i, i] \<Rightarrow> i" where
  "p2(A, B) == spread({ab:(A*B)*B. EX a b. ab = <<a,b>, b>})"

definition dub :: "i \<Rightarrow> i" where
  "dub(A) == spread({ab:A*(A*A). EX a. ab = <a, <a,a>>})"

definition pzip :: "[i, i, i, i] \<Rightarrow> i" where
  "pzip(A, B, C, E) ==
    spread({ab: (((A*B)*(C*E))*((A*C)*(B*E))).
    EX a b c d. ab = <<<a, b>, <c, d>>, <<a, c>, <b, d>>>})"

definition NNIL :: "i" where
  "NNIL == spread({<nnil, nnil>})"

definition apl :: "[i, i] \<Rightarrow> i" where
  "apl(A, n) == spread({ab:(A*nlist[n]A)*nlist[succ(n)]A.
  EX a1 a2. ab = <<a1, a2>, ncons(n, a1, a2)>})"

definition apr :: "[i, i] \<Rightarrow> i" where
  "apr(A, n) == spread({ab:(nlist[n]A*A)*nlist[succ(n)]A.
  EX a1 a2. ab = <<a1, a2>, nsnoc(n, a1, a2)>})"

definition rapp :: "[i, i, i] \<Rightarrow> i" where
  "rapp(A, n, m) == spread({ab:(nlist[n]A*nlist[m]A)*nlist[n #+ m]A.
  EX a1 a2. ab = <<a1, a2>, napp(n, m, a1, a2)>})"

theorem reorg_type: "reorg(A,B,C): (A*B)*C <~>A*B*C"
apply(unfold reorg_def)
apply(rule spread_type, blast)
done

theorem reorgR: "\<lbrakk> A:ChTy; B:ChTy; C:ChTy \<rbrakk> \<Longrightarrow> reorg(A,B,C):(A*B)*C<R>A*B*C"
apply(unfold reorg_def)
apply(rule spreadR)
apply((intro prod_in_chty, simp+)+, blast)
done

lemma spair_apply_time: "t:int \<Longrightarrow> <a#b>`t = <a`t, b`t>"
apply(simp add: spair_def)
done

lemma sig_apply_time: "\<lbrakk> a:sig(A); t:int \<rbrakk> \<Longrightarrow> a`t:A"
apply(simp)
done

theorem reorgI:
  "\<lbrakk> a:sig(A); b:sig(B); c:sig(C) \<rbrakk> \<Longrightarrow> <<<a#b>#c>,<a#<b#c>>>:reorg(A,B,C)"
apply(unfold reorg_def)
apply(rule spreadI)
apply(rule, rule)
apply((subst spair_apply_time, simp)+)
apply((drule sig_apply_time, simp)+)
apply(simp)
apply((subst spair_apply_time, simp)+)
apply(simp)
apply(blast)
apply((intro spair_type, simp+)+)
done

theorem reorgE:
  "\<lbrakk> <<<a#b>#c>,<d#<e#f>>>:reorg(A,B,C);
    \<lbrakk> a=d; b=e; c=f \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(B'); c:sig(C');
    d:sig(A''); e:sig(B''); f:sig(C'') \<rbrakk> \<Longrightarrow> P"
apply(unfold reorg_def)
apply(erule spreadE)
apply(subgoal_tac "a=d & b=e & c=f", simp)
apply(intro conjI)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem cross_type: "cross(A,B):A*B<~>B*A"
apply(unfold cross_def)
apply(rule spread_type, blast)
done

theorem crossR: "\<lbrakk> A:ChTy; B:ChTy \<rbrakk> \<Longrightarrow> cross(A,B):A*B<R>B*A"
apply(unfold cross_def)
apply(rule spreadR)
apply((intro prod_in_chty, simp+)+, blast)
done

theorem crossI: "\<lbrakk> a:sig(A); b:sig(B) \<rbrakk> \<Longrightarrow> <<a#b>, <b#a>>:cross(A,B)"
apply(unfold cross_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast)
apply((intro spair_type, simp+)+)
done

theorem crossE:
  "\<lbrakk> <<a#b>, <c#d>>:cross(A,B); \<lbrakk> a=d; b=c \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(B'); c:sig(B''); d:sig(A'') \<rbrakk> \<Longrightarrow> P"
apply(unfold cross_def, erule spreadE)
apply(subgoal_tac "a=d & b=c", simp)
apply(rule)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem Id_type: "Id(A):A<~>A"
apply(unfold Id_def)
apply(rule spread_type, blast)
done

theorem IdR: "A:ChTy \<Longrightarrow> Id(A):A<R>A"
apply(unfold Id_def, rule spreadR)
apply((simp | blast)+)
done

theorem IdI: "a:sig(A) \<Longrightarrow> <a,a>:Id(A)"
apply(unfold Id_def, rule spreadI, rule)
apply((simp | blast)+)
done

theorem IdI2: "\<lbrakk> a:sig(A); b:sig(B); a=b \<rbrakk> \<Longrightarrow> <a, b>:Id(A)"
apply(simp, rule IdI, simp)
done

theorem IdE: "\<lbrakk> <x,y>:Id(A); \<lbrakk> x=y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold Id_def)
apply(subgoal_tac "x:sig(A) & y:sig(A)")
apply(erule spreadE)
apply(subgoal_tac "x=y", simp)
apply(rule fun_extension, auto)
apply(unfold spread_def, auto)
apply(subgoal_tac "domain({xy \<in> A \<times> A . \<exists>x. xy = \<langle>x, x\<rangle>}) \<subseteq> A")
apply(drule sig_mono, rule subsetD, simp+, blast)
apply(subgoal_tac "range({xy \<in> A \<times> A . \<exists>x. xy = \<langle>x, x\<rangle>}) \<subseteq> A")
apply(drule sig_mono, rule subsetD, simp+, blast)
done

theorem lwir_type: "lwir(A,B):A<~>A*B*B"
apply(unfold lwir_def, rule spread_type, blast)
done

theorem lwirR: "\<lbrakk> A:ChTy; B:ChTy \<rbrakk> \<Longrightarrow> lwir(A,B):A<R>A*B*B"
apply(unfold lwir_def, rule spreadR)
apply(((intro prod_in_chty)?, simp)+)
apply(blast)
done

theorem lwirI: "\<lbrakk> a:sig(A); b:sig(B) \<rbrakk> \<Longrightarrow> <a, <a#<b#b>>>:lwir(A,B)"
apply(unfold lwir_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
done

theorem lwirE:
  "\<lbrakk> <a, <b#<c#d>>>:lwir(A,B);
    a:sig(C1); b:sig(C2); c:sig(C3); d:sig(C4);
    \<lbrakk> a=b; c=d \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold lwir_def, erule spreadE)
apply(subgoal_tac "a=b & c=d", simp)
apply(rule)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem rwir_type: "rwir(A,B):A*A*B<~>B"
apply(unfold rwir_def, rule spread_type, blast)
done

theorem rwirR: "\<lbrakk> A:ChTy; B:ChTy \<rbrakk> \<Longrightarrow> rwir(A,B):A*A*B<R>B"
apply(unfold rwir_def, rule spreadR)
apply(((intro prod_in_chty)?, simp)+)
apply(blast)
done

theorem rwirI: "\<lbrakk> a:sig(A); b:sig(B) \<rbrakk> \<Longrightarrow> <<a#<a#b>>,b>:rwir(A,B)"
apply(unfold rwir_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
done

theorem rwirE:
  "\<lbrakk> <<a#<b#c>>,d>:rwir(A,B); \<lbrakk> a=b; c=d \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(A''); c:sig(B'); d:sig(B'') \<rbrakk> \<Longrightarrow> P"
apply(unfold rwir_def, erule spreadE)
apply(subgoal_tac "a=b & c=d", simp)
apply(rule)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem p1_type: "p1(A,B):A*B<~>A"
apply(unfold p1_def, rule spread_type, blast)
done

theorem p1R: "\<lbrakk> A:ChTy; B:ChTy \<rbrakk> \<Longrightarrow> p1(A,B):A*B<R>A"
apply(unfold p1_def, rule spreadR)
apply(((intro prod_in_chty)?, simp)+)
apply(blast)
done

theorem p1I: "\<lbrakk> a:sig(A); b:sig(B) \<rbrakk> \<Longrightarrow> <<a#b>, a>:p1(A,B)"
apply(unfold p1_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
done

theorem p1E:
  "\<lbrakk> <<a#b>,c>:p1(A,B); \<lbrakk> a=c \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(B'); c:sig(A'') \<rbrakk> \<Longrightarrow> P"
apply(unfold p1_def, erule spreadE)
apply(subgoal_tac "a=c", simp)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem p2_type: "p2(A,B):A*B<~>B"
apply(unfold p2_def, rule spread_type, blast)
done

theorem p2R: "\<lbrakk> A:ChTy; B:ChTy \<rbrakk> \<Longrightarrow> p2(A,B):A*B<R>B"
apply(unfold p2_def, rule spreadR)
apply(((intro prod_in_chty)?, simp)+)
apply(blast)
done

theorem p2I: "\<lbrakk> a:sig(A); b:sig(B) \<rbrakk> \<Longrightarrow> <<a#b>, b>:p2(A,B)"
apply(unfold p2_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
done

theorem p2E:
  "\<lbrakk> <<a#b>,c>:p2(A,B); \<lbrakk> b=c \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(B'); c:sig(A'') \<rbrakk> \<Longrightarrow> P"
apply(unfold p2_def, erule spreadE)
apply(subgoal_tac "b=c", simp)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem dub_type: "dub(A):A<~>A*A"
apply(unfold dub_def, rule spread_type, blast)
done

theorem dubR: "A:ChTy \<Longrightarrow> dub(A):A<R>A*A"
apply(unfold dub_def, rule spreadR)
apply(((intro prod_in_chty)?, simp)+)
apply(blast)
done

theorem dubI: "a:sig(A) \<Longrightarrow> <a, <a#a>>:dub(A)"
apply(unfold dub_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
done

theorem dubE:
  "\<lbrakk> <a, <b#c>>:dub(A); \<lbrakk> a=b;a=c \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(A''); c:sig(A''') \<rbrakk> \<Longrightarrow> P"
apply(unfold dub_def, erule spreadE)
apply(subgoal_tac "a=b & a=c", simp, rule conjI)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem pzip_type: "pzip(A,B,C,E):(A*B)*C*E<~>(A*C)*B*E"
apply(unfold pzip_def, rule spread_type, blast)
done

theorem pzipR:
  "\<lbrakk> A:ChTy; B:ChTy; C:ChTy; E:ChTy \<rbrakk>
  \<Longrightarrow> pzip(A,B,C,E):(A*B)*C*E<R>(A*C)*B*E"
apply(unfold pzip_def, rule spreadR)
apply(((intro prod_in_chty)?, simp)+)
apply(blast)
done

theorem pzipI:
  "\<lbrakk> a:sig(A); b:sig(B); c:sig(C); d:sig(E) \<rbrakk>
  \<Longrightarrow> <<<a#b>#<c#d>>,<<a#c>#<b#d>>>:pzip(A,B,C,E)"
apply(unfold pzip_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
done

theorem pzipE:
  "\<lbrakk> <<<a#b>#<c#d>>,<<e#f>#<g#h>>>:pzip(A,B,C,E);
    \<lbrakk> a=e; b=g; c=f; d=h \<rbrakk> \<Longrightarrow> P;
    a:sig(A'); b:sig(B'); c:sig(C'); d:sig(E');
    e:sig(A''); f:sig(C''); g:sig(B''); h:sig(E'') \<rbrakk> \<Longrightarrow> P"
apply(unfold pzip_def, erule spreadE)
apply(subgoal_tac "a=e & b=g & c=f & d=h", simp, intro conjI)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp)+)
done

theorem NNIL_type: "NNIL:nlist[0]A<~>nlist[0]B"
apply(unfold NNIL_def, rule spread_type)
apply(subgoal_tac "nnil:nlist[0]A & nnil:nlist[0]B", simp)
apply(intro conjI nnil_type)
done

theorem NNILR: "\<lbrakk> A:ChTy; B:ChTy \<rbrakk> \<Longrightarrow> NNIL:nlist[0]A<R>nlist[0]B"
apply(unfold NNIL_def, rule spreadR)
apply((intro nlist_in_chty, simp)+)
apply(subgoal_tac "nnil:nlist[0]A & nnil:nlist[0]B", simp)
apply(intro conjI nnil_type)
done

theorem NNILI: "<snil, snil>:NNIL"
apply(unfold NNIL_def, rule spreadI)
apply(rule, simp add: snil_def)
defer
apply(rule snil_type[of A])
apply(rule snil_type[of B])
apply(subgoal_tac "nnil:nlist[0]A & nnil:nlist[0]B", simp)
apply(intro conjI nnil_type)
done

theorem NNILE:
  "\<lbrakk> <x,y>:NNIL; x:sig(nlist[0]A'); y:sig(nlist[0]B');
    \<lbrakk> x=snil; y=snil \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold NNIL_def, erule spreadE)
apply(subgoal_tac "x = snil & y = snil", simp, rule conjI)
apply((simp add: snil_def, rule fun_extension, simp+)+)
done

theorem apl_type: "apl(A,n):A*nlist[n]A<~>nlist[succ(n)]A"
apply(unfold apl_def, rule spread_type, blast)
done

theorem aplR: "A:ChTy \<Longrightarrow> apl(A,n):A*nlist[n]A<R>nlist[succ(n)]A"
apply(unfold apl_def, rule spreadR)
apply(((intro prod_in_chty nlist_in_chty)?, simp)+)
apply(blast)
done

theorem aplI: "\<lbrakk> a:sig(A); l:sig(nlist[n]A) \<rbrakk> \<Longrightarrow> <<a#l>, [a@>l|n]>:apl(A,n)"
apply(unfold apl_def scons_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
apply(insert scons_type, simp add: scons_def)
done

theorem aplE:
  "\<lbrakk> <<a#la>,[b@>lb|n]>:apl(A,n);
    a:sig(A1); b:sig(A2); la:sig(nlist[n]A3); lb:sig(nlist[n]A4);
    \<lbrakk> a=b; la=lb \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold apl_def scons_def, erule spreadE)
apply(subgoal_tac "a=b & la=lb", simp, intro conjI)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp,
      elim conjE ncons_inject, simp+)+)
done

theorem apr_type: "apr(A,n):nlist[n]A*A<~>nlist[succ(n)]A"
apply(unfold apr_def, rule spread_type, blast)
done

theorem aprR: "A:ChTy \<Longrightarrow> apr(A,n):nlist[n]A*A<R>nlist[succ(n)]A"
apply(unfold apr_def, rule spreadR)
apply(((intro prod_in_chty nlist_in_chty)?, simp)+)
apply(blast)
done

theorem aprI: "\<lbrakk> a:sig(A); l:sig(nlist[n]A) \<rbrakk> \<Longrightarrow> <<l#a>, [l<@a|n]>:apr(A,n)"
apply(unfold apr_def ssnoc_def)
apply(rule spreadI, rule+)
apply((intro sig_apply_time spair_type, simp+)+)
apply((subst spair_apply_time, simp)+, simp)
apply(blast+)
apply((intro sig_apply_time spair_type, simp+)+)
apply(insert ssnoc_type2, simp add: ssnoc_def)
done

theorem aprE:
  "\<lbrakk> <<la#a>,[lb<@b|n]>:apr(A,n);
    a:sig(A1); b:sig(A2); la:sig(nlist[n]A3); lb:sig(nlist[n]A4);
    \<lbrakk> a=b; la=lb \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
apply(unfold apr_def ssnoc_def, erule spreadE)
apply(subgoal_tac "a=b & la=lb", simp, intro conjI)
apply((rule fun_extension, simp+,
      drule bspec, simp,
      (subst (asm) spair_apply_time, simp)+, simp,
      elim conjE nsnoc_inject, simp+)+)
done

lemmas Ruby_type = Ruby_type
  reorg_type cross_type Id_type
  lwir_type rwir_type p1_type p2_type
  dub_type pzip_type NNIL_type
  apl_type apr_type

lemmas RubyR = RubyR
  reorgR crossR IdR lwirR rwirR
  p1R p2R dubR pzipR NNILR
  aplR aprR

lemmas RubyI = RubyI
  reorgI crossI IdI lwirI rwirI
  p1I p2I dubI pzipI NNILI
  aplI aprI

lemmas RubyE = RubyE
  reorgE crossE IdE lwirE rwirE
  p1E p2E dubE pzipE NNILE
  aplE aprE

declare Ruby_type [TC]

end


(*  File:       Evaluation_Function.thy
    Copyright   2023  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Refinement of Evaluation Function\<close>

theory Evaluation_Function_Ref
  imports "Verified_Voting_Rule_Construction.Evaluation_Function"
    "Social_Choice_Types/Profile_List_Monadic"
  Refine_Imperative_HOL.IICF
begin

text \<open>
  In this section, we refine Evaluation Function from Verified-Voting-Rule-Construction.
  Evaluation Function are used to instantiate Elimination Modules. Elimination Modules
  are a way to formalize certain voting rules. Elimination Modules have been defined by
  Stephan Bohr. They work with a finite non-empty set of alternatives. This precondition
  is encoded in the refinement relations here.
\<close>

subsection \<open>Definition\<close>

type_synonym 'a Evaluation_Function_Ref = "'a  \<Rightarrow> 'a set \<Rightarrow> 'a Profile_List \<Rightarrow> nat nres"

abbreviation "efunrel \<equiv> Id \<rightarrow> \<langle>Id\<rangle>set_rel \<rightarrow> profile_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"

definition evalf_rel ::
    "(('a \<Rightarrow> 'a set \<Rightarrow> 'a list list \<Rightarrow> nat nres)
\<times> ('a \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set list \<Rightarrow> nat)) set"
    where  evalf_rel_def:
"evalf_rel \<equiv> {(eref,e).(eref, (\<lambda> a A pro. SPEC (\<lambda> sc. sc = e a A pro)))
  \<in> Id \<rightarrow> \<langle>Id\<rangle>set_rel \<rightarrow> profile_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel}"

lemma evalfeq:
  fixes "A" :: "'a set"
  fixes pr :: "'a Profile"
  fixes pl :: "'a Profile_List"
  assumes
     fina: "finite A" and
     pref: "(pl, pr) \<in> profile_rel" and
     evalref: "(refn, efn) \<in> evalf_rel"
   shows "\<forall> a \<in> A. refn a A pl \<le> SPEC (\<lambda>score. score = (efn a A pr))"
proof (-)
  from evalref have efrel: "(refn, (\<lambda> a A pro. SPEC (\<lambda> sc. sc = efn a A pro))) \<in> efunrel"
  unfolding evalf_rel_def by simp
  from this pref efrel[THEN fun_relD, THEN fun_relD,THEN fun_relD,THEN nres_relD,THEN refine_IdD]
  show ?thesis
    by force
qed

  subsection \<open>Refined Condorcet Property\<close>

text \<open>
  An Evaluation function is Condorcet-rating iff the following holds:
  If a Condorcet Winner w exists, w and only w has the highest value.
\<close>

definition condorcet_rating_mon_aux :: "'a Evaluation_Function_Ref
  \<Rightarrow> 'a set \<Rightarrow> 'a Profile_List \<Rightarrow> 'a \<Rightarrow> bool nres" where
  "condorcet_rating_mon_aux f A p w \<equiv>
  FOREACH A (\<lambda> x b.
      if (x = w) then RETURN b
      else do {
      sw \<leftarrow> f w A p;
      sl \<leftarrow> f x A p;
      RETURN (b \<and> (sl < sw))}) (True)"

subsection \<open>Theorems\<close>

text \<open>
  If e is Condorcet-rating, the following holds:
  If a Condorcet Winner w exists, w has the maximum evaluation value.
\<close>

(*theorem cond_winner_imp_max_eval_val_ref:
  fixes A :: "'a set"
  fixes eref :: "'a Evaluation_Function_Ref"
  and efn :: "'a Evaluation_Function"
  fixes pl :: "'a Profile_List" and pr :: "'a Profile"
  assumes fina: "finite A"
  and profrel : "(pl, pr) \<in> profile_rel"
  and efref: "eref w A pl \<le> SPEC (\<lambda> score. score = (efn w A pr))"
  assumes
    rating: "condorcet_rating efn" and
    profl: "profile_l A pl" and
    winnerl: "condorcet_winner_l A pl w"
  shows "eref w A pl \<le> RETURN (Max {efn a A pr | a. a \<in> A})"
proof -
  from win
  from fina profl profrel have f_prof: "finite_profile A pr"
    using profile_ref
    by fastforce
  from winnerl condorcet_winner_l_correct[THEN fun_relD, THEN fun_relD,THEN fun_relD]
  profrel
  have winner: "condorcet_winner A pr w"
    by (metis pair_in_Id_conv set_rel_id)
  from rating f_prof winner
  have "efn w A pr = Max {efn a A pr |a. a \<in> A}" using cond_winner_imp_max_eval_val
    by (metis (mono_tags, lifting))
  from efref this show ?thesis
    by auto
qed*)

text \<open>
  If e is Condorcet-rating, the following holds:
  If a Condorcet Winner w exists, a non-Condorcet
  winner has a value lower than the maximum
  evaluation value.
\<close>

find_theorems "Max"

theorem non_cond_winner_not_max_eval_ref:
  fixes A :: "'a set"
  fixes eref :: "'a Evaluation_Function_Ref"
  and efn :: "'a Evaluation_Function"
  fixes pl :: "'a Profile_List" and pr :: "'a Profile"
  assumes fina: "finite A"
  assumes profrel : "(pl, pr) \<in> profile_rel"
  and efref: "\<forall> c \<in> A. eref c A pl \<le> SPEC (\<lambda> score. score = (efn c A pr))"
  assumes
    rating: "condorcet_rating efn" and
    profl: "profile_l A pl" and
    winnerl: "condorcet_winner_l A pl w" and
    linA: "l \<in> A" and
    loser: "w \<noteq> l"
  shows "do {sl \<leftarrow> eref l A pl; RETURN (sl < Max {efn a A pr | a. a \<in> A})} \<le> RETURN True"
proof -
  from winnerl have winA: "w \<in> A" by simp
  from fina profl profrel have f_prof: "finite_profile A pr"
    using profile_ref
    by fastforce
  from winnerl condorcet_winner_l_correct[THEN fun_relD, THEN fun_relD,THEN fun_relD]
  profrel
  have winner: "condorcet_winner A pr w"
    by (metis pair_in_Id_conv set_rel_id)
  from f_prof winner rating linA loser have lt: "efn l A pr < Max {efn a A pr | a. a \<in> A}"
    using non_cond_winner_not_max_eval[where A= A and l = l and e = efn and w = w and p = pr]
    by simp
  from  fina linA efref  show ?thesis unfolding SPEC_eq_is_RETURN(2)[symmetric]
    using specify_left[where m = "eref l A pl" and \<Phi> = "(\<lambda>score. score = efn l A pr)"
          and f = "(\<lambda>sl. SPEC (\<lambda>x. x = (sl < Max {efn a A pr |a. a \<in> A})))"
          and M= "SPEC (\<lambda>x. x = True)"]
    using lt by fastforce

qed

end


header {* \isaheader{Semantics} *}

theory Semantics imports Labels Com begin

subsection {* Small Step Semantics *}

inductive red :: "cmd * state \<Rightarrow> cmd * state \<Rightarrow> bool"
and red' :: "cmd \<Rightarrow> state \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> bool"
  ("((1\<langle>_,/_\<rangle>) \<rightarrow>/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81)
where
   "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> == red (c,s) (c',s')"
  | RedLAss:
   "\<langle>V:=e,s\<rangle> \<rightarrow> \<langle>Skip,s(V:=(interpret e s))\<rangle>"

  | SeqRed:
  "\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s'\<rangle> \<Longrightarrow> \<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>1';;c\<^sub>2,s'\<rangle>"

  | RedSeq:
  "\<langle>Skip;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<rangle>"

  | RedCondTrue:
  "interpret b s = Some true \<Longrightarrow> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>1,s\<rangle>"

  | RedCondFalse:
  "interpret b s = Some false \<Longrightarrow> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<rangle>"

  | RedWhileTrue:
  "interpret b s = Some true \<Longrightarrow> \<langle>while (b) c,s\<rangle> \<rightarrow> \<langle>c;;while (b) c,s\<rangle>"

  | RedWhileFalse:
  "interpret b s = Some false \<Longrightarrow> \<langle>while (b) c,s\<rangle> \<rightarrow> \<langle>Skip,s\<rangle>"

lemmas red_induct = red.induct[split_format (complete)]

abbreviation reds ::"cmd \<Rightarrow> state \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> bool"
   ("((1\<langle>_,/_\<rangle>) \<rightarrow>*/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81) where
  "\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle> == red\<^sup>*\<^sup>* (c,s) (c',s')"

subsection{* Label Semantics *}

inductive step :: "cmd \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> bool"
   ("(_ \<turnstile> (1\<langle>_,/_,/_\<rangle>) \<leadsto>/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81)
where

StepLAss:
  "V:=e \<turnstile> \<langle>V:=e,s,0\<rangle> \<leadsto> \<langle>Skip,s(V:=(interpret e s)),1\<rangle>"

| StepSeq:
  "\<lbrakk>labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2); labels (c\<^sub>1;;c\<^sub>2) #:c\<^sub>1 c\<^sub>2; l < #:c\<^sub>1\<rbrakk>
  \<Longrightarrow> c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1\<rangle>"

| StepSeqWhile:
  "labels (while (b) c') l (Skip;;while (b) c')
  \<Longrightarrow> while (b) c' \<turnstile> \<langle>Skip;;while (b) c',s,l\<rangle> \<leadsto> \<langle>while (b) c',s,0\<rangle>"

| StepCondTrue:
  "interpret b s = Some true
     \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>"

| StepCondFalse:
  "interpret b s = Some false
  \<Longrightarrow> if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>"

| StepWhileTrue:
  "interpret b s = Some true
     \<Longrightarrow> while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>c;;while (b) c,s,2\<rangle>"

| StepWhileFalse:
  "interpret b s = Some false \<Longrightarrow> while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>"

| StepRecSeq1:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> prog;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c';;c\<^sub>2,s',l'\<rangle>"

| StepRecSeq2:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> c\<^sub>1;;prog \<turnstile> \<langle>c,s,l + #:c\<^sub>1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1\<rangle>"

| StepRecCond1:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> if (b) prog else c\<^sub>2 \<turnstile> \<langle>c,s,l + 1\<rangle> \<leadsto> \<langle>c',s',l' + 1\<rangle>"

| StepRecCond2:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> if (b) c\<^sub>1 else prog \<turnstile> \<langle>c,s,l + #:c\<^sub>1 + 1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1 + 1\<rangle>"

| StepRecWhile:
  "cx \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>
  \<Longrightarrow> while (b) cx \<turnstile> \<langle>c;;while (b) cx,s,l + 2\<rangle> \<leadsto> \<langle>c';;while (b) cx,s',l' + 2\<rangle>"

lemma step_label_less:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<Longrightarrow> l < #:prog \<and> l' < #:prog"
proof(induct rule:step.induct)
  case (StepSeq c\<^sub>1 c\<^sub>2 l s)
  from `labels (c\<^sub>1;;c\<^sub>2) l (Skip;;c\<^sub>2)`
  have "l < #:(c\<^sub>1;; c\<^sub>2)" by(rule label_less_num_inner_nodes)
  thus ?case by(simp add:num_inner_nodes_gr_0)
next
  case (StepSeqWhile b cx l s)
  from `labels (while (b) cx) l (Skip;;while (b) cx)`
  have "l < #:(while (b) cx)" by(rule label_less_num_inner_nodes)
  thus ?case by simp
qed (auto intro:num_inner_nodes_gr_0)

abbreviation steps :: "cmd \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> cmd \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> bool"
   ("(_ \<turnstile> (1\<langle>_,/_,/_\<rangle>) \<leadsto>*/ (1\<langle>_,/_,/_\<rangle>))" [51,0,0,0,0,0,0] 81) where
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> ==
     (\<lambda>(c,s,l) (c',s',l'). prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>)\<^sup>*\<^sup>* (c,s,l) (c',s',l')"

subsection{* Proof of bisimulation of @{term "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"}\\
  and @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"} via @{term "labels"} *}

(*<*)
lemmas converse_rtranclp_induct3 =
  converse_rtranclp_induct[of _ "(ax,ay,az)" "(bx,by,bz)", split_rule,
                 consumes 1, case_names refl step]
(*>*)

subsubsection {* From @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"} to
  @{term "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"} *}

lemma step_red:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<Longrightarrow> \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"
by(induct rule:step.induct,rule RedLAss,auto intro:red.intros)

lemma steps_reds:
  "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> \<Longrightarrow> \<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>"
proof(induct rule:converse_rtranclp_induct3)
  case refl thus ?case by simp
next
  case (step c s l c'' s'' l'')
  then have "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s'',l''\<rangle>"
    and "\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>" by simp_all
  from `prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s'',l''\<rangle>` have "\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s''\<rangle>"
    by(fastforce intro:step_red)
  with `\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>` show ?case
    by(fastforce intro:converse_rtranclp_into_rtranclp)
qed

(*<*)declare fun_upd_apply [simp del] One_nat_def [simp del](*>*)

subsubsection {* From @{term "\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"} and @{term labels} to
  @{term "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"} *}

lemma red_step:
  "\<lbrakk>labels prog l c; \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>\<rbrakk>
  \<Longrightarrow> \<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels prog l' c'"
proof(induct arbitrary:c' rule:labels.induct)
  case (Labels_Base c)
  from `\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>` show ?case
  proof(induct rule:red_induct)
    case (RedLAss V e s)
    have "V:=e \<turnstile> \<langle>V:=e,s,0\<rangle> \<leadsto> \<langle>Skip,s(V:=(interpret e s)),1\<rangle>" by(rule StepLAss)
    have "labels (V:=e) 1 Skip" by(fastforce intro:Labels_LAss)
    with `V:=e \<turnstile> \<langle>V:=e,s,0\<rangle> \<leadsto> \<langle>Skip,s(V:=(interpret e s)),1\<rangle>` show ?case by blast
  next
    case (SeqRed c\<^sub>1 s c\<^sub>1' s' c\<^sub>2)
    from `\<exists>l'. c\<^sub>1 \<turnstile> \<langle>c\<^sub>1,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1',s',l'\<rangle> \<and> labels c\<^sub>1 l' c\<^sub>1'`
    obtain l' where "c\<^sub>1 \<turnstile> \<langle>c\<^sub>1,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1',s',l'\<rangle>" and "labels c\<^sub>1 l' c\<^sub>1'" by blast
    from `c\<^sub>1 \<turnstile> \<langle>c\<^sub>1,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1',s',l'\<rangle>` have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c\<^sub>1;;c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1';;c\<^sub>2,s',l'\<rangle>"
      by(rule StepRecSeq1)
    moreover
    from `labels c\<^sub>1 l' c\<^sub>1'` have "labels (c\<^sub>1;;c\<^sub>2) l' (c\<^sub>1';;c\<^sub>2)" by(rule Labels_Seq1)
    ultimately show ?case by blast
  next
    case (RedSeq c\<^sub>2 s)
    have "labels c\<^sub>2 0 c\<^sub>2" by(rule Labels.Labels_Base)
    hence "labels (Skip;;c\<^sub>2) (0 + #:Skip) c\<^sub>2" by(rule Labels_Seq2)
    have "labels (Skip;;c\<^sub>2) 0 (Skip;;c\<^sub>2)" by(rule Labels.Labels_Base)
    with `labels (Skip;;c\<^sub>2) (0 + #:Skip) c\<^sub>2`
    have "Skip;;c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:Skip\<rangle>"
      by(fastforce intro:StepSeq)
    with `labels (Skip;;c\<^sub>2) (0 + #:Skip) c\<^sub>2` show ?case by auto
  next
    case (RedCondTrue b s c\<^sub>1 c\<^sub>2)
    from `interpret b s = Some true`
    have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>"
      by(rule StepCondTrue)
    have "labels (if (b) c\<^sub>1 else c\<^sub>2) (0 + 1) c\<^sub>1"
      by(rule Labels_CondTrue,rule Labels.Labels_Base)
    with `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>1,s,1\<rangle>` show ?case by auto
  next
    case (RedCondFalse b s c\<^sub>1 c\<^sub>2)
    from `interpret b s = Some false`
    have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>"
      by(rule StepCondFalse)
    have "labels (if (b) c\<^sub>1 else c\<^sub>2) (0 + #:c\<^sub>1 + 1) c\<^sub>2"
      by(rule Labels_CondFalse,rule Labels.Labels_Base)
    with `if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s,0\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1 + 1\<rangle>`
    show ?case by auto
  next
    case (RedWhileTrue b s c)
    from `interpret b s = Some true`
    have "while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>c;; while (b) c,s,2\<rangle>"
      by(rule StepWhileTrue)
    have "labels (while (b) c) (0 + 2) (c;; while (b) c)"
      by(rule Labels_WhileBody,rule Labels.Labels_Base)
    with `while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>c;; while (b) c,s,2\<rangle>`
    show ?case by(auto simp del:add_2_eq_Suc')
  next
    case (RedWhileFalse b s c)
    from `interpret b s = Some false`
    have "while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>"
      by(rule StepWhileFalse)
    have "labels (while (b) c) 1 Skip" by(rule Labels_WhileExit)
    with `while (b) c \<turnstile> \<langle>while (b) c,s,0\<rangle> \<leadsto> \<langle>Skip,s,1\<rangle>` show ?case by auto
  qed
next
  case (Labels_LAss V e)
  from `\<langle>Skip,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>` have False by(auto elim:red.cases)
  thus ?case by simp
next
  case (Labels_Seq1 c\<^sub>1 l c c\<^sub>2)
  note IH = `\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
        \<exists>l'. c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>1 l' c'`
  from `\<langle>c;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>`
  have "(c = Skip \<and> c' = c\<^sub>2 \<and> s = s') \<or> (\<exists>c''. c' = c'';;c\<^sub>2)"
    by -(erule red.cases,auto)
  thus ?case
  proof
    assume [simp]:"c = Skip \<and> c' = c\<^sub>2 \<and> s = s'"
    from `labels c\<^sub>1 l c` have "l < #:c\<^sub>1"
      by(rule label_less_num_inner_nodes[simplified])
    have "labels (c\<^sub>1;;c\<^sub>2) (0 + #:c\<^sub>1) c\<^sub>2"
      by(rule Labels_Seq2,rule Labels_Base)
    from `labels c\<^sub>1 l c` have "labels (c\<^sub>1;; c\<^sub>2) l (Skip;;c\<^sub>2)"
      by(fastforce intro:Labels.Labels_Seq1)
    with `labels (c\<^sub>1;;c\<^sub>2) (0 + #:c\<^sub>1) c\<^sub>2` `l < #:c\<^sub>1`
    have "c\<^sub>1;; c\<^sub>2 \<turnstile> \<langle>Skip;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c\<^sub>2,s,#:c\<^sub>1\<rangle>"
      by(fastforce intro:StepSeq)
    with `labels (c\<^sub>1;;c\<^sub>2) (0 + #:c\<^sub>1) c\<^sub>2` show ?case by auto
  next
    assume "\<exists>c''. c' = c'';;c\<^sub>2"
    then obtain c'' where [simp]:"c' = c'';;c\<^sub>2" by blast
    with `\<langle>c;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>` have "\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle>"
      by(auto elim!:red.cases,induct c\<^sub>2,auto)
    from IH[OF this] obtain l' where "c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>"
      and "labels c\<^sub>1 l' c''" by blast
    from `c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>` have "c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c'';;c\<^sub>2,s',l'\<rangle>"
      by(rule StepRecSeq1)
    from `labels c\<^sub>1 l' c''` have "labels (c\<^sub>1;;c\<^sub>2) l' (c'';;c\<^sub>2)"
      by(rule Labels.Labels_Seq1)
    with `c\<^sub>1;;c\<^sub>2 \<turnstile> \<langle>c;;c\<^sub>2,s,l\<rangle> \<leadsto> \<langle>c'';;c\<^sub>2,s',l'\<rangle>` show ?case by auto
  qed
next
  case (Labels_Seq2 c\<^sub>2 l c c\<^sub>1 c')
  note IH = `\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
            \<exists>l'. c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>2 l' c'`
  from IH[OF `\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>`] obtain l' where "c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>2 l' c'" by blast
  from `c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>` have "c\<^sub>1;; c\<^sub>2 \<turnstile> \<langle>c,s,l + #:c\<^sub>1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1\<rangle>"
    by(rule StepRecSeq2)
  moreover
  from `labels c\<^sub>2 l' c'` have "labels (c\<^sub>1;;c\<^sub>2) (l' + #:c\<^sub>1) c'"
    by(rule Labels.Labels_Seq2)
  ultimately show ?case by blast
next
  case (Labels_CondTrue c\<^sub>1 l c b c\<^sub>2 c')
  note label = `labels c\<^sub>1 l c` and red = `\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>`
    and IH = `\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
                   \<exists>l'. c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>1 l' c'`
  from IH[OF `\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>`] obtain l' where "c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>1 l' c'" by blast
  from `c\<^sub>1 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>`
  have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>c,s,l + 1\<rangle> \<leadsto> \<langle>c',s',l' + 1\<rangle>"
    by(rule StepRecCond1)
  moreover
  from `labels c\<^sub>1 l' c'` have "labels (if (b) c\<^sub>1 else c\<^sub>2) (l' + 1) c'"
    by(rule Labels.Labels_CondTrue)
  ultimately show ?case by blast
next
  case (Labels_CondFalse c\<^sub>2 l c b c\<^sub>1 c')
  note IH = `\<And>c'. \<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle> \<Longrightarrow>
            \<exists>l'. c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle> \<and> labels c\<^sub>2 l' c'`
  from IH[OF `\<langle>c,s\<rangle> \<rightarrow> \<langle>c',s'\<rangle>`] obtain l' where "c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels c\<^sub>2 l' c'" by blast
  from `c\<^sub>2 \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>`
  have "if (b) c\<^sub>1 else c\<^sub>2 \<turnstile> \<langle>c,s,l + #:c\<^sub>1 + 1\<rangle> \<leadsto> \<langle>c',s',l' + #:c\<^sub>1 + 1\<rangle>"
    by(rule StepRecCond2)
  moreover
  from `labels c\<^sub>2 l' c'` have "labels (if (b) c\<^sub>1 else c\<^sub>2) (l' + #:c\<^sub>1 + 1) c'"
    by(rule Labels.Labels_CondFalse)
  ultimately show ?case by blast
next
  case (Labels_WhileBody c' l c b cx)
  note IH = `\<And>c''. \<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle> \<Longrightarrow>
            \<exists>l'. c' \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle> \<and> labels c' l' c''`
  from `\<langle>c;;while (b) c',s\<rangle> \<rightarrow> \<langle>cx,s'\<rangle>`
  have "(c = Skip \<and> cx = while (b) c' \<and> s = s') \<or> (\<exists>c''. cx = c'';;while (b) c')"
    by -(erule red.cases,auto)
  thus ?case
  proof
    assume [simp]:"c = Skip \<and> cx = while (b) c' \<and> s = s'"
    have "labels (while (b) c') 0 (while (b) c')"
      by(fastforce intro:Labels_Base)
    from `labels c' l c` have "labels (while (b) c') (l + 2) (Skip;;while (b) c')"
      by(fastforce intro:Labels.Labels_WhileBody simp del:add_2_eq_Suc')
    hence "while (b) c' \<turnstile> \<langle>Skip;;while (b) c',s,l + 2\<rangle> \<leadsto> \<langle>while (b) c',s,0\<rangle>"
      by(rule StepSeqWhile)
    with `labels (while (b) c') 0 (while (b) c')` show ?case by simp blast
  next
    assume "\<exists>c''. cx = c'';;while (b) c'"
    then obtain c'' where [simp]:"cx = c'';;while (b) c'" by blast
    with `\<langle>c;;while (b) c',s\<rangle> \<rightarrow> \<langle>cx,s'\<rangle>` have "\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle>"
      by(auto elim:red.cases)
    from IH[OF this] obtain l' where "c' \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>"
      and "labels c' l' c''" by blast
    from `c' \<turnstile> \<langle>c,s,l\<rangle> \<leadsto> \<langle>c'',s',l'\<rangle>`
    have "while (b) c' \<turnstile> \<langle>c;;while (b) c',s,l + 2\<rangle> \<leadsto> \<langle>c'';;while (b) c',s',l' + 2\<rangle>"
      by(rule StepRecWhile)
    moreover
    from `labels c' l' c''` have "labels (while (b) c') (l' + 2) (c'';;while (b) c')"
      by(rule Labels.Labels_WhileBody)
    ultimately show ?case by simp blast
  qed
next
  case (Labels_WhileExit b c' c'')
  from `\<langle>Skip,s\<rangle> \<rightarrow> \<langle>c'',s'\<rangle>` have False by(auto elim:red.cases)
  thus ?case by simp
qed

lemma reds_steps:
  "\<lbrakk>\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>; labels prog l c\<rbrakk>
  \<Longrightarrow> \<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> \<and> labels prog l' c'"
proof(induct rule:rtranclp_induct2)
  case refl
  from `labels prog l c` show ?case by blast
next
  case (step c'' s'' c' s')
  note IH = `labels prog l c \<Longrightarrow>
    \<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c'',s'',l'\<rangle> \<and> labels prog l' c''`
  from IH[OF `labels prog l c`] obtain l'' where "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c'',s'',l''\<rangle>"
    and "labels prog l'' c''" by blast
  from `labels prog l'' c''` `\<langle>c'',s''\<rangle> \<rightarrow> \<langle>c',s'\<rangle>` obtain l'
    where "prog \<turnstile> \<langle>c'',s'',l''\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>"
    and "labels prog l' c'" by(auto dest:red_step)
  from `prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c'',s'',l''\<rangle>` `prog \<turnstile> \<langle>c'',s'',l''\<rangle> \<leadsto> \<langle>c',s',l'\<rangle>`
  have "prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle>"
    by(fastforce elim:rtranclp_trans)
  with `labels prog l' c'` show ?case by blast
qed

subsubsection {* The bisimulation theorem *}

theorem reds_steps_bisimulation:
  "labels prog l c \<Longrightarrow> (\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>) =
     (\<exists>l'. prog \<turnstile> \<langle>c,s,l\<rangle> \<leadsto>* \<langle>c',s',l'\<rangle> \<and> labels prog l' c')"
  by(fastforce intro:reds_steps elim:steps_reds)

end


(*  Title:      HOL/Nitpick_Examples/Special_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's "specialize" optimization.
*)

section \<open>Examples Featuring Nitpick's \textit{specialize} Optimization\<close>

theory Special_Nits
imports Main
begin

nitpick_params [verbose, card = 4, sat_solver = MiniSat_JNI, max_threads = 1,
                timeout = 240]

fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f1 a b c d e = a + b + c + d + e"

lemma "f1 0 0 0 0 0 = f1 0 0 0 0 (1 - 1)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f1 u v w x y = f1 y x w v u"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f2 a b c d (Suc e) = a + b + c + d + e"

lemma "f2 0 0 0 0 0 = f2 (1 - 1) 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 0 (v - v) 0 (x - x) 0 = f2 (u - u) 0 (w - w) 0 (y - y)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 1 0 0 0 0 = f2 0 1 0 0 0"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f2 0 0 0 0 0 = f2 0 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f3 (Suc a) b 0 d (Suc e) = a + b + d + e" |
"f3 0 b 0 d 0 = b + d"

lemma "f3 a b c d e = f3 e d c b a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f3 a b c d a = f3 a d c d a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "\<lbrakk>c < 1; a \<ge> e; e \<ge> a\<rbrakk> \<Longrightarrow> f3 a b c d a = f3 e d c b e"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "(\<forall>u. a = u \<longrightarrow> f3 a a a a a = f3 u u u u u)
       \<and> (\<forall>u. b = u \<longrightarrow> f3 b b u b b = f3 u u b u u)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

function f4 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"f4 x x = 1" |
"f4 y z = (if y = z then 1 else 0)"
by auto
termination by lexicographic_order

lemma "f4 a b = f4 b a"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f4 a (Suc a) = f4 a a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

fun f5 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
"f5 f (Suc a) = f a"

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {2}. \<exists>two \<in> {1}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = potential]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11 \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then a else h b\<^sub>2) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = none]
nitpick [dont_box, expect = none]
nitpick [dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 \<ge> b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize,
         expect = potential]
oops

end


(*  Title:      HOL/MicroJava/J/JBasis.thy
    Author:     David von Oheimb, TU Muenchen
*)

chapter {* Java Source Language \label{cha:j} *}

section {* Some Auxiliary Definitions *}

theory JBasis imports Main "~~/src/HOL/Library/Transitive_Closure_Table" begin

lemmas [simp] = Let_def

subsection "unique"

definition unique :: "('a \<times> 'b) list => bool" where
  "unique == distinct \<circ> map fst"

lemma fst_in_set_lemma: "(x, y) : set xys ==> x : fst ` set xys"
  by (induct xys) auto

lemma unique_Nil [simp]: "unique []"
  by (simp add: unique_def)

lemma unique_Cons [simp]: "unique ((x,y)#l) = (unique l & (!y. (x,y) ~: set l))"
  by (auto simp: unique_def dest: fst_in_set_lemma)

lemma unique_append: "unique l' ==> unique l ==>
    (!(x,y):set l. !(x',y'):set l'. x' ~= x) ==> unique (l @ l')"
  by (induct l) (auto dest: fst_in_set_lemma)

lemma unique_map_inj: "unique l ==> inj f ==> unique (map (%(k,x). (f k, g k x)) l)"
  by (induct l) (auto dest: fst_in_set_lemma simp add: inj_eq)

subsection "More about Maps"

lemma map_of_SomeI: "unique l ==> (k, x) : set l ==> map_of l k = Some x"
  by (induct l) auto

lemma Ball_set_table: "(\<forall>(x,y)\<in>set l. P x y) ==> (\<forall>x. \<forall>y. map_of l x = Some y --> P x y)"
  by (induct l) auto

lemma table_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) ==>
    map_of t (k, k') = Some x"
  by (atomize (full), induct t) auto

end


(*  Title:      HOL/Auth/Public.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Theory of Public Keys (common to all public-key protocols)

Private and public keys; initial states of agents
*)

theory Public
imports Event
begin

lemma invKey_K: "K \<in> symKeys ==> invKey K = K"
by (simp add: symKeys_def)

subsection\<open>Asymmetric Keys\<close>

datatype keymode = Signature | Encryption

consts
  publicKey :: "[keymode,agent] => key"

abbreviation
  pubEK :: "agent => key" where
  "pubEK == publicKey Encryption"

abbreviation
  pubSK :: "agent => key" where
  "pubSK == publicKey Signature"

abbreviation
  privateKey :: "[keymode, agent] => key" where
  "privateKey b A == invKey (publicKey b A)"

abbreviation
  (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
  priEK :: "agent => key" where
  "priEK A == privateKey Encryption A"

abbreviation
  priSK :: "agent => key" where
  "priSK A == privateKey Signature A"

text\<open>These abbreviations give backward compatibility.  They represent the
simple situation where the signature and encryption keys are the same.\<close>

abbreviation
  pubK :: "agent => key" where
  "pubK A == pubEK A"

abbreviation
  priK :: "agent => key" where
  "priK A == invKey (pubEK A)"

text\<open>By freeness of agents, no two agents have the same key.  Since
  @{term "True\<noteq>False"}, no agent has identical signing and encryption keys\<close>
specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' ==> b=c & A=A'"
   apply (rule exI [of _
       "%b A. 2 * case_agent 0 (\<lambda>n. n + 2) 1 A + case_keymode 0 1 b"])
   apply (auto simp add: inj_on_def split: agent.split keymode.split)
   apply presburger
   apply presburger
   done

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]: "privateKey b A \<noteq> publicKey c A'"

lemmas publicKey_neq_privateKey = privateKey_neq_publicKey [THEN not_sym]
declare publicKey_neq_privateKey [iff]

subsection\<open>Basic properties of @{term pubK} and @{term priK}\<close>

lemma publicKey_inject [iff]: "(publicKey b A = publicKey c A') = (b=c & A=A')"
by (blast dest!: injective_publicKey)

lemma not_symKeys_pubK [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_priK [iff]: "privateKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKey_neq_priEK: "K \<in> symKeys ==> K \<noteq> priEK A"
by auto

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) ==> K \<noteq> K'"
by blast

lemma symKeys_invKey_iff [iff]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by (auto simp add: symKeys_def)

subsection\<open>"Image" equations that hold for injective functions\<close>

lemma invKey_image_eq [simp]: "(invKey x \<in> invKey`A) = (x \<in> A)"
by auto

(*holds because invKey is injective*)
lemma publicKey_image_eq [simp]:
     "(publicKey b x \<in> publicKey c ` AA) = (b=c & x \<in> AA)"
by auto

lemma privateKey_notin_image_publicKey [simp]: "privateKey b x \<notin> publicKey c ` AA"
by auto

lemma privateKey_image_eq [simp]:
     "(privateKey b A \<in> invKey ` publicKey c ` AS) = (b=c & A\<in>AS)"
by auto

lemma publicKey_notin_image_privateKey [simp]: "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

subsection\<open>Symmetric Keys\<close>

text\<open>For some protocols, it is convenient to equip agents with symmetric as
well as asymmetric keys.  The theory \<open>Shared\<close> assumes that all keys
are symmetric.\<close>

consts
  shrK    :: "agent => key"    \<comment>\<open>long-term shared keys\<close>

specification (shrK)
  inj_shrK: "inj shrK"
  \<comment>\<open>No two agents have the same long-term key\<close>
   apply (rule exI [of _ "case_agent 0 (\<lambda>n. n + 2) 1"])
   apply (simp add: inj_on_def split: agent.split)
   done

axiomatization where
  sym_shrK [iff]: "shrK X \<in> symKeys" \<comment>\<open>All shared keys are symmetric\<close>

text\<open>Injectiveness: Agents' long-term keys are distinct.\<close>
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_shrK [simp]: "invKey (shrK A) = shrK A"
by (simp add: invKey_K)

lemma analz_shrK_Decrypt:
     "[| Crypt (shrK A) X \<in> analz H; Key(shrK A) \<in> analz H |] ==> X \<in> analz H"
by auto

lemma analz_Decrypt':
     "[| Crypt K X \<in> analz H; K \<in> symKeys; Key K \<in> analz H |] ==> X \<in> analz H"
by (auto simp add: invKey_K)

lemma priK_neq_shrK [iff]: "shrK A \<noteq> privateKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_priK = priK_neq_shrK [THEN not_sym]
declare shrK_neq_priK [simp]

lemma pubK_neq_shrK [iff]: "shrK A \<noteq> publicKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_pubK = pubK_neq_shrK [THEN not_sym]
declare shrK_neq_pubK [simp]

lemma priEK_noteq_shrK [simp]: "priEK A \<noteq> shrK B"
by auto

lemma publicKey_notin_image_shrK [simp]: "publicKey b x \<notin> shrK ` AA"
by auto

lemma privateKey_notin_image_shrK [simp]: "privateKey b x \<notin> shrK ` AA"
by auto

lemma shrK_notin_image_publicKey [simp]: "shrK x \<notin> publicKey b ` AA"
by auto

lemma shrK_notin_image_privateKey [simp]: "shrK x \<notin> invKey ` publicKey b ` AA"
by auto

lemma shrK_image_eq [simp]: "(shrK x \<in> shrK ` AA) = (x \<in> AA)"
by auto

text\<open>For some reason, moving this up can make some proofs loop!\<close>
declare invKey_K [simp]

subsection\<open>Initial States of Agents\<close>

text\<open>Note: for all practical purposes, all that matters is the initial
knowledge of the Spy.  All other agents are automata, merely following the
protocol.\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where
        (*Agents know their private key and all public keys*)
  initState_Server:
    "initState Server     =
       {Key (priEK Server), Key (priSK Server)} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK) \<union> (Key ` range shrK)"

| initState_Friend:
    "initState (Friend i) =
       {Key (priEK(Friend i)), Key (priSK(Friend i)), Key (shrK(Friend i))} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"

| initState_Spy:
    "initState Spy        =
       (Key ` invKey ` pubEK ` bad) \<union> (Key ` invKey ` pubSK ` bad) \<union>
       (Key ` shrK ` bad) \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"

end

text\<open>These lemmas allow reasoning about @{term "used evs"} rather than
   @{term "knows Spy evs"}, which is useful when there are private Notes.
   Because they depend upon the definition of @{term initState}, they cannot
   be moved up.\<close>

lemma used_parts_subset_parts [rule_format]:
     "\<forall>X \<in> used evs. parts {X} \<subseteq> used evs"
apply (induct evs)
 prefer 2
 apply (simp add: used_Cons split: event.split)
 apply (metis Un_iff empty_subsetI insert_subset le_supI1 le_supI2 parts_subset_iff)
txt\<open>Base case\<close>
apply (auto dest!: parts_cut simp add: used_Nil)
done

lemma MPair_used_D: "\<lbrace>X,Y\<rbrace> \<in> used H ==> X \<in> used H & Y \<in> used H"
by (drule used_parts_subset_parts, simp, blast)

text\<open>There was a similar theorem in Event.thy, so perhaps this one can
  be moved up if proved directly by induction.\<close>
lemma MPair_used [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> used H;
         [| X \<in> used H; Y \<in> used H |] ==> P |]
      ==> P"
by (blast dest: MPair_used_D)

text\<open>Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.\<close>

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

lemma Crypt_notin_initState: "Crypt K X \<notin> parts (initState B)"
by (induct B, auto)

lemma Crypt_notin_used_empty [simp]: "Crypt K X \<notin> used []"
by (simp add: Crypt_notin_initState used_Nil)

(*** Basic properties of shrK ***)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_knows [iff]: "Key (shrK A) \<in> knows A evs"
by (simp add: initState_subset_knows [THEN subsetD])

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(** Fresh keys never clash with long-term shared keys **)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs ==> K \<notin> range shrK"
by blast

lemma shrK_neq: "Key K \<notin> used evs ==> shrK B \<noteq> K"
by blast

lemmas neq_shrK = shrK_neq [THEN not_sym]
declare neq_shrK [simp]

subsection\<open>Function @{term spies}\<close>

lemma not_SignatureE [elim!]: "b \<noteq> Signature \<Longrightarrow> b = Encryption"
  by (cases b, auto)

text\<open>Agents see their own private keys!\<close>
lemma priK_in_initState [iff]: "Key (privateKey b A) \<in> initState A"
  by (cases A, auto)

text\<open>Agents see all public keys!\<close>
lemma publicKey_in_initState [iff]: "Key (publicKey b A) \<in> initState B"
  by (cases B, auto)

text\<open>All public keys are visible\<close>
lemma spies_pubK [iff]: "Key (publicKey b A) \<in> spies evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split: event.split)
done

lemmas analz_spies_pubK = spies_pubK [THEN analz.Inj]
declare analz_spies_pubK [iff]

text\<open>Spy sees private keys of bad agents!\<close>
lemma Spy_spies_bad_privateKey [intro!]:
     "A \<in> bad ==> Key (privateKey b A) \<in> spies evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split: event.split)
done

text\<open>Spy sees long-term shared keys of bad agents!\<close>
lemma Spy_spies_bad_shrK [intro!]:
     "A \<in> bad ==> Key (shrK A) \<in> spies evs"
apply (induct_tac "evs")
apply (simp_all add: imageI knows_Cons split: event.split)
done

lemma publicKey_into_used [iff] :"Key (publicKey b A) \<in> used evs"
apply (rule initState_into_used)
apply (rule publicKey_in_initState [THEN parts.Inj])
done

lemma privateKey_into_used [iff]: "Key (privateKey b A) \<in> used evs"
apply(rule initState_into_used)
apply(rule priK_in_initState [THEN parts.Inj])
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad:
     "[| Crypt (shrK A) X \<in> analz (knows Spy evs);  A \<in> bad |]
      ==> X \<in> analz (knows Spy evs)"
by force

subsection\<open>Fresh Nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection\<open>Supply fresh nonces for possibility theorems\<close>

text\<open>In any trace, there is an upper bound N on the greatest nonce in use\<close>
lemma Nonce_supply_lemma: "EX N. ALL n. N<=n --> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split: event.split)
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "EX N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection\<open>Specialized Rewriting for Theorems About @{term analz} and Image\<close>

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} Un H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

lemma Crypt_imp_keysFor :"[|Crypt K X \<in> H; K \<in> symKeys|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text\<open>Lemma for the trivial direction of the if-and-only-if of the
Session Key Compromise Theorem\<close>
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) --> (K \<in> nE | Key K \<in> analz H)  ==>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment>\<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD]
       insert_Key_singleton
       Key_not_used insert_Key_image Un_assoc [THEN sym]

ML \<open>
structure Public =
struct

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
    delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
    addsimps @{thms analz_image_freshK_simps})

(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt setSolver safe_solver delsimps [@{thm used_Says}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

end
\<close>

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Public.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

subsection\<open>Specialized Methods for Possibility Theorems\<close>

method_setup possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o Public.possibility_tac)\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o Public.basic_possibility_tac)\<close>
    "for proving possibility theorems"

end