(*  Title:      HOL/HOLCF/IOA/NTP/Sender.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section {* The implementation: sender *}

theory Sender
imports IOA Action
begin

type_synonym
'm sender_state = "'m list * bool multiset * bool multiset * bool * bool"
(*                messages   #sent           #received      header  mode *)

definition sq :: "'m sender_state => 'm list" where "sq = fst"
definition ssent :: "'m sender_state => bool multiset" where "ssent = fst o snd"
definition srcvd :: "'m sender_state => bool multiset" where "srcvd = fst o snd o snd"
definition sbit :: "'m sender_state => bool" where "sbit = fst o snd o snd o snd"
definition ssending :: "'m sender_state => bool" where "ssending = snd o snd o snd o snd"

definition
  sender_asig :: "'m action signature" where
  "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
                   UN pkt. {S_pkt(pkt)},
                   {C_m_s,C_r_s})"

definition
  sender_trans :: "('m action, 'm sender_state)transition set" where
  "sender_trans =
 {tr. let s = fst(tr);
          t = snd(snd(tr))
      in case fst(snd(tr))
      of
      S_msg(m) => sq(t)=sq(s)@[m]   &
                  ssent(t)=ssent(s) &
                  srcvd(t)=srcvd(s) &
                  sbit(t)=sbit(s)   &
                  ssending(t)=ssending(s) |
      R_msg(m) => False |
      S_pkt(pkt) => hdr(pkt) = sbit(s)      &
                       (? Q. sq(s) = (msg(pkt)#Q))  &
                       sq(t) = sq(s)           &
                       ssent(t) = addm (ssent s) (sbit s) &
                       srcvd(t) = srcvd(s) &
                       sbit(t) = sbit(s)   &
                       ssending(s)         &
                       ssending(t) |
    R_pkt(pkt) => False |
    S_ack(b)   => False |
      R_ack(b) => sq(t)=sq(s)                  &
                     ssent(t)=ssent(s)            &
                     srcvd(t) = addm (srcvd s) b  &
                     sbit(t)=sbit(s)              &
                     ssending(t)=ssending(s) |
      C_m_s => count (ssent s) (~sbit s) < count (srcvd s) (~sbit s) &
               sq(t)=sq(s)       &
               ssent(t)=ssent(s) &
               srcvd(t)=srcvd(s) &
               sbit(t)=sbit(s)   &
               ssending(s)       &
               ~ssending(t) |
      C_m_r => False |
      C_r_s => count (ssent s) (sbit s) <= count (srcvd s) (~sbit s) &
               sq(t)=tl(sq(s))      &
               ssent(t)=ssent(s)    &
               srcvd(t)=srcvd(s)    &
               sbit(t) = (~sbit(s)) &
               ~ssending(s)         &
               ssending(t) |
      C_r_r(m) => False}"

definition
  sender_ioa :: "('m action, 'm sender_state)ioa" where
  "sender_ioa =
   (sender_asig, {([],{|},{|},False,True)}, sender_trans,{},{})"

lemma in_sender_asig:
  "S_msg(m) : actions(sender_asig)"
  "R_msg(m) ~: actions(sender_asig)"
  "S_pkt(pkt) : actions(sender_asig)"
  "R_pkt(pkt) ~: actions(sender_asig)"
  "S_ack(b) ~: actions(sender_asig)"
  "R_ack(b) : actions(sender_asig)"
  "C_m_s : actions(sender_asig)"
  "C_m_r ~: actions(sender_asig)"
  "C_r_s : actions(sender_asig)"
  "C_r_r(m) ~: actions(sender_asig)"
  by (simp_all add: sender_asig_def actions_def asig_projections)

lemmas sender_projections = sq_def ssent_def srcvd_def sbit_def ssending_def

end


theory TTreeImplCardinality
imports TTreeAnalysisSig CardinalityAnalysisSig "Cardinality-Domain-Lists"
begin

hide_const Multiset.single

context TTreeAnalysis
begin

fun unstack :: "stack \<Rightarrow> exp \<Rightarrow> exp" where
  "unstack [] e = e"
| "unstack (Alts e1 e2 # S) e = unstack S e"
| "unstack (Upd x # S) e = unstack S e"
| "unstack (Arg x # S) e = unstack S (App e x)"
| "unstack (Dummy x # S) e = unstack S e"

fun Fstack :: "Arity list \<Rightarrow> stack \<Rightarrow> var ttree"
  where "Fstack _ [] = \<bottom>"
  | "Fstack (a#as) (Alts e1 e2 # S) = (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S"
  | "Fstack as (Arg x # S) = many_calls x \<otimes>\<otimes> Fstack as S"
  | "Fstack as (_ # S) = Fstack as S"

(*
lemma carrier_Fstack[simp]: "carrier (Fstack S) = ap S"
  by (induction S rule: Fstack.induct) (auto simp add: empty_is_bottom[symmetric])
*)

fun prognosis :: "AEnv \<Rightarrow> Arity list \<Rightarrow> Arity \<Rightarrow> conf \<Rightarrow> var \<Rightarrow> two"
   where "prognosis ae as a (\<Gamma>, e, S) = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)))"
end

end


(*  Title:       Inductive definition of Hoare logic
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory PsHoare imports PsLang begin

subsection\<open>Hoare logic for partial correctness\<close>

type_synonym 'a assn = "'a \<Rightarrow> state \<Rightarrow> bool"
type_synonym 'a cntxt = "('a assn \<times> com \<times> 'a assn)set"

definition
 valid :: "'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
 "\<Turnstile> {P}c{Q} \<equiv> (\<forall>s t z. s -c\<rightarrow> t \<longrightarrow> P z s \<longrightarrow> Q z t)"

definition
 valids :: "'a cntxt \<Rightarrow> bool" ("|\<Turnstile> _" 50) where
 "|\<Turnstile> D \<equiv> (\<forall>(P,c,Q) \<in> D. \<Turnstile> {P}c{Q})"

definition
 nvalid :: "nat \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile>_ {(1_)}/ (_)/ {(1_)}" 50) where
 "\<Turnstile>n {P}c{Q} \<equiv> (\<forall>s t z. s -c-n\<rightarrow> t \<longrightarrow> P z s \<longrightarrow> Q z t)"

definition
 nvalids :: "nat \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("|\<Turnstile>'__/ _" 50) where
 "|\<Turnstile>_n C \<equiv> (\<forall>(P,c,Q) \<in> C. \<Turnstile>n {P}c{Q})"

text\<open>We now need an additional notion of
validity \mbox{\<open>C |\<Turnstile> D\<close>} where @{term D} is a set as well. The
reason is that we can now have mutually recursive procedures whose
correctness needs to be established by simultaneous induction. Instead
of sets of Hoare triples we may think of conjunctions. We define both
\<open>C |\<Turnstile> D\<close> and its relativized version:\<close>

definition
 cvalids :: "'a cntxt \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("_ |\<Turnstile>/ _" 50) where
  "C |\<Turnstile> D \<longleftrightarrow> |\<Turnstile> C \<longrightarrow> |\<Turnstile> D"

definition
 cnvalids :: "'a cntxt \<Rightarrow> nat \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("_ |\<Turnstile>'__/ _" 50) where
  "C |\<Turnstile>_n D \<longleftrightarrow> |\<Turnstile>_n C \<longrightarrow> |\<Turnstile>_n D"

text\<open>Our Hoare logic now defines judgements of the form \<open>C \<tturnstile>
D\<close> where both @{term C} and @{term D} are (potentially infinite) sets
of Hoare triples; \<open>C \<turnstile> {P}c{Q}\<close> is simply an abbreviation for
\<open>C \<tturnstile> {(P,c,Q)}\<close>.\<close>

inductive
  hoare :: "'a cntxt \<Rightarrow> 'a cntxt \<Rightarrow> bool" ("_ \<tturnstile>/ _" 50)
  and hoare3 :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("_ \<turnstile>/ ({(1_)}/ (_)/ {(1_)})" 50)
where
  "C \<turnstile> {P}c{Q}  \<equiv>  C \<tturnstile> {(P,c,Q)}"
| Do:  "C \<turnstile> {\<lambda>z s. \<forall>t \<in> f s . P z t} Do f {P}"
| Semi: "\<lbrakk> C \<turnstile> {P}c{Q}; C \<turnstile> {Q}d{R} \<rbrakk> \<Longrightarrow> C \<turnstile> {P} c;d {R}"
| If: "\<lbrakk> C \<turnstile> {\<lambda>z s. P z s \<and> b s}c{Q}; C \<turnstile> {\<lambda>z s. P z s \<and> \<not>b s}d{Q}  \<rbrakk> \<Longrightarrow>
      C \<turnstile> {P} IF b THEN c ELSE d {Q}"
| While: "C \<turnstile> {\<lambda>z s. P z s \<and> b s} c {P} \<Longrightarrow>
          C \<turnstile> {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not>b s}"

| Conseq: "\<lbrakk> C \<turnstile> {P'}c{Q'};
             \<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t) \<rbrakk> \<Longrightarrow>
           C \<turnstile> {P}c{Q}"

| Call: "\<lbrakk> \<forall>(P,c,Q) \<in> C. \<exists>p. c = CALL p;
     C \<tturnstile> {(P,b,Q). \<exists>p. (P,CALL p,Q) \<in> C \<and> b = body p} \<rbrakk>
  \<Longrightarrow> {} \<tturnstile> C"

| Asm: "(P,CALL p,Q) \<in> C \<Longrightarrow> C \<turnstile> {P} CALL p {Q}"

| ConjI: "\<forall>(P,c,Q) \<in> D. C \<turnstile> {P}c{Q}  \<Longrightarrow>  C \<tturnstile> D"
| ConjE: "\<lbrakk> C \<tturnstile> D; (P,c,Q) \<in> D \<rbrakk> \<Longrightarrow> C \<turnstile> {P}c{Q}"

| Local: "\<lbrakk> \<forall>s'. C \<turnstile> {\<lambda>z s. P z s' \<and> s = f s'} c {\<lambda>z t. Q z (g s' t)} \<rbrakk> \<Longrightarrow>
        C \<turnstile> {P} LOCAL f;c;g {Q}"
monos split_beta

lemmas valid_defs = valid_def valids_def cvalids_def
                    nvalid_def nvalids_def cnvalids_def

theorem "C \<tturnstile> D  \<Longrightarrow>  C |\<Turnstile> D"

txt\<open>\noindent As before, we prove a generalization of @{prop"C |\<Turnstile> D"},
namely @{prop"\<forall>n. C |\<Turnstile>_n D"}, by induction on @{prop"C \<tturnstile> D"}, with an
induction on @{term n} in the @{term CALL} case.\<close>

apply(subgoal_tac "\<forall>n. C |\<Turnstile>_n D")
apply(unfold valid_defs exec_iff_execn[THEN eq_reflection])
 apply fast
apply(erule hoare.induct)
      apply simp
     apply simp
     apply fast
    apply simp
   apply clarify
   apply(drule while_rule)
   prefer 3
   apply (assumption, assumption)
   apply simp
  apply simp
  apply fast
 apply(rule allI, rule impI)
 apply(induct_tac n)
  apply force
 apply clarify
 apply(frule bspec, assumption)
 apply (simp(no_asm_use))
 apply fast
apply simp
apply fast

apply simp
apply fast

apply fast

apply fastforce
done

definition MGT :: "com \<Rightarrow> state assn \<times> com \<times> state assn" where
  [simp]: "MGT c = (\<lambda>z s. z = s, c, \<lambda>z t. z -c\<rightarrow> t)"

lemma MGT_implies_complete:
  "{} \<tturnstile> {MGT c} \<Longrightarrow> \<Turnstile> {P}c{Q} \<Longrightarrow> {} \<turnstile> {P}c{Q::state assn}"
apply(unfold MGT_def)
apply (erule hoare.Conseq)
apply(simp add: valid_defs)
done

lemma MGT_lemma: "\<forall>p. C \<tturnstile> {MGT(CALL p)}  \<Longrightarrow>  C \<tturnstile> {MGT c}"
apply (simp)
apply(induct_tac c)
    apply (rule strengthen_pre[OF _ hoare.Do])
    apply blast
   apply simp
   apply (rule hoare.Semi)
    apply blast
   apply (rule hoare.Conseq)
    apply blast
   apply blast
  apply clarsimp
  apply(rule hoare.If)
   apply(rule hoare.Conseq)
    apply blast
   apply simp
  apply(rule hoare.Conseq)
   apply blast
  apply simp
 prefer 2
 apply simp
apply(rename_tac b c)
apply(rule hoare.Conseq)
 apply(rule_tac P = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^*"
       in hoare.While)
 apply(erule hoare.Conseq)
 apply(blast intro:rtrancl_into_rtrancl)
apply clarsimp
apply(rename_tac s t)
apply(erule_tac x = s in allE)
apply clarsimp
apply(erule converse_rtrancl_induct)
 apply(blast intro:exec.intros)
apply(fast elim:exec.WhileTrue)

apply(fastforce intro: hoare.Local elim!: hoare.Conseq)
done

lemma MGT_body: "(P, CALL p, Q) = MGT (CALL pa) \<Longrightarrow> C \<tturnstile> {MGT (body p)} \<Longrightarrow> C \<turnstile> {P} body p {Q}"
apply clarsimp
done

declare MGT_def[simp del]

theorem Complete: "\<Turnstile> {P}c{Q}  \<Longrightarrow>  {} \<turnstile> {P}c{Q::state assn}"
apply(rule MGT_implies_complete)
 prefer 2
 apply assumption
apply (rule MGT_lemma)
apply(rule allI)
apply(unfold MGT_def)
apply(rule hoare.ConjE[OF MGT_CALL])
apply(simp add:MGT_def fun_eq_iff)
done

end


(*
 * Copyright 2018, Data61
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory Word_Lemmas_32_Internal
imports Word_Lemmas_32
begin

lemmas sint_eq_uint_32 = sint_eq_uint_2pl[where 'a=32, simplified]

lemmas sle_positive_32 = sle_le_2pl[where 'a=32, simplified]

lemmas sless_positive_32 = sless_less_2pl[where 'a=32, simplified]

lemma zero_le_sint_32:
  "\<lbrakk> 0 \<le> (a :: word32); a < 0x80000000 \<rbrakk>
   \<Longrightarrow> 0 \<le> sint a"
  by (clarsimp simp: sint_eq_uint_32 unat_less_helper)

lemmas unat_add_simple = iffD1[OF unat_add_lem[where 'a = 32, folded word_bits_def]]

lemma upto_enum_inc_1:
  "a < 2 ^ word_bits - 1
   \<Longrightarrow> [(0:: 'a :: len word) .e. 1 + a] = [0.e.a] @ [(1+a)]"
  using upper_trivial upto_enum_inc_1_len by force

lemmas upt_enum_offset_trivial =
  upt_enum_offset_trivial[where 'a=32, folded word_bits_def]

lemmas unat32_eq_of_nat = unat_eq_of_nat[where 'a=32, folded word_bits_def]

declare mask_32_max_word[simp]

lemma le_32_mask_eq:
  "(bits :: word32) \<le> 32 \<Longrightarrow> bits && mask 6 = bits"
  by (fastforce elim: le_less_trans intro: less_mask_eq)

lemmas scast_1_32[simp] = scast_1[where 'a=32]

lemmas mask_32_id[simp] = mask_len_id[where 'a=32, folded word_bits_def]

lemmas t2p_shiftr_32 = t2p_shiftr[where 'a=32, folded word_bits_def]

lemma mask_eq1_nochoice:
  "(x :: word32) && 1 = x
   \<Longrightarrow> x = 0 \<or> x = 1"
  using mask_eq1_nochoice len32 by force

lemmas const_le_unat_word_32 = const_le_unat[where 'a=32, folded word_bits_def]

lemmas createNewCaps_guard_helper =
  createNewCaps_guard[where 'a=32, folded word_bits_def]

lemma word_log2_max_word32[simp]:
  "word_log2 (w :: 32 word) < 32"
  using word_log2_max[where w=w]
  by (simp add: word_size)

(* FIXME: specialize using pow_sub_less_word *)
lemma mapping_two_power_16_64_inequality:
  assumes sz: "sz \<le> 4" and len: "unat (len :: word32) = 2 ^ sz"
  shows "unat (len * 8 - 1) \<le> 127"
  using pow_sub_less[where 'a=32 and b=3, simplified]
proof -
  have len2: "len = 2 ^ sz"
    apply (rule word_unat.Rep_eqD, simp only: len)
    using sz
    apply simp
    done

  show ?thesis using two_power_increasing_less_1[where 'a=32 and n="sz + 3" and m=7]
    by (simp add: word_le_nat_alt sz power_add len2 field_simps)
qed

lemmas pre_helper2_32 = pre_helper2[where 'a=32, folded word_bits_def]

lemmas of_nat_shift_distinct_helper_machine =
  of_nat_shift_distinct_helper[where 'a=32, folded word_bits_def]

lemmas ptr_add_distinct_helper_32 =
  ptr_add_distinct_helper[where 'a=32, folded word_bits_def]

lemmas mask_out_eq_0_32 = mask_out_eq_0[where 'a=32, folded word_bits_def]

lemmas neg_mask_mask_unat_32 = neg_mask_mask_unat[where 'a=32, folded word_bits_def]

lemmas unat_less_iff_32 = unat_less_iff[where 'a=32, folded word_bits_def]

lemmas is_aligned_no_overflow3_32 = is_aligned_no_overflow3[where 'a=32, folded word_bits_def]

lemmas unat_ucast_16_32 = unat_signed_ucast_less_ucast[where 'a=16 and 'b=32, simplified]

(* FIXME: generalize? *)
lemma scast_mask_8:
  "scast (mask 8 :: sword32) = (mask 8 :: word32)"
  by (clarsimp simp: mask_def)

lemmas ucast_le_8_32_equiv = ucast_le_up_down_iff[where 'a=8 and 'b=32, simplified]

lemma signed_unat_minus_one_32:
  "unat (-1 :: 32 signed word) = 4294967295"
  by (simp del: word_pow_0 diff_0 add: unat_sub_if' minus_one_word)

lemmas two_bits_cases_32 = two_bits_cases[where 'a=32, simplified]

lemmas word_ctz_not_minus_1_32 = word_ctz_not_minus_1[where 'a=32, simplified]

lemmas sint_ctz_32 = sint_ctz[where 'a=32, simplified]

(* FIXME: inline these? *)
lemmas scast_specific_plus32 =
  scast_of_nat_signed_to_unsigned_add[where 'a=32 and x="word_ctz x" and y="0x20" for x,
                                      simplified]
lemmas scast_specific_plus32_signed =
  scast_of_nat_unsigned_to_signed_add[where 'a=32 and x="word_ctz x" and y="0x20" for x,
                                      simplified]

end