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

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

section \<open>Continuity and Induction for Loops\<close>

theory LoopInduction imports Healthiness Continuity begin

text \<open>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.\<close>

text \<open>A loop step is monotonic.\<close>
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 \<open>We can therefore apply the standard fixed-point lemmas to unfold it:\<close>
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 \<open>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.\<close>
lemma loop_induct:
  fixes body::"'s prog"
  assumes hwp:  "healthy (wp body)"
      and hwlp: "nearly_healthy (wlp body)"
      \<comment> \<open>The body must be healthy, both in strict and liberal semantics.\<close>
      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))"
      \<comment> \<open>The property holds at limit points.\<close>
      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))"
      \<comment> \<open>The inductive step.  The property is preserved by a single loop iteration.\<close>
      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'"
      \<comment> \<open>The property must be preserved by equivalence\<close>
  shows "P (wp (do G \<longrightarrow> body od)) (wlp (do G \<longrightarrow> body od))"
  \<comment> \<open>The property can refer to both interpretations simultaneously.  The unifier will happily
  apply the rule to just one or the other, however.\<close>
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> {}"
      then obtain x where xin: "x \<in> ?M" by auto
      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 ne obtain x where xin: "x \<in> ?M" by auto
      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[simplified 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[simplified 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 \<open>The Limit of Iterates\<close>

text \<open>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.\<close>
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 \<open>All iterates are healthy.\<close>
lemma iterates_healthy:
  "healthy (wp body) \<Longrightarrow> healthy (iterates body G i)"
  by(induct i, auto intro:healthy_intros)

text \<open>The iterates are an ascending chain.\<close>
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 \<open>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.\<close>
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"
        apply (simp only: 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"
  proof(simp only: wp_eval, 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 cong del: image_cong_simp)
    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 \<open>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.\<close>
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) \<longlonglongrightarrow> 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) \<longlonglongrightarrow> 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 \<open>The iterates themselves are all continuous.\<close>
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 \<open>Therefore so is the loop itself.\<close>
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, 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, 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 cong del: SUP_cong_simp)
      }
      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 cong del: SUP_cong_simp)
  }
  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:      Code_Target_Bits_Int.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* Implementation of bit operations on int by target language operations *}

theory Code_Target_Bits_Int
imports
  Bits_Integer
  "HOL-Library.Code_Target_Int"
begin

declare [[code drop:
  "bitAND :: int \<Rightarrow> _" "bitOR :: int \<Rightarrow> _" "bitXOR :: int \<Rightarrow> _" "bitNOT :: int \<Rightarrow> _"
  "lsb :: int \<Rightarrow> _" "set_bit :: int \<Rightarrow> _" "test_bit :: int \<Rightarrow> _"
  "shiftl :: int \<Rightarrow> _" "shiftr :: int \<Rightarrow> _"
  bin_last bin_rest bin_nth Bit
  int_of_integer_symbolic
  ]]

context
includes integer.lifting
begin

lemma bitAND_int_code [code]:
  "int_of_integer i AND int_of_integer j = int_of_integer (i AND j)"
by transfer simp

lemma bitOR_int_code [code]:
  "int_of_integer i OR int_of_integer j = int_of_integer (i OR j)"
by transfer simp

lemma bitXOR_int_code [code]:
  "int_of_integer i XOR int_of_integer j = int_of_integer (i XOR j)"
by transfer simp

lemma bitNOT_int_code [code]:
  "NOT (int_of_integer i) = int_of_integer (NOT i)"
by transfer simp

declare bin_last_conv_AND [code]

lemma bin_rest_code [code]:
   "bin_rest (int_of_integer i) = int_of_integer (bin_rest_integer i)"
by transfer simp

declare bitval_bin_last [code_unfold]

declare bin_nth_conv_AND [code]

lemma Bit_code [code]: "int_of_integer i BIT b = int_of_integer (Bit_integer i b)"
by transfer simp

lemma test_bit_int_code [code]: "int_of_integer x !! n = x !! n"
by transfer simp

lemma lsb_int_code [code]: "lsb (int_of_integer x) = lsb x"
by transfer simp

lemma set_bit_int_code [code]: "set_bit (int_of_integer x) n b = int_of_integer (set_bit x n b)"
by transfer simp

lemma shiftl_int_code [code]: "int_of_integer x << n = int_of_integer (x << n)"
by transfer simp

lemma shiftr_int_code [code]: "int_of_integer x >> n = int_of_integer (x >> n)"
by transfer simp

lemma int_of_integer_symbolic_code [code]:
  "int_of_integer_symbolic = int_of_integer"
by(simp add: int_of_integer_symbolic_def)

end

code_identifier code_module Code_Target_Bits_Int \<rightharpoonup>
  (SML) Bit_Int and (OCaml) Bit_Int and (Haskell) Bit_Int and (Scala) Bit_Int

end


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

chapter {* Unsigned words of 16 bits *}

theory Uint16 imports
  Word_Misc
  Bits_Integer
begin

text {*
  Restriction for ML code generation:
  This theory assumes that the ML system provides a Word16
  implementation (mlton does, but PolyML 5.5 does not).
  Therefore, the code setup lives in the target @{text SML_word}
  rather than @{text SML}.  This ensures that code generation still
  works as long as @{text "uint16"} is not involved.
  For the target @{text SML} itself, no special code generation
  for this type is set up. Nevertheless, it should work by emulation via @{typ "16 word"}
  if the theory @{text Code_Target_Bits_Int} is imported.

  Restriction for OCaml code generation:
  OCaml does not provide an int16 type, so no special code generation
  for this type is set up.
*}

declare prod.Quotient[transfer_rule]

section {* Type definition and primitive operations *}

typedef uint16 = "UNIV :: 16 word set" ..

setup_lifting type_definition_uint16

text {* Use an abstract type for code generation to disable pattern matching on @{term Abs_uint16}. *}
declare Rep_uint16_inverse[code abstype]

declare Quotient_uint16[transfer_rule]

instantiation uint16 :: "{neg_numeral, Divides.div, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint16 :: uint16 is "0" .
lift_definition one_uint16 :: uint16 is "1" .
lift_definition plus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op +" .
lift_definition minus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op -" .
lift_definition uminus_uint16 :: "uint16 \<Rightarrow> uint16" is uminus .
lift_definition times_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op *" .
lift_definition divide_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op div" .
lift_definition mod_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op mod" .
instance by standard (transfer, simp add: algebra_simps)+
end

instantiation uint16 :: linorder begin
lift_definition less_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "op <" .
lift_definition less_eq_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "op \<le>" .
instance by standard (transfer, simp add: less_le_not_le linear)+
end

lemmas [code] = less_uint16.rep_eq less_eq_uint16.rep_eq

instantiation uint16 :: bitss begin
lift_definition bitNOT_uint16 :: "uint16 \<Rightarrow> uint16" is bitNOT .
lift_definition bitAND_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitAND .
lift_definition bitOR_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitOR .
lift_definition bitXOR_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitXOR .
lift_definition test_bit_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint16" is set_bit .
lift_definition set_bits_uint16 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16" is "set_bits" .
lift_definition lsb_uint16 :: "uint16 \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" is shiftl .
lift_definition shiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" is shiftr .
lift_definition msb_uint16 :: "uint16 \<Rightarrow> bool" is msb .
instance ..
end

lemmas [code] = test_bit_uint16.rep_eq lsb_uint16.rep_eq msb_uint16.rep_eq

instantiation uint16 :: equal begin
lift_definition equal_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint16.rep_eq

instantiation uint16 :: size begin
lift_definition size_uint16 :: "uint16 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint16.rep_eq

lift_definition sshiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" (infixl ">>>" 55) is sshiftr .

lift_definition uint16_of_int :: "int \<Rightarrow> uint16" is "word_of_int" .

definition uint16_of_nat :: "nat \<Rightarrow> uint16"
where "uint16_of_nat = uint16_of_int \<circ> int"

lift_definition int_of_uint16 :: "uint16 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint16 :: "uint16 \<Rightarrow> nat" is "unat" .

definition integer_of_uint16 :: "uint16 \<Rightarrow> integer"
where "integer_of_uint16 = integer_of_int o int_of_uint16"

text {* Use pretty numerals from integer for pretty printing *}

context includes integer.lifting begin

lift_definition Uint16 :: "integer \<Rightarrow> uint16" is "word_of_int" .

lemma Rep_uint16_numeral [simp]: "Rep_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def Abs_uint16_inverse numeral.simps plus_uint16_def)

lemma Rep_uint16_neg_numeral [simp]: "Rep_uint16 (- numeral n) = - numeral n"
by(simp only: uminus_uint16_def)(simp add: Abs_uint16_inverse)

lemma numeral_uint16_transfer [transfer_rule]:
  "(rel_fun op = cr_uint16) numeral numeral"
by(auto simp add: cr_uint16_def)

lemma numeral_uint16 [code_unfold]: "numeral n = Uint16 (numeral n)"
by transfer simp

lemma neg_numeral_uint16 [code_unfold]: "- numeral n = Uint16 (- numeral n)"
by transfer(simp add: cr_uint16_def)

end

lemma Abs_uint16_numeral [code_post]: "Abs_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def numeral.simps plus_uint16_def Abs_uint16_inverse)

lemma Abs_uint16_0 [code_post]: "Abs_uint16 0 = 0"
by(simp add: zero_uint16_def)

lemma Abs_uint16_1 [code_post]: "Abs_uint16 1 = 1"
by(simp add: one_uint16_def)

section {* Code setup *}

code_printing code_module Uint16 \<rightharpoonup> (SML_word)
{*(* Test that words can handle numbers between 0 and 15 *)
val _ = if 4 <= Word.wordSize then () else raise (Fail ("wordSize less than 4"));

structure Uint16 : sig
  val set_bit : Word16.word -> IntInf.int -> bool -> Word16.word
  val shiftl : Word16.word -> IntInf.int -> Word16.word
  val shiftr : Word16.word -> IntInf.int -> Word16.word
  val shiftr_signed : Word16.word -> IntInf.int -> Word16.word
  val test_bit : Word16.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word16.orb (x, mask)
     else Word16.andb (x, Word16.notb mask)
  end

fun shiftl x n =
  Word16.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word16.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word16.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word16.andb (x, Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word16.fromInt 0

end; (* struct Uint16 *)*}
code_reserved SML_word Uint16

code_printing code_module Uint16 \<rightharpoonup> (Haskell)
{*import qualified Data.Word;
import qualified Data.Int;

type Int16 = Data.Int.Int16;

type Word16 = Data.Word.Word16;*}
code_reserved Haskell Uint16

text {* Scala provides unsigned 16-bit numbers as Char. *}

code_printing code_module Uint16 \<rightharpoonup> (Scala)
{*object Uint16 {

def set_bit(x: scala.Char, n: BigInt, b: Boolean) : scala.Char =
  if (b)
    (x | (1.toChar << n.intValue)).toChar
  else
    (x & (1.toChar << n.intValue).unary_~).toChar

def shiftl(x: scala.Char, n: BigInt) : scala.Char = (x << n.intValue).toChar

def shiftr(x: scala.Char, n: BigInt) : scala.Char = (x >>> n.intValue).toChar

def shiftr_signed(x: scala.Char, n: BigInt) : scala.Char = (x.toShort >> n.intValue).toChar

def test_bit(x: scala.Char, n: BigInt) : Boolean = (x & (1.toChar << n.intValue)) != 0

} /* object Uint16 */*}
code_reserved Scala Uint16

text {*
  Avoid @{term Abs_uint16} in generated code, use @{term Rep_uint16'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint16}.

  The new destructor @{term Rep_uint16'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint16} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint16}
  ([code abstract] equations for @{typ uint16} may use @{term Rep_uint16} because
  these instances will be folded away.)

  To convert @{typ "16 word"} values into @{typ uint16}, use @{term "Abs_uint16'"}.
*}

definition Rep_uint16' where [simp]: "Rep_uint16' = Rep_uint16"

lemma Rep_uint16'_transfer [transfer_rule]:
  "rel_fun cr_uint16 op = (\<lambda>x. x) Rep_uint16'"
unfolding Rep_uint16'_def by(rule uint16.rep_transfer)

lift_definition Abs_uint16' :: "16 word \<Rightarrow> uint16" is "\<lambda>x :: 16 word. x" .

lemma Abs_uint16'_code [code]:
  "Abs_uint16' x = Uint16 (integer_of_int (uint x))"
including integer.lifting by transfer simp

lemma [code, code del]: "term_of_class.term_of = (term_of_class.term_of :: uint16 \<Rightarrow> _)" ..

lemma term_of_uint16_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint16.Abs_uint16'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]], TR (STR ''Uint16.uint16'') []]))
       (term_of_class.term_of (Rep_uint16' x))"
by(simp add: term_of_anything)

lemma Uin16_code [code abstract]: "Rep_uint16 (Uint16 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint16_def int_of_integer_symbolic_def by(simp add: Abs_uint16_inverse)

code_printing
  type_constructor uint16 \<rightharpoonup>
  (SML_word) "Word16.word" and
  (Haskell) "Uint16.Word16" and
  (Scala) "scala.Char"
| constant Uint16 \<rightharpoonup>
  (SML_word) "Word16.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint16.Word16)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Word16)" and
  (Scala) "_.charValue"
| constant "0 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 0)" and
  (Haskell) "(0 :: Uint16.Word16)" and
  (Scala) "0"
| constant "1 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 1)" and
  (Haskell) "(1 :: Uint16.Word16)" and
  (Scala) "1"
| constant "plus :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toChar"
| constant "uminus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toChar"
| constant "minus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toChar"
| constant "times :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toChar"
| constant "HOL.equal :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "!((_ : Word16.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint16 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) infixl 4 "<="
| constant "less :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) infixl 4 "<"
| constant "bitNOT :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toChar"
| constant "bitAND :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toChar"
| constant "bitOR :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toChar"
| constant "bitXOR :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toChar"

definition uint16_div :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_div x y = (if y = 0 then undefined (op div :: uint16 \<Rightarrow> _) x (0 :: uint16) else x div y)"

definition uint16_mod :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_mod x y = (if y = 0 then undefined (op mod :: uint16 \<Rightarrow> _) x (0 :: uint16) else x mod y)"

context includes undefined_transfer begin

lemma div_uint16_code [code]: "x div y = (if y = 0 then 0 else uint16_div x y)"
unfolding uint16_div_def by transfer (simp add: word_div_def)

lemma mod_uint16_code [code]: "x mod y = (if y = 0 then x else uint16_mod x y)"
unfolding uint16_mod_def by transfer (simp add: word_mod_def)

lemma uint16_div_code [code abstract]:
  "Rep_uint16 (uint16_div x y) =
  (if y = 0 then Rep_uint16 (undefined (op div :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x div Rep_uint16 y)"
unfolding uint16_div_def by transfer simp

lemma uint16_mod_code [code abstract]:
  "Rep_uint16 (uint16_mod x y) =
  (if y = 0 then Rep_uint16 (undefined (op mod :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x mod Rep_uint16 y)"
unfolding uint16_mod_def by transfer simp

end

code_printing constant uint16_div \<rightharpoonup>
  (SML_word) "Word16.div ((_), (_))" and
  (Haskell) "Prelude.div" and
  (Scala) "(_ '/ _).toChar"
| constant uint16_mod \<rightharpoonup>
  (SML_word) "Word16.mod ((_), (_))" and
  (Haskell) "Prelude.mod" and
  (Scala) "(_ % _).toChar"

definition uint16_test_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint16_test_bit x n =
  (if n < 0 \<or> 15 < n then undefined (test_bit :: uint16 \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint16_code [code]:
  "test_bit x n \<longleftrightarrow> n < 16 \<and> uint16_test_bit x (integer_of_nat n)"
unfolding uint16_test_bit_def including undefined_transfer integer.lifting
by transfer(auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint16_test_bit_code [code]:
  "uint16_test_bit w n =
  (if n < 0 \<or> 15 < n then undefined (test_bit :: uint16 \<Rightarrow> _) w n else Rep_uint16 w !! nat_of_integer n)"
unfolding uint16_test_bit_def by(simp add: test_bit_uint16.rep_eq)

code_printing constant uint16_test_bit \<rightharpoonup>
  (SML_word) "Uint16.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint16.test'_bit"

definition uint16_set_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint16"
where [code del]:
  "uint16_set_bit x n b =
  (if n < 0 \<or> 15 < n then undefined (set_bit :: uint16 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint16_code [code]:
  "set_bit x n b = (if n < 16 then uint16_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint16_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint16_set_bit_code [code abstract]:
  "Rep_uint16 (uint16_set_bit w n b) =
  (if n < 0 \<or> 15 < n then Rep_uint16 (undefined (set_bit :: uint16 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint16 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint16_set_bit_def by transfer simp

code_printing constant uint16_set_bit \<rightharpoonup>
  (SML_word) "Uint16.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint16.set'_bit"

lift_definition uint16_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16 \<Rightarrow> nat \<Rightarrow> uint16" is set_bits_aux .

lemma uint16_set_bits_code [code]:
  "uint16_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint16_set_bits f ((w << 1) OR (if f n' then 1 else 0)) n')"
by(transfer fixing: n)(cases n, simp_all)

lemma set_bits_uint16 [code]:
  "(BITS n. f n) = uint16_set_bits f 0 16"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint16 shows "lsb x = x !! 0"
by transfer(simp add: word_lsb_def word_test_bit_def)

definition uint16_shiftl :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftl x n = (if n < 0 \<or> 16 \<le> n then undefined (shiftl :: uint16 \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint16_code [code]: "x << n = (if n < 16 then uint16_shiftl x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint16_shiftl_def
by transfer(simp add: not_less shiftl_zero_size word_size)

lemma uint16_shiftl_code [code abstract]:
  "Rep_uint16 (uint16_shiftl w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (shiftl :: uint16 \<Rightarrow> _) w n)
   else Rep_uint16 w << nat_of_integer n)"
including undefined_transfer unfolding uint16_shiftl_def by transfer simp

code_printing constant uint16_shiftl \<rightharpoonup>
  (SML_word) "Uint16.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint16.shiftl"

definition uint16_shiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftr x n = (if n < 0 \<or> 16 \<le> n then undefined (shiftr :: uint16 \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint16_code [code]: "x >> n = (if n < 16 then uint16_shiftr x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint16_shiftr_def
by transfer(simp add: not_less shiftr_zero_size word_size)

lemma uint16_shiftr_code [code abstract]:
  "Rep_uint16 (uint16_shiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (shiftr :: uint16 \<Rightarrow> _) w n)
   else Rep_uint16 w >> nat_of_integer n)"
including undefined_transfer unfolding uint16_shiftr_def by transfer simp

code_printing constant uint16_shiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint16.shiftr"

definition uint16_sshiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_sshiftr x n =
  (if n < 0 \<or> 16 \<le> n then undefined sshiftr_uint16 x n else sshiftr_uint16 x (nat_of_integer n))"

lemma sshiftr_beyond: fixes x :: "'a :: len word" shows
  "size x \<le> n \<Longrightarrow> x >>> n = (if x !! (size x - 1) then -1 else 0)"
by(rule word_eqI)(simp add: nth_sshiftr word_size)

lemma sshiftr_uint16_code [code]:
  "x >>> n =
  (if n < 16 then uint16_sshiftr x (integer_of_nat n) else if x !! 15 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint16_sshiftr_def
by transfer (simp add: not_less sshiftr_beyond word_size)

lemma uint16_sshiftr_code [code abstract]:
  "Rep_uint16 (uint16_sshiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined sshiftr_uint16 w n)
   else Rep_uint16 w >>> nat_of_integer n)"
including undefined_transfer unfolding uint16_sshiftr_def by transfer simp

code_printing constant uint16_sshiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Int16) _)) :: Uint16.Word16)" and
  (Scala) "Uint16.shiftr'_signed"

lemma uint16_msb_test_bit: "msb x \<longleftrightarrow> (x :: uint16) !! 15"
by transfer(simp add: msb_nth)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint16_test_bit x 15"
by(simp add: uint16_test_bit_def uint16_msb_test_bit)

lemma uint16_of_int_code [code]: "uint16_of_int i = Uint16 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint16_code [code]:
  "int_of_uint16 x = int_of_integer (integer_of_uint16 x)"
by(simp add: integer_of_uint16_def)

lemma nat_of_uint16_code [code]:
  "nat_of_uint16 x = nat_of_integer (integer_of_uint16 x)"
unfolding integer_of_uint16_def including integer.lifting by transfer (simp add: unat_def)

lemma integer_of_uint16_code [code]:
  "integer_of_uint16 n = integer_of_int (uint (Rep_uint16' n))"
unfolding integer_of_uint16_def by transfer auto

code_printing
  constant "integer_of_uint16" \<rightharpoonup>
  (SML_word) "Word16.toInt _ : IntInf.int" and
  (Haskell) "Prelude.toInteger" and
  (Scala) "BigInt"

section {* Quickcheck setup *}

definition uint16_of_natural :: "natural \<Rightarrow> uint16"
where "uint16_of_natural x \<equiv> Uint16 (integer_of_natural x)"

instantiation uint16 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint16 \<equiv> qc_random_cnv uint16_of_natural"
definition "exhaustive_uint16 \<equiv> qc_exhaustive_cnv uint16_of_natural"
definition "full_exhaustive_uint16 \<equiv> qc_full_exhaustive_cnv uint16_of_natural"
instance ..
end

instantiation uint16 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint16 i in (x, 0xFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint16.uint16'') []" .

definition "narrowing_uint16 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint16 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint16 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint16 (infixl ">>>" 55)

end


(*  Title:       Deriving class instances for datatypes
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2013 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Generating linear orders for datatypes\<close>

theory Order_Generator
imports
  Derive_Aux
begin

subsection Introduction

text \<open>

The order generator registers itself at the derive-manager for the classes @{class ord},
@{class order}, and @{class linorder}.
To be more precise,
it automatically generates the two functions @{term "(\<le>)"} and @{term "(<)"} for some datatype
\texttt{dtype} and
proves the following instantiations.

\begin{itemize}
\item \texttt{instantiation dtype :: (ord,\ldots,ord) ord}
\item \texttt{instantiation dtype :: (order,\ldots,order) order}
\item \texttt{instantiation dtype :: (linorder,\ldots,linorder) linorder}
\end{itemize}

All the non-recursive types that are used in the datatype must have similar instantiations.
For recursive type-dependencies this is automatically generated.

For example, for the \texttt{datatype tree = Leaf nat | Node "tree list"} we require that
@{type nat} is already in @{class linorder}, whereas for @{type list} nothing is required, since for the
\texttt{tree}
datatype the @{type list} is only used recursively.

However, if we define \texttt{datatype tree = Leaf "nat list" | Node tree tree} then
@{type list} must
provide the above instantiations.

Note that when calling the generator for @{class linorder}, it will automatically also derive the instantiations
for @{class order}, which in turn invokes the generator for @{class ord}.
A later invokation of @{class linorder}
after @{class order} or @{class ord} is not possible.
\<close>

subsection "Implementation Notes"

text \<open>
The generator uses the recursors from the datatype package to define a lexicographic order.
E.g., for a declaration
\texttt{datatype 'a tree = Empty | Node "'a tree" 'a "'a tree"}
this will semantically result in
\begin{verbatim}
(Empty < Node _ _ _) = True
(Node l1 l2 l3 < Node r1 r2 r3) =
  (l1 < r1 || l1 = r1 && (l2 < r2 || l2 = r2 && l3 < r3))
(_ < _) = False
(l <= r) = (l < r || l = r)
\end{verbatim}

The desired properties (like @{term "x < y \<Longrightarrow> y < z \<Longrightarrow> x < z"})
of the orders are all proven using induction (with the induction theorem from the datatype on @{term x}),
and afterwards there is a case distinction on the remaining variables, i.e., here @{term y} and @{term z}.
If the constructors of @{term x}, @{term y}, and @{term z} are different always some basic tactic is invoked.
In the other case (identical constructors) for each property a dedicated tactic was designed.
\<close>

subsection "Features and Limitations"

text \<open>
The order generator has been developed mainly for datatypes without explicit mutual recursion.
For mutual recursive datatypes---like
\texttt{datatype a = C b and b = D a a}---only
for the first mentioned datatype---here \texttt{a}---the instantiations of the order-classes are
derived.

Indirect recursion like in \texttt{datatype tree = Leaf nat | Node "tree list"} should work
without problems.
\<close>

subsection "Installing the generator"

lemma linear_cases: "(x :: 'a :: linorder) = y \<or> x < y \<or> y < x" by auto

ML_file \<open>order_generator.ML\<close>

end