section {* Lifting expressions *}

theory utp_lift
  imports
    utp_alphabet
begin

subsection {* Lifting definitions *}

text {* We define operators for converting an expression to and from a relational state space
  with the help of alphabet extrusion and restriction. In general throughout Isabelle/UTP
  we adopt the notation $\lceil P \rceil$ with some subscript to denote lifting an expression
  into a larger alphabet, and $\lfloor P \rfloor$ for dropping into a smaller alphabet.

  The following two functions lift and drop an expression, respectively, whose alphabet is
  @{typ "'\<alpha>"}, into a product alphabet @{typ "'\<alpha> \<times> '\<beta>"}. This allows us to deal with expressions
  which refer only to undashed variables, and use the type-system to ensure this. *}

abbreviation lift_pre :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uexpr" ("\<lceil>_\<rceil>\<^sub><")
where "\<lceil>P\<rceil>\<^sub>< \<equiv> P \<oplus>\<^sub>p fst\<^sub>L"

abbreviation drop_pre :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<lfloor>_\<rfloor>\<^sub><")
where "\<lfloor>P\<rfloor>\<^sub>< \<equiv> P \<restriction>\<^sub>p fst\<^sub>L"

text {* The following two functions lift and drop an expression, respectively, whose alphabet is
  @{typ "'\<beta>"}, into a product alphabet @{typ "'\<alpha> \<times> '\<beta>"}. This allows us to deal with expressions
  which refer only to dashed variables. *}

abbreviation lift_post :: "('a, '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uexpr" ("\<lceil>_\<rceil>\<^sub>>")
where "\<lceil>P\<rceil>\<^sub>> \<equiv> P \<oplus>\<^sub>p snd\<^sub>L"

abbreviation drop_post :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta>) uexpr" ("\<lfloor>_\<rfloor>\<^sub>>")
where "\<lfloor>P\<rfloor>\<^sub>> \<equiv> P \<restriction>\<^sub>p snd\<^sub>L"

abbreviation lift_cond_pre ("\<lceil>_\<rceil>\<^sub>\<leftarrow>") where "\<lceil>P\<rceil>\<^sub>\<leftarrow> \<equiv> P \<oplus>\<^sub>p (1\<^sub>L \<times>\<^sub>L 0\<^sub>L)"
abbreviation lift_cond_post ("\<lceil>_\<rceil>\<^sub>\<rightarrow>") where "\<lceil>P\<rceil>\<^sub>\<rightarrow> \<equiv> P \<oplus>\<^sub>p (0\<^sub>L \<times>\<^sub>L 1\<^sub>L)"

abbreviation drop_cond_pre ("\<lfloor>_\<rfloor>\<^sub>\<leftarrow>") where "\<lfloor>P\<rfloor>\<^sub>\<leftarrow> \<equiv> P \<restriction>\<^sub>p (1\<^sub>L \<times>\<^sub>L 0\<^sub>L)"
abbreviation drop_cond_post ("\<lfloor>_\<rfloor>\<^sub>\<rightarrow>") where "\<lfloor>P\<rfloor>\<^sub>\<rightarrow> \<equiv> P \<restriction>\<^sub>p (0\<^sub>L \<times>\<^sub>L 1\<^sub>L)"

subsection {* Lifting Laws *}

text {* With the help of our alphabet laws, we can prove some intuitive laws about alphabet
  lifting. For example, lifting variables yields an unprimed or primed relational variable
  expression, respectively. *}

lemma lift_pre_var [simp]:
  "\<lceil>var x\<rceil>\<^sub>< = $x"
  by (alpha_tac)

lemma lift_post_var [simp]:
  "\<lceil>var x\<rceil>\<^sub>> = $x\<acute>"
  by (alpha_tac)

lemma lift_cond_pre_var [simp]:
  "\<lceil>$x\<rceil>\<^sub>\<leftarrow> = $x"
  by (pred_auto)

lemma lift_cond_post_var [simp]:
  "\<lceil>$x\<acute>\<rceil>\<^sub>\<rightarrow> = $x\<acute>"
  by (pred_auto)

subsection {* Substitution Laws *}

lemma pre_var_subst [usubst]:
  "\<sigma>($x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> \<lceil>P\<rceil>\<^sub>< = \<sigma> \<dagger> \<lceil>P\<lbrakk>\<guillemotleft>v\<guillemotright>/&x\<rbrakk>\<rceil>\<^sub><"
  by (pred_simp)

subsection {* Unrestriction laws *}

text {* Crucially, the lifting operators allow us to demonstrate unrestriction properties. For
  example, we can show that no primed variable is restricted in an expression over only the
  first element of the state-space product type. *}

lemma unrest_dash_var_pre [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp> \<lceil>p\<rceil>\<^sub><"
  by (pred_auto)

lemma unrest_dash_var_cond_pre [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>\<leftarrow>"
  by (pred_auto)
end


theory ElGamal
imports Hoare_Tactics Procs_Typed Tactic_Inline Lang_Simplifier RHL_Typed Callproc ML_Term LangSyntax2
begin

(* Working EC version with elgamal.ec:
  47f69a002b66340bb3b4967b46973670a0e46750 (2015-10-16)
*)

subsection {* General setup *}

default_sort prog_type

class ab_group_mult = inverse + ab_semigroup_mult + monoid_mult +
  assumes left_inverse [simp]: "(inverse a) * a = 1"

lemma (in ab_group_mult) right_inverse [simp]: "a * inverse a = 1"
  by (subst mult_commute, simp)

locale group =
  (* fixes 'G *)
  fixes g::"'G::{prog_type,inverse,power,ab_group_mult}" (* generator *)
  and q::nat (* group order *)

subsection {* DDH *}

type_synonym Game = "(unit,bool) procedure"
type_synonym 'g DDH_Adv = "('g*'g*'g,bool) procedure"

procedure (in group) DDH0 :: "'G DDH_Adv =proc=> Game" where
  "DDH0 <$> A =
    PR \<open>proc () {
      x <$ uniform {0..<q};
      y <$ uniform {0..<q};
      b <@ A (g^x, g^y, g^(x*y));
      return b
    }\<close>"

procedure (in group) DDH1 :: "'G DDH_Adv =proc=> Game" where
  "DDH1 <$> A =
    PR \<open>proc () {
      x <$ uniform {0..<q};
      y <$ uniform {0..<q};
      z <$ uniform {0..<q};
      b <@ A (g^x, g^y, g^z);
      return b
    }\<close>"

subsection {* PKE definitions *}

module_type ('pk,'sk,'m,'c) EncScheme =
  keygen :: "(unit,'pk*'sk) procedure"
  enc :: "('pk*'m, 'c) procedure"
  dec :: "('sk*'c, 'm option) procedure"
(*setup {*
  Lang_Syntax2.insert_field_selector_thy "keygen" @{type_name EncScheme} @{const_name keygen}
  #> Lang_Syntax2.insert_field_selector_thy "enc" @{type_name EncScheme} @{const_name enc}
  #> Lang_Syntax2.insert_field_selector_thy "dec" @{type_name EncScheme} @{const_name dec}
*}*)

(*module_type ('pk,'sk,'m,'c) Adversary =
  choos :: "('pk,'m*'m)procedure"
  "guess" :: "('c,bool)procedure"

procedure CPA :: "('pk,'sk,'m,'c) EncScheme * ('pk,'sk,'m,'c) Adversary =proc=> Game" where
  "CPA<$>(E,A) = LOCAL pk sk m0 m1 c b b'. proc() {
    (pk, sk) <@ keygen<$>E();
    (m0, m1) <@ choos<$>A(pk);
    b        <- uniform UNIV;
    c        <@ enc<$>E(pk, if b then m1 else m0);
    b'       <@ guess<$>A(c);
    return (b' = b)
  }"*)

subsection {* Declaring CPA game *}

module_type ('pk,'sk,'m,'c) CPA_Adv =
  pick    :: "('pk,'m*'m) procedure"
  "guess" :: "('c,bool) procedure"
(* setup {* declare_method_field_selector @{binding pick} *} *)

  (*
setup {*
  Lang_Syntax2.insert_field_selector_thy "pick" @{type_name CPA_Adv} @{const_name pick}
  #> Lang_Syntax2.insert_field_selector_thy "guess" @{type_name CPA_Adv} @{const_name guess}
*}*)

term "(E::(_,_,_,_)CPA_Adv) .pick"

procedure CPA_main :: "('pk,'sk,'m,'c) EncScheme * ('pk,'sk,'m,'c) CPA_Adv =proc=> (unit,bool)procedure" where
 "CPA_main <$> (E,A) =
  PR \<open>proc () {
    (pk,sk) <@ E.keygen ();
    (m0,m1) <@ A.pick (pk);
    b <$ uniform UNIV;
    c <@ E.enc(pk, if b then m1 else m0);
    b' <@ A.guess (c);
    return b'=b
  }\<close>"

subsection {* ElGamal *}

(* These should be generated by module_type EncScheme *)

lemma aux1 [reduce_procfun.safe]:
  assumes "schematic=Abs_EncScheme(A,B,C)"
  assumes "A=Y"
  shows "EncScheme.keygen<$>schematic = Y"
using assms by simp

lemma aux2 [reduce_procfun.safe]:
  assumes "schematic=Abs_EncScheme(A,B,C)"
  assumes "B=Y"
  shows "EncScheme.enc<$>schematic = Y"
using assms by simp

lemma aux3 [reduce_procfun.safe]:
  assumes "schematic=Abs_EncScheme(A,B,C)"
  assumes "C=Y"
  shows "EncScheme.dec<$>schematic = Y"
using assms by simp

procedure (in group) ElGamal :: "('G, nat, 'G, 'G\<times>'G) EncScheme" where
    "EncScheme.keygen<$>ElGamal = PR \<open>proc() { sk <$ uniform {0..<q}; return (g^sk, sk) }\<close>"
| "EncScheme.enc<$>ElGamal = PR \<open>proc(pk,m) { y <$ uniform {0..<q}; return (g^y, pk^y * m) }\<close>"
| "EncScheme.dec<$>ElGamal = PR \<open>proc(sk,(c1,c2)) { gy := c1; gm := c2; return Some (gm * inverse (gy^sk)) }\<close>"

procedure Correctness :: "(_,_,_,_) EncScheme =proc=> (_,bool)procedure" where
  "Correctness <$> E =
  PR \<open>proc(m) {
    (pk,sk) <@ E.keygen ();
    c <@ E.enc (pk, m);
    m2 <@ E.dec (sk, c);
    return (m2 = Some m)
  }\<close>"

context group begin

lemma correctness:
  defines "G = Correctness <$> ElGamal"
  shows "hoare {True} succ0 <@ G(m) {succ0}"
apply (inline "Correctness<$>ElGamal")
apply (inline "keygen<$>ElGamal")
apply (inline "dec<$>ElGamal")
apply (inline "enc<$>ElGamal")
apply (wp sample) apply skip apply auto
unfolding power_mult[symmetric] apply (subst mult.commute[where 'a=nat])
apply (subst mult.commute[where 'a='G]) apply (subst mult.assoc) by simp

(* sorry (* "uncommented for speed" *) *)

type_synonym 'g ElGamal_Adv = "('g, nat, 'g, 'g\<times>'g) CPA_Adv"

procedure DDHAdv :: "'G ElGamal_Adv =proc=> 'G DDH_Adv" where
  "DDHAdv <$> A = PR\<open>
    proc (gx, gy, gz) {
      (m0, m1) <@ A.pick(gx);
      b  <$ uniform UNIV;
      b' <@ A.guess(gy, gz * (if b then m1 else m0));
      return b' = b
  }\<close>"

(* TODO move, add syntax *)
definition "game_probability game args mem E ==
  LOCAL res.
  probability
    (denotation (callproc (variable_pattern res) game (const_expression args)) mem)
    {m. E (memory_lookup m res)}"

(* TODO move *)
(* TODO: correct precondition (refer only to globals of p1,p2) *)
lemma byequiv_rule:
  assumes "LOCAL res1 res2. hoare {&1=m \<and> &2=m} (res1 <@ p1(a1)) ~ (res2 <@ p2(a2)) {E (res1)\<^sub>1 \<longleftrightarrow> F (res2)\<^sub>2}"
  shows "game_probability p1 a1 m E = game_probability p2 a2 m F"
proof -
  let ?res1 = "LOCAL res1. (res1 :: 'a variable)"
  let ?res2 = "LOCAL res2. (res2 :: 'c variable)"
  let ?res1' = "LOCAL res. (res :: 'a variable)"
  let ?res2' = "LOCAL res. (res :: 'c variable)"
  let ?pr1 = "PROGRAM[ ?res1 <@ p1(a1) ]"
  let ?pr2 = "PROGRAM[ ?res2 <@ p2(a2) ]"
  obtain \<mu> where fst: "apply_to_distr fst \<mu> = denotation ?pr1 m"
             and snd: "apply_to_distr snd \<mu> = denotation ?pr2 m"
             and supp: "\<And>m1' m2'. (m1',m2') \<in> support_distr \<mu> \<Longrightarrow> E (memory_lookup m1' ?res1) = F (memory_lookup m2' ?res2)"
    using assms unfolding rhoare_def program_def by auto
  have "game_probability p1 a1 m E = probability (denotation PROGRAM[ ?res1' <@ p1(a1) ] m) {m. E (memory_lookup m ?res1')}"
    unfolding game_probability_def program_def by simp
  also have "\<dots> = probability (denotation ?pr1 m) {m. E (memory_lookup m ?res1)}"
    sorry
  also have "... = probability (apply_to_distr fst \<mu>) {m. E (memory_lookup m ?res1)}"
    unfolding fst by simp
  also have "\<dots> = probability \<mu> {m12. E (memory_lookup (fst m12) ?res1)}"
    unfolding probability_apply_to_distr by simp
  also have "\<dots> = probability \<mu> {m12. F (memory_lookup (snd m12) ?res2)}"
    apply (rule probability_cong)
    using supp by auto
  also have "... = probability (apply_to_distr snd \<mu>) {m. F (memory_lookup m ?res2)}"
    unfolding probability_apply_to_distr by simp
  also have "\<dots> = probability (denotation ?pr2 m) {m. F (memory_lookup m ?res2)}"
    unfolding snd by simp
  also have "\<dots> = probability (denotation PROGRAM[ ?res2' <@ p2(a2) ] m) {m. F (memory_lookup m ?res2')}"
    sorry
  also have "\<dots> = game_probability p2 a2 m F"
    unfolding game_probability_def program_def by simp

  finally show ?thesis by assumption
qed

(* TODO move *)
lemma denotation_eq_rule_left:
  assumes "denotation d = denotation c"
  assumes "rhoare P c e Q"
  shows   "rhoare P d e Q"
using assms unfolding rhoare_def by auto

(* TODO move *)
lemma lang_simp_assign_ignore [lang_simp]: "fun_equiv denotation (assign ignore_pattern e) Lang_Typed.skip"
  sorry

lemma LVariable_notin_write_vars_proc_global [simp]: "mk_variable_untyped (LVariable x) \<notin> set (write_vars_proc_global f)" sorry
lemma LVariable_notin_vars_proc_global [simp]: "mk_variable_untyped (LVariable x) \<notin> set (vars_proc_global f)" sorry

(* abbreviation "res == LVariable ''res''"
abbreviation "args == LVariable ''args''" *)

(* TODO: define product_type on untyped level *)
(* TODO define pair pattern on untyped level *)
(*definition pair_pattern_untyped :: "pattern_untyped \<Rightarrow> pattern_untyped \<Rightarrow> pattern_untyped" where
  "pair_pattern_untyped p1 p2 = Abs_pattern_untyped
  \<lparr> pur_var_getters=(map (\<lambda>(v,g). (v,g o fst o inv val_prod_embedding)) (pu_var_getters p1))
                  @ (map (\<lambda>(v,g). (v,g o snd o inv val_prod_embedding)) (pu_var_getters p2)),
    pur_type=Type TYPE('a::prog_type*'b::prog_type) \<rparr>) :: ('a*'b) pattern) \<rparr>"
lemma Rep_pair_pattern': "Rep_pattern (pair_pattern x y) = pair_pattern_untyped (Rep_pattern x) (Rep_pattern y)"
  sorry*)

(* fun list_pattern_untyped :: "variable_untyped list \<Rightarrow> pattern_untyped" where
  "list_pattern_untyped [] = pattern_ignore unit_type"
| "list_pattern_untyped (x#xs) = pair_pattern_untyped (pattern_1var x) (list_pattern_untyped xs)" *)

(*
lemma list_pattern_untyped_nil: "list_pattern_untyped [] = Rep_pattern unit_pattern"
  apply simp apply (subst Rep_pattern_untyped_inject[symmetric]) unfolding Rep_unit_pattern Rep_pattern_ignore by (auto simp: Type_def unit_type_def)
lemma list_pattern_untyped_cons: "list_pattern_untyped (mk_variable_untyped x # xs)
     = Rep_pattern (pair_pattern (variable_pattern x) (Abs_pattern (list_pattern_untyped xs)))"
  apply simp unfolding Rep_pair_pattern Rep_variable_pattern
  apply (subst Abs_pattern_inverse) apply simp
sorry
*)

(* abbreviation "list_pattern xs == Abs_pattern (list_pattern_untyped xs)"

abbreviation "x1 == LVariable ''x1'' :: int variable"
abbreviation "x2 == LVariable ''x2'' :: bool variable"
abbreviation "x3 == LVariable ''x3'' :: (nat\<Rightarrow>nat) variable"

lemma t1: "pattern_ignore unit_type = Rep_pattern unit_pattern"
  apply (rule Rep_pattern_untyped_inject[THEN iffD1])
  unfolding Rep_unit_pattern Rep_pattern_ignore
  by (simp add: Type_def unit_type_def)

lemma "list_pattern [mk_variable_untyped x1, mk_variable_untyped x2, mk_variable_untyped x3] =
(pair_pattern (variable_pattern x1) (pair_pattern (variable_pattern x2) (pair_pattern (variable_pattern x3) unit_pattern)))"
using[[show_consts]]
  by (simp add: t1 Rep_variable_pattern[symmetric] Rep_pair_pattern[symmetric] Rep_pattern_inverse) *)

(*
{P} f ~ g {Q}
{A} p ~ q {  P{y_1/arg_1, y_2/arg_2}  /\
      \forall gR,gL,yL,yR.   Q{gL/glob f1,gR/glob f2,yL/res_1,yR/res_2}
                                ==> B{gL/glob f1,gR/glob f2,yL/x_1,yR/x_2}  }
-----------------------------------------------
{A} p;x=f(y) ~ q;x=f(y) {B}
*)

lemma cpa_ddh0:
  "game_probability (CPA_main<$>(ElGamal,A)) () m (\<lambda>res. res)
 = game_probability (DDH0<$>(DDHAdv<$>A)) () m (\<lambda>res. res)"

apply (rule byequiv_rule)
apply (inline "CPA_main<$>(ElGamal,A)")
apply (inline "DDH0<$>(DDHAdv<$>A)")
apply (inline "keygen <$> ElGamal")
apply (inline "enc <$> ElGamal")
apply (inline "DDHAdv<$>A")
apply simp

find_theorems "fun_equiv denotation (assign (?x) ?e) Lang_Typed.skip"
(*
pre = (glob A){2} = (glob A){m} /\ (glob A){1} = (glob A){m}

sk0 <$ FDistr.dt            (1)  x <$ FDistr.dt
(pk, sk) <- (g ^ sk0, sk0)  (2)  y <$ FDistr.dt
(m0, m1) <@ A.choose(pk)    (3)  gx <- g ^ x
b <$ {0,1}                  (4)  gy <- g ^ y
pk0 <- pk                   (5)  gz <- g ^ (x * y)
m <- b ? m1 : m0            (6)  (m0, m1) <@ A.choose(gx)
y <$ FDistr.dt              (7)  b0 <$ {0,1}
c <- (g ^ y, pk0 ^ y * m)   (8)  b' <@ A.guess(gy, gz * (b0 ? m1 : m0))
b' <@ A.guess(c)            (9)  b <- b' = b0

post = (b'{1} = b{1}) = b{2}
*)

apply (rule denotation_eq_rule_left) apply (tactic \<open>Hoare_Tactics.swap_tac @{context} ([10],6) 4 false 1\<close>) (* TODO right numbers *)
apply simp

(*
pre = (glob A){2} = (glob A){m} /\ (glob A){1} = (glob A){m}

sk0 <$ FDistr.dt            (1)  x <$ FDistr.dt
y <$ FDistr.dt              (2)  y <$ FDistr.dt
(pk, sk) <- (g ^ sk0, sk0)  (3)  gx <- g ^ x
(m0, m1) <@ A.choose(pk)    (4)  gy <- g ^ y
b <$ {0,1}                  (5)  gz <- g ^ (x * y)
pk0 <- pk                   (6)  (m0, m1) <@ A.choose(gx)
m <- b ? m1 : m0            (7)  b0 <$ {0,1}
c <- (g ^ y, pk0 ^ y * m)   (8)  b' <@ A.guess(gy, gz * (b0 ? m1 : m0))
b' <@ A.guess(c)            (9)  b <- b' = b0

post = (b'{1} = b{1}) = b{2}
*)

apply wp
apply simp?

(*
pre = (glob A){2} = (glob A){m} /\ (glob A){1} = (glob A){m}

sk0 <$ FDistr.dt            (1)  x <$ FDistr.dt
y <$ FDistr.dt              (2)  y <$ FDistr.dt
(pk, sk) <- (g ^ sk0, sk0)  (3)  gx <- g ^ x
(m0, m1) <@ A.choose(pk)    (4)  gy <- g ^ y
b <$ {0,1}                  (5)  gz <- g ^ (x * y)
pk0 <- pk                   (6)  (m0, m1) <@ A.choose(gx)
m <- b ? m1 : m0            (7)  b0 <$ {0,1}
c <- (g ^ y, pk0 ^ y * m)   (8)  b' <@ A.guess(gy, gz * (b0 ? m1 : m0))
b' <@ A.guess(c)            (9)

post = (b'{1} = b{1}) = (b'{2} = b0{2})
*)

(* apply (rule callproc_split_result[where ?x1.0="LVariable ''res''" and ?x2.0="LVariable ''res''"])
  close (tactic \<open>Tactic_Inline.assertion_footprint_tac @{context} 1\<close>; simp)
 close (tactic \<open>Tactic_Inline.assertion_footprint_tac @{context} 1\<close>; simp) *)

apply (rule callproc_split_args[where ?x1.0="LVariable ''args''" and ?x2.0="LVariable ''args''"])
      close (tactic \<open>Tactic_Inline.assertion_footprint_tac @{context} 1\<close>; simp)
     close (tactic \<open>Tactic_Inline.assertion_footprint_tac @{context} 1\<close>; simp)
    close 4

apply (rule call_rule_abstract[where globals_f="remdups (vars_proc_global (guess <$> A))"])
close
using write_vars_proc_global_subset_vars_proc_global close
close
close
close
close
close
close

(*
  local lemma cpa_ddh0 &m:
      Pr[CPA(ElGamal,A).main() @ &m : res] =
      Pr[DDH0(DDHAdv(A)).main() @ &m : res].
  proof.
    byequiv => //;proc;inline *.
    swap{1} 7 -5.
    auto;call (_:true);auto;call (_:true);auto;progress;smt.
  qed.

  local module Gb = {
    proc main () : bool = {
      var x, y, z, m0, m1, b, b';
      x  = $FDistr.dt;
      y  = $FDistr.dt;
      (m0,m1) = A.choose(g^x);
      z  = $FDistr.dt;
      b' = A.guess(g^y, g^z);
      b  = ${0,1};
      return b' = b;
    }
  }.

  local lemma ddh1_gb &m:
      Pr[DDH1(DDHAdv(A)).main() @ &m : res] =
      Pr[Gb.main() @ &m : res].
  proof.
    byequiv => //;proc;inline *.
    swap{1} 3 2;swap{1} [5..6] 2;swap{2} 6 -2.
    auto;call (_:true);wp.
    rnd (fun z, z + log(if b then m1 else m0){2})
        (fun z, z - log(if b then m1 else m0){2}).
    auto;call (_:true);auto;progress; (algebra || smt).
  qed.

  axiom Ac_l : islossless A.choose.
  axiom Ag_l : islossless A.guess.

  local lemma Gb_half &m:
     Pr[Gb.main()@ &m : res] = 1%r/2%r.
  proof.
    byphoare => //;proc.
    rnd  ((=) b')=> //=.
    call Ag_l;auto;call Ac_l;auto;progress;smt.
  qed.

  lemma conclusion &m :
    `| Pr[CPA(ElGamal,A).main() @ &m : res] - 1%r/2%r | =
    `| Pr[DDH0(DDHAdv(A)).main() @ &m : res] -
         Pr[DDH1(DDHAdv(A)).main() @ &m : res] |.
  proof.
   by rewrite (cpa_ddh0 &m) (ddh1_gb &m) (Gb_half &m).
  qed.
*)

end (* context: group *)

end (* theory *)


section \<open> Circus Trace Merge \<close>

theory utp_circus_traces
  imports "UTP1-Stateful-Failures.utp_sf_rdes"
begin

subsection \<open> Function Definition \<close>

fun tr_par ::
  "'\<theta> set \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> list set" where
"tr_par cs [] [] = {[]}" |
"tr_par cs (e # t) [] = (if e \<in> cs then {[]} else {[e]} \<^sup>\<frown> (tr_par cs t []))" |
"tr_par cs [] (e # t) = (if e \<in> cs then {[]} else {[e]} \<^sup>\<frown> (tr_par cs [] t))" |
"tr_par cs (e\<^sub>1 # t\<^sub>1) (e\<^sub>2 # t\<^sub>2) =
  (if e\<^sub>1 = e\<^sub>2
    then
      if e\<^sub>1 \<in> cs
        then {[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 t\<^sub>2)
        else
          ({[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 (e\<^sub>2 # t\<^sub>2))) \<union>
          ({[e\<^sub>2]} \<^sup>\<frown> (tr_par cs (e\<^sub>1 # t\<^sub>1) t\<^sub>2))
    else
      if e\<^sub>1 \<in> cs then
        if e\<^sub>2 \<in> cs then {[]}
        else
          {[e\<^sub>2]} \<^sup>\<frown> (tr_par cs (e\<^sub>1 # t\<^sub>1) t\<^sub>2)
      else
        if e\<^sub>2 \<in> cs then
          {[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 (e\<^sub>2 # t\<^sub>2))
        else
          {[e\<^sub>1]} \<^sup>\<frown> (tr_par cs t\<^sub>1 (e\<^sub>2 # t\<^sub>2)) \<union>
          {[e\<^sub>2]} \<^sup>\<frown> (tr_par cs (e\<^sub>1 # t\<^sub>1) t\<^sub>2))"

abbreviation tr_inter :: "'\<theta> list \<Rightarrow> '\<theta> list \<Rightarrow> '\<theta> list set" (infixr "|||\<^sub>t" 100) where
"x |||\<^sub>t y \<equiv> tr_par {} x y"

subsection {* Lifted Trace Merge *}

syntax "_utr_par" ::
  "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(_ \<star>\<^bsub>_\<^esub>/ _)" [100, 0, 101] 100)

text {* The function @{const trop} is used to lift ternary operators. *}

translations
  "t1 \<star>\<^bsub>cs\<^esub> t2" == "(CONST bop) (CONST tr_par cs) t1 t2"

subsection {* Trace Merge Lemmas *}

lemma tr_par_empty:
"tr_par cs t1 [] = {takeWhile (\<lambda>x. x \<notin> cs) t1}"
"tr_par cs [] t2 = {takeWhile (\<lambda>x. x \<notin> cs) t2}"
\<comment> \<open> Subgoal 1 \<close>
apply (induct t1; simp)
\<comment> \<open> Subgoal 2 \<close>
apply (induct t2; simp)
done

lemma tr_par_sym:
"tr_par cs t1 t2 = tr_par cs t2 t1"
apply (induct t1 arbitrary: t2)
\<comment> \<open> Subgoal 1 \<close>
apply (simp add: tr_par_empty)
\<comment> \<open> Subgoal 2 \<close>
apply (induct_tac t2)
\<comment> \<open> Subgoal 2.1 \<close>
apply (clarsimp)
\<comment> \<open> Subgoal 2.2 \<close>
apply (clarsimp)
apply (blast)
done

lemma tr_inter_sym: "x |||\<^sub>t y = y |||\<^sub>t x"
  by (simp add: tr_par_sym)

lemma trace_merge_nil [simp]: "x \<star>\<^bsub>{}\<^esub> U([]) = {x}\<^sub>u"
  by (pred_auto, simp_all add: tr_par_empty, metis takeWhile_eq_all_conv)

lemma trace_merge_empty [simp]:
  "(U([]) \<star>\<^bsub>cs\<^esub> U([])) = U({[]})"
  by (rel_auto)

lemma trace_merge_single_empty [simp]:
  "a \<in> cs \<Longrightarrow> U([\<guillemotleft>a\<guillemotright>]) \<star>\<^bsub>cs\<^esub> U([]) = U({[]})"
  by (rel_auto)

lemma trace_merge_empty_single [simp]:
  "a \<in> cs \<Longrightarrow> U([]) \<star>\<^bsub>cs\<^esub> U([\<guillemotleft>a\<guillemotright>]) = U({[]})"
  by (rel_auto)

lemma trace_merge_commute: "t\<^sub>1 \<star>\<^bsub>cs\<^esub> t\<^sub>2 = t\<^sub>2 \<star>\<^bsub>cs\<^esub> t\<^sub>1"
  by (rel_simp, simp add: tr_par_sym)

lemma csp_trace_simps [simp]:
  "U(v + []) = v" "U([] + v) = v"
  "bop (#) x xs ^\<^sub>u ys = bop (#) x (xs ^\<^sub>u ys)"
  by (rel_auto)+

text \<open> Alternative characterisation of traces, adapted from CSP-Prover \<close>

inductive_set
  parx :: "'a set => ('a list * 'a list * 'a list) set"
  for X :: "'a set"

where
parx_nil_nil [intro]:
  "([], [], []) \<in> parx X" |

parx_Ev_nil [intro]:
  "[| (u, s, []) \<in> parx X ; a \<notin> X |]
   ==> (a # u, a # s, []) \<in> parx X" |

parx_nil_Ev [intro]:
  "[| (u, [], t) \<in> parx X ; a \<notin> X |]
   ==> (a # u, [], a # t) \<in> parx X" |

parx_Ev_sync [intro]:
  "[| (u, s, t) \<in> parx X ; a \<in> X |]
   ==> (a # u, a # s, a # t) \<in> parx X" |

parx_Ev_left [intro]:
  "[| (u, s, t) \<in> parx X ; a \<notin> X |]
   ==> (a # u, a # s, t) \<in> parx X" |

parx_Ev_right [intro]:
  "[| (u, s, t) \<in> parx X ; a \<notin> X |]
   ==> (a # u, s, a # t) \<in> parx X"

lemma parx_implies_tr_par: "(t, t\<^sub>1, t\<^sub>2) \<in> parx cs \<Longrightarrow> t \<in> tr_par cs t\<^sub>1 t\<^sub>2"
  apply (induct rule: parx.induct)
       apply (auto)
   apply (case_tac t)
    apply (auto)
  apply (case_tac s)
   apply (auto)
  done

end


(*  Title:      HOL/Cardinals/Wellorder_Extension.thy
    Author:     Christian Sternagel, JAIST
*)

section \<open>Extending Well-founded Relations to Wellorders\<close>

theory Wellorder_Extension
imports MainRLT Order_Union
begin

subsection \<open>Extending Well-founded Relations to Wellorders\<close>

text \<open>A \emph{downset} (also lower set, decreasing set, initial segment, or
downward closed set) is closed w.r.t.\ smaller elements.\<close>
definition downset_on where
  "downset_on A r = (\<forall>x y. (x, y) \<in> r \<and> y \<in> A \<longrightarrow> x \<in> A)"

(*
text {*Connection to order filters of the @{theory Cardinals} theory.*}
lemma (in wo_rel) ofilter_downset_on_conv:
  "ofilter A \<longleftrightarrow> downset_on A r \<and> A \<subseteq> Field r"
  by (auto simp: downset_on_def ofilter_def under_def)
*)

lemma downset_onI:
  "(\<And>x y. (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A) \<Longrightarrow> downset_on A r"
  by (auto simp: downset_on_def)

lemma downset_onD:
  "downset_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A"
  unfolding downset_on_def by blast

text \<open>Extensions of relations w.r.t.\ a given set.\<close>
definition extension_on where
  "extension_on A r s = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> s \<longrightarrow> (x, y) \<in> r)"

lemma extension_onI:
  "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A; (x, y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r) \<Longrightarrow> extension_on A r s"
  by (auto simp: extension_on_def)

lemma extension_onD:
  "extension_on A r s \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> (x, y) \<in> s \<Longrightarrow> (x, y) \<in> r"
  by (auto simp: extension_on_def)

lemma downset_on_Union:
  assumes "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p"
  shows "downset_on (Field (\<Union>R)) p"
  using assms by (auto intro: downset_onI dest: downset_onD)

lemma chain_subset_extension_on_Union:
  assumes "chain\<^sub>\<subseteq> R" and "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
  shows "extension_on (Field (\<Union>R)) (\<Union>R) p"
  using assms
  by (simp add: chain_subset_def extension_on_def)
     (metis (no_types) mono_Field subsetD)

lemma downset_on_empty [simp]: "downset_on {} p"
  by (auto simp: downset_on_def)

lemma extension_on_empty [simp]: "extension_on {} p q"
  by (auto simp: extension_on_def)

text \<open>Every well-founded relation can be extended to a wellorder.\<close>
theorem well_order_extension:
  assumes "wf p"
  shows "\<exists>w. p \<subseteq> w \<and> Well_order w"
proof -
  let ?K = "{r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p}"
  define I where "I = init_seg_of \<inter> ?K \<times> ?K"
  have I_init: "I \<subseteq> init_seg_of" by (simp add: I_def)
  then have subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
    by (auto simp: init_seg_of_def chain_subset_def Chains_def)
  have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow>
      Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p"
    by (simp add: Chains_def I_def) blast
  have FI: "Field I = ?K" by (auto simp: I_def init_seg_of_def Field_def)
  then have 0: "Partial_order I"
    by (auto simp: partial_order_on_def preorder_on_def antisym_def antisym_init_seg_of refl_on_def
      trans_def I_def elim: trans_init_seg_of)
  have "\<Union>R \<in> ?K \<and> (\<forall>r\<in>R. (r,\<Union>R) \<in> I)" if "R \<in> Chains I" for R
  proof -
    from that have Ris: "R \<in> Chains init_seg_of" using mono_Chains [OF I_init] by blast
    have subch: "chain\<^sub>\<subseteq> R" using \<open>R \<in> Chains I\<close> I_init
      by (auto simp: init_seg_of_def chain_subset_def Chains_def)
    have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r" and
      "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)" and
      "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p" and
      "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
      using Chains_wo [OF \<open>R \<in> Chains I\<close>] by (simp_all add: order_on_defs)
    have "Refl (\<Union>R)" using \<open>\<forall>r\<in>R. Refl r\<close>  unfolding refl_on_def by fastforce
    moreover have "trans (\<Union>R)"
      by (rule chain_subset_trans_Union [OF subch \<open>\<forall>r\<in>R. trans r\<close>])
    moreover have "antisym (\<Union>R)"
      by (rule chain_subset_antisym_Union [OF subch \<open>\<forall>r\<in>R. antisym r\<close>])
    moreover have "Total (\<Union>R)"
      by (rule chain_subset_Total_Union [OF subch \<open>\<forall>r\<in>R. Total r\<close>])
    moreover have "wf ((\<Union>R) - Id)"
    proof -
      have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
      with \<open>\<forall>r\<in>R. wf (r - Id)\<close> wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
      show ?thesis by fastforce
    qed
    ultimately have "Well_order (\<Union>R)" by (simp add: order_on_defs)
    moreover have "\<forall>r\<in>R. r initial_segment_of \<Union>R" using Ris
      by (simp add: Chains_init_seg_of_Union)
    moreover have "downset_on (Field (\<Union>R)) p"
      by (rule downset_on_Union [OF \<open>\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p\<close>])
    moreover have "extension_on (Field (\<Union>R)) (\<Union>R) p"
      by (rule chain_subset_extension_on_Union [OF subch \<open>\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p\<close>])
    ultimately show ?thesis
      using mono_Chains [OF I_init] and \<open>R \<in> Chains I\<close>
      by (simp (no_asm) add: I_def del: Field_Union) (metis Chains_wo)
  qed
  then have 1: "\<exists>u\<in>Field I. \<forall>r\<in>R. (r, u) \<in> I" if "R\<in>Chains I" for R
    using that by (subst FI) blast
  txt \<open>Zorn's Lemma yields a maximal wellorder m.\<close>
  from Zorns_po_lemma [OF 0 1] obtain m :: "('a \<times> 'a) set"
    where "Well_order m" and "downset_on (Field m) p" and "extension_on (Field m) m p" and
    max: "\<forall>r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p \<and>
      (m, r) \<in> I \<longrightarrow> r = m"
    by (auto simp: FI)
  have "Field p \<subseteq> Field m"
  proof (rule ccontr)
    let ?Q = "Field p - Field m"
    assume "\<not> (Field p \<subseteq> Field m)"
    with assms [unfolded wf_eq_minimal, THEN spec, of ?Q]
      obtain x where "x \<in> Field p" and "x \<notin> Field m" and
      min: "\<forall>y. (y, x) \<in> p \<longrightarrow> y \<notin> ?Q" by blast
    txt \<open>Add \<^term>\<open>x\<close> as topmost element to \<^term>\<open>m\<close>.\<close>
    let ?s = "{(y, x) | y. y \<in> Field m}"
    let ?m = "insert (x, x) m \<union> ?s"
    have Fm: "Field ?m = insert x (Field m)" by (auto simp: Field_def)
    have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
      using \<open>Well_order m\<close> by (simp_all add: order_on_defs)
    txt \<open>We show that the extension is a wellorder.\<close>
    have "Refl ?m" using \<open>Refl m\<close> Fm by (auto simp: refl_on_def)
    moreover have "trans ?m" using \<open>trans m\<close> \<open>x \<notin> Field m\<close>
      unfolding trans_def Field_def Domain_unfold Domain_converse [symmetric] by blast
    moreover have "antisym ?m" using \<open>antisym m\<close> \<open>x \<notin> Field m\<close>
      unfolding antisym_def Field_def Domain_unfold Domain_converse [symmetric] by blast
    moreover have "Total ?m" using \<open>Total m\<close> Fm by (auto simp: Relation.total_on_def)
    moreover have "wf (?m - Id)"
    proof -
      have "wf ?s" using \<open>x \<notin> Field m\<close>
        by (simp add: wf_eq_minimal Field_def Domain_unfold Domain_converse [symmetric]) metis
      thus ?thesis using \<open>wf (m - Id)\<close> \<open>x \<notin> Field m\<close>
        wf_subset [OF \<open>wf ?s\<close> Diff_subset]
        by (fastforce intro!: wf_Un simp add: Un_Diff Field_def)
    qed
    ultimately have "Well_order ?m" by (simp add: order_on_defs)
    moreover have "extension_on (Field ?m) ?m p"
      using \<open>extension_on (Field m) m p\<close> \<open>downset_on (Field m) p\<close>
      by (subst Fm) (auto simp: extension_on_def dest: downset_onD)
    moreover have "downset_on (Field ?m) p"
      apply (subst Fm)
      using \<open>downset_on (Field m) p\<close> and min
      unfolding downset_on_def Field_def by blast
    moreover have "(m, ?m) \<in> I"
      using \<open>Well_order m\<close> and \<open>Well_order ?m\<close> and
      \<open>downset_on (Field m) p\<close> and \<open>downset_on (Field ?m) p\<close> and
      \<open>extension_on (Field m) m p\<close> and \<open>extension_on (Field ?m) ?m p\<close> and
      \<open>Refl m\<close> and \<open>x \<notin> Field m\<close>
      by (auto simp: I_def init_seg_of_def refl_on_def)
    ultimately
    \<comment> \<open>This contradicts maximality of m:\<close>
    show False using max and \<open>x \<notin> Field m\<close> unfolding Field_def by blast
  qed
  have "p \<subseteq> m"
    using \<open>Field p \<subseteq> Field m\<close> and \<open>extension_on (Field m) m p\<close>
    unfolding Field_def extension_on_def by auto fast
  with \<open>Well_order m\<close> show ?thesis by blast
qed

text \<open>Every well-founded relation can be extended to a total wellorder.\<close>
corollary total_well_order_extension:
  assumes "wf p"
  shows "\<exists>w. p \<subseteq> w \<and> Well_order w \<and> Field w = UNIV"
proof -
  from well_order_extension [OF assms] obtain w
    where "p \<subseteq> w" and wo: "Well_order w" by blast
  let ?A = "UNIV - Field w"
  from well_order_on [of ?A] obtain w' where wo': "well_order_on ?A w'" ..
  have [simp]: "Field w' = ?A" using well_order_on_Well_order [OF wo'] by simp
  have *: "Field w \<inter> Field w' = {}" by simp
  let ?w = "w \<union>o w'"
  have "p \<subseteq> ?w" using \<open>p \<subseteq> w\<close> by (auto simp: Osum_def)
  moreover have "Well_order ?w" using Osum_Well_order [OF * wo] and wo' by simp
  moreover have "Field ?w = UNIV" by (simp add: Field_Osum)
  ultimately show ?thesis by blast
qed

corollary well_order_on_extension:
  assumes "wf p" and "Field p \<subseteq> A"
  shows "\<exists>w. p \<subseteq> w \<and> well_order_on A w"
proof -
  from total_well_order_extension [OF \<open>wf p\<close>] obtain r
    where "p \<subseteq> r" and wo: "Well_order r" and univ: "Field r = UNIV" by blast
  let ?r = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"
  from \<open>p \<subseteq> r\<close> have "p \<subseteq> ?r" using \<open>Field p \<subseteq> A\<close> by (auto simp: Field_def)
  have "Refl r" "trans r" "antisym r" "Total r" "wf (r - Id)"
    using \<open>Well_order r\<close> by (simp_all add: order_on_defs)
  have "refl_on A ?r" using \<open>Refl r\<close> by (auto simp: refl_on_def univ)
  moreover have "trans ?r" using \<open>trans r\<close>
    unfolding trans_def by blast
  moreover have "antisym ?r" using \<open>antisym r\<close>
    unfolding antisym_def by blast
  moreover have "total_on A ?r" using \<open>Total r\<close> by (simp add: total_on_def univ)
  moreover have "wf (?r - Id)" by (rule wf_subset [OF \<open>wf(r - Id)\<close>]) blast
  ultimately have "well_order_on A ?r" by (simp add: order_on_defs)
  with \<open>p \<subseteq> ?r\<close> show ?thesis by blast
qed

end


section \<open>Iterating a Commutative Computation Concurrently\<close>

theory Parallel_Multiset_Fold
  imports "HOL-Library.Multiset"
begin

text \<open>
This theory formalizes a deep embedding of a simple parallel computation model.
In this model, we formalize a computation scheme to execute a fold-function over a
commutative operation concurrently, and prove it correct.
\<close>

subsection \<open>Misc\<close>

(* TODO: Move *)
lemma (in comp_fun_commute) fold_mset_rewr: "fold_mset f a (mset l) = fold f l a"
  by (induction l arbitrary: a; clarsimp; metis fold_mset_fun_left_comm)

lemma finite_set_of_finite_maps:
  fixes A :: "'a set"
    and B :: "'b set"
  assumes "finite A"
    and "finite B"
  shows "finite {m. dom m \<subseteq> A \<and> ran m \<subseteq> B}"
proof -
  have "{m. dom m \<subseteq> A \<and> ran m \<subseteq> B} \<subseteq> (\<Union> S \<in> {S. S \<subseteq> A}. {m. dom m = S \<and> ran m \<subseteq> B})"
    by auto
  moreover have "finite \<dots>"
    using assms by (auto intro!: finite_set_of_finite_maps intro: finite_subset)
  ultimately show ?thesis
    by (rule finite_subset)
qed

lemma wf_rtranclp_ev_induct[consumes 1, case_names step]:
  assumes "wf {(x, y). R y x}" and step: "\<And> x. R\<^sup>*\<^sup>* a x \<Longrightarrow> P x \<or> (\<exists> y. R x y)"
  shows "\<exists>x. P x \<and> R\<^sup>*\<^sup>* a x"
proof -
  have "\<exists>y. P y \<and> R\<^sup>*\<^sup>* x y" if "R\<^sup>*\<^sup>* a x" for x
    using assms(1) that
  proof induction
    case (less x)
    from step[OF \<open>R\<^sup>*\<^sup>* a x\<close>] have "P x \<or> (\<exists>y. R x y)" .
    then show ?case
    proof
      assume "P x"
      then show ?case
        by auto
    next
      assume "\<exists>y. R x y"
      then obtain y where "R x y" ..
      with less(1)[of y] less(2) show ?thesis
        by simp (meson converse_rtranclp_into_rtranclp rtranclp.rtrancl_into_rtrancl)
    qed
  qed
  then show ?thesis
    by blast
qed

subsection \<open>The Concurrent System\<close>
text \<open>
  A state of our concurrent systems consists of a list of tasks,
  a partial map from threads to the task they are currently working on,
  and the current computation result.\<close>
type_synonym ('a, 's) state = "'a list \<times> (nat \<rightharpoonup> 'a) \<times> 's"

context comp_fun_commute
begin

context
  fixes n :: nat \<comment> \<open>The number of threads.\<close>
  assumes n_gt_0[simp, intro]: "n > 0"
begin

text \<open>
  A state is \<^emph>\<open>final\<close> if there are no remaining tasks and if all workers have finished their work.\<close>
definition
  "final \<equiv> \<lambda>(ts, ws, r). ts = [] \<and> dom ws \<inter> {0..<n} = {}"

text \<open>At any point a thread can:
  \<^item> pick a new task from the queue if it is currently not busy
  \<^item> or execute its current task.\<close>
inductive step :: "('a, 'b) state \<Rightarrow> ('a, 'b) state \<Rightarrow> bool" where
  pick: "step (t # ts, ws, s) (ts, ws(i := Some t), s)"   if "ws i = None"   and "i < n"
| exec: "step (ts, ws, s)     (ts, ws(i := None), f a s)" if "ws i = Some a" and "i < n"

lemma no_deadlock:
  assumes "\<not> final cfg"
  shows "\<exists>cfg'. step cfg cfg'"
  using assms
  apply (cases cfg)
  apply safe
  subgoal for ts ws s
    by (cases ts; cases "ws 0") (auto 4 5 simp: final_def intro: step.intros)
  done

lemma wf_step:
  "wf {((ts', ws', r'), (ts, ws, r)).
    step (ts, ws, r) (ts', ws', r') \<and> set ts' \<subseteq> S \<and> dom ws \<subseteq> {0..<n} \<and> ran ws \<subseteq> S}"
  if "finite S"
proof -
  let ?R1 = "{(x, y). dom x \<subset> dom y \<and> ran x \<subseteq> S \<and> dom y \<subseteq> {0..<n} \<and> ran y \<subseteq> S}"
  have "?R1 \<subseteq> {y. dom y \<subseteq> {0..<n} \<and> ran y \<subseteq> S} \<times> {y. dom y \<subseteq> {0..<n} \<and> ran y \<subseteq> S}"
    by auto
  then have "finite ?R1"
    using \<open>finite S\<close> by - (erule finite_subset, auto intro: finite_set_of_finite_maps)
  then have [intro]: "wf ?R1"
    apply (rule finite_acyclic_wf)
    apply (rule preorder_class.acyclicI_order[where f = "\<lambda>x. n - card (dom x)"])
    apply clarsimp
    by (metis (full_types)
        cancel_ab_semigroup_add_class.diff_right_commute diff_diff_cancel domD domI
        psubsetI psubset_card_mono subset_eq_atLeast0_lessThan_card
        subset_eq_atLeast0_lessThan_finite zero_less_diff)
  let ?R = "measure length <*lex*> ?R1 <*lex*> {}"
  have "wf ?R"
    by auto
  then show ?thesis
    apply (rule wf_subset)
    apply clarsimp
    apply (erule step.cases; clarsimp)
    by (smt
        Diff_iff domIff fun_upd_apply mem_Collect_eq option.simps(3) psubsetI ran_def
        singletonI subset_iff)
qed

context
  fixes ts :: "'a list" and start :: "'b"
begin

definition
  "s\<^sub>0 = (ts, \<lambda>_. None, start)"

definition "reachable \<equiv> (step\<^sup>*\<^sup>*) s\<^sub>0"

definition "is_invar I \<equiv> I s\<^sub>0 \<and> (\<forall>s s'. reachable s \<and> I s \<and> step s s' \<longrightarrow> I s')"

lemma is_invarI[intro?]:
  "\<lbrakk> I s\<^sub>0; \<And>s s'. \<lbrakk> reachable s; I s; step s s'\<rbrakk> \<Longrightarrow> I s' \<rbrakk> \<Longrightarrow> is_invar I"
  by (auto simp: is_invar_def)

lemma invar_reachable: "is_invar I \<Longrightarrow> reachable s \<Longrightarrow> I s"
  unfolding reachable_def
  by rotate_tac (induction rule: rtranclp_induct, auto simp: is_invar_def reachable_def)

definition
  "invar \<equiv> \<lambda>(ts2, ws, r).
    (\<exists>ts1.
      mset ts = ts1 + {# the (ws i). i \<in># mset_set (dom ws \<inter> {0..<n}) #} + mset ts2
    \<and> r = fold_mset f start ts1
    \<and> set ts2 \<subseteq> set ts \<and> ran ws \<subseteq> set ts \<and> dom ws \<subseteq> {0..<n})"

lemma invariant:
  "is_invar invar"
  apply rule
  subgoal
    unfolding s\<^sub>0_def unfolding invar_def by simp
  subgoal
    unfolding invar_def
    apply (elim step.cases)
     apply (clarsimp split: option.split_asm)
    subgoal for ws i t ts ts1
      apply (rule exI[where x = ts1])
       apply (subst mset_set.insert)
         apply (auto intro!: multiset.map_cong0)
      done
    apply (clarsimp split!: prod.splits)
    subgoal for ws i a ts ts1
      apply (rule exI[where x = "add_mset a ts1"])
         apply (subst Diff_Int_distrib2)
         apply (subst mset_set.remove)
           apply (auto intro!: multiset.map_cong0 split: if_split_asm simp: ran_def)
      done
    done
  done

lemma final_state_correct1:
  assumes "invar (ts', ms, r)" "final (ts', ms, r)"
  shows "r = fold_mset f start (mset ts)"
  using assms unfolding invar_def final_def by auto

lemma final_state_correct2:
  assumes "reachable (ts', ms, r)" "final (ts', ms, r)"
  shows "r = fold_mset f start (mset ts)"
  using assms by - (rule final_state_correct1, rule invar_reachable[OF invariant])

text \<open>Soundness: whenever we reach a final state, the computation result is correct.\<close>
theorem final_state_correct:
  assumes "reachable (ts', ms, r)" "final (ts', ms, r)"
  shows "r = fold f ts start"
  using final_state_correct2[OF assms] by (simp add: fold_mset_rewr)

text \<open>Termination: at any point during the program execution, we can continue to a final state.
That is, the computation always terminates.
\<close>
theorem "termination":
  assumes "reachable s"
  shows "\<exists>s'. final s' \<and> step\<^sup>*\<^sup>* s s'"
proof -
  have "{(s', s). step s s' \<and> reachable s} \<subseteq> {(s', s). step s s' \<and> reachable s \<and> reachable s'}"
    unfolding reachable_def by auto
  also have "\<dots> \<subseteq> {((ts', ws', r'), (ts1, ws, r)).
    step (ts1, ws, r) (ts', ws', r') \<and> set ts' \<subseteq> set ts \<and> dom ws \<subseteq> {0..<n} \<and> ran ws \<subseteq> set ts}"
    by (force dest!: invar_reachable[OF invariant] simp: invar_def)
  finally have "wf {(s', s). step s s' \<and> reachable s}"
    by (elim wf_subset[OF wf_step, rotated]) simp
  then have "\<exists>s'. final s' \<and> (\<lambda>s s'. step s s' \<and> reachable s)\<^sup>*\<^sup>* s s'"
  proof (induction rule: wf_rtranclp_ev_induct)
    case (step x)
    then have "(\<lambda>s s'. step s s')\<^sup>*\<^sup>* s x"
      by (elim mono_rtranclp[rule_format, rotated] conjE)
    with \<open>reachable s\<close> have "reachable x"
      unfolding reachable_def by auto
    then show ?case
      using no_deadlock[of x] by auto
  qed
  then show ?thesis
    apply clarsimp
    apply (intro exI conjI, assumption)
    apply (rule mono_rtranclp[rule_format])
     apply auto
    done
qed

end (* Fixed task list *)

end (* Fixed number of workers *)

end (* Commutative function *)

text \<open>The main theorems outside the locale:\<close>
thm comp_fun_commute.final_state_correct comp_fun_commute.termination

end (* End of theory *)


theory Model
  imports "HOL-Library.Word"
begin

type_synonym byte = "8 word"
type_synonym val = "byte list"
type_synonym loc = "64 word"

abbreviation offset :: "loc \<Rightarrow> nat \<Rightarrow> loc" where
  "offset l n \<equiv> l + (word_of_nat n)"

lemma offset_suc: "offset l (Suc n) = offset (offset l n) 1"
  by (induction n) auto

lemma offset_suc2: "offset l (Suc n) = offset (offset l 1) n"
  by (induction n) auto

locale loc_ops =
  fixes N :: "'a::len"
  assumes bytes: "LENGTH('a) mod 8 = 0" begin
definition get_nth_byte :: "'a word \<Rightarrow> nat \<Rightarrow> byte" where
  "get_nth_byte x n = ucast (drop_bit (n*8) (take_bit ((n+1)*8) x))"

fun to_val_aux :: "'a word \<Rightarrow> nat \<Rightarrow> val" where
  "to_val_aux x 0 = [get_nth_byte x 0]"
| "to_val_aux x n = (get_nth_byte x n) # (to_val_aux x (n-1))"

definition to_val :: "'a word \<Rightarrow> val" where
  "to_val x = to_val_aux x (LENGTH('a)-8)"

fun from_val_aux :: "val \<Rightarrow> ('a word \<times> nat)" where
  "from_val_aux [] = (0,0)"
| "from_val_aux (v#vs) = (let (w,n) = from_val_aux vs in
    (w + ((ucast v)*2^n),Suc n))"

definition from_val :: "val \<Rightarrow> 'a word" where
  "from_val v = fst (from_val_aux v)"

lemma get_nth_byte_zero:
  "get_nth_byte 0 n = 0" by (simp add: get_nth_byte_def)
end

abbreviation "loc_N_b\<equiv>64::nat"
abbreviation "loc_N_B\<equiv>8::nat"

interpretation loc64_ops: loc_ops "64::64" by standard simp
abbreviation null_loc :: val where "null_loc \<equiv> loc64_ops.to_val 0"

typedecl var
axiomatization size :: "var \<Rightarrow> nat"
  and fresh :: "var set \<Rightarrow> var"
  where pos_size: "size v > 0" and new_fresh: "fresh vs \<notin> vs"

instance var :: linorder sorry

abbreviation sizev :: "var \<Rightarrow> 'a::len word" where
  "sizev v \<equiv> word_of_nat (size v)"

definition null :: "var \<Rightarrow> val" where
  "null x = replicate (size x) (0::byte)"

definition fits :: "val \<Rightarrow> var \<Rightarrow> bool" where
  "fits x v \<equiv> length x = size v"

typedef stack = "{s::var \<Rightarrow> val. \<forall>v. fits (s v) v}" morphisms lookup Stack
proof -
  define s :: "var \<Rightarrow> val" where "s = (\<lambda>v. replicate (size v) 0)"
  have "\<forall>v. length (s v) = size v" by (simp add: s_def)
  then show ?thesis by (auto simp: fits_def)
qed
setup_lifting type_definition_stack

lift_definition empty_stack :: stack is "\<lambda>x. null x" unfolding null_def by (simp add: fits_def)

abbreviation update_stack :: "stack \<Rightarrow> var \<Rightarrow> val \<Rightarrow> stack" where
  "update_stack s x v \<equiv> Stack ((lookup s)(x:=v))"

lemma fits_upd: "fits k x \<Longrightarrow> (lookup s)(x:=k) \<in> {s. \<forall>v. fits (s v) v}"
  using lookup by (auto simp: fits_def)

definition bind_args_to_params :: "(var \<Rightarrow> val) \<Rightarrow> var list \<Rightarrow> var list \<Rightarrow> var \<Rightarrow> val" where
  "bind_args_to_params s params args x \<equiv>
    case map_of (zip params args) x of Some a \<Rightarrow> s a | None \<Rightarrow> s x"

type_synonym memory = "loc \<rightharpoonup> byte"

fun intv :: "loc \<Rightarrow> (loc\<times>loc) \<Rightarrow> bool" where
  "intv x (l,u) = (l\<le>x \<and> x<u)"

fun raw_access_rev :: "memory \<Rightarrow> loc \<Rightarrow> nat \<Rightarrow> byte option list" where
  "raw_access_rev m b 0 = [m b]"
| "raw_access_rev m b (Suc n) = m (offset b (Suc n))#(raw_access_rev m b n)"

lemma raw_access_set: "set (raw_access_rev m l n) = {m x | x. \<exists>n'. n' \<le> n \<and> x = offset l n'}"
  apply (induction n)
   apply auto
    apply fastforce
  using le_SucI apply blast
  by (metis (no_types, lifting) le_SucE of_nat_Suc)

definition access :: "memory \<Rightarrow> loc \<Rightarrow> nat \<Rightarrow> val option" where
  "access m l n \<equiv>
    fold (\<lambda>x l. case x of Some x' \<Rightarrow> (case l of Some l' \<Rightarrow> Some (x'#l') | _ \<Rightarrow> None) | _ \<Rightarrow> None)
      (raw_access_rev m l n) (Some [])"

lemma fold_neq_none:
  "(fold (\<lambda>x l. case x of None \<Rightarrow> None | Some x' \<Rightarrow> case l of None \<Rightarrow> None | Some l' \<Rightarrow> Some (x' # l'))
   l acc \<noteq> None) \<longleftrightarrow> ((\<forall>x\<in>set l. x \<noteq> None) \<and> acc \<noteq> None)"
  apply (induction l arbitrary: acc)
  by (auto split: option.splits)

lemma fold_raw_access_none:
  "(fold (\<lambda>x l. case x of None \<Rightarrow> None | Some x' \<Rightarrow> case l of None \<Rightarrow> None | Some l' \<Rightarrow> Some (x' # l'))
   (raw_access_rev m l n) (Some acc) \<noteq> None) \<longleftrightarrow> (\<forall>y. (\<exists>n'. n' \<le> n \<and> y = offset l n') \<longrightarrow> m y \<noteq> None)"
  (is "(?f \<noteq> _) \<longleftrightarrow> _")
proof -
  have "?f \<noteq> None \<longleftrightarrow> (\<forall>x\<in>set (raw_access_rev m l n). x \<noteq> None)" using fold_neq_none by fastforce
  also have "\<dots> = (\<forall>x\<in>{m y | y. \<exists>n'. n' \<le> n \<and> y = offset l n'}. x \<noteq> None)" by (simp add: raw_access_set)
  also have "\<dots> = (\<forall>y. (\<exists>n'. n' \<le> n \<and> y = offset l n') \<longrightarrow> m y \<noteq> None)" by blast
  finally show ?thesis .
qed

lemma access_none: "access m l n \<noteq> None \<longleftrightarrow> (\<forall>y. (\<exists>n'. n' \<le> n \<and> y = offset l n') \<longrightarrow> m y \<noteq> None)"
  unfolding access_def using fold_raw_access_none by simp

fun update_memory :: "memory \<Rightarrow> loc \<Rightarrow> val \<Rightarrow> memory" where
  "update_memory m _ [] = m"
| "update_memory m l (v#vs) = update_memory (m(l\<mapsto>v)) (offset l 1) vs"

definition free_memory :: "memory \<Rightarrow> loc \<Rightarrow> loc \<Rightarrow> memory" where
  "free_memory m l u \<equiv> \<lambda>x. if intv x (l,u) then None else m x"

type_synonym blockname = nat
type_synonym block = "(blockname\<times>(loc\<times>loc))"

typedef blocks = "{b::block list.
  (\<forall>n l u. (n,(l,u)) \<in> set b \<longrightarrow> (l<u \<and> l\<noteq>0)) \<and>
  (\<forall>n1 n2 l1 l2 u1 u2. ((n1,(l1,u1)) \<in> set b \<and> (n2,(l2,u2)) \<in> set b
    \<and> (l1\<noteq>l2 \<or> u1 \<noteq> u2 \<or> n1\<noteq>n2))
    \<longrightarrow> (u1\<le>l2 \<or> u2\<le>l1))}" morphisms raw_blocks Blocks
proof -
  have "([]::block list) \<in> {b. (\<forall>n l u. (n, l, u) \<in> set b \<longrightarrow> l < u \<and> l \<noteq> 0) \<and>
         (\<forall>n1 n2 l1 l2 u1 u2. (n1, l1, u1) \<in> set b \<and> (n2, l2, u2) \<in> set b \<and> (l1 \<noteq> l2 \<or> u1 \<noteq> u2 \<or> n1\<noteq>n2)
          \<longrightarrow> (u1\<le>l2 \<or> u2\<le>l1))}" by simp
  then show ?thesis by blast
qed
setup_lifting type_definition_blocks

definition overlaps_with :: "block \<Rightarrow> block \<Rightarrow> bool" where
  "overlaps_with b1 b2 \<equiv> (case b1 of (_,l1,u1) \<Rightarrow> case b2 of (_,l2,u2) \<Rightarrow>
    \<exists>x. intv x (l1,u1) \<and> intv x (l2,u2))"

lemma overlaps_alt: "overlaps_with (n1,l1,u1) (n2,l2,u2) \<longleftrightarrow> l1<u1 \<and> l2<u2 \<and>
  ((l1<u2\<and>l2\<le>l1) \<or> (l2<u1\<and>l1\<le>l2))"
  by (auto simp: overlaps_with_def)

definition free_block_from :: "block list \<Rightarrow> loc \<Rightarrow> block list" where
  "free_block_from B x = filter (\<lambda>(_,l,_). l\<noteq>x) B"

lemma free_block_from_set: "set (free_block_from B x) = {(n,l,u) | n l u. (n,l,u) \<in> set B \<and> l \<noteq> x}"
  unfolding free_block_from_def by auto

lift_definition free_block :: "blocks \<Rightarrow> loc \<Rightarrow> blocks" is free_block_from
  using free_block_from_set apply auto apply fast by meson+

type_synonym pre_config = "stack \<times> blocks \<times> memory"

lift_definition initial :: pre_config is "(empty_stack, [], Map.empty)" by auto

abbreviation config_def :: "pre_config \<Rightarrow> bool" where
  "config_def c \<equiv> case c of (s,b,m) \<Rightarrow>
    \<forall>x::loc. m x \<noteq> None \<longrightarrow> (\<exists>n lu. (n,lu) \<in> set (raw_blocks b) \<and> intv x lu)"

typedef config = "{c. config_def c}" by auto
setup_lifting type_definition_config

lift_definition get_stack :: "config \<Rightarrow> stack" is "\<lambda>c. (case c of (s::stack,_,_) \<Rightarrow> s)" .
lift_definition get_blocks :: "config \<Rightarrow> blocks" is "\<lambda>c. (case c of (_,b::blocks,_) \<Rightarrow> b)" .
lift_definition get_memory :: "config \<Rightarrow> memory" is "\<lambda>c. (case c of (_,_,m::memory) \<Rightarrow> m)" .

lemma "finite (dom (get_memory c))"
  apply transfer by auto

definition from_block_raw :: "loc \<Rightarrow> block list \<Rightarrow> block option" where
  "from_block_raw l bs \<equiv> find (\<lambda>(_,lu). intv l lu) bs"

lift_definition from_block :: "loc \<Rightarrow> blocks \<Rightarrow> block option" is "from_block_raw" .

lemma from_block_raw_intv: "from_block_raw x B = Some (n,l,u) \<Longrightarrow> intv x (l,u)"
  unfolding from_block_raw_def
  apply (induction B) apply (auto split: option.splits)
   by (metis Pair_inject option.inject)+

lemma intv_from_block_raw: "\<exists>n l u. intv x (l,u) \<and> (n,l,u) \<in> set B \<Longrightarrow> from_block_raw x B \<noteq> None"
  unfolding from_block_raw_def apply (induction B) by auto

lemma from_block_raw_set: "from_block_raw x B = Some (n,l,u) \<Longrightarrow> (n,l,u) \<in> set B"
  unfolding from_block_raw_def apply (induction B) by auto (metis Pair_inject option.inject)+

lemma blocks_non_overlapping:
  "\<lbrakk>(n1,l1,u1)\<in>set (raw_blocks B); (n2,l2,u2)\<in>set (raw_blocks B); intv z (l1,u1); intv z (l2,u2)\<rbrakk>
    \<Longrightarrow> (n1,l1,u1) = (n2,l2,u2)"
proof -
  assume assms: "(n1,l1,u1)\<in>set (raw_blocks B)" "(n2,l2,u2)\<in>set (raw_blocks B)"
    "intv z (l1, u1)" "intv z (l2, u2)"
  with assms have ineq: "l1 \<le> z" "l2 \<le> z" "z < u1" "z < u2" by auto
  {
    assume "(n1,l1,u1) \<noteq> (n2,l2,u2)"
    with assms(1,2) raw_blocks have "(u1\<le>l2 \<or> u2\<le>l1)" by blast
    with ineq have False by auto
  }
  then show ?thesis by auto
qed

lemma offset_in_block: "\<lbrakk>from_block_raw x (raw_blocks B) = Some (n,l,u); offset x y<u; x\<le>offset x y\<rbrakk>
  \<Longrightarrow> from_block_raw (offset x y) (raw_blocks B) = Some (n,l,u)"
proof (induction y arbitrary: x)
  case 0
  then show ?case by simp
next
  case (Suc y)
  with from_block_raw_intv[OF Suc(2)] have "l \<le> offset x (Suc y)" by auto
  with Suc(3) have intv_offset: "intv (offset x (Suc y)) (l,u)" by simp
  then have "from_block_raw (offset x (Suc y)) (raw_blocks B) \<noteq> None"
    using intv_from_block_raw from_block_raw_set[OF Suc(2)] by blast
  then obtain n' l' u' where "from_block_raw (offset x (Suc y)) (raw_blocks B) = Some (n',l',u')" by auto
  with blocks_non_overlapping[OF from_block_raw_set[OF Suc(2)] from_block_raw_set[OF this] intv_offset from_block_raw_intv[OF this]]
    show ?case  by simp
qed

fun bounds :: "block list \<Rightarrow> loc \<Rightarrow> (loc\<times>loc)" where
  "bounds [] l = (0,0)"
| "bounds ((_,lu)#bs) l = (if intv l lu then lu else bounds bs l)"

lemma bounds_neq_zero_in: "fst (bounds b l) \<noteq> 0 \<Longrightarrow> \<exists>n. (n,bounds b l) \<in> set b"
  apply (induction rule: bounds.induct) by simp fastforce

lemma bounds_neq_zero: "fst (bounds b l) \<noteq> 0 \<Longrightarrow> intv l (bounds b l)"
  by (induction rule: bounds.induct) auto

lemma sublist_raw_blocks: "b#bs = raw_blocks B \<Longrightarrow> bs \<in> {b. (\<forall>n l u. (n, l, u) \<in> set b \<longrightarrow> l < u \<and> l \<noteq> 0) \<and>
         (\<forall>n1 n2 l1 l2 u1 u2. (n1, l1, u1) \<in> set b \<and> (n2, l2, u2) \<in> set b \<and> (l1 \<noteq> l2 \<or> u1 \<noteq> u2 \<or> n1\<noteq>n2)
          \<longrightarrow> (u1\<le>l2 \<or> u2\<le>l1))}" (is "_ \<Longrightarrow> _ \<in> {b. ?block_inv b}")
proof -
  assume "b#bs = raw_blocks B"
  with blocks.raw_blocks have "b#bs \<in> {b. ?block_inv b}" by presburger
  then have "?block_inv (b#bs)" by blast
  moreover have "set bs \<subseteq> set (b#bs)" by (rule set_subset_Cons)
  ultimately have "?block_inv bs" by blast
  then show ?thesis by blast
qed

lemma base_eq_zero: "fst (bounds (raw_blocks B) l) = 0 \<Longrightarrow> snd (bounds (raw_blocks B) l) = 0"
proof (induction "raw_blocks B" l arbitrary: B rule: bounds.induct)
  case (1 l)
  then show ?case by simp
next
  case (2 n lu bs l)
  from Blocks_inverse[OF sublist_raw_blocks[OF this(2)]] have bs: "bs = raw_blocks (Blocks bs)" ..
  show ?case proof (cases "intv l lu")
    case True
    with 2(2)[symmetric] have "bounds (raw_blocks B) l = lu" by auto
    with 2(3) have l0: "fst lu = 0" by simp
    from blocks.raw_blocks 2(2) have "\<forall>n' l u. (n', l, u) \<in> set ((n,lu)#bs) \<longrightarrow> l < u \<and> l \<noteq> 0"
      by simp
    then have "fst lu \<noteq> 0" by (metis list.set_intros(1) prod.collapse)
    with l0 show ?thesis by simp
  next
    case False
    with 2(2)[symmetric] have Bbs: "bounds (raw_blocks B) l = bounds bs l" by simp
    with 2(3) have "fst (bounds bs l) = 0" by simp
    with 2(1)[OF False bs] bs have "snd (bounds bs l) = 0" by simp
    with Bbs show ?thesis by simp
  qed
qed

lift_definition base :: "blocks \<Rightarrow> loc \<Rightarrow> loc" is "\<lambda>B l. fst (bounds B l)" .
lift_definition ende :: "blocks \<Rightarrow> loc \<Rightarrow> loc" is "\<lambda>B l. snd (bounds B l)" .

lemma blocks_axiom1: "base B l = 0 \<or> (base B l \<le> l \<and> l < ende B l)"
proof (auto)
  assume base_neq_zero: "base B l \<noteq> 0"
  obtain b e where be:"bounds (raw_blocks B) l = (b,e)" by force
  from base_neq_zero bounds_neq_zero have "intv l (bounds (raw_blocks B) l)" unfolding base.rep_eq by simp
  with be have "intv l (b,e)" by simp
  then show "base B l \<le> l" unfolding base.rep_eq be by simp
next
  assume base_neq_zero: "base B l \<noteq> 0"
  obtain b e where be:"bounds (raw_blocks B) l = (b,e)" by force
  from base_neq_zero bounds_neq_zero have "intv l (bounds (raw_blocks B) l)" unfolding base.rep_eq by simp
  with be have "intv l (b,e)" by simp
  then show "l < ende B l" unfolding ende.rep_eq be by simp
qed

lemma blocks_axiom2:
  "(0<base B l \<and> base B l<ende B l' \<and> ende B l'\<le>ende B l) \<or>
   (0<base B l' \<and> base B l'<ende B l \<and> ende B l\<le>ende B l') \<Longrightarrow>
    base B l = base B l' \<and> ende B l = ende B l'"
proof (auto)
  assume assms: "0<base B l" "base B l<ende B l'" "ende B l'\<le>ende B l"
  from assms base_eq_zero[of B] have bl'0: "base B l' \<noteq> 0" unfolding base.rep_eq ende.rep_eq by auto
  from assms have bl0: "base B l \<noteq> 0" by simp
  {
    assume "base B l \<noteq> base B l'"
    then have "bounds (raw_blocks B) l \<noteq> bounds (raw_blocks B) l'" by (auto simp: base.rep_eq)
    moreover from bounds_neq_zero_in bl0 obtain n where "(n, bounds (raw_blocks B) l) \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    moreover from bounds_neq_zero_in bl'0 obtain n' where n': "(n', bounds (raw_blocks B) l') \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    ultimately have "(snd (bounds (raw_blocks B) l)\<le>fst (bounds (raw_blocks B) l') \<or> snd (bounds (raw_blocks B) l')\<le>fst (bounds (raw_blocks B) l))"
        using blocks.raw_blocks by (smt (verit, ccfv_threshold) mem_Collect_eq prod.collapse)
    with assms(2) have "snd (bounds (raw_blocks B) l)\<le>fst (bounds (raw_blocks B) l')" by (auto simp:  base.rep_eq ende.rep_eq)
    with assms(3)[unfolded ende.rep_eq] have "snd (bounds (raw_blocks B) l') \<le>  fst (bounds (raw_blocks B) l')" by simp
    with n' blocks.raw_blocks[of B] have False using base.rep_eq bl'0 blocks_axiom1 ende.rep_eq order.trans by fastforce
  }
  then show "base B l = base B l'" by auto
next
  assume assms: "0<base B l" "base B l<ende B l'" "ende B l'\<le>ende B l"
  from assms base_eq_zero[of B] have bl'0: "base B l' \<noteq> 0" unfolding base.rep_eq ende.rep_eq by auto
  from assms have bl0: "base B l \<noteq> 0" by simp
  {
    assume "ende B l \<noteq> ende B l'"
    then have "bounds (raw_blocks B) l \<noteq> bounds (raw_blocks B) l'" by (auto simp: ende.rep_eq)
    moreover from bounds_neq_zero_in bl0 obtain n where "(n, bounds (raw_blocks B) l) \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    moreover from bounds_neq_zero_in bl'0 obtain n' where n': "(n', bounds (raw_blocks B) l') \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    ultimately have "(snd (bounds (raw_blocks B) l)\<le>fst (bounds (raw_blocks B) l') \<or> snd (bounds (raw_blocks B) l')\<le>fst (bounds (raw_blocks B) l))"
      using blocks.raw_blocks by (smt (verit, ccfv_threshold) mem_Collect_eq prod.collapse)
    with assms(2) have "snd (bounds (raw_blocks B) l)\<le>fst (bounds (raw_blocks B) l')" by (auto simp:  base.rep_eq ende.rep_eq)
    with assms(3)[unfolded ende.rep_eq] have "snd (bounds (raw_blocks B) l') \<le>  fst (bounds (raw_blocks B) l')" by simp
    with n' blocks.raw_blocks[of B] have False using base.rep_eq bl'0 blocks_axiom1 ende.rep_eq order.trans by fastforce
  }
  then show "ende B l = ende B l'" by auto
next
  assume assms: "0 < base B l'" "base B l' < ende B l" "ende B l \<le> ende B l'"
  from assms base_eq_zero[of B] have bl0: "base B l \<noteq> 0" unfolding base.rep_eq ende.rep_eq by auto
  from assms have bl'0: "base B l' \<noteq> 0" by simp
  {
    assume "base B l \<noteq> base B l'"
    then have "bounds (raw_blocks B) l \<noteq> bounds (raw_blocks B) l'" by (auto simp: base.rep_eq)
    moreover from bounds_neq_zero_in bl0 obtain n where n: "(n, bounds (raw_blocks B) l) \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    moreover from bounds_neq_zero_in bl'0 obtain n' where "(n', bounds (raw_blocks B) l') \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    ultimately have "(snd (bounds (raw_blocks B) l)\<le>fst (bounds (raw_blocks B) l') \<or> snd (bounds (raw_blocks B) l')\<le>fst (bounds (raw_blocks B) l))"
      using blocks.raw_blocks by (smt (verit, ccfv_threshold) mem_Collect_eq prod.collapse)
    with assms(2) have "snd (bounds (raw_blocks B) l')\<le>fst (bounds (raw_blocks B) l)" by (auto simp:  base.rep_eq ende.rep_eq)
    with assms(3)[unfolded ende.rep_eq] have "snd (bounds (raw_blocks B) l) \<le>  fst (bounds (raw_blocks B) l)" by simp
    with n blocks.raw_blocks[of B] have False using base.rep_eq bl0 blocks_axiom1 ende.rep_eq order.trans by fastforce
  }
  then show "base B l = base B l'" by auto
next
   assume assms: "0 < base B l'" "base B l' < ende B l" "ende B l \<le> ende B l'"
  from assms base_eq_zero[of B] have bl0: "base B l \<noteq> 0" unfolding base.rep_eq ende.rep_eq by auto
  from assms have bl'0: "base B l' \<noteq> 0" by simp
  {
    assume "ende B l \<noteq> ende B l'"
    then have "bounds (raw_blocks B) l \<noteq> bounds (raw_blocks B) l'" by (auto simp: ende.rep_eq)
    moreover from bounds_neq_zero_in bl0 obtain n where n: "(n, bounds (raw_blocks B) l) \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    moreover from bounds_neq_zero_in bl'0 obtain n' where "(n', bounds (raw_blocks B) l') \<in> set (raw_blocks B)"
      by (auto simp: base.rep_eq)
    ultimately have "(snd (bounds (raw_blocks B) l)\<le>fst (bounds (raw_blocks B) l') \<or> snd (bounds (raw_blocks B) l')\<le>fst (bounds (raw_blocks B) l))"
      using blocks.raw_blocks by (smt (verit, ccfv_threshold) mem_Collect_eq prod.collapse)
    with assms(2) have "snd (bounds (raw_blocks B) l')\<le>fst (bounds (raw_blocks B) l)" by (auto simp:  base.rep_eq ende.rep_eq)
    with assms(3)[unfolded ende.rep_eq] have "snd (bounds (raw_blocks B) l) \<le>  fst (bounds (raw_blocks B) l)" by simp
    with n blocks.raw_blocks[of B] have False using base.rep_eq bl0 blocks_axiom1 ende.rep_eq order.trans by fastforce
  }
  then show "ende B l = ende B l'" by auto
qed

end


theory Op_SL
imports State_SL
(*This file defines the operation semantics of HCSP.*)

begin

(*Five kinds of events for HCSP processes*)
datatype event = Tau | In cname val | Out cname val | IO cname val | Delay time
type_synonym now = real

(* continuous evolution*)
(*Explicit solution*)
consts Solution :: "proc \<Rightarrow> state \<Rightarrow> real => val"

consts evalP :: "proc => now => history => event * proc * now * history"
consts evalPP :: "procP => now => history => history   => event * procP * now  * history * history"

(*We define the semantics in two ways: as axioms, or after this approach, by inductive definition*)
(*In the semantics, we assume Skip as the terminal procedure.*)
axiomatization where
 skip :  "evalP Skip now f = (Tau, Skip, now, f)"

axiomatization where
assignR :  "evalP ((RVar (x)) := e) now f  =(Tau,
   Skip, now, (%t. if t = now then (%(y, i). if y=x & i=R then (evalE e (f(t))) else (f(t)(y, i))) else f(t)))" and
assignS :  "evalP ((SVar (x)) := e) now f  =(Tau,
   Skip, now, (%t. if t = now then  (%(y, i). if y=x & i=S then (evalE e (f(t))) else (f(t)(y, i))) else f(t)))" and
assignB :  "evalP ((BVar (x)) := e) now f  =(Tau,
   Skip, now, (%t. if t = now then  (%(y, i). if y=x & i=B then (evalE e (f(t))) else (f(t)(y, i))) else f(t)))"

axiomatization where
 continuousF : "([\<not>]b) (f(now))
                ==> evalP (<[s]:E&&Inv&b>)  now f  = (Tau, Skip, now, f)" and
 continuousT : "d\<ge>0 \<Longrightarrow>
                     (let f'= (%t. if t <= now+d & t > now then
                       (%(y, i). if y=fst (s) & i=snd (s) then (Solution (<[s]:E&&Inv&b>) (f(now)) (t-now)) else f(now)(y, i)) else f(t)) in
                    ALL t.  t <= now+d & t \<ge> now -->  (b) (f'(t)))
                ==> evalP (<[s]:E&&Inv&b>)  now f  =  (let f'= (%t. if t <= now+d & t > now then
                       (%(y, i). if y=fst (s) & i=snd (s) then (Solution (<[s]:E&&Inv&b>) (f(now)) (t-now)) else f(now)(y, i)) else f(t)) in
                             (Delay d,<[s]:E&&Inv&b>, now+d, f'))"

(*sequential*)
axiomatization where
 sequenceL :  "evalP P now f = (ev, P', now', f')
               & ~ (P'= Skip)
==> evalP (P; Q) now f = (ev, P';Q, now', f') "
and
 sequenceR :  "evalP P now f = (ev, P', now', f')
               & (P'= Skip)
==> evalP (P; Q) now f = (ev, Q, now', f') "

(*condition*)
axiomatization where
 conditionT :  "be (f(now))
                   ==> evalP (IF be P) now f = (Tau, P, now, f)" and
 conditionF :  "\<not> be (f(now))
                   ==> evalP (IF be P) now f = (Tau, Skip, now, f)"
(*join*)
axiomatization where
 joinL : "evalP (P[[Q) now f = (Tau, P, now, f)" and
 joinR : "evalP (P[[Q) now f = (Tau, Q, now, f)"

(*repetition*)
axiomatization where
 repetition0 : "evalP (P*&&Inv) now f = (Tau, Skip, now, f)" and
 repetitionk : "evalP P now f = (ev, P', now', f')
               & ~(P'= Skip) ==>
                evalP (P*&&Inv) now f = (ev, (P'; P*&&Inv), now',f')" and
 repetitionk1 : "evalP P now f = (ev, P', now', f')
               & (P'= Skip) ==>
                evalP (P*&&Inv) now f = (ev, P*&&Inv, now',f')"

(*communication*)
axiomatization where
 outputC : "evalP (Cm (ch!!e)) now f = ((Out ch (valE e f(now))), Skip, now, f)" and
 outputW : "d\<ge>0 \<Longrightarrow> evalP (Cm (ch!!e)) now f = ((Delay d), Cm (ch!!e), now+d,
            (%t. if t <= now+d & t > now then f(now) else f(t)))" and
 inputC : "EX c. evalP (Cm (ch??x)) now f = ((In ch c), x:= (Con c), now, f)" and
 inputW : "d\<ge>0 \<Longrightarrow> evalP (Cm (ch??x)) now f = ((Delay d), Cm (ch??x), now+d,
            (%t. if t <= now+d & t > now then f(now) else f(t)))"

(*parallel composition*)
(*Auxiliary functions needed to be introduced first.*)
(*chanset returns the channel set of a procecure, while varset the variable set of a
procedure.*)
primrec compat :: "event => event => bool" where
"compat Tau ev = False" |
"compat (In ch val) ev = (if (ev = Out ch val) then True else False)" |
"compat (Out ch val) ev = (if (ev = In ch val) then True else False)" |
"compat (IO ch val) ev = False" |
"compat (Delay d) ev = False"

primrec handshake :: "event => event => event" where
"handshake Tau ev = Tau" |
"handshake (In ch val) ev = (if (ev = Out ch val) then (IO ch val) else Tau)" |
"handshake (Out ch val) ev = (if (ev = In ch val) then (IO ch val) else Tau)" |
"handshake (IO ch val) ev =Tau" |
"handshake (Delay d) ev =Tau"

primrec chansetC :: "comm => string set" where
"chansetC (ch!!e) = {ch} "|
"chansetC (ch??e) = {ch}"

primrec chanset :: "proc => string set" where
"chanset (Cm r) = chansetC r" |
"chanset Skip = {}" |
"chanset (e := f) = {}" |
"chanset (P; Q) = chanset P \<union> chanset Q" |
"chanset (IF b P) = chanset P" |
"chanset (C \<rightarrow> P) = chansetC C \<union> chanset P" |
"chanset (P [[ Q) = chanset P \<union> chanset Q" |
"chanset (P << Q) = chanset P \<union> chanset Q" |
(*"chanset (P || Q) = chanset P \<union> chanset Q" |*)
"chanset (P*&&Inv) = chanset P" |
"chanset (<vl:el&&Inv&b>) = {}"|
"chanset (P [[> Q) = chanset P \<union> chanset Q"

(*Semantics for \<parallel>*)
axiomatization where
 parallel0 : "evalPP (P||Q) now f g = (evalPP (Q||P) now f g)" and
 parallel1 : "evalP P now f = (evp, P', now, f)
             & evalP Q now g = (evq, Q', now, g')
             & compat evp evq
             ==>
        evalPP (P||Q) now f g = (handshake evp evq, P'||Q', now, f, g')" and
parallel2 : "evalP P now f = (evp, P', now', f')
             & ((evp = Tau) | (EX ch c. evp = Out ch c & ~(ch \<in> chanset P \<inter> chanset Q))
| (EX ch c. evp = In ch c & ~(ch \<in> chanset P \<inter> chanset Q))
| (EX ch c. evp = IO ch c & ~(ch \<in> chanset P \<inter> chanset Q)))
                         ==>
        evalPP (P||Q) now f g = (evp, P'||Q, now', f', g)" and
parallel3 : "evalP P now f = (Delay d, P', now+d, f')
             &evalP Q now g = (Delay d, Q', now+d, g')
                         ==>
        evalPP (P||Q) now f g = (Delay d, P'||Q', now+d, (%t. if t <= now+d & t >= now then f'(t) else f(t)),
                      (%t. if t <= now+d & t >= now then g'(t) else g(t)))"

(*An alternative approach for defining operational semantics of HCSP.*)
(*small step*)
inductive semP :: "proc => now => history => (event * proc * now * history) \<Rightarrow> bool"
where
  skip : "semP Skip now f (Tau, Skip, now, f)"
| assignR : "semP ((RVar (x)) := e) now f
   (Tau, Skip, now, (%t. if t = now then (%(y, i). if y=x & i=R then (evalE e (f(t))) else (f(t)(y, i))) else f(t)))"
| assignS :"semP ((SVar (x)) := e) now f (Tau,
   Skip, now, (%t. if t = now then  (%(y, i). if y=x & i=S then (evalE e (f(t))) else (f(t)(y, i))) else f(t)))"
| assignB :"semP  ((BVar (x)) := e) now f (Tau,
   Skip, now, (%t. if t = now then  (%(y, i). if y=x & i=B then (evalE e (f(t))) else (f(t)(y, i))) else f(t)))"
| continuousF : "([\<not>]b) (f(now)) ==> semP (<[s]:E&&Inv&b>)  now f  (Tau, Skip, now, f)"
| continuousT : "d\<ge>0 \<Longrightarrow> (
                     (let f'= (%t. if t <= now+d & t > now then
                       (%(y, i). if y=fst (s) & i=snd (s) then (Solution (<[s]:E&&Inv&b>) (f(now)) (t-now)) else f(now)(y, i)) else f(t)) in
                    \<forall> m.  m <= now+d & m \<ge> now --> (b) (f'(m))))
    ==> semP (<[s]:E&&Inv&b>) now f
       (Delay d, <[s]:E&&Inv&b>, now+d, (%t. if t <= now+d & t > now then
       (%(y, i). if y=fst (s) & i=snd (s) then (Solution (<[s]:E&&Inv&b>) (f(now)) (t-now)) else f(now)(y, i)) else f(t)))"
| sequenceL : "semP P now f (ev, P', now', f') \<and> ~ (P'= Skip)
               ==> semP (P; Q) now f  (ev, P';Q, now', f')"
| sequenceR : "semP P now f (ev, P', now', f') \<and> (P'= Skip)
   ==> semP (P; Q) now f (ev, Q, now', f')"
| conditionT : " be (f(now)) ==> semP (IF be P) now f  (Tau, P, now, f)"
| conditionF : "~be (f(now)) ==> semP (IF be P) now f (Tau, Skip, now, f)"
| joinL : "semP (P[[Q) now f (Tau, P, now, f)"
| joinR : "semP (P[[Q) now f (Tau, Q, now, f)"
| repetition0 : "semP (P*&&Inv) now f  (Tau, Skip, now, f)"
| repetitionk : "semP P now f (ev, P', now', f') \<and> ~(P'= Skip) ==>
                semP (P*&&Inv) now f (ev, (P'; P*&&Inv), now',f')"
| repetitionk1 : "semP P now f (ev, P', now', f') \<and> (P'= Skip) ==>
                  semP (P*&&Inv) now f  (ev, P*&&Inv, now',f')"
| outputC : "semP (Cm (ch!!e)) now f  ((Out ch (valE e f(now))), Skip, now, f)"
| outputW : "d\<ge>0 \<Longrightarrow> semP (Cm (ch!!e)) now f ((Delay d), Cm (ch!!e), now+d,
            (%t. if t <= now+d & t > now then f(now) else f(t)))"
| inputC : "semP (Cm (ch??x)) now f ((In ch c), x:= (Con c), now, f)"
| inputW : "d\<ge>0 \<Longrightarrow> semP (Cm (ch??x)) now f ((Delay d), Cm (ch??x), now+d,
            (%t. if t <= now+d & t > now then f(now) else f(t)))"

inductive semPP :: "procP => now => history \<Rightarrow> history => (event * procP * now * history * history) \<Rightarrow> bool"
where
  parallel0 : "semPP (P||Q) now f g (eve, P'||Q', now', f', g') \<Longrightarrow> semPP (Q||P) now g f (eve, Q'||P', now', g', f')"
| parallel1 : "semP P now f (evp, P', now, f) \<and> semP Q now g (evq, Q', now, g') \<and> compat evp evq
             ==> semPP (P||Q) now f  g  (handshake evp evq, P'||Q', now, f', g')"
| parallel2 : "semP P now f  (evp, P', now', f')
             \<and> ((evp = Tau) | (EX ch c. evp = Out ch c & ~(ch \<in> chanset P \<inter> chanset Q))
             \<or> (EX ch c. evp = In ch c & ~(ch \<in> chanset P \<inter> chanset Q))
             \<or>(EX ch c. evp = IO ch c & ~(ch \<in> chanset P \<inter> chanset Q)))
            ==> semPP (P||Q) now f g (evp, P'||Q, now', f', g)"
| parallel3 : "semP P now f   (Delay d, P', now+d, f')
              \<and> semP Q now g (Delay d, Q', now+d, g')
               ==> semPP (P||Q) now f g (Delay d, P'||Q', now+d, (%t. if t <= now+d & t >= now then f'(t) else f(t)),
                   (%t. if t <= now+d & t >= now then g'(t) else g(t)))"
(*| parallel4: "semP (Skip||Skip) now f (Tau, Skip, now, f)"*)

(*Big-step semantics*)
inductive semB :: "proc => now => history => now \<Rightarrow> history \<Rightarrow> bool"
where
  skipB : "semB Skip now f now f"
| assignBR : "semB ((RVar (x)) := e) now f
    now  (%t. if t = now then (%(y, i). if y=x & i=R then (evalE e (f(t))) else (f(t)(y, i))) else f(t))"
| assignBS :"semB ((SVar (x)) := e) now f
  now (%t. if t = now then  (%(y, i). if y=x & i=S then (evalE e (f(t))) else (f(t)(y, i))) else f(t))"
| assignBB :"semB  ((BVar (x)) := e) now f
  now (%t. if t = now then  (%(y, i). if y=x & i=B then (evalE e (f(t))) else (f(t)(y, i))) else f(t))"
| continuousBF : "([\<not>]b) (f(now)) ==> semB (<[s]:E&&Inv&b>)  now f   now  f "
| continuousBT : "d>0 \<Longrightarrow> (
                     (let f'= (%t. if t <= now+d & t > now then
                       (%(y, i). if y=fst (s) & i=snd (s) then (Solution (<[s]:E&&Inv&b>) (f(now)) (t-now)) else f(now)(y, i)) else f(t)) in
                   ( \<forall> m.  m < now+d & m \<ge> now --> (b) (f'(m))) \<and> ([\<not>]b) (f'(now+d))))
    ==> semB (<[s]:E&&Inv&b>) now f
         (now+d) (%t. if t <= now+d & t > now then
       (%(y, i). if y=fst (s) & i=snd (s) then (Solution (<[s]:E&&Inv&b>) (f(now)) (t-now)) else f(now)(y, i)) else f(t))"
| sequenceB : "semB P now f now' f' \<and> semB Q now' f' now'' f''
               ==> semB (P; Q) now f now'' f''"
| conditionBT : "be (f(now)) ==> semB (P) now f  now_d f_d \<Longrightarrow> semB (IF be P) now f  now_d f_d"
| conditionBF : "\<not>be (f(now)) ==> semB (IF be P) now f  now  f "
| conditionGBT : "be (f(now)) ==> semB (P) now f  now_d f_d \<Longrightarrow> semB (IFELSE be P Q) now f  now_d f_d"
| conditionGBF : "\<not>be (f(now)) ==> semB (Q) now f  now_d f_d \<Longrightarrow> semB (IFELSE be P Q) now f  now_d f_d"
| joinBL : " semB (P) now f  now_d f_d ⟹ semB (P[[Q) now f  now_d f_d"
| joinBR : " semB (Q) now f  now_d f_d ⟹ semB (P[[Q) now f  now_d f_d"
(*| repetition0B : "semB (P*&&Inv) now f now f"
| repetitionkB : "semB P now f now_d f_d ⟹ semB (P*&&Inv) now_d f_d  now_dd f_dd ==>
                semB (P*&&Inv) now f  now_dd f_dd" *)
| repetitionB : "∃ N. semB (P* NUM N) now f  now_dd f_dd ⟹ semB (P*&&Inv) now f  now_dd f_dd"
| repetitionN0B : "N = (0::nat) ⟹  semB (P* NUM N) now f now f"
| repetitionNkB : "N >0 ⟹ semB P now f now_d f_d ⟹ semB (P* NUM (N-(1::nat))) now_d f_d  now_dd f_dd ==>
                semB (P* NUM N) now f  now_dd f_dd"
| outputBC : "d\<ge>0 \<Longrightarrow> semB (Cm (ch!!e)) now f (now+d)  (%t. if t <= now+d & t > now then f(now) else f(t))"
| inputBC : "d\<ge> 0 \<Longrightarrow> semB (Cm (ch??(RVar (x)))) now f (now + d)
            (%t. if t < now+d & t > now then f(now) else (if t = now+d then (%(y, i). if y=x & i=R then (c) else (f(now)(y, i))) else f(t)))"

(*There are four cases for semantics of parallel  composition.*)
inductive semBP :: "procP => now => history \<Rightarrow> now \<Rightarrow> history \<Rightarrow>  now \<Rightarrow> history \<Rightarrow> now \<Rightarrow> history \<Rightarrow> bool"
where
 parallelB1 : "semB P nowp fp nowp' fp' \<Longrightarrow> semB Q nowq fq nowq' fq' \<Longrightarrow> chanset P = {} \<and> chanset Q = {}  \<Longrightarrow>
   semBP (P||Q) nowp fp nowq fq nowp' fp' nowq'  fq'"
| parallelB2 : "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'  \<Longrightarrow>
                semB U nowp' fp' nowu' fu' \<Longrightarrow> semB V nowq' fq' nowv' fv'  \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
                chanset U = {} \<and> chanset V = {} \<Longrightarrow>
   semBP ((P; U) || (Q; V)) nowp fp nowq fq  nowu' fu' nowv' fv'"
| parallelB3: "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'
  \<Longrightarrow> semBP ((P;Cm (ch??(RVar (x))))||(Q; (Cm (ch!!e)))) nowp fp nowq fq (max nowp' nowq')
      (%t. if t>nowp'\<and> t< max nowp' nowq' then fp'(nowp') else
             (if t =max nowp' nowq' then (%(y, i).
                   if  y=x & i=R then (evalE e (fp'(nowp'))) else (fp'(nowp')(y, i))) else fp'(t)))
(max nowp' nowq')
 (%t. if t>nowq'\<and> t\<le> max nowp' nowq' then fq'(nowq') else fq'(t))"
| parallelB4: "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'
  \<Longrightarrow> semBP(((P; (Cm (ch!!e))))||(Q; Cm (ch??(RVar (x))))) nowp fp nowq fq (max nowp' nowq')
      (%t. if t>nowp'\<and> t\<le> max nowp' nowq' then fp'(nowp') else fp'(t))
(max nowp' nowq')
 (%t. if t>nowq'\<and> t< max nowp' nowq' then fq'(nowq') else
             (if t =max nowp' nowq' then (%(y, i).
                   if  y=x & i=R then (evalE e (fq'(nowq'))) else (fq'(nowq')(y, i))) else fq'(t)))"

inductive_cases [elim!]:
  "semB Skip now f now' f'" "semB ((RVar (x)) := e) now f now' f' "
"semB ((SVar (x)) := e) now f now' f' " "semB ((BVar (x)) := e) now f now' f' "
"semB (P; Q) now f now' f'" "semB (IF be P) now f  now'  f'" "semB (IFELSE be P Q) now f  now'  f'"
" semB (P[[Q) now f  now' f'" "semB (<[s]:E&&Inv&b>)  now f   now'  f'"
"semB (P*&&Inv) now f now' f'"
" semB (P* NUM N) now f now' f'"
"semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"

subsection{*Continuous evolution*}
(*Differential invariant: Now the invariant is annotated in the equation directly.*)
(*consts Invariant :: "proc \<Rightarrow> fform"*)
(*exeFlow defines the execution of a continuous process from a state satisfying a given property*)
definition exeFlow :: "proc \<Rightarrow> fform \<Rightarrow> fform" where
"exeFlow P p s \<equiv> (\<exists>  now f now' f'. (  (semB (P) now f now' f') \<and> p (f(now)) \<and>
(\<exists> t. t\<le> now' \<and> t\<ge> now \<and> f'(t) = s)))"

subsection{*Properties related to semantics*}
lemma sem1 : "semB P now f now' f' \<Longrightarrow> now \<le> now'"
apply (erule semB.induct)
apply auto
done

lemma semB1 : "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp \<le> nowp' \<and> nowq \<le> nowq'"
apply (erule semBP.induct)
apply (rule conjI)
apply (rule sem1, simp)
apply (rule sem1, simp)
apply (metis order_trans sem1)
apply (metis le_max_iff_disj)+
done

lemma sem2 : "semB P now f now' f' ⟹ ( ∀ t. t< now ∨ t> now' ⟶ f t = f' t)"
apply (erule semB.induct)
apply simp+
apply (subgoal_tac "now ≤ now' ∧ now' ≤ now''")
apply (metis (poly_guards_query) antisym_conv3 le_less_trans less_not_sym)
apply (rule conjI)
apply (cut_tac P = "P" and now = now and  now'=now' and f = "f" and f' = "f'" in sem1, simp)
apply metis
apply (cut_tac P = "Q" and now = now' and  now'=now'' and f = "f'" and f' = "f''" in sem1, simp)
apply metis+
apply (subgoal_tac "now ≤ now_d ∧ now_d ≤ now_dd")
apply (metis (poly_guards_query) antisym_conv3 le_less_trans less_not_sym)
apply (rule conjI)
apply (cut_tac P = "P" and now = now and  now'=now_d and f = "f" and f' = "f_d" in sem1, simp)
apply metis
apply (cut_tac P = "P* NUM (N - 1)" and now = now_d and  now'=now_dd and f = "f_d" and f' = "f_dd" in sem1, simp)
apply metis
   apply (metis less_not_sym not_le)
 by auto

lemma semB2 : "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' ⟹
  ( ∀ t. t< nowp ∨ t> nowp' ⟶ (fp t = fp' t))
∧  ( ∀ t. t< nowq ∨ t> nowq' ⟶ (fq t = fq' t))"
apply (erule semBP.induct)
apply (metis sem2)
apply (subgoal_tac "nowp ≤ nowp'∧ nowq ≤ nowq'∧ nowp'≤ nowu'∧ nowq'≤ nowv'")
apply (subgoal_tac "(∀t. t < nowp' ∨ nowu' < t ⟶ fp' t = fu' t) ∧ (∀t. t < nowq' ∨ nowv' < t ⟶ fq' t = fv' t)")
apply simp
apply (simp add: sem2)
apply (simp add: sem1 semB1)
apply (rule conjI)
apply (metis less_irrefl less_max_iff_disj max_def not_le semB1)
apply (metis less_irrefl less_max_iff_disj max_def not_le semB1)
apply (rule conjI)
apply (metis less_irrefl less_max_iff_disj max_def not_le semB1)
apply (metis less_irrefl less_max_iff_disj max_def not_le semB1)
done

lemma semB3 : " semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq'
                  \<Longrightarrow> chanset P = {} \<and> chanset Q = {}
                  \<Longrightarrow> semB P nowp fp nowp' fp' \<and> semB Q nowq fq nowq' fq'"
apply (ind_cases "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq'", simp)
apply (simp add:chanset_def)+
done

end


(*  Title:      HOL/Old_Number_Theory/Gauss.thy
    Authors:    Jeremy Avigad, David Gray, and Adam Kramer
*)

section {* Gauss' Lemma *}

theory Gauss
imports Euler
begin

locale GAUSS =
  fixes p :: "int"
  fixes a :: "int"

  assumes p_prime: "zprime p"
  assumes p_g_2: "2 < p"
  assumes p_a_relprime: "~[a = 0](mod p)"
  assumes a_nonzero:    "0 < a"
begin

definition "A = {(x::int). 0 < x & x \<le> ((p - 1) div 2)}"
definition "B = (%x. x * a) ` A"
definition "C = StandardRes p ` B"
definition "D = C \<inter> {x. x \<le> ((p - 1) div 2)}"
definition "E = C \<inter> {x. ((p - 1) div 2) < x}"
definition "F = (%x. (p - x)) ` E"

subsection {* Basic properties of p *}

lemma p_odd: "p \<in> zOdd"
  by (auto simp add: p_prime p_g_2 zprime_zOdd_eq_grt_2)

lemma p_g_0: "0 < p"
  using p_g_2 by auto

lemma int_nat: "int (nat ((p - 1) div 2)) = (p - 1) div 2"
  using ListMem.insert p_g_2 by (auto simp add: pos_imp_zdiv_nonneg_iff)

lemma p_minus_one_l: "(p - 1) div 2 < p"
proof -
  have "(p - 1) div 2 \<le> (p - 1) div 1"
    by (rule zdiv_mono2) (auto simp add: p_g_0)
  also have "\<dots> = p - 1" by simp
  finally show ?thesis by simp
qed

lemma p_eq: "p = (2 * (p - 1) div 2) + 1"
  using div_mult_self1_is_id [of 2 "p - 1"] by auto

lemma (in -) zodd_imp_zdiv_eq: "x \<in> zOdd ==> 2 * (x - 1) div 2 = 2 * ((x - 1) div 2)"
  apply (frule odd_minus_one_even)
  apply (simp add: zEven_def)
  apply (subgoal_tac "2 \<noteq> 0")
  apply (frule_tac b = "2 :: int" and a = "x - 1" in div_mult_self1_is_id)
  apply (auto simp add: even_div_2_prop2)
  done

lemma p_eq2: "p = (2 * ((p - 1) div 2)) + 1"
  apply (insert p_eq p_prime p_g_2 zprime_zOdd_eq_grt_2 [of p], auto)
  apply (frule zodd_imp_zdiv_eq, auto)
  done

subsection {* Basic Properties of the Gauss Sets *}

lemma finite_A: "finite (A)"
by (auto simp add: A_def)

lemma finite_B: "finite (B)"
by (auto simp add: B_def finite_A)

lemma finite_C: "finite (C)"
by (auto simp add: C_def finite_B)

lemma finite_D: "finite (D)"
by (auto simp add: D_def finite_C)

lemma finite_E: "finite (E)"
by (auto simp add: E_def finite_C)

lemma finite_F: "finite (F)"
by (auto simp add: F_def finite_E)

lemma C_eq: "C = D \<union> E"
by (auto simp add: C_def D_def E_def)

lemma A_card_eq: "card A = nat ((p - 1) div 2)"
  apply (auto simp add: A_def)
  apply (insert int_nat)
  apply (erule subst)
  apply (auto simp add: card_bdd_int_set_l_le)
  done

lemma inj_on_xa_A: "inj_on (%x. x * a) A"
  using a_nonzero by (simp add: A_def inj_on_def)

lemma A_res: "ResSet p A"
  apply (auto simp add: A_def ResSet_def)
  apply (rule_tac m = p in zcong_less_eq)
  apply (insert p_g_2, auto)
  done

lemma B_res: "ResSet p B"
  apply (insert p_g_2 p_a_relprime p_minus_one_l)
  apply (auto simp add: B_def)
  apply (rule ResSet_image)
  apply (auto simp add: A_res)
  apply (auto simp add: A_def)
proof -
  fix x fix y
  assume a: "[x * a = y * a] (mod p)"
  assume b: "0 < x"
  assume c: "x \<le> (p - 1) div 2"
  assume d: "0 < y"
  assume e: "y \<le> (p - 1) div 2"
  from a p_a_relprime p_prime a_nonzero zcong_cancel [of p a x y]
  have "[x = y](mod p)"
    by (simp add: zprime_imp_zrelprime zcong_def p_g_0 order_le_less)
  with zcong_less_eq [of x y p] p_minus_one_l
      order_le_less_trans [of x "(p - 1) div 2" p]
      order_le_less_trans [of y "(p - 1) div 2" p] show "x = y"
    by (simp add: b c d e p_minus_one_l p_g_0)
qed

lemma SR_B_inj: "inj_on (StandardRes p) B"
  apply (auto simp add: B_def StandardRes_def inj_on_def A_def)
proof -
  fix x fix y
  assume a: "x * a mod p = y * a mod p"
  assume b: "0 < x"
  assume c: "x \<le> (p - 1) div 2"
  assume d: "0 < y"
  assume e: "y \<le> (p - 1) div 2"
  assume f: "x \<noteq> y"
  from a have "[x * a = y * a](mod p)"
    by (simp add: zcong_zmod_eq p_g_0)
  with p_a_relprime p_prime a_nonzero zcong_cancel [of p a x y]
  have "[x = y](mod p)"
    by (simp add: zprime_imp_zrelprime zcong_def p_g_0 order_le_less)
  with zcong_less_eq [of x y p] p_minus_one_l
    order_le_less_trans [of x "(p - 1) div 2" p]
    order_le_less_trans [of y "(p - 1) div 2" p] have "x = y"
    by (simp add: b c d e p_minus_one_l p_g_0)
  then have False
    by (simp add: f)
  then show "a = 0"
    by simp
qed

lemma inj_on_pminusx_E: "inj_on (%x. p - x) E"
  apply (auto simp add: E_def C_def B_def A_def)
  apply (rule_tac g = "%x. -1 * (x - p)" in inj_on_inverseI)
  apply auto
  done

lemma A_ncong_p: "x \<in> A ==> ~[x = 0](mod p)"
  apply (auto simp add: A_def)
  apply (frule_tac m = p in zcong_not_zero)
  apply (insert p_minus_one_l)
  apply auto
  done

lemma A_greater_zero: "x \<in> A ==> 0 < x"
  by (auto simp add: A_def)

lemma B_ncong_p: "x \<in> B ==> ~[x = 0](mod p)"
  apply (auto simp add: B_def)
  apply (frule A_ncong_p)
  apply (insert p_a_relprime p_prime a_nonzero)
  apply (frule_tac a = xa and b = a in zcong_zprime_prod_zero_contra)
  apply (auto simp add: A_greater_zero)
  done

lemma B_greater_zero: "x \<in> B ==> 0 < x"
  using a_nonzero by (auto simp add: B_def A_greater_zero)

lemma C_ncong_p: "x \<in> C ==>  ~[x = 0](mod p)"
  apply (auto simp add: C_def)
  apply (frule B_ncong_p)
  apply (subgoal_tac "[xa = StandardRes p xa](mod p)")
  defer apply (simp add: StandardRes_prop1)
  apply (frule_tac a = xa and b = "StandardRes p xa" and c = 0 in zcong_trans)
  apply auto
  done

lemma C_greater_zero: "y \<in> C ==> 0 < y"
  apply (auto simp add: C_def)
proof -
  fix x
  assume a: "x \<in> B"
  from p_g_0 have "0 \<le> StandardRes p x"
    by (simp add: StandardRes_lbound)
  moreover have "~[x = 0] (mod p)"
    by (simp add: a B_ncong_p)
  then have "StandardRes p x \<noteq> 0"
    by (simp add: StandardRes_prop3)
  ultimately show "0 < StandardRes p x"
    by (simp add: order_le_less)
qed

lemma D_ncong_p: "x \<in> D ==> ~[x = 0](mod p)"
  by (auto simp add: D_def C_ncong_p)

lemma E_ncong_p: "x \<in> E ==> ~[x = 0](mod p)"
  by (auto simp add: E_def C_ncong_p)

lemma F_ncong_p: "x \<in> F ==> ~[x = 0](mod p)"
  apply (auto simp add: F_def)
proof -
  fix x assume a: "x \<in> E" assume b: "[p - x = 0] (mod p)"
  from E_ncong_p have "~[x = 0] (mod p)"
    by (simp add: a)
  moreover from a have "0 < x"
    by (simp add: a E_def C_greater_zero)
  moreover from a have "x < p"
    by (auto simp add: E_def C_def p_g_0 StandardRes_ubound)
  ultimately have "~[p - x = 0] (mod p)"
    by (simp add: zcong_not_zero)
  from this show False by (simp add: b)
qed

lemma F_subset: "F \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
  apply (auto simp add: F_def E_def)
  apply (insert p_g_0)
  apply (frule_tac x = xa in StandardRes_ubound)
  apply (frule_tac x = x in StandardRes_ubound)
  apply (subgoal_tac "xa = StandardRes p xa")
  apply (auto simp add: C_def StandardRes_prop2 StandardRes_prop1)
proof -
  from zodd_imp_zdiv_eq p_prime p_g_2 zprime_zOdd_eq_grt_2 have
    "2 * (p - 1) div 2 = 2 * ((p - 1) div 2)"
    by simp
  with p_eq2 show " !!x. [| (p - 1) div 2 < StandardRes p x; x \<in> B |]
      ==> p - StandardRes p x \<le> (p - 1) div 2"
    by simp
qed

lemma D_subset: "D \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
  by (auto simp add: D_def C_greater_zero)

lemma F_eq: "F = {x. \<exists>y \<in> A. ( x = p - (StandardRes p (y*a)) & (p - 1) div 2 < StandardRes p (y*a))}"
  by (auto simp add: F_def E_def D_def C_def B_def A_def)

lemma D_eq: "D = {x. \<exists>y \<in> A. ( x = StandardRes p (y*a) & StandardRes p (y*a) \<le> (p - 1) div 2)}"
  by (auto simp add: D_def C_def B_def A_def)

lemma D_leq: "x \<in> D ==> x \<le> (p - 1) div 2"
  by (auto simp add: D_eq)

lemma F_ge: "x \<in> F ==> x \<le> (p - 1) div 2"
  apply (auto simp add: F_eq A_def)
proof -
  fix y
  assume "(p - 1) div 2 < StandardRes p (y * a)"
  then have "p - StandardRes p (y * a) < p - ((p - 1) div 2)"
    by arith
  also from p_eq2 have "... = 2 * ((p - 1) div 2) + 1 - ((p - 1) div 2)"
    by auto
  also have "2 * ((p - 1) div 2) + 1 - (p - 1) div 2 = (p - 1) div 2 + 1"
    by arith
  finally show "p - StandardRes p (y * a) \<le> (p - 1) div 2"
    using zless_add1_eq [of "p - StandardRes p (y * a)" "(p - 1) div 2"] by auto
qed

lemma all_A_relprime: "\<forall>x \<in> A. zgcd x p = 1"
  using p_prime p_minus_one_l by (auto simp add: A_def zless_zprime_imp_zrelprime)

lemma A_prod_relprime: "zgcd (setprod id A) p = 1"
by(rule all_relprime_prod_relprime[OF finite_A all_A_relprime])

subsection {* Relationships Between Gauss Sets *}

lemma B_card_eq_A: "card B = card A"
  using finite_A by (simp add: finite_A B_def inj_on_xa_A card_image)

lemma B_card_eq: "card B = nat ((p - 1) div 2)"
  by (simp add: B_card_eq_A A_card_eq)

lemma F_card_eq_E: "card F = card E"
  using finite_E by (simp add: F_def inj_on_pminusx_E card_image)

lemma C_card_eq_B: "card C = card B"
  apply (insert finite_B)
  apply (subgoal_tac "inj_on (StandardRes p) B")
  apply (simp add: B_def C_def card_image)
  apply (rule StandardRes_inj_on_ResSet)
  apply (simp add: B_res)
  done

lemma D_E_disj: "D \<inter> E = {}"
  by (auto simp add: D_def E_def)

lemma C_card_eq_D_plus_E: "card C = card D + card E"
  by (auto simp add: C_eq card_Un_disjoint D_E_disj finite_D finite_E)

lemma C_prod_eq_D_times_E: "setprod id E * setprod id D = setprod id C"
  apply (insert D_E_disj finite_D finite_E C_eq)
  apply (frule setprod.union_disjoint [of D E id])
  apply auto
  done

lemma C_B_zcong_prod: "[setprod id C = setprod id B] (mod p)"
  apply (auto simp add: C_def)
  apply (insert finite_B SR_B_inj)
  apply (frule setprod.reindex [of "StandardRes p" B id])
  apply auto
  apply (rule setprod_same_function_zcong)
  apply (auto simp add: StandardRes_prop1 zcong_sym p_g_0)
  done

lemma F_Un_D_subset: "(F \<union> D) \<subseteq> A"
  apply (rule Un_least)
  apply (auto simp add: A_def F_subset D_subset)
  done

lemma F_D_disj: "(F \<inter> D) = {}"
  apply (simp add: F_eq D_eq)
  apply (auto simp add: F_eq D_eq)
proof -
  fix y fix ya
  assume "p - StandardRes p (y * a) = StandardRes p (ya * a)"
  then have "p = StandardRes p (y * a) + StandardRes p (ya * a)"
    by arith
  moreover have "p dvd p"
    by auto
  ultimately have "p dvd (StandardRes p (y * a) + StandardRes p (ya * a))"
    by auto
  then have a: "[StandardRes p (y * a) + StandardRes p (ya * a) = 0] (mod p)"
    by (auto simp add: zcong_def)
  have "[y * a = StandardRes p (y * a)] (mod p)"
    by (simp only: zcong_sym StandardRes_prop1)
  moreover have "[ya * a = StandardRes p (ya * a)] (mod p)"
    by (simp only: zcong_sym StandardRes_prop1)
  ultimately have "[y * a + ya * a =
    StandardRes p (y * a) + StandardRes p (ya * a)] (mod p)"
    by (rule zcong_zadd)
  with a have "[y * a + ya * a = 0] (mod p)"
    apply (elim zcong_trans)
    by (simp only: zcong_refl)
  also have "y * a + ya * a = a * (y + ya)"
    by (simp add: distrib_left mult.commute)
  finally have "[a * (y + ya) = 0] (mod p)" .
  with p_prime a_nonzero zcong_zprime_prod_zero [of p a "y + ya"]
    p_a_relprime
  have a: "[y + ya = 0] (mod p)"
    by auto
  assume b: "y \<in> A" and c: "ya: A"
  with A_def have "0 < y + ya"
    by auto
  moreover from b c A_def have "y + ya \<le> (p - 1) div 2 + (p - 1) div 2"
    by auto
  moreover from b c p_eq2 A_def have "y + ya < p"
    by auto
  ultimately show False
    apply simp
    apply (frule_tac m = p in zcong_not_zero)
    apply (auto simp add: a)
    done
qed

lemma F_Un_D_card: "card (F \<union> D) = nat ((p - 1) div 2)"
proof -
  have "card (F \<union> D) = card E + card D"
    by (auto simp add: finite_F finite_D F_D_disj
      card_Un_disjoint F_card_eq_E)
  then have "card (F \<union> D) = card C"
    by (simp add: C_card_eq_D_plus_E)
  from this show "card (F \<union> D) = nat ((p - 1) div 2)"
    by (simp add: C_card_eq_B B_card_eq)
qed

lemma F_Un_D_eq_A: "F \<union> D = A"
  using finite_A F_Un_D_subset A_card_eq F_Un_D_card by (auto simp add: card_seteq)

lemma prod_D_F_eq_prod_A:
    "(setprod id D) * (setprod id F) = setprod id A"
  apply (insert F_D_disj finite_D finite_F)
  apply (frule setprod.union_disjoint [of F D id])
  apply (auto simp add: F_Un_D_eq_A)
  done

lemma prod_F_zcong:
  "[setprod id F = ((-1) ^ (card E)) * (setprod id E)] (mod p)"
proof -
  have "setprod id F = setprod id (op - p ` E)"
    by (auto simp add: F_def)
  then have "setprod id F = setprod (op - p) E"
    apply simp
    apply (insert finite_E inj_on_pminusx_E)
    apply (frule setprod.reindex [of "minus p" E id])
    apply auto
    done
  then have one:
    "[setprod id F = setprod (StandardRes p o (op - p)) E] (mod p)"
    apply simp
    apply (insert p_g_0 finite_E StandardRes_prod)
    by (auto)
  moreover have a: "\<forall>x \<in> E. [p - x = 0 - x] (mod p)"
    apply clarify
    apply (insert zcong_id [of p])
    apply (rule_tac a = p and m = p and c = x and d = x in zcong_zdiff, auto)
    done
  moreover have b: "\<forall>x \<in> E. [StandardRes p (p - x) = p - x](mod p)"
    apply clarify
    apply (simp add: StandardRes_prop1 zcong_sym)
    done
  moreover have "\<forall>x \<in> E. [StandardRes p (p - x) = - x](mod p)"
    apply clarify
    apply (insert a b)
    apply (rule_tac b = "p - x" in zcong_trans, auto)
    done
  ultimately have c:
    "[setprod (StandardRes p o (op - p)) E = setprod (uminus) E](mod p)"
    apply simp
    using finite_E p_g_0
      setprod_same_function_zcong [of E "StandardRes p o (op - p)" uminus p]
    by auto
  then have two: "[setprod id F = setprod (uminus) E](mod p)"
    apply (insert one c)
    apply (rule zcong_trans [of "setprod id F"
                               "setprod (StandardRes p o op - p) E" p
                               "setprod uminus E"], auto)
    done
  also have "setprod uminus E = (setprod id E) * (-1)^(card E)"
    using finite_E by (induct set: finite) auto
  then have "setprod uminus E = (-1) ^ (card E) * (setprod id E)"
    by (simp add: mult.commute)
  with two show ?thesis
    by simp
qed

subsection {* Gauss' Lemma *}

lemma aux: "setprod id A * (- 1) ^ card E * a ^ card A * (- 1) ^ card E = setprod id A * a ^ card A"
  by (auto simp add: finite_E neg_one_special)

theorem pre_gauss_lemma:
  "[a ^ nat((p - 1) div 2) = (-1) ^ (card E)] (mod p)"
proof -
  have "[setprod id A = setprod id F * setprod id D](mod p)"
    by (auto simp add: prod_D_F_eq_prod_A mult.commute cong del:setprod.cong)
  then have "[setprod id A = ((-1)^(card E) * setprod id E) *
      setprod id D] (mod p)"
    apply (rule zcong_trans)
    apply (auto simp add: prod_F_zcong zcong_scalar cong del: setprod.cong)
    done
  then have "[setprod id A = ((-1)^(card E) * setprod id C)] (mod p)"
    apply (rule zcong_trans)
    apply (insert C_prod_eq_D_times_E, erule subst)
    apply (subst mult.assoc, auto)
    done
  then have "[setprod id A = ((-1)^(card E) * setprod id B)] (mod p)"
    apply (rule zcong_trans)
    apply (simp add: C_B_zcong_prod zcong_scalar2 cong del:setprod.cong)
    done
  then have "[setprod id A = ((-1)^(card E) *
    (setprod id ((%x. x * a) ` A)))] (mod p)"
    by (simp add: B_def)
  then have "[setprod id A = ((-1)^(card E) * (setprod (%x. x * a) A))]
    (mod p)"
    by (simp add:finite_A inj_on_xa_A setprod.reindex cong del:setprod.cong)
  moreover have "setprod (%x. x * a) A =
    setprod (%x. a) A * setprod id A"
    using finite_A by (induct set: finite) auto
  ultimately have "[setprod id A = ((-1)^(card E) * (setprod (%x. a) A *
    setprod id A))] (mod p)"
    by simp
  then have "[setprod id A = ((-1)^(card E) * a^(card A) *
      setprod id A)](mod p)"
    apply (rule zcong_trans)
    apply (simp add: zcong_scalar2 zcong_scalar finite_A setprod_constant mult.assoc)
    done
  then have a: "[setprod id A * (-1)^(card E) =
      ((-1)^(card E) * a^(card A) * setprod id A * (-1)^(card E))](mod p)"
    by (rule zcong_scalar)
  then have "[setprod id A * (-1)^(card E) = setprod id A *
      (-1)^(card E) * a^(card A) * (-1)^(card E)](mod p)"
    apply (rule zcong_trans)
    apply (simp add: a mult.commute mult.left_commute)
    done
  then have "[setprod id A * (-1)^(card E) = setprod id A *
      a^(card A)](mod p)"
    apply (rule zcong_trans)
    apply (simp add: aux cong del:setprod.cong)
    done
  with this zcong_cancel2 [of p "setprod id A" "(- 1) ^ card E" "a ^ card A"]
      p_g_0 A_prod_relprime have "[(- 1) ^ card E = a ^ card A](mod p)"
    by (simp add: order_less_imp_le)
  from this show ?thesis
    by (simp add: A_card_eq zcong_sym)
qed

theorem gauss_lemma: "(Legendre a p) = (-1) ^ (card E)"
proof -
  from Euler_Criterion p_prime p_g_2 have
      "[(Legendre a p) = a^(nat (((p) - 1) div 2))] (mod p)"
    by auto
  moreover note pre_gauss_lemma
  ultimately have "[(Legendre a p) = (-1) ^ (card E)] (mod p)"
    by (rule zcong_trans)
  moreover from p_a_relprime have "(Legendre a p) = 1 | (Legendre a p) = (-1)"
    by (auto simp add: Legendre_def)
  moreover have "(-1::int) ^ (card E) = 1 | (-1::int) ^ (card E) = -1"
    by (rule neg_one_power)
  ultimately show ?thesis
    by (auto simp add: p_g_2 one_not_neg_one_mod_m zcong_sym)
qed

end

end