(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Thomas Sewell *)

section "Enumeration Instances for Words"

theory Word_Enum
imports Enumeration Word_Lib
begin

instantiation word :: (len) enum
begin

definition
  "(enum_class.enum :: ('a :: len) word list) \<equiv> map of_nat [0 ..< 2 ^ LENGTH('a)]"

definition
  "enum_class.enum_all (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Ball UNIV P"

definition
  "enum_class.enum_ex (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Bex UNIV P"

instance
  apply (intro_classes)
     apply (force simp: enum_word_def)
    apply (simp add: distinct_map enum_word_def)
    apply (rule subset_inj_on, rule word_unat.Abs_inj_on)
    apply (clarsimp simp add: unats_def)
   apply (simp add: enum_all_word_def)
  apply (simp add: enum_ex_word_def)
  done

end

lemma fromEnum_unat[simp]: "fromEnum (x :: 'a::len word) = unat x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a::len word list)" by (auto intro: the_index_bounded)
  moreover
  { fix y assume "of_nat y = x"
    moreover assume "y < 2 ^ LENGTH('a)"
    ultimately have "y = unat x" using of_nat_inverse by fastforce
  }
  ultimately
  show ?thesis by (simp add: fromEnum_def enum_word_def)
qed

lemma length_word_enum: "length (enum :: 'a :: len word list) = 2 ^ LENGTH('a)"
  by (simp add: enum_word_def)

lemma toEnum_of_nat[simp]: "n < 2 ^ LENGTH('a) \<Longrightarrow> (toEnum n :: 'a :: len word) = of_nat n"
  by (simp add: toEnum_def length_word_enum enum_word_def)

declare of_nat_diff [simp]

instantiation word :: (len) enumeration_both
begin

definition
  enum_alt_word_def: "enum_alt \<equiv> alt_from_ord (enum :: ('a :: len) word list)"

instance
  by (intro_classes, simp add: enum_alt_word_def)

end

definition
  upto_enum_step :: "('a :: len) word \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word list" ("[_ , _ .e. _]")
where
  "upto_enum_step a b c \<equiv>
      if c < a then [] else map (\<lambda>x. a + x * (b - a)) [0 .e. (c - a) div (b - a)]"
  (* in the wraparound case, bad things happen. *)

lemma maxBound_word:
  "(maxBound::'a::len word) = -1"
  by (simp add: maxBound_def enum_word_def last_map)

lemma minBound_word:
  "(minBound::'a::len word) = 0"
  by (simp add: minBound_def enum_word_def upt_conv_Cons)

lemma maxBound_max_word:
  "(maxBound::'a::len word) = max_word"
  by (simp add: maxBound_word max_word_minus [symmetric])

end


(*  Title:      HOL/Proofs/Lambda/StrongNorm.thy
    Author:     Stefan Berghofer
    Copyright   2000 TU Muenchen
*)

section \<open>Strong normalization for simply-typed lambda calculus\<close>

theory StrongNorm imports LambdaType InductTermi begin

text \<open>
Formalization by Stefan Berghofer. Partly based on a paper proof by
Felix Joachimski and Ralph Matthes @{cite "Matthes-Joachimski-AML"}.
\<close>

subsection \<open>Properties of \<open>IT\<close>\<close>

lemma lift_IT [intro!]: "IT t \<Longrightarrow> IT (lift t i)"
  apply (induct arbitrary: i set: IT)
    apply (simp (no_asm))
    apply (rule conjI)
     apply
      (rule impI,
       rule IT.Var,
       erule listsp.induct,
       simp (no_asm),
       simp (no_asm),
       rule listsp.Cons,
       blast,
       assumption)+
     apply auto
   done

lemma lifts_IT: "listsp IT ts \<Longrightarrow> listsp IT (map (\<lambda>t. lift t 0) ts)"
  by (induct ts) auto

lemma subst_Var_IT: "IT r \<Longrightarrow> IT (r[Var i/j])"
  apply (induct arbitrary: i j set: IT)
    txt \<open>Case @{term Var}:\<close>
    apply (simp (no_asm) add: subst_Var)
    apply
    ((rule conjI impI)+,
      rule IT.Var,
      erule listsp.induct,
      simp (no_asm),
      simp (no_asm),
      rule listsp.Cons,
      fast,
      assumption)+
   txt \<open>Case @{term Lambda}:\<close>
   apply atomize
   apply simp
   apply (rule IT.Lambda)
   apply fast
  txt \<open>Case @{term Beta}:\<close>
  apply atomize
  apply (simp (no_asm_use) add: subst_subst [symmetric])
  apply (rule IT.Beta)
   apply auto
  done

lemma Var_IT: "IT (Var n)"
  apply (subgoal_tac "IT (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule IT.Var)
  apply (rule listsp.Nil)
  done

lemma app_Var_IT: "IT t \<Longrightarrow> IT (t \<degree> Var i)"
  apply (induct set: IT)
    apply (subst app_last)
    apply (rule IT.Var)
    apply simp
    apply (rule listsp.Cons)
     apply (rule Var_IT)
    apply (rule listsp.Nil)
   apply (rule IT.Beta [where ?ss = "[]", unfolded foldl_Nil [THEN eq_reflection]])
    apply (erule subst_Var_IT)
   apply (rule Var_IT)
  apply (subst app_last)
  apply (rule IT.Beta)
   apply (subst app_last [symmetric])
   apply assumption
  apply assumption
  done

subsection \<open>Well-typed substitution preserves termination\<close>

lemma subst_type_IT:
  "\<And>t e T u i. IT t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    IT u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> IT (t[u/i])"
  (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
proof (induct U)
  fix T t
  assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
  assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
  assume "IT t"
  thus "\<And>e T' u i. PROP ?Q t e T' u i T"
  proof induct
    fix e T' u i
    assume uIT: "IT u"
    assume uT: "e \<turnstile> u : T"
    {
      case (Var rs n e1 T'1 u1 i1)
      assume nT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree>\<degree> rs : T'"
      let ?ty = "\<lambda>t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'"
      let ?R = "\<lambda>t. \<forall>e T' u i.
        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> IT u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> IT (t[u/i])"
      show "IT ((Var n \<degree>\<degree> rs)[u/i])"
      proof (cases "n = i")
        case True
        show ?thesis
        proof (cases rs)
          case Nil
          with uIT True show ?thesis by simp
        next
          case (Cons a as)
          with nT have "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a \<degree>\<degree> as : T'" by simp
          then obtain Ts
              where headT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a : Ts \<Rrightarrow> T'"
              and argsT: "e\<langle>i:T\<rangle> \<tturnstile> as : Ts"
            by (rule list_app_typeE)
          from headT obtain T''
              where varT: "e\<langle>i:T\<rangle> \<turnstile> Var n : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
              and argT: "e\<langle>i:T\<rangle> \<turnstile> a : T''"
            by cases simp_all
          from varT True have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'"
            by cases auto
          with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
          from T have "IT ((Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0])"
          proof (rule MI2)
            from T have "IT ((lift u 0 \<degree> Var 0)[a[u/i]/0])"
            proof (rule MI1)
              have "IT (lift u 0)" by (rule lift_IT [OF uIT])
              thus "IT (lift u 0 \<degree> Var 0)" by (rule app_Var_IT)
              show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
              proof (rule typing.App)
                show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
                  by (rule lift_type) (rule uT')
                show "e\<langle>0:T''\<rangle> \<turnstile> Var 0 : T''"
                  by (rule typing.Var) simp
              qed
              from Var have "?R a" by cases (simp_all add: Cons)
              with argT uIT uT show "IT (a[u/i])" by simp
              from argT uT show "e \<turnstile> a[u/i] : T''"
                by (rule subst_lemma) simp
            qed
            thus "IT (u \<degree> a[u/i])" by simp
            from Var have "listsp ?R as"
              by cases (simp_all add: Cons)
            moreover from argsT have "listsp ?ty as"
              by (rule lists_typings)
            ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) as"
              by simp
            hence "listsp IT (map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as))"
              (is "listsp IT (?ls as)")
            proof induct
              case Nil
              show ?case by fastforce
            next
              case (Cons b bs)
              hence I: "?R b" by simp
              from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> b : U" by fast
              with uT uIT I have "IT (b[u/i])" by simp
              hence "IT (lift (b[u/i]) 0)" by (rule lift_IT)
              hence "listsp IT (lift (b[u/i]) 0 # ?ls bs)"
                by (rule listsp.Cons) (rule Cons)
              thus ?case by simp
            qed
            thus "IT (Var 0 \<degree>\<degree> ?ls as)" by (rule IT.Var)
            have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'"
              by (rule typing.Var) simp
            moreover from uT argsT have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
              by (rule substs_lemma)
            hence "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> ?ls as : Ts"
              by (rule lift_types)
            ultimately show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> ?ls as : T'"
              by (rule list_app_typeI)
            from argT uT have "e \<turnstile> a[u/i] : T''"
              by (rule subst_lemma) (rule refl)
            with uT' show "e \<turnstile> u \<degree> a[u/i] : Ts \<Rrightarrow> T'"
              by (rule typing.App)
          qed
          with Cons True show ?thesis
            by (simp add: comp_def)
        qed
      next
        case False
        from Var have "listsp ?R rs" by simp
        moreover from nT obtain Ts where "e\<langle>i:T\<rangle> \<tturnstile> rs : Ts"
          by (rule list_app_typeE)
        hence "listsp ?ty rs" by (rule lists_typings)
        ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) rs"
          by simp
        hence "listsp IT (map (\<lambda>x. x[u/i]) rs)"
        proof induct
          case Nil
          show ?case by fastforce
        next
          case (Cons a as)
          hence I: "?R a" by simp
          from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> a : U" by fast
          with uT uIT I have "IT (a[u/i])" by simp
          hence "listsp IT (a[u/i] # map (\<lambda>t. t[u/i]) as)"
            by (rule listsp.Cons) (rule Cons)
          thus ?case by simp
        qed
        with False show ?thesis by (auto simp add: subst_Var)
      qed
    next
      case (Lambda r e1 T'1 u1 i1)
      assume "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
        and "\<And>e T' u i. PROP ?Q r e T' u i T"
      with uIT uT show "IT (Abs r[u/i])"
        by fastforce
    next
      case (Beta r a as e1 T'1 u1 i1)
      assume T: "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a \<degree>\<degree> as : T'"
      assume SI1: "\<And>e T' u i. PROP ?Q (r[a/0] \<degree>\<degree> as) e T' u i T"
      assume SI2: "\<And>e T' u i. PROP ?Q a e T' u i T"
      have "IT (Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
      proof (rule IT.Beta)
        have "Abs r \<degree> a \<degree>\<degree> as \<rightarrow>\<^sub>\<beta> r[a/0] \<degree>\<degree> as"
          by (rule apps_preserves_beta) (rule beta.beta)
        with T have "e\<langle>i:T\<rangle> \<turnstile> r[a/0] \<degree>\<degree> as : T'"
          by (rule subject_reduction)
        hence "IT ((r[a/0] \<degree>\<degree> as)[u/i])"
          using uIT uT by (rule SI1)
        thus "IT (r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
          by (simp del: subst_map add: subst_subst subst_map [symmetric])
        from T obtain U where "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a : U"
          by (rule list_app_typeE) fast
        then obtain T'' where "e\<langle>i:T\<rangle> \<turnstile> a : T''" by cases simp_all
        thus "IT (a[u/i])" using uIT uT by (rule SI2)
      qed
      thus "IT ((Abs r \<degree> a \<degree>\<degree> as)[u/i])" by simp
    }
  qed
qed

subsection \<open>Well-typed terms are strongly normalizing\<close>

lemma type_implies_IT:
  assumes "e \<turnstile> t : T"
  shows "IT t"
  using assms
proof induct
  case Var
  show ?case by (rule Var_IT)
next
  case Abs
  show ?case by (rule IT.Lambda) (rule Abs)
next
  case (App e s T U t)
  have "IT ((Var 0 \<degree> lift t 0)[s/0])"
  proof (rule subst_type_IT)
    have "IT (lift t 0)" using \<open>IT t\<close> by (rule lift_IT)
    hence "listsp IT [lift t 0]" by (rule listsp.Cons) (rule listsp.Nil)
    hence "IT (Var 0 \<degree>\<degree> [lift t 0])" by (rule IT.Var)
    also have "Var 0 \<degree>\<degree> [lift t 0] = Var 0 \<degree> lift t 0" by simp
    finally show "IT \<dots>" .
    have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
      by (rule typing.Var) simp
    moreover have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t 0 : T"
      by (rule lift_type) (rule App.hyps)
    ultimately show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t 0 : U"
      by (rule typing.App)
    show "IT s" by fact
    show "e \<turnstile> s : T \<Rightarrow> U" by fact
  qed
  thus ?case by simp
qed

theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> termip beta t"
proof -
  assume "e \<turnstile> t : T"
  hence "IT t" by (rule type_implies_IT)
  thus ?thesis by (rule IT_implies_termi)
qed

end


section "Unique Identifiers"
theory unique_ids
  imports execution_invariants
    "fuzzyrule.fuzzyrule"
    "fuzzyrule.fuzzy_goal_cases"
begin

text \<open>In this section we prove some general properties about unique identifiers.

In general, we assume that procedure implementations are well behaved and cannot produce unique
identifiers out of thin air (i.e. ``guess'' them).
We define this property inductively:
\<close>

fun action_inputs where
  "action_inputs (ALocal ls) = {}"
| "action_inputs (ANewId i) = uniqueIds i"
| "action_inputs (ABeginAtomic t c) =  {}"
| "action_inputs AEndAtomic = {}"
| "action_inputs (ADbOp c opr res) = uniqueIds res"
| "action_inputs (AInvoc proc) = uniqueIds proc"
| "action_inputs (AReturn r) = {}"
| "action_inputs ACrash   = {}"
| "action_inputs (AInvcheck b) = {}"

lemma action_inputs_cases:
 "x \<in> action_inputs a \<longleftrightarrow>
(case a of
    ANewId i \<Rightarrow> x \<in> uniqueIds i
  | ADbOp c opr res \<Rightarrow> x \<in> uniqueIds res
  | AInvoc proc \<Rightarrow> x \<in> uniqueIds proc
  | _ \<Rightarrow> False)"
  by (auto split: action.splits)

fun action_outputs where
  "action_outputs (ALocal ls) = {}"
| "action_outputs (ANewId i) = {}"
| "action_outputs (ABeginAtomic t c) =  {}"
| "action_outputs AEndAtomic = {}"
| "action_outputs (ADbOp c opr res) = uniqueIds opr"
| "action_outputs (AInvoc proc) = {}"
| "action_outputs (AReturn r) = uniqueIds r"
| "action_outputs ACrash   = {}"
| "action_outputs (AInvcheck b) = {}"

definition trace_inputs :: "('proc::valueType, 'op, 'any::valueType) trace \<Rightarrow> invocId \<Rightarrow> uniqueId set" where
"trace_inputs trace i \<equiv> \<Union>((action_inputs \<circ> snd) ` (Set.filter (\<lambda>a. fst a = i) (set trace)))"

definition trace_outputs :: "('proc, 'op::valueType, 'any::valueType) trace \<Rightarrow>  invocId \<Rightarrow> uniqueId set" where
"trace_outputs trace i \<equiv> \<Union>((action_outputs \<circ> snd) ` (Set.filter (\<lambda>a. fst a = i) (set trace)))"

lemma trace_inputs_empty: "trace_inputs [] i = {}"
  by (simp add: trace_inputs_def)

lemma trace_outputs_empty: "trace_outputs [] i = {}"
  by (simp add: trace_outputs_def)

lemma trace_inputs_append: "trace_inputs (a@b) i = trace_inputs a i \<union> trace_inputs b i"
  by (auto simp add: trace_inputs_def Set.filter_def)

lemma trace_outputs_append: "trace_outputs (a@b) i = trace_outputs a i \<union> trace_outputs b i"
  by (auto simp add: trace_outputs_def Set.filter_def)

lemma trace_inputs_cons: "trace_inputs (a#b) i = (if get_invoc a = i then action_inputs (get_action a) else {}) \<union> trace_inputs b i"
  by (auto simp add: trace_inputs_def Set.filter_def)

lemma trace_outputs_cons: "trace_outputs (a#b) i = (if get_invoc a = i then action_outputs (get_action a) else {}) \<union> trace_outputs b i"
  by (auto simp add: trace_outputs_def Set.filter_def)

\<comment> \<open>uids are the ids that are already known in invocation i.
The property states that no further unique ids may be produced in the output
of invocation i without obtaining them as input first.\<close>
definition
"invocation_cannot_guess_ids uids i S \<equiv>
 \<forall>tr a S'. (S ~~ tr@[a] \<leadsto>* S')
  \<longrightarrow> trace_outputs (tr@[a]) i \<subseteq> trace_inputs tr i \<union> uids"

definition
"invocations_cannot_guess_ids progr \<equiv>
  \<forall>i. invocation_cannot_guess_ids {} i (initialState progr)"

lemmas use_invocation_cannot_guess_ids = invocation_cannot_guess_ids_def[THEN meta_eq_to_obj_eq, THEN iffD1, rule_format]

text \<open>Alternative definition for readability: \<close>
lemma invocations_cannot_guess_ids_def2:
  "invocations_cannot_guess_ids progr \<longleftrightarrow>
   (\<forall>tr i a S' uid.
    (initialState progr ~~ tr@[(i,a)] \<leadsto>* S')
    \<and> uid \<in> action_outputs a
    \<longrightarrow> (\<exists>a'. (i,a')\<in>set tr \<and> uid \<in> action_inputs a'))"

proof (rule iffI, goal_cases A B)
  case A
  then show ?case
    apply (auto simp add: invocations_cannot_guess_ids_def invocation_cannot_guess_ids_def trace_outputs_def trace_inputs_def)
    subgoal for tr i a S'
      apply (drule spec[where x=i])
      apply (drule spec[where x=tr])
      apply (drule spec[where x=i])
      apply (drule spec[where x=a])
      apply auto
      using subsetD by fastforce
    done
next
  case B
  show ?case
    unfolding invocations_cannot_guess_ids_def invocation_cannot_guess_ids_def trace_outputs_def trace_inputs_def
  proof (intro allI impI subsetI)
    fix i tr a S' x
    assume steps: "initialState progr ~~ tr @ [a] \<leadsto>* S'"
      and x_out: "x \<in> \<Union> ((action_outputs \<circ> get_action) ` Set.filter (\<lambda>a. get_invoc a = i) (set (tr @ [a])))"

    from x_out
    obtain k ao where "(tr@[a]) ! k = (i, ao)"
      and "k \<le> length tr"
      and "x \<in> action_outputs ao"
      by (auto simp add:  in_set_conv_nth   split: if_splits)
        (force,  (use nth_append_first in fastforce)+)

    obtain rest_tr where "tr@[a] = take (Suc k) (tr@[a]) @ rest_tr"
      by (metis append_take_drop_id)

    hence "tr@[a] = take k tr @ [(i, ao)] @ rest_tr"
      by (smt \<open>(tr @ [a]) ! k = (i, ao)\<close> \<open>k \<le> length tr\<close> append.assoc butlast_snoc le_imp_less_Suc length_append_singleton take_Suc_conv_app_nth take_butlast)

    with steps
    obtain S''
      where steps': "initialState progr ~~ take k tr @ [(i, ao)] \<leadsto>* S''"
      using steps_append by fastforce

    from B[unfolded imp_conjL, rule_format, OF steps' \<open>x \<in> action_outputs ao\<close>]
    obtain ai
      where "(i, ai) \<in> set (take k tr)"
        and "x \<in> action_inputs ai"
      by blast

    from this
    show "x \<in> \<Union> ((action_inputs \<circ> get_action) ` Set.filter (\<lambda>a. get_invoc a = i) (set tr)) \<union> {}"
      using in_set_takeD  by auto force
  qed
qed

lemma show_invocation_cannot_guess_ids:
  assumes a: "\<And>x tr a S'. S ~~ tr@[(i, a)] \<leadsto>* S'
      \<Longrightarrow> x \<in> action_outputs a
      \<Longrightarrow> x \<notin> uids
      \<Longrightarrow> x \<in> trace_inputs tr i"
  shows "invocation_cannot_guess_ids uids i S"
  unfolding invocation_cannot_guess_ids_def
proof auto
  fix tr i' action x S''
  assume a0: "x \<in> trace_outputs (tr @ [(i', action)]) i"
    and a1: "x \<notin> uids"
    and steps: "S ~~ tr @ [(i', action)] \<leadsto>* S''"

  show "x \<in> trace_inputs tr i"
    using a0
  proof (auto simp add: trace_outputs_def split: if_splits)

    show "x \<in> trace_inputs tr i"
      if c0: "i' = i"
        and c1: "x \<in> action_outputs action"
      using steps
    proof (fuzzy_rule a)
      show "i'=i" using `i' = i` .
      show "x \<in> action_outputs action"
        using `x \<in> action_outputs action` by simp
      show "x \<notin> uids" using a1 by simp
    qed

    fix action
    assume  "x \<in> action_outputs action"
      and  "(i, action) \<in> set tr"

    from `(i, action) \<in> set tr`
    obtain k where "k < length tr" and "tr!k = (i,action)"
      by (meson in_set_conv_nth)

    obtain S1
      where "S ~~ take (Suc k) tr \<leadsto>* S1"
      by (metis split_take steps steps_append)

    have "x \<in> trace_inputs (take k tr) i"
    proof (rule a)
      show "S ~~ take k tr @ [(i,action)] \<leadsto>* S1"
        using \<open>S ~~ take (Suc k) tr \<leadsto>* S1\<close> \<open>k < length tr\<close> \<open>tr ! k = (i, action)\<close> take_Suc_conv_app_nth by fastforce

      show "x \<in> action_outputs action"
        by (simp add: \<open>x \<in> action_outputs action\<close>)

      show "x \<notin> uids"
        by (simp add: a1)
    qed

    thus "x \<in> trace_inputs tr i"
      by (auto simp add: trace_inputs_def Set.filter_def dest: in_set_takeD)
    thus "x \<in> trace_inputs tr i" .
  qed
qed

lemma invocation_cannot_guess_ids_step:
  assumes "invocation_cannot_guess_ids uids i S"
    and step: "S ~~ (i, a) \<leadsto> S'"
    and "x \<in> action_outputs a"
  shows "x \<in> uids"
proof -
  from step have steps: "S ~~ []@[(i, a)] \<leadsto>* S'"
    by (simp add: steps_single)
  from use_invocation_cannot_guess_ids[OF `invocation_cannot_guess_ids uids i S` steps]
  have "trace_outputs [(i, a)] i \<subseteq> uids"
    by (auto simp add: trace_inputs_def)
  hence "action_outputs a \<subseteq>  uids"
    by (auto simp add: trace_outputs_def trace_inputs_def)
  with `x \<in> action_outputs a`
  show  ?thesis
    by auto
qed

lemma  show_invocation_cannot_guess_ids_step:
 assumes "invocation_cannot_guess_ids uids i S"
    and step: "S ~~ (i, a) \<leadsto> S'"
  shows "invocation_cannot_guess_ids (uids \<union> action_inputs a) i S'"
  unfolding invocation_cannot_guess_ids_def
proof (intro allI impI)
  fix tr aa S'a
  assume a0: "S' ~~ tr @ [aa] \<leadsto>* S'a"

  with step
  have S_steps: "S ~~ ((i,a)#tr) @ [aa] \<leadsto>* S'a"
    using steps_appendFront by fastforce

  from use_invocation_cannot_guess_ids[OF `invocation_cannot_guess_ids uids i S` S_steps]
  show "trace_outputs (tr @ [aa]) i \<subseteq> trace_inputs tr i \<union> (uids \<union> action_inputs a)"
    by (auto simp add: trace_outputs_def trace_inputs_def)
qed

lemma  show_invocation_cannot_guess_ids_step_other:
  assumes "invocation_cannot_guess_ids uids i S"
    and step: "S ~~ (i', a) \<leadsto> S'"
    and "i' \<noteq> i"
  shows "invocation_cannot_guess_ids uids i S'"
  unfolding invocation_cannot_guess_ids_def
proof (intro allI impI)
  fix tr aa S'a
  assume a0: "S' ~~ tr @ [aa] \<leadsto>* S'a"

  with step
  have S_steps: "S ~~ ((i',a)#tr) @ [aa] \<leadsto>* S'a"
    using steps_appendFront by fastforce

  from use_invocation_cannot_guess_ids[OF `invocation_cannot_guess_ids uids i S` S_steps]
  show "trace_outputs (tr @ [aa]) i \<subseteq> trace_inputs tr i \<union> uids"
    using `i' \<noteq> i`
    by (auto simp add: trace_outputs_def trace_inputs_def)
qed

(* TODO transfer this to local states, procedures, programs  *)
(* TODO show procedure_cannot_guess_ids implies the semantic property *)
(* TODO show that syntactic property for toImpl with loops implies semantic property *)

definition query_cannot_guess_ids :: "uniqueId set \<Rightarrow> (('op::valueType, 'any::valueType) operationContext \<Rightarrow> 'any \<Rightarrow> bool) \<Rightarrow> bool"  where
  "query_cannot_guess_ids oprUids spec \<equiv>
  \<forall>ctxt res.
   spec ctxt res \<longrightarrow> uniqueIds res \<subseteq> oprUids \<union> \<Union>{uniqueIds (call_operation c) | cId c. calls ctxt cId \<triangleq> c}"

lemma exists_call_expand:
"(\<exists>c. P c) \<longleftrightarrow> (\<exists>op r. P (Call op r))"
  by (auto, metis call.collapse)

lemma query_cannot_guess_ids_def2:
  "query_cannot_guess_ids oprUids spec =
  (\<forall>ctxt res x.
   spec ctxt res
 \<longrightarrow> x \<in> uniqueIds res
 \<longrightarrow> x \<notin> oprUids
 \<longrightarrow> (\<exists>cId opr res. calls ctxt cId \<triangleq> Call opr res \<and> x \<in> uniqueIds opr))"
  by (auto simp add: query_cannot_guess_ids_def subset_iff exists_call_expand, blast+)

definition queries_cannot_guess_ids :: "('op \<Rightarrow> ('op::valueType, 'any::valueType) operationContext \<Rightarrow> 'any \<Rightarrow> bool) \<Rightarrow> bool"  where
  "queries_cannot_guess_ids spec \<equiv>
  \<forall>opr. query_cannot_guess_ids (uniqueIds opr) (spec opr)"

lemma queries_cannot_guess_ids_def2:
  "queries_cannot_guess_ids qry =
  (\<forall>opr ctxt res x.
   qry opr ctxt res
 \<longrightarrow> x \<in> uniqueIds res
 \<longrightarrow> x \<notin> uniqueIds opr
 \<longrightarrow> (\<exists>cId opr res. calls ctxt cId \<triangleq> Call opr res \<and> x \<in> uniqueIds opr))"
  by (auto simp add: queries_cannot_guess_ids_def query_cannot_guess_ids_def2)

definition program_wellFormed :: " ('proc::valueType, 'ls, 'op::valueType, 'any::valueType) prog \<Rightarrow> bool" where
  "program_wellFormed progr \<equiv>
   invocations_cannot_guess_ids progr
 \<and> queries_cannot_guess_ids (querySpec progr)
"

lemma exists_elim_h: "\<lbrakk>P x; Q x\<rbrakk> \<Longrightarrow> \<exists>x. P x \<and> Q x" for P Q x
  by auto

lemma wf_knownIds_subset_generatedIds_h:
  fixes S :: "('proc::valueType, 'ls, 'op::valueType, 'any::valueType) state"
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
  shows "\<And>i. \<exists>uids\<subseteq>dom (generatedIds S). invocation_cannot_guess_ids uids i S"
    and "knownIds S \<subseteq> dom (generatedIds S)"
    and "\<And>c opr r. calls S c \<triangleq> Call opr r \<Longrightarrow> uniqueIds opr \<subseteq> dom (generatedIds S)"
    and "\<And>c opr r. calls S c \<triangleq> Call opr r \<Longrightarrow> uniqueIds r \<subseteq> dom (generatedIds S)"

  using wf prog_wf
proof -

  from wf prog_wf
  have H: "(\<forall>i. (\<exists>uids. uids \<subseteq> dom (generatedIds S) \<and> invocation_cannot_guess_ids uids i S))
       \<and> (knownIds S \<subseteq> dom (generatedIds S))
       \<and> (\<forall>c opr r. calls S c \<triangleq> Call opr r \<longrightarrow> uniqueIds opr \<subseteq> dom (generatedIds S) \<and> uniqueIds r \<subseteq> dom (generatedIds S))"
  proof (induct rule: wellFormed_induct)
    case initial
    then show ?case
      by (auto simp add: invocations_cannot_guess_ids_def program_wellFormed_def initialState_def)
  next
    case (step S1 a S2)

    obtain progr where [simp]: "prog S1 = progr"
      by auto

    have [simp]: "prog S2 = progr"
      using \<open>prog S1 = progr\<close> prog_inv step.hyps(3) by blast

    have  prog_wf: "program_wellFormed progr"
      using \<open>prog S2 = progr\<close> step.prems by blast

    from prog_wf
    have "invocations_cannot_guess_ids progr"
      and "queries_cannot_guess_ids (querySpec progr)"
      using program_wellFormed_def by auto

    have inv1: "(\<exists>uids\<subseteq>dom (generatedIds S1). invocation_cannot_guess_ids uids i S1)" for i
      using \<open>prog S1 = progr\<close> step.hyps(2) step.prems  by auto

    have inv2: "knownIds S1 \<subseteq> dom (generatedIds S1)"
      using \<open>prog S1 = progr\<close> prog_wf step.hyps(2) by blast

    have inv3: "uniqueIds opr \<subseteq> dom (generatedIds S1)"
      if "calls S1 c \<triangleq> Call opr r"
      for c opr r
      using \<open>prog S1 = progr\<close> prog_wf step.hyps(2) that by blast

    have inv4r: "x \<in> dom (generatedIds S1)"
      if "calls S1 c \<triangleq> Call opr r"
        and "x \<in> uniqueIds r"
      for c opr r x
      using \<open>prog S1 = progr\<close> prog_wf step.hyps(2) that(1) that(2) by blast

    have inv4o: "x \<in> dom (generatedIds S1)"
      if "calls S1 c \<triangleq> Call opr r"
        and "x \<in> uniqueIds opr"
      for c opr r x
      using inv3 that(1) that(2) by blast

    obtain action i where a_def: "a = (i, action)"
      using surjective_pairing by blast

    obtain uids_i
      where inv1_i1: "uids_i \<subseteq>  dom (generatedIds S1)"
        and inv1_i: "invocation_cannot_guess_ids uids_i i S1"
      using inv1 by auto

    from `S1 ~~ a \<leadsto> S2`[simplified a_def]
    have "S1 ~~ (i, action) \<leadsto> S2" .

    show "?case"
    proof (intro allI conjI impI)

      have i_in_out: "x \<in> uids_i"
        if "x \<in> action_outputs action"
        for x
        using that invocation_cannot_guess_ids_step[OF `invocation_cannot_guess_ids uids_i i S1` `S1 ~~ (i, action) \<leadsto> S2`]
        by auto

      show "knownIds S2 \<subseteq> dom (generatedIds S2)"
        using i_in_out `S1 ~~ (i, action) \<leadsto> S2` inv2 inv1_i1
        by (auto simp add: step.simps, blast+)

      from queries_cannot_guess_ids_def2[THEN iffD1, rule_format, OF `queries_cannot_guess_ids (querySpec progr)`]
      have qry_wf: "\<exists>cId opr res. calls ctxt cId \<triangleq> Call opr res \<and> x \<in> uniqueIds opr"
        if c0: "querySpec progr opr ctxt res"
          and c2: "x \<notin> uniqueIds opr"
          and c1: "x \<in> uniqueIds res"
        for ctxt opr res x
        using that by auto

      have qryOk: "x \<notin> uniqueIds res"
        if q: "querySpec progr Op (getContextH (calls S1) (happensBefore S1) (Some vis)) res"
          and no: "x \<notin> uniqueIds Op"
          and noG: "x \<notin> dom (generatedIds S1)"
        for Op vis res x
      proof
        assume " x \<in> uniqueIds res"
        from qry_wf[OF q no `x \<in> uniqueIds res`]
        obtain cId opr res where "cId \<in> vis" and  "x \<in> uniqueIds opr" and "calls S1 cId \<triangleq> Call opr res"
          by (auto simp add: getContextH_def restrict_map_def split: if_splits)
        thus False
          using inv4o noG by blast
      qed

      have qryOk': "\<exists>i. generatedIds S1 x \<triangleq> i"
        if q: "querySpec progr Op (getContextH (calls S1) (happensBefore S1) (Some vis)) res"
          and no: "x \<notin> uniqueIds Op"
          and noG: "x \<in> uniqueIds res"
        for Op vis res x
        by (meson domD no noG q qryOk)

      have "x \<in> dom (generatedIds S2)"
        if "x \<in> action_outputs action"
        for x
        using `S1 ~~ (i, action) \<leadsto> S2` that
        by (meson domIff generatedIds_mono2_rev inv1_i inv1_i1 invocation_cannot_guess_ids_step subsetD)

      show "\<exists>uids\<subseteq>dom (generatedIds S2). invocation_cannot_guess_ids uids i' S2"
        for i'
      proof (cases "i' = i")
        case True
        have "uids_i \<union> action_inputs action \<subseteq> dom (generatedIds S2)"
          using `S1 ~~ (i, action) \<leadsto> S2` inv1_i1 i_in_out
          apply (auto simp add: step.simps)
          apply (meson in_dom qryOk')
          using inv2 by blast

        moreover
        have "invocation_cannot_guess_ids (uids_i \<union> action_inputs action) i S2"
          using \<open>S1 ~~ (i, action) \<leadsto> S2\<close> inv1_i show_invocation_cannot_guess_ids_step by blast

        ultimately
        show ?thesis
          using True by blast
      next
        case False
        obtain uids where "uids\<subseteq>dom (generatedIds S1)" and "invocation_cannot_guess_ids uids i' S1"
          using inv1 by auto

        show ?thesis
        proof (intro exI conjI)
          show "uids \<subseteq> dom (generatedIds S2)"
            using \<open>S1 ~~ (i, action) \<leadsto> S2\<close> \<open>uids \<subseteq> dom (generatedIds S1)\<close> generatedIds_mono map_le_implies_dom_le by blast
          show "invocation_cannot_guess_ids uids i' S2"
            using False \<open>S1 ~~ (i, action) \<leadsto> S2\<close> \<open>invocation_cannot_guess_ids uids i' S1\<close> show_invocation_cannot_guess_ids_step_other by blast
        qed
      qed

      show "uniqueIds opr \<subseteq> dom (generatedIds S2)"
        if c0: "calls S2 c \<triangleq> Call opr r"
        for  c opr r
        using `S1 ~~ a \<leadsto> S2` that inv3 a_def action_outputs.simps(5) i_in_out inv1_i1
        by (auto simp add: step.simps split: if_splits) blast+

      show "uniqueIds r \<subseteq> dom (generatedIds S2)"
        if c0: "calls S2 c \<triangleq> Call opr r"
        for  c opr r
        using `S1 ~~ a \<leadsto> S2` that
        apply (auto simp add: step.simps domD inv4r split: if_splits)
        by (metis (mono_tags, hide_lams) action_outputs.simps(5) in_dom inv1 invocation_cannot_guess_ids_step qryOk' step.hyps(3))

    qed
  qed

  from H
  show "\<And>i. \<lbrakk>state_wellFormed S; program_wellFormed (prog S)\<rbrakk>
         \<Longrightarrow> \<exists>uids\<subseteq>dom (generatedIds S). invocation_cannot_guess_ids uids i S"
    by blast
  from H
  show "\<lbrakk>state_wellFormed S; program_wellFormed (prog S)\<rbrakk> \<Longrightarrow> knownIds S \<subseteq> dom (generatedIds S)"
    by blast
  from H
  show "\<And>c opr r.
       \<lbrakk>calls S c \<triangleq> Call opr r; state_wellFormed S; program_wellFormed (prog S)\<rbrakk>
       \<Longrightarrow> uniqueIds opr \<subseteq> dom (generatedIds S)"
    by blast
  from  H
  show "\<And>c opr r.
       \<lbrakk>calls S c \<triangleq> Call opr r; state_wellFormed S; program_wellFormed (prog S)\<rbrakk> \<Longrightarrow> uniqueIds r \<subseteq> dom (generatedIds S)"
    by blast

qed

lemmas wf_knownIds_subset_generatedIds = wf_knownIds_subset_generatedIds_h(2)

lemma wf_knownIds_subset_generatedIds2:
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and "x \<in> knownIds S"
  shows "x \<in> dom (generatedIds S)"
  using assms
  by (meson domExists_simp in_dom wf_knownIds_subset_generatedIds)

lemma wf_onlyGeneratedIdsInKnownIds:
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and not_generated: "generatedIds S uid = None"
  shows "uid \<notin> knownIds S"
  by (meson domIff local.wf not_generated prog_wf wf_knownIds_subset_generatedIds2)

lemma wf_onlyGeneratedIdsInCalls:
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and not_generated: "generatedIds S uid = None"
  shows "calls S c \<triangleq> Call opr r \<Longrightarrow> uid \<notin> uniqueIds opr"
  by (meson domIff in_mono local.wf not_generated prog_wf wf_knownIds_subset_generatedIds_h(3))

lemma wf_onlyGeneratedIdsInCallResults:
  fixes S :: "('proc::valueType, 'ls, 'op::valueType, 'any::valueType) state"
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and not_generated: "generatedIds S uid = None"
  shows "calls S c \<triangleq> Call opr r \<Longrightarrow> uid \<notin> uniqueIds r"
  by (meson domIff in_mono local.wf not_generated prog_wf wf_knownIds_subset_generatedIds_h(4))

lemma wf_onlyGeneratedIdsInInvocationOps:
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and not_generated: "generatedIds S uid = None"
  shows "invocOp S c \<triangleq> opr \<Longrightarrow> uid \<notin> uniqueIds opr"
  using wf prog_wf not_generated proof (induct rule: wellFormed_induct)
  case initial
  then show ?case
    by (auto simp add: initialState_def)

next
  case (step t a s)
  then show ?case
    using wf_onlyGeneratedIdsInKnownIds by (auto simp add: step.simps split: if_splits, blast)
qed

lemma wf_onlyGeneratedIdsInInvocationRes:
  fixes S :: "('proc::valueType, 'ls, 'op::valueType, 'any::valueType) state"
  assumes wf: "state_wellFormed S"
    and prog_wf: "program_wellFormed (prog S)"
    and not_generated: "generatedIds S uid = None"
  shows "invocRes S c \<triangleq> res \<Longrightarrow> uid \<notin> uniqueIds res"

  using wf prog_wf not_generated proof (induct rule: wellFormed_induct)
  case initial
  then show ?case
    by (auto simp add: initialState_def)

next
  case (step t a s)
  then show ?case
    by (auto simp add: step.simps split: if_splits,
        metis (mono_tags, hide_lams) action_outputs.simps(7) domIff invocation_cannot_guess_ids_step step.hyps(1) step.hyps(3) subsetD wf_knownIds_subset_generatedIds_h(1))
qed

lemma use_invocation_cannot_guess_ids_dbop:
  assumes "invocation_cannot_guess_ids uids i S"
and "S ~~ (i, ADbOp c Op res) \<leadsto> S'"
  shows "uniqueIds Op \<subseteq> uids"
  using action_outputs.simps(5) assms(1) assms(2) invocation_cannot_guess_ids_step by blast

lemma use_invocation_cannot_guess_ids_return:
  assumes "invocation_cannot_guess_ids uids i S"
and "S ~~ (i, AReturn res) \<leadsto> S'"
shows "uniqueIds res \<subseteq> uids"
  using action_outputs.simps(7) assms(1) assms(2) invocation_cannot_guess_ids_step by blast

(*
text "We restrict the definition invocation_cannot_guess_ids to a
specific local state and procedure implementation:"

definition procedure_cannot_guess_ids :: "('proc::valueType) itself \<Rightarrow> uniqueId set \<Rightarrow> 'ls \<Rightarrow> ('ls, 'op::valueType, 'any::valueType) procedureImpl \<Rightarrow> bool" where
"procedure_cannot_guess_ids _ uids ls impl \<equiv>
\<forall>(S::('proc, 'ls, 'op, 'any) state) (i::invocId).
      localState S i \<triangleq> ls
  \<longrightarrow> currentProc S i \<triangleq> impl
  \<longrightarrow> invocation_cannot_guess_ids uids i S"

lemmas use_procedure_cannot_guess_ids = procedure_cannot_guess_ids_def[THEN meta_eq_to_obj_eq, THEN iffD1, rule_format]

definition procedures_cannot_guess_ids :: "('proc::valueType \<Rightarrow> ('ls \<times> ('ls, 'op::valueType, 'any::valueType) procedureImpl)) \<Rightarrow> bool" where
  "procedures_cannot_guess_ids proc =
(\<forall>p ls impl uids. proc p = (ls, impl) \<longrightarrow>  procedure_cannot_guess_ids (TYPE('proc)) (uids\<union>uniqueIds p) ls impl)"

lemmas use_procedures_cannot_guess_ids = procedures_cannot_guess_ids_def[THEN iffD1, rule_format]

text "Show: if all procedures cannot guess ids, then program is also wellformed."

lemma invocations_cannot_guess_ids_if_procedures:
  assumes "procedures_cannot_guess_ids (procedure progr)"
  shows "invocations_cannot_guess_ids progr"
  unfolding invocations_cannot_guess_ids_def
proof (rule, rule show_invocation_cannot_guess_ids)
  fix i x tr a S'
  assume a0: "initialState progr ~~ tr @ [(i,a)] \<leadsto>* S'"
    and a1: "x \<in> action_outputs a"
    and a2: "x \<notin> {}"

  have s: "invocation_cannot_guess_ids (trace_inputs tr i) i S"
    if "initialState progr ~~ tr \<leadsto>* S"
      and "invocOp S i \<noteq> None"
    for S
    using that  proof (induct rule: steps_induct)
    case initial
    then show ?case
      by (simp add: initialState_def)
  next
    case (step S' tr a S'')

    have [simp]: "prog S' = progr"
      by (metis (no_types, lifting) distributed_state.simps(1) initialState_def step.steps steps_do_not_change_prog)

    show ?case
    proof (cases "invocOp S' i = None")
      case True

      have [simp]: "localState S' i = None"
        using True invocation_ops_if_localstate_nonempty step.steps by blast

      from step.step
      obtain proc initialState impl
        where c0: "a = (i, AInvoc proc)"
          and S''_def: "S'' = S' \<lparr>localState := localState S'(i \<mapsto> initialState), currentProc := currentProc S'(i \<mapsto> impl), visibleCalls := visibleCalls S'(i \<mapsto> {}), invocOp := invocOp S'(i \<mapsto> proc)\<rparr>"
          and c2: "procedure progr proc = (initialState, impl)"
          and c3: "uniqueIds proc \<subseteq> knownIds S'"
          and c4: "invocOp S' i = None"
        apply atomize_elim
        using `invocOp S' i = None` `invocOp S'' i \<noteq> None`
        by (auto simp add: step.simps split: if_splits)

      from use_procedures_cannot_guess_ids[OF `procedures_cannot_guess_ids (procedure progr)`
          `procedure progr proc = (initialState, impl)`]
      have t: "procedure_cannot_guess_ids TYPE('a) ({} \<union> uniqueIds proc) initialState impl" .

      hence "invocation_cannot_guess_ids (uniqueIds proc) i S''"
      proof (fuzzy_rule use_procedure_cannot_guess_ids)
        show "{} \<union> uniqueIds proc = uniqueIds proc" by simp
        show " localState S'' i \<triangleq> initialState" by (simp add: S''_def)
        show "currentProc S'' i \<triangleq> impl"  by (simp add: S''_def)
      qed

      have "(i,a) \<notin> set tr" if " \<And>t. a \<noteq> AInvcheck t" for a
        using step.steps `invocOp S' i = None` that
        by (rule no_steps_in_i')

      hence "trace_inputs (tr @ [a]) i = uniqueIds proc"
        using `a = (i, AInvoc proc)`
        by (auto simp add: trace_inputs_def action_inputs_cases split: action.splits)

      show ?thesis
        by (simp add: \<open>invocation_cannot_guess_ids (uniqueIds proc) i S''\<close> \<open>trace_inputs (tr @ [a]) i = uniqueIds proc\<close>)
    next
      case False
      hence " invocation_cannot_guess_ids (trace_inputs tr i) i S'"
        by (simp add: step.IH)

      show ?thesis
      proof (cases "get_invoc a = i")
        case True
        show ?thesis
          using `invocation_cannot_guess_ids (trace_inputs tr i) i S'`
        proof (fuzzy_rule show_invocation_cannot_guess_ids_step)
          show  "S' ~~ (i, snd a) \<leadsto> S''"
            using `get_invoc a = i` step.step by auto
          show "trace_inputs tr i \<union> action_inputs (get_action a) = trace_inputs (tr @ [a]) i"
            by (auto simp add: trace_inputs_def `get_invoc a = i`)
        qed
      next
        case False
        show ?thesis
        proof (fuzzy_rule show_invocation_cannot_guess_ids_step_other)
          from `invocation_cannot_guess_ids (trace_inputs tr i) i S'`
          show "invocation_cannot_guess_ids (trace_inputs (tr @ [a]) i) i S'"
            using `get_invoc a \<noteq> i`
            by (auto simp add: trace_inputs_def)
          show "S' ~~ (get_invoc a, get_action a) \<leadsto> S''"
            by (simp add: step.step)
          show "get_invoc a \<noteq> i" using False.
        qed
      qed
    qed
  qed

  from `initialState progr ~~ tr @ [(i,a)] \<leadsto>* S'`
  obtain S1 where "initialState progr ~~ tr \<leadsto>* S1"
    and "S1 ~~ (i,a) \<leadsto> S'"
    using steps_appendBack by blast

  show "x \<in> trace_inputs tr i"
  proof (cases "invocOp S1 i")
    case None

    have [simp]: "localState S1 i = None"
      using None \<open>initialState progr ~~ tr \<leadsto>* S1\<close> invocation_ops_if_localstate_nonempty by blast

    from `S1 ~~ (i,a) \<leadsto> S'` a1
    show ?thesis
      by (auto simp add: step.simps)
  next
    case (Some proc)
    from s[OF `initialState progr ~~ tr \<leadsto>* S1`]
    have t: "invocation_cannot_guess_ids (trace_inputs tr i) i S1"
      using Some by blast

    thus ?thesis
      using `S1 ~~ (i,a) \<leadsto> S'` a1
      by (rule invocation_cannot_guess_ids_step)
  qed
qed

*)

end


(*
Title: SIFUM-Type-Systems
Authors: Sylvia Grewe, Heiko Mantel, Daniel Schoepe
*)
header {* Definition of the SIFUM-Security Property *}

theory Security
imports Main Preliminaries
begin

context sifum_security begin

subsection {* Evaluation of Concurrent Programs *}

abbreviation eval_abv :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow> (_, _, _) LocalConf \<Rightarrow> bool"
  (infixl "\<leadsto>" 70)
  where
  "x \<leadsto> y \<equiv> (x, y) \<in> eval"

abbreviation conf_abv :: "'Com \<Rightarrow> 'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_,_,_) LocalConf"
  ("\<langle>_, _, _\<rangle>" [0, 0, 0] 1000)
  where
  "\<langle> c, mds, mem \<rangle> \<equiv> ((c, mds), mem)"

(* Evaluation of global configurations: *)
inductive_set meval :: "(_,_,_) GlobalConf rel"
  and meval_abv :: "_ \<Rightarrow> _ \<Rightarrow> bool" (infixl "\<rightarrow>" 70)
  where
  "conf \<rightarrow> conf' \<equiv> (conf, conf') \<in> meval" |
  meval_intro [iff]: "\<lbrakk> (cms ! n, mem) \<leadsto> (cm', mem'); n < length cms \<rbrakk> \<Longrightarrow>
  ((cms, mem), (cms [n := cm'], mem')) \<in> meval"

inductive_cases meval_elim [elim!]: "((cms, mem), (cms', mem')) \<in> meval"

(* Syntactic sugar for the reflexive-transitive closure of meval: *)
abbreviation meval_clos :: "_ \<Rightarrow> _ \<Rightarrow> bool" (infixl "\<rightarrow>\<^sup>*" 70)
  where
  "conf \<rightarrow>\<^sup>* conf' \<equiv> (conf, conf') \<in> meval\<^sup>*"

fun lc_set_var :: "(_, _, _) LocalConf \<Rightarrow> 'Var \<Rightarrow> 'Val \<Rightarrow> (_, _, _) LocalConf"
  where
  "lc_set_var (c, mem) x v = (c, mem (x := v))"

fun meval_k :: "nat \<Rightarrow> ('Com, 'Var, 'Val) GlobalConf \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> bool"
  where
  "meval_k 0 c c' = (c = c')" |
  "meval_k (Suc n) c c' = (\<exists> c''. meval_k n c c'' \<and> c'' \<rightarrow> c')"

(* k steps of evaluation (for global configurations: *)
abbreviation meval_k_abv :: "nat \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> bool"
  ("_ \<rightarrow>\<index> _" [100, 100] 80)
  where
  "gc \<rightarrow>\<^bsub>k \<^esub>gc' \<equiv> meval_k k gc gc'"

subsection {* Low-equivalence and Strong Low Bisimulations *}

(* Low-equality between memory states: *)
definition low_eq :: "('Var, 'Val) Mem \<Rightarrow> (_, _) Mem \<Rightarrow> bool" (infixl "=\<^sup>l" 80)
  where
  "mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<equiv> (\<forall> x. dma x = Low \<longrightarrow> mem\<^sub>1 x = mem\<^sub>2 x)"

(* Low-equality modulo a given mode state: *)
definition low_mds_eq :: "'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_, _) Mem \<Rightarrow> bool"
  ("_ =\<index>\<^sup>l _" [100, 100] 80)
  where
  "(mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<equiv> (\<forall> x. dma x = Low \<and> x \<notin> mds AsmNoRead \<longrightarrow> mem\<^sub>1 x = mem\<^sub>2 x)"

(* Initial mode state: *)
definition "mds\<^sub>s" :: "'Var Mds" where
  "mds\<^sub>s x = {}"

lemma [simp]: "(\<forall> mds. mem =\<^bsub>mds\<^esub>\<^sup>l mem') \<Longrightarrow> mem =\<^sup>l mem'"
  by (auto simp: low_mds_eq_def low_eq_def)

(* Closedness under globally consistent changes: *)
definition closed_glob_consistent :: "(('Com, 'Var, 'Val) LocalConf) rel \<Rightarrow> bool"
  where
  "closed_glob_consistent \<R> =
  (\<forall> c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R> \<longrightarrow>
   (\<forall> x. ((dma x = High \<and> x \<notin> mds AsmNoWrite) \<longrightarrow>
           (\<forall> v\<^sub>1 v\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 (x := v\<^sub>1) \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 (x := v\<^sub>2) \<rangle>) \<in> \<R>)) \<and>
         ((dma x = Low \<and> x \<notin> mds AsmNoWrite) \<longrightarrow>
           (\<forall> v. (\<langle> c\<^sub>1, mds, mem\<^sub>1 (x := v) \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 (x := v) \<rangle>) \<in> \<R>))))"

(* Strong low bisimulations modulo modes: *)
definition strong_low_bisim_mm :: "(('Com, 'Var, 'Val) LocalConf) rel \<Rightarrow> bool"
  where
  "strong_low_bisim_mm \<R> \<equiv>
  sym \<R> \<and>
  closed_glob_consistent \<R> \<and>
  (\<forall> c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R> \<longrightarrow>
   (mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<and>
   (\<forall> c\<^sub>1' mds' mem\<^sub>1'. \<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<leadsto> \<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle> \<longrightarrow>
    (\<exists> c\<^sub>2' mem\<^sub>2'. \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle> \<leadsto> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle> \<and>
                  (\<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle>, \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle>) \<in> \<R>)))"

inductive_set mm_equiv :: "(('Com, 'Var, 'Val) LocalConf) rel"
  and mm_equiv_abv :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow>
  ('Com, 'Var, 'Val) LocalConf \<Rightarrow> bool" (infix "\<approx>" 60)
  where
  "mm_equiv_abv x y \<equiv> (x, y) \<in> mm_equiv" |
  mm_equiv_intro [iff]: "\<lbrakk> strong_low_bisim_mm \<R> ; (lc\<^sub>1, lc\<^sub>2) \<in> \<R> \<rbrakk> \<Longrightarrow> (lc\<^sub>1, lc\<^sub>2) \<in> mm_equiv"

inductive_cases mm_equiv_elim [elim]: "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"

definition low_indistinguishable :: "'Var Mds \<Rightarrow> 'Com \<Rightarrow> 'Com \<Rightarrow> bool"
  ("_ \<sim>\<index> _" [100, 100] 80)
  where "c\<^sub>1 \<sim>\<^bsub>mds\<^esub> c\<^sub>2 = (\<forall> mem\<^sub>1 mem\<^sub>2. mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2 \<longrightarrow>
    \<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>)"

subsection {* SIFUM-Security *}

(* SIFUM-security for commands: *)
definition com_sifum_secure :: "'Com \<Rightarrow> bool"
  where "com_sifum_secure c = c \<sim>\<^bsub>mds\<^sub>s\<^esub> c"

definition add_initial_modes :: "'Com list \<Rightarrow> ('Com \<times> 'Var Mds) list"
  where "add_initial_modes cmds = zip cmds (replicate (length cmds) mds\<^sub>s)"

definition no_assumptions_on_termination :: "'Com list \<Rightarrow> bool"
  where "no_assumptions_on_termination cmds =
  (\<forall> mem mem' cms'.
    (add_initial_modes cmds, mem) \<rightarrow>\<^sup>* (cms', mem') \<and>
    list_all (\<lambda> c. c = stop) (map fst cms') \<longrightarrow>
      (\<forall> mds' \<in> set (map snd cms'). mds' AsmNoRead = {} \<and> mds' AsmNoWrite = {}))"

(* SIFUM-security for programs: *)
definition prog_sifum_secure :: "'Com list \<Rightarrow> bool"
  where "prog_sifum_secure cmds =
  (no_assumptions_on_termination cmds \<and>
   (\<forall> mem\<^sub>1 mem\<^sub>2. mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<longrightarrow>
    (\<forall> k cms\<^sub>1' mem\<^sub>1'.
     (add_initial_modes cmds, mem\<^sub>1) \<rightarrow>\<^bsub>k\<^esub> (cms\<^sub>1', mem\<^sub>1') \<longrightarrow>
      (\<exists> cms\<^sub>2' mem\<^sub>2'. (add_initial_modes cmds, mem\<^sub>2) \<rightarrow>\<^bsub>k\<^esub> (cms\<^sub>2', mem\<^sub>2') \<and>
                      map snd cms\<^sub>1' = map snd cms\<^sub>2' \<and>
                      length cms\<^sub>2' = length cms\<^sub>1' \<and>
                      (\<forall> x. dma x = Low \<and> (\<forall> i < length cms\<^sub>1'.
                        x \<notin> snd (cms\<^sub>1' ! i) AsmNoRead) \<longrightarrow> mem\<^sub>1' x = mem\<^sub>2' x)))))"

subsection {* Sound Mode Use *}

definition doesnt_read :: "'Com \<Rightarrow> 'Var \<Rightarrow> bool"
  where
  "doesnt_read c x = (\<forall> mds mem c' mds' mem'.
  \<langle> c, mds, mem \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle> \<longrightarrow>
  ((\<forall> v. \<langle> c, mds, mem (x := v) \<rangle> \<leadsto> \<langle> c', mds', mem' (x := v) \<rangle>) \<or>
   (\<forall> v. \<langle> c, mds, mem (x := v) \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle>)))"

definition doesnt_modify :: "'Com \<Rightarrow> 'Var \<Rightarrow> bool"
  where
  "doesnt_modify c x = (\<forall> mds mem c' mds' mem'. (\<langle> c, mds, mem \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle>) \<longrightarrow>
                        mem x = mem' x)"

(* Local reachability of local configurations: *)
inductive_set loc_reach :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow> ('Com, 'Var, 'Val) LocalConf set"
  for lc :: "(_, _, _) LocalConf"
  where
  refl : "\<langle>fst (fst lc), snd (fst lc), snd lc\<rangle> \<in> loc_reach lc" |
  step : "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach lc;
            \<langle>c', mds', mem'\<rangle> \<leadsto> \<langle>c'', mds'', mem''\<rangle> \<rbrakk> \<Longrightarrow>
          \<langle>c'', mds'', mem''\<rangle> \<in> loc_reach lc" |
  mem_diff : "\<lbrakk> \<langle> c', mds', mem' \<rangle> \<in> loc_reach lc;
                (\<forall> x \<in> mds' AsmNoWrite. mem' x = mem'' x) \<rbrakk> \<Longrightarrow>
              \<langle> c', mds', mem'' \<rangle> \<in> loc_reach lc"

definition locally_sound_mode_use :: "(_, _, _) LocalConf \<Rightarrow> bool"
  where
  "locally_sound_mode_use lc =
  (\<forall> c' mds' mem'. \<langle> c', mds', mem' \<rangle> \<in> loc_reach lc \<longrightarrow>
    (\<forall> x. (x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read c' x) \<and>
          (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)))"

definition compatible_modes :: "('Var Mds) list \<Rightarrow> bool"
  where
  "compatible_modes mdss = (\<forall> (i :: nat) x. i < length mdss \<longrightarrow>
    (x \<in> (mdss ! i) AsmNoRead \<longrightarrow>
     (\<forall> j < length mdss. j \<noteq> i \<longrightarrow> x \<in> (mdss ! j) GuarNoRead)) \<and>
    (x \<in> (mdss ! i) AsmNoWrite \<longrightarrow>
     (\<forall> j < length mdss. j \<noteq> i \<longrightarrow> x \<in> (mdss ! j) GuarNoWrite)))"

definition reachable_mode_states :: "('Com, 'Var, 'Val) GlobalConf \<Rightarrow> (('Var Mds) list) set"
  where "reachable_mode_states gc =
  {mdss. (\<exists> cms' mem'. gc \<rightarrow>\<^sup>* (cms', mem') \<and> map snd cms' = mdss)}"

definition globally_sound_mode_use :: "('Com, 'Var, 'Val) GlobalConf \<Rightarrow> bool"
  where "globally_sound_mode_use gc =
  (\<forall> mdss. mdss \<in> reachable_mode_states gc \<longrightarrow> compatible_modes mdss)"

primrec sound_mode_use :: "(_, _, _) GlobalConf \<Rightarrow> bool"
  where
  "sound_mode_use (cms, mem) =
     (list_all (\<lambda> cm. locally_sound_mode_use (cm, mem)) cms \<and>
      globally_sound_mode_use (cms, mem))"

(* We now show that mm_equiv itself forms a strong low bisimulation modulo modes: *)
lemma mm_equiv_sym:
  assumes equivalent: "\<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle> \<approx> \<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>"
  shows "\<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle> \<approx> \<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>"
proof -
  from equivalent obtain \<R>
    where \<R>_bisim: "strong_low_bisim_mm \<R> \<and> (\<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>, \<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>) \<in> \<R>"
    by (metis mm_equiv.simps)
  hence "sym \<R>"
    by (auto simp: strong_low_bisim_mm_def)
  hence "(\<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>, \<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>) \<in> \<R>"
    by (metis \<R>_bisim symE)
  thus ?thesis
    by (metis \<R>_bisim mm_equiv.intros)
qed

lemma low_indistinguishable_sym: "lc \<sim>\<^bsub>mds\<^esub> lc' \<Longrightarrow> lc' \<sim>\<^bsub>mds\<^esub> lc"
  by (auto simp: mm_equiv_sym low_indistinguishable_def low_mds_eq_def)

lemma mm_equiv_glob_consistent: "closed_glob_consistent mm_equiv"
  unfolding closed_glob_consistent_def
  apply clarify
  apply (erule mm_equiv_elim)
  by (auto simp: strong_low_bisim_mm_def closed_glob_consistent_def)

lemma mm_equiv_strong_low_bisim: "strong_low_bisim_mm mm_equiv"
  unfolding strong_low_bisim_mm_def
proof (auto)
  show "closed_glob_consistent mm_equiv" by (rule mm_equiv_glob_consistent)
next
  fix c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2 x
  assume "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"
  then obtain \<R> where
    "strong_low_bisim_mm \<R> \<and> (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R>"
    by blast
  thus "mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2" by (auto simp: strong_low_bisim_mm_def)
next
  fix c\<^sub>1 :: 'Com
  fix mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2 c\<^sub>1' mds' mem\<^sub>1'
  let ?lc\<^sub>1 = "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>" and
      ?lc\<^sub>1' = "\<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle>" and
      ?lc\<^sub>2 = "\<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"
  assume "?lc\<^sub>1 \<approx> ?lc\<^sub>2"
  then obtain \<R> where "strong_low_bisim_mm \<R> \<and> (?lc\<^sub>1, ?lc\<^sub>2) \<in> \<R>"
    by (rule mm_equiv_elim, blast)
  moreover assume "?lc\<^sub>1 \<leadsto> ?lc\<^sub>1'"
  ultimately show "\<exists> c\<^sub>2' mem\<^sub>2'. ?lc\<^sub>2 \<leadsto> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle> \<and> ?lc\<^sub>1' \<approx> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle>"
    by (simp add: strong_low_bisim_mm_def mm_equiv_sym, blast)
next
  show "sym mm_equiv"
    by (auto simp: sym_def mm_equiv_sym)
qed

end

end


header {* Utilities for defining constants and functions *}

theory Utils imports LambdaTerms begin

lemma beta_app:
  "(\<integral> x. M) \<cdot> Var x \<approx> M"
  by (rule b3, rule bI)
     (simp add: b1)

lemma lam1_fast_app:
  assumes leq: "\<And>a. (L = \<integral> a. (F (V a)))"
      and su: "\<And>x. atom x \<sharp> A \<Longrightarrow> F (V x) [x ::= A] = F A"
  shows "L \<cdot> A \<approx> F A"
proof -
  obtain x :: name where a: "atom x \<sharp> A" using obtain_fresh by blast
  show ?thesis
    by (simp add: leq[of x], rule b3, rule bI, simp add: su b1 a)
qed

lemma lam2_fast_app:
  assumes leq: "\<And>a b. a \<noteq> b \<Longrightarrow> L = \<integral> a. \<integral> b. (F (V a) (V b))"
     and su: "\<And>x y. atom x \<sharp> A \<Longrightarrow> atom y \<sharp> A \<Longrightarrow> atom x \<sharp> B \<Longrightarrow> atom y \<sharp> B \<Longrightarrow>
       x \<noteq> y \<Longrightarrow> F (V x) (V y) [x ::= A] [y ::= B] = F A B"
  shows "L \<cdot> A \<cdot> B \<approx> F A B"
proof -
  obtain x :: name where a: "atom x \<sharp> (A, B)" using obtain_fresh by blast
  obtain y :: name where b: "atom y \<sharp> (x, A, B)" using obtain_fresh by blast
  obtain z :: name where c: "atom z \<sharp> (x, y, A, B)" using obtain_fresh by blast
  have *: "x \<noteq> y" "x \<noteq> z" "y \<noteq> z"
    using a b c by (simp_all add: fresh_Pair fresh_at_base) blast+
  have ** : "atom y \<sharp> z" "atom x \<sharp> z" "atom y \<sharp> x"
            "atom z \<sharp> y" "atom z \<sharp> x" "atom x \<sharp> y"
            "atom x \<sharp> A" "atom y \<sharp> A" "atom z \<sharp> A"
            "atom x \<sharp> B" "atom y \<sharp> B" "atom z \<sharp> B"
    using a b c by (simp_all add: fresh_Pair fresh_at_base) blast+
  show ?thesis
    apply (simp add: leq[OF *(1)])
    apply (rule b3) apply (rule b5) apply (rule bI)
    apply (simp add: ** fresh_Pair)
    apply (rule b3) apply (rule bI) apply (simp add: su b1 ** *)
    done
  qed

lemma lam3_fast_app:
  assumes leq: "\<And>a b c. a \<noteq> b \<Longrightarrow> b \<noteq> c \<Longrightarrow> c \<noteq> a \<Longrightarrow>
       L = \<integral> a. \<integral> b. \<integral> c. (F (V a) (V b) (V c))"
     and su: "\<And>x y z. atom x \<sharp> A \<Longrightarrow> atom y \<sharp> A \<Longrightarrow> atom z \<sharp> A \<Longrightarrow>
                     atom x \<sharp> B \<Longrightarrow> atom y \<sharp> B \<Longrightarrow> atom z \<sharp> B \<Longrightarrow>
                     atom y \<sharp> B \<Longrightarrow> atom y \<sharp> B \<Longrightarrow> atom z \<sharp> B \<Longrightarrow>
                     x \<noteq> y \<Longrightarrow> y \<noteq> z \<Longrightarrow> z \<noteq> x \<Longrightarrow>
      ((F (V x) (V y) (V z))[x ::= A] [y ::= B] [z ::= C] = F A B C)"
  shows "L \<cdot> A \<cdot> B \<cdot> C \<approx> F A B C"
proof -
  obtain x :: name where a: "atom x \<sharp> (A, B, C)" using obtain_fresh by blast
  obtain y :: name where b: "atom y \<sharp> (x, A, B, C)" using obtain_fresh by blast
  obtain z :: name where c: "atom z \<sharp> (x, y, A, B, C)" using obtain_fresh by blast
  have *: "x \<noteq> y" "y \<noteq> z" "z \<noteq> x"
    using a b c by (simp_all add: fresh_Pair fresh_at_base) blast+
  have ** : "atom y \<sharp> z" "atom x \<sharp> z" "atom y \<sharp> x"
            "atom z \<sharp> y" "atom z \<sharp> x" "atom x \<sharp> y"
            "atom x \<sharp> A" "atom y \<sharp> A" "atom z \<sharp> A"
            "atom x \<sharp> B" "atom y \<sharp> B" "atom z \<sharp> B"
            "atom x \<sharp> C" "atom y \<sharp> C" "atom z \<sharp> C"
    using a b c by (simp_all add: fresh_Pair fresh_at_base) blast+
  show ?thesis
    apply (simp add: leq[OF *(1) *(2) *(3)])
    apply (rule b3) apply (rule b5) apply (rule b5) apply (rule bI)
    apply (simp add: ** fresh_Pair)
    apply (rule b3) apply (rule b5) apply (rule bI)
    apply (simp add: ** fresh_Pair)
    apply (rule b3) apply (rule bI) apply (simp add: su b1 ** *)
    done
  qed

definition cn :: "nat \<Rightarrow> name" where "cn n \<equiv> Abs_name (Atom (Sort ''LambdaTerms.name'' []) n)"

lemma cnd[simp]: "m \<noteq> n \<Longrightarrow> cn m \<noteq> cn n"
  unfolding cn_def using Abs_name_inject by simp

definition cx :: name where "cx \<equiv> cn 0"
definition cy :: name where "cy \<equiv> cn 1"
definition cz :: name where "cz \<equiv> cn 2"

lemma cx_cy_cz[simp]:
  "cx \<noteq> cy" "cx \<noteq> cz" "cz \<noteq> cy"
  unfolding cx_def cy_def cz_def
  by simp_all

lemma noteq_fresh: "atom x \<sharp> y = (x \<noteq> y)"
  by (simp add: fresh_at_base(2))

lemma fresh_fun_eqvt_app2:
  assumes a: "eqvt f"
  and b: "a \<sharp> x" "a \<sharp> y"
  shows "a \<sharp> f x y"
  using fresh_fun_eqvt_app[OF a b(1)] a b
  by (metis fresh_fun_app)

end


theory Automation_Setup
  imports System_Specification
begin

lemma add_prop:
  assumes "PROP (T)"
  shows "A ==> PROP (T)"
  using assms .

lemmas exhaust_elim =
   sActt.exhaust[of x, THEN add_prop[where A="a=Sact x"], rotated -1]
   cActt.exhaust[of x, THEN add_prop[where A="a=Cact x"], rotated -1]
   uActt.exhaust[of x, THEN add_prop[where A="a=Uact x"], rotated -1]
   rActt.exhaust[of x, THEN add_prop[where A="a=Ract x"], rotated -1]
   lActt.exhaust[of x, THEN add_prop[where A="a=Lact x"], rotated -1]
   comActt.exhaust[of x, THEN add_prop[where A="a=COMact x"], rotated -1]
  for x a

lemma state_cong:
fixes s::state
assumes
"pendingUReqs s = pendingUReqs s1 \<and> userReq s = userReq s1 \<and> userIDs s = userIDs s1 \<and>
 postIDs s = postIDs s1 \<and> admin s = admin s1 \<and>
 user s = user s1 \<and> pass s = pass s1 \<and> pendingFReqs s = pendingFReqs s1 \<and> friendReq s = friendReq s1 \<and> friendIDs s = friendIDs s1 \<and>
 sentOuterFriendIDs s = sentOuterFriendIDs s1 \<and>
 recvOuterFriendIDs s = recvOuterFriendIDs s1 \<and>
 post s = post s1 \<and>
 owner s = owner s1 \<and> vis s = vis s1 \<and>
 pendingSApiReqs s = pendingSApiReqs s1 \<and> sApiReq s = sApiReq s1 \<and> serverApiIDs s = serverApiIDs s1 \<and> serverPass s = serverPass s1 \<and>
 outerPostIDs s = outerPostIDs s1 \<and> outerPost s = outerPost s1 \<and>
 outerOwner s = outerOwner s1 \<and> outerVis s = outerVis s1 \<and>
 pendingCApiReqs s = pendingCApiReqs s1 \<and> cApiReq s = cApiReq s1 \<and> clientApiIDs s = clientApiIDs s1 \<and> clientPass s = clientPass s1 \<and>
 sharedWith s = sharedWith s1"
shows "s = s1"
using assms apply (cases s, cases s1) by auto

(*
lemma Paper_dest_conv:
  "(p =
        Paper title abstract content reviews dis decs fcontent) \<longleftrightarrow>
  title = titlePaper p \<and>
  abstract = abstractPaper p \<and>
  content = contentPaper p \<and>
  reviews = reviewsPaper p \<and>
  dis = disPaper p \<and>
  decs = decsPaper p \<and>
  fcontent = fcontentPaper p
  "
  by (cases p) auto
*)

end


chapter {* Generated by Lem from word8.lem. *}

theory "Word8Auxiliary"

imports
 	 Main "~~/src/HOL/Library/Code_Target_Numeral"
	 "Lem_pervasives"
	 "Lem_word"
	 "Word8"

begin

(****************************************************)
(*                                                  *)
(* Lemmata                                          *)
(*                                                  *)
(****************************************************)

lemma bs_to_w8_def_lemma:
" ((\<forall> seq.
   W8 (integerFromBitSeq seq) =
     (\<lambda> w .  word_of_int (integerFromBitSeq w)) seq)) "
(* Theorem: bs_to_w8_def_lemma*)(* try *) by auto

lemma w8_to_bs_def_lemma:
" ((\<forall> i.
   bitSeqFromInteger (Some (( 8 :: nat))) i =
     (\<lambda> w .  bitSeqFromInteger (Some 8) ( (sint w))) (W8 i))) "
(* Theorem: w8_to_bs_def_lemma*)(* try *) by auto

lemma word8ToNat_def_lemma:
" ((\<forall> w.
   nat
     (abs
        (
           (integerFromBitSeq
              ((\<lambda> w .  bitSeqFromInteger (Some 8) ( (sint w))) w))))
     = unat w)) "
(* Theorem: word8ToNat_def_lemma*)(* try *) by auto

lemma word8ToInt_def_lemma:
" ((\<forall> w.

     (integerFromBitSeq
        ((\<lambda> w .  bitSeqFromInteger (Some 8) ( (sint w))) w)) =
   sint w)) "
(* Theorem: word8ToInt_def_lemma*)(* try *) by auto

lemma word8FromInteger_def_lemma:
" ((\<forall> i. W8 (i mod base) = (\<lambda> i .  word_of_int ( i)) i)) "
(* Theorem: word8FromInteger_def_lemma*)(* try *) by auto

lemma word8FromInt_def_lemma:
" ((\<forall> i. W8 ( i mod base) = word_of_int i)) "
(* Theorem: word8FromInt_def_lemma*)(* try *) by auto

lemma word8FromBoollist_def_lemma:
" ((\<forall> lst.
   (case  bitSeqFromBoolList lst of
         None => (\<lambda> w .  word_of_int (integerFromBitSeq w))
                   (bitSeqFromInteger None (( 0 :: int)))
     | Some a => (\<lambda> w .  word_of_int (integerFromBitSeq w)) a
   ) = of_bl lst)) "
(* Theorem: word8FromBoollist_def_lemma*)(* try *) by auto

lemma boolListFromWord8_def_lemma:
" ((\<forall> w.
   boolListFrombitSeq (( 8 :: nat))
     ((\<lambda> w .  bitSeqFromInteger (Some 8) ( (sint w))) w) = to_bl w)) "
(* Theorem: boolListFromWord8_def_lemma*)(* try *) by auto

lemma word8FromNumeral_def_lemma:
" ((\<forall> w. W8 (( w :: int) mod base) = ((word_of_int w) :: 8 word))) "
(* Theorem: word8FromNumeral_def_lemma*)(* try *) by auto

lemma w8Less_def_lemma:
" ((\<forall> bs1. \<forall> bs2.
   word8BinTest (op<) bs1 bs2 = word_sless bs1 bs2)) "
(* Theorem: w8Less_def_lemma*)(* try *) by auto

lemma w8LessEqual_def_lemma:
" ((\<forall> bs1. \<forall> bs2.
   word8BinTest (op \<le>) bs1 bs2 = word_sle bs1 bs2)) "
(* Theorem: w8LessEqual_def_lemma*)(* try *) by auto

lemma w8Greater_def_lemma:
" ((\<forall> bs1. \<forall> bs2.
   word8BinTest (op>) bs1 bs2 = word_sless bs2 bs1)) "
(* Theorem: w8Greater_def_lemma*)(* try *) by auto

lemma w8GreaterEqual_def_lemma:
" ((\<forall> bs1. \<forall> bs2.
   word8BinTest (op \<ge>) bs1 bs2 = word_sle bs2 bs1)) "
(* Theorem: w8GreaterEqual_def_lemma*)(* try *) by auto

lemma w8Compare_def_lemma:
" ((\<forall> bs1. \<forall> bs2.
   word8BinTest (genericCompare (op<) (op=)) bs1 bs2 =
     (genericCompare word_sless w8Eq bs1 bs2))) "
(* Theorem: w8Compare_def_lemma*)(* try *) by auto

lemma word8Negate_def_lemma:
" (( word8UnaryOp (\<lambda> i. - i) = (\<lambda> i. - i))) "
(* Theorem: word8Negate_def_lemma*)(* try *) by auto

lemma word8Succ_def_lemma:
" (( word8UnaryOp (\<lambda> n. n + ( 1 :: int)) = (\<lambda> n. n + 1))) "
(* Theorem: word8Succ_def_lemma*)(* try *) by auto

lemma word8Pred_def_lemma:
" (( word8UnaryOp (\<lambda> n. n - ( 1 :: int)) = (\<lambda> n. n - 1))) "
(* Theorem: word8Pred_def_lemma*)(* try *) by auto

lemma word8Lnot_def_lemma:
" (( word8UnaryOp integerLnot = (\<lambda> w. (NOT w)))) "
(* Theorem: word8Lnot_def_lemma*)(* try *) by auto

lemma word8Add_def_lemma:
" (( word8BinOp (op+) = (op+))) "
(* Theorem: word8Add_def_lemma*)(* try *) by auto

lemma word8Minus_def_lemma:
" (( word8BinOp (op-) = (op-))) "
(* Theorem: word8Minus_def_lemma*)(* try *) by auto

lemma word8Mult_def_lemma:
" (( word8BinOp (op*) = (op*))) "
(* Theorem: word8Mult_def_lemma*)(* try *) by auto

lemma word8IntegerDivision_def_lemma:
" (( word8BinOp (op div) = (op div))) "
(* Theorem: word8IntegerDivision_def_lemma*)(* try *) by auto

lemma word8Division_def_lemma:
" (( word8BinOp (op div) = (op div))) "
(* Theorem: word8Division_def_lemma*)(* try *) by auto

lemma word8Remainder_def_lemma:
" (( word8BinOp (op mod) = (op mod))) "
(* Theorem: word8Remainder_def_lemma*)(* try *) by auto

lemma word8Land_def_lemma:
" (( word8BinOp integerLand = (op AND))) "
(* Theorem: word8Land_def_lemma*)(* try *) by auto

lemma word8Lor_def_lemma:
" (( word8BinOp integerLor = (op OR))) "
(* Theorem: word8Lor_def_lemma*)(* try *) by auto

lemma word8Lxor_def_lemma:
" (( word8BinOp integerLxor = (op XOR))) "
(* Theorem: word8Lxor_def_lemma*)(* try *) by auto

lemma word8Min_def_lemma:
" (( word8BinOp (min) = min)) "
(* Theorem: word8Min_def_lemma*)(* try *) by auto

lemma word8Max_def_lemma:
" (( word8BinOp (max) = max)) "
(* Theorem: word8Max_def_lemma*)(* try *) by auto

lemma word8Power_def_lemma:
" (( word8NatOp (op^) = (op^))) "
(* Theorem: word8Power_def_lemma*)(* try *) by auto

lemma word8Asr_def_lemma:
" (( word8NatOp integerAsr = (op>>>))) "
(* Theorem: word8Asr_def_lemma*)(* try *) by auto

lemma word8Lsr_def_lemma:
" (( word8NatOp integerAsr = (op>>))) "
(* Theorem: word8Lsr_def_lemma*)(* try *) by auto

lemma word8Lsl_def_lemma:
" (( word8NatOp integerLsl = (op<<))) "
(* Theorem: word8Lsl_def_lemma*)(* try *) by auto

lemma word8UGT_def_lemma:
" ((\<forall> a. \<forall> b. (unat a > unat b) = a > b)) "
(* Theorem: word8UGT_def_lemma*)(* try *) by auto

end


theory Proofs
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_1_1:
"VC1 inv1 s0"
  apply(simp only: VC1_def inv1_def R1_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_2_1:
"VC1 inv2 s0"
  apply(simp only: VC1_def inv2_def R2_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_3_1:
"VC1 inv3 s0"
  apply(simp only: VC1_def inv3_def R3_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_4_1:
"VC1 inv4 s0"
  apply(simp only: VC1_def inv4_def R4_def
 extraInv_def waiting_def drying_def)
  by auto

theorem proof_2_2:
"VC2 inv2 s0 hands_value"
  apply(simp only: VC2_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using extra2 by (auto simp add: VC2_def dryer_def)

theorem proof_2_3:
"VC3 inv2 s0 hands_value"
 apply(simp only: VC3_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra3 by (auto simp add: VC3_def dryer_def)

theorem proof_2_4:
"VC4 inv2 s0 hands_value"
 apply(simp only: VC4_def R2_def
dryer_def)
  by auto

theorem proof_2_5:
"VC5 inv2 s0 hands_value"
 apply(simp only: VC5_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using extra5 by (auto simp add: VC5_def)

lemma proof_2_6_dryer_value:
"getVarBool s0 (Suc (Suc 0)) =
getVarBool ( toEnv
           (setPstate (setVarAny s0 OFF) Ctrl
             waiting))
(Suc (Suc 0))" by (simp)

theorem proof_2_6:
"VC6 inv2 s0 hands_value"
 apply(simp only: VC6_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using proof_2_6_dryer_value apply(force)
  using substate_toEnvNum_id apply(blast)
  using extra6 by (auto simp add: VC6_def)

lemma proof_2_7_dryer_value:
"getVarBool s0 (Suc (Suc 0)) =
getVarBool ( toEnv (setVarAny s0 hands_value))
(Suc (Suc 0))" by (simp)

theorem proof_2_7:
"VC7 inv2 s0 hands_value"
 apply(simp only: VC7_def inv2_def R2_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using proof_2_7_dryer_value apply(force)
  using substate_toEnvNum_id apply(blast)
  using extra7 by (auto simp add: VC7_def)

theorem proof_4_2:
"VC2 inv4 s0 hands_value"
apply(simp only: VC2_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra2 by (auto simp add: VC2_def dryer_def)

theorem proof_4_3:
"VC3 inv4 s0 hands_value"
apply(simp only: VC3_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra3 by (auto simp add: VC3_def dryer_def)

theorem proof_4_4:
"VC4 inv4 s0 hands_value"
apply(simp only: VC4_def R4_def
dryer_def)
  by auto

lemma proof_4_5_dryer_value:
"getVarBool s0 (Suc (Suc 0)) =
getVarBool (toEnv (reset (setVarAny s0 ON) Ctrl))
(Suc (Suc 0))" by (simp)

theorem proof_4_5:
"VC5 inv4 s0 hands_value"
apply(simp only: VC5_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
  apply(auto)
  using proof_4_5_dryer_value apply(force)
  using substate_toEnvNum_id apply(blast)
  using extra5 by (auto simp add: VC5_def)

theorem proof_4_6:
"VC6 inv4 s0 hands_value"
apply(simp only: VC6_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra6 by (auto simp add: VC6_def)

theorem proof_4_7:
"VC7 inv4 s0 hands_value"
apply(simp only: VC7_def inv4_def R4_def
dryer_def)
  apply(rule impI; rule conjI)
   apply(auto)
  using extra7 by (auto simp add: VC7_def)

theorem proof_1_4:
"VC4 inv1 s0 hands_value"
apply(simp only: VC4_def R1_def
dryer_def)
  by auto

theorem proof_3_4:
"VC4 inv3 s0 hands_value"
apply(simp only: VC4_def R3_def
dryer_def)
  by auto

end


(*  Title:      Code_Target_Word_Base.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Common base for target language implementations of word types\<close>

theory Code_Target_Word_Base
  imports
    "HOL-Library.Word"
    "Word_Lib.Signed_Division_Word"
    "Word_Lib.More_Word"
begin

subsection \<open>More on conversions\<close>

lemma int_of_integer_unsigned_eq [simp]:
  \<open>int_of_integer (unsigned w) = uint w\<close>
  by transfer simp

lemma int_of_integer_signed_eq [simp]:
  \<open>int_of_integer (signed w) = sint w\<close>
  by transfer simp

abbreviation word_of_integer :: \<open>integer \<Rightarrow> 'a::len word\<close>
  where \<open>word_of_integer k \<equiv> word_of_int (int_of_integer k)\<close>

subsection \<open>Quickcheck conversion functions\<close>

context
  includes state_combinator_syntax
begin

definition qc_random_cnv ::
  "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
    \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
  where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
       let n = a_of_natural k
       in (n, \<lambda>_. Code_Evaluation.term_of n)))"

end

definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_exhaustive_cnv a_of_natural f d =
   Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"

definition qc_full_exhaustive_cnv ::
  "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
  (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"

declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]

definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
where
  "qc_narrowing_drawn_from xs =
   foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"

locale quickcheck_narrowing_samples =
  fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
  and zero :: "'a"
  and tr :: "typerep"
begin

function narrowing_samples :: "integer \<Rightarrow> 'a list"
where
  "narrowing_samples i =
   (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
by pat_completeness auto
termination including integer.lifting
proof(relation "measure nat_of_integer")
  fix i :: integer
  assume "0 < i"
  thus "(i - 1, i) \<in> measure nat_of_integer"
    by simp(transfer, simp)
qed simp

definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
where
  "partial_term_of_sample i =
  (if i < 0 then undefined
   else if i = 0 then zero
   else if i mod 2 = 0 then snd (a_of_integer (i div 2))
   else fst (a_of_integer (i div 2 + 1)))"

lemma partial_term_of_code:
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
    Code_Evaluation.Free (STR ''_'') tr"
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
   Code_Evaluation.term_of (partial_term_of_sample i)"
by (rule partial_term_of_anything)+

end

lemmas [code] =
  quickcheck_narrowing_samples.narrowing_samples.simps
  quickcheck_narrowing_samples.partial_term_of_sample_def

subsection \<open>More on division\<close>

lemma div_half_nat:
  fixes x y :: nat
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  let ?q = "2 * (x div 2 div y)"
  have q: "?q = x div y - x div y mod 2"
    by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
  let ?r = "x - ?q * y"
  have r: "?r = x mod y + x div y mod 2 * y"
    by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)

  show ?thesis
  proof(cases "y \<le> x - ?q * y")
    case True
    with assms q have "x div y mod 2 \<noteq> 0" unfolding r
      by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1))
    hence "x div y = ?q + 1" unfolding q
      by simp
    moreover hence "x mod y = ?r - y"
      by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
    ultimately show ?thesis using True by(simp add: Let_def)
  next
    case False
    hence "x div y mod 2 = 0" unfolding r
      by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
    hence "x div y = ?q" unfolding q by simp
    moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
    ultimately show ?thesis using False by(simp add: Let_def)
  qed
qed

lemma div_half_word:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = push_bit 1 (drop_bit 1 x div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
    by (rule that [of \<open>unat x\<close>]) simp_all
  moreover obtain m where m: "y = of_nat m" "m < 2 ^ LENGTH('a)"
    by (rule that [of \<open>unat y\<close>]) simp_all
  ultimately have [simp]: \<open>unat (of_nat n :: 'a word) = n\<close> \<open>unat (of_nat m :: 'a word) = m\<close>
    by (transfer, simp add: take_bit_of_nat take_bit_nat_eq_self_iff)+
  let ?q = "push_bit 1 (drop_bit 1 x div y)"
  let ?q' = "2 * (n div 2 div m)"
  have "n div 2 div m < 2 ^ LENGTH('a)"
    using n by (metis of_nat_inverse uno_simps(2) unsigned_less)
  hence q: "?q = of_nat ?q'" using n m
    by (auto simp add: drop_bit_eq_div word_arith_nat_div uno_simps take_bit_nat_eq_self unsigned_of_nat)
  from assms have "m \<noteq> 0" using m by -(rule notI, simp)

  from n have "2 * (n div 2 div m) < 2 ^ LENGTH('a)"
    by (metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unsigned_less uno_simps(2))
  moreover
  have "2 * (n div 2 div m) * m < 2 ^ LENGTH('a)" using n unfolding div_mult2_eq[symmetric]
    by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
  moreover have "2 * (n div 2 div m) * m \<le> n"
    by (simp flip: div_mult2_eq ac_simps)
  ultimately
  have r: "x - ?q * y = of_nat (n - ?q' * m)"
    and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
    using n m unfolding q
     apply (simp_all add: of_nat_diff)
    apply (subst of_nat_diff)
    apply (cases \<open>LENGTH('a) \<ge> 2\<close>)
     apply (simp_all add: word_le_nat_alt take_bit_nat_eq_self unat_sub_if' unat_word_ariths unsigned_of_nat)
    done
  then show ?thesis using n m div_half_nat [OF \<open>m \<noteq> 0\<close>, of n] unfolding q
    by (simp add: word_le_nat_alt word_div_def word_mod_def Let_def take_bit_nat_eq_self unsigned_of_nat
      flip: zdiv_int zmod_int
      split del: if_split split: if_split_asm)
qed

text \<open>Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.\<close>

lemma [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"
  for x y :: \<open>'a::len word\<close>
proof -
  have *: \<open>k mod l = k - k div l * l\<close> for k l :: int
    by (simp add: minus_div_mult_eq_mod)
  show ?thesis
    by (simp add: smod_word_def signed_modulo_int_def signed_divide_int_def * sgn_if Let_def)
qed

text \<open>
  This algorithm implements unsigned division in terms of signed division.
  Taken from Hacker's Delight.
\<close>

lemma divmod_via_sdivmod:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows
  "(x div y, x mod y) =
  (if push_bit (LENGTH('a) - 1) 1 \<le> y then if x < y then (0, x) else (1, x - y)
   else let q = (push_bit 1 (drop_bit 1 x sdiv y));
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
proof(cases "push_bit (LENGTH('a) - 1) 1 \<le> y")
  case True
  note y = this
  show ?thesis
  proof(cases "x < y")
    case True
    then have "x mod y = x"
      by transfer simp
    then show ?thesis using True y
      using bits_mod_div_trivial [of x y] by simp
  next
    case False
    obtain n where n: "y = of_nat n" "n < 2 ^ LENGTH('a)"
      by (rule that [of \<open>unat y\<close>]) simp_all
    have "unat x < 2 ^ LENGTH('a)" by (rule unsigned_less)
    also have "\<dots> = 2 * 2 ^ (LENGTH('a) - 1)"
      by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
    also have "\<dots> \<le> 2 * n" using y n
      by transfer (simp add: take_bit_eq_mod)
    finally have div: "x div of_nat n = 1" using False n
      by (simp add: take_bit_nat_eq_self unsigned_of_nat word_div_eq_1_iff)
    moreover have "x mod y = x - x div y * y"
      by (simp add: minus_div_mult_eq_mod)
    with div n have "x mod y = x - y" by simp
    ultimately show ?thesis using False y n by simp
  qed
next
  case False
  note y = this
  obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
    by (rule that [of \<open>unat x\<close>]) simp_all
  hence "int n div 2 + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
    by (cases \<open>LENGTH('a)\<close>)
      (auto dest: less_imp_of_nat_less [where ?'a = int])
  with y n have "sint (drop_bit 1 x) = uint (drop_bit 1 x)"
    by (cases \<open>LENGTH('a)\<close>)
      (auto simp add: sint_uint drop_bit_eq_div take_bit_nat_eq_self uint_div_distrib
        signed_take_bit_int_eq_self_iff unsigned_of_nat)
  moreover have "uint y + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
    using y by (cases \<open>LENGTH('a)\<close>)
      (simp_all add: not_le word_less_alt uint_power_lower)
  then have "sint y = uint y"
    apply (cases \<open>LENGTH('a)\<close>)
     apply (auto simp add: sint_uint signed_take_bit_int_eq_self_iff)
    using uint_ge_0 [of y]
    by linarith
  ultimately show ?thesis using y
    apply (subst div_half_word [OF assms])
    apply (simp add: sdiv_word_def signed_divide_int_def flip: uint_div)
    done
qed

subsection \<open>More on misc operations\<close>

context
  includes bit_operations_syntax
begin

lemma word_of_int_code:
  "uint (word_of_int x :: 'a word) = x AND mask (LENGTH('a :: len))"
  by (simp add: unsigned_of_int take_bit_eq_mask)

lemma word_and_mask_or_conv_and_mask:
  "bit n index \<Longrightarrow> (n AND mask index) OR (push_bit index 1) = n AND mask (index + 1)"
  for n :: \<open>'a::len word\<close>
  by (rule bit_eqI) (auto simp add: bit_simps)

lemma uint_and_mask_or_full:
  fixes n :: "'a :: len word"
  assumes "bit n (LENGTH('a) - 1)"
  and "mask1 = mask (LENGTH('a) - 1)"
  and "mask2 = push_bit (LENGTH('a) - 1) 1"
  shows "uint (n AND mask1) OR mask2 = uint n"
proof -
  have "mask2 = uint (push_bit (LENGTH('a) - 1) 1 :: 'a word)" using assms
    by transfer (simp add: take_bit_push_bit)
  hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (push_bit (LENGTH('a) - 1) 1 :: 'a word))"
    by(simp add: uint_or)
  also have "\<dots> = uint (n AND mask (LENGTH('a) - 1 + 1))"
    using assms by(simp only: word_and_mask_or_conv_and_mask)
  also have "\<dots> = uint n" by simp
  finally show ?thesis .
qed

lemma word_of_int_via_signed:
  fixes mask
  assumes mask_def: "mask = Bit_Operations.mask LENGTH('a)"
  and shift_def: "shift = push_bit LENGTH('a) 1"
  and index_def: "index = LENGTH('a) - 1"
  and overflow_def:"overflow = push_bit (LENGTH('a) - 1) 1"
  and least_def: "least = - overflow"
  shows
  "(word_of_int i :: 'a :: len word) =
   (let i' = i AND mask
    in if bit i' index then
         if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
       else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
proof -
  define i' where "i' = i AND mask"
  have "shift = mask + 1" unfolding assms
    by (simp add: mask_eq_exp_minus_1)
  hence "i' < shift"
    by (simp add: mask_def i'_def)
  show ?thesis
  proof(cases "bit i' index")
    case True
    then have unf: "i' = overflow OR i'"
      apply (simp add: assms i'_def flip: take_bit_eq_mask)
      apply (rule bit_eqI)
      apply (auto simp add: bit_take_bit_iff bit_or_iff bit_exp_iff)
      done
    have \<open>overflow \<le> overflow OR i'\<close>
      by (simp add: i'_def mask_def or_greater_eq)
    then have "overflow \<le> i'"
      by (subst unf)
    hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
      by(cases "LENGTH('a)")(simp_all add: not_less)
    moreover
    have "overflow \<le> i' - shift \<longleftrightarrow> False" using \<open>i' < shift\<close> unfolding assms
      by(cases "LENGTH('a)")(auto simp add: not_le elim: less_le_trans)
    moreover
    have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using \<open>i' < shift\<close>
      by (simp add: i'_def shift_def mask_def word_of_int_eq_iff flip: take_bit_eq_mask)
    ultimately show ?thesis using True by(simp add: Let_def i'_def)
  next
    case False
    have "i' = i AND Bit_Operations.mask (LENGTH('a) - 1)"
      apply (rule bit_eqI)
      apply (use False in \<open>auto simp add: bit_simps assms i'_def\<close>)
      apply (auto simp add: less_le)
      done
    also have "\<dots> \<le> Bit_Operations.mask (LENGTH('a) - 1)"
      using AND_upper2 mask_nonnegative_int by blast
    also have "\<dots> < overflow"
      by (simp add: mask_int_def overflow_def)
    also
    have "least \<le> 0" unfolding least_def overflow_def by simp
    have "0 \<le> i'" by (simp add: i'_def mask_def)
    hence "least \<le> i'" using \<open>least \<le> 0\<close> by simp
    moreover
    have "word_of_int i' = (word_of_int i :: 'a word)"
      by (simp add: i'_def mask_def of_int_and_eq of_int_mask_eq)
    ultimately show ?thesis using False by(simp add: Let_def i'_def)
  qed
qed

end

subsection \<open>Code generator setup\<close>

text \<open>
  The separate code target \<open>SML_word\<close> collects setups for the
  code generator that PolyML does not provide.
\<close>

setup \<open>Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)])\<close>

code_identifier code_module Code_Target_Word_Base \<rightharpoonup>
  (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word

text \<open>Misc\<close>

lemmas word_sdiv_def = sdiv_word_def
lemmas word_smod_def = smod_word_def

end


(*
 *
 * Copyright 2017, Data61, CSIRO
 *
 * 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 Eval_Bool

imports Try_Methods

begin

text {* The eval_bool method/simproc uses the code generator setup to
reduce terms of boolean type to True or False. Reducing booleans to
True or False is nearly always desirable, and is a fairly good heuristic
for when to make use of definitions/code-equations.

Additional simprocs exist to reduce other types.
*}

ML {*
structure Eval_Simproc = struct

exception Failure

fun mk_constname_tab ts = fold Term.add_const_names ts []
  |> Symtab.make_set

fun is_built_from tab t = case Term.strip_comb t of
    (Const (cn, _), ts) => Symtab.defined tab cn
        andalso forall (is_built_from tab) ts
  | _ => false

fun eval tab ctxt ct = let
    val t = Thm.term_of ct
    val _ = Term.fold_aterms (fn Free _ => raise Failure
      | Var _ => raise Failure | _ => ignore) t ()
    val _ = not (is_built_from tab t) orelse raise Failure
    val ev = the (try (Code_Simp.dynamic_conv ctxt) ct)
  in if is_built_from tab (Thm.term_of (Thm.rhs_of ev))
    then SOME ev else NONE end
  handle Failure => NONE | Option => NONE

val eval_bool = eval (mk_constname_tab [@{term "True"}, @{term "False"}])
val eval_nat = eval (mk_constname_tab [@{term "Suc 0"}, @{term "Suc 1"},
    @{term "Suc 9"}])
val eval_int = eval (mk_constname_tab [@{term "0 :: int"}, @{term "1 :: int"},
    @{term "18 :: int"}, @{term "(-9) :: int"}])

val eval_bool_simproc = Simplifier.make_simproc @{context} "eval_bool"
  { lhss = [@{term "b :: bool"}], proc = K eval_bool }
val eval_nat_simproc = Simplifier.make_simproc @{context} "eval_nat"
  { lhss = [@{term "n :: nat"}], proc = K eval_nat }
val eval_int_simproc = Simplifier.make_simproc @{context} "eval_int"
  { lhss = [@{term "i :: int"}], proc = K eval_int }

end
*}

method_setup eval_bool = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (CHANGED o full_simp_tac (clear_simpset ctxt
        addsimprocs [Eval_Simproc.eval_bool_simproc])))\<close>
    "use code generator setup to simplify booleans in goals to True or False"

method_setup eval_int_nat = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (CHANGED o full_simp_tac (clear_simpset ctxt
        addsimprocs [Eval_Simproc.eval_nat_simproc, Eval_Simproc.eval_int_simproc])))\<close>
    "use code generator setup to simplify nats and ints in goals to values"

add_try_method eval_bool

text {* Testing. *}
definition
  eval_bool_test_seq :: "int list"
where
  "eval_bool_test_seq = [2, 3, 4, 5, 6, 7, 8]"

lemma
  "eval_bool_test_seq ! 4 = 6 \<and> (3 :: nat) < 4
    \<and> sorted eval_bool_test_seq"
  by eval_bool

text {*
A related gadget for installing constant definitions from locales
as code equations. Useful where locales are being used to "hide"
constants from the global state rather than to do anything tricky
with interpretations.

Installing the global definitions in this way will allow eval_bool
etc to "see through" the hiding and decide questions about these
constants.
*}

ML {*
structure Add_Locale_Code_Defs = struct

fun get_const_defs thy nm = Sign.consts_of thy
  |> Consts.dest |> #constants
  |> map fst
  |> filter (fn s => case Long_Name.explode s of
        [_, nm', _] => nm' = nm | _ => false)
  |> map_filter (try (suffix "_def" #> Global_Theory.get_thm thy))

fun setup nm thy = fold (fn t => Code.add_eqn_global (t, true))
    (get_const_defs thy nm) thy

end
*}

locale eval_bool_test_locale begin

definition
  "x == (12 :: int)"

definition
  "y == (13 :: int)"

definition
  "z = (x * y) + x + y"

end

setup {* Add_Locale_Code_Defs.setup "eval_bool_test_locale" *}

setup {* Add_Locale_Code_Defs.setup "eval_bool_test_locale" *}

lemma "eval_bool_test_locale.z > 150"
  by eval_bool

end


section \<open>Semantics of SM\<close>
theory SM_Semantics
imports SM_State SM_Cfg Gen_Scheduler
begin

  section \<open>Evaluation of Expressions\<close>
  subsection \<open>Basic operations\<close>
  text \<open>Attention: Silently overflows, using 2's complement.
    This should match Java-semantics. In C, signed overflow is undefined!\<close>

  context
    includes bit_operations_syntax
  begin

  primrec eval_bin_op :: "bin_op \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
    "eval_bin_op bo_plus v1 v2 = v1+v2"
  | "eval_bin_op bo_minus v1 v2 = v1-v2"
  | "eval_bin_op bo_mul v1 v2 = v1*v2"
  | "eval_bin_op bo_div v1 v2 = v1 sdiv v2"
  | "eval_bin_op bo_mod v1 v2 = v1 smod v2"
  | "eval_bin_op bo_less v1 v2 = val_of_bool (v1 < v2)"
  | "eval_bin_op bo_less_eq v1 v2 = val_of_bool (v1 \<le> v2)"
  | "eval_bin_op bo_eq v1 v2 = val_of_bool (v1 = v2)"
  | "eval_bin_op bo_and v1 v2 = v1 AND v2"
  | "eval_bin_op bo_or v1 v2 = v1 OR v2"
  | "eval_bin_op bo_xor v1 v2 = v1 XOR v2"

  primrec eval_un_op :: "un_op \<Rightarrow> val \<Rightarrow> val" where
    "eval_un_op uo_minus v = -v"  \<comment> \<open>Attention: Silently overflows. @{term "-min_int = min_int"}!\<close>
  | "eval_un_op uo_not v = NOT v"

  end

  subsection \<open>Expressions\<close>
  abbreviation exists_var :: "valuation \<Rightarrow> ident \<Rightarrow> bool" where
    "exists_var s x \<equiv> x \<in> dom s"

  abbreviation update_var :: "ident \<Rightarrow> val \<Rightarrow> valuation \<Rightarrow> valuation" where
    "update_var x v s \<equiv> s(x\<mapsto>v)"

  fun eval_exp :: "exp \<Rightarrow> focused_state \<rightharpoonup> val" where
    "eval_exp (e_var x) (ls,gs) = do {
      let lv = local_state.variables ls; let gv = global_state.variables gs;
      case lv x of
        Some v \<Rightarrow> Some v
      | None \<Rightarrow> (case gv x of
          Some v \<Rightarrow> Some v
        | None \<Rightarrow> None)
    }"
  | "eval_exp (e_localvar x) (ls,gs) = local_state.variables ls x"
  | "eval_exp (e_globalvar x) (ls,gs) = global_state.variables gs x"
  | "eval_exp (e_const n) fs = do {
      assert_option (n\<ge>min_signed \<and> n\<le>max_signed);
      Some (signed_of_int n)
    }"
  | "eval_exp (e_bin bop e1 e2) fs = do {
      v1\<leftarrow>eval_exp e1 fs;
      v2\<leftarrow>eval_exp e2 fs;
      Some (eval_bin_op bop v1 v2)
      }"
  | "eval_exp (e_un uop e) fs = do {
      v\<leftarrow>eval_exp e fs;
      Some (eval_un_op uop v)
      }"

  subsection \<open>Local Actions\<close>

  text \<open>Enabledness and effects of actions\<close>
  primrec la_en :: "focused_state \<Rightarrow> action \<rightharpoonup> bool" where
    "la_en fs (AAssign c _ _) = do { v \<leftarrow> eval_exp c fs; Some (bool_of_val v)}"
  | "la_en fs (AAssign_local c _ _) = do { v \<leftarrow> eval_exp c fs; Some (bool_of_val v)}"
  | "la_en fs (AAssign_global c _ _) = do { v \<leftarrow> eval_exp c fs; Some (bool_of_val v)}"
  | "la_en fs (ATest e) = do {
      v \<leftarrow> eval_exp e fs;
      Some (bool_of_val v)}"
  | "la_en _ (ASkip) = Some True"

  text \<open>Extension (for run, handshake): Let action have scheduler effect\<close>
  fun la_ex :: "focused_state \<Rightarrow> action \<rightharpoonup> focused_state" where
    "la_ex (ls,gs) (AAssign c x e) = do {
      u \<leftarrow> eval_exp c (ls,gs);
      assert_option (bool_of_val u);
      v \<leftarrow> eval_exp e (ls,gs);
      if exists_var (local_state.variables ls) x then do {
        let ls = local_state.variables_update (update_var x v) ls;
        Some (ls,gs)
      } else do {
        assert_option (exists_var (global_state.variables gs) x);
        let gs = global_state.variables_update (update_var x v) gs;
        Some (ls,gs)
      }
    }"
  | "la_ex (ls,gs) (AAssign_local c x e) = do {
      u \<leftarrow> eval_exp c (ls,gs);
      assert_option (bool_of_val u);
      v \<leftarrow> eval_exp e (ls,gs);
      assert_option (exists_var (local_state.variables ls) x);
      let ls = local_state.variables_update (update_var x v) ls;
      Some (ls,gs)
    }"
  | "la_ex (ls,gs) (AAssign_global c x e) = do {
      u \<leftarrow> eval_exp c (ls,gs);
      assert_option (bool_of_val u);
      v \<leftarrow> eval_exp e (ls,gs);
      assert_option (exists_var (global_state.variables gs) x);
      let gs = global_state.variables_update (update_var x v) gs;
      Some (ls,gs)
    }"
  | "la_ex fs (ATest e) = do {
      v \<leftarrow> eval_exp e fs;
      assert_option (bool_of_val v);
      Some fs
    }"
  | "la_ex fs ASkip = Some fs"

  subsection "Scheduling"
  type_synonym local_config = "(cmd,local_state) local_config"
  type_synonym global_config = "(cmd,local_state,global_state) global_config"

  interpretation li: Gen_Scheduler cfg la_en la_ex .

  subsection \<open>Initial State\<close>
  definition init_valuation :: "var_decl list \<Rightarrow> valuation" where
    "init_valuation vd x \<equiv> if x \<in> set vd then Some 0 else None"

  lemma init_valuation_eq_Some[simp]: "init_valuation vd x = Some v \<longleftrightarrow> x\<in>set vd \<and> v=0"
    unfolding init_valuation_def by auto

  lemma init_valuation_eq_None[simp]: "init_valuation vd x = None \<longleftrightarrow> x\<notin>set vd"
    unfolding init_valuation_def by auto

  definition init_pc :: "proc_decl \<Rightarrow> local_config" where
    "init_pc pd \<equiv> \<lparr>
      local_config.command = proc_decl.body pd,
      local_config.state = \<lparr>
        local_state.variables = init_valuation (proc_decl.local_vars pd)
      \<rparr>
    \<rparr>"

  definition init_gc :: "program \<Rightarrow> global_config" where
    "init_gc prog \<equiv> \<lparr>
      global_config.processes = mset (map init_pc (program.processes prog)),
      global_config.state = \<lparr>
        global_state.variables = init_valuation (program.global_vars prog)
      \<rparr>
    \<rparr>"

  subsection "Semantics Reference Point"

  interpretation li: Gen_Scheduler_linit cfg la_en la_ex "{init_gc prog}" global_config.state
    for prog .

  abbreviation "ref_is_run \<equiv> li.sa.is_run"
  abbreviation "ref_accept \<equiv> li.sa.accept"

end