theory LLVM_DS_Block_Alloc
imports "../vcg/LLVM_VCG_Main"
begin

section \<open>Operations on memory blocks\<close>
context
begin
  interpretation llvm_prim_mem_setup .

definition "ll_bpto \<equiv> mk_assn (\<lambda>x p. \<up>(abase p) ** \<upharpoonleft>ll_pto x p ** ll_malloc_tag 1 p)"
definition [llvm_code, llvm_inline]: "ll_ref (x::'a::llvm_rep) \<equiv> doM { r \<leftarrow> ll_malloc TYPE('a) (1::1 word); ll_store x r; return r }"
definition ll_balloc :: "'a::llvm_rep ptr llM" where [llvm_code, llvm_inline]: "ll_balloc \<equiv> ll_malloc TYPE('a) (1::1 word)"
abbreviation "ll_balloc' TYPE('a::llvm_rep) \<equiv> ll_balloc :: 'a ptr llM"

lemma ll_range_01: "\<upharpoonleft>(ll_range {0..<1}) f p = (\<up>(abase p) ** \<upharpoonleft>ll_pto (f 0) p )"
  unfolding ll_range_def
  apply (subgoal_tac "({0..<1}::int set) = {0}")
  by auto

lemma ll_bpto_alt: "\<upharpoonleft>ll_bpto x p = (\<upharpoonleft>(ll_range {0..<1}) (\<lambda>_. x) p ** ll_malloc_tag 1 p)"
  unfolding ll_bpto_def ll_range_01
  by simp

lemma ll_bpto_null[simp]: "\<upharpoonleft>ll_bpto x null = sep_false"
  unfolding ll_bpto_def
  by simp

lemma ll_ref_rule[vcg_rules]: "llvm_htriple \<box> (ll_ref x) (\<lambda>p. \<upharpoonleft>ll_bpto x p)"
  unfolding ll_bpto_def ll_ref_def
  supply [simp] = ll_range_01
  apply vcg
  done

lemma ll_balloc_rule[vcg_rules]: "llvm_htriple \<box> (ll_balloc' TYPE('a::llvm_rep)) (\<lambda>p. \<upharpoonleft>ll_bpto (init::'a) p)"
  unfolding ll_bpto_def ll_balloc_def
  supply [simp] = ll_range_01
  apply vcg
  done

lemma ll_free_bpto_rule[vcg_rules]: "llvm_htriple (\<upharpoonleft>ll_bpto x p) (ll_free p) (\<lambda>_. \<box>)"
  unfolding ll_bpto_alt
  by vcg

lemma ll_load_bpto_rule[vcg_rules]: "llvm_htriple (\<upharpoonleft>ll_bpto x p) (ll_load p) (\<lambda>r. \<up>(r=x) ** \<upharpoonleft>ll_bpto x p)"
  unfolding ll_bpto_def
  by vcg

lemma ll_store_bpto_rule[vcg_rules]: "llvm_htriple (\<upharpoonleft>ll_bpto x p) (ll_store x' p) (\<lambda>_. \<upharpoonleft>ll_bpto x' p)"
  unfolding ll_bpto_def
  by vcg

end

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

header "Nondeterministic automata with epsilon transitions"

theory NAe
imports NA
begin

type_synonym ('a,'s)nae = "('a option,'s)na"

abbreviation
  eps :: "('a,'s)nae => ('s * 's)set" where
  "eps A == step A None"

primrec steps :: "('a,'s)nae => 'a list =>   ('s * 's)set" where
"steps A [] = (eps A)^*" |
"steps A (a#w) = (eps A)^* O step A (Some a) O steps A w"

definition
 accepts :: "('a,'s)nae => 'a list => bool" where
"accepts A w = (? q. (start A,q) : steps A w & fin A q)"

(* not really used:
consts delta :: "('a,'s)nae => 'a list => 's => 's set"
primrec
"delta A [] s = (eps A)^* `` {s}"
"delta A (a#w) s = lift(delta A w) (lift(next A (Some a)) ((eps A)^* `` {s}))"
*)

lemma steps_epsclosure[simp]: "(eps A)^* O steps A w = steps A w"
by (cases w) (simp_all add: O_assoc[symmetric])

lemma in_steps_epsclosure:
  "[| (p,q) : (eps A)^*; (q,r) : steps A w |] ==> (p,r) : steps A w"
apply(rule steps_epsclosure[THEN equalityE])
apply blast
done

lemma epsclosure_steps: "steps A w O (eps A)^* = steps A w";
apply(induct w)
 apply simp
apply(simp add:O_assoc)
done

lemma steps_append[simp]:  "steps A (v@w) = steps A v  O  steps A w"
by(induct v)(simp_all add:O_assoc[symmetric])

lemma in_steps_append[iff]:
  "(p,r) : steps A (v@w) = ((p,r) : (steps A v O steps A w))"
apply(rule steps_append[THEN equalityE])
apply blast
done

(* Equivalence of steps and delta
* Use "(? x : f ` A. P x) = (? a:A. P(f x))" ?? *
Goal "!p. (p,q) : steps A w = (q : delta A w p)";
by (induct_tac "w" 1);
 by (Simp_tac 1);
by (asm_simp_tac (simpset() addsimps [comp_def,step_def]) 1);
by (Blast_tac 1);
qed_spec_mp "steps_equiv_delta";
*)

end


theory Complete
  imports BigStepParallel
begin

subsection \<open>Proof system\<close>

inductive hoare :: "assn \<Rightarrow> proc \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
  and echoice_hoare :: "assn \<Rightarrow> nat \<Rightarrow> (comm \<times> proc) list \<Rightarrow> assn \<Rightarrow> bool"
  and interrupt_hoare :: "assn \<Rightarrow> nat \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> (comm \<times> proc) list \<Rightarrow> assn \<Rightarrow> bool" where
  SkipH: "\<turnstile> {P} Skip {P}"
| AssignH: "\<turnstile> {\<lambda>s. Q (s(var := e s))} (var ::= e) {Q}"
| SendH:
    "\<turnstile> {\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)]) \<and>
               (\<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) ({ch}, {}), OutBlock ch (e s)])) \<and>
               Q s (tr @ [WaitBlk \<infinity> (\<lambda>_. State s) ({ch}, {})])}
         (Cm (ch[!]e))
       {Q}"
| ReceiveH:
    "\<turnstile> {\<lambda>s tr. (\<forall>v. Q (s(var := v)) (tr @ [InBlock ch v])) \<and>
               (\<forall>d::real>0. \<forall>v. Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) ({}, {ch}), InBlock ch v])) \<and>
               Q s (tr @ [WaitBlk \<infinity> (\<lambda>_. State s) ({}, {ch})])}
         (Cm (ch[?]var))
       {Q}"
| SeqH:
    "\<turnstile> {P} c1 {Q} \<Longrightarrow> \<turnstile> {Q} c2 {R} \<Longrightarrow> \<turnstile> {P} c1; c2 {R}"
| CondH:
    "\<turnstile> {P1} c1 {Q} \<Longrightarrow> \<turnstile> {P2} c2 {Q} \<Longrightarrow>
     \<turnstile> {\<lambda>s. if b s then P1 s else P2 s} (Cond b c1 c2) {Q}"
| WaitH:
    "\<turnstile> {\<lambda>s tr. if e s > 0 then Q s (tr @ [WaitBlk (e s) (\<lambda>_. State s) ({}, {})]) else Q s tr}
         (Wait e)
       {Q}"
| RepH:
    "\<turnstile> {P} c {P} \<Longrightarrow> \<turnstile> {P} (Rep c) {P}"
| IChoiceH:
    "\<turnstile> {P1} c1 {Q} \<Longrightarrow> \<turnstile> {P2} c2 {Q} \<Longrightarrow>
     \<turnstile> {\<lambda>s tr. P1 s tr \<and> P2 s tr} IChoice c1 c2 {Q}"
| EChoiceH1:
    "echoice_hoare P 0 es R"
| EChoiceH2:
    "\<turnstile> {Q} p2 {R} \<Longrightarrow>
     es ! n = (ch[!]e, p2) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)])) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)])) \<Longrightarrow>
     echoice_hoare P n es R \<Longrightarrow>
     echoice_hoare P (Suc n) es R"
| EChoiceH3:
    "\<turnstile> {Q} p2 {R} \<Longrightarrow>
     es ! n = (ch[?]var, p2) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>v. Q (s(var := v)) (tr @ [InBlock ch v])) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. \<forall>v. Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v])) \<Longrightarrow>
     echoice_hoare P n es R \<Longrightarrow>
     echoice_hoare P (Suc n) es R"
| EChoiceH4:
    "echoice_hoare P (length es) es R \<Longrightarrow> \<turnstile> {P} EChoice es {R}"
| EChoiceH5:
    "P' \<Longrightarrow>\<^sub>A P \<Longrightarrow> echoice_hoare P n es R \<Longrightarrow> echoice_hoare P' n es R"
| ContH:
    "\<turnstile> {\<lambda>s tr. (\<not>b s \<longrightarrow> Q s tr) \<and>
             (\<forall>d p. 0 < d \<longrightarrow> ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow> (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
                   Q (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) ({}, {})]))}
         (Cont ode b)
       {Q}"
| InterruptH1:
    "P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<not>b s \<longrightarrow> R s tr) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
               (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
               R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es)]))) \<Longrightarrow>
     interrupt_hoare P 0 ode b es R"
| InterruptH2:
    "\<turnstile> {Q} p2 {R} \<Longrightarrow>
     es ! n = (ch[!]e, p2) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)])) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
               (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
               Q (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es),
                              OutBlock ch (e (p d))])) \<Longrightarrow>
     interrupt_hoare P n ode b es R \<Longrightarrow>
     interrupt_hoare P (Suc n) ode b es R"
| InterruptH3:
    "\<turnstile> {Q} p2 {R} \<Longrightarrow>
     es ! n = (ch[?]var, p2) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>v. Q (s(var := v)) (tr @ [InBlock ch v])) \<Longrightarrow>
     P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
               (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
               Q ((p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es),
                                          InBlock ch v])) \<Longrightarrow>
     interrupt_hoare P n ode b es R \<Longrightarrow>
     interrupt_hoare P (Suc n) ode b es R"
| InterruptH4:
    "interrupt_hoare P (length es) ode b es R \<Longrightarrow> \<turnstile> {P} Interrupt ode b es {R}"
| InterruptH5:
    "P' \<Longrightarrow>\<^sub>A P \<Longrightarrow> interrupt_hoare P n ode b es R \<Longrightarrow> interrupt_hoare P' n ode b es R"
| ConseqH:
    "P' \<Longrightarrow>\<^sub>A P \<Longrightarrow> Q \<Longrightarrow>\<^sub>A Q' \<Longrightarrow> \<turnstile> {P} c {Q} \<Longrightarrow> \<turnstile> {P'} c {Q'}"

inductive big_step_echoice :: "nat \<Rightarrow> (comm \<times> proc) list \<Rightarrow> state \<Rightarrow> trace \<Rightarrow> state \<Rightarrow> bool" where
  "i < n \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
    big_step p2 s1 tr2 s2 \<Longrightarrow>
    big_step_echoice n cs s1 (OutBlock ch (e s1) # tr2) s2"
| "(d::real) > 0 \<Longrightarrow> i < n \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
    big_step p2 s1 tr2 s2 \<Longrightarrow>
    big_step_echoice n cs s1 (WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice cs) #
                              OutBlock ch (e s1) # tr2) s2"
| "i < n \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
    big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow>
    big_step_echoice n cs s1 (InBlock ch v # tr2) s2"
| "(d::real) > 0 \<Longrightarrow> i < n \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
    big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow>
    big_step_echoice n cs s1 (WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice cs) #
                              InBlock ch v # tr2) s2"

inductive_cases big_step_echoiceE: "big_step_echoice n cs s1 tr s2"

lemma big_step_echoice_next_rev1:
  "big_step_echoice (Suc n) es s1 tr s2 \<Longrightarrow>
   es ! n = (Send ch e, p2) \<Longrightarrow>
   (big_step_echoice n es s1 tr s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>tr2. tr = OutBlock ch (e s1) # tr2 \<Longrightarrow> big_step p2 s1 tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>d tr2. (d::real) > 0 \<Longrightarrow>
       tr = WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice es) #
            OutBlock ch (e s1) # tr2 \<Longrightarrow> big_step p2 s1 tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   P"
  apply (auto elim!: big_step_echoiceE)
  subgoal for i ch' e' p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(1))
    by (metis Pair_inject comm.inject(1) less_antisym)
  subgoal for d i ch' e' p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(2))
    by (metis Pair_inject comm.inject(1) less_antisym)
  subgoal for i ch' var p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(3))
    by (metis Pair_inject comm.distinct(1) less_SucE)
  subgoal for d i ch' var p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(4))
    by (metis Pair_inject comm.distinct(1) less_SucE)
  done

lemma big_step_echoice_next_rev2:
  "big_step_echoice (Suc n) es s1 tr s2 \<Longrightarrow>
   es ! n = (Receive ch var, p2) \<Longrightarrow>
   (big_step_echoice n es s1 tr s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>tr2 v. tr = InBlock ch v # tr2 \<Longrightarrow> big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>d tr2 v. (d::real) > 0 \<Longrightarrow>
       tr = WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice es) #
            InBlock ch v # tr2 \<Longrightarrow> big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   P"
  apply (auto elim!: big_step_echoiceE)
  subgoal for i ch' e' p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(1))
    by (metis Pair_inject comm.distinct(1) less_SucE)
  subgoal for d i ch' e' p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(2))
    by (metis Pair_inject comm.distinct(1) less_SucE)
  subgoal for i ch' var' p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(3))
    by (metis comm.inject(2) less_antisym old.prod.inject)
  subgoal for d i ch' var' p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_echoice.intros(4))
    by (metis Pair_inject comm.inject(2) less_SucE)
  done

lemma big_step_echoice_final:
  "big_step_echoice (length cs) cs s1 tr s2 \<longleftrightarrow> big_step (EChoice cs) s1 tr s2"
  apply (rule iffI)
  apply (auto elim!: echoiceE big_step_echoiceE)
  by (auto intro: big_step.intros big_step_echoice.intros)

lemma big_step_echoice_provable:
  assumes "\<forall>e\<in>set es. \<turnstile> {wp (snd e) Q} snd e {Q}"
  shows "n \<le> length es \<Longrightarrow> echoice_hoare
    (\<lambda>s tr. \<forall>i<n.
      case es ! i of
        (ch[!]e, p2) \<Rightarrow>
          wp p2 Q s (tr @ [OutBlock ch (e s)]) \<and>
          (\<forall>d::real>0. wp p2 Q s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)]))
      | (ch[?]var, p2) \<Rightarrow>
          (\<forall>v. wp p2 Q (s(var := v)) (tr @ [InBlock ch v])) \<and>
          (\<forall>d::real>0. \<forall>v. wp p2 Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v])))
    n es Q"
proof (induction n)
  case 0
  then show ?case
    by (auto intro: EChoiceH1)
next
  case (Suc n)
  have "es ! n \<in> set es"
    using Suc(2) by auto
  then have 1: "\<turnstile> {wp (snd (es ! n)) Q} (snd (es ! n)) {Q}"
    using assms(1) by auto
  show ?case
  proof (cases "es ! n")
    case (Pair cm p2)
    then show ?thesis
    proof (cases cm)
      case (Send ch e)
      show ?thesis
        apply (rule EChoiceH2[of "wp p2 Q" p2 _ es n ch e])
        subgoal using 1 Pair by auto
        subgoal using Pair Send by auto
        subgoal using Pair Send unfolding entails_def by auto
        subgoal using Pair Send unfolding entails_def by auto
        apply (rule EChoiceH5[OF _ Suc(1)])
         apply (auto simp add: entails_def)
        using Suc(2) by auto
    next
      case (Receive ch var)
      show ?thesis
        apply (rule EChoiceH3[of "wp p2 Q" p2 _ es n ch var])
        subgoal using 1 Pair by auto
        subgoal using Pair Receive by auto
        subgoal using Pair Receive unfolding entails_def by auto
        subgoal using Pair Receive unfolding entails_def by auto
        apply (rule EChoiceH5[OF _ Suc(1)])
         apply (auto simp add: entails_def)
        using Suc(2) by auto
    qed
  qed
qed

definition echoice_Valid :: "assn \<Rightarrow> nat \<Rightarrow> (comm \<times> proc) list \<Rightarrow> assn \<Rightarrow> bool" where
  "echoice_Valid P n cs Q \<longleftrightarrow>
    (\<forall>s1 tr1 s2 tr2. P s1 tr1 \<longrightarrow> big_step_echoice n cs s1 tr2 s2 \<longrightarrow> Q s2 (tr1 @ tr2))"

inductive big_step_interrupt :: "nat \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> (comm \<times> proc) list \<Rightarrow> state \<Rightarrow> trace \<Rightarrow> state \<Rightarrow> bool" where
  "i < n \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
   big_step p2 s tr2 s2 \<Longrightarrow>
   big_step_interrupt n ode b cs s (OutBlock ch (e s) # tr2) s2"
| "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s1 \<Longrightarrow>
   (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
   i < n \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
   rdy = rdy_of_echoice cs \<Longrightarrow>
   big_step p2 (p d) tr2 s2 \<Longrightarrow>
   big_step_interrupt n ode b cs s1 (WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) rdy #
                                     OutBlock ch (e (p d)) # tr2) s2"
| "i < n \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
   big_step p2 (s(var := v)) tr2 s2 \<Longrightarrow>
   big_step_interrupt n ode b cs s (InBlock ch v # tr2) s2"
| "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s1 \<Longrightarrow>
   (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
   i < n \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
   rdy = rdy_of_echoice cs \<Longrightarrow>
   big_step p2 ((p d)(var := v)) tr2 s2 \<Longrightarrow>
   big_step_interrupt n ode b cs s1 (WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) rdy #
                                     InBlock ch v # tr2) s2"
| "\<not>b s \<Longrightarrow> big_step_interrupt n ode b cs s [] s"
| "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow>
   (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
   \<not>b (p d) \<Longrightarrow> p 0 = s1 \<Longrightarrow> p d = s2 \<Longrightarrow>
   rdy = rdy_of_echoice cs \<Longrightarrow>
   big_step_interrupt n ode b cs s1 [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) rdy] s2"

inductive_cases big_step_interruptE: "big_step_interrupt n ode b cs s1 tr s2"

lemma big_step_interrupt_next_rev1:
  "big_step_interrupt (Suc n) ode b es s1 tr s2 \<Longrightarrow>
   es ! n = (Send ch e, p2) \<Longrightarrow>
   (big_step_interrupt n ode b es s1 tr s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>tr2. tr = OutBlock ch (e s1) # tr2 \<Longrightarrow>
      big_step p2 s1 tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>p d tr2.
      tr = WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es) #
           OutBlock ch (e (p d)) # tr2 \<Longrightarrow>
      d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s1 \<Longrightarrow>
      (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
      big_step p2 (p d) tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   P"
  apply (elim big_step_interruptE)
  subgoal for i ch' e' p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(1))
    using less_antisym by fastforce
  subgoal for d p i ch' e' p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(2))
    by (metis comm.inject(1) nat_neq_iff not_less_eq old.prod.inject)
  subgoal for i ch' var p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(3))
    using less_antisym by fastforce
  subgoal for d p i ch' var p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(4))
    by (metis Pair_inject comm.distinct(1) less_SucE)
  by (auto simp add: big_step_interrupt.intros(5,6))

lemma big_step_interrupt_next_rev2:
  "big_step_interrupt (Suc n) ode b es s1 tr s2 \<Longrightarrow>
   es ! n = (Receive ch var, p2) \<Longrightarrow>
   (big_step_interrupt n ode b es s1 tr s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>v tr2. tr = InBlock ch v # tr2 \<Longrightarrow>
      big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
   (\<And>p d v tr2.
      tr = WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es) #
           InBlock ch v # tr2 \<Longrightarrow>
      d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s1 \<Longrightarrow>
      (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
      big_step p2 ((p d)(var := v)) tr2 s2 \<Longrightarrow> P) \<Longrightarrow>
    P"
  apply (elim big_step_interruptE)
  subgoal for i ch' e p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(1))
    using less_antisym by fastforce
  subgoal for d p i ch' e p2' tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(2))
    by (metis Pair_inject comm.distinct(1) less_SucE)
  subgoal for i ch' var' p2' v' tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(3))
    using less_antisym by fastforce
  subgoal for d p i ch' var' p2' v tr2
    apply (cases "i < n")
     apply (simp add: big_step_interrupt.intros(4))
    by (metis Pair_inject comm.inject(2) less_antisym)
  by (auto simp add: big_step_interrupt.intros(5,6))

lemma big_step_interrupt_final:
  "big_step_interrupt (length es) ode b es s1 tr s2 \<longleftrightarrow> big_step (Interrupt ode b es) s1 tr s2"
  apply (rule iffI)
  apply (auto elim!: interruptE big_step_interruptE)
  by (auto intro: big_step.intros big_step_interrupt.intros)

lemma big_step_interrupt_provable:
  assumes "\<forall>e\<in>set es. \<turnstile> {wp (snd e) R} snd e {R}"
  shows "n \<le> length es \<Longrightarrow> interrupt_hoare
    (\<lambda>s tr. (\<forall>i<n.
      case es ! i of
        (ch[!]e, p2) \<Rightarrow>
          wp p2 R s (tr @ [OutBlock ch (e s)]) \<and>
          (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
             (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
             wp p2 R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es),
                                  OutBlock ch (e (p d))]))
      | (ch[?]var, p2) \<Rightarrow>
          (\<forall>v. wp p2 R (s(var := v)) (tr @ [InBlock ch v])) \<and>
          (\<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
             (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
             wp p2 R ((p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es),
                                              InBlock ch v]))) \<and>
        (\<not>b s \<longrightarrow> R s tr) \<and>
        (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
           (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
           R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es)])))
    n ode b es R"
proof (induction n)
  case 0
  show ?case
    apply (rule InterruptH1)
    unfolding entails_def by auto
next
  case (Suc n)
  have "es ! n \<in> set es"
    using Suc(2) by auto
  then have 1: "\<turnstile> {wp (snd (es ! n)) R} (snd (es ! n)) {R}"
    using assms(1) by auto
  show ?case
  proof (cases "es ! n")
    case (Pair cm p2)
    then show ?thesis
    proof (cases cm)
      case (Send ch e)
      show ?thesis
        apply (rule InterruptH2[of "wp p2 R" p2 _ es n ch e])
        subgoal using 1 Pair by auto
        subgoal using Pair Send by auto
        subgoal using Pair Send unfolding entails_def by auto
        subgoal using Pair Send unfolding entails_def by auto
        apply (rule InterruptH5[OF _ Suc(1)])
         apply (auto simp add: entails_def)
        using Suc(2) by auto
    next
      case (Receive ch var)
      show ?thesis
        apply (rule InterruptH3[of "wp p2 R" p2 _ es n ch var])
        subgoal using 1 Pair by auto
        subgoal using Pair Receive by auto
        subgoal using Pair Receive unfolding entails_def by auto
        subgoal using Pair Receive unfolding entails_def by auto
        apply (rule InterruptH5[OF _ Suc(1)])
         apply (auto simp add: entails_def)
        using Suc(2) by auto
    qed
  qed
qed

definition interrupt_Valid :: "assn \<Rightarrow> nat \<Rightarrow> ODE \<Rightarrow> fform \<Rightarrow> (comm \<times> proc) list \<Rightarrow> assn \<Rightarrow> bool" where
  "interrupt_Valid P n ode b cs Q \<longleftrightarrow>
    (\<forall>s1 tr1 s2 tr2. P s1 tr1 \<longrightarrow> big_step_interrupt n ode b cs s1 tr2 s2 \<longrightarrow> Q s2 (tr1 @ tr2))"

subsection \<open>Weakest precondition\<close>

definition wp :: "proc \<Rightarrow> assn \<Rightarrow> assn" where
  "wp c Q = (\<lambda>s tr. \<forall>s' tr'. big_step c s tr' s' \<longrightarrow> Q s' (tr @ tr'))"

lemma wp_Skip: "wp Skip Q = Q"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: skipE)
    using skipB by fastforce
  done

lemma wp_Assign: "wp (var ::= e) Q = (\<lambda>s. Q (s(var := e s)))"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: assignE)
    using assignB by fastforce
  done

lemma wp_Send:
  "wp (Cm (ch[!]e)) Q =
    (\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)]) \<and>
            (\<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) ({ch}, {}), OutBlock ch (e s)])) \<and>
            Q s (tr @ [WaitBlk \<infinity> (\<lambda>_. State s) ({ch}, {})]))"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: sendE)
     apply (simp add: sendB1)
    using sendB2 apply blast
    using sendB3 by blast
  done

lemma wp_Receive:
  "wp (Cm (ch[?]var)) Q =
    (\<lambda>s tr. (\<forall>v. Q (s(var := v)) (tr @ [InBlock ch v])) \<and>
            (\<forall>d::real>0. \<forall>v. Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) ({}, {ch}), InBlock ch v])) \<and>
            Q s (tr @ [WaitBlk \<infinity> (\<lambda>_. State s) ({}, {ch})]))"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: receiveE)
     apply (simp add: receiveB1)
    using receiveB2 apply blast
    using receiveB3 by blast
  done

lemma wp_Seq: "wp (c1; c2) Q = wp c1 (wp c2 Q)"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: seqE)
    using seqB by fastforce
  done

lemma wp_Cond: "wp (Cond b c1 c2) Q = (\<lambda>s. if b s then wp c1 Q s else wp c2 Q s)"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: condE)
    using condB1 condB2 by auto
  done

lemma wp_Wait:
  "wp (Wait e) Q =
    (\<lambda>s tr. if e s > 0 then Q s (tr @ [WaitBlk (e s) (\<lambda>_. State s) ({}, {})]) else Q s tr)"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim!: waitE)
    using waitB1[of e s] waitB2[of e s] apply auto
    by fastforce
  done

lemma wp_IChoice:
  "wp (IChoice c1 c2) Q = (\<lambda>s tr. wp c1 Q s tr \<and> wp c2 Q s tr)"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: ichoiceE)
    by (auto simp add: IChoiceB1 IChoiceB2)
  done

lemma wp_ODE:
  "wp (Cont ode b) Q =
    (\<lambda>s tr. (\<not>b s \<longrightarrow> Q s tr) \<and>
            (\<forall>d p. 0 < d \<longrightarrow> ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow> (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
                   Q (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) ({}, {})])))"
  apply (rule ext) apply (rule ext)
  subgoal for s tr
    apply (auto simp add: wp_def elim: contE)
    apply (auto simp add: ContB2)
    using ContB1[of b s] by fastforce
  done

lemma wp_echoice:
  "wp (EChoice es) R =
    (\<lambda>s tr. (\<forall>i<length es.
      case es ! i of
        (ch[!]e, p2) \<Rightarrow>
          wp p2 R s (tr @ [OutBlock ch (e s)]) \<and>
          (\<forall>d::real>0. wp p2 R s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)]))
      | (ch[?]var, p2) \<Rightarrow>
          (\<forall>v. wp p2 R (s(var := v)) (tr @ [InBlock ch v])) \<and>
          (\<forall>d::real>0. \<forall>v. wp p2 R (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v]))))"
proof -
  have a: "R s' (tr @ tr')" if assms_a:
    "\<forall>i<length es.
       case es ! i of
       (ch[!]e, p2) \<Rightarrow>
         wp p2 R s (tr @ [OutBlock ch (e s)]) \<and>
         (\<forall>d::real>0. wp p2 R s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)]))
       | (ch[?]var, p2) \<Rightarrow>
           (\<forall>v. wp p2 R (s(var := v)) (tr @ [InBlock ch v])) \<and>
           (\<forall>d::real>0. \<forall>v. wp p2 R (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v]))"
    "big_step (EChoice es) s tr' s'" for s s' tr tr'
  proof -
    have a1: "R s' (tr @ OutBlock ch (e s) # tr2)"
      if "i < length es" "es ! i = (ch[!]e, p2)" "big_step p2 s tr2 s'" for ch tr2 i e p2
    proof -
      have "wp p2 R s (tr @ [OutBlock ch (e s)])"
        using assms_a(1) that(1,2) by fastforce
      then show ?thesis
        unfolding wp_def using that(3) by auto
    qed
    have a2: "R s' (tr @ WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es) # OutBlock ch (e s) # tr2)"
      if "0 < (d::real)" "i < length es" "es ! i = (ch[!]e, p2)" "big_step p2 s tr2 s'" for d ch e tr2 i p2
    proof -
      have "wp p2 R s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)])"
        using assms_a(1) that(1-3) by fastforce
      then show ?thesis
        unfolding wp_def using that(4) by auto
    qed
    have a3: "R s' (tr @ InBlock ch v # tr2)"
      if "i < length es" "es ! i = (ch[?]var, p2)" "big_step p2 (s(var := v)) tr2 s'" for ch v tr2 i var p2
    proof -
      have "wp p2 R (s(var := v)) (tr @ [InBlock ch v])"
        using assms_a(1) that(1,2) by fastforce
      then show ?thesis
        unfolding wp_def using that(3) by auto
    qed
    have a4: "R s' (tr @ WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es) # InBlock ch v # tr2)"
      if "0 < (d::real)" "i < length es" "es ! i = (ch[?]var, p2)" "big_step p2 (s(var := v)) tr2 s'" for d ch v tr2 i var p2
    proof -
      have "wp p2 R (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v])"
        using assms_a(1) that(1-3) by fastforce
      then show ?thesis
        unfolding wp_def using that(4) by auto
    qed
    from assms_a(2) show ?thesis
      apply (auto elim!: echoiceE)
      using a1 a2 a3 a4 by auto
  qed
  show ?thesis
    apply (rule ext) apply (rule ext)
    subgoal for s tr
      apply (auto simp add: wp_def)
      subgoal for i cm p2
        apply (cases cm)
        subgoal for ch e
          by (auto simp add: wp_def intro: big_step.intros)
        subgoal for ch var
          by (auto simp add: wp_def intro: big_step.intros)
        done
      subgoal for s' tr'
        using a by auto
      done
    done
qed

lemma wp_interrupt:
  "wp (Interrupt ode b es) R =
    (\<lambda>s tr. (\<forall>i<length es.
      case es ! i of
        (ch[!]e, p2) \<Rightarrow>
          wp p2 R s (tr @ [OutBlock ch (e s)]) \<and>
          (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
             (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
             wp p2 R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es),
                                  OutBlock ch (e (p d))]))
      | (ch[?]var, p2) \<Rightarrow>
          (\<forall>v. wp p2 R (s(var := v)) (tr @ [InBlock ch v])) \<and>
          (\<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
             (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
             wp p2 R ((p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es),
                                              InBlock ch v]))) \<and>
        (\<not>b s \<longrightarrow> R s tr) \<and>
        (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow> p 0 = s \<longrightarrow>
           (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow> \<not>b (p d) \<longrightarrow>
           R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es)])))"
proof -
  have a: "R s tr" if "\<forall>s' tr'. big_step (Interrupt ode b es) s tr' s' \<longrightarrow> R s' (tr @ tr')" "\<not> b s" for s tr
  proof -
    have "big_step (Interrupt ode b es) s [] s"
      using that(2) by (auto intro: big_step.intros)
    then show ?thesis
      using that(1) by fastforce
  qed
  have b: "R s' (tr @ tr')" if assms_b:
    "\<forall>i<length es.
       case es ! i of
       (ch[!]e, p2) \<Rightarrow>
         wp p2 R s (tr @ [OutBlock ch (e s)]) \<and>
         (\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow>
                    p 0 = s \<longrightarrow>
                    (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                    wp p2 R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es), OutBlock ch (e (p d))]))
       | (ch[?]var, p2) \<Rightarrow>
           (\<forall>v. wp p2 R (s(var := v)) (tr @ [InBlock ch v])) \<and>
           (\<forall>d>0. \<forall>p v. ODEsol ode p d \<longrightarrow>
                        p 0 = s \<longrightarrow>
                        (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
                        wp p2 R ((p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es), InBlock ch v]))"
    "\<not> b s \<longrightarrow> R s tr"
    "\<forall>d>0. \<forall>p. ODEsol ode p d \<longrightarrow>
              p 0 = s \<longrightarrow>
              (\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)) \<longrightarrow>
              \<not> b (p d) \<longrightarrow> R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es)])"
    "big_step (Interrupt ode b es) s tr' s'" for s s' tr tr'
  proof -
    have b1: "R s' (tr @ OutBlock ch (e s) # tr2)"
      if "i < length es" "es ! i = (ch[!]e, p2)" "big_step p2 s tr2 s'" for ch e tr2 i p2
    proof -
      have "wp p2 R s (tr @ [OutBlock ch (e s)])"
        using assms_b(1) that(1,2) by fastforce
      then show ?thesis
        unfolding wp_def using that(3) by auto
    qed
    have b2: "R s' (tr @ WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es) # OutBlock ch (e (p d)) # tr2)"
      if "0 < d" "ODEsol ode p d" "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)" "i < length es" "es ! i = (ch[!]e, p2)"
         "big_step p2 (p d) tr2 s'" "s = p 0" for ch e p d tr2 p2 i
    proof -
      have "wp p2 R (p d) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es), OutBlock ch (e (p d))])"
        using assms_b(1) that(1-5,7) by fastforce
      then show ?thesis
        unfolding wp_def using that(6) by auto
    qed
    have b3: "R s' (tr @ InBlock ch v # tr2)"
      if "i < length es" "es ! i = (ch[?]var, p2)" "big_step p2 (s(var := v)) tr2 s'" for ch v tr2 i var p2
    proof -
      have "wp p2 R (s(var := v)) (tr @ [InBlock ch v])"
        using assms_b(1) that(1,2) by fastforce
      then show ?thesis
        unfolding wp_def using that(3) by auto
    qed
    have b4: "R s' (tr @ WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es) # InBlock ch v # tr2)"
      if "0 < d" "ODEsol ode p d" "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> b (p t)" "i < length es" "es ! i = (ch[?]var, p2)"
       "big_step p2 ((p d)(var := v)) tr2 s'" "s = p 0" for d ch v tr2 i var p2 p
    proof -
      have "wp p2 R ((p d)(var := v)) (tr @ [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) (rdy_of_echoice es), InBlock ch v])"
        using assms_b(1) that(1-5,7) by fastforce
      then show ?thesis
        unfolding wp_def using that(6) by auto
    qed
    from assms_b(4) show ?thesis
      apply (auto elim!: interruptE)
      using b1 b2 b3 b4 assms_b(2,3) by auto
  qed
  show ?thesis
    apply (rule ext) apply (rule ext)
    subgoal for s tr
      apply (auto simp add: wp_def)
      subgoal for i cm p2
        apply (cases cm)
        subgoal for ch e
          by (auto simp add: wp_def intro: big_step.intros)
        subgoal for ch var
          by (auto simp add: wp_def intro: big_step.intros)
        done
      subgoal by (rule a)
      subgoal using InterruptB2 by blast
      subgoal for s' tr' using b by blast
      subgoal for s' tr' using b by blast
      done
    done
qed

lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
proof (induction c arbitrary: Q)
  case (Cm cm)
  then show ?case
  proof (cases cm)
    case (Send ch e)
    show ?thesis
      unfolding Send wp_Send
      by (rule SendH)
  next
    case (Receive ch v)
    show ?thesis
      unfolding Receive wp_Receive
      by (rule ReceiveH)
  qed
next
  case Skip
  then show ?case
    unfolding wp_Skip by (rule SkipH)
next
  case (Assign v e)
  then show ?case
    unfolding wp_Assign by (rule AssignH)
next
  case (Seq c1 c2)
  then show ?case
    unfolding wp_Seq by (rule SeqH)
next
  case (Cond x1a c1 c2)
  then show ?case
    unfolding wp_Cond by (rule CondH)
next
  case (Wait e)
  then show ?case
    unfolding wp_Wait by (rule WaitH)
next
  case (IChoice c1 c2)
  then show ?case
    unfolding wp_IChoice by (rule IChoiceH)
next
  case (EChoice es)
  show ?case
    unfolding wp_echoice
    apply (rule EChoiceH4)
    apply (rule big_step_echoice_provable)
    using EChoice by auto
next
  case (Rep c)
  show ?case
    apply (rule ConseqH[where P="wp (Rep c) Q" and Q="wp (Rep c) Q"])
    subgoal by simp
    subgoal unfolding entails_def wp_def apply auto
      using RepetitionB1 by fastforce
    apply (rule RepH)
    apply (rule ConseqH[where Q="wp (Rep c) Q"])
      prefer 2 apply simp
     prefer 2 apply (rule Rep)
    unfolding entails_def wp_def apply auto
    subgoal for s1 tr1 s2 tr2 s3 tr3
      using RepetitionB2 by auto
    done
next
  case (Cont ode b)
  then show ?case
    unfolding wp_ODE by (rule ContH)
next
  case (Interrupt ode b es)
  show ?case
    unfolding wp_interrupt
    apply (rule InterruptH4)
    apply (rule big_step_interrupt_provable)
    using Interrupt by auto
qed

theorem hoare_complete:
  "\<Turnstile> {P} c {Q} \<Longrightarrow> \<turnstile> {P} c {Q}"
  apply (rule ConseqH[where P="wp c Q" and Q=Q])
    apply (auto simp add: entails_def)
   apply (auto simp add: Valid_def wp_def)[1]
  by (rule wp_is_pre)

theorem hoare_sound_complete:
  "\<turnstile> {P} c {Q} \<longleftrightarrow> \<Turnstile> {P} c {Q}"
  using hoare_sound hoare_complete by auto

subsection \<open>Completeness for parallel programs\<close>

inductive par_hoare :: "gs_assn \<Rightarrow> pproc \<Rightarrow> gassn \<Rightarrow> bool" ("\<turnstile>\<^sub>p ({(1_)}/ (_)/ {(1_)})" 50) where
  "\<turnstile> {\<lambda>s tr. P s \<and> tr = []} c {Q} \<Longrightarrow>
   \<turnstile>\<^sub>p {sing_assn P} (Single c) {sing_gassn Q}"
| "\<turnstile>\<^sub>p {P1} p1 {Q1} \<Longrightarrow> \<turnstile>\<^sub>p {P2} p2 {Q2} \<Longrightarrow>
   \<turnstile>\<^sub>p {par_assn P1 P2} (Parallel p1 chs p2) {sync_gassn chs Q1 Q2}"
| "\<turnstile>\<^sub>p {P} c {Q} \<Longrightarrow> \<forall>s. P' s \<longrightarrow> P s \<Longrightarrow> \<forall>s tr. Q s tr \<longrightarrow> Q' s tr \<Longrightarrow>
   \<turnstile>\<^sub>p {P'} c {Q'}"

theorem par_hoare_sound:
  "\<turnstile>\<^sub>p {P} c {Q} \<Longrightarrow> \<Turnstile>\<^sub>p {P} c {Q}"
proof (induction rule: par_hoare.induct)
  case (1 P c Q)
  show ?case
    apply (rule ParValid_Single)
    using hoare_sound_complete 1 by auto
next
  case (2 P1 p1 Q1 P2 p2 Q2 chs)
  show ?case
    apply (rule ParValid_Parallel)
    using 2 by auto
next
  case (3 P c Q P' Q')
  then show ?case
    unfolding ParValid_def by auto
qed

lemma ParValid_to_Valid:
  assumes "\<Turnstile>\<^sub>p {sing_assn P} Single c {sing_gassn Q}"
  shows "\<Turnstile> {\<lambda>s tr. P s \<and> tr = []} c {Q}"
  using assms unfolding Valid_def ParValid_def
  using SingleB by force

definition sp :: "proc \<Rightarrow> fform \<Rightarrow> assn" where
  "sp c P = (\<lambda>s' tr. \<exists>s. P s \<and> big_step c s tr s')"

lemma Valid_sp:
  "\<Turnstile> {\<lambda>s tr. P s \<and> tr = []} c {sp c P}"
  unfolding Valid_def sp_def by auto

definition par_sp :: "pproc \<Rightarrow> gs_assn \<Rightarrow> gassn" where
  "par_sp c P = (\<lambda>s' tr'. \<exists>s. P s \<and> par_big_step c s tr' s')"

lemma par_sp_single:
  "par_sp (Single c) (sing_assn P) = sing_gassn (sp c P)"
  unfolding par_sp_def apply (rule ext) apply (rule ext)
  subgoal for s' tr'
    apply (cases s')
    subgoal for s1
      apply (auto simp add: sp_def)
      using SingleE apply fastforce
      using SingleB sing_assn.simps(1) by blast
    subgoal for s1 s2
      using SingleE by fastforce
    done
  done

lemma par_sp_parallel:
  "par_sp (Parallel p1 chs p2) (par_assn P1 P2) =
   sync_gassn chs (par_sp p1 P1) (par_sp p2 P2)"
  unfolding par_sp_def apply (rule ext) apply (rule ext)
  subgoal for s' tr'
    apply (cases s')
    subgoal for s1
      using ParallelE by fastforce
    subgoal for s1 s2
      apply auto
      subgoal apply (elim ParallelE) by auto
      using ParallelB by force
    done
  done

inductive wf_pre :: "pproc \<Rightarrow> gs_assn \<Rightarrow> bool" where
  "wf_pre (Single c) (sing_assn P)"
| "wf_pre p1 P1 \<Longrightarrow> wf_pre p2 P2 \<Longrightarrow> wf_pre (Parallel p1 chs p2) (par_assn P1 P2)"

inductive_cases wf_pre_Single: "wf_pre (Single c) P"
inductive_cases wf_pre_Parallel: "wf_pre (Parallel p1 chs p2) P"

lemma par_sp_is_post: "wf_pre c P \<Longrightarrow> \<turnstile>\<^sub>p {P} c {par_sp c P}"
proof (induction c arbitrary: P)
  case (Single p)
  then show ?case
    apply (elim wf_pre_Single)
    apply (auto simp add: par_sp_single)
    apply (rule par_hoare.intros(1))
    apply (rule hoare_complete)
    by (rule Valid_sp)
next
  case (Parallel p1 chs p2)
  show ?case
    using Parallel(3) apply (elim wf_pre_Parallel)
    apply (auto simp add: par_sp_parallel)
    apply (rule par_hoare.intros(2))
    using Parallel(1,2) by auto
qed

theorem par_hoare_complete:
  "wf_pre c P \<Longrightarrow> \<Turnstile>\<^sub>p {P} c {Q} \<Longrightarrow> \<turnstile>\<^sub>p {P} c {Q}"
  apply (rule par_hoare.intros(3))
  apply (rule par_sp_is_post)
    apply assumption
   apply simp
  using ParValid_def par_sp_def by auto

theorem par_hoare_sound_complete:
  assumes "wf_pre c P"
  shows "\<turnstile>\<^sub>p {P} c {Q} \<longleftrightarrow> \<Turnstile>\<^sub>p {P} c {Q}"
  using par_hoare_sound par_hoare_complete assms by auto

end


theory RelyGuarantee
  imports HoareLogic
begin

class rg_algebra = ckat +
  fixes I :: "'a set"
  assumes inv_def: "r \<in> I \<longleftrightarrow>  1 \<le> r \<and> r \<parallel> r = r \<and> r\<parallel>(x\<cdot>y) \<le> (r\<parallel>x)\<cdot>(r\<parallel>y) \<and> (r\<parallel>x)\<^sup>+ = r\<parallel>x\<^sup>+"
  and inv_add_closed: "\<lbrakk>r \<in> I; s \<in> I\<rbrakk> \<Longrightarrow> (r+s) \<in> I"
  and inv_mult_closed: "\<lbrakk>r \<in> I; s \<in> I\<rbrakk> \<Longrightarrow> (r\<cdot>s) \<in> I"
  and inv_par_closed: "\<lbrakk>r \<in> I; s \<in> I\<rbrakk> \<Longrightarrow> (r\<parallel>s) \<in> I"
begin

definition guarantee_relation :: "'a \<Rightarrow> 'a \<Rightarrow> bool" ("_ guar _" [99, 99] 100) where
  "b guar g \<equiv> g \<in> I \<and> b \<le> g"

definition jones_quintuples :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("\<lbrace>_,_\<rbrace>_\<lbrace>_,_\<rbrace>") where
  "\<lbrace>a, r\<rbrace> b \<lbrace>c, g\<rbrace> \<equiv> \<lbrace>a\<rbrace> r\<parallel>b \<lbrace>c\<rbrace> \<and> r \<in> I \<and> b guar g"

lemma inv_refl: "r \<in> I \<Longrightarrow> 1 \<le> r"
  by (metis inv_def)

lemma inv_unit: "1 \<in> I"
  by (metis eq_refl inv_def par_unitl)

lemma inv_idem_mult: "r \<in> I \<Longrightarrow> r\<cdot>r = r"
  by (metis boffa_var inv_def less_eq_def mult_incl sup_id_star1)

lemma inv_idem_par : "r \<in> I \<Longrightarrow> r \<parallel> r = r"
  by (metis inv_def)

lemma inv_exchange: "r \<in> I \<Longrightarrow> r\<parallel>(x\<cdot>y) = (r\<parallel>x)\<cdot>(r\<parallel>y)"
  by (smt eq_iff exchange inv_def inv_idem_mult)

lemma guar_par: "\<lbrakk>b guar g; b' guar g'\<rbrakk> \<Longrightarrow> (b \<parallel> b') guar (g \<parallel> g')"
  by (metis guarantee_relation_def inv_par_closed par_double_iso)

theorem paralel_composition_basic:
  assumes "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "\<lbrace>p, r\<rbrace> y \<lbrace>q, g\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x\<parallel>y \<lbrace>q, g\<rbrace>"
proof -
  have guar: "x\<parallel>y \<le> g"
    by (metis (full_types) assms(1) assms(2) par_isol par_isor guarantee_relation_def inv_idem_par jones_quintuples_def order_trans)
  have a: "p\<cdot>(r\<parallel>(x\<parallel>y)) = p\<cdot>((r\<parallel>x)\<parallel>(r\<parallel>y))"
    by (metis assms(1) inv_idem_par jones_quintuples_def par_assoc par_comml)
  also have b: "... = (p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y))"
    by (metis assms(1) hoare_triple_def jones_quintuples_def test_assocl)
  also have "... = (p\<cdot>(r\<parallel>x)\<cdot>q)\<parallel>(p\<cdot>(r\<parallel>y)\<cdot>q)"
    by (metis assms(1) assms(2) hoare_triple_def jones_quintuples_def)
  also have "... = ((p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y)))\<cdot>q"
    by (metis assms(2) hoare_triple_def jones_quintuples_def test_assocr)
  also have "... = p\<cdot>(r\<parallel>(x\<parallel>y))\<cdot>q"
    by (metis a b)
  finally show ?thesis
    by (metis assms(2) guar guarantee_relation_def hoare_triple_def jones_quintuples_def)
qed

theorem paralel_composition_post:
  assumes "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "\<lbrace>p, r\<rbrace> y \<lbrace>q', g\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x\<parallel>y \<lbrace>q + q', g\<rbrace>"
proof -
  have guar: "x\<parallel>y \<le> g"
    by (metis (full_types) assms(1) assms(2) par_isol par_isor guarantee_relation_def inv_idem_par jones_quintuples_def order_trans)
  have a: "p\<cdot>(r\<parallel>(x\<parallel>y)) = p\<cdot>((r\<parallel>x)\<parallel>(r\<parallel>y))"
    by (metis assms(1) inv_idem_par jones_quintuples_def par_assoc par_comml)
  also have b: "... = (p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y))"
    by (metis assms(1) hoare_triple_def jones_quintuples_def test_assocl)
  also have "... = (p\<cdot>(r\<parallel>x)\<cdot>q)\<parallel>(p\<cdot>(r\<parallel>y)\<cdot>q')"
    by (metis assms(1) assms(2) hoare_triple_def jones_quintuples_def)
  also have "... \<le> (p\<cdot>(r\<parallel>x)\<cdot>(q + q'))\<parallel>(p\<cdot>(r\<parallel>y)\<cdot>(q + q'))"
    by (metis add_ub2 mult_isol par_double_iso subdistl)
  also have "... = ((p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y)))\<cdot>(q + q')"
    by (metis assms(1) assms(2) b hoare_equiv jones_quintuples_def test_add_closed test_assocr)
  also have "... = p\<cdot>(r\<parallel>(x\<parallel>y))\<cdot>(q + q')"
    by (metis a b)
  finally show ?thesis
    by (metis assms hoare_equiv guar guarantee_relation_def jones_quintuples_def test_add_closed)
qed

theorem paralel_composition_post_guar:
  assumes "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "\<lbrace>p, r\<rbrace> y \<lbrace>q', g'\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x\<parallel>y \<lbrace>q + q', g\<parallel>g'\<rbrace>"
proof -
  have guar: "x\<parallel>y \<le> g\<parallel>g'"
   by (metis (full_types) assms(1) assms(2) par_isol par_isor guarantee_relation_def jones_quintuples_def order_trans)
  have a: "p\<cdot>(r\<parallel>(x\<parallel>y)) = p\<cdot>((r\<parallel>x)\<parallel>(r\<parallel>y))"
    by (metis assms(1) inv_idem_par jones_quintuples_def par_assoc par_comml)
  also have b: "... = (p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y))"
    by (metis assms(1) hoare_triple_def jones_quintuples_def test_assocl)
  also have "... = (p\<cdot>(r\<parallel>x)\<cdot>q)\<parallel>(p\<cdot>(r\<parallel>y)\<cdot>q')"
    by (metis assms(1) assms(2) hoare_triple_def jones_quintuples_def)
  also have "... \<le> (p\<cdot>(r\<parallel>x)\<cdot>(q + q'))\<parallel>(p\<cdot>(r\<parallel>y)\<cdot>(q + q'))"
    by (metis add_ub2 mult_isol par_double_iso subdistl)
  also have "... = ((p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y)))\<cdot>(q + q')"
    by (metis assms(1) assms(2) b hoare_equiv jones_quintuples_def test_add_closed test_assocr)
  also have "... = p\<cdot>(r\<parallel>(x\<parallel>y))\<cdot>(q + q')"
    by (metis a b)
  finally show ?thesis
    by (metis assms hoare_equiv guar guarantee_relation_def jones_quintuples_def test_add_closed inv_par_closed)
qed

theorem paralel_composition_post_par:
  assumes "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "\<lbrace>p, r\<rbrace> y \<lbrace>q', g'\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x\<parallel>y \<lbrace>q\<parallel>q', g\<parallel>g'\<rbrace>"
proof -
  have guar: "x\<parallel>y \<le> g\<parallel>g'"
   by (metis (full_types) assms(1) assms(2) par_isol par_isor guarantee_relation_def jones_quintuples_def order_trans)
  have a: "p\<cdot>(r\<parallel>(x\<parallel>y)) = p\<cdot>((r\<parallel>x)\<parallel>(r\<parallel>y))"
    by (metis assms(1) inv_idem_par jones_quintuples_def par_assoc par_comml)
  also have b: "... = (p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y))"
    by (metis assms(1) hoare_triple_def jones_quintuples_def test_assocl)
  also have "... =((p\<cdot>(r\<parallel>x))\<cdot>q)\<parallel>((p\<cdot>(r\<parallel>y))\<cdot>q')"
    by (metis assms(1) assms(2) hoare_triple_def jones_quintuples_def)
  also have "... = ((p\<cdot>(r\<parallel>x))\<parallel>(p\<cdot>(r\<parallel>y)))\<cdot>(q\<parallel>q')"
    by (metis assms(1) assms(2) test_exchanger hoare_triple_def jones_quintuples_def)
  also have "... = p\<cdot>(r\<parallel>(x\<parallel>y))\<cdot>(q\<parallel>q')"
    by (metis a b)
  finally show ?thesis
    by (metis assms hoare_triple_def guar guarantee_relation_def jones_quintuples_def test_par_closed inv_par_closed)
qed

lemma consequence_rule_pre:
  assumes "p' \<le> p" and "p' \<in> B" and "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>"
  shows "\<lbrace>p', r\<rbrace> x \<lbrace>q, g\<rbrace>"
  by (metis assms(1) assms(2) assms(3) jones_quintuples_def weakening_rule)

lemma consequence_rule_rely:
  assumes "r' \<le> r" and "r' \<in> I" and "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "r\<parallel>x \<le> x"
  shows "\<lbrace>p, r'\<rbrace> x \<lbrace>q, g\<rbrace>"
  by (metis antisym assms(1) assms(2) assms(3) assms(4) inv_refl jones_quintuples_def less_eq_def par_subdistl par_unitl)

lemma consequence_rule_guar:
  assumes "g \<le> g'" and "g' \<in> I" and "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "g\<parallel>x \<le> x"
  shows "\<lbrace>p, r\<rbrace> x \<lbrace>q, g'\<rbrace>"
  by (metis (full_types) assms(1) assms(2) assms(3) guarantee_relation_def jones_quintuples_def order_trans)

lemma consequence_rule_post:
  assumes "q \<le> q'" and "q' \<in> B" and "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x \<lbrace>q', g\<rbrace>"
  by (metis assms(1) assms(2) assms(3) jones_quintuples_def weakening_rule2)

theorem consequence_rule:
  assumes "p' \<le> p" "r' \<le> r" "g \<le> g'" "q \<le> q'" "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" "p' \<in> B" "r' \<in> I" "g' \<in> I" "q' \<in> B" "r\<parallel>x \<le> x" "g\<parallel>x \<le> x"
  shows "\<lbrace>p', r'\<rbrace> x \<lbrace>q', g'\<rbrace>"
  by (metis assms consequence_rule_pre consequence_rule_rely consequence_rule_guar consequence_rule_post)

theorem sequential_composition:
  assumes a: "\<lbrace>p, r\<rbrace> x \<lbrace>m, g\<rbrace>" and b: "\<lbrace>m, r\<rbrace> y \<lbrace>q, g\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x\<cdot>y \<lbrace>q, g\<rbrace>"
proof -
  have "x \<le> g \<and> y \<le> g"
    by (metis a b guarantee_relation_def jones_quintuples_def)
  also have "x\<cdot>y \<le> g\<cdot>g"
    by (metis calculation mult_isol mult_isor order_trans)
  ultimately have c: "x\<cdot>y \<le> g"
    by (metis (full_types) b guarantee_relation_def inv_idem_mult jones_quintuples_def)
  have d: "p\<cdot>((x\<cdot>y)\<parallel>r) = p\<cdot>(x\<parallel>r)\<cdot>(y\<parallel>r)"
    by (metis b par_comm inv_exchange jones_quintuples_def mult_assoc)
  also have e: "... = p\<cdot>(x\<parallel>r)\<cdot>m\<cdot>(y\<parallel>r)"
    by (metis a par_comm hoare_triple_def jones_quintuples_def)
  also have "... = p\<cdot>(x\<parallel>r)\<cdot>m\<cdot>(y\<parallel>r)\<cdot>q"
    by (metis b par_comm mult_assoc hoare_triple_def jones_quintuples_def)
  also have "... = p\<cdot>((x\<cdot>y)\<parallel>r)\<cdot>q"
    by (metis d e)
  finally show ?thesis
    by (metis a b c par_comm guarantee_relation_def hoare_triple_def jones_quintuples_def)
qed

theorem rg_one: "\<lbrace>p, r\<rbrace> 1 \<lbrace>q, g\<rbrace> \<longleftrightarrow> \<lbrace>p\<rbrace> r \<lbrace>q\<rbrace> \<and> r \<in> I \<and> g \<in> I"
  by (metis guarantee_relation_def inv_refl jones_quintuples_def par_unitr)

theorem rg_add:
  assumes "\<lbrace>p, r\<rbrace> x \<lbrace>q, g\<rbrace>" and "\<lbrace>p, r\<rbrace> y \<lbrace>q, g\<rbrace>"
  shows "\<lbrace>p, r\<rbrace> x + y \<lbrace>q, g\<rbrace>"
proof -
  have "p\<cdot>(r\<parallel>(x + y)) = p\<cdot>(r\<parallel>x) + p\<cdot>(r\<parallel>y)"
    by (metis distrib_left par_distl)
  also have "... = p\<cdot>(r\<parallel>x)\<cdot>q + p\<cdot>(r\<parallel>y)\<cdot>q"
    by (metis assms hoare_triple_def jones_quintuples_def)
  also have "... = p\<cdot>(r\<parallel>(x + y))\<cdot>q"
    by (metis distrib_left distrib_right par_distl)
  finally show ?thesis
    by (metis add_lub assms(1) assms(2) guarantee_relation_def hoare_triple_def jones_quintuples_def)
qed

lemma one_transcl: "1\<^sup>+ = 1"
  by (metis mult_1_right star_one star_trancl)

lemma inv_plus_eq: "r \<in> I \<Longrightarrow> r = r\<^sup>+"
  by (metis par_comm par_unitl inv_def one_transcl)

lemma inv_def_var: "r \<in> I \<Longrightarrow> (r\<parallel>x)\<^sup>+ = r\<parallel>x\<^sup>+"
  by (metis inv_def)

lemma guar_transcl: "b guar g \<Longrightarrow> b\<^sup>+ guar g"
  by (metis add_lub guarantee_relation_def inv_def inv_idem_mult less_eq_def star_slide_var star_subdist_var star_trancl star_unfoldl_eq tc)

theorem rg_transcl: "\<lbrace>p, r\<rbrace> x \<lbrace>p, g\<rbrace> \<Longrightarrow> \<lbrace>p, r\<rbrace> x\<^sup>+ \<lbrace>p, g\<rbrace>"
  by (metis (full_types) guar_transcl inv_def iteration2 jones_quintuples_def)

theorem rg_star: "\<lbrakk>\<lbrace>p\<rbrace> r \<lbrace>p\<rbrace>; \<lbrace>p, r\<rbrace> x \<lbrace>p, g\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>p, r\<rbrace> x\<^sup>\<star> \<lbrace>p, g\<rbrace>"
  by (metis star_trancl2 guarantee_relation_def jones_quintuples_def rg_add rg_one rg_transcl)

end

end


theory weird_nat_mul3_assoc2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

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

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

(*hipster add3 mul3 *)

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

end


theory NumberWang_IPv6
imports
  Word_Lib.Word_Lemmas
  Word_Lib.Word_Syntax
  Word_Lib.Reversed_Bit_Lists
begin

section\<open>Helper Lemmas for Low-Level Operations on Machine Words\<close>
text\<open>Needed for IPv6 Syntax\<close>

lemma length_drop_bl: "length (dropWhile Not (to_bl (of_bl bs))) \<le> length bs"
proof -
  have length_takeWhile_Not_replicate_False:
    "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
  for n ls by(subst takeWhile_append2) simp+
  show ?thesis by(simp add: word_rep_drop dropWhile_eq_drop length_takeWhile_Not_replicate_False)
qed

lemma bl_drop_leading_zeros:
      "(of_bl:: bool list \<Rightarrow> 'a::len word) (dropWhile Not bs) =
       (of_bl:: bool list \<Rightarrow> 'a::len word) bs"
by(induction bs) simp_all

lemma bl_length_drop_bound: assumes "length (dropWhile Not bs) \<le> n"
  shows "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs))) \<le> n"
proof -
  have bl_length_drop_twice:
      "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) (dropWhile Not bs)))) =
       length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs)))"
    by(simp add: bl_drop_leading_zeros)
  from length_drop_bl
  have *: "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs))) \<le> length (dropWhile Not bs)"
   apply(rule dual_order.trans)
   apply(subst bl_length_drop_twice)
   ..
  show ?thesis
  apply(rule order.trans, rule *)
  using assms by(simp)
qed

lemma length_drop_mask_outer: fixes ip::"'a::len word"
  shows "LENGTH('a) - n' = len \<Longrightarrow> length (dropWhile Not (to_bl (ip AND (mask n << n') >> n'))) \<le> len"
  apply(subst word_and_mask_shiftl)
  apply(subst shiftl_shiftr1)
   apply(simp; fail)
  apply(simp)
  apply(subst and_mask)
  apply(simp add: word_size)
  apply(simp add: length_drop_mask)
  done
lemma length_drop_mask_inner: fixes ip::"'a::len word"
  shows "n \<le> LENGTH('a) - n' \<Longrightarrow> length (dropWhile Not (to_bl (ip AND (mask n << n') >> n'))) \<le> n"
  apply(subst word_and_mask_shiftl)
  apply(subst shiftl_shiftr3)
   apply(simp; fail)
  apply(simp)
  apply(simp add: word_size)
  apply(simp add: mask_twice)
  apply(simp add: length_drop_mask)
  done

lemma mask128: "0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF = (mask 128 :: 'a::len word)"
  by (simp add: mask_eq push_bit_of_1)

(*-------------- things for ipv6 syntax round trip property two ------------------*)

(*n small, m large*)
lemma helper_masked_ucast_generic:
  fixes b::"16 word"
  assumes "n + 16 \<le> m" and "m < 128"
  shows "((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << m) = 0"
proof -
  have "x < 2 ^ (m - n)" if mnh2: "x < 0x10000"
    for x::"128 word"
  proof -
    from assms(1) have mnh3: "16 \<le> m - n" by fastforce
    have power_2_16_nat: "(16::nat) \<le> n \<Longrightarrow> (65535::nat) < 2 ^ n" if a:"16 \<le> n"for n
    proof -
      have power2_rule: "a \<le> b \<Longrightarrow> (2::nat)^a \<le> 2 ^ b" for a b by fastforce
      show ?thesis
       apply(subgoal_tac "65536 \<le> 2 ^ n")
        apply(subst Nat.less_eq_Suc_le)
        apply(simp; fail)
       apply(subgoal_tac "(65536::nat) = 2^16")
        subgoal using power2_rule \<open>16 \<le> n\<close> by presburger
       by(simp)
    qed
    have "65536 = unat (65536::128 word)" by auto
    moreover from mnh2 have "unat x <  unat (65536::128 word)" by(rule Word.unat_mono)
    ultimately have x: "unat x < 65536" by simp
    with mnh3 have "unat x < 2 ^ (m - n)"
      using power_2_16_nat [of \<open>m - n\<close>] by simp
    with assms(2) show ?thesis by(subst word_less_nat_alt) simp
  qed
  hence mnhelper2: "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) < 2 ^ (m - n)"
    apply(subgoal_tac "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) < 2^(LENGTH(16))")
     apply(simp; fail)
    by(rule of_bl_length_less) simp+
  have mnhelper3: "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) * 2 ^ n < 2 ^ m"
    apply(rule div_lt_mult)
     apply(rule word_less_two_pow_divI)
       using assms by(simp_all add: mnhelper2 p2_gt_0)

  from assms show ?thesis
    apply(subst ucast_bl)+
    apply(subst shiftl_of_bl)
    apply(subst of_bl_append)
    apply simp
    apply(subst word_and_mask_shiftl)
    apply(subst shiftr_div_2n_w)
     subgoal by(simp add: word_size; fail)
    apply(subst word_div_less)
     subgoal by(rule mnhelper3)
    apply simp
    done
qed

lemma unat_of_bl_128_16_less_helper:
  fixes b::"16 word"
  shows "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2^16"
proof -
  from word_bl_Rep' have 1: "length (to_bl b) = 16" by simp
  have "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2^(length (to_bl b))"
    by(fact unat_of_bl_length)
  with 1 show ?thesis by auto
qed
lemma unat_of_bl_128_16_le_helper: "unat ((of_bl:: bool list \<Rightarrow> 128 word) (to_bl (b::16 word))) \<le> 65535"
proof -
  from unat_of_bl_128_16_less_helper[of b] have
    "unat ((of_bl:: bool list \<Rightarrow> 128 word) (to_bl b)) < 65536" by simp
  from Suc_leI[OF this] show ?thesis by simp
qed

(*reverse*)
 lemma helper_masked_ucast_reverse_generic:
   fixes b::"16 word"
   assumes "m + 16 \<le> n" and "n \<le> 128 - 16"
   shows "((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << m) = 0"
 proof -

   have power_less_128_helper: "2 ^ n * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2 ^ LENGTH(128)"
     if n: "n \<le> 128 - 16" for n
   proof -
     have help_mult: "n \<le> l \<Longrightarrow> 2 ^ n * x < 2 ^ l \<longleftrightarrow> x < 2 ^ (l - n)" for x::nat and l
       by (simp add: nat_mult_power_less_eq semiring_normalization_rules(7))
     from n show ?thesis
       apply(subst help_mult)
        subgoal by (simp)
       apply(rule order_less_le_trans)
        apply(rule unat_of_bl_128_16_less_helper)
       apply(rule Power.power_increasing)
        apply(simp_all)
       done
   qed

   have *: "2 ^ m * (2 ^ (n - m) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b))) =
            2 ^ n * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b))"
   proof(cases "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) = 0")
   case True thus ?thesis by simp
   next
   case False
    have help_mult: "x \<noteq> 0 \<Longrightarrow> b * (c * x) = a * (x::nat)  \<longleftrightarrow> b * c = a" for x a b c by simp
    from assms show ?thesis
     apply(subst help_mult[OF False])
     apply(subst Power.monoid_mult_class.power_add[symmetric])
     apply(simp)
     done
   qed

  from assms have "unat ((2 ^ n)::128 word) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128) =
        2 ^ m * (2 ^ (n - m) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128))"
     apply(subst nat_mod_eq')
      subgoal apply(subst unat_power_lower)
       subgoal by(simp; fail)
      subgoal by (rule power_less_128_helper) simp
      done
     apply(subst nat_mod_eq')
      subgoal by(rule power_less_128_helper) simp
     apply(subst unat_power_lower)
      apply(simp; fail)
     apply(simp only: *)
     done
   hence ex_k: "\<exists>k. unat ((2 ^ n)::128 word) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128) = 2 ^ m * k"
     by blast

   hence aligned: "is_aligned ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b) << n) m"
     unfolding is_aligned_iff_dvd_nat
     unfolding dvd_def
     unfolding shiftl_t2n
     unfolding Word.unat_word_ariths(2)
     by assumption

   from assms have of_bl_to_bl_shift_mask: "((of_bl::bool list \<Rightarrow> 128 word) (to_bl b) << n) && mask (16 + m) = 0"
    using is_aligned_mask is_aligned_shiftl by force (*sledgehammer*)

   show ?thesis
    apply(subst ucast_bl)+
    apply(subst word_and_mask_shiftl)
    apply(subst aligned_shiftr_mask_shiftl)
     subgoal by (fact aligned)
    subgoal by (fact of_bl_to_bl_shift_mask)
    done
qed

lemma helper_masked_ucast_equal_generic:
  fixes b::"16 word"
  assumes "n \<le> 128 - 16"
  shows "ucast (((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << n) >> n) = b"
proof -
  have ucast_mask: "(ucast:: 16 word \<Rightarrow> 128 word) b && mask 16 = ucast b"
    by transfer (simp flip: take_bit_eq_mask)
  from assms have "ucast (((ucast:: 16 word \<Rightarrow> 128 word) b && mask (128 - n) && mask 16) && mask (128 - n)) = b"
    by (auto simp add: bit_simps word_size intro!: bit_word_eqI)
  thus ?thesis
  apply(subst word_and_mask_shiftl)
  apply(subst shiftl_shiftr3)
   apply(simp; fail)
  apply(simp)
  apply(subst shiftl_shiftr3)
    apply(simp_all add: word_size and.assoc)
  done
qed

end