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

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

header {* Continuity and Induction for Loops*}

theory LoopInduction imports Healthiness Continuity begin

text {* Showing continuity for loops requires a stronger induction principle than we have used
so far, which in turn relies on the continuity of loops (inductively).  Thus, the proofs are
intertwined, and broken off from the main set of continuity proofs.  This result is also
essential in showing the sublinearity of loops. *}

text {* A loop step is monotonic. *}
lemma wp_loop_step_mono_trans:
  fixes body::"'s prog"
  assumes sP: "sound P"
      and hb: "healthy (wp body)"
  shows "mono_trans (\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * P s)"
proof(intro mono_transI le_funI, simp)
  fix Q R::"'s expect" and s::'s
  assume sQ: "sound Q" and sR: "sound R" and le: "Q \<tturnstile> R"
  hence "wp body Q \<tturnstile> wp body R"
    by(rule mono_transD[OF healthy_monoD, OF hb])
  thus "\<guillemotleft>G\<guillemotright> s * wp body Q s \<le> \<guillemotleft>G\<guillemotright> s * wp body R s"
    by(auto dest:le_funD intro:mult_left_mono)
qed

text {* We can therefore apply the standard fixed-point lemmas to unfold it: *}
lemma lfp_wp_loop_unfold:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and sP: "sound P"
  shows "lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s) =
         (\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)) s +
              \<guillemotleft>\<N> G\<guillemotright> s * P s)"
proof(rule lfp_exp_unfold)
  from assms show "mono_trans (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
    by(blast intro:wp_loop_step_mono_trans)
  from assms show "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. bound_of P) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile> \<lambda>s. bound_of P"
    by(blast intro:lfp_loop_fp)
  from sP show "sound (\<lambda>s. bound_of P)"
    by(auto)
  fix Q::"'s expect"
  assume "sound Q"
  with assms show "sound (\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
    by(intro wp_loop_step_sound[unfolded wp_eval, simplified, folded negate_embed], auto)
qed

  from uP uwQ have "wp body Q s \<le> 1" "P s \<le> 1" by(auto)
  hence "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> \<guillemotleft>G\<guillemotright> s * 1 + \<guillemotleft>\<N> G\<guillemotright> s * 1"
    by(blast intro:add_mono mult_left_mono)
  also have "... = 1" by(simp add:negate_embed)
  finally show "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> 1" .
qed

lemma lfp_loop_unitary:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and uP: "unitary P"
  shows "unitary (lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s))"
  using assms by(blast intro:lfp_exp_unitary wp_loop_step_unitary)

text {* From the lattice structure on transformers, we establish a transfinite induction
  principle for loops.  We use this to show a number of properties, particularly
  subdistributivity, for loops.  This proof follows the pattern of lemma lfp\_ordinal\_induct
  in HOL/Inductive. *}
lemma loop_induct:
  fixes body::"'s prog"
  assumes hwp:  "healthy (wp body)"
      and hwlp: "nearly_healthy (wlp body)"
      -- "The body must be healthy, both in strict and liberal semantics."
      and Limit:   "\<And>S. \<lbrakk> \<forall>x\<in>S. P (fst x) (snd x); \<forall>x\<in>S. feasible (fst x);
                          \<forall>x\<in>S. \<forall>Q. unitary Q \<longrightarrow> unitary (snd x Q) \<rbrakk> \<Longrightarrow>
                    P (Sup_trans (fst ` S)) (Inf_utrans (snd ` S))"
      -- "The property holds at limit points."
      and IH:   "\<And>t u. \<lbrakk> P t u; feasible t; \<And>Q. unitary Q \<Longrightarrow> unitary (u Q)  \<rbrakk> \<Longrightarrow>
                        P (wp  (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))
                          (wlp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
      -- "The inductive step.  The property is preserved by a single loop iteration."
      and P_equiv: "\<And>t t' u u'. \<lbrakk> P t u; equiv_trans t t'; equiv_utrans u u' \<rbrakk> \<Longrightarrow> P t' u'"
      -- "The property must be preserved by equivalence"
  shows "P (wp (do G \<longrightarrow> body od)) (wlp (do G \<longrightarrow> body od))"
  -- "The property can refer to both interpretations simultaneously.  The unifier will happily
  apply the rule to just one or the other, however."
proof(simp add:wp_eval)
  let "?X t" = "wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"
  let "?Y t" = "wlp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"

  let ?M = "{x. P (fst x) (snd x) \<and>
                feasible (fst x) \<and>
                (\<forall>Q. unitary Q \<longrightarrow> unitary (snd x Q)) \<and>
                le_trans (fst x) (lfp_trans ?X) \<and>
                le_utrans (gfp_trans ?Y) (snd x)}"

  have fSup: "feasible (Sup_trans (fst ` ?M))"
  proof(intro feasibleI bounded_byI2 nnegI2)
    fix Q::"'s expect" and b::real
    assume nQ: "nneg Q" and bQ: "bounded_by b Q"
    show "Sup_trans (fst ` ?M) Q \<tturnstile> \<lambda>s. b"
      unfolding Sup_trans_def
      using nQ bQ by(auto intro!:Sup_exp_least)
    show "\<lambda>s. 0 \<tturnstile> Sup_trans (fst ` ?M) Q"
    proof(cases)
      assume empty: "?M = {}"
      show ?thesis by(simp add:Sup_trans_def Sup_exp_def empty)
    next
      assume ne: "?M \<noteq> {}"
      hence "\<exists>x. x \<in> ?M" by(rule nonempty_witness)
      then obtain x where xin: "x \<in> ?M" by(rule exE)
      hence ffx: "feasible (fst x)" by(simp)
      with nQ bQ have "\<lambda>s. 0 \<tturnstile> fst x Q" by(auto)
      also from xin have "fst x Q \<tturnstile> Sup_trans (fst ` ?M) Q"
          apply(intro Sup_trans_upper2[OF imageI _ nQ bQ], assumption)
          apply(clarsimp, blast intro: sound_nneg[OF feasible_sound] feasible_boundedD)
          done
      finally show "\<lambda>s. 0 \<tturnstile> Sup_trans (fst ` ?M) Q" .
    qed
  qed

  have uInf: "\<And>P. unitary P \<Longrightarrow> unitary (Inf_utrans (snd ` ?M) P)"
  proof(cases "?M = {}")
    fix P
    assume empty: "?M = {}"
    show "?thesis P" by(simp only:empty, simp add:Inf_utrans_def)
  next
    fix P::"'s expect"
    assume uP: "unitary P"
       and ne: "?M \<noteq> {}"
    show "?thesis P"
    proof(intro unitaryI2 nnegI2 bounded_byI2)
      from nonempty_witness[OF ne] obtain x where xin: "x \<in> ?M" by(iprover)
      hence sxin: "snd x \<in> snd ` ?M" by(simp)
      hence "le_utrans (Inf_utrans (snd ` ?M)) (snd x)"
        by(intro Inf_utrans_lower, auto)
      with uP
      have "Inf_utrans (snd ` ?M) P \<tturnstile> snd x P" by(auto)
      also {
        from xin uP have "unitary (snd x P)" by(simp)
        hence "snd x P \<tturnstile> \<lambda>s. 1" by(auto)
      }
      finally show "Inf_utrans (snd ` ?M) P \<tturnstile> \<lambda>s. 1" .

      have "\<lambda>s. 0 \<tturnstile> Inf_trans (snd ` ?M) P"
        unfolding Inf_trans_def
      proof(rule Inf_exp_greatest)
        from sxin show "{t P |t. t \<in> snd ` ?M} \<noteq> {}" by(auto)
        show "\<forall>P\<in>{t P |t. t \<in> snd ` ?M}. \<lambda>s. 0 \<tturnstile> P"
        proof(clarsimp)
          fix t::"'s trans"
          assume "\<forall>Q. unitary Q \<longrightarrow> unitary (t Q)"
          with uP have "unitary (t P)" by(auto)
          thus "\<lambda>s. 0 \<tturnstile> t P" by(auto)
        qed
      qed
      also {
        from ne have X: "(snd ` ?M = {}) = False" by(simp)
        have "Inf_trans (snd ` ?M) P = Inf_utrans (snd ` ?M) P"
          unfolding Inf_utrans_def by(subst X, simp)
      }
      finally show "\<lambda>s. 0 \<tturnstile> Inf_utrans (snd ` ?M) P" .
    qed
  qed

  have wp_loop_mono: "\<And>t u. \<lbrakk> le_trans t u; \<And>P. sound P \<Longrightarrow> sound (t P);
                               \<And>P. sound P \<Longrightarrow> sound (u P) \<rbrakk> \<Longrightarrow> le_trans (?X t) (?X u)"
  proof(intro le_transI le_funI, simp add:wp_eval)
    fix t u::"'s trans" and P::"'s expect" and s::'s
    assume le: "le_trans t u"
       and st: "\<And>P. sound P \<Longrightarrow> sound (t P)"
       and su: "\<And>P. sound P \<Longrightarrow> sound (u P)"
       and sP: "sound P"
    hence "sound (t P)" "sound (u P)" by(auto)
    with healthy_monoD[OF hwp] le sP have "wp body (t P) \<tturnstile> wp body (u P)" by(auto)
    hence "wp body (t P) s \<le> wp body (u P) s" by(auto)
    thus "\<guillemotleft>G\<guillemotright> s * wp body (t P) s \<le> \<guillemotleft>G\<guillemotright> s * wp body (u P) s" by(auto intro:mult_left_mono)
  qed

  have wlp_loop_mono: "\<And>t u. \<lbrakk> le_utrans t u; \<And>P. unitary P \<Longrightarrow> unitary (t P);
                               \<And>P. unitary P \<Longrightarrow> unitary (u P) \<rbrakk> \<Longrightarrow> le_utrans (?Y t) (?Y u)"
  proof(intro le_utransI le_funI, simp add:wp_eval)
    fix t u::"'s trans" and P::"'s expect" and s::'s
    assume le: "le_utrans t u"
       and ut: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
       and uu: "\<And>P. unitary P \<Longrightarrow> unitary (u P)"
       and uP: "unitary P"
    hence "unitary (t P)" "unitary (u P)" by(auto)
    with le uP have "wlp body (t P) \<tturnstile> wlp body (u P)"
      by(auto intro:nearly_healthy_monoD[OF hwlp])
    hence "wlp body (t P) s \<le> wlp body (u P) s" by(auto)
    thus "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s \<le> \<guillemotleft>G\<guillemotright> s * wlp body (u P) s"
      by(auto intro:mult_left_mono)
  qed

  from hwp have hX: "\<And>t. healthy t \<Longrightarrow> healthy (?X t)"
    by(auto intro:healthy_intros)

  from hwlp have hY: "\<And>t. nearly_healthy t \<Longrightarrow> nearly_healthy (?Y t)"
    by(auto intro!:healthy_intros)

  have PLimit: "P (Sup_trans (fst ` ?M)) (Inf_utrans (snd ` ?M))"
    by(auto intro:Limit)

  have feasible_lfp_loop:
    "feasible (lfp_trans ?X)"
  proof(intro feasibleI bounded_byI2 nnegI2,
        simp_all add:wp_Loop1[unfolded wp_eval] soundI2 hwp)
    fix P::"'s expect" and b::real
    assume bP: "bounded_by b P" and nP: "nneg P"
    hence sP: "sound P" by(auto)
    show "lfp_exp (\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * P s) \<tturnstile> \<lambda>s. b"
    proof(intro lfp_exp_lowerbound le_funI)
      fix s::'s
      from bP nP have nnb: "0 \<le> b" by(auto)
      hence "sound (\<lambda>s. b)" "bounded_by b (\<lambda>s. b)" by(auto)
      with hwp have "bounded_by b (wp body (\<lambda>s. b))" by(auto)
      with bP have "wp body (\<lambda>s. b) s \<le> b" "P s \<le> b" by(auto)
      hence "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. b) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> \<guillemotleft>G\<guillemotright> s * b + \<guillemotleft>\<N> G\<guillemotright> s * b"
        by(auto intro:add_mono mult_left_mono)
      thus "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. b) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> b"
        by(simp add:negate_embed algebra_simps)
      from nnb show "sound (\<lambda>s. b)" by(auto)
    qed
    from hwp sP show "\<lambda>s. 0 \<tturnstile> lfp_exp (\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * P s)"
      by(blast intro!:lfp_exp_greatest lfp_loop_fp)
  qed

  have unitary_gfp:
    "\<And>P. unitary P \<Longrightarrow> unitary (gfp_trans ?Y P)"
  proof(intro unitaryI2 nnegI2 bounded_byI2,
      simp_all add:wlp_Loop1[unfolded wp_eval] hwlp)
    fix P::"'s expect"
    assume uP: "unitary P"
    show "\<lambda>s. 0 \<tturnstile> gfp_exp (\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wlp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * P s)"
    proof(rule gfp_exp_upperbound[OF le_funI])
      fix s::"'s"
      from hwlp uP have "0 \<le> wlp body (\<lambda>s. 0) s" "0 \<le> P s" by(auto dest!:unitary_sound)
      thus "0 \<le> \<guillemotleft>G\<guillemotright> s * wlp body (\<lambda>s. 0) s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
        by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
      show "unitary (\<lambda>s. 0)" by(auto)
    qed
    show "gfp_exp (\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wlp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * P s) \<tturnstile> \<lambda>s. 1"
      by(auto intro:gfp_exp_least)
  qed

  have fX:
    "\<And>t. feasible t \<Longrightarrow> feasible (?X t)"
  proof(intro feasibleI nnegI bounded_byI, simp_all add:wp_eval)
    fix t::"'s trans" and Q::"'s expect" and b::real and s::'s
    assume ft: "feasible t" and bQ: "bounded_by b Q" and nQ: "nneg Q"
    hence "nneg (t Q)" "bounded_by b (t Q)" by(auto)
    moreover hence stQ: "sound (t Q)" by(auto)
    ultimately have "wp body (t Q) s \<le> b" using hwp by(auto)
    moreover from bQ have "Q s \<le> b" by(auto)
    ultimately have "\<guillemotleft>G\<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft>G\<guillemotright> s) * Q s \<le>
                     \<guillemotleft>G\<guillemotright> s * b + (1 - \<guillemotleft> G \<guillemotright> s) * b"
      by(auto intro:add_mono mult_left_mono)
    thus "\<guillemotleft>G\<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft>G\<guillemotright> s) * Q s \<le> b"
      by(simp add:algebra_simps)

    from nQ stQ hwp have "0 \<le> wp body (t Q) s" "0 \<le> Q s" by(auto)
    thus "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body (t Q) s + (1 - \<guillemotleft>G\<guillemotright> s) * Q s"
      by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
  qed

  have uY:
    "\<And>t P. (\<And>P. unitary P \<Longrightarrow> unitary (t P)) \<Longrightarrow> unitary P \<Longrightarrow> unitary (?Y t P)"
  proof(intro unitaryI2 nnegI bounded_byI, simp_all add:wp_eval)
    fix t::"'s trans" and P::"'s expect" and s::'s
    assume ut: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
       and uP: "unitary P"
    hence utP: "unitary (t P)" by(auto)
    with hwlp have ubtP: "unitary (wlp body (t P))" by(auto)
    with uP have "0 \<le> P s" "0 \<le> wlp body (t P) s" by(auto)
    thus "0 \<le> \<guillemotleft>G\<guillemotright> s * wlp body (t P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s"
      by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)

    from uP ubtP have "P s \<le> 1" "wlp body (t P) s \<le> 1" by(auto)
    hence "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le> \<guillemotleft>G\<guillemotright> s * 1 + (1-\<guillemotleft>G\<guillemotright> s) * 1"
      by(blast intro:add_mono mult_left_mono)
    also have "... = 1" by(simp add:algebra_simps)
    finally show "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le> 1" .
  qed

  have fw_lfp: "le_trans (Sup_trans (fst ` ?M)) (lfp_trans ?X)"
    using feasible_nnegD[OF feasible_lfp_loop]
    by(intro le_transI[OF Sup_trans_least2], blast+)
  hence "le_trans (?X (Sup_trans (fst ` ?M))) (?X (lfp_trans ?X))"
    by(auto intro:wp_loop_mono feasible_sound[OF fSup]
                  feasible_sound[OF feasible_lfp_loop])
  also have "equiv_trans ... (lfp_trans ?X)"
  proof(rule iffD1[OF equiv_trans_comm, OF lfp_trans_unfold], iprover intro:wp_loop_mono)
    fix t::"'s trans" and P::"'s expect"
    assume st: "\<And>Q. sound Q \<Longrightarrow> sound (t Q)"
       and sP: "sound P"
    show "sound (?X t P)"
    proof(intro soundI2 bounded_byI nnegI, simp_all add:wp_eval)
      fix s::'s
      from sP st hwp have "0 \<le> P s" "0 \<le> wp body (t P) s" by(auto)
      thus "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s"
        by(blast intro:add_nonneg_nonneg mult_nonneg_nonneg)
      from sP st have "bounded_by (bound_of (t P)) (t P)" by(auto)
      with sP st hwp have "bounded_by (bound_of (t P)) (wp body (t P))" by(auto)
      hence "wp body (t P) s \<le> bound_of (t P)" by(auto)
      moreover from sP st hwp have "P s \<le> bound_of P" by(auto)
      moreover have "\<guillemotleft>G\<guillemotright> s \<le> 1" "1 - \<guillemotleft>G\<guillemotright> s \<le> 1" by(auto)
      moreover from sP st hwp have "0 \<le> wp body (t P) s" "0 \<le> P s" by(auto)
      moreover have "(0::real) \<le> 1" by(simp)
      ultimately show "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
                       1 * bound_of (t P) + 1 * bound_of P"
        by(blast intro:add_mono mult_mono)
      qed
    next
    let "?fp" = "\<lambda>R s. bound_of R"
    show "le_trans (?X ?fp) ?fp" by(auto intro:healthy_intros hwp)
    fix P::"'s expect" assume "sound P"
    thus "sound (?fp P)" by(auto)
  qed
  finally have le_lfp: "le_trans (?X (Sup_trans (fst ` ?M))) (lfp_trans ?X)" .

  have fw_gfp: "le_utrans (gfp_trans ?Y) (Inf_utrans (snd ` ?M))"
    by(auto intro:Inf_utrans_greatest unitary_gfp)

  have "equiv_utrans (gfp_trans ?Y) (?Y (gfp_trans ?Y))"
    by(auto intro!:gfp_trans_unfold wlp_loop_mono uY)
  also from fw_gfp have "le_utrans (?Y (gfp_trans ?Y)) (?Y (Inf_utrans (snd ` ?M)))"
    by(auto intro:wlp_loop_mono uInf unitary_gfp)
  finally have ge_gfp: "le_utrans (gfp_trans ?Y) (?Y (Inf_utrans (snd ` ?M)))" .
  from PLimit fX uY fSup uInf have "P (?X (Sup_trans (fst ` ?M))) (?Y (Inf_utrans (snd ` ?M)))"
    by(iprover intro:IH)
  moreover from fSup have "feasible (?X (Sup_trans (fst ` ?M)))" by(rule fX)
  moreover have "\<And>P. unitary P \<Longrightarrow> unitary (?Y (Inf_utrans (snd ` ?M)) P)"
    by(auto intro:uY uInf)
  moreover note le_lfp ge_gfp
  ultimately have pair_in: "(?X (Sup_trans (fst ` ?M)), ?Y (Inf_utrans (snd ` ?M))) \<in> ?M"
    by(simp)

  have "?X (Sup_trans (fst ` ?M)) \<in> fst ` ?M"
    by(rule imageI[OF pair_in, of fst, simplified])
  hence "le_trans (?X (Sup_trans (fst ` ?M))) (Sup_trans (fst ` ?M))"
  proof(rule le_transI[OF Sup_trans_upper2[where t="?X (Sup_trans (fst ` ?M))"
                                             and S="fst ` ?M"]])
    fix P::"'s expect"
    assume sP: "sound P"
    thus "nneg P" by(auto)
    from sP show "bounded_by (bound_of P) P" by(auto)
    from sP show "\<forall>u\<in>fst ` ?M. \<forall>Q. nneg Q \<and> bounded_by (bound_of P) Q \<longrightarrow>
                                   nneg (u Q) \<and> bounded_by (bound_of P) (u Q)"
      by(auto)
  qed
  hence "le_trans (lfp_trans ?X) (Sup_trans (fst ` ?M))"
    by(auto intro:lfp_trans_lowerbound feasible_sound[OF fSup])
  with fw_lfp have eqt: "equiv_trans (Sup_trans (fst ` ?M)) (lfp_trans ?X)"
    by(rule le_trans_antisym)

  have "?Y (Inf_utrans (snd ` ?M)) \<in> snd ` ?M"
    by(rule imageI[OF pair_in, of snd, simplified])
  hence "le_utrans (Inf_utrans (snd ` ?M)) (?Y (Inf_utrans (snd ` ?M)))"
    by(intro Inf_utrans_lower, auto)
  hence "le_utrans (Inf_utrans (snd ` ?M)) (gfp_trans ?Y)"
    by(blast intro:gfp_trans_upperbound uInf)
  with fw_gfp have equ: "equiv_utrans (Inf_utrans (snd ` ?M)) (gfp_trans ?Y)"
    by(auto intro:le_utrans_antisym)
  from PLimit eqt equ show "P (lfp_trans ?X) (gfp_trans ?Y)" by(rule P_equiv)
qed

subsection {* The Limit of Iterates *}

text {* The iterates of a loop are its sequence of finite unrollings.  We show shortly that this
converges on the least fixed point.  This is enormously useful, as we can appeal to various
properties of the finite iterates (which will follow by finite induction), which we can then
transfer to the limit. *}
definition iterates :: "'s prog \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's trans"
where "iterates body G i = ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) ^^ i) (\<lambda>P s. 0)"

lemma iterates_0[simp]:
  "iterates body G 0 = (\<lambda>P s. 0)"
  by(simp add:iterates_def)

lemma iterates_Suc[simp]:
  "iterates body G (Suc i) = wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft>G\<guillemotright>\<^esub>\<oplus> Skip)"
  by(simp add:iterates_def)

text {* All iterates are healthy. *}
lemma iterates_healthy:
  "healthy (wp body) \<Longrightarrow> healthy (iterates body G i)"
  by(induct i, auto intro:healthy_intros)

text {* The iterates are an ascending chain. *}
lemma iterates_increasing:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
  shows "le_trans (iterates body G i) (iterates body G (Suc i))"
proof(induct i)
  show "le_trans (iterates body G 0) (iterates body G (Suc 0))"
  proof(simp add:iterates_def, rule le_transI)
    fix P::"'s expect"
    assume "sound P"
    with hb have "sound (wp (body ;; Embed (\<lambda>P s. 0) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
      by(auto intro!:wp_loop_step_sound)
    thus "\<lambda>s. 0 \<tturnstile> wp (body ;; Embed (\<lambda>P s. 0) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P"
      by(auto)
  qed

  fix i
  assume IH: "le_trans (iterates body G i) (iterates body G (Suc i))"
  have "equiv_trans (iterates body G (Suc i))
                    (wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
    by(simp)
  also from iterates_healthy[OF hb]
  have "le_trans ... (wp (body ;; Embed (iterates body G (Suc i)) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
    by(blast intro:wp_loop_step_mono[OF hb IH])
  also have "equiv_trans ... (iterates body G (Suc (Suc i)))"
    by(simp)
  finally show "le_trans (iterates body G (Suc i)) (iterates body G (Suc (Suc i)))" .
qed

lemma wp_loop_step_bounded:
  fixes t::"'s trans" and Q::"'s expect"
  assumes nQ: "nneg Q"
      and bQ: "bounded_by b Q"
      and ht: "healthy t"
      and hb: "healthy (wp body)"
  shows "bounded_by b (wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q)"
proof(rule bounded_byI, simp add:wp_eval)
  fix s::'s
  from nQ bQ have sQ: "sound Q" by(auto)
  with bQ ht have "sound (t Q)" "bounded_by b (t Q)" by(auto)
  with hb have "bounded_by b (wp body (t Q))" by(auto)
  with bQ have "wp body (t Q) s \<le> b" "Q s \<le> b" by(auto)
  hence "\<guillemotleft>G\<guillemotright> s * wp body (t Q) s + (1-\<guillemotleft>G\<guillemotright> s) * Q s \<le>
         \<guillemotleft>G\<guillemotright> s * b + (1-\<guillemotleft>G\<guillemotright> s) * b"
    by(auto intro:add_mono mult_left_mono)
  also have "... = b" by(simp add:algebra_simps)
  finally show "\<guillemotleft>G\<guillemotright> s * wp body (t Q) s + (1-\<guillemotleft>G\<guillemotright> s) * Q s \<le> b" .
qed

text {* This is the key result: The loop is equivalent to the supremum of its iterates.  This
proof follows the pattern of lemma continuous\_lfp in HOL/Library/Continuity. *}
lemma lfp_iterates:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and cb: "bd_cts (wp body)"
  shows "equiv_trans (wp (do G \<longrightarrow> body od)) (Sup_trans (range (iterates body G)))"
        (is "equiv_trans ?X ?Y")
proof(rule le_trans_antisym)
  let ?F = "\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"
  let ?bot = "\<lambda>(P::'s \<Rightarrow> real) s::'s. 0::real"

  have HF: "\<And>i. healthy ((?F ^^ i) ?bot)"
  proof -
    fix i from hb show "(?thesis i)"
      by(induct i, simp_all add:healthy_intros)
  qed

  from iterates_healthy[OF hb]
  have "\<And>i. feasible (iterates body G i)" by(auto)
  hence fSup: "feasible (Sup_trans (range (iterates body G)))"
    by(auto intro:feasible_Sup_trans)

  {
    fix i
    have "le_trans ((?F ^^ i) ?bot) ?X"
    proof(induct i)
      show "le_trans ((?F ^^ 0) ?bot) ?X"
      proof(simp, intro le_transI)
        fix P::"'s expect"
        assume "sound P"
        with hb healthy_wp_loop
        have "sound (wp (\<mu> x. body ;; x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
          by(auto)
        thus "\<lambda>s. 0 \<tturnstile> wp (\<mu> x. body ;; x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P"
          by(auto)
      qed
      fix i
      assume IH: "le_trans ((?F ^^ i) ?bot) ?X"
      have "equiv_trans ((?F ^^ (Suc i)) ?bot) (?F ((?F ^^ i) ?bot))" by(simp)
      also have "le_trans ... (?F ?X)"
      proof(rule wp_loop_step_mono[OF hb IH])
        fix P::"'s expect"
        assume sP: "sound P"
        with hb healthy_wp_loop
        show "sound (wp (\<mu> x. body ;; x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
          by(auto)
        from sP show "sound ((?F ^^ i) ?bot P)"
          by(rule healthy_sound[OF HF])
      qed
      also {
        from hb have X: "le_trans (wp (body ;; Embed (\<lambda>P s. bound_of P) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))
                                 (\<lambda>P s. bound_of P)"
          by(intro le_transI, simp add:wp_eval, auto intro: lfp_loop_fp[unfolded negate_embed])
        have "equiv_trans (?F ?X) ?X"
        unfolding wp_eval
        by(intro iffD1[OF equiv_trans_comm, OF lfp_trans_unfold]
                 wp_loop_step_mono[OF hb] wp_loop_step_sound[OF hb], (blast|rule X)+)
      }
      finally show "le_trans ((?F ^^ (Suc i)) ?bot) ?X" .
    qed
  }
  hence "\<And>i. le_trans (iterates body G i) (wp do G \<longrightarrow> body od)"
    by(simp add:iterates_def)
  thus "le_trans ?Y ?X"
    by(auto intro!:le_transI[OF Sup_trans_least2] sound_nneg
                   healthy_sound[OF iterates_healthy, OF hb]
                   healthy_bounded_byD[OF iterates_healthy, OF hb]
                   healthy_sound[OF healthy_wp_loop] hb)

  show "le_trans ?X ?Y"
    unfolding wp_eval
  proof(rule lfp_trans_lowerbound)
    from hb cb have "bd_cts_tr ?F" by(rule cts_wp_loopstep)
    with iterates_increasing[OF hb] iterates_healthy[OF hb]
    have "equiv_trans (?F ?Y) (Sup_trans (range (?F o (iterates body G))))"
      by(auto intro!:healthy_feasibleD bd_cts_trD)
    also have "le_trans (Sup_trans (range (?F o (iterates body G)))) ?Y"
    proof(rule le_transI)
      fix P::"'s expect"
      assume sP: "sound P"
      show "(Sup_trans (range (?F o (iterates body G)))) P \<tturnstile> ?Y P"
      proof(rule Sup_trans_least2, clarsimp)
        show "\<forall>u\<in>range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> iterates body G).
              \<forall>R. nneg R \<and> bounded_by (bound_of P) R \<longrightarrow>
                  nneg (u R) \<and> bounded_by (bound_of P) (u R)"
        proof(clarsimp, intro conjI)
          fix Q::"'s expect" and i
          assume nQ: "nneg Q" and bQ: "bounded_by (bound_of P) Q"
          hence "sound Q" by(auto)
          moreover from iterates_healthy[OF hb]
          have "\<And>P. sound P \<Longrightarrow> sound (iterates body G i P)" by(auto)
          moreover note hb
          ultimately have "sound (wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q)"
            by(iprover intro:wp_loop_step_sound)
          thus "nneg (wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q)"
            by(auto)
          from nQ bQ iterates_healthy[OF hb] hb
          show "bounded_by (bound_of P) (wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q)"
            by(rule wp_loop_step_bounded)
        qed
        from sP show "nneg P" "bounded_by (bound_of P) P" by(auto)
      next
        fix Q::"'s expect"
        assume nQ: "nneg Q" and bQ: "bounded_by (bound_of P) Q"
        hence "sound Q" by(auto)
        with fSup have "sound (Sup_trans (range (iterates body G)) Q)" by(auto)
        thus "nneg (Sup_trans (range (iterates body G)) Q)" by(auto)

        fix i
        show "wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q \<tturnstile>
              Sup_trans (range (iterates body G)) Q"
        proof(rule Sup_trans_upper2[OF _ _ nQ bQ])
          from iterates_healthy[OF hb]
          show "\<forall>u\<in>range (iterates body G).
                \<forall>R. nneg R \<and> bounded_by (bound_of P) R \<longrightarrow>
                     nneg (u R) \<and> bounded_by (bound_of P) (u R)"
            by(auto)
          have "wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) = iterates body G (Suc i)"
            by(simp)
          also have "... \<in> range (iterates body G)"
            by(blast)
          finally show "wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) \<in>
                        range (iterates body G)" .
        qed
      qed
    qed
    finally show "le_trans (?F ?Y) ?Y" .

    fix P::"'s expect"
    assume "sound P"
    with fSup show "sound (?Y P)" by(auto)
  qed
qed

text {* Therefore, evaluated at a given point (state), the sequence of iterates gives a sequence
of real values that converges on that of the loop itself. *}
corollary loop_iterates:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and cb: "bd_cts (wp body)"
      and sP: "sound P"
  shows "(\<lambda>i. iterates body G i P s) ----> wp (do G \<longrightarrow> body od) P s"
proof -
  let ?X = "{f s |f. f \<in> {t P |t. t \<in> range (iterates body G)}}"
  have closure_Sup: "Sup ?X \<in> closure ?X"
  proof(rule closure_contains_Sup, simp, clarsimp)
    fix i
    from sP have "bounded_by (bound_of P) P" by(auto)
    with iterates_healthy[OF hb] sP have "\<And>j. bounded_by (bound_of P) (iterates body G j P)"
      by(auto)
    thus "iterates body G i P s \<le> bound_of P" by(auto)
  qed

  have "(\<lambda>i. iterates body G i P s) ----> Sup {f s |f. f \<in> {t P |t. t \<in> range (iterates body G)}}"
  proof(rule LIMSEQ_I)
    fix r::real assume posr: "0 < r"
    with closure_Sup obtain y where yin: "y \<in> ?X" and ey: "dist y (Sup ?X) < r"
      by(simp only:closure_approachable, blast)
    from yin obtain i where yit: "y = iterates body G i P s" by(auto)
    {
      fix j
      have "i \<le> j \<longrightarrow> le_trans (iterates body G i) (iterates body G j)"
      proof(induct j, simp, clarify)
        fix k
        assume IH: "i \<le> k \<longrightarrow> le_trans (iterates body G i) (iterates body G k)"
           and le: "i \<le> Suc k"
        show "le_trans (iterates body G i) (iterates body G (Suc k))"
        proof(cases "i = Suc k", simp)
          assume "i \<noteq> Suc k"
          with le have "i \<le> k" by(auto)
          with IH have "le_trans (iterates body G i) (iterates body G k)" by(auto)
          also note iterates_increasing[OF hb]
          finally show "le_trans (iterates body G i) (iterates body G (Suc k))" .
        qed
      qed
    }
    with sP have "\<forall>j\<ge>i. iterates body G i P s \<le> iterates body G j P s"
      by(auto)
    moreover {
      from sP have "bounded_by (bound_of P) P" by(auto)
      with iterates_healthy[OF hb] sP have "\<And>j. bounded_by (bound_of P) (iterates body G j P)"
        by(auto)
      hence "\<And>j. iterates body G j P s \<le> bound_of P" by(auto)
      hence "\<And>j. iterates body G j P s \<le> Sup ?X"
        by(intro cSup_upper bdd_aboveI, auto)
    }
    ultimately have "\<And>j. i \<le> j \<Longrightarrow>
                           norm (iterates body G j P s - Sup ?X) \<le>
                           norm (iterates body G i P s - Sup ?X)"
      by(auto)
    also from ey yit have "norm (iterates body G i P s - Sup ?X) < r"
      by(simp add:dist_real_def)
    finally show "\<exists>no. \<forall>n\<ge>no. norm (iterates body G n P s -
                                    Sup {f s |f. f \<in> {t P |t. t \<in> range (iterates body G)}}) < r"
      by(auto)
  qed
  moreover
  from hb cb sP have "wp do G \<longrightarrow> body od P s = Sup_trans (range (iterates body G)) P s"
    by(simp add:equiv_transD[OF lfp_iterates])
  moreover have "... = Sup {f s |f. f \<in> {t P |t. t \<in> range (iterates body G)}}"
    by(simp add:Sup_trans_def Sup_exp_def)
  ultimately show ?thesis by(simp)
qed

text {* The iterates themselves are all continuous. *}
lemma cts_iterates:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and cb: "bd_cts (wp body)"
  shows "bd_cts (iterates body G i)"
proof(induct i, simp_all)
  have "range (\<lambda>(n::nat) (s::'s). 0::real) = {\<lambda>s. 0::real}"
    by(auto)
  thus "bd_cts (\<lambda>P (s::'s). 0)"
    by(intro bd_ctsI, simp add:o_def Sup_exp_def)
next
  fix i
  assume IH: "bd_cts (iterates body G i)"
  thus "bd_cts (wp (body ;; Embed (iterates body G i) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
    by(blast intro:cts_wp_PC cts_wp_Seq cts_wp_Embed cts_wp_Skip
                   healthy_intros iterates_healthy cb hb)
qed

text {* Therefore so is the loop itself. *}
lemma cts_wp_loop:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and cb: "bd_cts (wp body)"
  shows "bd_cts (wp do G \<longrightarrow> body od)"
proof(rule bd_ctsI)
  fix M::"nat \<Rightarrow> 's expect" and b::real
  assume chain: "\<And>i. M i \<tturnstile> M (Suc i)"
     and sM: "\<And>i. sound (M i)"
     and bM: "\<And>i. bounded_by b (M i)"

  from sM bM iterates_healthy[OF hb]
  have "\<And>j i. bounded_by b (iterates body G i (M j))" by(blast)
  hence iB: "\<And>j i s. iterates body G i (M j) s \<le> b" by(auto)

  from sM bM have sSup: "sound (Sup_exp (range M))"
    by(auto intro:Sup_exp_sound)
  with lfp_iterates[OF hb cb]
  have "wp do G \<longrightarrow> body od (Sup_exp (range M)) =
        Sup_trans (range (iterates body G)) (Sup_exp (range M))"
    by(simp add:equiv_transD)
  also {
    from chain sM bM
    have "\<And>i. iterates body G i (Sup_exp (range M)) = Sup_exp (range (iterates body G i o M))"
      by(blast intro:bd_ctsD cts_iterates[OF hb cb])
    hence "{t (Sup_exp (range M)) |t. t \<in> range (iterates body G)} =
           {Sup_exp (range (t o M)) |t. t \<in> range (iterates body G)}"
      by(auto intro:sym)
    hence "Sup_trans (range (iterates body G)) (Sup_exp (range M)) =
           Sup_exp {Sup_exp (range (t \<circ> M)) |t. t \<in> range (iterates body G)}"
      by(simp add:Sup_trans_def)
  }
  also {
    have "\<And>s. {f s |f. \<exists>t. f = (\<lambda>s. Sup {f s |f. f \<in> range (t \<circ> M)}) \<and>
                           t \<in> range (iterates body G)} =
          range (\<lambda>i. Sup (range (\<lambda>j. iterates body G i (M j) s)))"
      (is "\<And>s. ?X s = ?Y s")
    proof(intro antisym subsetI)
      fix s x
      assume "x \<in> ?X s"
      then obtain t where rwx: "x = Sup {f s |f. f \<in> range (t \<circ> M)}"
                      and "t \<in> range (iterates body G)" by(auto)
      then obtain i where "t = iterates body G i" by(auto)
      with rwx have "x = Sup {f s |f. f \<in> range (\<lambda>j. iterates body G i (M j))}"
        by(simp add:o_def)
      moreover have "{f s |f. f \<in> range (\<lambda>j. iterates body G i (M j))} =
                     range (\<lambda>j. iterates body G i (M j) s)" by(auto)
      ultimately have "x = Sup (range (\<lambda>j. iterates body G i (M j) s))"
        by(simp)
      thus "x \<in> range (\<lambda>i. Sup (range (\<lambda>j. iterates body G i (M j) s)))"
        by(auto)
    next
      fix s x
      assume "x \<in> ?Y s"
      then obtain i where A: "x = Sup (range (\<lambda>j. iterates body G i (M j) s))"
        by(auto)

      have "\<And>s. {f s |f. f \<in> range (\<lambda>j. iterates body G i (M j))} =
            range (\<lambda>j. iterates body G i (M j) s)" by(auto)
      hence B: "(\<lambda>s. Sup (range (\<lambda>j. iterates body G i (M j) s))) =
             (\<lambda>s. Sup {f s |f. f \<in> range (iterates body G i o M)})"
        by(simp add:o_def)

      have C: "iterates body G i \<in> range (iterates body G)" by(auto)

      have "\<exists>f. x = f s \<and>
                (\<exists>t. f = (\<lambda>s. Sup {f s |f. f \<in> range (t \<circ> M)}) \<and>
                     t \<in> range (iterates body G))"
        by(iprover intro:A B C)
      thus "x \<in> ?X s" by(simp)
    qed
    hence "Sup_exp {Sup_exp (range (t \<circ> M)) |t. t \<in> range (iterates body G)} =
           (\<lambda>s. Sup (range (\<lambda>i. Sup (range (\<lambda>j. iterates body G i (M j) s)))))"
      by(simp add:Sup_exp_def)
  }
  also have "(\<lambda>s. Sup (range (\<lambda>i. Sup (range (\<lambda>j. iterates body G i (M j) s))))) =
             (\<lambda>s. Sup (range (\<lambda>(i,j). iterates body G i (M j) s)))"
    (is "?X = ?Y")
  proof(rule ext, rule antisym)
    fix s::'s
    show "?Y s \<le> ?X s"
    proof(rule cSup_least, blast, clarify)
      fix i j::nat
      from iB have "iterates body G i (M j) s \<le> Sup (range (\<lambda>j. iterates body G i (M j) s))"
        by(intro cSup_upper bdd_aboveI, auto)
      also from iB have "... \<le> Sup (range (\<lambda>i. Sup (range (\<lambda>j. iterates body G i (M j) s))))"
        by(intro cSup_upper cSup_least bdd_aboveI, (blast intro:cSup_least)+)
      finally show "iterates body G i (M j) s \<le>
                    Sup (range (\<lambda>i. Sup (range (\<lambda>j. iterates body G i (M j) s))))" .
    qed
    have "\<And>i j. iterates body G i (M j) s \<le>
                Sup (range (\<lambda>(i, j). iterates body G i (M j) s))"
      by(rule cSup_upper, auto intro:iB)
    thus "?X s \<le> ?Y s"
      by(intro cSup_least, blast, clarify, simp del:Sup_image_eq, blast intro:cSup_least)
  qed
  also have "... = (\<lambda>s. Sup (range (\<lambda>j .Sup (range (\<lambda>i. iterates body G i (M j) s)))))"
    (is "?X = ?Y")
  proof(rule ext, rule antisym)
    fix s::'s
    have "\<And>i j. iterates body G i (M j) s \<le>
                Sup (range (\<lambda>(i, j). iterates body G i (M j) s))"
      by(rule cSup_upper, auto intro:iB)
    thus "?Y s \<le> ?X s"
      by(intro cSup_least, blast, clarify, simp del:Sup_image_eq, blast intro:cSup_least)
    show "?X s \<le> ?Y s"
    proof(rule cSup_least, blast, clarify)
      fix i j::nat
      from iB have "iterates body G i (M j) s \<le> Sup (range (\<lambda>i. iterates body G i (M j) s))"
        by(intro cSup_upper bdd_aboveI, auto)
      also from iB have "... \<le> Sup (range (\<lambda>j. Sup (range (\<lambda>i. iterates body G i (M j) s))))"
        by(intro cSup_upper cSup_least bdd_aboveI, blast, blast intro:cSup_least)
      finally show "iterates body G i (M j) s \<le>
                    Sup (range (\<lambda>j. Sup (range (\<lambda>i. iterates body G i (M j) s))))" .
    qed
  qed
  also {
    have "\<And>s. range (\<lambda>j. Sup (range (\<lambda>i. iterates body G i (M j) s))) =
               {f s |f. f \<in> range ((\<lambda>P s. Sup {f s |f. \<exists>t. f = t P \<and>
               t \<in> range (iterates body G)}) \<circ> M)}" (is "\<And>s. ?X s = ?Y s")
    proof(intro antisym subsetI)
      fix s x
      assume "x \<in> ?X s"
      then obtain j where rwx: "x = Sup (range (\<lambda>i. iterates body G i (M j) s))" by(auto)
      moreover {
        have "\<And>s. range (\<lambda>i. iterates body G i (M j) s) =
                   {f s |f. \<exists>t. f = t (M j) \<and> t \<in> range (iterates body G)}"
          by(auto)
        hence "(\<lambda>s. Sup (range (\<lambda>i. iterates body G i (M j) s))) \<in>
              range ((\<lambda>P s. Sup {f s |f.
                           \<exists>t. f = t P \<and> t \<in> range (iterates body G)}) \<circ> M)"
          by(simp add:o_def)
      }
      ultimately show "x \<in> ?Y s" by(auto)
    next
      fix s x
      assume "x \<in> ?Y s"
      then obtain P where rwx: "x = P s"
                      and Pin: "P \<in> range ((\<lambda>P s. Sup {f s |f.
                            \<exists>t. f = t P \<and> t \<in> range (iterates body G)}) \<circ> M)"
        by(auto)
      then obtain j where "P = (\<lambda>s. Sup {f s |f. \<exists>t. f = t (M j) \<and>
                                                 t \<in> range (iterates body G)})"
        by(auto)
      also {
        have "\<And>s. {f s |f. \<exists>t. f = t (M j) \<and> t \<in> range (iterates body G)} =
                  range (\<lambda>i. iterates body G i (M j) s)" by(auto)
        hence "(\<lambda>s. Sup {f s |f. \<exists>t. f = t (M j) \<and> t \<in> range (iterates body G)}) =
               (\<lambda>s. Sup (range (\<lambda>i. iterates body G i (M j) s)))"
          by(simp)
      }
      finally have "x = Sup (range (\<lambda>i. iterates body G i (M j) s))"
        by(simp add:rwx)
      thus "x \<in> ?X s" by(simp)
    qed
    hence "(\<lambda>s. Sup (range (\<lambda>j .Sup (range (\<lambda>i. iterates body G i (M j) s))))) =
          Sup_exp (range (Sup_trans (range (iterates body G)) o M))"
      by(simp add:Sup_exp_def Sup_trans_def)
  }
  also have "Sup_exp (range (Sup_trans (range (iterates body G)) o M)) =
             Sup_exp (range (wp do G \<longrightarrow> body od o M))"
    by(simp add:o_def equiv_transD[OF lfp_iterates, OF hb cb, OF sM])
  finally show "wp do G \<longrightarrow> body od (Sup_exp (range M)) =
                Sup_exp (range (wp do G \<longrightarrow> body od o M))" .
qed

lemmas cts_intros =
  cts_wp_Abort  cts_wp_Skip
  cts_wp_Seq    cts_wp_PC
  cts_wp_DC     cts_wp_Embed
  cts_wp_Apply  cts_wp_SetDC
  cts_wp_SetPC  cts_wp_Bind
  cts_wp_repeat

end


(*  Title:      HOL/Auth/Guard/Guard_Shared.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>lemmas on guarded messages for protocols with symmetric keys\<close>

theory Guard_Shared imports Guard GuardK "../Shared" begin

subsection\<open>Extensions to Theory \<open>Shared\<close>\<close>

declare initState.simps [simp del]

subsubsection\<open>a little abbreviation\<close>

abbreviation
  Ciph :: "agent => msg => msg" where
  "Ciph A X == Crypt (shrK A) X"

subsubsection\<open>agent associated to a key\<close>

definition agt :: "key => agent" where
"agt K == SOME A. K = shrK A"

lemma agt_shrK [simp]: "agt (shrK A) = A"
by (simp add: agt_def)

subsubsection\<open>basic facts about \<^term>\<open>initState\<close>\<close>

lemma no_Crypt_in_parts_init [simp]: "Crypt K X \<notin> parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X \<notin> analz (initState A)"
by auto

lemma no_shrK_in_analz_init [simp]: "A \<notin> bad
\<Longrightarrow> Key (shrK A) \<notin> analz (initState Spy)"
by (auto simp: initState.simps)

lemma shrK_notin_initState_Friend [simp]: "A \<noteq> Friend C
\<Longrightarrow> Key (shrK A) \<notin> parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection\<open>sets of symmetric keys\<close>

definition shrK_set :: "key set => bool" where
"shrK_set Ks \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> (\<exists>A. K = shrK A)"

lemma in_shrK_set: "\<lbrakk>shrK_set Ks; K \<in> Ks\<rbrakk> \<Longrightarrow> \<exists>A. K = shrK A"
by (simp add: shrK_set_def)

lemma shrK_set1 [iff]: "shrK_set {shrK A}"
by (simp add: shrK_set_def)

lemma shrK_set2 [iff]: "shrK_set {shrK A, shrK B}"
by (simp add: shrK_set_def)

subsubsection\<open>sets of good keys\<close>

definition good :: "key set \<Rightarrow> bool" where
"good Ks \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> agt K \<notin> bad"

lemma in_good: "\<lbrakk>good Ks; K \<in> Ks\<rbrakk> \<Longrightarrow> agt K \<notin> bad"
by (simp add: good_def)

lemma good1 [simp]: "A \<notin> bad \<Longrightarrow> good {shrK A}"
by (simp add: good_def)

lemma good2 [simp]: "\<lbrakk>A \<notin> bad; B \<notin> bad\<rbrakk> \<Longrightarrow> good {shrK A, shrK B}"
by (simp add: good_def)

subsection\<open>Proofs About Guarded Messages\<close>

subsubsection\<open>small hack\<close>

lemma shrK_is_invKey_shrK: "shrK A = invKey (shrK A)"
by simp

lemmas shrK_is_invKey_shrK_substI = shrK_is_invKey_shrK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n \<in> parts {X} \<Longrightarrow> Crypt (shrK A) X \<in> guard n {shrK A}"
apply (rule shrK_is_invKey_shrK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection\<open>guardedness results on nonces\<close>

lemma guard_ciph [simp]: "shrK A \<in> Ks \<Longrightarrow> Ciph A X \<in> guard n Ks"
by (rule Guard_Nonce, simp)

lemma guardK_ciph [simp]: "shrK A \<in> Ks \<Longrightarrow> Ciph A X \<in> guardK n Ks"
by (rule Guard_Key, simp)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
\<Longrightarrow> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n \<notin> used evs
\<Longrightarrow> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "\<lbrakk>evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "\<lbrakk>evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "\<lbrakk>evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection\<open>guardedness results on keys\<close>

lemma GuardK_init [simp]: "n \<notin> range shrK \<Longrightarrow> GuardK n Ks (initState B)"
by (induct B, auto simp: GuardK_def initState.simps)

lemma GuardK_knows_max': "\<lbrakk>GuardK n A (knows_max' C evs); n \<notin> range shrK\<rbrakk>
\<Longrightarrow> GuardK n A (knows_max C evs)"
by (simp add: knows_max_def)

lemma Key_not_used_GuardK_spies [dest]: "Key n \<notin> used evs
\<Longrightarrow> GuardK n A (spies evs)"
by (auto simp: GuardK_def dest: not_used_not_known parts_sub)

lemma Key_not_used_GuardK [dest]: "\<lbrakk>evs \<in> p; Key n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> GuardK n A (knows (Friend C) evs)"
by (auto simp: GuardK_def dest: known_used parts_trans)

lemma Key_not_used_GuardK_max [dest]: "\<lbrakk>evs \<in> p; Key n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> GuardK n A (knows_max (Friend C) evs)"
by (auto simp: GuardK_def dest: known_max_used parts_trans)

lemma Key_not_used_GuardK_max' [dest]: "\<lbrakk>evs \<in> p; Key n \<notin> used evs;
Gets_correct p; one_step p\<rbrakk> \<Longrightarrow> GuardK n A (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in GuardK_mono)
by (auto simp: knows_max_def)

subsubsection\<open>regular protocols\<close>

definition regular :: "event list set => bool" where
"regular p \<equiv> \<forall>evs A. evs \<in> p \<longrightarrow> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"

lemma shrK_parts_iff_bad [simp]: "\<lbrakk>evs \<in> p; regular p\<rbrakk> \<Longrightarrow>
(Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (auto simp: regular_def)

lemma shrK_analz_iff_bad [simp]: "\<lbrakk>evs \<in> p; regular p\<rbrakk> \<Longrightarrow>
(Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Guard_Nonce_analz: "\<lbrakk>Guard n Ks (spies evs); evs \<in> p;
shrK_set Ks; good Ks; regular p\<rbrakk> \<Longrightarrow> Nonce n \<notin> analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_shrK_set, simp+, clarify)
apply (frule_tac A=A in shrK_analz_iff_bad)
by (simp add: knows_decomp)+

lemma GuardK_Key_analz:
  assumes "GuardK n Ks (spies evs)" "evs \<in> p" "shrK_set Ks"
    "good Ks" "regular p" "n \<notin> range shrK"
  shows "Key n \<notin> analz (spies evs)"
proof (rule ccontr)
  assume "\<not> Key n \<notin> analz (knows Spy evs)"
  then have *: "Key n \<in> analz (spies' evs \<union> initState Spy)"
    by (simp add: knows_decomp)
  from \<open>GuardK n Ks (spies evs)\<close>
  have "GuardK n Ks (spies' evs \<union> initState Spy)"
    by (simp add: knows_decomp)
  then have "GuardK n Ks (spies' evs)"
    and "finite (spies' evs)" "keyset (initState Spy)"
    by simp_all
  moreover have "Key n \<notin> initState Spy"
    using \<open>n \<notin> range shrK\<close> by (simp add: image_iff initState_Spy)
  ultimately obtain K
    where "K \<in> Ks" and **: "Key K \<in> analz (spies' evs \<union> initState Spy)"
    using * by (auto dest: GuardK_invKey_keyset)
  from \<open>K \<in> Ks\<close> and \<open>good Ks\<close> have "agt K \<notin> bad"
    by (auto dest: in_good)
  from \<open>K \<in> Ks\<close> \<open>shrK_set Ks\<close> obtain A
    where "K = shrK A"
    by (auto dest: in_shrK_set)
  then have "agt K \<in> bad"
    using ** \<open>evs \<in> p\<close> \<open>regular p\<close> shrK_analz_iff_bad [of evs p "agt K"]
    by (simp add: knows_decomp)
  with \<open>agt K \<notin> bad\<close> show False by simp
qed

end


subsection \<open>1-out-of-4 OT to GMW\<close>

text\<open>We prove security for the gates of the GMW protocol in the semi honest model. We assume security on
1-out-of-4 OT.\<close>

theory GMW imports
  OT14
begin

type_synonym share_1 = bool
type_synonym share_2 = bool

type_synonym shares_1 = "bool list"
type_synonym shares_2 = "bool list"

type_synonym msgs_14_OT = "(bool \<times> bool \<times> bool \<times> bool)"
type_synonym choice_14_OT = "(bool \<times> bool)"

type_synonym share_wire = "(share_1 \<times> share_2)"

locale gmw_base =
  fixes S1_14_OT :: "msgs_14_OT \<Rightarrow> unit \<Rightarrow> 'v_14_OT1 spmf" \<comment> \<open>simulated view for party 1 of OT14\<close>
    and R1_14_OT :: "msgs_14_OT \<Rightarrow> choice_14_OT \<Rightarrow> 'v_14_OT1 spmf" \<comment> \<open>real view for party 1 of OT14\<close>
    and S2_14_OT :: "choice_14_OT \<Rightarrow> bool \<Rightarrow> 'v_14_OT2 spmf"
    and R2_14_OT :: "msgs_14_OT \<Rightarrow> choice_14_OT \<Rightarrow> 'v_14_OT2 spmf"
    and protocol_14_OT :: "msgs_14_OT \<Rightarrow> choice_14_OT \<Rightarrow> (unit \<times> bool) spmf"
    and adv_14_OT :: real
  assumes P1_OT_14_adv_bound: "sim_det_def.adv_P1 R1_14_OT S1_14_OT funct_14_OT M C D \<le> adv_14_OT" \<comment> \<open>bound the advantage of party 1 in the 1-out-of-4 OT\<close>
    and P2_OT_12_inf_theoretic: "sim_det_def.perfect_sec_P2 R2_14_OT S2_14_OT funct_14_OT M C" \<comment> \<open>information theoretic security for party 2 in the 1-out-of-4 OT\<close>
    and correct_14: "funct_OT_14 msgs C = protocol_14_OT msgs C" \<comment> \<open>correctness of the 1-out-of-4 OT\<close>
    and lossless_R1_14_OT: "lossless_spmf (R1_14_OT (m1,m2,m3,m4) (c0,c1))"
    and lossless_R2_14_OT: "lossless_spmf (R2_14_OT (m1,m2,m3,m4) (c0,c1))"
    and lossless_S1_14_OT: "lossless_spmf (S1_14_OT (m1,m2,m3,m4) ())"
    and lossless_S2_14_OT: "lossless_spmf (S2_14_OT (c0,c1) b)"
    and lossless_protocol_14_OT: "lossless_spmf (protocol_14_OT S C)"
    and lossless_funct_14_OT: "lossless_spmf (funct_14_OT M C)"
begin

lemma  funct_14: "funct_OT_14 (m00,m01,m10,m11) (c0,c1)
                      = return_spmf ((),if c0 then (if c1 then m11 else m10) else (if c1 then m01 else m00))"
  by(simp add: funct_OT_14_def)

sublocale OT_14_sim: sim_det_def R1_14_OT S1_14_OT R2_14_OT S2_14_OT funct_14_OT protocol_14_OT
  unfolding sim_det_def_def
  by(simp add: lossless_R1_14_OT lossless_S1_14_OT lossless_funct_14_OT lossless_R2_14_OT lossless_S2_14_OT)

lemma inf_th_14_OT_P4: "R2_14_OT msgs C = (funct_OT_14 msgs C \<bind> (\<lambda> (s1, s2). S2_14_OT C s2))"
  using P2_OT_12_inf_theoretic sim_det_def.perfect_sec_P2_def OT_14_sim.perfect_sec_P2_def by auto

lemma ass_adv_14_OT: "\<bar>spmf (bind_spmf (S1_14_OT msgs ()) (\<lambda> view. (D view))) True -
                    spmf (bind_spmf (R1_14_OT msgs (c0,c1)) (\<lambda> view. (D view))) True \<bar> \<le> adv_14_OT"
  (is "?lhs \<le> adv_14_OT")
proof-
  have "funct_OT_14 (m0,m1,m2,m3) (c0, c1) \<bind> (\<lambda>(o1, o2). S1_14_OT (m0,m1,m2,m3) () \<bind> D) = S1_14_OT (m0,m1,m2,m3) () \<bind> D"
    for m0 m1 m2 m3 by(simp add: funct_14)
  hence funct: "funct_OT_14 msgs (c0, c1) \<bind> (\<lambda>(o1, o2). S1_14_OT msgs () \<bind> D) = S1_14_OT msgs () \<bind> D"
    by (metis prod_cases4)
  have "?lhs = \<bar>spmf (bind_spmf (R1_14_OT msgs (c0,c1)) (\<lambda> view. (D view))) True
                  - spmf (bind_spmf (S1_14_OT msgs ()) (\<lambda> view. (D view))) True\<bar>"
    by linarith
  hence "... = \<bar>(spmf (R1_14_OT msgs (c0,c1) \<bind> (\<lambda> view. D view)) True)
            - spmf (funct_OT_14 msgs (c0,c1) \<bind> (\<lambda> (o1, o2). S1_14_OT msgs o1 \<bind> (\<lambda> view. D view))) True\<bar>"
    by(simp add: funct)
  thus ?thesis using P1_OT_14_adv_bound sim_det_def.adv_P1_def
    by (simp add: OT_14_sim.adv_P1_def abs_minus_commute)
qed

text \<open>The sharing scheme\<close>

definition share :: "bool \<Rightarrow> share_wire spmf"
  where "share x = do {
    a\<^sub>1 \<leftarrow> coin_spmf;
    let b\<^sub>1 = x \<oplus> a\<^sub>1;
    return_spmf (a\<^sub>1, b\<^sub>1)}"

lemma lossless_share [simp]: "lossless_spmf (share x)"
  by(simp add: share_def)

definition reconstruct :: "(share_1 \<times> share_2) \<Rightarrow> bool spmf"
  where "reconstruct shares = do {
    let (a,b) = shares;
    return_spmf (a \<oplus> b)}"

lemma lossless_reconstruct [simp]: "lossless_spmf (reconstruct s)"
  by(simp add: reconstruct_def split_def)

lemma reconstruct_share : "(bind_spmf (share x) reconstruct) = (return_spmf x)"
proof-
  have "y = (y = x) = x" for y by auto
  thus ?thesis
    by(auto simp add: share_def reconstruct_def bind_spmf_const eq_commute)
qed

lemma "(reconstruct (s1,s2) \<bind> (\<lambda> rec. share rec \<bind> (\<lambda> shares. reconstruct shares))) = return_spmf (s1 \<oplus> s2)"
  apply(simp add: reconstruct_share reconstruct_def share_def)
  apply(cases s1; cases s2) by(auto simp add: bind_spmf_const)

definition xor_evaluate ::  "bool \<Rightarrow> bool \<Rightarrow> bool spmf"
  where "xor_evaluate A B = return_spmf (A \<oplus> B)"

definition xor_funct :: "share_wire \<Rightarrow> share_wire \<Rightarrow> (bool \<times> bool) spmf"
  where "xor_funct A B = do {
    let (a1, b1) = A;
    let (a2,b2) = B;
    return_spmf (a1 \<oplus> a2, b1 \<oplus> b2)}"

lemma lossless_xor_funct: "lossless_spmf (xor_funct A B)"
  by(simp add: xor_funct_def split_def)

definition xor_protocol :: "share_wire \<Rightarrow> share_wire \<Rightarrow> (bool \<times> bool) spmf"
  where "xor_protocol A B = do {
    let (a1, b1) = A;
    let (a2,b2) = B;
    return_spmf (a1 \<oplus> a2, b1 \<oplus> b2)}"

lemma lossless_xor_protocol: "lossless_spmf (xor_protocol A B)"
  by(simp add: xor_protocol_def split_def)

lemma share_xor_reconstruct:
  shows "share x \<bind> (\<lambda> w1. share y \<bind> (\<lambda> w2. xor_protocol w1 w2
              \<bind> (\<lambda> (a, b). reconstruct (a, b)))) = xor_evaluate x y"
proof-
  have "(ya = (\<not> yb)) = ((x = (\<not> ya)) = (y = (\<not> yb))) = (x = (\<not> y))" for ya yb
    by auto
  then show ?thesis
    by(simp add: share_def xor_protocol_def reconstruct_def xor_evaluate_def bind_spmf_const)
qed

definition R1_xor :: "(bool \<times> bool) \<Rightarrow> (bool \<times> bool) \<Rightarrow> (bool \<times> bool) spmf"
  where "R1_xor A B = return_spmf A"

lemma lossless_R1_xor: "lossless_spmf (R1_xor A B)"
  by(simp add: R1_xor_def)

definition S1_xor :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> (bool \<times> bool) spmf"
  where "S1_xor A out  = return_spmf A"

lemma lossless_S1_xor: "lossless_spmf (S1_xor A out)"
  by(simp add: S1_xor_def)

lemma P1_xor_inf_th: "R1_xor A B = xor_funct A B \<bind> (\<lambda> (out1, out2). S1_xor A out1)"
  by(simp add: R1_xor_def xor_funct_def S1_xor_def split_def)

definition R2_xor :: "(bool \<times> bool) \<Rightarrow> (bool \<times> bool) \<Rightarrow> (bool \<times> bool) spmf"
  where "R2_xor A B = return_spmf B"

lemma lossless_R2_xor: "lossless_spmf (R2_xor A B)"
  by(simp add: R2_xor_def)

definition S2_xor :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> (bool \<times> bool) spmf"
  where "S2_xor B out  = return_spmf B"

lemma lossless_S2_xor: "lossless_spmf (S2_xor A out)"
  by(simp add: S2_xor_def)

lemma P2_xor_inf_th: "R2_xor A B = xor_funct A B \<bind> (\<lambda> (out1, out2). S2_xor B out2)"
  by(simp add: R2_xor_def xor_funct_def S2_xor_def split_def)

sublocale xor_sim_det: sim_det_def  R1_xor S1_xor R2_xor S2_xor xor_funct xor_protocol
  unfolding sim_det_def_def
  by(simp add: lossless_R1_xor lossless_S1_xor lossless_R2_xor lossless_S2_xor lossless_xor_funct)

lemma "xor_sim_det.perfect_sec_P1 m1 m2"
  by(simp add: xor_sim_det.perfect_sec_P1_def P1_xor_inf_th)

lemma "xor_sim_det.perfect_sec_P2 m1 m2"
  by(simp add: xor_sim_det.perfect_sec_P2_def P2_xor_inf_th)

definition and_funct :: "(share_1 \<times> share_2) \<Rightarrow> (share_1 \<times> share_2) \<Rightarrow> share_wire spmf"
  where "and_funct A B = do {
    let (a1, a2) = A;
    let (b1,b2) = B;
    \<sigma> \<leftarrow> coin_spmf;
    return_spmf (\<sigma>, \<sigma> \<oplus> ((a1 \<oplus> b1) \<and> (a2 \<oplus> b2)))}"

lemma lossless_and_funct: "lossless_spmf (and_funct A B)"
  by(simp add: and_funct_def split_def)

definition and_evaluate :: "bool \<Rightarrow> bool \<Rightarrow> bool spmf"
  where "and_evaluate A B  = return_spmf (A \<and> B)"

definition and_protocol :: "share_wire \<Rightarrow> share_wire \<Rightarrow> share_wire spmf"
  where "and_protocol A B = do {
    let (a1, b1) = A;
    let (a2,b2) = B;
    \<sigma> \<leftarrow> coin_spmf;
    let s0 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (b1 \<oplus> False));
    let s1 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (b1 \<oplus> True));
    let s2 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (b1 \<oplus> False));
    let s3 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (b1 \<oplus> True));
    (_, s) \<leftarrow> protocol_14_OT (s0,s1,s2,s3) (a2,b2);
    return_spmf (\<sigma>, s)}"

lemma lossless_and_protocol: "lossless_spmf (and_protocol A B)"
  by(simp add: and_protocol_def split_def lossless_protocol_14_OT)

lemma and_correct: "and_protocol (a1, b1) (a2,b2) = and_funct (a1, b1) (a2,b2)"
  apply(simp add: and_protocol_def and_funct_def correct_14[symmetric] funct_14)
  by(cases b2 ; cases b1; cases a1; cases a2; auto)

lemma share_and_reconstruct:
  shows "share x \<bind> (\<lambda> (a1,a2). share y \<bind> (\<lambda> (b1,b2).
             and_protocol (a1,b1) (a2,b2) \<bind> (\<lambda> (a, b). reconstruct (a, b)))) = and_evaluate x y"
proof-
  have "(yc = (\<not> (if x = (\<not> ya) then if snd (snd (ya, x = (\<not> ya)), snd (yb, y = (\<not> yb))) then yc
            = (fst (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb))) \<or> snd (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb))))
                   else yc = (fst (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb))) \<or> \<not> snd (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb))))
                       else if snd (snd (ya, x = (\<not> ya)), snd (yb, y = (\<not> yb))) then yc = (fst (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb)))
                            \<longrightarrow> snd (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb))))
                                  else yc = (fst (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb)))
                                      \<longrightarrow> \<not> snd (fst (ya, x = (\<not> ya)), fst (yb, y = (\<not> yb))))))) = (x \<and> y)"
    for yc yb ya by auto
  then show ?thesis
    by(auto simp add: share_def reconstruct_def and_protocol_def and_evaluate_def split_def correct_14[symmetric] funct_14 bind_spmf_const Let_def)
qed

definition and_R1 :: "(share_1 \<times> share_1) \<Rightarrow> (share_2 \<times> share_2) \<Rightarrow> (((share_1 \<times> share_1) \<times> bool \<times> 'v_14_OT1)  \<times> (share_1 \<times> share_2)) spmf"
  where "and_R1 A B = do {
    let (a1, a2) = A;
    let (b1,b2) = B;
    \<sigma> \<leftarrow> coin_spmf;
    let s0 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False));
    let s1 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True));
    let s2 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False));
    let s3 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True));
    V \<leftarrow> R1_14_OT (s0,s1,s2,s3) (b1,b2);
    (_, s) \<leftarrow> protocol_14_OT (s0,s1,s2,s3) (b1,b2);
    return_spmf (((a1,a2), \<sigma>, V), (\<sigma>, s))}"

lemma lossless_and_R1: "lossless_spmf (and_R1 A B)"
  apply(simp add: and_R1_def split_def lossless_R1_14_OT lossless_protocol_14_OT Let_def)
  by (metis prod.collapse lossless_R1_14_OT)

definition S1_and :: "(share_1 \<times> share_1) \<Rightarrow> bool \<Rightarrow> (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1)) spmf"
  where "S1_and A \<sigma> = do {
    let (a1,a2) = A;
    let s0 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False));
    let s1 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True));
    let s2 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False));
    let s3 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True));
    V \<leftarrow> S1_14_OT (s0,s1,s2,s3) ();
    return_spmf ((a1,a2), \<sigma>, V)}"

definition out1 :: "(share_1 \<times> share_1) \<Rightarrow> (share_2 \<times> share_2) \<Rightarrow> bool \<Rightarrow> (share_1 \<times> share_2) spmf"
  where "out1 A B \<sigma> = do {
    let (a1,a2) = A;
    let (b1,b2) = B;
    return_spmf (\<sigma>, \<sigma> \<oplus> ((a1 \<oplus> b1) \<and> (a2 \<oplus> b2)))}"

definition S1_and' :: "(share_1 \<times> share_1) \<Rightarrow> (share_2 \<times> share_2) \<Rightarrow> bool \<Rightarrow> (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) spmf"
  where "S1_and' A B \<sigma> = do {
    let (a1,a2) = A;
    let (b1,b2) = B;
    let s0 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False));
    let s1 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True));
    let s2 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False));
    let s3 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True));
    V \<leftarrow> S1_14_OT (s0,s1,s2,s3) ();
    return_spmf (((a1,a2), \<sigma>, V), (\<sigma>, \<sigma> \<oplus> ((a1 \<oplus> b1) \<and> (a2 \<oplus> b2))))}"

lemma sec_ex_P1_and:
  shows "\<exists> (A :: 'v_14_OT1 \<Rightarrow> bool \<Rightarrow> bool spmf).
          \<bar>spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1)
            \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) \<Rightarrow> bool spmf))) True - spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> D) True\<bar> =
              \<bar>spmf (coin_spmf \<bind> (\<lambda> \<sigma>. S1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) ()
                \<bind>  (\<lambda> view. A view \<sigma>))) True
                  - spmf (coin_spmf \<bind> (\<lambda> \<sigma>. R1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) (b1, b2)
                    \<bind> (\<lambda> view. A view \<sigma>))) True\<bar>"
  including monad_normalisation
proof-
  define A' where "A' == \<lambda> view \<sigma>.  (D (((a1,a2), \<sigma>, view), (\<sigma>, \<sigma> \<oplus> ((a1 \<oplus> b1) \<and> (a2 \<oplus> b2)))))"
  have "\<bar>spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1)
          \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) \<Rightarrow> bool spmf))) True -
            spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (bool \<times> bool)) \<Rightarrow> bool spmf)) True\<bar> =
              \<bar>spmf (coin_spmf \<bind> (\<lambda> \<sigma> :: bool. S1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) ()
                \<bind>  (\<lambda> view. A' view \<sigma>))) True - spmf (coin_spmf \<bind> (\<lambda> \<sigma>. R1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) (b1, b2)
                  \<bind> (\<lambda> view. A' view \<sigma>))) True\<bar>"
    by(auto simp add: S1_and'_def A'_def and_funct_def and_R1_def Let_def split_def correct_14[symmetric] funct_14; cases a1; cases a2; cases b1; cases b2; auto)
  then show ?thesis by auto
qed

lemma bound_14_OT:
  "\<bar>spmf (coin_spmf \<bind> (\<lambda> \<sigma>. S1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) ()
        \<bind>  (\<lambda> view. (A :: 'v_14_OT1 \<Rightarrow> bool \<Rightarrow> bool spmf) view \<sigma>))) True - spmf (coin_spmf \<bind> (\<lambda> \<sigma>. R1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) (b1, b2)
              \<bind> (\<lambda> view. A view \<sigma>))) True\<bar> \<le> adv_14_OT"
  (is "?lhs \<le> adv_14_OT")
proof-
  have int1: "integrable (measure_spmf coin_spmf) (\<lambda>x. spmf (S1_14_OT (x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> True), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> True)) () \<bind> (\<lambda>view. A view x)) True)"
    and int2: "integrable (measure_spmf coin_spmf) (\<lambda>x. spmf (R1_14_OT (x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> True), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> True)) (b1, b2) \<bind> (\<lambda>view. A view x)) True)"
    by(rule measure_spmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)+
  have "?lhs = \<bar>LINT x|measure_spmf coin_spmf.
        spmf (S1_14_OT (x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> True), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> True)) () \<bind> (\<lambda>view. A view x)) True -
        spmf (R1_14_OT (x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> False \<and> a2 \<oplus> True), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> False), x \<oplus> (a1 \<oplus> True \<and> a2 \<oplus> True)) (b1, b2) \<bind> (\<lambda>view. A view x)) True\<bar>"
    apply(subst (1 2) spmf_bind) using int1 int2 by simp
  also have "... \<le> LINT x|measure_spmf coin_spmf. \<bar>spmf (S1_14_OT (x = (a1 \<longrightarrow> \<not> a2), x = (a1 \<longrightarrow> a2), x = (a1 \<or> \<not> a2), x = (a1 \<or> a2)) () \<bind> (\<lambda>view. A view x)) True
                - spmf (R1_14_OT (x = (a1 \<longrightarrow> \<not> a2), x = (a1 \<longrightarrow> a2), x = (a1 \<or> \<not> a2), x = (a1 \<or> a2)) (b1, b2) \<bind> (\<lambda>view. A view x)) True\<bar>"
    by(rule integral_abs_bound[THEN order_trans]; simp add: split_beta)
  ultimately have "?lhs \<le> LINT x|measure_spmf coin_spmf. \<bar>spmf (S1_14_OT (x = (a1 \<longrightarrow> \<not> a2), x = (a1 \<longrightarrow> a2), x = (a1 \<or> \<not> a2), x = (a1 \<or> a2)) () \<bind> (\<lambda>view. A view x)) True
                - spmf (R1_14_OT (x = (a1 \<longrightarrow> \<not> a2), x = (a1 \<longrightarrow> a2), x = (a1 \<or> \<not> a2), x = (a1 \<or> a2)) (b1, b2) \<bind> (\<lambda>view. A view x)) True\<bar>"
    by simp
  also have "LINT x|measure_spmf coin_spmf. \<bar>spmf (S1_14_OT (x = (a1 \<longrightarrow> \<not> a2), x = (a1 \<longrightarrow> a2), x = (a1 \<or> \<not> a2), x = (a1 \<or> a2)) () \<bind> (\<lambda>view. A view x)) True
                - spmf (R1_14_OT (x = (a1 \<longrightarrow> \<not> a2), x = (a1 \<longrightarrow> a2), x = (a1 \<or> \<not> a2), x = (a1 \<or> a2)) (b1, b2) \<bind> (\<lambda>view. A view x)) True\<bar> \<le> adv_14_OT"
    apply(rule integral_mono[THEN order_trans])
       apply(rule measure_spmf.integrable_const_bound[where B=2])
        apply clarsimp
        apply(rule abs_triangle_ineq4[THEN order_trans])
        apply(cases a1) apply(cases a2)
    subgoal for M
      using pmf_le_1[of "R1_14_OT (\<not> M, M, M, M) (b1,b2) \<bind>  (\<lambda> view. A view M)" "Some True"]
        pmf_le_1[of "S1_14_OT (\<not> M, M, M, M) () \<bind>  (\<lambda> view. A view M)" "Some True"]
      by simp
    subgoal for M
      using pmf_le_1[of "R1_14_OT  (M, \<not> M, M, M) (b1,b2) \<bind>  (\<lambda> view. A view M)" "Some True"]
        pmf_le_1[of "S1_14_OT (M, \<not> M, M, M) () \<bind>  (\<lambda> view. A view M)" "Some True"]
      by simp
        apply(cases a2) apply(auto)
    subgoal for M
      using pmf_le_1[of "R1_14_OT  (M, M, \<not> M, M) (b1,b2) \<bind>  (\<lambda> view. A view M)" "Some True"]
        pmf_le_1[of "S1_14_OT (M, M, \<not> M, M) () \<bind>  (\<lambda> view. A view M)" "Some True"]
      by(simp)
    subgoal for M
      using pmf_le_1[of "R1_14_OT  (M, M, M, \<not> M) (b1,b2) \<bind>  (\<lambda> view. A view M)" "Some True"]
        pmf_le_1[of "S1_14_OT (M, M, M, \<not> M) () \<bind>  (\<lambda> view. A view M)" "Some True"]
      by(simp)
    using ass_adv_14_OT by fast
  ultimately show ?thesis by simp
qed

lemma security_and_P1:
  shows "\<bar>spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1)
              \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) \<Rightarrow> bool spmf))) True -
                    spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> D) True\<bar> \<le> adv_14_OT"
proof-
  obtain A :: "'v_14_OT1 \<Rightarrow> bool \<Rightarrow> bool spmf" where A:
    "\<bar>spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1) \<bind> D)) True - spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> D) True\<bar> =
       \<bar>spmf (coin_spmf \<bind> (\<lambda> \<sigma>. S1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) ()
         \<bind>  (\<lambda> view. A view \<sigma>))) True - spmf (coin_spmf
           \<bind> (\<lambda> \<sigma>. R1_14_OT ((\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False))), (\<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True)))) (b1, b2)
             \<bind> (\<lambda> view. A view \<sigma>))) True\<bar>"
    using sec_ex_P1_and by blast
  then show ?thesis using bound_14_OT[of "a1" "a2" "A" "b1" "b2" ] by metis
qed

lemma security_and_P1':
  shows "\<bar>spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> D) True -
           spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1)
            \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) \<Rightarrow> bool spmf))) True\<bar> \<le> adv_14_OT"
proof-
  have "\<bar>spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> D) True -
          spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1)
            \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) \<Rightarrow> bool spmf))) True\<bar> =
              \<bar>spmf ((and_funct (a1, a2) (b1,b2)) \<bind> (\<lambda> (s1, s2). (S1_and' (a1,a2) (b1,b2) s1)
                \<bind> (D :: (((bool \<times> bool) \<times> bool \<times> 'v_14_OT1) \<times> (share_1 \<times> share_2)) \<Rightarrow> bool spmf))) True -
                  spmf ((and_R1 (a1, a2) (b1,b2)) \<bind> D) True\<bar>" using abs_minus_commute by blast
  thus ?thesis using security_and_P1 by simp
qed

definition and_R2 :: "(share_1 \<times> share_2) \<Rightarrow> (share_2 \<times> share_1) \<Rightarrow> (((bool \<times> bool) \<times> 'v_14_OT2) \<times> (share_1 \<times> share_2)) spmf"
  where "and_R2 A B = do {
    let (a1, a2) = A;
    let (b1,b2) = B;
    \<sigma> \<leftarrow> coin_spmf;
    let s0 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> False));
    let s1 = \<sigma> \<oplus> ((a1 \<oplus> False) \<and> (a2 \<oplus> True));
    let s2 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> False));
    let s3 = \<sigma> \<oplus> ((a1 \<oplus> True) \<and> (a2 \<oplus> True));
    (_, s) \<leftarrow> protocol_14_OT (s0,s1,s2,s3) B;
    V \<leftarrow> R2_14_OT (s0,s1,s2,s3) B;
    return_spmf ((B, V), (\<sigma>, s))}"

lemma lossless_and_R2: "lossless_spmf (and_R2 A B)"
  apply(simp add: and_R2_def split_def lossless_R2_14_OT lossless_protocol_14_OT Let_def)
  by (metis lossless_R2_14_OT prod.collapse)

definition S2_and :: "(share_1 \<times> share_2) \<Rightarrow> bool \<Rightarrow> (((bool \<times> bool) \<times> 'v_14_OT2)) spmf"
  where "S2_and B s2 =  do {
    let (a2,b2) = B;
    V :: 'v_14_OT2 \<leftarrow> S2_14_OT (a2,b2) s2;
    return_spmf ((B, V))}"

definition out2 :: "(share_1 \<times> share_2) \<Rightarrow> (share_1 \<times> share_2) \<Rightarrow> bool \<Rightarrow> (share_1 \<times> share_2) spmf"
  where "out2 B A s2 = do {
    let (a1, b1) = A;
    let (a2,b2) = B;
    let s1 = s2 \<oplus> ((a1 \<oplus> a2) \<and> (b1 \<oplus> b2));
    return_spmf (s1, s2)}"

definition S2_and' :: "(share_1 \<times> share_2) \<Rightarrow> (share_1 \<times> share_2) \<Rightarrow> bool \<Rightarrow> (((bool \<times> bool) \<times> 'v_14_OT2) \<times> (share_1 \<times> share_2)) spmf"
  where "S2_and' B A s2 =  do {
    let (a1, a2) = A;
    let (b1,b2) = B;
    V :: 'v_14_OT2 \<leftarrow> S2_14_OT B s2;
    let s1 = s2 \<oplus> ((a1 \<oplus> b1) \<and> (a2 \<oplus> b2));
    return_spmf ((B, V), s1, s2)}"

lemma lossless_S2_and: "lossless_spmf (S2_and B s2)"
  apply(simp add: S2_and_def split_def)
  by(metis prod.collapse lossless_S2_14_OT)

sublocale and_secret_sharing: sim_non_det_def and_R1 S1_and out1 and_R2 S2_and out2 and_funct .

lemma ideal_S1_and: "and_secret_sharing.Ideal1 (a1, b1) (a2, b2) s2 = S1_and' (a1, b1) (a2, b2) s2"
  by(simp add: Let_def and_secret_sharing.Ideal1_def S1_and'_def split_def out1_def S1_and_def)

lemma and_P2_security: "and_secret_sharing.perfect_sec_P2 m1 m2"
proof-
  have "and_R2 (a1, b1) (a2, b2) = and_funct (a1, b1) (a2, b2) \<bind> (\<lambda>(s1, s2). and_secret_sharing.Ideal2 (a2, b2) (a1, b1) s2)"
    for a1 a2 b1 b2
    apply(auto simp add: split_def inf_th_14_OT_P4  S2_and'_def and_R2_def and_funct_def Let_def correct_14[symmetric] and_secret_sharing.Ideal2_def S2_and_def out2_def)
    apply(simp only: funct_14)
    apply auto
    by(cases b1;cases b2; cases a1; cases a2; auto)
  thus ?thesis
    by(simp add: and_secret_sharing.perfect_sec_P2_def; metis  prod.collapse)
qed

lemma and_P1_security: "and_secret_sharing.adv_P1 m1 m2 D \<le> adv_14_OT"
proof-
  have "\<bar>spmf (and_R1 (a1, a2) (b1, b2) \<bind> D) True -
            spmf (and_funct (a1, a2) (b1, b2) \<bind> (\<lambda>(s1, s2).
                and_secret_sharing.Ideal1 (a1, a2) (b1, b2) s1 \<bind> D)) True\<bar>
                    \<le> adv_14_OT" for a1 a2 b1 b2
    using security_and_P1' ideal_S1_and prod.collapse by simp
  thus ?thesis
    by(simp add:  and_secret_sharing.adv_P1_def; metis prod.collapse)
qed

definition "F = {and_evaluate, xor_evaluate}"

lemma share_reconstruct_xor: "share x \<bind> (\<lambda>(a1, a2). share y \<bind> (\<lambda>(b1, b2).
          xor_protocol (a1, b1) (a2, b2) \<bind> (\<lambda>(a, b).
              reconstruct (a, b)))) = xor_evaluate x y"
proof-
  have "(((ya = (x = ya)) = (yb = (y = (\<not> yb))))) = (x = (\<not> y))" for ya yb by auto
  thus ?thesis
    by(simp add: xor_protocol_def share_def reconstruct_def xor_evaluate_def bind_spmf_const)
qed

sublocale share_correct: secret_sharing_scheme share reconstruct F .

lemma "share_correct.sharing_correct input"
  by(simp add: share_correct.sharing_correct_def reconstruct_share)

lemma "share_correct.correct_share_eval input1 input2"
  unfolding share_correct.correct_share_eval_def
  apply(auto simp add: F_def)
  using share_and_reconstruct apply auto
  using share_reconstruct_xor by force

end

locale gmw_asym =
  fixes S1_14_OT :: "nat \<Rightarrow> msgs_14_OT \<Rightarrow> unit \<Rightarrow> 'v_14_OT1 spmf"
    and R1_14_OT :: "nat \<Rightarrow> msgs_14_OT \<Rightarrow> choice_14_OT \<Rightarrow> 'v_14_OT1 spmf"
    and S2_14_OT :: "nat \<Rightarrow> choice_14_OT \<Rightarrow> bool \<Rightarrow> 'v_14_OT2 spmf"
    and R2_14_OT :: "nat \<Rightarrow> msgs_14_OT \<Rightarrow> choice_14_OT \<Rightarrow> 'v_14_OT2 spmf"
    and protocol_14_OT :: "nat \<Rightarrow> msgs_14_OT \<Rightarrow> choice_14_OT \<Rightarrow> (unit \<times> bool) spmf"
    and adv_14_OT :: "nat \<Rightarrow> real"
  assumes gmw_base: "\<And> (n::nat). gmw_base (S1_14_OT n) (R1_14_OT n) (S2_14_OT n) (R2_14_OT n) (protocol_14_OT n) (adv_14_OT n)"
begin

sublocale gmw_base "(S1_14_OT n)" "(R1_14_OT n)" "(S2_14_OT n)" "(R2_14_OT n)" "(protocol_14_OT n)" "(adv_14_OT n)"
  by (simp add: gmw_base)

lemma "xor_sim_det.perfect_sec_P1 m1 m2"
  by (simp add: P1_xor_inf_th xor_sim_det.perfect_sec_P1_def)

lemma "xor_sim_det.perfect_sec_P2 m1 m2"
  by (simp add: P2_xor_inf_th xor_sim_det.perfect_sec_P2_def)

lemma and_P1_adv_negligible:
  assumes "negligible (\<lambda> n. adv_14_OT n)"
  shows "negligible (\<lambda> n. and_secret_sharing.adv_P1 n m1 m2 D)"
proof-
  have "and_secret_sharing.adv_P1 n m1 m2 D \<le> adv_14_OT n" for n
    by (simp add: and_P1_security)
  thus ?thesis
    using and_secret_sharing.adv_P1_def assms negligible_le by auto
qed

lemma and_P2_security: "and_secret_sharing.perfect_sec_P2 n m1 m2"
  by (simp add: and_P2_security)

end

end