section "Interface for Labelled Transition Systems"
theory LTSSpec
imports
  Main
  "../LTS"
  "../../Collections/Refine_Dflt"
  "../../Collections/ICF/CollectionsV1"
begin
  type_synonym ('V,'W,'L) lts_\<alpha> = "'L \<Rightarrow> ('V * 'W * 'V) set"
  locale lts =
    fixes \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes invar :: "'L \<Rightarrow> bool"

  locale finite_lts = lts +
    assumes finite[simp, intro!]: "invar l \<Longrightarrow> finite (\<alpha> l)"

  locale dlts = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    assumes dlts_det: "invar l \<Longrightarrow> LTS_is_deterministic (\<alpha> l)"

  type_synonym ('V,'W,'L) lts_succ = "'L \<Rightarrow> 'V \<Rightarrow>'W \<Rightarrow> 'V option"
  locale lts_succ = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes succ :: "('V,'W,'L)lts_succ"
    assumes lts_succ_correct:
      "invar l \<Longrightarrow> (succ l v w = None) \<Longrightarrow> \<forall>v'. (v, w, v') \<notin> (\<alpha> l)"
      "invar l \<Longrightarrow> (succ l v w = Some v') \<Longrightarrow> (v, w, v') \<in> (\<alpha> l)"
  begin
    lemma lts_succ_det_correct:
      "invar l \<Longrightarrow> LTS_is_deterministic (\<alpha> l) \<Longrightarrow>
          (succ l v w = Some v') \<longleftrightarrow> (v, w, v') \<in> (\<alpha> l)"
      "invar l \<Longrightarrow> LTS_is_deterministic (\<alpha> l) \<Longrightarrow>
          (succ l v w = None) \<longleftrightarrow> (\<forall>v'. (v, w, v') \<notin> (\<alpha> l))"
       using lts_succ_correct[of l v w]
       unfolding LTS_is_deterministic_def
    by (metis not_Some_eq)+
  end

  locale dlts_succ = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes succ :: "('V,'W,'L)lts_succ"
    assumes dlts_succ_correct:
      "invar l \<Longrightarrow> (succ l v w = Some v') \<longleftrightarrow> (v, w, v') \<in> (\<alpha> l)"

  lemma dlts_succ_sublocale: "dlts_succ \<alpha> invar succ \<Longrightarrow> lts_succ \<alpha> invar succ"
  unfolding lts_succ_def dlts_succ_def
  by auto (metis option.simps(2))

  lemma lts_succ_sublocale: "dlts \<alpha> invar \<Longrightarrow> lts_succ \<alpha> invar succ \<Longrightarrow> dlts_succ \<alpha> invar succ"
  proof -
    assume dlts_OK: "dlts \<alpha> invar"
    assume lts_succ: "lts_succ \<alpha> invar succ"

    show "dlts_succ \<alpha> invar succ"
    proof
      fix l v w v'
      assume invar_l: "invar l"
      from dlts.dlts_det [OF dlts_OK, OF invar_l]
      have det_l: "LTS_is_deterministic (\<alpha> l)" .

      from lts_succ.lts_succ_det_correct[OF lts_succ, OF invar_l det_l]
      show "(succ l v w = Some v') = ((v, w, v') \<in> \<alpha> l)" by simp
    qed
  qed

  type_synonym ('V,'W,'L) lts_memb = "'L \<Rightarrow> 'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> bool"
  locale lts_memb = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes memb :: "('V,'W,'L) lts_memb"
    assumes lts_memb_correct:
      "invar l \<Longrightarrow> (memb l v w v') \<longleftrightarrow> (v, w, v') \<in> (\<alpha> l)"

  locale lts_copy = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
  for \<alpha>1 :: "'L1 \<Rightarrow> ('A * 'B * 'A) set" and invar1
  and \<alpha>2 :: "'L2 \<Rightarrow> ('A * 'B * 'A) set" and invar2
  +
  fixes copy :: "'L1 \<Rightarrow> 'L2"
  assumes copy_correct:
    "invar1 t1 \<Longrightarrow> \<alpha>2 (copy t1) = \<alpha>1 t1"
    "invar1 t1 \<Longrightarrow> invar2 (copy t1)"

  type_synonym ('V,'W,'L) lts_empty  = "unit \<Rightarrow> 'L"
  locale lts_empty = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes empty :: "unit \<Rightarrow> 'L"
    assumes lts_empty_correct:
      "\<alpha> (empty ()) = {}"
      "invar (empty ())"

  type_synonym ('V,'W,'L) lts_add = "'V \<Rightarrow>'W \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
  locale lts_add = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes add :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes lts_add_correct:
      "invar l \<Longrightarrow> invar (add v e v' l)"
      "invar l \<Longrightarrow> \<alpha> (add v e v' l) = insert (v, e, v') (\<alpha> l)"

  locale dlts_add = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes add :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes dlts_add_correct:
      "invar l \<Longrightarrow> \<lbrakk>\<And>v''. v'' \<noteq> v' \<Longrightarrow> (v, e, v'') \<notin> \<alpha> l\<rbrakk> \<Longrightarrow> invar (add v e v' l)"
      "invar l \<Longrightarrow> \<lbrakk>\<And>v''. v'' \<noteq> v' \<Longrightarrow> (v, e, v'') \<notin> \<alpha> l\<rbrakk> \<Longrightarrow>
       \<alpha> (add v e v' l) = insert (v, e, v') (\<alpha> l)"

  definition lts_dlts_add where
    "lts_dlts_add \<alpha> invar add \<longleftrightarrow>
     lts_add \<alpha> invar (add False) \<and> dlts_add \<alpha> invar (add True)"

  lemma lts_add_sublocale: "lts_add \<alpha> invar add \<Longrightarrow> dlts_add \<alpha> invar add"
  unfolding lts_add_def dlts_add_def
  by simp

  type_synonym ('V,'W,'L) lts_add_succs = "'V \<Rightarrow>'W \<Rightarrow> 'V list \<Rightarrow> 'L \<Rightarrow> 'L"
  locale lts_add_succs = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes add_succs :: "'V \<Rightarrow> 'W \<Rightarrow> 'V list \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes lts_add_succs_correct:
      "invar l \<Longrightarrow> invar (add_succs v e vs l)"
      "invar l \<Longrightarrow> \<alpha> (add_succs v e vs l) = (\<alpha> l) \<union> {(v, e, v') | v'. v' \<in> set vs}"

  locale dlts_add_succs = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes add_succs :: "'V \<Rightarrow> 'W \<Rightarrow> 'V list \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes dlts_add_succs_correct:
      "invar l \<Longrightarrow> length vs < 2 \<Longrightarrow> \<lbrakk>\<And>v'. v' \<notin> set vs \<Longrightarrow> (v, e, v') \<notin> \<alpha> l\<rbrakk> \<Longrightarrow> invar (add_succs v e vs l)"
      "invar l \<Longrightarrow> length vs < 2 \<Longrightarrow> \<lbrakk>\<And>v'. v' \<notin> set vs \<Longrightarrow> (v, e, v') \<notin> \<alpha> l\<rbrakk> \<Longrightarrow>
       \<alpha> (add_succs v e vs l) = (\<alpha> l) \<union> {(v, e, v') | v'. v' \<in> set vs}"

  lemma lts_add_succs_sublocale: "lts_add_succs \<alpha> invar add_succs \<Longrightarrow> dlts_add_succs \<alpha> invar add_succs"
  unfolding lts_add_succs_def dlts_add_succs_def
  by simp

  type_synonym ('V, 'W, 'L1, 'L2, 'L3) lts_union = "'L1 \<Rightarrow> 'L2 \<Rightarrow> 'L3"

  locale lts_union = lts \<alpha>1 invar1 + lts \<alpha>2 invar2 + lts \<alpha>3 invar3
    for \<alpha>1 :: "('V, 'W, 'L1) lts_\<alpha>" and invar1
    and \<alpha>2 :: "('V, 'W, 'L2) lts_\<alpha>" and invar2
    and \<alpha>3 :: "('V, 'W, 'L3) lts_\<alpha>" and invar3
    +
    fixes union :: "('V, 'W, 'L1, 'L2, 'L3) lts_union"
    assumes lts_union_correct:
      "invar1 l1 \<Longrightarrow> invar2 l2 \<Longrightarrow> invar3 (union l1 l2)"
      "invar1 l1 \<Longrightarrow> invar2 l2 \<Longrightarrow> \<alpha>3 (union l1 l2) = \<alpha>1 l1 \<union> \<alpha>2 l2"

  locale dlts_union = lts \<alpha>1 invar1 + lts \<alpha>2 invar2 + lts \<alpha>3 invar3
    for \<alpha>1 :: "('V, 'W, 'L1) lts_\<alpha>" and invar1
    and \<alpha>2 :: "('V, 'W, 'L2) lts_\<alpha>" and invar2
    and \<alpha>3 :: "('V, 'W, 'L3) lts_\<alpha>" and invar3
    +
    fixes union :: "('V, 'W, 'L1, 'L2, 'L3) lts_union"
    assumes dlts_union_correct:
      "invar1 l1 \<Longrightarrow> invar2 l2 \<Longrightarrow> LTS_is_deterministic (\<alpha>1 l1) \<Longrightarrow>
        (\<And> p a q1 q2. (p, a, q1) \<in> \<alpha>1 l1 \<Longrightarrow> (p, a, q2) \<in> \<alpha>2 l2 \<Longrightarrow> q1 = q2) \<Longrightarrow>
        invar3 (union l1 l2)"
      "invar1 l1 \<Longrightarrow> invar2 l2 \<Longrightarrow> LTS_is_deterministic (\<alpha>1 l1) \<Longrightarrow>
        (\<And> p a q1 q2. (p, a, q1) \<in> \<alpha>1 l1 \<Longrightarrow> (p, a, q2) \<in> \<alpha>2 l2 \<Longrightarrow> q1 = q2) \<Longrightarrow>
        \<alpha>3 (union l1 l2) = \<alpha>1 l1 \<union> \<alpha>2 l2"

  lemma lts_union_sublocale:
    assumes "lts_union \<alpha> invar \<alpha> invar \<alpha> invar union'"
    shows "dlts_union \<alpha> invar \<alpha> invar \<alpha> invar union'"
    using assms
    unfolding lts_union_def dlts_union_def
    by simp

  locale lts_add_label_set = lts \<alpha> invar + set \<alpha>_s invar_s
    for \<alpha> :: "('V,'W,'L) lts_\<alpha>" and invar
    and \<alpha>_s :: "'Wset \<Rightarrow> 'W set" and invar_s +
    fixes add_label_set :: "'V \<Rightarrow> 'Wset \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes lts_add_label_set_correct:
      "invar l \<Longrightarrow> invar_s es \<Longrightarrow> invar (add_label_set v es v' l)"
      "invar l \<Longrightarrow> invar_s es \<Longrightarrow>  \<alpha> (add_label_set v es v' l) = (\<alpha> l) \<union> {(v, e, v') | e. e \<in> \<alpha>_s es}"

  locale dlts_add_label_set = lts \<alpha> invar + set \<alpha>_s invar_s
    for \<alpha> :: "('V,'W,'L) lts_\<alpha>" and invar
    and \<alpha>_s :: "'Wset \<Rightarrow> 'W set" and invar_s +
    fixes add_label_set :: "'V \<Rightarrow> 'Wset \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes dlts_add_label_set_correct:
      "invar l \<Longrightarrow> invar_s es \<Longrightarrow> \<lbrakk>\<And>e v''. e \<in> \<alpha>_s es \<Longrightarrow> v'' \<noteq> v' \<Longrightarrow> (v, e, v'') \<notin> \<alpha> l\<rbrakk> \<Longrightarrow>
       invar (add_label_set v es v' l)"
      "invar l \<Longrightarrow> invar_s es \<Longrightarrow> \<lbrakk>\<And>e v''. e \<in> \<alpha>_s es \<Longrightarrow> v'' \<noteq> v' \<Longrightarrow> (v, e, v'') \<notin> \<alpha> l\<rbrakk> \<Longrightarrow>
       \<alpha> (add_label_set v es v' l) = (\<alpha> l) \<union> {(v, e, v') | e. e \<in> \<alpha>_s es}"

  lemma lts_add_label_set_sublocale: "lts_add_label_set \<alpha> invar \<alpha>_s invar_s add_label_set \<Longrightarrow>
      dlts_add_label_set \<alpha> invar \<alpha>_s invar_s add_label_set"
  unfolding lts_add_label_set_def dlts_add_label_set_def
  by simp

  type_synonym ('V,'W,'L) lts_delete = "'V \<Rightarrow>'W \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
  locale lts_delete = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes delete :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'L \<Rightarrow> 'L"
    assumes lts_delete_correct:
      "invar l \<Longrightarrow> invar (delete v e v' l)"
      "invar l \<Longrightarrow> \<alpha> (delete v e v' l) = (\<alpha> l) - {(v, e, v')}"

  type_synonym ('V,'W,'\<sigma>,'L) lts_it = "'L \<Rightarrow> (('V\<times>'W\<times>'V),'\<sigma>) set_iterator"
  locale lts_iterator = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes it :: "('V,'W,'\<sigma>,'L) lts_it"
    assumes lts_it_correct:
      "invar l \<Longrightarrow> set_iterator (it l) (\<alpha> l)"

  type_synonym ('V,'W,'\<sigma>,'L) lts_filter_it = "('V \<Rightarrow> bool) \<Rightarrow> ('W \<Rightarrow> bool) \<Rightarrow> ('V \<Rightarrow> bool) \<Rightarrow>
        (('V \<times> 'W \<times> 'V) \<Rightarrow> bool) \<Rightarrow> 'L \<Rightarrow> (('V\<times>'W\<times>'V),'\<sigma>) set_iterator"
  locale lts_filter_it = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes filter_it :: "('V,'W,'\<sigma>,'L) lts_filter_it"
    assumes lts_filter_it_correct :
      "invar l \<Longrightarrow> set_iterator (filter_it P_v1 P_e P_v2 P l)
         {(v1, e, v2) . (v1, e, v2) \<in> (\<alpha> l) \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

  type_synonym ('V,'W,'L) lts_filter = "('V \<Rightarrow> bool) \<Rightarrow> ('W \<Rightarrow> bool) \<Rightarrow> ('V \<Rightarrow> bool) \<Rightarrow>
        (('V \<times> 'W \<times> 'V) \<Rightarrow> bool) \<Rightarrow> 'L \<Rightarrow> 'L"
  locale lts_filter = lts  +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes filter :: "('V,'W,'L) lts_filter"
    assumes lts_filter_correct :
      "invar l \<Longrightarrow> invar (filter P_v1 P_e P_v2 P l)"
      "invar l \<Longrightarrow> \<alpha>(filter P_v1 P_e P_v2 P l) =
             {(v1, e, v2). (v1, e, v2) \<in> (\<alpha> l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

  type_synonym ('V1,'W1,'L1,'V2,'W2,'L2) lts_image_filter = "
        (('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)) \<Rightarrow>
        ('V1 \<Rightarrow> bool) \<Rightarrow> ('W1 \<Rightarrow> bool) \<Rightarrow> ('V1 \<Rightarrow> bool) \<Rightarrow>
        (('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> bool) \<Rightarrow> 'L1 \<Rightarrow> 'L2"
  locale lts_image_filter = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes image_filter :: "('V1,'W1,'L1,'V2,'W2,'L2) lts_image_filter"
    assumes lts_image_filter_correct :
      "invar1 l \<Longrightarrow> invar2 (image_filter f P_v1 P_e P_v2 P l)"
      "invar1 l \<Longrightarrow> \<alpha>2(image_filter f P_v1 P_e P_v2 P l) =
         f ` {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

  locale dlts_image_filter = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes image_filter
    assumes dlts_image_filter_correct :
      "invar1 l \<Longrightarrow> LTS_is_deterministic (f ` {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}) \<Longrightarrow> invar2 (image_filter f P_v1 P_e P_v2 P l)"
      "invar1 l \<Longrightarrow> LTS_is_deterministic (f ` {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}) \<Longrightarrow> \<alpha>2(image_filter f P_v1 P_e P_v2 P l) =
         f ` {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

  lemma dlts_image_filter_sublocale :
    "lts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 image_filter \<Longrightarrow>
     dlts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 image_filter"
  unfolding lts_image_filter_def dlts_image_filter_def by simp

  locale lts_image_fixed = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes image_f :: "'L1 \<Rightarrow> 'L2" and f :: "('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)"
    assumes lts_image_fixed_correct :
      "invar1 l \<Longrightarrow> invar2 (image_f l)"
      "invar1 l \<Longrightarrow> \<alpha>2(image_f l) = f ` (\<alpha>1 l)"

  type_synonym ('V1,'W1,'L1,'V2,'W2,'L2) lts_image = "
        (('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)) \<Rightarrow> 'L1 \<Rightarrow> 'L2"
  locale lts_image = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes image :: "('V1,'W1,'L1,'V2,'W2,'L2) lts_image"
    assumes lts_image_correct :
      "invar1 l \<Longrightarrow> invar2 (image f l)"
      "invar1 l \<Longrightarrow> \<alpha>2(image f l) = f ` (\<alpha>1 l)"

  lemma lts_image_alt_def :
    "lts_image \<alpha>1 invar1 \<alpha>2 invar2 im \<longleftrightarrow>
     (\<forall>f. lts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 (im f) f)"
    unfolding lts_image_def lts_image_fixed_def by auto

  locale dlts_image_fixed = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes image_f :: "'L1 \<Rightarrow> 'L2" and f :: "('V1 \<times> 'W1 \<times> 'V1) \<Rightarrow> ('V2 \<times> 'W2 \<times> 'V2)"
    assumes dlts_image_fixed_correct :
      "invar1 l \<Longrightarrow> LTS_is_deterministic (f ` (\<alpha>1 l)) \<Longrightarrow> invar2 (image_f l)"
      "invar1 l \<Longrightarrow> LTS_is_deterministic (f ` (\<alpha>1 l)) \<Longrightarrow> \<alpha>2(image_f l) = f ` (\<alpha>1 l)"

  locale dlts_image = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes image :: "('V1,'W1,'L1,'V2,'W2,'L2) lts_image"
    assumes dlts_image_correct :
      "invar1 l \<Longrightarrow> LTS_is_deterministic (f ` (\<alpha>1 l)) \<Longrightarrow> invar2 (image f l)"
      "invar1 l \<Longrightarrow> LTS_is_deterministic (f ` (\<alpha>1 l)) \<Longrightarrow> \<alpha>2(image f l) = f ` (\<alpha>1 l)"

  lemma dlts_image_alt_def :
    "dlts_image \<alpha>1 invar1 \<alpha>2 invar2 im \<longleftrightarrow>
     (\<forall>f. dlts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 (im f) f)"
    unfolding dlts_image_def dlts_image_fixed_def by auto

  lemma dlts_image_sublocale :
    "lts_image \<alpha>1 invar1 \<alpha>2 invar2 im \<Longrightarrow>
     dlts_image \<alpha>1 invar1 \<alpha>2 invar2 im"
  unfolding lts_image_def dlts_image_def by simp

  lemma dlts_image_fixed_sublocale :
    "lts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 im f \<Longrightarrow>
     dlts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 im f"
  unfolding lts_image_fixed_def dlts_image_fixed_def by simp

  definition lts_rename_states_fixed where
    "lts_rename_states_fixed \<alpha>1 invar1 \<alpha>2 invar2 im f =
     lts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 im
        (\<lambda>qaq. (f (fst qaq), fst (snd qaq), f (snd (snd qaq))))"

  definition dlts_rename_states_fixed where
    "dlts_rename_states_fixed \<alpha>1 invar1 \<alpha>2 invar2 im f =
     dlts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 im
        (\<lambda>qaq. (f (fst qaq), fst (snd qaq), f (snd (snd qaq))))"

  definition lts_rename_labels_fixed where
    "lts_rename_labels_fixed \<alpha>1 invar1 \<alpha>2 invar2 im f =
     lts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 im
        (\<lambda>qaq. (fst qaq, f (fst (snd qaq)), snd (snd qaq)))"

  definition dlts_rename_labels_fixed where
    "dlts_rename_labels_fixed \<alpha>1 invar1 \<alpha>2 invar2 im f =
     dlts_image_fixed \<alpha>1 invar1 \<alpha>2 invar2 im
        (\<lambda>qaq. (fst qaq, f (fst (snd qaq)), snd (snd qaq)))"

  locale lts_inj_image_filter = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V1,'W1,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V2,'W2,'L2) lts_\<alpha>" and invar2 +
    fixes inj_image_filter
    assumes lts_inj_image_filter_correct :
      "invar1 l \<Longrightarrow> LTS_image_filter_inj_on f {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)} \<Longrightarrow> invar2 (inj_image_filter f P_v1 P_e P_v2 P l)"
      "invar1 l \<Longrightarrow> LTS_image_filter_inj_on f {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)} \<Longrightarrow> \<alpha>2(inj_image_filter f P_v1 P_e P_v2 P l) =
         f ` {(v1, e, v2). (v1, e, v2) \<in> (\<alpha>1 l) \<and> P_v1 v1 \<and>
               P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

  lemma lts_inj_image_filter_sublocale :
    "lts_image_filter \<alpha>1 invar1 \<alpha>2 invar2 image_filter \<Longrightarrow>
     lts_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 image_filter"
  unfolding lts_image_filter_def lts_inj_image_filter_def by simp

  type_synonym ('V,'W,'\<sigma>,'L) lts_succ_label_it =
    "'L \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,'\<sigma>) set_iterator"
  locale lts_succ_label_it = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes succ_label_it :: "('V,'W,'\<sigma>,'L) lts_succ_label_it"
    assumes lts_succ_label_it_correct:
      "invar l \<Longrightarrow> set_iterator (succ_label_it l v) {(e, v') . (v, e, v') \<in> (\<alpha> l)}"

  type_synonym ('V,'W,'\<sigma>,'L) lts_succ_label_abs_it =
    "'L \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,'\<sigma>) set_iterator"
  locale lts_succ_label_abs_it = lts \<alpha> invar + set \<alpha>_s invar_s
    for \<alpha> :: "('V,'W,'L) lts_\<alpha>" and invar
    and \<alpha>_s :: "'Vset \<Rightarrow> 'V set" and invar_s +
    fixes succ_label_abs_it
    assumes lts_succ_label_abs_it_correct:
      "invar l \<Longrightarrow> map_iterator_abs \<alpha>_s invar_s (succ_label_abs_it l v)
           (\<lambda>e. let vs = {v' . (v, e, v') \<in> \<alpha> l} in (if vs = {} then None else Some vs))"

  type_synonym ('V,'W,'\<sigma>,'L) lts_pre_label_it =  "'L \<Rightarrow> 'V \<Rightarrow> ('V\<times>'W,'\<sigma>) set_iterator"
  locale lts_pre_label_it = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes pre_label_it :: "'L \<Rightarrow> 'V \<Rightarrow> ('V\<times>'W,'\<sigma>) set_iterator"
    assumes lts_pre_label_it_correct:
      "invar l \<Longrightarrow> set_iterator (pre_label_it l v') {(v, e) . (v, e, v') \<in> (\<alpha> l)}"

  type_synonym ('V,'W,'\<sigma>,'L) lts_succ_it =
    "'L \<Rightarrow> 'V \<Rightarrow> 'W \<Rightarrow> ('V,'\<sigma>) set_iterator"
  locale lts_succ_it = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes succ_it :: "('V,'W,'\<sigma>,'L) lts_succ_it"
    assumes lts_succ_it_correct:
      "invar l \<Longrightarrow> set_iterator (succ_it l v e) {v' . (v, e, v') \<in> (\<alpha> l)}"

  type_synonym ('V,'W,'\<sigma>,'L) lts_pre_it =  "'L \<Rightarrow> 'V \<Rightarrow> 'W \<Rightarrow> ('V,'\<sigma>) set_iterator"
  locale lts_pre_it = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes pre_it :: "('V,'W,'\<sigma>,'L) lts_pre_it"
    assumes lts_pre_it_correct:
      "invar l \<Longrightarrow> set_iterator (pre_it l v' e) {v . (v, e, v') \<in> (\<alpha> l)}"

  type_synonym ('V,'W,'L) lts_succ_bquant = "'L \<Rightarrow> ('V \<Rightarrow> bool) \<Rightarrow> 'V \<Rightarrow> 'W \<Rightarrow> bool"
  locale lts_succ_ball = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes succ_ball :: "('V,'W,'L) lts_succ_bquant"
    assumes lts_succ_ball_correct:
      "invar l \<Longrightarrow> succ_ball l P v e \<longleftrightarrow> (\<forall>v'. (v, e, v') \<in> (\<alpha> l) \<longrightarrow> P v')"

  locale lts_succ_bex = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes succ_bex :: "('V,'W,'L) lts_succ_bquant"
    assumes lts_succ_bex_correct:
      "invar l \<Longrightarrow> succ_bex l P v e \<longleftrightarrow> (\<exists>v'. (v, e, v') \<in> (\<alpha> l) \<and> P v')"

  type_synonym ('V,'W,'L) lts_pre_bquant = "'L \<Rightarrow> ('V \<Rightarrow> bool) \<Rightarrow> 'V \<Rightarrow> 'W \<Rightarrow> bool"
  locale lts_pre_ball = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes pre_ball :: "('V,'W,'L) lts_pre_bquant"
    assumes lts_pre_ball_correct:
      "invar l \<Longrightarrow> pre_ball l P v' e \<longleftrightarrow> (\<forall>v. (v, e, v') \<in> (\<alpha> l) \<longrightarrow> P v)"

  locale lts_pre_bex = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes pre_bex :: "('V,'W,'L) lts_pre_bquant"
    assumes lts_pre_bex_correct:
      "invar l \<Longrightarrow> pre_bex l P v' e \<longleftrightarrow> (\<exists>v. (v, e, v') \<in> (\<alpha> l) \<and> P v)"

  type_synonym ('V,'W,'L) lts_from_list = "('V \<times> 'W \<times> 'V) list \<Rightarrow> 'L"
  locale lts_from_list = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes from_list :: "('V,'W,'L) lts_from_list"
    assumes lts_from_list_correct:
      "invar (from_list ll)"
      "\<alpha> (from_list ll) = set ll"

  locale dlts_from_list = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes from_list :: "('V,'W,'L) lts_from_list"
    assumes dlts_from_list_correct:
      "(\<forall>v w v' v''. (v, w, v') \<in> set ll \<and> (v, w, v'') \<in> set ll \<longrightarrow> v' = v'') \<Longrightarrow> invar (from_list ll)"
      "(\<forall>v w v' v''. (v, w, v') \<in> set ll \<and> (v, w, v'') \<in> set ll \<longrightarrow> v' = v'') \<Longrightarrow>
         \<alpha> (from_list ll) = set ll"

  lemma lts_from_list_sublocale: "lts_from_list \<alpha> invar from_list \<Longrightarrow>
                                  dlts_from_list \<alpha> invar from_list"
  unfolding lts_from_list_def dlts_from_list_def
  by simp

  type_synonym ('V,'W,'L) lts_to_list = "'L \<Rightarrow> ('V \<times> 'W \<times> 'V) list"
  locale lts_to_list = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes to_list :: "('V,'W,'L) lts_to_list"
    assumes lts_to_list_correct:
      "invar l \<Longrightarrow> set (to_list l) = \<alpha> l"
      "invar l \<Longrightarrow> distinct (to_list l)"

  type_synonym ('V,'W,'L) lts_to_collect_list = "'L \<Rightarrow> ('V \<times> 'W list \<times> 'V) list"
  locale lts_to_collect_list = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes to_collect_list :: "('V,'W,'L) lts_to_collect_list"
    assumes lts_to_collect_list_correct:
      "invar l \<Longrightarrow> \<alpha> l = {(v, e, v'). \<exists>es. (v, es, v') \<in> set (to_collect_list l) \<and> e \<in> set es}"
      "invar l \<Longrightarrow> distinct (map (\<lambda>vesv'. (fst vesv', snd (snd vesv'))) (to_collect_list l))"
      "invar l \<Longrightarrow> (v, es, v') \<in> set (to_collect_list l) \<Longrightarrow> es \<noteq> []"

  type_synonym ('V,'W,'L) lts_from_collect_list = "('V \<times> 'W list \<times> 'V) list \<Rightarrow> 'L"
  locale lts_from_collect_list = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes from_collect_list :: "('V,'W,'L) lts_from_collect_list"
    assumes lts_from_collect_list_correct:
      "invar (from_collect_list ll)"
      "\<alpha> (from_collect_list ll) = {(v, e, v'). \<exists>es. (v, es, v') \<in> set ll \<and> e \<in> set es}"

  locale dlts_from_collect_list = lts +
    constrains \<alpha> :: "('V,'W,'L) lts_\<alpha>"
    fixes from_collect_list :: "('V,'W,'L) lts_from_collect_list"
    assumes dlts_from_collect_list_correct:
      "(\<forall>v ws ws' w v' v''. (v, ws, v') \<in> set ll \<and> (v, ws', v'') \<in> set ll \<and>
                               (w \<in> set ws) \<and> (w \<in> set ws') \<longrightarrow> (v' = v'')) \<Longrightarrow>
       invar (from_collect_list ll)"
      "(\<forall>v ws ws' w v' v''. (v, ws, v') \<in> set ll \<and> (v, ws', v'') \<in> set ll \<and>
                               (w \<in> set ws) \<and> (w \<in> set ws') \<longrightarrow> (v' = v'')) \<Longrightarrow>
       \<alpha> (from_collect_list ll) = {(v, e, v'). \<exists>es. (v, es, v') \<in> set ll \<and> e \<in> set es}"

  lemma lts_from_collect_list_sublocale: "lts_from_collect_list \<alpha> invar from_collect_list \<Longrightarrow>
                                  dlts_from_collect_list \<alpha> invar from_collect_list"
  unfolding lts_from_collect_list_def dlts_from_collect_list_def
  by simp

  type_synonym ('V,'W,'L1,'L2) lts_reverse = "'L1 \<Rightarrow> 'L2"
  locale lts_reverse = lts \<alpha>1 invar1 + lts \<alpha>2 invar2
    for \<alpha>1 :: "('V,'W,'L1) lts_\<alpha>" and invar1 and
        \<alpha>2 :: "('V,'W,'L2) lts_\<alpha>" and invar2 +
    fixes reverse :: "('V,'W,'L1,'L2) lts_reverse"
    assumes lts_reverse_correct:
      "invar1 l \<Longrightarrow> invar2 (reverse l)"
      "invar1 l \<Longrightarrow> \<alpha>2 (reverse l) = {(v', e, v) | v e v'. (v, e, v') \<in> \<alpha>1 l}"

  type_synonym ('V,'W,'L,'\<sigma>_s) lts_get_succ_set =
    "'L \<Rightarrow> 'V list \<Rightarrow> 'W \<Rightarrow> '\<sigma>_s"
  locale lts_get_succ_set = lts \<alpha> invar + set \<alpha>_s invar_s
    for \<alpha> :: "('V,'W,'L) lts_\<alpha>" and invar and
        \<alpha>_s :: "'\<sigma>_s \<Rightarrow> 'V set" and invar_s +
    fixes get_succ_set :: "('V,'W,'L,'\<sigma>_s) lts_get_succ_set"
    assumes lts_get_succ_set_correct:
      "invar l \<Longrightarrow> invar_s (get_succ_set l vs e)"
      "invar l \<Longrightarrow> \<alpha>_s (get_succ_set l vs e) = {v' . \<exists>v. v \<in> set vs \<and> (v, e, v') \<in> (\<alpha> l)}"

  definition lts_iterator_union :: "('V, 'W, 'L, 'L) lts_it \<Rightarrow>
    ('V ,'W, 'L) lts_add \<Rightarrow> ('V, 'W, 'L, 'L, 'L) lts_union"
  where "lts_iterator_union iterator add l1 l2 =
    iterator l1 (\<lambda> _. True) (\<lambda> (p, a, q). add p a q) l2"

  lemma lts_iterator_union_correct:
    assumes a: "lts_iterator \<alpha> invar iterator"
    assumes b: "lts_add \<alpha> invar add"
    shows "lts_union \<alpha> invar \<alpha> invar \<alpha> invar (lts_iterator_union iterator add)"
  proof -
    interpret lts_iterator \<alpha> invar iterator using a by assumption
    interpret lts_add \<alpha> invar add using b by assumption
    show ?thesis
      apply (unfold_locales)
      unfolding lts_iterator_union_def
      apply (rule_tac I = "\<lambda> _ \<sigma>. invar \<sigma>" in set_iterator_rule_P[OF lts_it_correct])
      apply (auto simp: lts_add_correct) [5]
      apply (rule_tac I = "\<lambda> it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> l2"
        in set_iterator_rule_insert_P[OF lts_it_correct])
      apply (auto simp: lts_add_correct) [5]
    done
  qed

  lemma dlts_iterator_union_correct:
    assumes a: "lts_iterator \<alpha> invar iterator"
    assumes b: "dlts_add \<alpha> invar add"
    shows "dlts_union \<alpha> invar \<alpha> invar \<alpha> invar (lts_iterator_union iterator add)"
  proof -
    interpret lts_iterator \<alpha> invar iterator using a by assumption
    interpret dlts_add \<alpha> invar add using b by assumption
    show ?thesis
    proof (unfold_locales)
      fix l1 l2
      assume a: "invar l1" "invar l2"
      assume b: "LTS_is_deterministic (\<alpha> l1)"
      assume c: "\<And> p a q1 q2. (p, a, q1) \<in> \<alpha> l1 \<Longrightarrow> (p, a, q2) \<in> \<alpha> l2 \<Longrightarrow> q1 = q2"

      {
        fix S \<sigma> p a q
        assume a: "(p, a, q) \<in> \<alpha> l1 - S" "invar \<sigma>" "\<alpha> \<sigma> = S \<union> \<alpha> l2" "S \<subseteq> \<alpha> l1"
        have "\<And> q'. (p, a, q') \<in> \<alpha> \<sigma> \<Longrightarrow> q' = q"
          using a b c
          unfolding LTS_is_deterministic_def
          by blast
        hence
          "invar (add p a q \<sigma>)"
          "\<alpha> (add p a q \<sigma>) = insert (p, a, q) S \<union> \<alpha> l2"
          using dlts_add_correct a
          by blast+
      }
      note d = this

      let ?I = "\<lambda> S \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = S \<union> \<alpha> l2"
      show "invar (lts_iterator_union iterator add l1 l2)"
        unfolding lts_iterator_union_def
        apply (rule set_iterator_rule_insert_P[OF lts_it_correct, where I = ?I])
        using a d
        apply auto
      done
      show "\<alpha> (lts_iterator_union iterator add l1 l2) = \<alpha> l1 \<union> \<alpha> l2"
        unfolding lts_iterator_union_def
        apply (rule set_iterator_rule_insert_P[OF lts_it_correct, where I = ?I])
        using a d
        apply auto
      done
    qed
  qed

  section \<open> Record Based Interface \<close>
  record ('V,'W,'L) lts_ops =
    lts_op_\<alpha> :: "('V,'W,'L) lts_\<alpha>"
    lts_op_invar :: "'L \<Rightarrow> bool"
    lts_op_empty :: "('V,'W,'L) lts_empty"
    lts_op_memb :: "('V,'W,'L) lts_memb"
    lts_op_iterator :: "('V, 'W, 'L, 'L) lts_it"
    lts_op_add :: "('V,'W,'L) lts_add"
    lts_op_add_succs :: "('V,'W,'L) lts_add_succs"
    lts_op_delete :: "('V,'W,'L) lts_delete"
    lts_op_succ_ball :: "('V,'W,'L) lts_succ_bquant"
    lts_op_succ_bex :: "('V,'W,'L) lts_succ_bquant"
    lts_op_pre_ball :: "('V,'W,'L) lts_pre_bquant"
    lts_op_pre_bex :: "('V,'W,'L) lts_pre_bquant"
    lts_op_to_list :: "('V,'W,'L) lts_to_list"
    lts_op_to_collect_list :: "('V,'W,'L) lts_to_collect_list"
    lts_op_from_list :: "('V,'W,'L) lts_from_list"
    lts_op_from_collect_list :: "('V,'W,'L) lts_from_collect_list"
    lts_op_image_filter :: "('V,'W,'L,'V,'W,'L) lts_image_filter"
    lts_op_filter :: "('V,'W,'L) lts_filter"
    lts_op_image :: "('V,'W,'L,'V,'W,'L) lts_image"
    lts_op_succ :: "('V,'W,'L) lts_succ"

  locale StdCommonLTSDefs =
    fixes ops :: "('V,'W,'L,'m) lts_ops_scheme"
  begin
    abbreviation \<alpha> where "\<alpha> \<equiv> lts_op_\<alpha> ops"
    abbreviation invar where "invar \<equiv> lts_op_invar ops"
    abbreviation empty where "empty \<equiv> lts_op_empty ops"
    abbreviation memb where "memb \<equiv> lts_op_memb ops"
    abbreviation iterator where "iterator \<equiv> lts_op_iterator ops"
    abbreviation add where "add \<equiv> lts_op_add ops"
    abbreviation add_succs where "add_succs \<equiv> lts_op_add_succs ops"
    abbreviation delete where "delete \<equiv> lts_op_delete ops"
    abbreviation from_list where "from_list \<equiv> lts_op_from_list ops"
    abbreviation from_collect_list where "from_collect_list \<equiv> lts_op_from_collect_list ops"
    abbreviation to_list where "to_list \<equiv> lts_op_to_list ops"
    abbreviation to_collect_list where "to_collect_list \<equiv> lts_op_to_collect_list ops"
    abbreviation succ_ball where "succ_ball \<equiv> lts_op_succ_ball ops"
    abbreviation succ_bex where "succ_bex \<equiv> lts_op_succ_bex ops"
    abbreviation pre_ball where "pre_ball \<equiv> lts_op_pre_ball ops"
    abbreviation pre_bex where "pre_bex \<equiv> lts_op_pre_bex ops"
    abbreviation image_filter where "image_filter \<equiv> lts_op_image_filter ops"
    abbreviation filter where "filter \<equiv> lts_op_filter ops"
    abbreviation image where "image \<equiv> lts_op_image ops"
    abbreviation succ where "succ \<equiv> lts_op_succ ops"
    abbreviation union where "union \<equiv> lts_iterator_union iterator add"
  end

  locale StdCommonLTS = StdCommonLTSDefs +
    finite_lts \<alpha> invar +
    lts_empty \<alpha> invar empty +
    lts_memb \<alpha> invar memb +
    lts_iterator \<alpha> invar iterator +
    lts_to_list \<alpha> invar to_list +
    lts_to_collect_list \<alpha> invar to_collect_list +
    lts_succ_ball \<alpha> invar succ_ball +
    lts_pre_ball \<alpha> invar pre_ball +
    lts_succ_bex \<alpha> invar succ_bex +
    lts_pre_bex \<alpha> invar pre_bex +
    dlts_add \<alpha> invar add +
    dlts_add_succs \<alpha> invar add_succs +
    lts_delete \<alpha> invar delete +
    dlts_from_list \<alpha> invar from_list +
    dlts_from_collect_list \<alpha> invar from_collect_list +
    lts_filter \<alpha> invar filter +
    dlts_image_filter \<alpha> invar \<alpha> invar image_filter +
    dlts_image \<alpha> invar \<alpha> invar image +
    lts_inj_image_filter \<alpha> invar  \<alpha> invar image_filter +
    lts_succ \<alpha> invar succ
  begin
    lemmas dlts_union_axioms = dlts_iterator_union_correct[OF lts_iterator_axioms dlts_add_axioms]
    lemmas correct_common = lts_empty_correct lts_memb_correct lts_it_correct
       lts_to_list_correct dlts_from_collect_list_correct
       lts_succ_ball_correct lts_pre_ball_correct lts_succ_correct
       lts_succ_bex_correct lts_pre_bex_correct
       dlts_add_correct dlts_add_succs_correct lts_delete_correct dlts_from_list_correct
       dlts_image_filter_correct lts_inj_image_filter_correct lts_filter_correct dlts_image_correct
       dlts_union.dlts_union_correct[OF dlts_union_axioms]
  end

  locale StdLTS = StdCommonLTSDefs +
    finite_lts \<alpha> invar +
    lts_empty \<alpha> invar empty +
    lts_memb \<alpha> invar memb +
    lts_iterator \<alpha> invar iterator +
    lts_to_list \<alpha> invar to_list +
    lts_to_collect_list \<alpha> invar to_collect_list +
    lts_succ_ball \<alpha> invar succ_ball +
    lts_pre_ball \<alpha> invar pre_ball +
    lts_succ_bex \<alpha> invar succ_bex +
    lts_pre_bex \<alpha> invar pre_bex +
    lts_add \<alpha> invar add +
    lts_add_succs \<alpha> invar add_succs +
    lts_delete \<alpha> invar delete +
    lts_from_list \<alpha> invar from_list +
    lts_from_collect_list \<alpha> invar from_collect_list +
    lts_filter \<alpha> invar filter +
    lts_image_filter \<alpha> invar \<alpha> invar image_filter +
    lts_image \<alpha> invar \<alpha> invar image +
    lts_succ \<alpha> invar succ
  begin
    lemmas lts_union_axioms = lts_iterator_union_correct[OF lts_iterator_axioms lts_add_axioms]
    lemmas correct = lts_empty_correct lts_memb_correct lts_it_correct
       lts_to_list_correct lts_succ_ball_correct lts_pre_ball_correct
       lts_succ_bex_correct lts_pre_bex_correct lts_succ_correct
       lts_add_correct lts_add_succs_correct lts_delete_correct lts_from_list_correct
       lts_from_collect_list_correct
       lts_image_filter_correct lts_filter_correct lts_image_correct
       lts_union.lts_union_correct[OF lts_union_axioms]
  end

  lemma StdLTS_sublocale : "StdLTS ops \<Longrightarrow> StdCommonLTS ops"
    unfolding StdLTS_def StdCommonLTS_def
    by (simp add: lts_add_sublocale lts_add_succs_sublocale
                  lts_from_list_sublocale lts_from_collect_list_sublocale
                  lts_inj_image_filter_sublocale dlts_image_filter_sublocale
                  dlts_image_sublocale)

  sublocale StdLTS < StdCommonLTS using StdLTS_sublocale [OF StdLTS_axioms] .

  locale StdDLTS = StdCommonLTSDefs +
    finite_lts \<alpha> invar +
    lts_empty \<alpha> invar empty +
    lts_memb \<alpha> invar memb +
    lts_iterator \<alpha> invar iterator +
    lts_to_list \<alpha> invar to_list +
    lts_to_collect_list \<alpha> invar to_collect_list +
    lts_succ_ball \<alpha> invar succ_ball +
    lts_pre_ball \<alpha> invar pre_ball +
    lts_succ_bex \<alpha> invar succ_bex +
    lts_pre_bex \<alpha> invar pre_bex +
    dlts_add \<alpha> invar add +
    dlts_add_succs \<alpha> invar add_succs +
    lts_delete \<alpha> invar delete +
    dlts_from_list \<alpha> invar from_list +
    dlts_from_collect_list \<alpha> invar from_collect_list +
    lts_filter \<alpha> invar filter +
    dlts_image_filter \<alpha> invar \<alpha> invar image_filter +
    dlts_image \<alpha> invar \<alpha> invar image +
    lts_inj_image_filter \<alpha> invar  \<alpha> invar image_filter +
    dlts_succ \<alpha> invar succ
  begin
    lemmas dlts_union_axioms = dlts_iterator_union_correct[OF lts_iterator_axioms dlts_add_axioms]
    lemmas correct = lts_empty_correct lts_memb_correct lts_it_correct
       lts_to_list_correct dlts_from_collect_list_correct
       lts_succ_ball_correct lts_pre_ball_correct dlts_succ_correct
       lts_succ_bex_correct lts_pre_bex_correct
       dlts_add_correct dlts_add_succs_correct lts_delete_correct dlts_from_list_correct
       dlts_image_filter_correct lts_inj_image_filter_correct lts_filter_correct dlts_image_correct
       dlts_union.dlts_union_correct[OF dlts_union_axioms]
  end

  lemma StdDLTS_sublocale : "StdDLTS ops \<Longrightarrow> StdCommonLTS ops"
    unfolding StdDLTS_def StdCommonLTS_def
    by (simp add: dlts_succ_sublocale)

  lemma StdLTS_sublocale2 : "StdLTS ops \<Longrightarrow> StdDLTS (ops \<lparr> lts_op_invar :=
       \<lambda>l. LTS_is_deterministic (lts_op_\<alpha> ops l) \<and> lts_op_invar ops l \<rparr>)"
    unfolding StdDLTS_def
    apply simp_all
    proof (intro conjI)
      assume "StdLTS ops"
      interpret lts: StdLTS ops by fact
      let ?invar' = "\<lambda>l. LTS_is_deterministic (lts_op_\<alpha> ops l) \<and> lts_op_invar ops l"

      show "finite_lts lts.\<alpha> ?invar'"
           "lts_memb lts.\<alpha> ?invar' lts.memb"
           "lts_iterator lts.\<alpha> ?invar' lts.iterator"
           "lts_to_list lts.\<alpha> ?invar' lts.to_list"
           "lts_succ_ball lts.\<alpha> ?invar' lts.succ_ball"
           "lts_succ_bex lts.\<alpha> ?invar' lts.succ_bex"
           "lts_pre_ball lts.\<alpha> ?invar' lts.pre_ball"
           "lts_pre_bex lts.\<alpha> ?invar' lts.pre_bex"
           "dlts_image_filter lts.\<alpha> ?invar' lts.\<alpha> ?invar' lts.image_filter"
        unfolding finite_lts_def lts_empty_def lts_memb_def lts_iterator_def
                  lts_to_list_def lts_succ_ball_def lts_succ_bex_def
                  lts_pre_ball_def lts_pre_bex_def lts_delete_def
                  dlts_image_filter_def
        by (simp_all add: lts.correct)

      show "lts_empty lts.\<alpha> ?invar' lts.empty"
        unfolding lts_empty_def LTS_is_deterministic_def
      by (simp add: lts.correct)

      show "lts_to_collect_list lts.\<alpha> ?invar' lts.to_collect_list"
        unfolding lts_to_collect_list_def
        using lts.lts_to_collect_list_correct
      by blast

      show "dlts_add lts.\<alpha> ?invar' lts.add"
        unfolding dlts_add_def
        using lts.lts_add_correct
      by (auto simp add: LTS_is_deterministic_def) metis+

      show "dlts_add_succs lts.\<alpha> ?invar' lts.add_succs"
        unfolding dlts_add_succs_def
        using lts.lts_add_succs_correct
        apply (simp add: LTS_is_deterministic_def length_Suc_conv)
        apply (subgoal_tac "\<And>xs::'a list. length xs < 2 \<longleftrightarrow> xs = [] \<or> (\<exists>x. xs = [x])")
        apply auto[]
        apply fastforce
        apply (case_tac xs)
        apply simp_all
      done

      show "lts_delete lts.\<alpha> ?invar' lts.delete"
        unfolding lts_delete_def
        using lts.lts_delete_correct
        by (auto simp add: LTS_is_deterministic_def)

      show "dlts_from_list lts.\<alpha> ?invar' lts.from_list"
        unfolding dlts_from_list_def
        using lts.lts_from_list_correct
      by (simp add: LTS_is_deterministic_def)

      show "dlts_from_collect_list lts.\<alpha> ?invar' lts.from_collect_list"
        unfolding dlts_from_collect_list_def
        using lts.lts_from_collect_list_correct
      by (simp add: LTS_is_deterministic_def) blast

      show "lts_filter lts.\<alpha> ?invar' lts.filter"
        unfolding lts_filter_def
        using lts.lts_filter_correct
      by (simp add: LTS_is_deterministic_def) blast

      show "lts_inj_image_filter lts.\<alpha> ?invar' lts.\<alpha> ?invar' lts.image_filter"
      proof
        fix f :: "'a \<times> 'b \<times> 'a \<Rightarrow> 'a \<times> 'b \<times> 'a"
        fix l P_v1 P_e P_v2 P
        assume invar_l: "LTS_is_deterministic (lts.\<alpha> l) \<and> lts.invar l"
        assume inj_on: "LTS_image_filter_inj_on f {(v1, e, v2).
          (v1, e, v2) \<in> lts.\<alpha> l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)}"

        have \<alpha>_eq: "lts.\<alpha> (lts.image_filter f P_v1 P_e P_v2 P l) =
           f ` {(v1, e, v2). (v1, e, v2) \<in> lts.\<alpha> l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)} "
          and invar_filter: "lts.invar (lts.image_filter f P_v1 P_e P_v2 P l)"
          using lts.lts_image_filter_correct [of l f P_v1 P_e P_v2 P] invar_l by simp_all

        show "lts.\<alpha> (lts.image_filter f P_v1 P_e P_v2 P l) =
           f ` {(v1, e, v2). (v1, e, v2) \<in> lts.\<alpha> l \<and> P_v1 v1 \<and> P_e e \<and> P_v2 v2 \<and> P (v1, e, v2)} "
          using \<alpha>_eq .

        from inj_on invar_l
        show "LTS_is_deterministic (lts.\<alpha> (lts.image_filter f P_v1 P_e P_v2 P l)) \<and>
              lts.invar (lts.image_filter f P_v1 P_e P_v2 P l)"
          unfolding \<alpha>_eq
          apply (simp add: invar_filter)
          apply (rule_tac lts_image_filter_inj_on_implies_deterministic)
          apply (simp_all add: LTS_is_deterministic_def)
          apply blast
        done
      qed

      show "dlts_image lts.\<alpha> ?invar' lts.\<alpha> ?invar' lts.image"
        unfolding dlts_image_def
        using lts.lts_image_correct
      by (simp add: LTS_is_deterministic_def)

      show "dlts_succ lts.\<alpha> ?invar' lts.succ"
        unfolding dlts_succ_def
        using lts.lts_succ_det_correct
      by simp
    qed

end


theory Hotel_Example_Prolog
imports
  Hotel_Example
  "~~/src/HOL/Library/Predicate_Compile_Alternative_Defs"
  "~~/src/HOL/Library/Code_Prolog"
begin

declare Let_def[code_pred_inline]
(*
thm hotel_def
lemma [code_pred_inline]: "insert == (%y A x. y = x | A x)"
by (auto simp add: insert_iff[unfolded mem_def] fun_eq_iff intro!: eq_reflection)

lemma [code_pred_inline]: "(op -) == (%A B x. A x \<and> \<not> B x)"
by (auto simp add: Diff_iff[unfolded mem_def] fun_eq_iff intro!: eq_reflection)
*)

definition issuedp :: "event list => key => bool"
where
  "issuedp evs k = (k \<in> issued evs)"

lemma [code_pred_def]:
  "issuedp [] Key0 = True"
  "issuedp (e # s) k = (issuedp s k \<or> (case e of Check_in g r (k1, k2) => k = k2 | _ => False))"
unfolding issuedp_def issued.simps initk_def
by (auto split: event.split)

definition cardsp
where
 "cardsp s g k = (k \<in> cards s g)"

lemma [code_pred_def]:
  "cardsp [] g k = False"
  "cardsp (e # s) g k =
    (let C = cardsp s g
     in case e of Check_in g' r c => if g' = g then k = c \<or> C k else C k | _ => C k)"
unfolding cardsp_def [abs_def] cards.simps by (auto simp add: Let_def split: event.split)

definition
  "isinp evs r g = (g \<in> isin evs r)"

lemma [code_pred_def]:
  "isinp [] r g = False"
  "isinp (e # s) r g =
  (let G = isinp s r
   in case e of Check_in g' r c => G g
    | Enter g' r' c => if r' = r then g = g' \<or> G g else G g
    | Exit g' r' => if r' = r then ((g \<noteq> g') \<and> G g) else G g)"
unfolding isinp_def [abs_def] isin.simps by (auto simp add: Let_def split: event.split)

declare hotel.simps(1)[code_pred_def]
lemma [code_pred_def]:
"hotel (e # s) =
  (hotel s & (case e of Check_in g r (k, k') => k = currk s r & \<not> issuedp s k'
  | Enter g r (k, k') => cardsp s g (k, k') & (roomk s r = k \<or> roomk s r = k')
  | Exit g r => isinp s r g))"
unfolding hotel.simps issuedp_def cardsp_def isinp_def
by (auto split: event.split)

declare List.member_rec[code_pred_def]

lemma [code_pred_def]: "no_Check_in s r = (~ (EX g c. List.member s (Check_in g r c)))"
unfolding no_Check_in_def member_def by auto

lemma [code_pred_def]: "feels_safe s r =
(EX s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
    s =
    s\<^sub>3 @
    [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 &
    no_Check_in (s\<^sub>3 @ s\<^sub>2) r &
    (\<not> (\<exists> g'. isinp (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r g')))"
unfolding feels_safe_def isinp_def by auto

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = []})\<close>

values_prolog 40 "{s. hotel s}"

setup \<open>
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
\<close>

lemma "\<lbrakk> hotel s; isinp s r g \<rbrakk> \<Longrightarrow> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

section \<open>Manual setup to find the counterexample\<close>

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [],
   limited_predicates = [(["hotel"], 4)],
   replacing = [(("hotel", "limited_hotel"), "quickcheck")],
   manual_reorder = []})\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = no_counterexample]
oops

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [],
   limited_predicates = [(["hotel"], 5)],
   replacing = [(("hotel", "limited_hotel"), "quickcheck")],
   manual_reorder = []})\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

section \<open>Using a global limit for limiting the execution\<close>

text \<open>A global depth limit of 10 does not suffice to find the counterexample.\<close>

setup \<open>
  Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = SOME 10,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = []})
\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = no_counterexample]
oops

text \<open>But a global depth limit of 11 does.\<close>

setup \<open>
  Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = SOME 11,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = []})
\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

end


theory BarcanDeduce
  imports Main QML_S5

begin

lemma BF:  "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<box>(\<phi>(x))) \<^bold>\<rightarrow>  \<^bold>\<box>(\<^bold>\<forall>x. \<phi>(x))\<rfloor>"
  by simp

lemma CBF:  "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x. \<phi>(x)) \<^bold>\<rightarrow> (\<^bold>\<forall>x. \<^bold>\<box>(\<phi>(x)))\<rfloor>"
   by simp

consts x::'a  y::'a
lemma NE: "valid((mforall(x mbox(mexists(y (y \<^bold>\<leftrightarrow> x))))))"
  nitpick
  oops

consts big::"'a \<Rightarrow> \<sigma>"
consts smaller::"'a \<Rightarrow> 'a \<Rightarrow> \<sigma>"

lemma "\<lfloor>\<^bold>\<box> (\<^bold>\<exists>x. big x \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists> y. smaller y x))\<rfloor>"
  nitpick
  oops

end


theory nmap_expr
imports nmap_var
begin

section \<open> Expression type \<close>

typedef ('t, '\<alpha>) uexpr = "UNIV :: ('\<alpha> \<Rightarrow> 't) set" ..

notation Rep_uexpr ("\<lbrakk>_\<rbrakk>\<^sub>e")
lemma uexpr_eq_iff: "e = f \<longleftrightarrow> (\<forall> b. \<lbrakk>e\<rbrakk>\<^sub>e b = \<lbrakk>f\<rbrakk>\<^sub>e b)"
  using Rep_uexpr_inject[of e f, THEN sym] by (auto)

section \<open> Core expression constructs using lift_definition  \<close>

setup_lifting type_definition_uexpr
lift_definition var :: "('t \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t, '\<alpha>) uexpr" is lens_get .
print_theorems
lift_definition lit :: "'t \<Rightarrow> ('t, '\<alpha>) uexpr" ("\<guillemotleft>_\<guillemotright>") is "\<lambda> v b. v" .
lift_definition bop ::"('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> ('c, '\<alpha>) uexpr"
 is "\<lambda> f u v b. f (u b) (v b)" .

definition eq_upred :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infixl "=\<^sub>u" 50)
  where "eq_upred x y = bop HOL.eq x y"

subsection \<open> Type class instantiations\<close>
instantiation uexpr :: (zero, type) zero
begin
  definition zero_uexpr_def : "0 = lit 0"
instance ..
end

instantiation uexpr :: (one, type) one
begin
  definition one_uexpr_def : "1 = lit 1"
instance ..
end

instantiation uexpr :: (plus, type) plus
begin
  definition plus_uexpr_def : "u + v = bop (+) u v"
instance ..
end

instance uexpr :: (numeral, type) numeral
  by (intro_classes, simp add: plus_uexpr_def, transfer, simp add: add.assoc)

instantiation uexpr :: (ord, type) ord
begin
  lift_definition less_eq_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> bool"
  is "\<lambda> P Q. (\<forall> A. P A \<le> Q A)" .
  definition less_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> bool"
    where "less_uexpr P Q = (P \<le> Q \<and> \<not> Q \<le> P)"
instance ..
end

lemma lit_ueval : "\<lbrakk>\<guillemotleft>x\<guillemotright>\<rbrakk>\<^sub>eb = x"
  by (transfer, simp)

lemma var_ueval: "\<lbrakk>var x\<rbrakk>\<^sub>eb = get\<^bsub>x\<^esub> b"
  by (transfer, simp)

lemma bop_ueval : "\<lbrakk>bop f x y\<rbrakk>\<^sub>eb = f (\<lbrakk>x\<rbrakk>\<^sub>eb) (\<lbrakk>y\<rbrakk>\<^sub>eb)"
  by (transfer, simp)

lemma plus_ueval : "\<lbrakk>x + y\<rbrakk>\<^sub>eb = (\<lbrakk>x\<rbrakk>\<^sub>eb) + (\<lbrakk>y\<rbrakk>\<^sub>eb)"
  by (simp add: bop_ueval plus_uexpr_def)

subsection \<open>The fundamental lemma of computation\<close>
lemma lit_fun_simps  :
  "\<guillemotleft>g x y\<guillemotright> = bop g \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright>"
  by (transfer, simp)+

lemma numeral_uexpr_rep_eq: "\<lbrakk>numeral x\<rbrakk>\<^sub>e b = numeral x"
  apply (induct x)
    apply (simp add: lit.rep_eq one_uexpr_def)
   apply (simp add: bop.rep_eq numeral_Bit0 plus_uexpr_def)
  apply (simp add: bop.rep_eq lit.rep_eq numeral_code(3) one_uexpr_def plus_uexpr_def)
  done

lemma lit_zero [simp]: "\<guillemotleft>0\<guillemotright> = 0" by (simp add: zero_uexpr_def)
lemma lit_one [simp]: "\<guillemotleft>1\<guillemotright> = 1" by (simp add: one_uexpr_def)
lemma lit_plus [simp]: "\<guillemotleft>x + y\<guillemotright> = \<guillemotleft>x\<guillemotright> + \<guillemotleft>y\<guillemotright>" by (simp add: plus_uexpr_def, transfer, simp)
lemma lit_numeral [simp]: "\<guillemotleft>numeral n\<guillemotright> = numeral n"
  by (simp add: uexpr_eq_iff numeral_uexpr_rep_eq lit.rep_eq)

section \<open> ???????????????? \<close>

syntax
  "_uuvar" :: "svar \<Rightarrow> logic" ("_")
translations
  "_uuvar x" == "CONST var x"

section \<open> Substitution definitions \<close>

consts usubst :: "'s \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "\<dagger>" 80)
type_synonym '\<alpha> usubst = "'\<alpha> \<Rightarrow> '\<alpha>"
lift_definition subst :: " '\<alpha> usubst \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" is
"\<lambda> \<sigma> e b. e (\<sigma> b)" .
print_theorems
adhoc_overloading
  usubst subst
lemma show_usubst:
  shows "\<lbrakk> x \<dagger> P \<rbrakk>\<^sub>e = (\<lambda>b. \<lbrakk>P\<rbrakk>\<^sub>e (x b))"
  by (simp add: subst.rep_eq)

type_synonym ('\<alpha>,'\<beta>) psubst = "'\<alpha> \<Rightarrow> '\<beta>"
consts subst_upd :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> 'v \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst"
definition subst_upd_uvar :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> ('\<alpha>,'\<beta>) psubst" where
"subst_upd_uvar \<sigma> x v = (\<lambda> b. put\<^bsub>x\<^esub> (\<sigma> b) (\<lbrakk>v\<rbrakk>\<^sub>e b))"
adhoc_overloading
  subst_upd subst_upd_uvar
lemma show_subst_upd:
  shows " subst_upd_uvar \<sigma> x e  = (\<lambda>b. put\<^bsub>x\<^esub> (\<sigma> b) (\<lbrakk>e\<rbrakk>\<^sub>e b))     "
  by (simp add: subst_upd_uvar_def)

lift_definition usubst_lookup :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<langle>_\<rangle>\<^sub>s")
is "\<lambda> \<sigma> x b. get\<^bsub>x\<^esub> (\<sigma> b)" .
print_theorems
lemma show_usubst_lookup:
  shows "\<lbrakk> \<langle>\<sigma>\<rangle>\<^sub>s x \<rbrakk>\<^sub>e = (\<lambda>b. get\<^bsub>x\<^esub> (\<sigma> b))"
  by (simp add: usubst_lookup.rep_eq)

subsection \<open> Syntax translations about subsitution \<close>

nonterminal smaplet and smaplets and uexp and uexprs and salphas

syntax
  "_smaplet"  :: "[salpha, 'a] => smaplet"             ("_ /\<mapsto>\<^sub>s/ _")
  ""          :: "smaplet => smaplets"            ("_")
  "_SMaplets" :: "[smaplet, smaplets] => smaplets" ("_,/ _")
  "_SubstUpd" :: "['m usubst, smaplets] => 'm usubst" ("_/'(_')" [900,0] 900)
  "_Subst"    :: "smaplets => 'a \<rightharpoonup> 'b"            ("(1[_])")
  "_psubst"  :: "[logic, svars, uexprs] \<Rightarrow> logic"

  "_uexp_l"  :: "logic \<Rightarrow> uexp" ("_" [64] 64)
  "_uexprs"  :: "[uexp, uexprs] => uexprs" ("_,/ _")
  ""         :: "uexp => uexprs" ("_")
  "_salphas" :: "[salpha, salphas] => salphas" ("_,/ _")
  ""         :: "salpha => salphas" ("_")

translations
  "_SubstUpd m (_SMaplets xy ms)"     == "_SubstUpd (_SubstUpd m xy) ms"
  "_SubstUpd m (_smaplet x y)"        == "CONST subst_upd m x y"
  "_Subst ms"                         == "_SubstUpd (CONST id) ms"
  "_Subst (_SMaplets ms1 ms2)"        <= "_SubstUpd (_Subst ms1) ms2"
  "_SMaplets ms1 (_SMaplets ms2 ms3)" <= "_SMaplets (_SMaplets ms1 ms2) ms3"
  "_psubst m (_salphas x xs) (_uexprs v vs)" => "_psubst (_psubst m x v) xs vs"
  "_psubst m x v"  => "CONST subst_upd m x v"
  "_uexp_l e" => "e"

lemma hello_wodsrlddwe:
  assumes"vwb_lens x"
  shows " [x \<mapsto>\<^sub>s e]  = (\<lambda>b. put\<^bsub>x\<^esub> b (\<lbrakk>e\<rbrakk>\<^sub>e b))"
  by (simp add: subst_upd_uvar_def)

section \<open> Substitution Application Laws \<close>

subsection  \<open>id has no effect \<close>

lemma usubst_lookup_id : "\<langle>id\<rangle>\<^sub>s x = var x"
proof -
  have f1:"\<lbrakk>var x\<rbrakk>\<^sub>e = get\<^bsub>x\<^esub>"
    by (simp add: var.rep_eq)
  then have f2:"\<lbrakk>\<langle>id\<rangle>\<^sub>s x\<rbrakk>\<^sub>e = (\<lambda>b. get\<^bsub>x\<^esub> (id b))"
    by (simp add: usubst_lookup.rep_eq)
  then show ?thesis
    by (simp add: f1 uexpr_eq_iff)
qed

lemma usubst_lookup_upd :
  assumes "vwb_lens x"
  shows "\<langle>\<sigma>(x \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x = v"
proof -
  have "\<forall> b. get\<^bsub>x\<^esub> (put\<^bsub>x\<^esub> (\<sigma> b) (\<lbrakk>v\<rbrakk>\<^sub>e b)) = \<lbrakk>v\<rbrakk>\<^sub>e b"
    by (simp add: assms)
  then have "\<forall>b. get\<^bsub>x\<^esub> ((\<sigma>(x \<mapsto>\<^sub>s v)) b) = \<lbrakk>v\<rbrakk>\<^sub>e b"
    by (simp add: subst_upd_uvar_def)
  then have "\<forall>b. \<lbrakk>\<langle>\<sigma>(x \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x \<rbrakk>\<^sub>e b = \<lbrakk>v\<rbrakk>\<^sub>e b"
    by (simp add: usubst_lookup.rep_eq)
  then show ?thesis
    by (simp add: uexpr_eq_iff)
qed

lemma usubst_lookup_upd_pr_var :
  assumes "vwb_lens x"
  shows "\<langle>\<sigma>(x \<mapsto>\<^sub>s v)\<rangle>\<^sub>s (pr_var x) = v"
  by (simp add: pr_var_def usubst_lookup_upd assms)

subsection \<open> Substitution update is idempotent. \<close>
lemma usubst_upd_idem :
  assumes "vwb_lens x"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, x \<mapsto>\<^sub>s v) = \<sigma>(x \<mapsto>\<^sub>s v)"
  by (simp add: assms subst_upd_uvar_def)

subsection \<open>just assignment \<close>
lemma usubst_upd_var_id :
  "vwb_lens x \<Longrightarrow> [x \<mapsto>\<^sub>s var x] = id"
  by (metis eq_id_iff subst_upd_uvar_def var.rep_eq vwb_lens.axioms(1) wb_lens.get_put)

lemma usubst_upd_pr_var_id :
  "vwb_lens x \<Longrightarrow> [x \<mapsto>\<^sub>s var (pr_var x)] = id"
  by (simp add: pr_var_def usubst_upd_var_id)

subsection \<open> Substitution updates commute when the lenses are independent. \<close>
lemma usubst_upd_comm:
  assumes "x \<bowtie> y"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v) = \<sigma>(y \<mapsto>\<^sub>s v, x \<mapsto>\<^sub>s u)"
  using assms
  by (rule_tac ext, auto simp add: subst_upd_uvar_def assms comp_def lens_indep_comm)

lemma usubst_upd_comm2:
  assumes "z \<bowtie> y"
  shows "\<sigma>(x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v, z \<mapsto>\<^sub>s s) = \<sigma>(x \<mapsto>\<^sub>s u, z \<mapsto>\<^sub>s s, y \<mapsto>\<^sub>s v)"
  using assms
  by (rule_tac ext, auto simp add: subst_upd_uvar_def assms comp_def lens_indep_comm)

subsection \<open> others \<close>
lemma subst_upd_lens_plus :
  "subst_upd \<sigma> (x +\<^sub>L y) \<guillemotleft>(u,v)\<guillemotright> = \<sigma>(y \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>, x \<mapsto>\<^sub>s \<guillemotleft>u\<guillemotright>)"
  by (simp add: lens_defs zero_uexpr_def subst_upd_uvar_def, transfer, auto)

lemma usubst_lookup_upd_indep :
  assumes "mwb_lens x" "x \<bowtie> y"
  shows "\<langle>\<sigma>(y \<mapsto>\<^sub>s v)\<rangle>\<^sub>s x = \<langle>\<sigma>\<rangle>\<^sub>s x"
  using assms
  by (simp add: subst_upd_uvar_def, transfer, simp)

consts
  usedBy :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

syntax
  "_usedBy" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<natural>" 20)
translations
  "_usedBy x p" == "CONST usedBy x p"
  "_usedBy (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_usedBy (x +\<^sub>L y) P"

lift_definition usedBy_uexpr :: "('b \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha>) uexpr \<Rightarrow> bool"
is "\<lambda> x e. (\<forall> b b'. e (b' \<oplus>\<^sub>L b on x) = e b)" .
adhoc_overloading usedBy usedBy_uexpr

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: LPF.thy                                                              *)
(* Authors: Casper Thule and Frank Zeyda                                      *)
(* Emails: casper.thule@eng.au.dk and frank.zeyda@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 21 Mar 2017 *)

section {* Logic of Partial Functions *}

theory LPF
imports Main Eisbach utp
begin

subsection {* LPF Type *}

text {*
  Below we define a new type to represent values in LPF. Effectively, we encode
  these as @{type option} types where @{const None} will be used to represent
  the undefined value of our LPF logic embedding.
*}

typedef 'a lpf = "UNIV :: 'a option set"
apply(rule UNIV_witness)
done
print_theorems
(* The type synonym below should really go into the VDM.thy theory. *)

(* At a later point we want to introduce a UTP expression type for VDM. *)

type_synonym ('a, '\<alpha>) vexpr = "('a lpf, '\<alpha>) uexpr"

(* With the below, pretty-printing of the type synonym works as well! *)

typ "('a, '\<alpha>) vexpr"

translations (type) "('a, '\<alpha>) vexpr" \<leftharpoondown> (type) "('a lpf, '\<alpha>) uexpr"

typ "('a, '\<alpha>) vexpr"

text {*Two theorems to use in proofs are set up  *}
named_theorems lpf_defs "lpf definitional axioms"
named_theorems lpf_transfer "lpf transfer laws"

lemmas Abs_lpf_inject_sym = sym [OF Abs_lpf_inject]
lemmas Rep_lpf_inject_sym = sym [OF Rep_lpf_inject]

declare Rep_lpf_inverse [lpf_transfer]
declare Abs_lpf_inverse [simplified, lpf_transfer]
declare Rep_lpf_inject_sym [lpf_transfer]
declare Abs_lpf_inject [simplified, lpf_transfer]

text {*The lifting of the type lpf is set up*}
setup_lifting type_definition_lpf

text {*Lifting of a HOL type into a defined lpf value*}
(*TODO: How can one define this as a function e.g. lpf_Some x = Some x*)
lift_definition lpf_Some :: "'a \<Rightarrow> 'a lpf"
is "Some" .
print_theorems

text {* Lpf value for undefined *}
lift_definition lpf_None :: "'a lpf"
is "None" .

text {* Definition of definedness for lpf values*}
definition defined :: "'a lpf \<Rightarrow> bool" ("\<D>'(_')") where
"defined x \<longleftrightarrow> (x \<noteq> lpf_None)"

declare lpf_Some.rep_eq [lpf_transfer]
declare lpf_None.rep_eq [lpf_transfer]
declare defined_def [lpf_defs]

text {*
  The following function checks if an input x satisfies a predicate (belongs to
  a set). If it does then it returns the value backed, wrapped up in the
  @{type lpf} type, otherwise it returns @{const lpf_None}.
*}

definition lpfSat :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a lpf" where
"lpfSat u a = (if a\<in>u then lpf_Some a else lpf_None)"

text {* Overloading definition for monadic bind *}
definition lift1_bind :: "'a lpf \<Rightarrow> ('a \<Rightarrow> 'b lpf) \<Rightarrow> 'b lpf" where
[lpf_defs]: "lift1_bind a f =
  (if \<D>(a) then  (f \<circ> the \<circ> Rep_lpf) a else lpf_None)"

adhoc_overloading
bind lift1_bind

text {* lift1_lpf takes a set which is a predicate on the input values,
  a total HOL function taking one argument and turns  it into a function on
  option types. The resulting value is defined if (1) each input is defined
  and (2) the input satisfies the predicate.
*}

definition lift1_lpf_old :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf)" where
[lpf_defs]:"lift1_lpf_old u f = (\<lambda>x . (x\<bind>lpfSat u)\<bind> lpf_Some \<circ> f)"

definition lift1_lpf'_old :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf)" where
[lpf_defs]:"lift1_lpf'_old = lift1_lpf_old UNIV"

lift_definition lift1_lpf :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf)" is
"(\<lambda> u f x . (x\<bind>lpfSat u)\<bind> lpf_Some \<circ> f)"
done

declare lift1_lpf.transfer [lpf_transfer]
declare lift1_lpf_def [lpf_defs]

lift_definition lift1_lpf' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf)" is
"(\<lambda> f . lift1_lpf UNIV f)"
done

declare lift1_lpf'.transfer [lpf_transfer]
declare lift1_lpf'_def [lpf_defs]

text {*
  Below we define unary operators on the lpf type
  using the lifting defined above.
*}

(* With instantiation, use the type class syntax for uminus. *)
(*instantiation lpf :: (uminus) uminus
begin
definition uminus_lpf :: "'a lpf \<Rightarrow> 'a lpf" where
"uminus_lpf = lift1_lpf' uminus"
instance ..
end*)

definition uminus_lpf :: "'a::uminus lpf \<Rightarrow> 'a lpf" ("-\<^sub>L _" [81] 80) where
[lpf_defs]: "uminus_lpf = lift1_lpf' uminus"

definition card_lpf :: "'a set lpf \<Rightarrow> nat lpf" where
[lpf_defs]: "card_lpf = lift1_lpf' card"

definition abs_lpf :: "real lpf \<Rightarrow> real lpf" where
[lpf_defs]: "abs_lpf = lift1_lpf' abs"

definition floor_lpf :: "real lpf \<Rightarrow> int lpf" where
[lpf_defs]: "floor_lpf = lift1_lpf' floor"

definition len_lpf :: "'a list lpf \<Rightarrow> nat lpf" where
[lpf_defs]: "len_lpf = lift1_lpf' length"

-- {* \todo{Define the following operators:
  Boolean type: Negation
  Record types: field select and is.
  Set unary operators: dunion, dinter and power.
  Sequence unary operators: hd, tl, elems, inds, reverse, conc and indexing.
  Map unary operators: dom, rng, merge, apply and inverse.  }
*}

lift_definition lift2_lpf ::
  "('a * 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf \<Rightarrow> 'c lpf)" is
  "(\<lambda> u f v1 v2.
  do { x \<leftarrow> v1; y \<leftarrow> v2; lpfSat u (x, y) } \<bind> lpf_Some \<circ> uncurry f)"
done

declare lift2_lpf.transfer [lpf_transfer]
declare lift2_lpf_def [lpf_defs]

lift_definition lift2_lpf' ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf \<Rightarrow> 'c lpf)" is
  "lift2_lpf UNIV"
done

declare lift2_lpf'.transfer [lpf_transfer]
declare lift2_lpf'_def [lpf_defs]

text {*
  Lifts a HOL function with two arguments into a function on the lpf type
*}
definition lift2_lpf_old ::
  "('a * 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf \<Rightarrow> 'c lpf)" where
[lpf_defs]: "lift2_lpf_old u f =
  (\<lambda> v1 v2. do { x \<leftarrow> v1; y \<leftarrow> v2; lpfSat u (x, y) } \<bind> lpf_Some \<circ> uncurry f)"

definition lift2_lpf'_old :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a lpf \<Rightarrow> 'b lpf \<Rightarrow> 'c lpf)" where
[lpf_defs]:"lift2_lpf'_old = lift2_lpf UNIV"

(*TODO: How should this be done? First lift into lpf', and then lift into vexpr?"*)
consts lift1_vdm :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> (('a, '\<alpha>) vexpr \<Rightarrow> ('b, '\<alpha>) vexpr)"
(* Open question: do we really need two layers of lifting? *)

declare lift1_lpf'_def [lpf_defs]

method lpf_simp = (simp add: lpf_defs lpf_transfer; clarsimp?)
method lpf_auto = (lpf_simp; auto)
method lpf_blast = (lpf_simp; blast)

lemma "lpf_Some x = lpf_Some y \<longleftrightarrow> x = y"
  by (metis lpf_Some.rep_eq option.inject)

lemma "lpf_Some x = lpf_Some y \<longleftrightarrow> x = y"
apply (lpf_simp)
done

(*How do I prove these?*)
lemma all_lpf_transfer [lpf_transfer]:
"(\<forall>x::'a lpf. P x) = (\<forall>x::'a option. P (Abs_lpf x))"
apply (safe)
-- {* Subgoal 1 *}
apply (drule_tac x = "Abs_lpf x" in spec)
apply (assumption)
-- {* Subgoal 2 *}
apply (drule_tac x = "Rep_lpf x" in spec)
apply (simp add: Rep_lpf_inverse)
done

thm exI
lemma ex_lpf_transfer [lpf_transfer]:
"(\<exists>x::'a lpf. P x) = (\<exists>x::'a option. P (Abs_lpf x))"
apply (safe)
-- {* Subgoal 1 *}
apply (rule_tac x = "Rep_lpf x" in exI)
apply (simp add: Rep_lpf_inverse)
-- {* Subgoal 2 *}
apply (rule_tac x = "Abs_lpf x" in exI)
apply (assumption)
done

lemma meta_lpf_transfer [lpf_transfer]:
"(\<And>x::'a lpf. P x) \<equiv> (\<And>x::'a option. P (Abs_lpf x))"
apply (rule)
-- {* Subgoal 1 *}
apply (drule_tac x = "Abs_lpf x" in meta_spec)
apply (assumption)
-- {* Subgoal 2 *}
apply (drule_tac x = "Rep_lpf x" in meta_spec)
apply (simp add: Rep_lpf_inverse)
done

lemma lift1_lpf'_example: "lift1_lpf' card lpf_None = lpf_None"
apply (lpf_simp)
done

lemma lift1_lpf'_example: "lift1_lpf' card (lpf_Some {1,2,3}) = lpf_Some 3"
apply (lpf_simp)
(* We need ex_lpf_transfer *)
oops
end


theory Hoare_Typed
imports Lang_Typed Hoare_Untyped
begin

subsection {* Definition of Hoare triples *}

definition hoare :: "(memory \<Rightarrow> bool) \<Rightarrow> program \<Rightarrow> (memory \<Rightarrow> bool) \<Rightarrow> bool" where
  "hoare pre prog post =
  (\<forall>m. pre m \<longrightarrow> (\<forall>m'. m' \<in> support_distr (denotation prog m) \<longrightarrow> post m'))"

lemma hoare_untyped: "hoare P c Q = hoare_untyped P (Rep_program c) Q"
  unfolding denotation_def hoare_def hoare_untyped_def by simp

(*
subsection {* Concrete syntax *}

syntax "_hoare" :: "(memory \<Rightarrow> bool) \<Rightarrow> program_syntax \<Rightarrow> (memory \<Rightarrow> bool) \<Rightarrow> term"
          ("hoare {(_)}/ (2_)/ {(_)}")
syntax "_memory" :: memory ("&m")
syntax "_assertion" :: "(memory \<Rightarrow> bool) \<Rightarrow> (memory \<Rightarrow> bool)" ("ASSERTION[_]")

ML_file "hoare_syntax.ML"

parse_translation {*
    [("_hoare", fn ctx => fn [P,c,Q] => Hoare_Syntax.trans_hoare ctx P c Q),
     ("_assertion", fn ctx => fn [P] => Hoare_Syntax.trans_assertion ctx P)]
*}

(* print_translation {*
  [(@{const_syntax hoare}, fn ctx => fn [P,c,Q] => Hoare_Syntax.trans_hoare_back ctx P c Q)]
*} *)
*)

subsection {* Rules *}

lemma assertion_footprint_lookup: "mk_variable_untyped x \<in> X \<Longrightarrow> assertion_footprint X (\<lambda>m. memory_lookup m x)"
  unfolding assertion_footprint_def by auto

lemma seq_rule:
  fixes P Q R c d
  assumes "hoare P c Q" and "hoare Q d R"
  shows "hoare P (seq c d) R"
  using assms seq_rule unfolding hoare_untyped by auto

lemma assign_rule:
  fixes P Q x e
  assumes "\<forall>m. P m \<longrightarrow> Q (memory_update_pattern m x (e_fun e m))"
  shows "hoare P (assign x e) Q"
  unfolding hoare_untyped Rep_assign
  apply (rule assign_rule)
  using assms unfolding memory_update_pattern_def by auto

lemma assign_rule':
  fixes P Q c x e
  assumes "hoare P c (\<lambda>m. Q (memory_update_pattern m x (e_fun e m)))"
  shows "hoare P (seq c (assign x e)) Q"
by (rule seq_rule, rule assms, rule assign_rule, simp)

lemma sample_rule:
  fixes P Q x e
  assumes "\<forall>m. P m \<longrightarrow> (\<forall>v\<in>support_distr (e_fun e m). Q (memory_update_pattern m x v))"
  shows "hoare P (sample x e) Q"
  unfolding hoare_untyped Rep_sample
  apply (rule sample_rule)
  using assms unfolding memory_update_pattern_def by auto

lemma sample_rule':
  fixes P Q c x e
  assumes "hoare P c (\<lambda>m. \<forall>v\<in>support_distr (e_fun e m). Q (memory_update_pattern m x v))"
  shows "hoare P (seq c (sample x e)) Q"
by (rule seq_rule, rule assms, rule sample_rule, simp)

lemma while_rule:
  fixes P Q I c e
  assumes "hoare (\<lambda>m. I m \<and> e_fun e m) c I"
          "\<forall>m. P m \<longrightarrow> I m"
          "\<forall>m. \<not> e_fun e m \<longrightarrow> I m \<longrightarrow> Q m"
  shows "hoare P (while e c) Q"
  unfolding hoare_untyped Rep_while
  apply (rule while_rule[where I=I])
  using assms unfolding hoare_untyped e_fun_bool_untyped.

lemma while_rule':
  fixes P Q I c0 c e
  assumes "hoare (\<lambda>m. I m \<and> e_fun e m) c I"
          "hoare P c0 I"
          "\<forall>m. \<not> e_fun e m \<longrightarrow> I m \<longrightarrow> Q m"
  shows "hoare P (seq c0 (while e c)) Q"
by (rule seq_rule, rule assms, rule while_rule, auto simp: assms)

lemma iftrue_rule:
  assumes "hoare P c1 Q"
          "\<forall>m. P m \<longrightarrow> e_fun e m"
  shows "hoare P (ifte e c1 c2) Q"
  unfolding hoare_untyped Rep_ifte
  apply (rule iftrue_rule)
  using assms unfolding hoare_untyped by auto

lemma iffalse_rule:
  fixes P Q I e p1 p2
  assumes "hoare P p2 Q"
          "\<forall>m. P m \<longrightarrow> \<not> e_fun e m"
  shows "hoare P (ifte e p1 p2) Q"
  unfolding hoare_untyped Rep_ifte
  apply (rule iffalse_rule)
  using assms unfolding hoare_untyped by auto

lemma true_rule [simp]: "(\<forall>m. Q m) \<Longrightarrow> hoare P c Q"
  unfolding hoare_def by simp

lemma skip_rule [simp]:
  assumes "\<forall>m. P m \<longrightarrow> Q m"
  shows "hoare P skip Q"
  unfolding hoare_def using assms denotation_skip by simp

lemma skip_rule' [simp]:
  assumes "hoare P c Q"
  shows "hoare P (seq c skip) Q"
  by (rule seq_rule, rule assms, rule skip_rule, simp)

lemma conseq_rule:
  assumes "\<forall>m. P m \<longrightarrow> P' m"
      and "\<forall>m. Q' m \<longrightarrow> Q m"
      and "hoare P' c Q'"
  shows "hoare P c Q"
  using assms unfolding hoare_def by auto

lemma case_rule:
  assumes "\<And>x. hoare (\<lambda>m. P m \<and> f m = x) c Q"
  shows "hoare P c Q"
using assms unfolding hoare_def by metis

lemma addskip_rule:
  assumes "hoare P (seq skip c) Q"
  shows "hoare P c Q"
  using assms unfolding hoare_def denotation_seq_skip by simp

lemma denotation_eq_rule:
  assumes "denotation d = denotation c"
  assumes "hoare P c Q"
  shows   "hoare P d Q"
using assms unfolding hoare_def by auto

section {* Rules for ML tactics *}

lemma seq_assoc_rule:
  assumes "hoare P (seq (seq a b) c) R"
  shows "hoare P (seq a (seq b c)) R"
using assms denotation_seq_assoc hoare_def by auto

(* Ordering of subgoals for certain tactics *)
lemma seq_rule_lastfirst:
  fixes P Q R c d
  assumes "hoare Q d R" and "hoare P c Q"
  shows "hoare P (seq c d) R"
  using assms seq_rule unfolding hoare_untyped Rep_seq by auto

lemma assign_rule_strict:
  fixes Q x e
  defines "Q' == \<lambda>m. Q (memory_update_pattern m x (e_fun e m))"
  shows "hoare Q' (assign x e) Q"
  apply (rule assign_rule)
  unfolding Q'_def by simp

lemma sample_rule_strict:
  fixes Q x e
  defines "Q' == \<lambda>m. \<forall>v\<in>support_distr (e_fun e m). Q (memory_update_pattern m x v)"
  shows "hoare Q' (sample x e) Q"
  apply (rule sample_rule)
  unfolding Q'_def by simp

lemma skip_rule_strict: "hoare P skip P"
  by (rule skip_rule, simp)

lemma if_case_rule:
  assumes "hoare P1 c1 Q"
  assumes "hoare P2 c2 Q"
  shows "hoare (\<lambda>m. if (e_fun e m) then (P1 m) else (P2 m))
               (ifte e c1 c2)
               Q"
  apply (rule case_rule[where f="\<lambda>m. e_fun e m"])
  apply (case_tac x, auto)
  apply (rule iftrue_rule)
  apply (rule conseq_rule[where P'=P1 and Q'=Q], auto simp: assms)
  apply (rule iffalse_rule)
  by (rule conseq_rule[where P'=P2 and Q'=Q], auto simp: assms)

lemma readonly_hoare:
  shows "program_readonly X c = (\<forall>a. hoare (\<lambda>m. \<forall>x\<in>X. memory_lookup_untyped m x = a x) c (\<lambda>m. \<forall>x\<in>X. memory_lookup_untyped m x = a x))"
using denotation_def hoare_untyped program_readonly_def program_untyped_readonly_def readonly_hoare_untyped by auto

lemma seq_swap:
  fixes A B R
  assumes a_ro: "program_readonly R a"
  assumes b_ro: "program_readonly R b"
  assumes foot_a: "program_footprint A a"
  assumes foot_b: "program_footprint B b"
  assumes ABR: "A\<inter>B\<subseteq>R"
  shows "denotation (seq a b) = denotation (seq b a)"
unfolding denotation_def apply simp apply (rule seq_swap_untyped[THEN ext])
using assms
unfolding program_readonly_def program_untyped_readonly_def denotation_def program_footprint_def program_untyped_footprint_def
by auto

lemma program_readonly_write_vars: "program_readonly (- set(write_vars p)) p"
  using program_untyped_readonly_write_vars[of "Rep_program p"]
  unfolding program_readonly_def program_untyped_readonly_def write_vars_def denotation_def
  by assumption

end