section \<open> GA \<close>

theory GasAnalysis_Verification
imports "Z_Machines.Z_Machine"

begin

datatype ('s, 'e) tag =
  State (ofState: 's) | Event (ofEvent: 'e)

abbreviation "is_Event x \<equiv> \<not> is_State x"

type_synonym ('s, 'e) rctrace = "('s, 'e) tag list"

definition wf_rcstore :: "('s, 'e) rctrace \<Rightarrow> 's \<Rightarrow> 's option \<Rightarrow> bool" where
[z_defs]: "wf_rcstore tr st final = (
     length(tr) > 0
   \<and> tr ! ((length tr) -1) = State st
   \<and> (final \<noteq> None \<longrightarrow> (\<forall>i<length tr. tr ! i = State (the final) \<longrightarrow> i= (length tr) -1))
   \<and> (filter is_State tr) ! (length (filter is_State tr) -1) = State  st)"

notation undefined ("???")

text \<open> This theory file is to model the GasAnalysis state machine of the Chemical Detector case study.  \<close>

subsection \<open> type definition \<close>

enumtype St = initial | NoGas | GasDetected | Analysis  | Reading  | final

definition "St = {initial , NoGas , GasDetected , Analysis , Reading  , final}"

enumtype Evt = gas | turn | resume | stop

definition "Evt = {gas, turn, resume, stop}"

enumtype Angle = Left | Right | Back |Front

definition "Angle = {Left, Right, Back, Front}"

enumtype Status = noGas | gasD
definition "Status= {noGas, gasD}"

type_synonym Chem= "nat"
type_synonym Intensity= "nat"

record GasSensor =
  c :: Chem
  i :: Intensity

record_default GasSensor

definition Chem :: "Chem set" where "Chem = {1,2,3}"
consts thr::"Intensity"
def_consts thr="2"

definition "SeqGasSensor = { [\<lparr> c = 1, i = 0 \<rparr>,\<lparr> c = 2, i = 1 \<rparr>,\<lparr> c = 2, i = 1 \<rparr>,\<lparr> c = 3, i = 3 \<rparr>]}"

text \<open> RoboChart functions using consts \<close>

fun goreq :: "Intensity \<times> Intensity \<Rightarrow> bool"
  where "goreq(i1, i2) = (i1 \<ge> i2)"

fun intensity_aux:: "GasSensor list \<Rightarrow> nat \<Rightarrow> Intensity" where
"intensity_aux [] n = n" |
"intensity_aux (g # gs) n = (if (i g) > n then intensity_aux gs (i g) else  intensity_aux gs n)"

abbreviation "intensity gs \<equiv> intensity_aux gs 0"

fun analysis:: "GasSensor list \<Rightarrow> Status" where
"analysis (gs) =(if intensity(gs)>0 then gasD else noGas ) "

fun angle::"nat\<Rightarrow> Angle"
  where"angle(x) = (if ((0<x \<and> x\<le>45)\<or> (x>315 \<and> x\<le>360)) then Front else
  if 45< x \<and> x\<le> 135 then  Right else
  if 135< x \<and> x\<le>225 then  Back else
 Left )"

fun location_aux :: "GasSensor list \<Rightarrow> nat \<Rightarrow> nat" where
"location_aux [] n = n" |
"location_aux (g # gs) n = (if i g = intensity( g #gs) then  n else  location_aux gs n+1)"

fun location:: " GasSensor list\<Rightarrow> Angle"
  where "location(gs) =(if goreq(intensity(gs), thr) then angle((360 div size gs)*( location_aux gs 0)) else Front)"

subsection \<open> State Space \<close>

zstore GasAnalysis =
  sts :: "Status"
  gs :: "GasSensor list"
  ins:: "Intensity"
  anl:: "Angle"
  st::"St"
  tr :: "(St, Evt) tag list"
  triggers:: "Evt set"
  where inv:
    "wf_rcstore tr st (Some final)"
    "(st=GasDetected) \<longrightarrow> ins=intensity(gs)"
    "sts=analysis(gs)"

subsection \<open> Operations \<close>

zoperation InitialToReading =
  over GasAnalysis
  pre "st= initial"
  update "[ st\<Zprime>= Reading
           ,tr\<Zprime>=tr @ [State Reading]
           ,triggers\<Zprime>={gas}
         ]"

zoperation ReadingToAnalysis =
  over GasAnalysis
  params g\<in>"SeqGasSensor"
  pre "st= Reading "
  update "[ sts\<Zprime> =analysis(g)
           ,gs\<Zprime> = g
           ,st\<Zprime>= Analysis
           ,tr\<Zprime>=tr @ [Event gas, State Analysis]
           ,triggers\<Zprime>={}
           ]"

zoperation AnalysisToNoGas =
  over GasAnalysis
  pre "st= Analysis \<and> sts=(noGas)"
  update "[ st\<Zprime>= NoGas
           ,tr\<Zprime>=tr @ [Event resume, State NoGas]
           ,triggers\<Zprime>={}
          ]"

zoperation NoGasToReading =
  over GasAnalysis
  pre "st= NoGas "
  update "[ st\<Zprime>= Reading
           ,tr\<Zprime>=tr @ [ State Reading]
           ,triggers\<Zprime>={gas}
          ]"

zoperation AnalysisToGasDetected =
  over GasAnalysis
  pre "st= Analysis \<and> sts=(gasD)"
  update "[ st\<Zprime>= GasDetected
           ,tr\<Zprime>=tr @ [State GasDetected]
           ,ins\<Zprime> = intensity(gs)
           ,triggers\<Zprime>={}
          ]"

zoperation GasDetectedToFinal =
  over GasAnalysis
  pre "st= GasDetected  \<and> goreq(ins, thr)"
  update "[ st\<Zprime>= final
           ,tr\<Zprime>=tr @ [Event stop, State final]
           ,triggers\<Zprime>={}
           ]"

zoperation GasDetectedToReading =
  over GasAnalysis
  pre "st= GasDetected \<and> \<not>goreq(ins, thr)"
  update "[ anl\<Zprime>= location(gs)
           ,st\<Zprime>= Reading
           ,tr\<Zprime>=tr @ [Event turn, State Reading]
           ,triggers\<Zprime>={gas}
           ]"

zoperation Bypass =
  over GasAnalysis
  pre "st = final"

definition Init :: "GasAnalysis subst" where
  [z_defs]:
  "Init =
   [sts\<leadsto> noGas,
    gs \<leadsto> [],
    ins\<leadsto> 0,
    anl\<leadsto> Front,
    st\<leadsto> initial,
    tr \<leadsto>[State initial],
    triggers \<leadsto> {}
   ]"

zmachine GasAnalysisMachine =
  init Init
  invariant GasAnalysis_inv
  operations InitialToReading AnalysisToNoGas AnalysisToGasDetected GasDetectedToFinal GasDetectedToReading ReadingToAnalysis NoGasToReading Bypass

subsection \<open> Structural Invariants \<close>

lemma Init [hoare_lemmas]:"Init establishes GasAnalysis_inv"
  by zpog_full

lemma InitialToReading_inv [hoare_lemmas]:"InitialToReading() preserves GasAnalysis_inv"
  apply zpog_full
  apply (metis St.distinct(9) less_Suc_eq nth_append tag.inject(1))
  by (metis St.distinct(9) not_less_less_Suc_eq nth_append tag.inject(1))

lemma AnalysisToNoGas_inv [hoare_lemmas]: "AnalysisToNoGas() preserves GasAnalysis_inv"
  apply zpog_full
  apply (metis One_nat_def Suc_eq_plus1 nth_Cons_0 nth_Cons_Suc nth_append_length_plus)
  by (metis St.distinct(28) less_SucE nth_append nth_append_length tag.disc(1) tag.disc(2) tag.inject(1))

lemma AnalysisToGasDetected_inv [hoare_lemmas]: "AnalysisToGasDetected() preserves GasAnalysis_inv"
  apply zpog_full
  by (metis St.distinct(27) less_antisym nth_append tag.inject(1))

lemma GasDetectedToFinal_inv [hoare_lemmas]: "GasDetectedToFinal() preserves GasAnalysis_inv"
  apply zpog_full
  apply (metis One_nat_def Suc_eq_plus1 nth_Cons_0 nth_Cons_Suc nth_append_length_plus)
  apply (metis St.distinct(23) not_less_less_Suc_eq nth_append nth_append_length tag.distinct(1) tag.inject(1))
  by (metis St.distinct(23) Suc_le_eq diff_Suc_Suc diff_diff_cancel less_SucE minus_nat.diff_0 nat_less_le nth_Cons_0 nth_Cons_Suc nth_append tag.distinct(1) tag.inject(1) zero_less_Suc)

lemma GasDetectedToReading_inv [hoare_lemmas]: "GasDetectedToReading() preserves GasAnalysis_inv"
  apply zpog_full
  apply (metis One_nat_def Suc_eq_plus1 nth_Cons_0 nth_Cons_Suc nth_append_length_plus)
  apply (metis St.distinct(24) less_antisym nth_append nth_append_length tag.distinct(1) tag.inject(1))
  by (smt (z3) One_nat_def St.distinct(24) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.distinct(1) tag.inject(1))

lemma ReadingToAnalysis_inv [hoare_lemmas]: "ReadingToAnalysis (l) preserves GasAnalysis_inv"
  apply zpog_full
  apply (metis One_nat_def Suc_eq_plus1 nth_Cons_0 nth_Cons_Suc nth_append_length_plus)
  apply (metis St.distinct(29) not_less_less_Suc_eq nth_append nth_append_length tag.distinct(1) tag.inject(1))
  by (smt (z3) One_nat_def St.distinct(30) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.distinct(1) tag.inject(1))

lemma NoGasToReading_inv [hoare_lemmas]: "NoGasToReading() preserves GasAnalysis_inv"
  apply zpog_full
  apply (metis St.distinct(17) less_antisym nth_append tag.inject(1))
  by (metis St.distinct(18) not_less_less_Suc_eq nth_append tag.inject(1))

lemma Bypass_inv [hoare_lemmas]: "Bypass() preserves GasAnalysis_inv"
  by (zpog_full; auto)

subsection \<open> Safety Requirements \<close>

zexpr R1 is
"sts=noGas \<and> thr>0 \<longrightarrow>(\<forall>i <(length tr). tr ! i \<noteq> State final)"

lemma "Init establishes R1 "
  by zpog_full

lemma "InitialToReading() preserves R1"
  apply zpog_full
  by (metis St.distinct(29) less_SucE nth_append nth_append_length tag.inject(1))

lemma "GasDetectedToFinal() preserves R1 under GasAnalysis_inv"
  by zpog_full

lemma "AnalysisToGasDetected() preserves R1 under GasAnalysis_inv"
 by zpog_full

lemma  "AnalysisToNoGas() preserves  R1"
  apply zpog_full
  by (metis One_nat_def St.distinct(18) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.distinct(1) tag.inject(1))

lemma  "NoGasToReading() preserves R1"
  apply zpog_full
  by (simp add: nth_append)

lemma  "GasDetectedToReading() preserves   R1 "
  apply zpog_full
  by (metis One_nat_def St.distinct(30) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.distinct(1) tag.inject(1))

lemma  "ReadingToAnalysis l preserves  R1 under GasAnalysis_inv  "
  apply zpog_full
  apply (metis (no_types, opaque_lifting) One_nat_def St.distinct(27) St.distinct(29) Suc_eq_plus1 Suc_lessI cancel_ab_semigroup_add_class.add_diff_cancel_left' diff_is_0_eq' less_Suc_eq_le not_less_eq nth_Cons_0 nth_Cons_Suc nth_append tag.distinct(1) tag.inject(1))
  apply (metis (mono_tags, lifting) One_nat_def St.distinct_disc(28) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.distinct(1) tag.inject(1))
  done

zexpr R2 is
"length tr>1\<longrightarrow> ( \<forall> i <(length tr). tr! i = State final   \<longrightarrow> tr ! (i-1) = Event stop )"

lemma "Init establishes R2"
  by (zpog_full; auto)

lemma  "InitialToReading() preserves  R2 under GasAnalysis_inv"
  apply zpog_full
  apply (metis St.distinct(30) St.simps(10) less_Suc_eq nth_append nth_append_length tag.inject(1))
  by (metis St.distinct(30) St.simps(10) less_Suc_eq nth_append nth_append_length tag.inject(1))

 lemma  "AnalysisToNoGas() preserves  R2 under GasAnalysis_inv"
  apply zpog_full
  by (smt (verit, del_insts) One_nat_def St.distinct(18) St.distinct_disc(27) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.disc(1) tag.disc(2) tag.inject(1))

lemma  "AnalysisToGasDetected()   preserves  R2 under GasAnalysis_inv"
  apply zpog_full
  by (metis St.distinct(24) St.distinct_disc(28) less_Suc_eq nth_append nth_append_length tag.inject(1))

lemma "GasDetectedToFinal() preserves R2 under GasAnalysis_inv"
  apply zpog_full
  apply (metis St.distinct(24) cancel_comm_monoid_add_class.diff_zero diff_Suc_Suc less_antisym nth_append nth_append_length tag.distinct(1) tag.inject(1))
  by (metis less_2_cases_iff less_numeral_extra(3) thr_def)

lemma  "GasDetectedToReading() preserves   R2 under GasAnalysis_inv "
  apply zpog_full
  apply (smt (verit, best) St.distinct(24) St.distinct(30) Suc_diff_Suc diff_Suc_1 diff_Suc_Suc less_SucE minus_gr_zero_iff nth_Cons_0 nth_Cons_pos nth_append tag.distinct(1) tag.inject(1))
  by (smt (verit, best) One_nat_def St.distinct(24) St.distinct(30) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.disc(1) tag.disc(2) tag.inject(1))

lemma  "ReadingToAnalysis l preserves  R2 under GasAnalysis_inv"
  apply zpog_full
  apply (smt (verit, best) One_nat_def St.distinct(30) St.distinct_disc(27) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.disc(1) tag.disc(2) tag.inject(1))
  by (smt (verit, best) One_nat_def St.distinct(30) St.distinct_disc(28) Suc_eq_plus1 less_SucE nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus tag.disc(1) tag.disc(2) tag.inject(1))

lemma  "NoGasToReading() preserves  R2 under GasAnalysis_inv "
  apply zpog_full
  apply (metis St.distinct(18) St.distinct(30) less_Suc_eq nth_append nth_append_length tag.inject(1))
  by (metis St.distinct(18) St.distinct(30) less_Suc_eq nth_append nth_append_length tag.inject(1))

zexpr R3
is "length tr>1 \<longrightarrow> (\<forall>i<length tr-1.  tr ! (i+1) = State Analysis \<longrightarrow>  tr ! i = Event gas)"

lemma "Init establishes R3"
  by (zpog_full; auto)

lemma  "InitialToReading() preserves  R3 under GasAnalysis_inv"
  apply zpog_full
  apply (smt (verit) One_nat_def St.distinct(5) St.simps(26) Suc_pred diff_is_0_eq' length_tl less_Suc0 less_Suc_eq_le list.sel(2) list.size(3) not_less_eq nth_Cons_0 nth_append tag.inject(1))
  by (smt (verit, del_insts) St.distinct(5) St.simps(26) Suc_pred diff_is_0_eq' less_Suc0 less_Suc_eq less_Suc_eq_le not_less_eq nth_Cons_0 nth_append tag.inject(1))

lemma  "ReadingToAnalysis l preserves  R3 under GasAnalysis_inv "
  apply zpog_full
  apply (smt (verit, ccfv_SIG) Suc_pred less_2_cases not_less_eq not_less_iff_gr_or_eq nth_append nth_append_length numeral_2_eq_2 tag.distinct(1))
  by (metis (no_types, lifting) Suc_lessI Suc_pred length_greater_0_conv less_2_cases less_SucE nth_append nth_append_length numeral_2_eq_2 tag.distinct(1))

lemma  "AnalysisToNoGas() preserves  R3  under GasAnalysis_inv"
  apply zpog_full
  by (smt (verit, del_insts) St.distinct(13) Suc_eq_plus1 Suc_pred less_2_cases_iff not_less_eq not_less_iff_gr_or_eq nth_Cons_0 nth_Cons_Suc nth_append nth_append_length nth_append_length_plus numeral_2_eq_2 one_add_one tag.distinct(1) tag.inject(1))

lemma  "AnalysisToGasDetected()   preserves  R3 under GasAnalysis_inv"
  apply zpog_full
  by (metis (no_types, lifting) Nat.lessE One_nat_def St.simps(20) Suc_leI Suc_lessI diff_Suc_1 diff_is_0_eq' length_greater_0_conv nth_append nth_append_length tag.inject(1))

lemma  "GasDetectedToReading() preserves  R3"
  apply zpog_full
  by (smt (verit, ccfv_SIG) One_nat_def St.simps(26) Suc_eq_plus1 Suc_less_eq2 cancel_ab_semigroup_add_class.add_diff_cancel_left' diff_Suc_1 length_Cons less_SucE less_nat_zero_code list.sel(3) list.size(3) not_less_iff_gr_or_eq nth_append nth_append_length nth_tl tag.distinct(1) tag.inject(1))

lemma  "NoGasToReading() preserves  R3"
  apply zpog_full
  by (metis (no_types, lifting) Nat.lessE One_nat_def St.simps(26) Suc_leI Suc_lessI diff_Suc_1 diff_is_0_eq' length_greater_0_conv nth_append nth_append_length tag.inject(1))

lemma "GasDetectedToFinal() preserves R3"
  apply zpog_full
  by (smt (verit) One_nat_def St.simps(28) Suc_eq_plus1 Suc_less_eq2 cancel_ab_semigroup_add_class.add_diff_cancel_left' diff_Suc_1 length_Cons less_nat_zero_code list.sel(3) list.size(3) not_less_eq not_less_iff_gr_or_eq nth_append nth_append_length nth_tl tag.distinct(1) tag.inject(1))

zexpr R4
is "(length tr)>1\<longrightarrow> ( \<forall> i <(length tr)-1  . tr ! i = Event turn  \<longrightarrow> tr ! (i+1) = State Reading )"

lemma "Init establishes R4"
  by (zpog_full; auto)

lemma  "InitialToReading() preserves  R4"
  apply zpog_full
  by (simp add: nth_append)

lemma  "ReadingToAnalysis l preserves  R4 under GasAnalysis_inv"
  apply zpog_full
  apply (smt (verit) Evt.distinct(1) Suc_lessI Suc_pred length_greater_0_conv less_Suc0 less_Suc_eq nth_append nth_append_length tag.disc(1) tag.disc(2) tag.inject(2))
  by (smt (verit, del_insts) Evt.distinct(1) Suc_lessI Suc_pred length_greater_0_conv less_Suc0 less_Suc_eq nth_append nth_append_length tag.disc(1) tag.disc(2) tag.inject(2))

lemma  "AnalysisToNoGas() preserves  R4 under GasAnalysis_inv"
  apply zpog_full
  by (smt (verit, best) Evt.distinct(7) One_nat_def Suc_diff_1 less_Suc0 linorder_neqE_nat not_less_eq nth_append nth_append_length tag.distinct(1) tag.inject(2))

lemma  "AnalysisToGasDetected()   preserves  R4  under GasAnalysis_inv "
  apply zpog_full
  by (metis (no_types, lifting) Nat.lessE One_nat_def diff_Suc_1 less_Suc0 not_less_eq nth_append tag.disc(1) tag.disc(2))

lemma  "GasDetectedToReading() preserves   R4 under GasAnalysis_inv"
  apply zpog_full
  apply (smt (verit, del_insts) One_nat_def Suc_eq_plus1 Suc_leI Suc_lessI Suc_pred diff_is_0_eq' less_Suc_eq nth_Cons_0 nth_Cons_Suc nth_append nth_append_length_plus tag.distinct(1) zero_less_Suc)
  by (smt (verit, del_insts) One_nat_def Suc_eq_plus1 Suc_lessI Suc_pred not_less_eq nth_Cons_0 nth_Cons_Suc nth_append nth_append_length_plus tag.disc(1) tag.disc(2) zero_less_Suc)

lemma  "NoGasToReading() preserves  R4 under GasAnalysis_inv"
  apply zpog_full
  apply (simp add: nth_append)
  by (simp add: nth_append)

lemma "GasDetectedToFinal() preserves R4 under GasAnalysis_inv"
  apply zpog_full
  apply (smt (verit) Evt.simps(10) Suc_pred less_Suc_eq not_less_eq nth_append nth_append_length tag.disc(1) tag.disc(2) tag.inject(2) zero_less_Suc)
  using Zero_not_Suc numerals(2) thr_def by presburger

zexpr R5 is
"length(filter is_State tr)>1 \<longrightarrow> (\<forall>i< (length(filter is_State tr)-1).  (filter is_State tr) ! i = State Reading \<longrightarrow> ( (filter is_State tr) ! (i+1)) =  State Analysis)"

lemma "Init establishes R5"
  by zpog_full

lemma  "InitialToReading() preserves  R5 under GasAnalysis_inv"
apply zpog_full
  apply (metis (no_types, lifting) Nat.lessE One_nat_def St.distinct(7) diff_Suc_1 less_Suc0 not_less_eq nth_append tag.inject(1))
  by (metis (no_types, lifting) Nat.lessE One_nat_def St.distinct(7) diff_Suc_1 less_Suc0 not_less_eq nth_append tag.inject(1))

lemma  "AnalysisToNoGas() preserves  R5 under GasAnalysis_inv "
  apply zpog_full
  by (metis (no_types, lifting) Nat.lessE One_nat_def St.simps(26) diff_Suc_1 less_Suc0 not_less_eq nth_append tag.inject(1))

lemma  "AnalysisToGasDetected()   preserves  R5 under GasAnalysis_inv "
  apply zpog_full
  by (metis (no_types, lifting) One_nat_def St.distinct(25) Suc_eq_plus1 Suc_lessI diff_Suc_1 diff_is_0_eq less_diff_conv less_nat_zero_code linorder_not_less nth_append tag.inject(1))

lemma "GasDetectedToFinal() preserves R5  under GasAnalysis_inv  "
  apply zpog_full
  apply (metis (no_types, lifting) One_nat_def St.distinct(21) Suc_eq_plus1 Suc_lessI diff_Suc_1 diff_is_0_eq gr_implies_not_zero less_diff_conv linorder_not_less nth_append tag.inject(1))
  by (metis less_2_cases_iff less_numeral_extra(3) thr_def)

lemma  "GasDetectedToReading() preserves   R5 under GasAnalysis_inv  "
  apply zpog_full
  apply (metis (no_types, lifting) One_nat_def St.distinct(21) Suc_eq_plus1 Suc_lessI diff_Suc_1 diff_is_0_eq less_diff_conv linorder_not_le not_less_zero nth_append tag.inject(1))
  by (metis (no_types, lifting) One_nat_def St.distinct(21) Suc_eq_plus1 Suc_lessI diff_Suc_1 diff_is_0_eq' less_diff_conv less_zeroE linorder_not_le nth_append tag.inject(1))

lemma  "ReadingToAnalysis l preserves  R5 under GasAnalysis_inv  "
  apply zpog_full
  apply (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Suc_lessI diff_is_0_eq less_diff_conv less_nat_zero_code linorder_not_less nth_append nth_append_length)
  by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Suc_lessI diff_is_0_eq less_diff_conv less_zeroE linorder_not_le nth_append nth_append_length)

lemma  "NoGasToReading() preserves  R5 under GasAnalysis_inv "
  apply zpog_full
  apply (metis (no_types, lifting) Nat.lessE One_nat_def St.distinct(15) diff_Suc_1 less_Suc0 not_less_eq nth_append tag.inject(1))
  by (metis (no_types, lifting) Nat.lessE One_nat_def St.distinct(15) diff_Suc_1 less_Suc0 not_less_eq nth_append tag.inject(1))

zexpr R6
is "  thr>0 \<and> intensity(gs)\<ge>thr  \<longrightarrow>   sts=gasD"

lemma "Init establishes R6"
  by (zpog_full; auto)

lemma  "InitialToReading()  preserves  R6"
  by (zpog_full; auto)

lemma  "ReadingToAnalysis l preserves  R6"
  by (zpog_full ; auto)

lemma "GasDetectedToFinal() preserves R6"
  by (zpog_full; auto)

lemma  "AnalysisToNoGas() preserves  R6"
  by (zpog_full; auto)

lemma  "AnalysisToGasDetected() preserves  R6"
  by (zpog_full; auto)

lemma  "GasDetectedToReading() preserves  R6"
  by (zpog_full; auto)

lemma  "NoGasToReading() preserves  R6"
  by (zpog_full; auto)

definition [z_defs]: "GasAnalysis_axioms = (thr >0 )"

lemma R8_GasAnalysis_deadlock_free: "GasAnalysis_axioms  \<Longrightarrow> deadlock_free GasAnalysisMachine"
  apply deadlock_free
  using SeqGasSensor_def St.exhaust_disc apply auto[1]
  using SeqGasSensor_def St.exhaust_disc by blast

end


theory Common_Primitive_Lemmas
imports Common_Primitive_Matcher
        "../Semantics_Ternary/Primitive_Normalization"
        "../Semantics_Ternary/MatchExpr_Fold"
begin

section\<open>Further Lemmas about the Common Matcher\<close>

lemma has_unknowns_common_matcher: fixes m::"'i::len common_primitive match_expr"
  shows "has_unknowns common_matcher m \<longleftrightarrow> has_disc is_Extra m"
  proof -
  { fix A and p :: "('i, 'a) tagged_packet_scheme"
    have "common_matcher A p = TernaryUnknown \<longleftrightarrow> is_Extra A"
      by(induction A p rule: common_matcher.induct) (simp_all add: bool_to_ternary_Unknown)
  } hence "\<beta> = (common_matcher::('i::len common_primitive, ('i, 'a) tagged_packet_scheme) exact_match_tac)
            \<Longrightarrow> has_unknowns \<beta> m = has_disc is_Extra m" for \<beta>
  by(induction \<beta> m rule: has_unknowns.induct)
    (simp_all)
  thus ?thesis by simp
qed

end


section {* WebAssembly Base Definitions *}

theory Wasm_Base_Defs imports Wasm_Ast Wasm_Type_Abs begin

instantiation i32 :: wasm_int begin instance .. end
instantiation i64 :: wasm_int begin instance .. end
instantiation f32 :: wasm_float begin instance .. end
instantiation f64 :: wasm_float begin instance .. end

consts
  (* inter-type conversions *)
  (* float to i32 *)
  ui32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  si32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  ui32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  si32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  (* float to i64 *)
  ui64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  si64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  ui64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  si64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  (* int to f32 *)
  f32_convert_ui32 :: "i32 \<Rightarrow> f32"
  f32_convert_si32 :: "i32 \<Rightarrow> f32"
  f32_convert_ui64 :: "i64 \<Rightarrow> f32"
  f32_convert_si64 :: "i64 \<Rightarrow> f32"
  (* int to f64 *)
  f64_convert_ui32 :: "i32 \<Rightarrow> f64"
  f64_convert_si32 :: "i32 \<Rightarrow> f64"
  f64_convert_ui64 :: "i64 \<Rightarrow> f64"
  f64_convert_si64 :: "i64 \<Rightarrow> f64"
  (* intra-{int/float} conversions *)
  wasm_wrap :: "i64 \<Rightarrow> i32"
  wasm_extend_u :: "i32 \<Rightarrow> i64"
  wasm_extend_s :: "i32 \<Rightarrow> i64"
  wasm_demote :: "f64 \<Rightarrow> f32"
  wasm_promote :: "f32 \<Rightarrow> f64"
  (* boolean encoding *)
  serialise_i32 :: "i32 \<Rightarrow> bytes"
  serialise_i64 :: "i64 \<Rightarrow> bytes"
  serialise_f32 :: "f32 \<Rightarrow> bytes"
  serialise_f64 :: "f64 \<Rightarrow> bytes"
  wasm_bool :: "bool \<Rightarrow> i32"
  int32_minus_one :: i32

  (* memory *)
definition mem_size :: "mem \<Rightarrow> nat" where
  "mem_size m = length (Rep_mem m)"

definition mem_grow :: "mem \<Rightarrow> nat \<Rightarrow> mem" where
  "mem_grow m n = mem_append m (bytes_replicate (n * 64000) 0)"

definition load :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load m n off l = (if (mem_size m \<ge> (n+off+l))
                       then Some (read_bytes m (n+off) l)
                       else None)"

definition sign_extend :: "sx \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" where
  "sign_extend sx l bytes = (let msb = msb (msbyte bytes) in
                          let byte = (case sx of U \<Rightarrow> 0 | S \<Rightarrow> if msb then -1 else 0) in
                          bytes_takefill byte l bytes)"

definition load_packed :: "sx \<Rightarrow> mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load_packed sx m n off lp l = map_option (sign_extend sx l) (load m n off lp)"

definition store :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store m n off bs l = (if (mem_size m \<ge> (n+off+l))
                          then Some (write_bytes m (n+off) (bytes_takefill 0 l bs))
                          else None)"

definition store_packed :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store_packed = store"

consts
  wasm_deserialise :: "bytes \<Rightarrow> t \<Rightarrow> v"
  (* host *)
  host_apply :: "s \<Rightarrow> tf \<Rightarrow> host \<Rightarrow> v list \<Rightarrow> host_state \<Rightarrow> (s \<times> v list) option"

definition typeof :: " v \<Rightarrow> t" where
  "typeof v = (case v of
                 ConstInt32 sec _ \<Rightarrow> (T_i32 sec)
               | ConstInt64 sec _ \<Rightarrow> (T_i64 sec)
               | ConstFloat32 _ \<Rightarrow> T_f32
               | ConstFloat64 _ \<Rightarrow> T_f64)"

definition trust_compat :: "trust \<Rightarrow> trust \<Rightarrow> bool" where
  "trust_compat tr tr' = (tr = Trusted \<or> (tr = Untrusted \<and> tr' = Untrusted))"

definition classify_t :: "t \<Rightarrow> t" where
  "classify_t t = (case t of
                     T_i32 _ \<Rightarrow> T_i32 Secret
                   | T_i64 _ \<Rightarrow> T_i64 Secret
                   | T_f32 \<Rightarrow> T_f32
                   | T_f64 \<Rightarrow> T_f64)"

definition classify :: "v \<Rightarrow> v" where
  "classify v = (case v of
                   ConstInt32 sec c \<Rightarrow> ConstInt32 Secret c
                 | ConstInt64 sec c \<Rightarrow> ConstInt64 Secret c
                 | ConstFloat32 c \<Rightarrow> ConstFloat32 c
                 | ConstFloat64 c \<Rightarrow> ConstFloat64 c)"

definition declassify_t :: "t \<Rightarrow> t" where
  "declassify_t t = (case t of
                     T_i32 _ \<Rightarrow> T_i32 Public
                   | T_i64 _ \<Rightarrow> T_i64 Public
                   | T_f32 \<Rightarrow> T_f32
                   | T_f64 \<Rightarrow> T_f64)"

definition declassify :: "v \<Rightarrow> v" where
  "declassify v = (case v of
                   ConstInt32 sec c \<Rightarrow> ConstInt32 Public c
                 | ConstInt64 sec c \<Rightarrow> ConstInt64 Public c
                 | ConstFloat32 c \<Rightarrow> ConstFloat32 c
                 | ConstFloat64 c \<Rightarrow> ConstFloat64 c)"

definition option_projl :: "('a \<times> 'b) option \<Rightarrow> 'a option" where
  "option_projl x = map_option fst x"

definition option_projr :: "('a \<times> 'b) option \<Rightarrow> 'b option" where
  "option_projr x = map_option snd x"

definition t_length :: "t \<Rightarrow> nat" where
 "t_length t = (case t of
                  T_i32 _ \<Rightarrow> 4
                | T_i64 _ \<Rightarrow> 8
                | T_f32 \<Rightarrow> 4
                | T_f64 \<Rightarrow> 8)"

definition tp_length :: "tp \<Rightarrow> nat" where
 "tp_length tp = (case tp of
                 Tp_i8 \<Rightarrow> 1
               | Tp_i16 \<Rightarrow> 2
               | Tp_i32 \<Rightarrow> 4)"

definition t_sec :: "t \<Rightarrow> sec" where
 "t_sec t = (case t of
               T_i32 sec \<Rightarrow> sec
             | T_i64 sec \<Rightarrow> sec
             | T_f32 \<Rightarrow> Public
             | T_f64 \<Rightarrow> Public)"

abbreviation is_public_t :: "t \<Rightarrow> bool" where
  "is_public_t t \<equiv> ((t_sec t) = Public)"

abbreviation is_secret_t :: "t \<Rightarrow> bool" where
  "is_secret_t t \<equiv> ((t_sec t) = Secret)"

definition is_int_t :: "t \<Rightarrow> bool" where
 "is_int_t t = (case t of
                  T_i32 _ \<Rightarrow> True
                | T_i64 _ \<Rightarrow> True
                | T_f32 \<Rightarrow> False
                | T_f64 \<Rightarrow> False)"

definition is_float_t :: "t \<Rightarrow> bool" where
 "is_float_t t = (case t of
                    T_i32 _ \<Rightarrow> False
                  | T_i64 _ \<Rightarrow> False
                  | T_f32 \<Rightarrow> True
                  | T_f64 \<Rightarrow> True)"

definition is_mut :: "tg \<Rightarrow> bool" where
  "is_mut tg = (tg_mut tg = T_mut)"

definition safe_binop_i :: "binop_i \<Rightarrow> bool" where
  "safe_binop_i bop =
     (case bop of
        Div _ \<Rightarrow> False
      | Rem _ \<Rightarrow> False
      | _ \<Rightarrow> True)"

definition app_unop_i :: "unop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int" where
  "app_unop_i iop c =
     (case iop of
     Ctz \<Rightarrow> int_ctz c
   | Clz \<Rightarrow> int_clz c
   | Popcnt \<Rightarrow> int_popcnt c)"

definition app_unop_f :: "unop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float" where
  "app_unop_f fop c =
                 (case fop of
                    Neg \<Rightarrow> float_neg c
                  | Abs \<Rightarrow> float_abs c
                  | Ceil \<Rightarrow> float_ceil c
                  | Floor \<Rightarrow> float_floor c
                  | Trunc \<Rightarrow> float_trunc c
                  | Nearest \<Rightarrow> float_nearest c
                  | Sqrt \<Rightarrow> float_sqrt c)"

definition app_binop_i :: "binop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> ('i::wasm_int) option" where
  "app_binop_i iop c1 c2 = (case iop of
                              Add \<Rightarrow> Some (int_add c1 c2)
                            | Sub \<Rightarrow> Some (int_sub c1 c2)
                            | Mul \<Rightarrow> Some (int_mul c1 c2)
                            | Div U \<Rightarrow> int_div_u c1 c2
                            | Div S \<Rightarrow> int_div_s c1 c2
                            | Rem U \<Rightarrow> int_rem_u c1 c2
                            | Rem S \<Rightarrow> int_rem_s c1 c2
                            | And \<Rightarrow> Some (int_and c1 c2)
                            | Or \<Rightarrow> Some (int_or c1 c2)
                            | Xor \<Rightarrow> Some (int_xor c1 c2)
                            | Shl \<Rightarrow> Some (int_shl c1 c2)
                            | Shr U \<Rightarrow> Some (int_shr_u c1 c2)
                            | Shr S \<Rightarrow> Some (int_shr_s c1 c2)
                            | Rotl \<Rightarrow> Some (int_rotl c1 c2)
                            | Rotr \<Rightarrow> Some (int_rotr c1 c2))"

definition app_binop_f :: "binop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> ('f::wasm_float) option" where
  "app_binop_f fop c1 c2 = (case fop of
                              Addf \<Rightarrow> Some (float_add c1 c2)
                            | Subf \<Rightarrow> Some (float_sub c1 c2)
                            | Mulf \<Rightarrow> Some (float_mul c1 c2)
                            | Divf \<Rightarrow> Some (float_div c1 c2)
                            | Min \<Rightarrow> Some (float_min c1 c2)
                            | Max \<Rightarrow> Some (float_max c1 c2)
                            | Copysign \<Rightarrow> Some (float_copysign c1 c2))"

definition app_testop_i :: "testop \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_testop_i testop c = (case testop of Eqz \<Rightarrow> int_eqz c)"

definition app_relop_i :: "relop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_relop_i rop c1 c2 = (case rop of
                              Eq \<Rightarrow> int_eq c1 c2
                            | Ne \<Rightarrow> int_ne c1 c2
                            | Lt U \<Rightarrow> int_lt_u c1 c2
                            | Lt S \<Rightarrow> int_lt_s c1 c2
                            | Gt U \<Rightarrow> int_gt_u c1 c2
                            | Gt S \<Rightarrow> int_gt_s c1 c2
                            | Le U \<Rightarrow> int_le_u c1 c2
                            | Le S \<Rightarrow> int_le_s c1 c2
                            | Ge U \<Rightarrow> int_ge_u c1 c2
                            | Ge S \<Rightarrow> int_ge_s c1 c2)"

definition app_relop_f :: "relop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> bool" where
  "app_relop_f rop c1 c2 = (case rop of
                              Eqf \<Rightarrow> float_eq c1 c2
                            | Nef \<Rightarrow> float_ne c1 c2
                            | Ltf \<Rightarrow> float_lt c1 c2
                            | Gtf \<Rightarrow> float_gt c1 c2
                            | Lef \<Rightarrow> float_le c1 c2
                            | Gef \<Rightarrow> float_ge c1 c2)"

definition types_agree :: "t \<Rightarrow> v \<Rightarrow> bool" where
  "types_agree t v = (typeof v = t)"

definition types_agree_insecure :: "t \<Rightarrow> v \<Rightarrow> bool" where
  "types_agree_insecure t v = (let v_t = typeof v in
                               is_int_t v_t = is_int_t t \<and> t_length v_t = t_length t)"

definition cl_type :: "cl \<Rightarrow> tf_t" where
  "cl_type cl = (case cl of Func_native _ tf _ _ \<Rightarrow> tf | Func_host tf _ \<Rightarrow> tf)"

definition rglob_is_mut :: "global \<Rightarrow> bool" where
  "rglob_is_mut g = (g_mut g = T_mut)"

definition stypes :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tf_t" where
  "stypes s i j = ((types ((inst s)!i))!j)"

definition sfunc_ind :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sfunc_ind s i j = ((inst.funcs ((inst s)!i))!j)"

definition sfunc :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl" where
  "sfunc s i j = (funcs s)!(sfunc_ind s i j)"

definition sglob_ind :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sglob_ind s i j = ((inst.globs ((inst s)!i))!j)"

definition sglob :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> global" where
  "sglob s i j = (globs s)!(sglob_ind s i j)"

definition sglob_val :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> v" where
  "sglob_val s i j = g_val (sglob s i j)"

definition smem_ind :: "s \<Rightarrow> nat \<Rightarrow> nat option" where
  "smem_ind s i = (inst.mem ((inst s)!i))"

definition stab_s :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab_s s i j = (let stabinst = ((tab s)!i) in  (if (length (stabinst) > j) then (stabinst!j) else None))"

definition stab :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab s i j = (case (inst.tab ((inst s)!i)) of Some k => stab_s s k j | None => None)"

definition supdate_glob_s :: "s \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob_s s k v = s\<lparr>globs := (globs s)[k:=((globs s)!k)\<lparr>g_val := v\<rparr>]\<rparr>"

definition supdate_glob :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob s i j v = (let k = sglob_ind s i j in supdate_glob_s s k v)"

definition is_const :: "e \<Rightarrow> bool" where
  "is_const e = (case e of Basic (C _) \<Rightarrow> True | _ \<Rightarrow> False)"

definition const_list :: "e list \<Rightarrow> bool" where
  "const_list xs = list_all is_const xs"

inductive store_extension :: "s \<Rightarrow> s \<Rightarrow> bool" where
"\<lbrakk>insts = insts'; fs = fs'; tclss = tclss'; list_all2 (\<lambda>(bs,sec) (bs',sec'). mem_size bs \<le> mem_size bs' \<and> sec = sec') bss bss'; gs = gs'\<rbrakk> \<Longrightarrow>
  store_extension \<lparr>s.inst = insts, s.funcs = fs, s.tab = tclss, s.mem = bss, s.globs = gs\<rparr>
                    \<lparr>s.inst = insts', s.funcs = fs', s.tab = tclss', s.mem = bss', s.globs = gs'\<rparr>"

abbreviation to_e_list :: "b_e list \<Rightarrow> e list" ("$* _" 60) where
  "to_e_list b_es \<equiv> map Basic b_es"

abbreviation v_to_e_list :: "v list \<Rightarrow> e list" ("$$* _" 60) where
  "v_to_e_list ves \<equiv> map (\<lambda>v. $C v) ves"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>const_list vs; lholed = (LBase vs es')\<rbrakk> \<Longrightarrow> Lfilled 0 lholed es (vs @ es @ es')"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled_exact :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>lholed = (LBase [] [])\<rbrakk> \<Longrightarrow> Lfilled_exact 0 lholed es es"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled_exact k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled_exact (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

definition load_store_t_bounds :: "a \<Rightarrow> tp option \<Rightarrow> t \<Rightarrow> bool" where
  "load_store_t_bounds a tp t = (case tp of
                                   None \<Rightarrow> 2^a \<le> t_length t
                                 | Some tp \<Rightarrow> 2^a \<le> tp_length tp \<and> tp_length tp < t_length t \<and>  is_int_t t)"

definition memory_public_agree :: "(mem \<times> sec) \<Rightarrow> (mem \<times> sec) \<Rightarrow> bool" where
  "memory_public_agree x y = (x = y \<or> (mem_size (fst x) = mem_size (fst y) \<and> (snd x = Secret) \<and> (snd y = Secret)))"

abbreviation memories_public_agree :: "(mem \<times> sec) list \<Rightarrow> (mem \<times> sec) list \<Rightarrow> bool" where
  "memories_public_agree xs ys \<equiv> list_all2 memory_public_agree xs ys"

definition public_agree :: "v \<Rightarrow> v \<Rightarrow> bool" where
  "public_agree x y = (y = x \<or> ((typeof y) = (typeof x) \<and> is_secret_t (typeof x)))"

abbreviation publics_agree :: "v list \<Rightarrow> v list \<Rightarrow> bool" where
  "publics_agree xs ys \<equiv> list_all2 public_agree xs ys"

definition global_public_agree :: "global \<Rightarrow> global \<Rightarrow> bool" where
  "global_public_agree x y = (g_mut x = g_mut y \<and> public_agree (g_val x) (g_val y))"

abbreviation globals_public_agree :: "global list \<Rightarrow> global list \<Rightarrow> bool" where
  "globals_public_agree xs ys \<equiv> list_all2 global_public_agree xs ys"

definition store_public_agree :: "s \<Rightarrow> s \<Rightarrow> bool" where
  "store_public_agree s s' = (inst s = inst s' \<and>
                        funcs s = funcs s' \<and>
                        tab s = tab s' \<and>
                        memories_public_agree (mem s) (mem s') \<and>
                        globals_public_agree (globs s) (globs s'))"

inductive expr_public_agree :: "e \<Rightarrow> e \<Rightarrow> bool" where
  "expr_public_agree e e"
| "\<lbrakk>public_agree v v'\<rbrakk> \<Longrightarrow>
     expr_public_agree ($C v) ($C v')"
| "\<lbrakk>list_all2 expr_public_agree ($* bes) ($* bes')\<rbrakk> \<Longrightarrow>
     expr_public_agree ($Block tf bes) ($Block tf bes')"
| "\<lbrakk>list_all2 expr_public_agree ($* bes) ($* bes')\<rbrakk> \<Longrightarrow>
     expr_public_agree ($Loop tf bes) ($Loop tf bes')"
| "\<lbrakk>list_all2 expr_public_agree ($* bes1) ($* bes1'); list_all2 expr_public_agree ($* bes2) ($* bes2')\<rbrakk> \<Longrightarrow>
     expr_public_agree ($If tf bes1 bes2) ($If tf bes1' bes2')"
| "\<lbrakk>list_all2 expr_public_agree les les'; list_all2 expr_public_agree es es'\<rbrakk> \<Longrightarrow>
     expr_public_agree (Label n les es) (Label n les' es')"
| "\<lbrakk>publics_agree vs vs'; list_all2 expr_public_agree es es'\<rbrakk> \<Longrightarrow>
     expr_public_agree (Local n i vs es) (Local n i vs' es')"

abbreviation exprs_public_agree :: "e list \<Rightarrow> e list \<Rightarrow> bool" where
  "exprs_public_agree es es' \<equiv> list_all2 expr_public_agree es es'"

inductive lholed_public_agree :: " Lholed \<Rightarrow> Lholed \<Rightarrow> bool" where
  "\<lbrakk>exprs_public_agree ves ves'; exprs_public_agree es es'\<rbrakk> \<Longrightarrow> lholed_public_agree (LBase ves es) (LBase ves' es')"
| "\<lbrakk>lholed_public_agree LN LN'; exprs_public_agree ves ves'; exprs_public_agree les les'; exprs_public_agree es es'\<rbrakk> \<Longrightarrow>
     lholed_public_agree (LRec ves n les LN es) (LRec ves' n les' LN' es')"

definition cvt_i32 :: "sx option \<Rightarrow> v \<Rightarrow> i32 option" where
  "cvt_i32 sx v = (case v of
                   ConstInt32 _ c \<Rightarrow> None
                 | ConstInt64 _ c \<Rightarrow> Some (wasm_wrap c)
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f32 c
                                      | Some S \<Rightarrow> si32_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f64 c
                                      | Some S \<Rightarrow> si32_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_i64 :: "sx option \<Rightarrow> v \<Rightarrow> i64 option" where
  "cvt_i64 sx v = (case v of
                   ConstInt32 _ c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (wasm_extend_u c)
                                      | Some S \<Rightarrow> Some (wasm_extend_s c)
                                      | None \<Rightarrow> None)
                 | ConstInt64 _ c \<Rightarrow> None
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f32 c
                                      | Some S \<Rightarrow> si64_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f64 c
                                      | Some S \<Rightarrow> si64_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_f32 :: "sx option \<Rightarrow> v \<Rightarrow> f32 option" where
  "cvt_f32 sx v = (case v of
                   ConstInt32 _ c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 _ c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> None
                 | ConstFloat64 c \<Rightarrow> Some (wasm_demote c))"

definition cvt_f64 :: "sx option \<Rightarrow> v \<Rightarrow> f64 option" where
  "cvt_f64 sx v = (case v of
                   ConstInt32 _ c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 _ c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> Some (wasm_promote c)
                 | ConstFloat64 c \<Rightarrow> None)"

definition cvt :: "t \<Rightarrow> sx option \<Rightarrow> v \<Rightarrow> v option" where
  "cvt t sx v = (case t of
                 (T_i32 sec) \<Rightarrow> (case (cvt_i32 sx v) of Some c \<Rightarrow> Some (ConstInt32 sec c) | None \<Rightarrow> None)
               | (T_i64 sec) \<Rightarrow> (case (cvt_i64 sx v) of Some c \<Rightarrow> Some (ConstInt64 sec c) | None \<Rightarrow> None)
               | T_f32 \<Rightarrow> (case (cvt_f32 sx v) of Some c \<Rightarrow> Some (ConstFloat32 c) | None \<Rightarrow> None)
               | T_f64 \<Rightarrow> (case (cvt_f64 sx v) of Some c \<Rightarrow> Some (ConstFloat64 c) | None \<Rightarrow> None))"

definition bits :: "v \<Rightarrow> bytes" where
  "bits v = (case v of
               ConstInt32 _ c \<Rightarrow> (serialise_i32 c)
             | ConstInt64 _ c \<Rightarrow> (serialise_i64 c)
             | ConstFloat32 c \<Rightarrow> (serialise_f32 c)
             | ConstFloat64 c \<Rightarrow> (serialise_f64 c))"

definition bitzero :: "t \<Rightarrow> v" where
  "bitzero t = (case t of
                (T_i32 sec) \<Rightarrow> ConstInt32 sec 0
              | (T_i64 sec) \<Rightarrow> ConstInt64 sec 0
              | T_f32 \<Rightarrow> ConstFloat32 0
              | T_f64 \<Rightarrow> ConstFloat64 0)"

definition n_zeros :: "t list \<Rightarrow> v list" where
  "n_zeros ts = (map (\<lambda>t. bitzero t) ts)"

lemma is_int_t_exists:
  assumes "is_int_t t"
  shows "\<exists>sec. t = (T_i32 sec) \<or> t = (T_i64 sec)"
  using assms
  by (cases t) (auto simp add: is_int_t_def)

lemma is_float_t_exists:
  assumes "is_float_t t"
  shows "\<exists>sec. t = T_f32 \<or> t = T_f64"
  using assms
  by (cases t) (auto simp add: is_float_t_def)

lemma int_float_disjoint: "is_int_t t = -(is_float_t t)"
  by simp (metis is_float_t_def is_int_t_def t.exhaust t.simps(15-18))

lemma types_agree_imp_types_agree_insecure:
  assumes "types_agree t v"
  shows "types_agree_insecure t v"
  using assms
  unfolding types_agree_def types_agree_insecure_def
  by simp

lemma stab_unfold:
  assumes "stab s i j = Some cl"
  shows "\<exists>k. inst.tab ((inst s)!i) = Some k \<and> length ((tab s)!k) > j \<and>((tab s)!k)!j = Some cl"
proof -
  obtain k where have_k:"(inst.tab ((inst s)!i)) = Some k"
    using assms
    unfolding stab_def
    by fastforce
  hence s_o:"stab s i j = stab_s s k j"
    using assms
    unfolding stab_def
    by simp
  then obtain stabinst where stabinst_def:"stabinst = ((tab s)!k)"
    by blast
  hence "stab_s s k j = (stabinst!j) \<and> (length stabinst > j)"
    using assms s_o
    unfolding stab_s_def
    by (cases "(length stabinst > j)", auto)
  thus ?thesis
    using have_k stabinst_def assms s_o
    by auto
qed

lemma inj_basic: "inj Basic"
  by (meson e.inject(1) injI)

lemma inj_basic_econst: "inj (\<lambda>v. $C v)"
  by (simp add: inj_def)

lemma to_e_list_1:"[$ a] = $* [a]"
  by simp

lemma to_e_list_2:"[$ a, $ b] = $* [a, b]"
  by simp

lemma to_e_list_3:"[$ a, $ b, $ c] = $* [a, b, c]"
  by simp

lemma v_exists_b_e:"\<exists>ves. ($$*vs) = ($*ves)"
proof (induction vs)
  case (Cons a vs)
  thus ?case
  by (metis list.simps(9))
qed auto

lemma Lfilled_exact_imp_Lfilled:
  assumes "Lfilled_exact n lholed es LI"
  shows "Lfilled n lholed es LI"
  using assms
proof (induction rule: Lfilled_exact.induct)
  case (L0 lholed es)
  thus ?case
    using const_list_def Lfilled.intros(1)
    by fastforce
next
  case (LN vs lholed n es' l es'' k es lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_exact_app_imp_exists_Lfilled:
  assumes "const_list ves"
          "Lfilled_exact n lholed (ves@es) LI"
  shows "\<exists>lholed'. Lfilled n lholed' es LI"
  using assms(2,1)
proof (induction "(ves@es)" LI rule: Lfilled_exact.induct)
  case (L0 lholed)
  show ?case
    using Lfilled.intros(1)[OF L0(2), of _ "[]"]
    by fastforce
next
  case (LN vs lholed n es' l es'' k lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_imp_exists_Lfilled_exact:
  assumes "Lfilled n lholed es LI"
  shows "\<exists>lholed' ves es_c. const_list ves \<and> Lfilled_exact n lholed' (ves@es@es_c) LI"
  using assms Lfilled_exact.intros
  by (induction rule: Lfilled.induct) fastforce+

lemma n_zeros_typeof:
  "n_zeros ts = vs \<Longrightarrow> (ts = map typeof vs)"
proof (induction ts arbitrary: vs)
  case Nil
  thus ?case
    unfolding n_zeros_def
    by simp
next
  case (Cons t ts)
  obtain vs' where "n_zeros ts = vs'"
    using n_zeros_def
    by blast
  moreover
  have "typeof (bitzero t) = t"
    unfolding typeof_def bitzero_def
    by (cases t, simp_all)
  ultimately
  show ?case
    using Cons
    unfolding n_zeros_def
    by auto
qed

end


(*  Title:       Mutually recursive procedures
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

header "Hoare Logics for Mutually Recursive Procedure"

theory PsLang imports Main begin

subsection{* The language *}

typedecl state
typedecl pname

type_synonym bexp = "state \<Rightarrow> bool"

datatype
  com = Do "state \<Rightarrow> state set"
      | Semi  com com          ("_; _"  [60, 60] 10)
      | Cond  bexp com com     ("IF _ THEN _ ELSE _"  60)
      | While bexp com         ("WHILE _ DO _"  60)
      | CALL pname
      | Local "(state \<Rightarrow> state)" com "(state \<Rightarrow> state \<Rightarrow> state)"
               ("LOCAL _; _; _" [0,0,60] 60)

consts body :: "pname \<Rightarrow> com"

text{* We generalize from a single procedure to a whole set of
procedures following the ideas of von Oheimb~\cite{Oheimb-FSTTCS99}.
The basic setup is modified only in a few places:
\begin{itemize}
\item We introduce a new basic type @{typ pname} of procedure names.
\item Constant @{term body} is now of type @{typ"pname \<Rightarrow> com"}.
\item The @{term CALL} command now has an argument of type @{typ pname},
the name of the procedure that is to be called.
\end{itemize}
*}

inductive
  exec :: "state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"   ("_/ -_\<rightarrow>/ _" [50,0,50] 50)
where
    Do:     "t \<in> f s \<Longrightarrow> s -Do f\<rightarrow> t"

  | Semi:   "\<lbrakk> s0 -c1\<rightarrow> s1; s1 -c2\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c1;c2\<rightarrow> s2"

  | IfTrue:  "\<lbrakk> b s;  s -c1\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"
  | IfFalse: "\<lbrakk> \<not>b s; s -c2\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"

  | WhileFalse: "\<not>b s \<Longrightarrow> s -WHILE b DO c\<rightarrow> s"
  | WhileTrue:  "\<lbrakk> b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u \<rbrakk>
                \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"

  | Call: "s -body p\<rightarrow> t \<Longrightarrow> s -CALL p\<rightarrow> t"

  | Local: "f s -c\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g\<rightarrow> g s t"

lemma [iff]: "(s -c;d\<rightarrow> u) = (\<exists>t. s -c\<rightarrow> t \<and> t -d\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -IF b THEN c ELSE d\<rightarrow> t) =
              (s -if b s then c else d\<rightarrow> t)"
apply(rule iffI)
 apply(auto elim: exec.cases intro:exec.intros)
apply(auto intro:exec.intros split:split_if_asm)
done

lemma [iff]: "(s -CALL p\<rightarrow> t) = (s -body p\<rightarrow> t)"
by(blast elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -LOCAL f; c; g\<rightarrow> u) = (\<exists>t. f s -c\<rightarrow> t \<and> u = g s t)"
by(fastforce elim: exec.cases intro:exec.intros)

inductive
  execn :: "state \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> bool"   ("_/ -_-_\<rightarrow>/ _" [50,0,0,50] 50)
where
    Do:     "t \<in> f s \<Longrightarrow> s -Do f-n\<rightarrow> t"

  | Semi:   "\<lbrakk> s0 -c0-n\<rightarrow> s1; s1 -c1-n\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c0;c1-n\<rightarrow> s2"

  | IfTrue: "\<lbrakk> b s; s -c0-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c0 ELSE c1-n\<rightarrow> t"

  | IfFalse: "\<lbrakk> \<not>b s; s -c1-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c0 ELSE c1-n\<rightarrow> t"

  | WhileFalse: "\<not>b s \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> s"

  | WhileTrue:  "\<lbrakk> b s; s -c-n\<rightarrow> t; t -WHILE b DO c-n\<rightarrow> u \<rbrakk>
                \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> u"

  | Call:  "s -body p-n\<rightarrow> t \<Longrightarrow> s -CALL p-Suc n\<rightarrow> t"

  | Local: "f s -c-n\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g-n\<rightarrow> g s t"

lemma [iff]: "(s -Do f-n\<rightarrow> t) = (t \<in> f s)"
by(auto elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -c1;c2-n\<rightarrow> u) = (\<exists>t. s -c1-n\<rightarrow> t \<and> t -c2-n\<rightarrow> u)"
by(best elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -IF b THEN c ELSE d-n\<rightarrow> t) =
              (s -if b s then c else d-n\<rightarrow> t)"
apply auto
apply(blast elim: execn.cases intro:execn.intros)+
done

lemma [iff]: "(s -CALL p- 0\<rightarrow> t) = False"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -CALL p-Suc n\<rightarrow> t) = (s -body p-n\<rightarrow> t)"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -LOCAL f; c; g-n\<rightarrow> u) = (\<exists>t. f s -c-n\<rightarrow> t \<and> u = g s t)"
by(auto elim: execn.cases intro:execn.intros)

lemma exec_mono[rule_format]: "s -c-m\<rightarrow> t \<Longrightarrow> \<forall>n. m \<le> n \<longrightarrow> s -c-n\<rightarrow> t"
apply(erule execn.induct)
       apply(blast)
      apply(blast)
     apply(simp)
    apply(simp)
   apply(simp add:execn.intros)
  apply(blast intro:execn.intros)
 apply(clarify)
 apply(rename_tac m)
 apply(case_tac m)
  apply simp
 apply simp
apply blast
done

lemma exec_iff_execn: "(s -c\<rightarrow> t) = (\<exists>n. s -c-n\<rightarrow> t)"
apply(rule iffI)
 apply(erule exec.induct)
        apply blast
       apply clarify
       apply(rename_tac m n)
       apply(rule_tac x = "max m n" in exI)
       apply(fastforce intro:exec.intros exec_mono simp add:max_def)
      apply fastforce
     apply fastforce
    apply(blast intro:execn.intros)
   apply clarify
   apply(rename_tac m n)
   apply(rule_tac x = "max m n" in exI)
   apply(fastforce elim:execn.WhileTrue exec_mono simp add:max_def)
  apply blast
 apply blast
apply(erule exE, erule execn.induct)
       apply blast
      apply blast
     apply fastforce
    apply fastforce
   apply(erule exec.WhileFalse)
  apply(blast intro: exec.intros)
 apply blast
apply blast
done

lemma while_lemma[rule_format]:
"s -w-n\<rightarrow> t \<Longrightarrow> !b c. w = WHILE b DO c \<and> P s \<and>
                    (!s s'. P s \<and> b s \<and> s -c-n\<rightarrow> s' \<longrightarrow> P s') \<longrightarrow> P t \<and> \<not>b t"
apply(erule execn.induct)
apply clarify+
defer
apply clarify+
apply(subgoal_tac "P t")
apply blast
apply blast
done

lemma while_rule:
 "\<lbrakk>s -WHILE b DO c-n\<rightarrow> t; P s; \<And>s s'. \<lbrakk>P s; b s; s -c-n\<rightarrow> s' \<rbrakk> \<Longrightarrow> P s'\<rbrakk>
  \<Longrightarrow> P t \<and> \<not>b t"
apply(drule while_lemma)
prefer 2 apply assumption
apply blast
done

end