section \<open>\isaheader{Map Interface}\<close>
theory Intf_Map
imports "../../../Refine_Monadic/Refine_Monadic"
begin

consts i_map :: "interface \<Rightarrow> interface \<Rightarrow> interface"

definition [simp]: "op_map_empty \<equiv> Map.empty"
definition op_map_lookup :: "'k \<Rightarrow> ('k\<rightharpoonup>'v) \<rightharpoonup> 'v"
  where [simp]: "op_map_lookup k m \<equiv> m k"
definition [simp]: "op_map_update k v m \<equiv> m(k\<mapsto>v)"
definition [simp]: "op_map_delete k m \<equiv> m |` (-{k})"
definition [simp]: "op_map_restrict P m \<equiv> m |` {k\<in>dom m. P (k, the (m k))}"
definition [simp]: "op_map_isEmpty x \<equiv> x=Map.empty"
definition [simp]: "op_map_isSng x \<equiv> \<exists>k v. x=[k\<mapsto>v]"
definition [simp]: "op_map_ball m P \<equiv> Ball (map_to_set m) P"
definition [simp]: "op_map_bex m P \<equiv> Bex (map_to_set m) P"
definition [simp]: "op_map_size m \<equiv> card (dom m)"
definition [simp]: "op_map_size_abort n m \<equiv> min n (card (dom m))"
definition [simp]: "op_map_sel m P \<equiv> SPEC (\<lambda>(k,v). m k = Some v \<and> P k v)"
definition [simp]: "op_map_pick m \<equiv> SPEC (\<lambda>(k,v). m k = Some v)"

definition [simp]: "op_map_pick_remove m \<equiv>
  SPEC (\<lambda>((k,v),m'). m k = Some v \<and> m' = m |` (-{k}))"

context begin interpretation autoref_syn .

  "m=Map.empty \<equiv> op_map_isEmpty$m"
  "Map.empty=m \<equiv> op_map_isEmpty$m"
  "dom m = {} \<equiv> op_map_isEmpty$m"
  "{} = dom m \<equiv> op_map_isEmpty$m"

  "\<exists>k v. m=[k\<mapsto>v] \<equiv> op_map_isSng$m"
  "\<exists>k v. [k\<mapsto>v]=m \<equiv> op_map_isSng$m"
  "\<exists>k. dom m={k} \<equiv> op_map_isSng$m"
  "\<exists>k. {k} = dom m \<equiv> op_map_isSng$m"
  "1 = card (dom m) \<equiv> op_map_isSng$m"

  "\<And>P. Ball (map_to_set m) P \<equiv> op_map_ball$m$P"
  "\<And>P. Bex (map_to_set m) P \<equiv> op_map_bex$m$P"

  "card (dom m) \<equiv> op_map_size$m"

  "min n (card (dom m)) \<equiv> op_map_size_abort$n$m"
  "min (card (dom m)) n \<equiv> op_map_size_abort$n$m"

  "\<And>P. SPEC (\<lambda>(k,v). m k=Some v \<and> P k v) \<equiv> op_map_sel$m$P"
  "\<And>P. SPEC (\<lambda>(k,v). P k v \<and> m k=Some v) \<equiv> op_map_sel$m$P"

  "\<And>P. SPEC (\<lambda>(k,v). m k = Some v) \<equiv> op_map_pick$m"
  "\<And>P. SPEC (\<lambda>(k,v). (k,v) \<in> map_to_set m) \<equiv> op_map_pick$m"
  by (auto
    intro!: eq_reflection ext
    simp: restrict_map_def dom_eq_singleton_conv card_Suc_eq map_to_set_def
    dest!: sym[of "Suc 0" "card (dom m)"] sym[of _ "dom m"]
  )

  lemma [autoref_op_pat]:
    "SPEC (\<lambda>((k,v),m'). m k = Some v \<and> m' = m |` (-{k}))
      \<equiv> op_map_pick_remove$m"
    by simp

  lemma op_map_pick_remove_alt: "
    do {((k,v),m) \<leftarrow> op_map_pick_remove m; f k v m}
      = (
    do {
      (k,v)\<leftarrow>SPEC (\<lambda>(k,v). m k = Some v);
       let m=m |` (-{k});
       f k v m
    })"
    unfolding op_map_pick_remove_def
    apply (auto simp: pw_eq_iff refine_pw_simps)
    done

  lemma [autoref_op_pat]:
    "do {
      (k,v)\<leftarrow>SPEC (\<lambda>(k,v). m k = Some v);
       let m=m |` (-{k});
       f k v m
    } \<equiv> do {((k,v),m) \<leftarrow> op_map_pick_remove m; f k v m}"
    unfolding op_map_pick_remove_alt .

end

lemma [autoref_itype]:
  "op_map_empty ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_lookup ::\<^sub>i Ik \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_option"
  "op_map_update ::\<^sub>i Ik \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_delete ::\<^sub>i Ik \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_restrict
    ::\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_isEmpty ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_bool"
  "op_map_isSng ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_bool"
  "op_map_ball ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_map_bex ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_map_size ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_nat"
  "op_map_size_abort ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_nat"
  "(++) ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "map_of ::\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"

  "op_map_sel ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (Ik \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i i_bool)
    \<rightarrow>\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "op_map_pick ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "op_map_pick_remove
    ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod,\<langle>Ik,Iv\<rangle>\<^sub>ii_map\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  by simp_all

lemma hom_map1[autoref_hom]:
  "CONSTRAINT Map.empty (\<langle>Rk,Rv\<rangle>Rm)"
  "CONSTRAINT map_of (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
  "CONSTRAINT (++) (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
  by simp_all

term op_map_restrict

  "CONSTRAINT op_map_sel (\<langle>Rk,Rv\<rangle>Rm\<rightarrow>(Rk \<rightarrow> Rv \<rightarrow> bool_rel)\<rightarrow>\<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
  "CONSTRAINT op_map_pick (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
  "CONSTRAINT op_map_pick_remove (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>(Rk\<times>\<^sub>rRv)\<times>\<^sub>r\<langle>Rk,Rv\<rangle>Rm\<rangle>nres_rel)"
  by simp_all

definition "finite_map_rel R \<equiv> Range R \<subseteq> Collect (finite \<circ> dom)"
lemma finite_map_rel_trigger: "finite_map_rel R \<Longrightarrow> finite_map_rel R" .

declaration \<open>Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms finite_map_rel_trigger}\<close>

end


(*  Title:      ZF/Constructible/DPow_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness for the Definable Powerset Function\<close>

theory DPow_absolute imports Satisfies_absolute begin

subsection\<open>Preliminary Internalizations\<close>

subsubsection\<open>The Operator @{term is_formula_rec}\<close>

text\<open>The three arguments of @{term p} are always 2, 1, 0.  It is buried
   within 11 quantifiers!!\<close>

(* is_formula_rec :: "[i=>o, [i,i,i]=>o, i, i] => o"
   "is_formula_rec(M,MH,p,z)  ==
      \<exists>dp[M]. \<exists>i[M]. \<exists>f[M]. finite_ordinal(M,dp) & is_depth(M,p,dp) &
       2       1      0
             successor(M,dp,i) & fun_apply(M,f,p,z) & is_transrec(M,MH,i,f)"
*)

definition
  formula_rec_fm :: "[i, i, i]=>i" where
 "formula_rec_fm(mh,p,z) ==
    Exists(Exists(Exists(
      And(finite_ordinal_fm(2),
       And(depth_fm(p#+3,2),
        And(succ_fm(2,1),
          And(fun_apply_fm(0,p#+3,z#+3), is_transrec_fm(mh,1,0))))))))"

lemma is_formula_rec_type [TC]:
     "[| p \<in> formula; x \<in> nat; z \<in> nat |]
      ==> formula_rec_fm(p,x,z) \<in> formula"
by (simp add: formula_rec_fm_def)

lemma sats_formula_rec_fm:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A; a8\<in>A; a9\<in>A; a10\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,
                                  Cons(a8,Cons(a9,Cons(a10,env))))))))))))"
  shows
      "[|x \<in> nat; z \<in> nat; env \<in> list(A)|]
       ==> sats(A, formula_rec_fm(p,x,z), env) \<longleftrightarrow>
           is_formula_rec(##A, MH, nth(x,env), nth(z,env))"
by (simp add: formula_rec_fm_def sats_is_transrec_fm is_formula_rec_def
              MH_iff_sats [THEN iff_sym])

lemma formula_rec_iff_sats:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A; a8\<in>A; a9\<in>A; a10\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,
                                  Cons(a8,Cons(a9,Cons(a10,env))))))))))))"
  shows
  "[|nth(i,env) = x; nth(k,env) = z;
      i \<in> nat; k \<in> nat; env \<in> list(A)|]
   ==> is_formula_rec(##A, MH, x, z) \<longleftrightarrow> sats(A, formula_rec_fm(p,i,k), env)"
by (simp add: sats_formula_rec_fm [OF MH_iff_sats])

theorem formula_rec_reflection:
  assumes MH_reflection:
    "!!f' f g h. REFLECTS[\<lambda>x. MH(L, f'(x), f(x), g(x), h(x)),
                     \<lambda>i x. MH(##Lset(i), f'(x), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_formula_rec(L, MH(L,x), f(x), h(x)),
               \<lambda>i x. is_formula_rec(##Lset(i), MH(##Lset(i),x), f(x), h(x))]"
apply (simp (no_asm_use) only: is_formula_rec_def)
apply (intro FOL_reflections function_reflections fun_plus_reflections
             depth_reflection is_transrec_reflection MH_reflection)
done

subsubsection\<open>The Operator @{term is_satisfies}\<close>

(* is_satisfies(M,A,p,z) == is_formula_rec (M, satisfies_MH(M,A), p, z) *)
definition
  satisfies_fm :: "[i,i,i]=>i" where
    "satisfies_fm(x) == formula_rec_fm (satisfies_MH_fm(x#+5#+6, 2, 1, 0))"

lemma is_satisfies_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> satisfies_fm(x,y,z) \<in> formula"
by (simp add: satisfies_fm_def)

lemma sats_satisfies_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_fm(x,y,z), env) \<longleftrightarrow>
        is_satisfies(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: satisfies_fm_def is_satisfies_def sats_satisfies_MH_fm
              sats_formula_rec_fm)

lemma satisfies_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_satisfies(##A, x, y, z) \<longleftrightarrow> sats(A, satisfies_fm(i,j,k), env)"
by (simp add: sats_satisfies_fm)

theorem satisfies_reflection:
     "REFLECTS[\<lambda>x. is_satisfies(L,f(x),g(x),h(x)),
               \<lambda>i x. is_satisfies(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_satisfies_def)
apply (intro formula_rec_reflection satisfies_MH_reflection)
done

subsection \<open>Relativization of the Operator @{term DPow'}\<close>

lemma DPow'_eq:
  "DPow'(A) = {z . ep \<in> list(A) * formula,
                    \<exists>env \<in> list(A). \<exists>p \<in> formula.
                       ep = <env,p> & z = {x\<in>A. sats(A, p, Cons(x,env))}}"
by (simp add: DPow'_def, blast)

text\<open>Relativize the use of @{term sats} within @{term DPow'}
(the comprehension).\<close>
definition
  is_DPow_sats :: "[i=>o,i,i,i,i] => o" where
   "is_DPow_sats(M,A,env,p,x) ==
      \<forall>n1[M]. \<forall>e[M]. \<forall>sp[M].
             is_satisfies(M,A,p,sp) \<longrightarrow> is_Cons(M,x,env,e) \<longrightarrow>
             fun_apply(M, sp, e, n1) \<longrightarrow> number1(M, n1)"

lemma (in M_satisfies) DPow_sats_abs:
    "[| M(A); env \<in> list(A); p \<in> formula; M(x) |]
    ==> is_DPow_sats(M,A,env,p,x) \<longleftrightarrow> sats(A, p, Cons(x,env))"
apply (subgoal_tac "M(env)")
 apply (simp add: is_DPow_sats_def satisfies_closed satisfies_abs)
apply (blast dest: transM)
done

lemma (in M_satisfies) Collect_DPow_sats_abs:
    "[| M(A); env \<in> list(A); p \<in> formula |]
    ==> Collect(A, is_DPow_sats(M,A,env,p)) =
        {x \<in> A. sats(A, p, Cons(x,env))}"
by (simp add: DPow_sats_abs transM [of _ A])

subsubsection\<open>The Operator @{term is_DPow_sats}, Internalized\<close>

(* is_DPow_sats(M,A,env,p,x) ==
      \<forall>n1[M]. \<forall>e[M]. \<forall>sp[M].
             is_satisfies(M,A,p,sp) \<longrightarrow> is_Cons(M,x,env,e) \<longrightarrow>
             fun_apply(M, sp, e, n1) \<longrightarrow> number1(M, n1) *)

definition
  DPow_sats_fm :: "[i,i,i,i]=>i" where
  "DPow_sats_fm(A,env,p,x) ==
   Forall(Forall(Forall(
     Implies(satisfies_fm(A#+3,p#+3,0),
       Implies(Cons_fm(x#+3,env#+3,1),
         Implies(fun_apply_fm(0,1,2), number1_fm(2)))))))"

lemma is_DPow_sats_type [TC]:
     "[| A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> DPow_sats_fm(A,x,y,z) \<in> formula"
by (simp add: DPow_sats_fm_def)

lemma sats_DPow_sats_fm [simp]:
   "[| u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, DPow_sats_fm(u,x,y,z), env) \<longleftrightarrow>
        is_DPow_sats(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
by (simp add: DPow_sats_fm_def is_DPow_sats_def)

lemma DPow_sats_iff_sats:
  "[| nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
      u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
   ==> is_DPow_sats(##A,nu,nx,ny,nz) \<longleftrightarrow>
       sats(A, DPow_sats_fm(u,x,y,z), env)"
by simp

theorem DPow_sats_reflection:
     "REFLECTS[\<lambda>x. is_DPow_sats(L,f(x),g(x),h(x),g'(x)),
               \<lambda>i x. is_DPow_sats(##Lset(i),f(x),g(x),h(x),g'(x))]"
apply (unfold is_DPow_sats_def)
apply (intro FOL_reflections function_reflections extra_reflections
             satisfies_reflection)
done

subsection\<open>A Locale for Relativizing the Operator @{term DPow'}\<close>

locale M_DPow = M_satisfies +
 assumes sep:
   "[| M(A); env \<in> list(A); p \<in> formula |]
    ==> separation(M, \<lambda>x. is_DPow_sats(M,A,env,p,x))"
 and rep:
    "M(A)
    ==> strong_replacement (M,
         \<lambda>ep z. \<exists>env[M]. \<exists>p[M]. mem_formula(M,p) & mem_list(M,A,env) &
                  pair(M,env,p,ep) &
                  is_Collect(M, A, \<lambda>x. is_DPow_sats(M,A,env,p,x), z))"

lemma (in M_DPow) sep':
   "[| M(A); env \<in> list(A); p \<in> formula |]
    ==> separation(M, \<lambda>x. sats(A, p, Cons(x,env)))"
by (insert sep [of A env p], simp add: DPow_sats_abs)

lemma (in M_DPow) rep':
   "M(A)
    ==> strong_replacement (M,
         \<lambda>ep z. \<exists>env\<in>list(A). \<exists>p\<in>formula.
                  ep = <env,p> & z = {x \<in> A . sats(A, p, Cons(x, env))})"
by (insert rep [of A], simp add: Collect_DPow_sats_abs)

lemma univalent_pair_eq:
     "univalent (M, A, \<lambda>xy z. \<exists>x\<in>B. \<exists>y\<in>C. xy = \<langle>x,y\<rangle> \<and> z = f(x,y))"
by (simp add: univalent_def, blast)

lemma (in M_DPow) DPow'_closed: "M(A) ==> M(DPow'(A))"
apply (simp add: DPow'_eq)
apply (fast intro: rep' sep' univalent_pair_eq)
done

text\<open>Relativization of the Operator @{term DPow'}\<close>
definition
  is_DPow' :: "[i=>o,i,i] => o" where
    "is_DPow'(M,A,Z) ==
       \<forall>X[M]. X \<in> Z \<longleftrightarrow>
         subset(M,X,A) &
           (\<exists>env[M]. \<exists>p[M]. mem_formula(M,p) & mem_list(M,A,env) &
                    is_Collect(M, A, is_DPow_sats(M,A,env,p), X))"

lemma (in M_DPow) DPow'_abs:
    "[|M(A); M(Z)|] ==> is_DPow'(M,A,Z) \<longleftrightarrow> Z = DPow'(A)"
apply (rule iffI)
 prefer 2 apply (simp add: is_DPow'_def DPow'_def Collect_DPow_sats_abs)
apply (rule M_equalityI)
apply (simp add: is_DPow'_def DPow'_def Collect_DPow_sats_abs, assumption)
apply (erule DPow'_closed)
done

subsection\<open>Instantiating the Locale \<open>M_DPow\<close>\<close>

subsubsection\<open>The Instance of Separation\<close>

lemma DPow_separation:
    "[| L(A); env \<in> list(A); p \<in> formula |]
     ==> separation(L, \<lambda>x. is_DPow_sats(L,A,env,p,x))"
apply (rule gen_separation_multi [OF DPow_sats_reflection, of "{A,env,p}"],
       auto intro: transL)
apply (rule_tac env="[A,env,p]" in DPow_LsetI)
apply (rule DPow_sats_iff_sats sep_rules | simp)+
done

subsubsection\<open>The Instance of Replacement\<close>

lemma DPow_replacement_Reflects:
 "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B &
             (\<exists>env[L]. \<exists>p[L].
               mem_formula(L,p) & mem_list(L,A,env) & pair(L,env,p,u) &
               is_Collect (L, A, is_DPow_sats(L,A,env,p), x)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B &
             (\<exists>env \<in> Lset(i). \<exists>p \<in> Lset(i).
               mem_formula(##Lset(i),p) & mem_list(##Lset(i),A,env) &
               pair(##Lset(i),env,p,u) &
               is_Collect (##Lset(i), A, is_DPow_sats(##Lset(i),A,env,p), x))]"
apply (unfold is_Collect_def)
apply (intro FOL_reflections function_reflections mem_formula_reflection
          mem_list_reflection DPow_sats_reflection)
done

lemma DPow_replacement:
    "L(A)
    ==> strong_replacement (L,
         \<lambda>ep z. \<exists>env[L]. \<exists>p[L]. mem_formula(L,p) & mem_list(L,A,env) &
                  pair(L,env,p,ep) &
                  is_Collect(L, A, \<lambda>x. is_DPow_sats(L,A,env,p,x), z))"
apply (rule strong_replacementI)
apply (rule_tac u="{A,B}"
         in gen_separation_multi [OF DPow_replacement_Reflects],
       auto)
apply (unfold is_Collect_def)
apply (rule_tac env="[A,B]" in DPow_LsetI)
apply (rule sep_rules mem_formula_iff_sats mem_list_iff_sats
            DPow_sats_iff_sats | simp)+
done

subsubsection\<open>Actually Instantiating the Locale\<close>

lemma M_DPow_axioms_L: "M_DPow_axioms(L)"
  apply (rule M_DPow_axioms.intro)
   apply (assumption | rule DPow_separation DPow_replacement)+
  done

theorem M_DPow_L: "PROP M_DPow(L)"
  apply (rule M_DPow.intro)
   apply (rule M_satisfies_L)
  apply (rule M_DPow_axioms_L)
  done

lemmas DPow'_closed [intro, simp] = M_DPow.DPow'_closed [OF M_DPow_L]
  and DPow'_abs [intro, simp] = M_DPow.DPow'_abs [OF M_DPow_L]

subsubsection\<open>The Operator @{term is_Collect}\<close>

text\<open>The formula @{term is_P} has one free variable, 0, and it is
enclosed within a single quantifier.\<close>

(* is_Collect :: "[i=>o,i,i=>o,i] => o"
    "is_Collect(M,A,P,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> A & P(x)" *)

definition
  Collect_fm :: "[i, i, i]=>i" where
 "Collect_fm(A,is_P,z) ==
        Forall(Iff(Member(0,succ(z)),
                   And(Member(0,succ(A)), is_P)))"

lemma is_Collect_type [TC]:
     "[| is_P \<in> formula; x \<in> nat; y \<in> nat |]
      ==> Collect_fm(x,is_P,y) \<in> formula"
by (simp add: Collect_fm_def)

lemma sats_Collect_fm:
  assumes is_P_iff_sats:
      "!!a. a \<in> A ==> is_P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
      "[|x \<in> nat; y \<in> nat; env \<in> list(A)|]
       ==> sats(A, Collect_fm(x,p,y), env) \<longleftrightarrow>
           is_Collect(##A, nth(x,env), is_P, nth(y,env))"
by (simp add: Collect_fm_def is_Collect_def is_P_iff_sats [THEN iff_sym])

lemma Collect_iff_sats:
  assumes is_P_iff_sats:
      "!!a. a \<in> A ==> is_P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
  "[| nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)|]
   ==> is_Collect(##A, x, is_P, y) \<longleftrightarrow> sats(A, Collect_fm(i,p,j), env)"
by (simp add: sats_Collect_fm [OF is_P_iff_sats])

text\<open>The second argument of @{term is_P} gives it direct access to @{term x},
  which is essential for handling free variable references.\<close>
theorem Collect_reflection:
  assumes is_P_reflection:
    "!!h f g. REFLECTS[\<lambda>x. is_P(L, f(x), g(x)),
                     \<lambda>i x. is_P(##Lset(i), f(x), g(x))]"
  shows "REFLECTS[\<lambda>x. is_Collect(L, f(x), is_P(L,x), g(x)),
               \<lambda>i x. is_Collect(##Lset(i), f(x), is_P(##Lset(i), x), g(x))]"
apply (simp (no_asm_use) only: is_Collect_def)
apply (intro FOL_reflections is_P_reflection)
done

subsubsection\<open>The Operator @{term is_Replace}\<close>

text\<open>BEWARE!  The formula @{term is_P} has free variables 0, 1
 and not the usual 1, 0!  It is enclosed within two quantifiers.\<close>

(*  is_Replace :: "[i=>o,i,[i,i]=>o,i] => o"
    "is_Replace(M,A,P,z) == \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A & P(x,u))" *)

definition
  Replace_fm :: "[i, i, i]=>i" where
  "Replace_fm(A,is_P,z) ==
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,A#+2), is_P))))"

lemma is_Replace_type [TC]:
     "[| is_P \<in> formula; x \<in> nat; y \<in> nat |]
      ==> Replace_fm(x,is_P,y) \<in> formula"
by (simp add: Replace_fm_def)

lemma sats_Replace_fm:
  assumes is_P_iff_sats:
      "!!a b. [|a \<in> A; b \<in> A|]
              ==> is_P(a,b) \<longleftrightarrow> sats(A, p, Cons(a,Cons(b,env)))"
  shows
      "[|x \<in> nat; y \<in> nat; env \<in> list(A)|]
       ==> sats(A, Replace_fm(x,p,y), env) \<longleftrightarrow>
           is_Replace(##A, nth(x,env), is_P, nth(y,env))"
by (simp add: Replace_fm_def is_Replace_def is_P_iff_sats [THEN iff_sym])

lemma Replace_iff_sats:
  assumes is_P_iff_sats:
      "!!a b. [|a \<in> A; b \<in> A|]
              ==> is_P(a,b) \<longleftrightarrow> sats(A, p, Cons(a,Cons(b,env)))"
  shows
  "[| nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)|]
   ==> is_Replace(##A, x, is_P, y) \<longleftrightarrow> sats(A, Replace_fm(i,p,j), env)"
by (simp add: sats_Replace_fm [OF is_P_iff_sats])

text\<open>The second argument of @{term is_P} gives it direct access to @{term x},
  which is essential for handling free variable references.\<close>
theorem Replace_reflection:
  assumes is_P_reflection:
    "!!h f g. REFLECTS[\<lambda>x. is_P(L, f(x), g(x), h(x)),
                     \<lambda>i x. is_P(##Lset(i), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_Replace(L, f(x), is_P(L,x), g(x)),
               \<lambda>i x. is_Replace(##Lset(i), f(x), is_P(##Lset(i), x), g(x))]"
apply (simp (no_asm_use) only: is_Replace_def)
apply (intro FOL_reflections is_P_reflection)
done

subsubsection\<open>The Operator @{term is_DPow'}, Internalized\<close>

(*  "is_DPow'(M,A,Z) ==
       \<forall>X[M]. X \<in> Z \<longleftrightarrow>
         subset(M,X,A) &
           (\<exists>env[M]. \<exists>p[M]. mem_formula(M,p) & mem_list(M,A,env) &
                    is_Collect(M, A, is_DPow_sats(M,A,env,p), X))" *)

definition
  DPow'_fm :: "[i,i]=>i" where
    "DPow'_fm(A,Z) ==
      Forall(
       Iff(Member(0,succ(Z)),
        And(subset_fm(0,succ(A)),
         Exists(Exists(
          And(mem_formula_fm(0),
           And(mem_list_fm(A#+3,1),
            Collect_fm(A#+3,
                       DPow_sats_fm(A#+4, 2, 1, 0), 2))))))))"

lemma is_DPow'_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> DPow'_fm(x,y) \<in> formula"
by (simp add: DPow'_fm_def)

lemma sats_DPow'_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, DPow'_fm(x,y), env) \<longleftrightarrow>
        is_DPow'(##A, nth(x,env), nth(y,env))"
by (simp add: DPow'_fm_def is_DPow'_def sats_subset_fm' sats_Collect_fm)

lemma DPow'_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_DPow'(##A, x, y) \<longleftrightarrow> sats(A, DPow'_fm(i,j), env)"
by (simp add: sats_DPow'_fm)

theorem DPow'_reflection:
     "REFLECTS[\<lambda>x. is_DPow'(L,f(x),g(x)),
               \<lambda>i x. is_DPow'(##Lset(i),f(x),g(x))]"
apply (simp only: is_DPow'_def)
apply (intro FOL_reflections function_reflections mem_formula_reflection
             mem_list_reflection Collect_reflection DPow_sats_reflection)
done

subsection\<open>A Locale for Relativizing the Operator @{term Lset}\<close>

definition
  transrec_body :: "[i=>o,i,i,i,i] => o" where
    "transrec_body(M,g,x) ==
      \<lambda>y z. \<exists>gy[M]. y \<in> x & fun_apply(M,g,y,gy) & is_DPow'(M,gy,z)"

lemma (in M_DPow) transrec_body_abs:
     "[|M(x); M(g); M(z)|]
    ==> transrec_body(M,g,x,y,z) \<longleftrightarrow> y \<in> x & z = DPow'(g`y)"
by (simp add: transrec_body_def DPow'_abs transM [of _ x])

locale M_Lset = M_DPow +
 assumes strong_rep:
   "[|M(x); M(g)|] ==> strong_replacement(M, \<lambda>y z. transrec_body(M,g,x,y,z))"
 and transrec_rep:
    "M(i) ==> transrec_replacement(M, \<lambda>x f u.
              \<exists>r[M]. is_Replace(M, x, transrec_body(M,f,x), r) &
                     big_union(M, r, u), i)"

lemma (in M_Lset) strong_rep':
   "[|M(x); M(g)|]
    ==> strong_replacement(M, \<lambda>y z. y \<in> x & z = DPow'(g`y))"
by (insert strong_rep [of x g], simp add: transrec_body_abs)

lemma (in M_Lset) DPow_apply_closed:
   "[|M(f); M(x); y\<in>x|] ==> M(DPow'(f`y))"
by (blast intro: DPow'_closed dest: transM)

lemma (in M_Lset) RepFun_DPow_apply_closed:
   "[|M(f); M(x)|] ==> M({DPow'(f`y). y\<in>x})"
by (blast intro: DPow_apply_closed RepFun_closed2 strong_rep')

lemma (in M_Lset) RepFun_DPow_abs:
     "[|M(x); M(f); M(r) |]
      ==> is_Replace(M, x, \<lambda>y z. transrec_body(M,f,x,y,z), r) \<longleftrightarrow>
          r =  {DPow'(f`y). y\<in>x}"
apply (simp add: transrec_body_abs RepFun_def)
apply (rule iff_trans)
apply (rule Replace_abs)
apply (simp_all add: DPow_apply_closed strong_rep')
done

lemma (in M_Lset) transrec_rep':
   "M(i) ==> transrec_replacement(M, \<lambda>x f u. u = (\<Union>y\<in>x. DPow'(f ` y)), i)"
apply (insert transrec_rep [of i])
apply (simp add: RepFun_DPow_apply_closed RepFun_DPow_abs
       transrec_replacement_def)
done

text\<open>Relativization of the Operator @{term Lset}\<close>

definition
  is_Lset :: "[i=>o, i, i] => o" where
   \<comment>\<open>We can use the term language below because @{term is_Lset} will
       not have to be internalized: it isn't used in any instance of
       separation.\<close>
   "is_Lset(M,a,z) == is_transrec(M, %x f u. u = (\<Union>y\<in>x. DPow'(f`y)), a, z)"

lemma (in M_Lset) Lset_abs:
  "[|Ord(i);  M(i);  M(z)|]
   ==> is_Lset(M,i,z) \<longleftrightarrow> z = Lset(i)"
apply (simp add: is_Lset_def Lset_eq_transrec_DPow')
apply (rule transrec_abs)
apply (simp_all add: transrec_rep' relation2_def RepFun_DPow_apply_closed)
done

lemma (in M_Lset) Lset_closed:
  "[|Ord(i);  M(i)|] ==> M(Lset(i))"
apply (simp add: Lset_eq_transrec_DPow')
apply (rule transrec_closed [OF transrec_rep'])
apply (simp_all add: relation2_def RepFun_DPow_apply_closed)
done

subsection\<open>Instantiating the Locale \<open>M_Lset\<close>\<close>

subsubsection\<open>The First Instance of Replacement\<close>

lemma strong_rep_Reflects:
 "REFLECTS [\<lambda>u. \<exists>v[L]. v \<in> B & (\<exists>gy[L].
                          v \<in> x & fun_apply(L,g,v,gy) & is_DPow'(L,gy,u)),
   \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B & (\<exists>gy \<in> Lset(i).
            v \<in> x & fun_apply(##Lset(i),g,v,gy) & is_DPow'(##Lset(i),gy,u))]"
by (intro FOL_reflections function_reflections DPow'_reflection)

lemma strong_rep:
   "[|L(x); L(g)|] ==> strong_replacement(L, \<lambda>y z. transrec_body(L,g,x,y,z))"
apply (unfold transrec_body_def)
apply (rule strong_replacementI)
apply (rule_tac u="{x,g,B}"
         in gen_separation_multi [OF strong_rep_Reflects], auto)
apply (rule_tac env="[x,g,B]" in DPow_LsetI)
apply (rule sep_rules DPow'_iff_sats | simp)+
done

subsubsection\<open>The Second Instance of Replacement\<close>

lemma transrec_rep_Reflects:
 "REFLECTS [\<lambda>x. \<exists>v[L]. v \<in> B &
              (\<exists>y[L]. pair(L,v,y,x) &
             is_wfrec (L, \<lambda>x f u. \<exists>r[L].
                is_Replace (L, x, \<lambda>y z.
                     \<exists>gy[L]. y \<in> x & fun_apply(L,f,y,gy) &
                      is_DPow'(L,gy,z), r) & big_union(L,r,u), mr, v, y)),
    \<lambda>i x. \<exists>v \<in> Lset(i). v \<in> B &
              (\<exists>y \<in> Lset(i). pair(##Lset(i),v,y,x) &
             is_wfrec (##Lset(i), \<lambda>x f u. \<exists>r \<in> Lset(i).
                is_Replace (##Lset(i), x, \<lambda>y z.
                     \<exists>gy \<in> Lset(i). y \<in> x & fun_apply(##Lset(i),f,y,gy) &
                      is_DPow'(##Lset(i),gy,z), r) &
                      big_union(##Lset(i),r,u), mr, v, y))]"
apply (simp only: rex_setclass_is_bex [symmetric])
  \<comment>\<open>Convert \<open>\<exists>y\<in>Lset(i)\<close> to \<open>\<exists>y[##Lset(i)]\<close> within the body
       of the @{term is_wfrec} application.\<close>
apply (intro FOL_reflections function_reflections
          is_wfrec_reflection Replace_reflection DPow'_reflection)
done

lemma transrec_rep:
    "[|L(j)|]
    ==> transrec_replacement(L, \<lambda>x f u.
              \<exists>r[L]. is_Replace(L, x, transrec_body(L,f,x), r) &
                     big_union(L, r, u), j)"
apply (rule transrec_replacementI, assumption)
apply (unfold transrec_body_def)
apply (rule strong_replacementI)
apply (rule_tac u="{j,B,Memrel(eclose({j}))}"
         in gen_separation_multi [OF transrec_rep_Reflects], auto)
apply (rule_tac env="[j,B,Memrel(eclose({j}))]" in DPow_LsetI)
apply (rule sep_rules is_wfrec_iff_sats Replace_iff_sats DPow'_iff_sats |
       simp)+
done

subsubsection\<open>Actually Instantiating \<open>M_Lset\<close>\<close>

lemma M_Lset_axioms_L: "M_Lset_axioms(L)"
  apply (rule M_Lset_axioms.intro)
       apply (assumption | rule strong_rep transrec_rep)+
  done

theorem M_Lset_L: "PROP M_Lset(L)"
  apply (rule M_Lset.intro)
   apply (rule M_DPow_L)
  apply (rule M_Lset_axioms_L)
  done

text\<open>Finally: the point of the whole theory!\<close>
lemmas Lset_closed = M_Lset.Lset_closed [OF M_Lset_L]
   and Lset_abs = M_Lset.Lset_abs [OF M_Lset_L]

subsection\<open>The Notion of Constructible Set\<close>

definition
  constructible :: "[i=>o,i] => o" where
    "constructible(M,x) ==
       \<exists>i[M]. \<exists>Li[M]. ordinal(M,i) & is_Lset(M,i,Li) & x \<in> Li"

theorem V_equals_L_in_L:
  "L(x) \<longleftrightarrow> constructible(L,x)"
apply (simp add: constructible_def Lset_abs Lset_closed)
apply (simp add: L_def)
apply (blast intro: Ord_in_L)
done

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header {* Well-Defined Programs. *}

theory WellDefined imports
  Healthiness
  Sublinearity
  LoopInduction
begin

text {* The definition of a well-defined program collects the various notions of healthiness and
well-behavedness that we have so far established: healthiness of the strict and liberal
transformers, continuity and sublinearity of the strict transformers, and two new properties.
These are that the strict transformer always lies below the liberal one (i.e. that it is at least
as \emph{strict}, recalling the standard embedding of a predicate), and that expectation
conjunction is distributed between then in a particular manner, which will be crucial in
establishing the loop rules. *}

subsection {* Strict Implies Liberal *}

text {* This establishes the first connection between the strict and
  liberal interpretations (@{term wp} and @{term wlp}). *}

definition
  wp_under_wlp :: "'s prog \<Rightarrow> bool"
where
  "wp_under_wlp prog \<equiv> \<forall>P. unitary P \<longrightarrow> wp prog P \<tturnstile> wlp prog P"

lemma wp_under_wlpI[intro]:
  "\<lbrakk> \<And>P. unitary P \<Longrightarrow> wp prog P \<tturnstile> wlp prog P \<rbrakk> \<Longrightarrow> wp_under_wlp prog"
  unfolding wp_under_wlp_def by(simp)

lemma wp_under_wlpD[dest]:
  "\<lbrakk> wp_under_wlp prog; unitary P \<rbrakk> \<Longrightarrow> wp prog P \<tturnstile> wlp prog P"
  unfolding wp_under_wlp_def by(simp)

lemma wp_under_le_trans:
  "wp_under_wlp a \<Longrightarrow> le_utrans (wp a) (wlp a)"
  by(blast)

lemma wp_under_wlp_Abort:
  "wp_under_wlp Abort"
  by(rule wp_under_wlpI, unfold wp_eval, auto)

lemma wp_under_wlp_Skip:
  "wp_under_wlp Skip"
  by(rule wp_under_wlpI, unfold wp_eval, blast)

lemma wp_under_wlp_Apply:
  "wp_under_wlp (Apply f)"
  by(auto simp:wp_eval)

lemma wp_under_wlp_Seq:
  assumes h_wlp_a: "nearly_healthy (wlp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
      and wp_u_a:  "wp_under_wlp a"
      and wp_u_b:  "wp_under_wlp b"
  shows "wp_under_wlp (a ;; b)"
proof(rule wp_under_wlpI, unfold wp_eval o_def)
  fix P::"'a \<Rightarrow> real" assume uP: "unitary P"
  with h_wp_b have "unitary (wp b P)" by(blast)
  with wp_u_a have "wp a (wp b P) \<tturnstile> wlp a (wp b P)" by(auto)
  also {
    from wp_u_b and uP have "wp b P \<tturnstile> wlp b P" by(blast)
    with h_wlp_a and h_wlp_b and h_wp_b and uP
    have "wlp a (wp b P) \<tturnstile> wlp a (wlp b P)"
      by(blast intro:nearly_healthy_monoD[OF h_wlp_a])
  }
  finally show "wp a (wp b P) \<tturnstile> wlp a (wlp b P)" .
qed

lemma wp_under_wlp_PC:
  assumes h_wp_a:  "healthy (wp a)"
      and h_wlp_a: "nearly_healthy (wlp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
      and wp_u_a:  "wp_under_wlp a"
      and wp_u_b:  "wp_under_wlp b"
      and uP:      "unitary P"
  shows "wp_under_wlp (a \<^bsub>P\<^esub>\<oplus> b)"
proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"
  from uP have "P s \<le> 1" by(blast)
  hence "0 \<le> 1 - P s" by(simp)
  moreover
  from uQ and wp_u_b have "wp b Q s \<le> wlp b Q s" by(blast)
  ultimately
  have "(1 - P s) * wp b Q s \<le> (1 - P s) * wlp b Q s"
    by(blast intro:mult_left_mono)

  moreover {
    from uQ and wp_u_a have "wp a Q s \<le> wlp a Q s" by(blast)
    with uP have "P s * wp a Q s \<le> P s * wlp a Q s"
      by(blast intro:mult_left_mono)
  }

  ultimately
  show "P s * wp  a Q s + (1 - P s) * wp  b Q s \<le>
        P s * wlp a Q s + (1 - P s) * wlp b Q s"
    by(blast intro: add_mono)
qed

lemma wp_under_wlp_DC:
  assumes wp_u_a:  "wp_under_wlp a"
      and wp_u_b:  "wp_under_wlp b"
  shows "wp_under_wlp (a \<Sqinter> b)"
proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"

  from wp_u_a uQ have "wp a Q s \<le> wlp a Q s" by(blast)
  moreover
  from wp_u_b uQ have "wp b Q s \<le> wlp b Q s" by(blast)
  ultimately
  show "min (wp a Q s) (wp b Q s) \<le> min (wlp a Q s) (wlp b Q s)"
    by(auto)
qed

lemma wp_under_wlp_SetPC:
  assumes wp_u_f:  "\<And>s a. a \<in> supp (P s) \<Longrightarrow> wp_under_wlp (f a)"
      and nP:      "\<And>s a. a \<in> supp (P s) \<Longrightarrow> 0 \<le> P s a"
  shows "wp_under_wlp (SetPC f P)"
proof(rule wp_under_wlpI, unfold wp_eval, rule le_funI)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"

  from wp_u_f uQ nP
  show "(\<Sum>a\<in>supp (P s). P s a * wp (f a) Q s) \<le> (\<Sum>a\<in>supp (P s). P s a * wlp (f a) Q s)"
    by(auto intro!:setsum_mono mult_left_mono)
qed

lemma wp_under_wlp_SetDC:
  assumes wp_u_f:  "\<And>s a. a \<in> S s \<Longrightarrow> wp_under_wlp (f a)"
      and hf:      "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (f a))"
      and nS:      "\<And>s. S s \<noteq> {}"
  shows "wp_under_wlp (SetDC f S)"
proof(rule wp_under_wlpI, rule le_funI, unfold wp_eval)
  fix Q::"'a \<Rightarrow> real" and s
  assume uQ: "unitary Q"

  show "Inf ((\<lambda>a. wp (f a) Q s) ` S s) \<le> Inf ((\<lambda>a. wlp (f a) Q s) ` S s)"
  proof(rule cInf_mono)
    from nS show "(\<lambda>a. wlp (f a) Q s) ` S s \<noteq> {}" by(blast)

    fix x assume xin: "x \<in> (\<lambda>a. wlp (f a) Q s) ` S s"
    then obtain a where ain: "a \<in> S s" and xrw: "x = wlp (f a) Q s"
      by(blast)
    with wp_u_f uQ
    have "wp (f a) Q s \<le> wlp (f a) Q s" by(blast)
    moreover from ain have "wp (f a) Q s \<in> (\<lambda>a. wp (f a) Q s) ` S s"
      by(blast)
    ultimately show "\<exists>y\<in> (\<lambda>a. wp (f a) Q s) ` S s. y \<le> x"
      by(auto simp:xrw)

  next
    fix y assume yin: "y \<in> (\<lambda>a. wp (f a) Q s) ` S s"
    then obtain a where ain: "a \<in> S s" and yrw: "y = wp (f a) Q s"
      by(blast)
    with hf uQ have "unitary (wp (f a) Q)" by(auto)
    with yrw show "0 \<le> y" by(auto)
  qed
qed

lemma wp_under_wlp_Embed:
  "wp_under_wlp (Embed t)"
  by(rule wp_under_wlpI, unfold wp_eval, blast)

lemma wp_under_wlp_loop:
  fixes body::"'s prog"
  assumes hwp: "healthy (wp body)"
      and hwlp: "nearly_healthy (wlp body)"
      and wp_under: "wp_under_wlp body"
  shows "wp_under_wlp (do G \<longrightarrow> body od)"
proof(rule wp_under_wlpI)
  fix P::"'s expect"
  assume uP: "unitary P" hence sP: "sound P" by(auto)

  let "?X Q s" = "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
  let "?Y Q s" = "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"

  show "wp (do G \<longrightarrow> body od) P \<tturnstile> wlp (do G \<longrightarrow> body od) P"
  proof(simp add:hwp hwlp sP uP wp_Loop1 wlp_Loop1, rule gfp_exp_upperbound)
    thm lfp_loop_fp
    from hwp sP have "lfp_exp ?X = ?X (lfp_exp ?X)"
      by(rule lfp_wp_loop_unfold)
    hence "lfp_exp ?X \<tturnstile> ?X (lfp_exp ?X)" by(simp)
    also {
      from hwp uP have "wp body (lfp_exp ?X) \<tturnstile> wlp body (lfp_exp ?X)"
        by(auto intro:wp_under_wlpD[OF wp_under] lfp_loop_unitary)
      hence "?X (lfp_exp ?X) \<tturnstile> ?Y (lfp_exp ?X)"
        by(auto intro:add_mono mult_left_mono)
    }
    finally show "lfp_exp ?X \<tturnstile> ?Y (lfp_exp ?X)" .
    from hwp uP show "unitary (lfp_exp ?X)"
      by(auto intro:lfp_loop_unitary)
  qed
qed

lemma wp_under_wlp_repeat:
  "\<lbrakk> healthy (wp a); nearly_healthy (wlp a); wp_under_wlp a \<rbrakk> \<Longrightarrow>
   wp_under_wlp (repeat n a)"
  by(induct n, auto intro!:wp_under_wlp_Skip wp_under_wlp_Seq healthy_intros)

lemma wp_under_wlp_Bind:
  "\<lbrakk> \<And>s. wp_under_wlp (a (f s)) \<rbrakk> \<Longrightarrow> wp_under_wlp (Bind f a)"
  unfolding wp_under_wlp_def by(auto simp:wp_eval)

lemmas wp_under_wlp_intros =
  wp_under_wlp_Abort wp_under_wlp_Skip
  wp_under_wlp_Apply wp_under_wlp_Seq
  wp_under_wlp_PC    wp_under_wlp_DC
  wp_under_wlp_SetPC wp_under_wlp_SetDC
  wp_under_wlp_Embed wp_under_wlp_loop
  wp_under_wlp_repeat wp_under_wlp_Bind

subsection {* Sub-Distributivity of Conjunction *}

definition
  sub_distrib_pconj :: "'s prog \<Rightarrow> bool"
where
  "sub_distrib_pconj prog \<equiv>
   \<forall>P Q. unitary P \<longrightarrow> unitary Q \<longrightarrow>
         wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q)"

lemma sub_distrib_pconjI[intro]:
  "\<lbrakk>\<And>P Q. \<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow>  wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q) \<rbrakk> \<Longrightarrow>
    sub_distrib_pconj prog"
  unfolding sub_distrib_pconj_def by(simp)

lemma sub_distrib_pconjD[dest]:
  "\<And>P Q. \<lbrakk> sub_distrib_pconj prog; unitary P; unitary Q \<rbrakk> \<Longrightarrow>
   wlp prog P && wp prog Q \<tturnstile> wp prog (P && Q)"
  unfolding sub_distrib_pconj_def by(simp)

lemma sdp_Abort:
  "sub_distrib_pconj Abort"
  by(rule sub_distrib_pconjI, unfold wp_eval, auto intro:exp_conj_rzero)

lemma sdp_Skip:
  "sub_distrib_pconj Skip"
  by(rule sub_distrib_pconjI, simp add:wp_eval)

lemma sdp_Seq:
  fixes a and b
  assumes sdp_a:   "sub_distrib_pconj a"
      and sdp_b:   "sub_distrib_pconj b"
      and h_wp_a:  "healthy (wp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
  shows "sub_distrib_pconj (a ;; b)"
proof(rule sub_distrib_pconjI, unfold wp_eval o_def)
  fix P::"'a \<Rightarrow> real" and Q::"'a \<Rightarrow> real"
  assume uP: "unitary P" and uQ: "unitary Q"

  with h_wp_b and h_wlp_b
  have "wlp a (wlp b P) && wp a (wp b Q) \<tturnstile> wp a (wlp b P && wp b Q)"
    by(blast intro!:sub_distrib_pconjD[OF sdp_a])
  also {
    from sdp_b and uP and uQ
    have "wlp b P && wp b Q \<tturnstile> wp b (P && Q)" by(blast)
    with h_wp_a h_wp_b h_wlp_b uP uQ
    have "wp a (wlp b P && wp b Q) \<tturnstile> wp a (wp b (P && Q))"
      by(blast intro!:mono_transD[OF healthy_monoD, OF h_wp_a] unitary_sound
                      unitary_intros sound_intros)
  }
  finally show "wlp a (wlp b P) && wp a (wp b Q) \<tturnstile> wp a (wp b (P && Q))" .
qed

lemma sdp_Apply:
  "sub_distrib_pconj (Apply f)"
  by(rule sub_distrib_pconjI, simp add:wp_eval)

lemma sdp_DC:
  fixes a::"'s prog" and b
  assumes sdp_a:   "sub_distrib_pconj a"
      and sdp_b:   "sub_distrib_pconj b"
      and h_wp_a:  "healthy (wp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
  shows "sub_distrib_pconj (a \<Sqinter> b)"
proof(rule sub_distrib_pconjI, unfold wp_eval, rule le_funI)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P" and uQ: "unitary Q"

  have "((\<lambda>s. min (wlp a P s) (wlp b P s)) &&
         (\<lambda>s. min (wp a Q s) (wp b Q s))) s \<le>
        min (wlp a P s .& wp a Q s) (wlp b P s .& wp b Q s)"
    unfolding exp_conj_def by(rule min_pconj)
  also {
    have "(\<lambda>s. wlp a P s .& wp a Q s) = wlp a P && wp a Q"
      by(simp add:exp_conj_def)
    also from sdp_a uP uQ have "... \<tturnstile> wp a (P && Q)"
      by(blast dest:sub_distrib_pconjD)
    finally have "wlp a P s .& wp a Q s \<le> wp a (P && Q) s"
      by(rule le_funD)
    moreover {
      have "(\<lambda>s. wlp b P s .& wp b Q s) = wlp b P && wp b Q"
        by(simp add:exp_conj_def)
    also from sdp_b uP uQ have "... \<tturnstile> wp b (P && Q)"
      by(blast)
    finally have "wlp b P s .& wp b Q s \<le> wp b (P && Q) s"
      by(rule le_funD)
    }
    ultimately
    have "min (wlp a P s .& wp a Q s) (wlp b P s .& wp b Q s) \<le>
          min (wp a (P && Q) s) (wp b (P && Q) s)" by(auto)
  }
  finally
  show "((\<lambda>s. min (wlp a P s) (wlp b P s)) &&
         (\<lambda>s. min (wp a Q s) (wp b Q s))) s \<le>
        min (wp a (P && Q) s) (wp b (P && Q) s)" .
qed

lemma sdp_PC:
  fixes a::"'s prog" and b
  assumes sdp_a:   "sub_distrib_pconj a"
      and sdp_b:   "sub_distrib_pconj b"
      and h_wp_a:  "healthy (wp a)"
      and h_wp_b:  "healthy (wp b)"
      and h_wlp_b: "nearly_healthy (wlp b)"
      and uP:      "unitary P"
  shows "sub_distrib_pconj (a \<^bsub>P\<^esub>\<oplus> b)"
proof(rule sub_distrib_pconjI, unfold wp_eval, rule le_funI)
  fix Q::"'s \<Rightarrow> real" and R::"'s \<Rightarrow> real" and s::'s
  assume uQ: "unitary Q" and uR: "unitary R"

  have nnA: "0 \<le> P s" and nnB: "0 \<le> 1 - P s"
    using uP by(auto simp:sign_simps)
  note nn = nnA nnB

  have "((\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) &&
         (\<lambda>s. P s *  wp a R s + (1 - P s) *  wp b R s)) s =
        ((P s * wlp a Q s + (1 - P s) * wlp b Q s) +
         (P s *  wp a R s + (1 - P s) *  wp b R s)) \<ominus> 1"
    by(simp add:exp_conj_def pconj_def)
  also have "... = P s *       (wlp a Q s + wp a R s) +
                   (1 - P s) * (wlp b Q s + wp b R s) \<ominus> 1"
    by(simp add:field_simps)
  also have "... = P s *       (wlp a Q s + wp a R s) +
                   (1 - P s) * (wlp b Q s + wp b R s) \<ominus>
                   (P s + (1 - P s))"
    by(simp)
  also have "... \<le> (P s *       (wlp a Q s + wp a R s) \<ominus> P s) +
                   ((1 - P s) * (wlp b Q s + wp b R s) \<ominus> (1 - P s))"
    by(rule tminus_add_mono)
  also have "... = (P s       * (wlp a Q s + wp a R s \<ominus> 1)) +
                   ((1 - P s) * (wlp b Q s + wp b R s \<ominus> 1))"
    by(simp add:nn tminus_left_distrib)
  also have "... = P s *       ((wlp a Q && wp a R) s) +
                   (1 - P s) * ((wlp b Q && wp b R) s)"
    by(simp add:exp_conj_def pconj_def)
  also {
    from sdp_a sdp_b uQ uR
    have "P s * (wlp a Q && wp a R) s \<le> P s * wp a (Q && R) s"
     and "(1 - P s) * (wlp b Q && wp b R) s \<le> (1 - P s) * wp b (Q && R) s"
      by(auto intro:le_funD sub_distrib_pconjD nn mult_left_mono)
    hence "P s *       ((wlp a Q && wp a R) s) +
           (1 - P s) * ((wlp b Q && wp b R) s) \<le>
           P s * wp a (Q && R) s + (1 - P s) * wp b (Q && R) s"
      by(auto)
  }
  finally show "((\<lambda>s. P s * wlp a Q s + (1 - P s) * wlp b Q s) &&
                 (\<lambda>s. P s *  wp a R s + (1 - P s) *  wp b R s)) s \<le>
                P s * wp a (Q && R) s + (1 - P s) * wp b (Q && R) s" .
qed

lemma sdp_Embed:
  "\<lbrakk> \<And>P Q. \<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow> t P && t Q \<tturnstile> t (P && Q) \<rbrakk> \<Longrightarrow>
   sub_distrib_pconj (Embed t)"
  by(auto simp:wp_eval)

lemma sdp_repeat:
  fixes a::"'s prog"
  assumes sdpa: "sub_distrib_pconj a"
      and hwp: "healthy (wp a)" and hwlp: "nearly_healthy (wlp a)"
  shows "sub_distrib_pconj (repeat n a)" (is "?X n")
proof(induct n)
  show "?X 0" by(simp add:sdp_Skip)
  fix n assume IH: "?X n"
  show "?X (Suc n)"
  proof(rule sub_distrib_pconjI, simp add:wp_eval)
    fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real"
    assume uP: "unitary P" and uQ: "unitary Q"
    from assms have hwlpa: "nearly_healthy (wlp (repeat n a))"
                and hwpa:  "healthy (wp (repeat n a))"
      by(auto intro:healthy_intros)
    from uP and hwlpa have "unitary (wlp (repeat n a) P)" by(blast)
    moreover from uQ and hwpa have "unitary (wp (repeat n a) Q)" by(blast)
    ultimately
    have "wlp a (wlp (repeat n a) P) && wp a (wp (repeat n a) Q) \<tturnstile>
          wp a (wlp (repeat n a) P && wp (repeat n a) Q)"
      using sdpa by(blast)
    also {
      from hwlp have "nearly_healthy (wlp (repeat n a))" by(rule healthy_intros)
      with uP have "sound (wlp (repeat n a) P)" by(auto)
      moreover from hwp uQ have "sound (wp (repeat n a) Q)"
        by(auto intro:healthy_intros)
      ultimately have "sound (wlp (repeat n a) P && wp (repeat n a) Q)"
        by(rule exp_conj_sound)
      moreover {
        from uP uQ have "sound (P && Q)" by(auto intro:exp_conj_sound)
        with hwp have "sound (wp (repeat n a) (P && Q))"
          by(auto intro:healthy_intros)
      }
      moreover from uP uQ IH
      have "wlp (repeat n a) P && wp (repeat n a) Q \<tturnstile> wp (repeat n a) (P && Q)"
        by(blast)
      ultimately
      have "wp a (wlp (repeat n a) P && wp (repeat n a) Q) \<tturnstile>
            wp a (wp (repeat n a) (P && Q))"
        by(rule mono_transD[OF healthy_monoD, OF hwp])
    }
    finally show "wlp a (wlp (repeat n a) P) && wp a (wp (repeat n a) Q) \<tturnstile>
                  wp a (wp (repeat n a) (P && Q))" .
  qed
qed

lemma sdp_SetPC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes sdp: "\<And>s a. a \<in> supp (P s) \<Longrightarrow> sub_distrib_pconj (p a)"
      and fin: "\<And>s. finite (supp (P s))"
      and nnp: "\<And>s a. 0 \<le> P s a"
      and sub: "\<And>s. setsum (P s) (supp (P s)) \<le> 1"
  shows "sub_distrib_pconj (SetPC p P)"
proof(rule sub_distrib_pconjI, simp add:wp_eval, rule le_funI)
  fix Q::"'s \<Rightarrow> real" and R::"'s \<Rightarrow> real" and s::'s
  assume uQ: "unitary Q" and uR: "unitary R"
  have "((\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) &&
         (\<lambda>s. \<Sum>a\<in>supp (P s). P s a *  wp (p a) R s)) s =
        (\<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) + (\<Sum>a\<in>supp (P s). P s a * wp (p a) R s) \<ominus> 1"
    by(simp add:exp_conj_def pconj_def)
  also have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s)) \<ominus> 1"
    by(simp add: setsum.distrib field_simps)
  also from sub
  have "... \<le> (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s)) \<ominus>
              (\<Sum>a\<in>supp (P s). P s a)"
    by(rule tminus_right_antimono)
  also from fin
  have "... \<le> (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s) \<ominus> P s a)"
    by(rule tminus_setsum_mono)
  also from nnp
  have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q s + wp (p a) R s \<ominus> 1))"
    by(simp add:tminus_left_distrib)
  also have "... = (\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q && wp (p a) R) s)"
    by(simp add:pconj_def exp_conj_def)
  also {
    from sdp uQ uR
    have "\<And>a. a \<in> supp (P s) \<Longrightarrow> wlp (p a) Q && wp (p a) R \<tturnstile> wp (p a) (Q && R)"
      by(blast intro:sub_distrib_pconjD)
    with nnp
    have "(\<Sum>a\<in>supp (P s). P s a * (wlp (p a) Q && wp (p a) R) s) \<le>
          (\<Sum>a\<in>supp (P s). P s a * (wp (p a) (Q && R)) s)"
      by(blast intro:setsum_mono mult_left_mono)
  }
  finally show "((\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wlp (p a) Q s) &&
                 (\<lambda>s. \<Sum>a\<in>supp (P s). P s a * wp (p a) R s)) s \<le>
                (\<Sum>a\<in>supp (P s). P s a * wp (p a) (Q && R) s)" .
qed

lemma sdp_SetDC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes sdp: "\<And>s a. a \<in> S s \<Longrightarrow> sub_distrib_pconj (p a)"
      and hwp: "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (p a))"
      and hwlp: "\<And>s a. a \<in> S s \<Longrightarrow> nearly_healthy (wlp (p a))"
      and ne:  "\<And>s. S s \<noteq> {}"
  shows "sub_distrib_pconj (SetDC p S)"
proof(rule sub_distrib_pconjI, rule le_funI)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P" and uQ: "unitary Q"

  from uP hwlp
  have "\<And>x. x \<in> (\<lambda>a. wlp (p a) P) ` S s \<Longrightarrow> unitary x" by(auto)
  hence "\<And>y. y \<in> (\<lambda>a. wlp (p a) P s) ` S s \<Longrightarrow> 0 \<le> y" by(auto)
  hence "\<And>a. a \<in> S s \<Longrightarrow> wlp (SetDC p S) P s \<le> wlp (p a) P s"
    unfolding wp_eval by(intro cInf_lower bdd_belowI, auto)
  moreover {
    from uQ hwp have "\<And>a. a \<in> S s \<Longrightarrow>  0 \<le> wp (p a) Q s" by(blast)
    hence "\<And>a. a \<in> S s \<Longrightarrow> wp (SetDC p S) Q s \<le> wp (p a) Q s"
    unfolding wp_eval by(intro cInf_lower bdd_belowI, auto)
  }
  ultimately
  have "\<And>a. a \<in> S s \<Longrightarrow> wlp (SetDC p S) P s + wp (SetDC p S) Q s \<ominus> 1 \<le>
                      wlp (p a) P s + wp (p a) Q s \<ominus> 1"
    by(auto intro:tminus_left_mono add_mono)
  also have "\<And>a. wlp (p a) P s + wp (p a) Q s \<ominus> 1 = (wlp (p a) P && wp (p a) Q) s"
    by(simp add:exp_conj_def pconj_def)
  also from sdp uP uQ
  have "\<And>a. a \<in> S s \<Longrightarrow> ... a \<le> wp (p a) (P && Q) s"
    by(blast)
  also have "\<And>a. ... a = wp (p a) (\<lambda>s. P s + Q s \<ominus> 1) s"
    by(simp add:exp_conj_def pconj_def)
  finally
  show "(wlp (SetDC p S) P && wp (SetDC p S) Q) s \<le> wp (SetDC p S) (P && Q) s"
    unfolding exp_conj_def pconj_def wp_eval
    using ne by(blast intro!:cInf_greatest)
qed

lemma sdp_Bind:
  "\<lbrakk> \<And>s. sub_distrib_pconj (p (f s)) \<rbrakk> \<Longrightarrow> sub_distrib_pconj (Bind f p)"
  unfolding sub_distrib_pconj_def wp_eval exp_conj_def pconj_def
  by(blast)

text {* For loops, we again appeal to our transfinite induction principle, this time taking
advantage of the simultaneous treatment of both strict and liberal transformers. *}
lemma sdp_loop:
  fixes body::"'s prog"
  assumes sdp_body: "sub_distrib_pconj body"
      and hwlp: "nearly_healthy (wlp body)"
      and hwp:  "healthy (wp body)"
  shows "sub_distrib_pconj (do G \<longrightarrow> body od)"
proof(rule sub_distrib_pconjI, rule loop_induct[OF hwp hwlp])
  fix P Q::"'s expect" and S::"('s trans \<times> 's trans) set"
  assume uP: "unitary P" and uQ: "unitary Q"
     and ffst: "\<forall>x\<in>S. feasible (fst x)"
     and usnd: "\<forall>x\<in>S. \<forall>Q. unitary Q \<longrightarrow> unitary (snd x Q)"
     and IH: "\<forall>x\<in>S. snd x P && fst x Q \<tturnstile> fst x (P && Q)"

  show "Inf_utrans (snd ` S) P && Sup_trans (fst ` S) Q \<tturnstile>
                  Sup_trans (fst ` S) (P && Q)"
  proof(cases)
    assume "S = {}"
    thus ?thesis
      by(simp add:Inf_trans_def Sup_trans_def Inf_utrans_def
                  Inf_exp_def Sup_exp_def exp_conj_def)
  next
    assume ne: "S \<noteq> {}"

    let "?f s" = "1 + Sup_trans (fst ` S) (P && Q) s - Inf_utrans (snd ` S) P s"

    from ne obtain t where tin: "t \<in> fst ` S" by(auto)
    from ne obtain u where uin: "u \<in> snd ` S" by(auto)

    from tin ffst uP uQ have utPQ: "unitary (t (P && Q))"
      by(auto intro:exp_conj_unitary)
    hence "\<And>s. 0 \<le> t (P && Q) s" by(auto)
    also {
      from ffst tin have le: "le_utrans t (Sup_trans (fst ` S))"
        by(auto intro:Sup_trans_upper)
      with uP uQ have "\<And>s. t (P && Q) s \<le> Sup_trans (fst ` S) (P && Q) s"
        by(auto intro:exp_conj_unitary)
    }
    finally have nn_rhs: "\<And>s. 0 \<le> Sup_trans (fst ` S) (P && Q) s" .

    have "\<And>R. Inf_utrans (snd ` S) P && R \<tturnstile> Sup_trans (fst ` S) (P && Q) \<Longrightarrow> R \<le> ?f"
    proof(rule contrapos_pp, assumption)
      fix R
      assume "\<not> R \<le> ?f"
      then obtain s where "\<not> R s \<le> ?f s" by(auto)
      hence gt: "?f s < R s" by(simp)

      from nn_rhs have g1: "1 \<le> 1 + Sup_trans (fst ` S) (P && Q) s" by(auto)
      hence "Sup_trans (fst ` S) (P && Q) s = Inf_utrans (snd ` S) P s .& ?f s"
        by(simp add:pconj_def)
      also from g1 have "... = Inf_utrans (snd ` S) P s + ?f s - 1"
        by(simp)
      also from gt have "... < Inf_utrans (snd ` S) P s + R s - 1"
        by(simp)
      also {
        with g1 have "1 \<le> Inf_utrans (snd ` S) P s + R s"
          by(simp)
        hence "Inf_utrans (snd ` S) P s + R s - 1 = Inf_utrans (snd ` S) P s .& R s"
          by(simp add:pconj_def)
      }
      finally
      have "\<not> (Inf_utrans (snd ` S) P && R) s \<le> Sup_trans (fst ` S) (P && Q) s"
        by(simp add:exp_conj_def)
      thus "\<not> Inf_utrans (snd ` S) P && R \<tturnstile> Sup_trans (fst ` S) (P && Q)"
        by(auto)
    qed

    moreover have "\<forall>t\<in>fst ` S. Inf_utrans (snd ` S) P && t Q  \<tturnstile> Sup_trans (fst ` S) (P && Q)"
    proof
      fix t assume tin: "t \<in> fst ` S"
      then obtain x where xin: "x \<in> S" and fx: "t = fst x" by(auto)

      from xin have "snd x \<in> snd ` S" by(auto)
      with uP usnd have "Inf_utrans (snd ` S) P \<tturnstile> snd x P"
        by(auto intro:le_utransD[OF Inf_utrans_lower])
      hence "Inf_utrans (snd ` S) P && fst x Q \<tturnstile> snd x P && fst x Q"
        by(auto intro:entails_frame)
      also from xin IH have "... \<tturnstile> fst x (P && Q)"
        by(auto)
      also from xin ffst exp_conj_unitary[OF uP uQ]
      have "... \<tturnstile> Sup_trans (fst ` S) (P && Q)"
        by(auto intro:le_utransD[OF Sup_trans_upper])
      finally show "Inf_utrans (snd ` S) P && t Q \<tturnstile> Sup_trans (fst ` S) (P && Q)"
        by(simp add:fx)
    qed
    ultimately have bt: "\<forall>t\<in>fst ` S. t Q \<tturnstile> ?f" by(blast)

    have "Sup_trans (fst ` S) Q = Sup_exp {t Q |t. t \<in> fst ` S}"
      by(simp add:Sup_trans_def)
    also have "... \<tturnstile> ?f"
    proof(rule Sup_exp_least)
      from bt show " \<forall>R\<in>{t Q |t. t \<in> fst ` S}. R \<tturnstile> ?f" by(blast)
      from ne obtain t where tin: "t \<in> fst ` S" by(auto)
      with ffst uQ have "unitary (t Q)" by(auto)
      hence "\<lambda>s. 0 \<tturnstile> t Q" by(auto)
      also from tin bt have "... \<tturnstile> ?f" by(auto)
      finally show "nneg (\<lambda>s. 1 + Sup_trans (fst ` S) (P && Q) s -
                          Inf_utrans (snd ` S) P s)"
        by(auto)
    qed
    finally have "Inf_utrans (snd ` S) P && Sup_trans (fst ` S) Q \<tturnstile>
                  Inf_utrans (snd ` S) P && ?f"
      by(auto intro:entails_frame)
    also from nn_rhs have "... \<tturnstile> Sup_trans (fst ` S) (P && Q)"
      by(simp add:exp_conj_def pconj_def)
    finally show ?thesis .
  qed

next
  fix P Q::"'s expect" and t u::"'s trans"
  assume uP: "unitary P" and uQ: "unitary Q"
     and ft: "feasible t"
     and uu: "\<And>Q. unitary Q \<Longrightarrow> unitary (u Q)"
     and IH: "u P && t Q \<tturnstile> t (P && Q)"
  show "wlp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P &&
        wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q \<tturnstile>
        wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) (P && Q)"
  proof(rule le_funI, simp add:wp_eval exp_conj_def pconj_def)
    fix s::'s
    have "\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s +
          (\<guillemotleft> G \<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> 1 =
          (\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + \<guillemotleft> G \<guillemotright> s * wp body (t Q) s) +
           ((1 - \<guillemotleft> G \<guillemotright> s) * P s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> (\<guillemotleft>G\<guillemotright> s + (1 - \<guillemotleft>G\<guillemotright> s))"
      by(simp add:ac_simps)
    also have "... \<le>
          (\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + \<guillemotleft> G \<guillemotright> s * wp body (t Q) s \<ominus> \<guillemotleft>G\<guillemotright> s) +
           ((1 - \<guillemotleft> G \<guillemotright> s) * P s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s \<ominus> (1 - \<guillemotleft>G\<guillemotright> s))"
      by(rule tminus_add_mono)
    also have "... =
          \<guillemotleft> G \<guillemotright> s * (wlp body (u P) s + wp body (t Q) s \<ominus> 1) +
           (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)"
       by(simp add:tminus_left_distrib distrib_left)
    also {
      from uP uQ ft uu
      have "wlp body (u P) && wp body (t Q) \<tturnstile> wp body (u P && t Q)"
        by(auto intro:sub_distrib_pconjD[OF sdp_body])
      also from IH unitary_sound[OF uP] unitary_sound[OF uQ] ft
                   unitary_sound[OF uu[OF uP]]
      have "\<dots> \<le> wp body (t (P && Q))"
        by(blast intro!:mono_transD[OF healthy_monoD, OF hwp] exp_conj_sound)
      finally have "wlp body (u P) s + wp body (t Q) s \<ominus> 1 \<le>
                    wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s"
        by(auto simp:exp_conj_def pconj_def)
      hence "\<guillemotleft> G \<guillemotright> s * (wlp body (u P) s + wp body (t Q) s \<ominus> 1) +
             (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1) \<le>
             \<guillemotleft> G \<guillemotright> s * wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s +
             (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)"
        by(auto intro:add_right_mono mult_left_mono)
    }
    finally
    show "\<guillemotleft> G \<guillemotright> s * wlp body (u P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s +
          (\<guillemotleft> G \<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft> G \<guillemotright> s) * Q s) \<ominus> 1 \<le>
          \<guillemotleft> G \<guillemotright> s * wp body (t (\<lambda>s. P s + Q s \<ominus> 1)) s +
          (1 - \<guillemotleft> G \<guillemotright> s) * (P s + Q s \<ominus> 1)" .
  qed
next
  fix P Q::"'s expect" and t t' u u'::"'s trans"
  assume "unitary P" "unitary Q"
         "equiv_trans t t'" "equiv_utrans u u'"
         "u P && t Q \<tturnstile> t (P && Q)"
  thus "u' P && t' Q \<tturnstile> t' (P && Q)"
    by(simp add:equiv_transD unitary_sound equiv_utransD exp_conj_unitary)
qed

lemmas sdp_intros =
  sdp_Abort  sdp_Skip  sdp_Apply
  sdp_Seq    sdp_DC    sdp_PC
  sdp_SetPC  sdp_SetDC sdp_Embed
  sdp_repeat sdp_Bind  sdp_loop

subsection {* The Well-Defined Predicate. *}

definition
  well_def :: "'s prog \<Rightarrow> bool"
where
  "well_def prog \<equiv> healthy (wp prog) \<and> nearly_healthy (wlp prog)
                 \<and> wp_under_wlp prog \<and> sub_distrib_pconj prog
                 \<and> sublinear (wp prog) \<and> bd_cts (wp prog)"

lemma well_defI[intro]:
  "\<lbrakk> healthy (wp prog); nearly_healthy (wlp prog);
     wp_under_wlp prog; sub_distrib_pconj prog; sublinear (wp prog);
     bd_cts (wp prog) \<rbrakk> \<Longrightarrow>
   well_def prog"
  unfolding well_def_def by(simp)

lemma well_def_wp_healthy[dest]:
  "well_def prog \<Longrightarrow> healthy (wp prog)"
  unfolding well_def_def by(simp)

lemma well_def_wlp_nearly_healthy[dest]:
  "well_def prog \<Longrightarrow> nearly_healthy (wlp prog)"
  unfolding well_def_def by(simp)

lemma well_def_wp_under[dest]:
  "well_def prog \<Longrightarrow> wp_under_wlp prog"
  unfolding well_def_def by(simp)

lemma well_def_sdp[dest]:
  "well_def prog \<Longrightarrow> sub_distrib_pconj prog"
  unfolding well_def_def by(simp)

lemma well_def_wp_sublinear[dest]:
  "well_def prog \<Longrightarrow> sublinear (wp prog)"
  unfolding well_def_def by(simp)

lemma well_def_wp_cts[dest]:
  "well_def prog \<Longrightarrow> bd_cts (wp prog)"
  unfolding well_def_def by(simp)

lemmas wd_dests =
  well_def_wp_healthy well_def_wlp_nearly_healthy
  well_def_wp_under well_def_sdp
  well_def_wp_sublinear well_def_wp_cts

lemma wd_Abort:
  "well_def Abort"
  by(blast intro:healthy_wp_Abort nearly_healthy_wlp_Abort
                 wp_under_wlp_Abort sdp_Abort sublinear_wp_Abort
                 cts_wp_Abort)

lemma wd_Skip:
  "well_def Skip"
  by(blast intro:healthy_wp_Skip nearly_healthy_wlp_Skip
                 wp_under_wlp_Skip sdp_Skip sublinear_wp_Skip
                 cts_wp_Skip)

lemma wd_Apply:
  "well_def (Apply f)"
  by(blast intro:healthy_wp_Apply nearly_healthy_wlp_Apply
                 wp_under_wlp_Apply sdp_Apply sublinear_wp_Apply
                 cts_wp_Apply)

lemma wd_Seq:
  "\<lbrakk> well_def a; well_def b \<rbrakk> \<Longrightarrow> well_def (a ;; b)"
  by(blast intro:healthy_wp_Seq nearly_healthy_wlp_Seq
                 wp_under_wlp_Seq sdp_Seq sublinear_wp_Seq
                 cts_wp_Seq)

lemma wd_PC:
  "\<lbrakk> well_def a; well_def b; unitary P \<rbrakk> \<Longrightarrow> well_def (a \<^bsub>P\<^esub>\<oplus> b)"
  by(blast intro:healthy_wp_PC nearly_healthy_wlp_PC
                 wp_under_wlp_PC sdp_PC sublinear_wp_PC
                 cts_wp_PC)

lemma wd_DC:
  "\<lbrakk> well_def a; well_def b \<rbrakk> \<Longrightarrow> well_def (a \<Sqinter> b)"
  by(blast intro:healthy_wp_DC nearly_healthy_wlp_DC
                 wp_under_wlp_DC sdp_DC sublinear_wp_DC
                 cts_wp_DC)

lemma wd_SetDC:
  "\<lbrakk> \<And>x s. x \<in> S s \<Longrightarrow> well_def (a x); \<And>s. S s \<noteq> {};
     \<And>s. finite (S s) \<rbrakk> \<Longrightarrow> well_def (SetDC a S)"
  by(iprover intro:well_defI healthy_wp_SetDC nearly_healthy_wlp_SetDC
                   wp_under_wlp_SetDC sdp_SetDC sublinear_wp_SetDC cts_wp_SetDC
                   nonempty_witness
             dest:wd_dests)

lemma wd_SetPC:
  "\<lbrakk> \<And>x s. x \<in> (supp (p s)) \<Longrightarrow> well_def (a x); \<And>s. unitary (p s); \<And>s. finite (supp (p s));
     \<And>s. setsum (p s) (supp (p s)) \<le> 1 \<rbrakk> \<Longrightarrow> well_def (SetPC a p)"
  by(iprover intro!:well_defI healthy_wp_SetPC nearly_healthy_wlp_SetPC
                    wp_under_wlp_SetPC sdp_SetPC sublinear_wp_SetPC cts_wp_SetPC
             dest:wd_dests unitary_sound sound_nneg[OF unitary_sound] nnegD)

lemma wd_Embed:
  fixes t::"'s trans"
  assumes ht: "healthy t" and st: "sublinear t" and ct: "bd_cts t"
  shows "well_def (Embed t)"
proof(intro well_defI)
  from ht show "healthy (wp (Embed t))" "nearly_healthy (wlp (Embed t))"
    by(simp add:wp_def wlp_def Embed_def healthy_nearly_healthy)+
  from st show "sublinear (wp (Embed t))" by(simp add:wp_def Embed_def)
  show "wp_under_wlp (Embed t)" by(simp add:wp_under_wlp_def wp_eval)
  show "sub_distrib_pconj (Embed t)"
    by(rule sub_distrib_pconjI,
       auto intro:le_funI[OF sublinearD[OF st, where a=1 and b=1 and c=1, simplified]]
            simp:exp_conj_def pconj_def wp_def wlp_def Embed_def)
  from ct show "bd_cts (wp (Embed t))"
    by(simp add:wp_def Embed_def)
qed

lemma wd_repeat:
  "well_def a \<Longrightarrow> well_def (repeat n a)"
  by(blast intro:healthy_wp_repeat nearly_healthy_wlp_repeat
                 wp_under_wlp_repeat sdp_repeat sublinear_wp_repeat cts_wp_repeat)

lemma wd_Bind:
  "\<lbrakk> \<And>s. well_def (a (f s)) \<rbrakk> \<Longrightarrow> well_def (Bind f a)"
  by(blast intro:healthy_wp_Bind nearly_healthy_wlp_Bind
                 wp_under_wlp_Bind sdp_Bind sublinear_wp_Bind cts_wp_Bind)

lemma wd_loop:
  "well_def body \<Longrightarrow> well_def (do G \<longrightarrow> body od)"
  by(blast intro:healthy_wp_loop nearly_healthy_wlp_loop
                 wp_under_wlp_loop sdp_loop sublinear_wp_loop cts_wp_loop)

lemmas wd_intros =
  wd_Abort wd_Skip   wd_Apply
  wd_Embed wd_Seq    wd_PC
  wd_DC    wd_SetPC  wd_SetDC
  wd_Bind  wd_repeat wd_loop

end


theory "LaunchburyCombined-Unstack"
imports LaunchburyCombined LaunchburyCombinedTaggedMap
begin

subsubsection {* Stacked evaluation implies original evaluation. *}

nominal_primrec convert_stack_elem  :: "exp \<Rightarrow> var list" where
  "convert_stack_elem (Var x) = [x]" |
  "convert_stack_elem (App e x) = [x]" |
  "convert_stack_elem (Lam [x]. e) = []" |
  "convert_stack_elem (Let as e) = []"
  unfolding convert_stack_elem_graph_def convert_stack_elem_graph_aux_def eqvt_def
  apply (rule, simp)
  apply rule
  apply (metis exp_assn.exhaust(1))
  apply auto
  done
termination (eqvt) by lexicographic_order

fun convert_stack :: "'a f\<rightharpoonup> exp \<Rightarrow> 'a list \<Rightarrow> var list" where
  "convert_stack \<Gamma> [] = []" |
  "convert_stack \<Gamma> (x#xs) = (if x \<in> fdom \<Gamma> then convert_stack_elem (\<Gamma> f! x) else []) @ convert_stack \<Gamma> xs"

lemma fresh_convert_stack_subset:
  fixes S :: "('a::fs) list"
  shows "a \<sharp> \<Gamma> \<Longrightarrow> a \<sharp> convert_stack \<Gamma> S"
  by (induction S)
     (auto simp add: fresh_Nil fresh_append fresh_lookup_fdom eqvt_fresh_cong1[OF convert_stack_elem.eqvt])

lemma convert_stack_upd_not_there[simp]:
  assumes "x \<notin> set S"
  shows "convert_stack (\<Gamma>(x f\<mapsto> e)) S = convert_stack \<Gamma> S"
using assms by (induction S) auto

lemma convert_stack_delete_not_there[simp]:
  assumes "x \<notin> set S"
  shows "convert_stack (fmap_delete x \<Gamma>) S = convert_stack \<Gamma> S"
using assms by (induction S) auto

lemma convert_stack_fun_merge_not_there[simp]:
  assumes "fdom m \<inter> set S = {}"
  shows "convert_stack (\<Gamma> f++ m) S = convert_stack \<Gamma> S"
using assms by (induction S) auto

(* Not really semantically correct, but might be a nice trick. *)
lemma convert_stack_app_to_var[simp]:
  "convert_stack (\<Gamma>(x f\<mapsto> App e y)) S =  convert_stack (\<Gamma>(x f\<mapsto> Var y)) S"
by (induction S, case_tac [2] "a = x") auto

lemma convert_stack_subset:
  assumes "\<Gamma> \<Down>\<^sup>\<times>\<^sup>u\<^sup>\<surd>\<^bsub>x#S\<^esub> \<Delta>"
  assumes "x \<notin> set S"
  assumes "set S \<subseteq> fdom \<Gamma>"
  shows "convert_stack \<Delta> S = convert_stack \<Gamma> S"
  using stack_unchanged[OF assms(1), simplified] reds_doesnt_forget[OF assms(1)] assms(2)
  by (induction S) (auto simp add: fdomIff)

lemma forget_stack_BH:
  assumes "\<Gamma> \<Down>\<^sup>\<times>\<^sup>u\<^sup>\<surd>\<^bsub>S\<^esub> \<Delta>"
  assumes "distinct S"
  assumes "set S \<subseteq> fdom \<Gamma>"
  shows "\<Gamma> f|` (-set S) : \<Gamma> f! hd S \<Down>\<^sup>\<times>\<^sup>\<surd>\<^bsub>convert_stack \<Gamma> (tl S)\<^esub> \<Delta> f|` (-set S) : \<Delta> f! hd S"
using assms
proof (nominal_induct \<Gamma> \<times> u \<surd> S \<Delta>  rule: LaunchburyCombinedTaggedMap.reds.strong_induct)
case Lambda
  show ?case by (auto intro: LambdaI)
next
case (Application n \<Gamma> x e y S z \<Delta> \<Theta> e' u)

  note `lookup \<Delta> n = Some (Lam [z]. e')`[simp]

  from `atom n \<sharp> \<Gamma>` have "n \<notin> fdom \<Gamma>" by (metis fresh_fdom)
  hence [simp]: "\<Gamma> f|` (- insert n (insert x  (set S))) = \<Gamma> f|` (- insert x  (set S))" by auto
  from `atom n \<sharp> x` have [simp]: "x \<noteq> n" by (metis not_self_fresh)

  have [simp]: "z \<noteq> n" by (metis (mono_tags) Application.hyps(11) Application.hyps(15) fresh_fdom hd.simps stack_bound)

  have [simp]: "fmap_delete n \<Delta> f|` (- insert x (set S)) = \<Delta> f|` (- insert n (insert x (set S)))" by auto

  have [simp]: "n \<notin> set S" by (metis Application.hyps(5) fresh_at_base_list)

  have [simp]: "\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e) f|` insert x (set S) = \<Gamma>(x f\<mapsto> App (Var n) y) f|` insert x (set S)"
    apply (rule fmap_eqI)
    apply auto
    apply (case_tac "xa = x \<or> xa = n")
    apply auto
    done

  from `distinct (x # S)` have [simp]: "x \<notin> set S" "distinct S" by simp_all

  let ?S' = "convert_stack \<Gamma> S"

  have "distinct (n # x # S)" using `x \<noteq> n` by (simp del: `x \<noteq> n`)
  from Application.hyps(16)[OF this] Application.prems(2)
  have hyp1: "\<Gamma> f|` (- insert x (set S)) : e \<Down>\<^sup>\<times>\<^sup>\<surd>\<^bsub>y#?S'\<^esub> \<Delta> f|` (- insert n (insert x (set S))) : Lam [z]. e'"
    by auto

  from reds_doesnt_forget[OF Application.hyps(15)]
  have [simp]: "x \<in> fdom \<Delta>" by simp

  from stack_unchanged[OF Application.hyps(15), where x = x]
  have [simp]: "\<Delta> f! x = App (Var n) y" by simp

  have "n \<notin> set (x # S)" using `x \<noteq> n` by (simp del: `x \<noteq> n`)

  from Application.prems(2)
  have prem2: "set (x # S) \<subseteq> fdom (\<Gamma>(x f\<mapsto> App (Var n) y)(n f\<mapsto> e))" by auto
  from  convert_stack_subset[OF Application.hyps(15) `n \<notin> set (x #S)` this]
  have [simp]: "convert_stack \<Delta> S = convert_stack \<Gamma> S" by simp

  from Application.prems(2) reds_doesnt_forget[OF Application.hyps(15)]
  have "set (x # S) \<subseteq> fdom (fmap_delete n \<Delta>(x f\<mapsto> e'[z::=y]))" by auto

  from Application.hyps(18)[OF Application.prems(1) this]
  have hyp2': "\<Delta> f|` (- insert n (insert x (set S))) : e'[z::=y] \<Down>\<^sup>\<times>\<^sup>\<surd>\<^bsub>?S'\<^esub> \<Theta> f|` (- insert x (set S)) : \<Theta> f! x"
    by simp

  have "x \<in> fdom \<Theta>" by (metis LaunchburyCombinedTaggedMap.reds_doesnt_forget[OF Application.hyps(17)] fmap_upd_fdom insert_subset)

  have "\<Gamma> f|` (- insert x (set S)) : App e y \<Down>\<^sup>\<times>\<^sup>\<surd>\<^bsub>?S'\<^esub> \<Theta> f|` (- insert x (set S)) : \<Theta> f! x"
    apply (rule LaunchburyCombined.reds.Application[OF _ hyp1 hyp2'])
    using Application(1,2,6-12) `x \<in> fdom \<Theta>`
    by (auto simp add: fresh_Pair fresh_fmap_restr_subset fresh_convert_stack_subset fresh_fmap_upd_eq fresh_fmap_delete_subset fresh_lookup_fdom)
  thus ?case by simp
next
case (Variable y x S \<Gamma> \<Delta>)
  from `y \<notin> set (x # S)`
  have [simp]: "y \<noteq> x" and [simp]: "y \<notin> set S" by simp_all

  from stack_head_there[OF Variable.hyps(3)]
  have [simp]: "y \<in> fdom \<Gamma>" by simp
  from stack_bound[OF Variable.hyps(3)]
  have "y \<in> fdom \<Delta>" by simp

  have [simp]: "(\<Delta> f|` (- insert y (insert x (set S))))(y f\<mapsto> \<Delta> f! y) = \<Delta> f|` (- insert x (set S))"
    apply (rule fmap_eqI)
    apply simp
    apply (rule subset_antisym)
    apply rule
    apply (case_tac "xa = x") (* auto does something wrong here *)
    using `y \<in> fdom \<Delta>` Variable(1)
    apply auto
    done

  have [simp]: "\<Gamma> f|` (- insert y (insert x (set S))) = fmap_delete y (\<Gamma> f|` (- insert x (set S)))"
    by auto

  from `distinct (x # S)` have [simp]: "x \<notin> set S" "distinct S" by simp_all

  thm Variable.hyps(4)
  let ?S' = "convert_stack \<Gamma> S"

  have "distinct (y # x # S)" by simp
  from Variable.hyps(4)[OF this] Variable.prems(2)
  have hyp: "fmap_delete y (\<Gamma> f|` (- insert x (set S))) : \<Gamma> f! y \<Down>\<^bsub>y#?S'\<^esub> \<Delta> f|` (- insert y (insert x (set S))) : \<Delta> f! y"
    by auto

  have "\<Gamma> f|` (- insert x (set S)) : Var y \<Down>\<^bsub>?S'\<^esub> \<Delta> f|` (- insert x (set S)) : \<Delta> f! y"
    apply (rule LaunchburyCombined.reds.Variable[OF _ hyp, simplified])
    using Variable(1) `y \<in> fdom \<Gamma>`
    apply auto
    by (metis `y \<in> fdom \<Gamma>` fdomIff option.exhaust the.simps)
  thus ?case by simp
next
case (Let as \<Gamma> x S body u \<Delta>)
  note `x \<notin> fdom \<Gamma>`[simp]

  from `distinct (x # S)` have [simp]: "x \<notin> set S" "distinct S" by simp_all

  from Let(2)
  have [simp]: "x \<notin> fdom (fmap_of (asToHeap as))"
    unfolding fdom_fmap_of_conv_heapVars set_bn_to_atom_heapVars fresh_star_def
    by auto

  have disj[simp]: "fdom (fmap_of (asToHeap as)) \<inter> set S = {}"
    by (metis fresh_star_list_distinct set_bn_to_atom_fdom Let.hyps(3) inf_commute)

  have [simp]: "(\<Gamma>(x f\<mapsto> body) f++ fmap_of (asToHeap as)) f|` (- insert x (set S))
   = (\<Gamma>(x f\<mapsto> body) f|` (- insert x (set S)))  f++ fmap_of (asToHeap as)"
   apply (auto simp add: fmap_restr_add intro: )
   apply (rule arg_cong[OF fmap_restr_useless])
   by (metis (full_types) Int_commute Int_insert_left LaunchburyCombinedTaggedMap.fdom_fmap_of_conv_heapVars `x \<notin> fdom (fmap_of (asToHeap as))` disj disjoint_eq_subset_Compl)

  let ?S' = "convert_stack \<Gamma> S"

  from  Let.hyps(6)[OF Let.prems(1)] Let.prems(2)
  have hyp: "(\<Gamma> f|` (- insert x (set S)))  f++ fmap_of (asToHeap as) : body \<Down>\<^bsub>?S'\<^esub> \<Delta> f|` (- insert x (set S)) : \<Delta> f! x"
    by auto

  have "\<Gamma> f|` (- insert x (set S)) : Terms.Let as body \<Down>\<^bsub>?S'\<^esub> \<Delta> f|` (- insert x (set S)) : \<Delta> f! x"
    apply (rule LaunchburyCombined.reds.Let[OF _  hyp])
    using Let(1)
    apply (auto simp add: fresh_star_Pair)
    apply (auto simp add: fresh_star_def fresh_fmap_restr_subset) [1]
    using Let(1,2,3)
    apply (auto simp add: fresh_star_def fresh_convert_stack_subset)
    done
  thus ?case by simp
qed

subsubsection {* Original evaluation implies stacked evaluation. *}

lemma add_stack:
  assumes "\<Gamma> : e \<Down>\<^sup>\<times>\<^sup>b\<^bsub>L\<^esub> \<Delta> : z"
  assumes "x \<in> set L"
  assumes "supp \<Gamma>' \<subseteq> supp L"
  shows "(\<Gamma> f++ \<Gamma>')(x f\<mapsto> e)  \<Down>\<^sup>\<times>\<^sup>u\<^sup>b\<^bsub>S\<^esub> (\<Delta> f++ \<Gamma>')(x f\<mapsto> e') "
using assms
proof (nominal_induct avoiding: \<Gamma>' x rule: reds_with_n_strong_induct)
case (Lambda \<Gamma> xa e L \<Gamma>')
  show ?case
    by (auto intro: LaunchburyStacked.reds.intros)
next
case (Application y \<Gamma> e xa L \<Delta> \<Theta> z n e' \<Gamma>' x)
  have fresh_n: "atom n \<sharp> (\<Gamma>, \<Gamma>', \<Delta>, \<Gamma>', x, e, xa, \<Theta>, (x, z) # \<Gamma>', y)"
    using Application
    by (simp add: fresh_Pair fresh_Cons fresh_at_base)

  have fresh_y: "atom y \<sharp> (\<Gamma>, \<Gamma>', \<Delta>, \<Gamma>', x, e, xa, \<Theta>, (x, z) # \<Gamma>')"
    using Application
    by (simp add: fresh_Pair fresh_Cons)

  have "supp ((x, App (Var n) xa) # \<Gamma>') \<subseteq> supp (n # xa # L)"
     using set_mp[OF supp_set_mem[OF `x \<in> set L`]] set_mp[OF `supp \<Gamma>' \<subseteq> supp L`]
     by (auto simp add: supp_Pair supp_Cons exp_assn.supp)
  hence hyp1: "\<Gamma> : (n, e) # (x, App (Var n) xa) # \<Gamma>' \<Down> \<Delta> : (n, Lam [y]. e') # (x, App (Var n) xa) # \<Gamma>'"
    apply (rule Application(21)[rotated])
    apply simp
    done

  have hyp2: "\<Delta> : (x, e'[y::=xa]) # \<Gamma>' \<Down> \<Theta> : (x, z) # \<Gamma>'"
    apply (rule Application(23)[OF Application.prems])
    done

  show ?case
    by (rule LaunchburyStacked.reds.Application[OF fresh_n fresh_y hyp1 hyp2])
next
case (Variable x e \<Gamma> L \<Delta> z \<Gamma>' xa)
  have "supp ((xa, Var x) # \<Gamma>') \<subseteq> supp (x # L)"
     using set_mp[OF supp_set_mem[OF `xa \<in> set L`]] set_mp[OF `supp \<Gamma>' \<subseteq> supp L`]
     by (auto simp add: supp_Pair supp_Cons exp_assn.supp)
  hence hyp: "delete x \<Gamma> : (x, e) # (xa, Var x) # \<Gamma>' \<Down> \<Delta> : (x, z) # (xa, Var x) # \<Gamma>'"
    apply (rule Variable.hyps(3)[rotated])
    apply (simp)
    done
  show ?case
    by (rule LaunchburyStacked.reds.Variable[OF `(x,e) \<in> set _` hyp])
next
case (Let as \<Gamma> L body \<Delta> z \<Gamma>' x)
  from `x \<in> set L` and `_ \<sharp>* L`
  have [simp]:"set (bn as) \<sharp>* x"
    by (metis fresh_star_Cons fresh_star_list(1) in_set_conv_decomp)

  from `supp \<Gamma>' \<subseteq> supp L` and `_ \<sharp>* L`
  have [simp]:"set (bn as) \<sharp>* \<Gamma>'"
    by (auto simp add: fresh_star_def fresh_def)

  have fresh: "set (bn as) \<sharp>* (\<Gamma>, x, \<Gamma>')"
    using Let(1-3)
    by (simp add: fresh_star_Pair)

  have hyp: "asToHeap as @ \<Gamma> : (x, body) # \<Gamma>' \<Down> \<Delta> : (x, z) # \<Gamma>'"
    by (rule Let.hyps(4)[OF Let.prems])

  show ?case
    by (rule LaunchburyStacked.reds.Let[OF fresh hyp])
qed

end


theory Dynamic_Programming
  imports Main "~~/src/HOL/Library/State_Monad"
begin

type_synonym ('s, 'a) state = "'s \<Rightarrow> ('a \<times> 's)"
type_synonym ('param, 'result) dpstate = "('param \<rightharpoonup> 'result, 'result) state"
type_synonym ('param, 'result) dpfun = "'param \<Rightarrow> ('param, 'result) dpstate"

definition return :: "'a \<Rightarrow> ('s, 'a) state" ("\<langle>_\<rangle>") where
  "\<langle>x\<rangle> = (\<lambda>M. (x, M))"
fun get :: "('s, 's) state" where
  "get M = (M, M)"
fun put :: "'s \<Rightarrow> ('s, unit) state" where
  "put M _ = ((), M)"

fun update :: "'param \<Rightarrow> ('param, 'result) dpstate \<Rightarrow> ('param, 'result) dpstate" where
  "update params calcVal = exec {
    v \<leftarrow> calcVal;
    M' \<leftarrow> get;
    _ \<leftarrow> put (M'(params\<mapsto>v));
    \<langle>v\<rangle>
  }"

fun checkmem :: "'param \<Rightarrow> ('param, 'result) dpstate \<Rightarrow> ('param, 'result) dpstate" where
  "checkmem params calcVal = exec {
    M \<leftarrow> get;
    case M params of
      Some v => \<langle>v\<rangle> |
      None => update params calcVal
    }"

definition lift_fun_app :: "('M,'a\<Rightarrow>'b) state \<Rightarrow> ('M,'a) state \<Rightarrow> ('M,'b) state" (infixl "." 51) where
  "lift_fun_app sf sv \<equiv> exec {f \<leftarrow> sf; v \<leftarrow> sv; \<langle>f v\<rangle>}"

lemma lift_fun_appE:
  assumes "(sf . sv) M = (v', M')"
  obtains f M'' v where "sf M = (f,M'')" and "sv M'' = (v,M')" and "v' = f v"
    using assms unfolding lift_fun_app_def return_def by (auto split: prod.splits)

primrec fold\<^sub>s :: "('M,'a \<Rightarrow> 'b \<Rightarrow> 'b) state \<Rightarrow> ('M,'a) state list \<Rightarrow> ('M,'b) state \<Rightarrow> ('M,'b) state" where
fold\<^sub>s_Nil:  "fold\<^sub>s f [] init = init" |
fold\<^sub>s_Cons: "fold\<^sub>s f (x # xs) init = fold\<^sub>s f xs (f . x . init)"

definition consistentM :: "('param \<Rightarrow> 'result) \<Rightarrow> ('param \<rightharpoonup> 'result) \<Rightarrow> bool" where
  "consistentM f M \<equiv> \<forall>param\<in>dom M. M param = Some (f param)"

lemma consistentM_I:
  assumes "\<And>param v. M param = Some v \<Longrightarrow> v = f param"
  shows "consistentM f M"
  using assms unfolding consistentM_def by auto

lemma consistentM_D:
  assumes "consistentM f M"
  shows "M param = Some v \<Longrightarrow> v = f param"
  using assms by (auto simp: consistentM_def dom_def)

definition consistentS :: "('param \<Rightarrow> 'result) \<Rightarrow> 'a \<Rightarrow> ('param\<rightharpoonup>'result, 'a) state \<Rightarrow> bool" where
  "consistentS f v s \<equiv> \<forall>M. consistentM f M \<longrightarrow> fst (s M) = v \<and> consistentM f (snd (s M))"

lemma consistentS_I:
  assumes "\<And>M v' M'. \<lbrakk>consistentM f M; s M = (v',M')\<rbrakk> \<Longrightarrow> v'=v \<and> consistentM f M'"
  shows "consistentS f v s"
  by (auto simp: consistentS_def intro!: assms)

lemma consistentS_D:
  assumes "consistentS f v s" "consistentM f M" "s M = (v',M')"
  shows consistentS_D1:"v'=v" and consistentS_D2:"consistentM f M'"
  using assms by(fastforce simp: consistentS_def)+

definition consistentDF :: "('param \<Rightarrow> 'result) \<Rightarrow> ('param, 'result) dpfun \<Rightarrow> bool" where
  "consistentDF f d \<equiv> \<forall>param. consistentS f (f param) (d param)"

lemma consistentDF_I:
  assumes "\<And>param. consistentS f (f param) (d param)"
  shows "consistentDF f d"
  by (auto simp: consistentDF_def intro!: assms)

lemma consistent_lift:
  assumes "consistentS dp f f'" "consistentS dp v v'"
  shows "consistentS dp (f v) (f' . v')" (is ?case)
  using assms by (auto intro!: consistentS_I elim!: lift_fun_appE dest: consistentS_D)

lemma consistentM_upd: "consistentM f M \<Longrightarrow> v = f param \<Longrightarrow> consistentM f (M(param\<mapsto>v))"
  unfolding consistentM_def by auto

lemma consistent_checkmem:
  assumes "consistentS f v s" "v = f param"
  shows "consistentS f v (checkmem param s)"
  apply (rule consistentS_I)
  using assms by (auto split: option.splits prod.splits simp: return_def intro: consistentM_upd dest: consistentS_D consistentM_D)

lemma consistentS_return:
  "sv = \<langle>v\<rangle> \<Longrightarrow> consistentS dp v sv"
  unfolding consistentS_def return_def by simp

text \<open>Generalized version of your fold lemma\<close>
lemma consistent_fold:
  assumes
    "consistentS dp init init'"
    "list_all2 (consistentS dp) xs xs'"
    "f' = \<langle>f\<rangle>"
  shows
    "consistentS dp (fold f xs init) (fold\<^sub>s f' xs' init')"
  using assms(2,1,3)
  by (induction arbitrary: init init' rule: list_all2_induct)
     (fastforce simp: assms(3) dest!: consistentS_return consistent_lift)+

lemma consistent_fold':
  "\<lbrakk>consistentS dp init init';
    \<And>i. i\<in>set idx \<Longrightarrow> consistentS dp (ls i) (ls' i);
    f' = \<langle>f\<rangle>\<rbrakk> \<Longrightarrow>
   consistentS dp (fold f (map ls idx) init) (fold\<^sub>s f' (map ls' idx) init')"
  apply (rule consistent_fold)
    apply assumption
  by (induction idx) auto

context
  includes lifting_syntax
begin

lemma consistent_binary_transfer:
  "(consistentS f ===> consistentS f ===> consistentS f) g (lift_binary g)"
  by (auto simp: rel_fun_def intro: consistent_binary)

lemma consistent_fold_alt:
  assumes
    "consistentS dp init init'"
    "list_all2 (consistentS dp) xs xs'"
  shows
    "consistentS dp (fold f xs init) (fold (lift_binary f) xs' init')"
  supply [transfer_rule] = consistent_binary_transfer assms
  by transfer_prover

text \<open>
  We could prove a stronger version of this lemma by replacing @{term "op ="}
  by another relation.
\<close>
lemma consistent_fold_map:
  "\<lbrakk>consistentS dp init init';
    (op = ===> consistentS dp) ls ls';
    f' = lift_binary f\<rbrakk> \<Longrightarrow>
   consistentS dp (fold f (map ls idx) init) (fold f' (map ls' idx) init')"
  apply (rule consistent_fold)
    apply assumption
  subgoal premises prems
    supply [transfer_rule] = prems
    by transfer_prover
  .

text \<open>And finally a 'big-bang version' of the last two proofs combined.\<close>
lemma consistent_fold_map_alt:
  assumes
    "consistentS dp init init'"
    "(op = ===> consistentS dp) ls ls'"
  shows
    "consistentS dp (fold f (map ls idx) init) (fold (lift_binary f) (map ls' idx) init')"
  supply [transfer_rule] = consistent_binary_transfer assms
  by transfer_prover

lemma consistent_cond_alt:
  assumes "consistentS dp v0 s0" "consistentS dp v1 s1"
  shows "consistentS dp (if b then v0 else v1) (if b then s0 else s1)"
  supply [transfer_rule] = assms
  by transfer_prover

text \<open>
  Conclusion: the default parametricity rules for \<open>map\<close> and \<open>if _ then _ else\<close> are too weak.
  Fold works out of the box.
\<close>

end (* End of lifting syntax *)

lemma consistent_cond:
  assumes "b \<Longrightarrow> consistentS dp v0 s0" "\<not>b \<Longrightarrow> consistentS dp v1 s1"
  shows "consistentS dp (if b then v0 else v1) (if b then s0 else s1)"
  using assms by auto

lemmas consistency_rules =
  consistent_cond consistent_fold' consistent_max consistent_plus consistent_checkmem'
  consistentS_return

(* Fib *)

fun fib :: "nat \<Rightarrow> nat" where
"fib 0 = 0" |
"fib (Suc 0) = 1" |
"fib (Suc(Suc n)) = (op +) (fib (Suc n)) (fib n)"

fun fib' fib'' :: "(nat, nat) dpfun" where
  "fib' param = checkmem param (fib'' param)" |
  "fib'' 0 = \<langle>0\<rangle>" |
  "fib'' (Suc 0) = \<langle>1\<rangle>" |
  "fib'' (Suc (Suc n)) = \<langle>op +\<rangle> . fib' (Suc n) . fib' n"

lemma "consistentDF fib fib'"
  unfolding consistentDF_def
  apply (rule allI)
  apply (induct_tac param rule: fib.induct)

    apply (simp only: fib'.simps fib''.simps fib.simps)
    apply (assumption | rule consistency_rules)+
    apply (simp_all only: fib.simps)

   apply (simp only: fib'.simps fib''.simps fib.simps)
   apply (assumption | rule consistency_rules)+
   apply (simp_all only: fib.simps)

  apply (simp only: fib'.simps fib''.simps fib.simps)
  apply (assumption | rule consistency_rules)+
  apply (simp_all only: fib.simps)
  done

(* Bellman Ford *)

context
  fixes W :: "nat \<Rightarrow> nat \<Rightarrow> int"
    and n :: nat
begin

text \<open>Could also be primrec\<close>
text \<open>Dimensionality as parameter\<close>

fun bf :: "(nat\<times>nat) \<Rightarrow> int" where
  "bf (0, j) = W 0 j" |
  "bf (Suc k, j) = fold min [bf (k, i) + W i j. i\<leftarrow>[0..<n]] (bf (k, j))"

fun bf' bf'' :: "(nat\<times>nat, int) dpfun" where
  "bf' params = checkmem params (bf'' params)" |
  "bf'' (0, j) = \<langle>W 0 j\<rangle>" |
  "bf'' (Suc k, j) = fold min\<^sub>s [bf' (k, i) +\<^sub>s \<langle>W i j\<rangle>. i\<leftarrow>[0..<n]] (bf' (k, j))"

lemma "consistentDF bf bf'"
  apply (unfold consistentDF_def, rule allI, induct_tac rule: bf.induct)
   apply (simp only: bf.simps bf'.simps bf''.simps)
   apply (assumption | rule consistency_rules)+
   apply (simp only: bf.simps)

  apply (simp only: bf.simps bf'.simps bf''.simps)
    apply (assumption | rule consistency_rules)+
   apply (simp only: min\<^sub>s_def)
  apply (simp only: bf.simps)
  done

end

text \<open>Not primrec\<close>
text \<open>Dimensionality given by i, j\<close>
fun ed :: "(nat\<times>nat) \<Rightarrow> nat" where
  "ed (0, 0) = 0" |
  "ed (0, Suc j) = Suc j" |
  "ed (Suc i, 0) = Suc i" |
  "ed (Suc i, Suc j) = min (ed (i, j) + 2) (min (ed (Suc i, j) + 1) (ed (i, Suc j) + 1))"

fun ed' ed''  :: "(nat\<times>nat, nat) dpfun" where
  "ed' params = checkmem params (ed'' params)" |
  "ed'' (0, 0) = \<langle>0\<rangle>" |
  "ed'' (0, Suc j) = \<langle>Suc j\<rangle>" |
  "ed'' (Suc i, 0) = \<langle>Suc i\<rangle>" |
  "ed'' (Suc i, Suc j) = min\<^sub>s (ed' (i, j) +\<^sub>s \<langle>2\<rangle>) (min\<^sub>s (ed' (Suc i, j) +\<^sub>s \<langle>1\<rangle>) (ed' (i, Suc j) +\<^sub>s \<langle>1\<rangle>))"
thm minus_nat_inst.minus_nat

lemma "consistentDF ed ed'"
  by (unfold consistentDF_def, rule allI, induct_tac rule: ed.induct)
     (auto simp only: ed.simps ed'.simps ed''.simps intro!: consistent_checkmem' consistentS_return consistent_min consistent_plus)

term "(a :: nat) - (b :: nat)"

context
  fixes w :: "nat \<Rightarrow> nat"
begin

fun su :: "(nat\<times>nat) \<Rightarrow> nat" where
  "su (0, W) = (if W < w 0 then 0 else w 0)" |
  "su (Suc i, W) = (if W < w (Suc i)
    then su (i, W)
    else max (su (i, W)) (w i + su (i, W - w i)))"

fun su' su'' :: "(nat\<times>nat, nat) dpfun" where
  "su' params = checkmem params (su'' params)" |
  "su'' (0, W) = (if W < w 0 then \<langle>0\<rangle> else \<langle>w 0\<rangle>)" |
  "su'' (Suc i, W) = (if W < w (Suc i)
    then su' (i, W)
    else max\<^sub>s (su' (i, W)) (\<langle>w i\<rangle> +\<^sub>s su' (i, W - w i)))"

lemma "consistentDF su su'"
  apply (unfold consistentDF_def, rule allI, induct_tac rule: su.induct)
   apply (simp only: su.simps su'.simps su''.simps)
   apply (assumption | rule consistency_rules)+
   apply (simp only: su.simps)

  apply (simp only: su.simps su'.simps su''.simps)
  apply (assumption | rule consistency_rules)+
  apply (simp only: su.simps)
  done
end

context
  fixes v :: "nat \<Rightarrow> nat"
    and p :: "nat \<Rightarrow> nat"
  assumes p_lt: "p (Suc j) < Suc j"
begin

text \<open>Dimensionality given by i\<close>
function wis :: "nat \<Rightarrow> nat" where
  "wis 0 = 0" |
  "wis (Suc i) = max (wis (p (Suc i)) + v i) (wis i)"
  by pat_completeness auto
termination
  by (relation "(\<lambda>p. size p) <*mlex*> {}") (auto intro: wf_mlex mlex_less simp: p_lt)

function wis' wis'' :: "(nat, nat) dpfun" where
  "wis' params = checkmem params (wis'' params)" |
  "wis'' 0 = \<langle>0\<rangle>" |
  "wis'' (Suc i) = max\<^sub>s (wis' (p (Suc i)) +\<^sub>s \<langle>v i\<rangle>) (wis' i)"
  by pat_completeness auto
termination
  by (relation "case_sum size size <*mlex*> case_sum (\<lambda>x. Suc 0) (\<lambda>x. 0) <*mlex*> {}")
     (auto simp: mlex_leq mlex_less wf_mlex p_lt)

lemma nat_le_induct:
  assumes "P 0" "\<And>x. (\<And>y. y<Suc x \<Longrightarrow> P y) \<Longrightarrow> P (Suc x)"
    shows "P a"
proof (cases a)
  case 0 thus ?thesis using assms(1) by simp next
  case Suc
  have "\<And>b. b\<le>a \<Longrightarrow> P b"
    using assms by (induction a) (auto elim: le_SucE)
  thus ?thesis by simp
qed

lemma "consistentDF wis wis'"
  apply (unfold consistentDF_def, rule allI, induct_tac param rule: wis.induct)
   apply (simp only: wis.simps wis'.simps wis''.simps)
   apply (assumption | rule consistency_rules)+
   apply (simp only: wis.simps)

  apply (simp only: wis.simps wis'.simps wis''.simps)
  apply (assumption | rule consistency_rules)+
  by (simp only: wis.simps)

end


(*
 * Copyright 2014, NICTA
 *
 * 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(NICTA_BSD)
 *)

theory word_abs_cases imports
  "../../AutoCorres"
begin

(* extra optimization for word_abs (currently does not work) *)
lemma INT_MIN_MAX_smod: "\<And>a b :: int. \<lbrakk> INT_MIN \<le> b; b \<le> INT_MAX; b \<noteq> 0 \<rbrakk> \<Longrightarrow> INT_MIN \<le> a smod b \<and> a smod b \<le> INT_MAX"
  apply (case_tac "b > 0")
   apply (rule conjI)
    apply (case_tac "a \<ge> 0")
     apply (frule_tac a = a and b = b in smod_int_compares(2))
      apply assumption
     apply (simp add: INT_MIN_def)
    apply (subgoal_tac "0 \<ge> a")
     apply (frule_tac a = a and b = b in smod_int_compares(3))
      apply assumption
     apply (simp add: INT_MIN_def INT_MAX_def)
    apply arith
   apply (case_tac "a \<ge> 0")
    apply (frule_tac a = a and b = b in smod_int_compares(1))
     apply assumption
    apply arith
   apply (subgoal_tac "0 \<ge> a")
    apply (frule_tac a = a and b = b in smod_int_compares(4))
     apply assumption
    apply arith
   apply arith
  apply (subgoal_tac "0 > b")
   apply (rule conjI)
    apply (case_tac "a \<ge> 0")
     apply (frule_tac a = a and b = b in smod_int_compares(6))
      apply assumption
     apply simp
    apply (subgoal_tac "0 \<ge> a")
     apply (frule_tac a = a and b = b in smod_int_compares(8))
      apply assumption
     apply (simp add: INT_MIN_def)
    apply arith
   apply (case_tac "a \<ge> 0")
    apply (frule_tac a = a and b = b in smod_int_compares(5))
     apply assumption
    apply (simp add: INT_MIN_def INT_MAX_def)
   apply (subgoal_tac "0 \<ge> a")
    apply (frule_tac a = a and b = b in smod_int_compares(7))
     apply assumption
    apply (simp add: INT_MAX_def)
   apply arith
  apply arith
  done
lemma [unfolded INT_MIN_def INT_MAX_def, simplified, L2flow]:
  "simp_expr (INT_MIN \<le> b \<and> b \<le> INT_MAX \<and> b \<noteq> 0) (INT_MIN \<le> a smod b) True"
  by (simp add: simp_expr_def INT_MIN_MAX_smod)
lemma [unfolded INT_MIN_def INT_MAX_def, simplified, L2flow]:
  "simp_expr (INT_MIN \<le> b \<and> b \<le> INT_MAX \<and> b \<noteq> 0) (a smod b \<le> INT_MAX) True"
  by (simp add: simp_expr_def INT_MIN_MAX_smod)

install_C_file "word_abs_cases.c"
autocorres [
  unsigned_word_abs = callee_flat_u_abs
             caller_flat_u_aa
             caller_flat_u_an
] "word_abs_cases.c"

context word_abs_cases begin

  declare K_bind_def[simp del]

  thm callee_flat_s'_def caller_flat_s'_def

  thm callee_flat_u_abs'_def callee_flat_u_noabs'_def
  thm caller_flat_u_aa'_def caller_flat_u_an'_def caller_flat_u_na'_def caller_flat_u_nn'_def

  thm callee_deep_s'.simps caller_deep_s'_def

  thm mutual_s1'.simps mutual_s2'.simps

  thm cross'_def gcd_s_rec'.simps gcd_s_loop'_def

  lemma int_max: "2147483647 \<le> a \<Longrightarrow> sint (n :: sword32) \<le> a"
    using INT_MIN_MAX_lemmas(2)[where s = n, unfolded INT_MAX_def]
    by arith
  lemma int_min: "a \<le> -2147483648 \<Longrightarrow> a \<le> sint (n :: sword32)"
    using INT_MIN_MAX_lemmas(3)[where s = n, unfolded INT_MIN_def]
    by arith
  lemma oguard_True: "(\<And>s. P s) \<Longrightarrow> DO oguard P; f OD = f"
    by (monad_eq simp: oguard_def obind_def K_bind_def)

  thm gcd_s_loop'_def gcd_s_loop'_def [simplified int_min int_max oguard_True]

  thm sum'_def sum'_def[simplified, folded INT_MAX_def[simplified] INT_MIN_def[simplified]]
end

end