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

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

header {* Healthiness *}

theory Healthiness imports Embedding begin

subsection {* The Healthiness of the Embedding *}

text {* Healthiness is mostly derived by structural induction using
  the simplifier.  @{term Abort}, @{term Skip} and @{term Apply}
  form base cases. *}

lemma healthy_wp_Abort:
  "healthy (wp Abort)"
proof(rule healthy_parts)
  fix b and P::"'a \<Rightarrow> real"
  assume nP: "nneg P" and bP: "bounded_by b P"
  thus "bounded_by b (wp Abort P)"
    unfolding wp_eval by(blast)
  show "nneg (wp Abort P)"
    unfolding wp_eval by(blast)
next
  fix P Q::"'a expect"
  show "wp Abort P \<tturnstile> wp Abort Q"
    unfolding wp_eval by(blast)
next
  fix P and c and s::'a
  show "c * wp Abort P s = wp Abort (\<lambda>s. c * P s) s"
    unfolding wp_eval by(auto)
qed

lemma nearly_healthy_wlp_Abort:
  "nearly_healthy (wlp Abort)"
proof(rule nearly_healthyI)
  fix P::"'s \<Rightarrow> real"
  show "unitary (wlp Abort P)"
    by(simp add:wp_eval)
next
  fix P Q :: "'s expect"
  assume "P \<tturnstile> Q" and "unitary P" and "unitary Q"
  thus "wlp Abort P \<tturnstile> wlp Abort Q"
    unfolding wp_eval by(blast)
qed

lemma healthy_wp_Skip:
  "healthy (wp Skip)"
  by(force intro!:healthy_parts simp:wp_eval)

lemma nearly_healthy_wlp_Skip:
  "nearly_healthy (wlp Skip)"
  by(auto simp:wp_eval)

lemma healthy_wp_Seq:
  fixes t::"'s prog" and u
  assumes ht: "healthy (wp t)" and hu: "healthy (wp u)"
  shows "healthy (wp (t ;; u))"
proof(rule healthy_parts, simp_all add:wp_eval)
  fix b and P::"'s \<Rightarrow> real"
  assume "bounded_by b P" and "nneg P"
  with hu have "bounded_by b (wp u P)" and "nneg (wp u P)" by(auto)
  with ht show "bounded_by b (wp t (wp u P))"
           and "nneg (wp t (wp u P))" by(auto)
next
  fix P::"'s \<Rightarrow> real" and Q
  assume "sound P" and "sound Q" and "P \<tturnstile> Q"
  with hu have "sound (wp u P)" and "sound (wp u Q)"
    and "wp u P \<tturnstile> wp u Q" by(auto)
  with ht show "wp t (wp u P) \<tturnstile> wp t (wp u Q)" by(auto)
next
  fix P::"'s \<Rightarrow> real" and c::real and s
  assume pos: "0 \<le> c" and sP: "sound P"
  with ht and hu have "c * wp t (wp u P) s = wp t (\<lambda>s. c * wp u P s) s"
    by(auto intro!:scalingD)
  also with hu and pos and sP have "... = wp t (wp u (\<lambda>s. c * P s)) s"
    by(simp add:scalingD[OF healthy_scalingD])
  finally show "c * wp t (wp u P) s = wp t (wp u (\<lambda>s. c * P s)) s" .
qed

lemma nearly_healthy_wlp_Seq:
  fixes t::"'s prog" and u
  assumes ht: "nearly_healthy (wlp t)" and hu: "nearly_healthy (wlp u)"
  shows "nearly_healthy (wlp (t ;; u))"
proof(rule nearly_healthyI, simp_all add:wp_eval)
  fix b and P::"'s \<Rightarrow> real"
  assume "unitary P"
  with hu have "unitary (wlp u P)" by(auto)
  with ht show "unitary (wlp t (wlp u P))" by(auto)
next
  fix P Q::"'s \<Rightarrow> real"
  assume "unitary P" and "unitary Q" and "P \<tturnstile> Q"
  with hu have "unitary (wlp u P)" and "unitary (wlp u Q)"
    and "wlp u P \<tturnstile> wlp u Q" by(auto)
  with ht show "wlp t (wlp u P) \<tturnstile> wlp t (wlp u Q)" by(auto)
qed

lemma healthy_wp_PC:
  fixes f::"'s prog"
  assumes hf: "healthy (wp f)" and hg: "healthy (wp g)"
      and uP: "unitary P"
  shows "healthy (wp (f \<^bsub>P\<^esub>\<oplus> g))"
proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all add:wp_eval)
  fix b and Q::"'s \<Rightarrow> real" and s::'s
  assume nQ: "nneg Q" and bQ: "bounded_by b Q"

  txt {* Non-negative: *}
  from nQ and bQ and hf have "0 \<le> wp f Q s" by(auto)
  with uP have "0 \<le> P s * ..." by(auto intro:mult_nonneg_nonneg)
  moreover {
    from uP have "0 \<le> 1 - P s" by(auto simp:sign_simps)
    with nQ and bQ and hg have "0 \<le> ... * wp g Q s"
      by(auto intro:mult_nonneg_nonneg)
  }
  ultimately show "0 \<le> P s * wp f Q s + (1 - P s) * wp g Q s"
    by(auto intro:mult_nonneg_nonneg)

  txt {* Bounded: *}
  from nQ bQ hf have "wp f Q s \<le> b" by(auto)
  with uP nQ bQ hf have "P s * wp f Q s \<le> P s * b"
    by(blast intro!:mult_mono)
  moreover {
    from nQ bQ hg uP
    have "wp g Q s \<le> b" and "0 \<le> 1 - P s" by(auto simp:sign_simps)
    with nQ bQ hg have "(1 - P s) * wp g Q s \<le> (1 - P s) * b"
      by(blast intro!:mult_mono)
  }
  ultimately have "P s * wp f Q s + (1 - P s) * wp g Q s \<le>
                   P s * b + (1 - P s) * b"
    by(blast intro:add_mono)
  also have "... = b" by(auto simp:algebra_simps)
  finally show "P s * wp f Q s + (1 - P s) * wp g Q s \<le> b" .
next
  txt {* Monotonic: *}
  fix Q R::"'s \<Rightarrow> real" and s
  assume sQ: "sound Q" and sR: "sound R" and le: "Q \<tturnstile> R"

  with hf have "wp f Q s \<le> wp f R s" by(blast dest:mono_transD)
  with uP have "P s * wp f Q s \<le> P s * wp f R s"
    by(auto intro:mult_left_mono)
  moreover {
    from sQ sR le hg
    have "wp g Q s \<le> wp g R s" by(blast dest:mono_transD)
    moreover from uP have "0 \<le> 1 - P s" by(auto simp:sign_simps)
    ultimately have "(1 - P s) * wp g Q s \<le> (1 - P s) * wp g R s"
      by(auto intro:mult_left_mono)
  }
  ultimately show "P s * wp f Q s + (1 - P s) * wp g Q s \<le>
                   P s * wp f R s + (1 - P s) * wp g R s" by(auto)
next
  txt {* Scaling: *}
  fix Q::"'s \<Rightarrow> real" and c::real and s::'s
  assume sQ: "sound Q" and pos: "0 \<le> c"
  have "c * (P s * wp f Q s + (1 - P s) * wp g Q s) =
        P s * (c * wp f Q s) + (1 - P s) * (c * wp g Q s)"
    by(simp add:distrib_left)
  also have "... = P s * wp f (\<lambda>s.  c * Q s) s +
                   (1 - P s) * wp g (\<lambda>s. c * Q s) s"
    using hf hg sQ pos
    by(simp add:scalingD[OF healthy_scalingD])
  finally show "c * (P s * wp f Q s + (1 - P s) * wp g Q s) =
                P s * wp f (\<lambda>s. c * Q s) s + (1 - P s) * wp g (\<lambda>s. c * Q s) s" .
qed

lemma nearly_healthy_wlp_PC:
  fixes f::"'s prog"
  assumes hf: "nearly_healthy (wlp f)"
      and hg: "nearly_healthy (wlp g)"
      and uP: "unitary P"
  shows "nearly_healthy (wlp (f \<^bsub>P\<^esub>\<oplus> g))"
proof(intro nearly_healthyI unitaryI2 nnegI bounded_byI le_funI,
      simp_all add:wp_eval)
  fix Q::"'s expect" and s::'s
  assume uQ: "unitary Q"
  from uQ hf hg have utQ: "unitary (wlp f Q)" "unitary (wlp g Q)" by(auto)
  from uP have nnP: "0 \<le> P s" "0 \<le> 1 - P s" by(auto simp:sign_simps)
  moreover from utQ have "0 \<le> wlp f Q s" "0 \<le> wlp g Q s" by(auto)
  ultimately show "0 \<le> P s * wlp f Q s + (1 - P s) * wlp g Q s"
    by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)

  from utQ have "wlp f Q s \<le> 1" "wlp g Q s \<le> 1" by(auto)
  with nnP have "P s * wlp f Q s + (1 - P s) * wlp g Q s \<le> P s * 1 + (1 - P s) * 1"
    by(blast intro:add_mono mult_left_mono)
  thus "P s * wlp f Q s + (1 - P s) * wlp g Q s \<le> 1" by(simp)

  fix R::"'s expect"
  assume uR: "unitary R" and le: "Q \<tturnstile> R"
  with uQ have "wlp f Q s \<le> wlp f R s"
    by(auto intro:le_funD[OF nearly_healthy_monoD, OF hf])
  with nnP have "P s * wlp f Q s \<le> P s * wlp f R s"
    by(auto intro:mult_left_mono)
  moreover {
    from uQ uR le have "wlp g Q s \<le> wlp g R s"
      by(auto intro:le_funD[OF nearly_healthy_monoD, OF hg])
    with nnP have "(1 - P s) * wlp g Q s \<le> (1 - P s) * wlp g R s"
      by(auto intro:mult_left_mono)
  }
  ultimately show "P s * wlp f Q s + (1 - P s) * wlp g Q s \<le>
                   P s * wlp f R s + (1 - P s) * wlp g R s"
    by(auto)
qed

lemma healthy_wp_DC:
  fixes f::"'s prog"
  assumes hf: "healthy (wp f)" and hg: "healthy (wp g)"
  shows "healthy (wp (f \<Sqinter> g))"
proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all only:wp_eval)
  fix b and P::"'s \<Rightarrow> real" and s::'s
  assume nP: "nneg P" and bP: "bounded_by b P"

  with hf have "bounded_by b (wp f P)" by(auto)
  hence "wp f P s \<le> b" by(blast)
  thus "min (wp f P s) (wp g P s) \<le> b" by(auto)

  from nP bP assms show "0 \<le> min (wp f P s) (wp g P s)" by(auto)
next
  fix P::"'s \<Rightarrow> real" and Q and s::'s
  from assms have mf: "mono_trans (wp f)" and mg: "mono_trans (wp g)" by(auto)
  assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
  hence "wp f P s \<le> wp f Q s" and "wp g P s \<le> wp g Q s"
    by(auto intro:le_funD[OF mono_transD[OF mf]] le_funD[OF mono_transD[OF mg]])
  thus "min (wp f P s) (wp g P s) \<le> min (wp f Q s) (wp g Q s)" by(auto)
next
  fix P::"'s \<Rightarrow> real" and c::real and s::'s
  assume sP: "sound P" and pos: "0 \<le> c"
  from assms have sf: "scaling (wp f)" and sg: "scaling (wp g)" by(auto)
  from pos have "c * min (wp f P s) (wp g P s) =
                 min (c * wp f P s) (c * wp g P s)"
    by(simp add:min_distrib)
  also from sP and pos
  have "... = min (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)"
    by(simp add:scalingD[OF sf] scalingD[OF sg])
  finally show "c * min (wp f P s) (wp g P s) =
                min (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)" .
qed

lemma nearly_healthy_wlp_DC:
  fixes f::"'s prog"
  assumes hf: "nearly_healthy (wlp f)"
      and hg: "nearly_healthy (wlp g)"
  shows "nearly_healthy (wlp (f \<Sqinter> g))"
proof(intro nearly_healthyI bounded_byI nnegI le_funI unitaryI2,
      simp_all add:wp_eval, safe)
  fix P::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P"
  with hf hg have utP: "unitary (wlp f P)" "unitary (wlp g P)" by(auto)
  thus "0 \<le> wlp f P s" "0 \<le> wlp g P s" by(auto)

  have "min (wlp f P s) (wlp g P s) \<le> wlp f P s" by(auto)
  also from utP have "... \<le> 1" by(auto)
  finally show "min (wlp f P s) (wlp g P s) \<le> 1" .

  fix Q::"'s \<Rightarrow> real"
  assume uQ: "unitary Q" and le: "P \<tturnstile> Q"
  have "min (wlp f P s) (wlp g P s) \<le> wlp f P s" by(auto)
  also from uP uQ le have "... \<le> wlp f Q s"
    by(auto intro:le_funD[OF nearly_healthy_monoD, OF hf])
  finally show "min (wlp f P s) (wlp g P s) \<le> wlp f Q s" .

  have "min (wlp f P s) (wlp g P s) \<le> wlp g P s" by(auto)
  also from uP uQ le have "... \<le> wlp g Q s"
    by(auto intro:le_funD[OF nearly_healthy_monoD, OF hg])
  finally show "min (wlp f P s) (wlp g P s) \<le> wlp g Q s" .
qed

lemma healthy_wp_AC:
  fixes f::"'s prog"
  assumes hf: "healthy (wp f)" and hg: "healthy (wp g)"
  shows "healthy (wp (f \<Squnion> g))"
proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all only:wp_eval)
  fix b and P::"'s \<Rightarrow> real" and s::'s
  assume nP: "nneg P" and bP: "bounded_by b P"

  with hf have "bounded_by b (wp f P)" by(auto)
  hence "wp f P s \<le> b" by(blast)
  moreover {
    from bP nP hg have "bounded_by b (wp g P)" by(auto)
    hence "wp g P s \<le> b" by(blast)
  }
  ultimately show "max (wp f P s) (wp g P s) \<le> b" by(auto)

  from nP bP assms have "0 \<le> wp f P s" by(auto)
  thus "0 \<le> max (wp f P s) (wp g P s)" by(auto)
next
  fix P::"'s \<Rightarrow> real" and Q and s::'s
  from assms have mf: "mono_trans (wp f)" and mg: "mono_trans (wp g)" by(auto)
  assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
  hence "wp f P s \<le> wp f Q s" and "wp g P s \<le> wp g Q s"
    by(auto intro:le_funD[OF mono_transD, OF mf] le_funD[OF mono_transD, OF mg])
  thus "max (wp f P s) (wp g P s) \<le> max (wp f Q s) (wp g Q s)" by(auto)
next
  fix P::"'s \<Rightarrow> real" and c::real and s::'s
  assume sP: "sound P" and pos: "0 \<le> c"
  from assms have sf: "scaling (wp f)" and sg: "scaling (wp g)" by(auto)
  from pos have "c * max (wp f P s) (wp g P s) =
                 max (c * wp f P s) (c * wp g P s)"
    by(simp add:max_distrib)
  also from sP and pos
  have "... = max (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)"
    by(simp add:scalingD[OF sf] scalingD[OF sg])
  finally show "c * max (wp f P s) (wp g P s) =
                max (wp f (\<lambda>s. c * P s) s) (wp g (\<lambda>s. c * P s) s)" .
qed

lemma nearly_healthy_wlp_AC:
  fixes f::"'s prog"
  assumes hf: "nearly_healthy (wlp f)"
      and hg: "nearly_healthy (wlp g)"
  shows "nearly_healthy (wlp (f \<Squnion> g))"
proof(intro nearly_healthyI bounded_byI nnegI unitaryI2 le_funI, simp_all only:wp_eval)
  fix b and P::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P"

  with hf have "wlp f P s \<le> 1" by(auto)
  moreover from uP hg have "unitary (wlp g P)" by(auto)
  hence "wlp g P s \<le> 1" by(auto)
  ultimately show "max (wlp f P s) (wlp g P s) \<le> 1" by(auto)

  from uP hf have "unitary (wlp f P)" by(auto)
  hence "0 \<le> wlp f P s" by(auto)
  thus "0 \<le> max (wlp f P s) (wlp g P s)" by(auto)
next
  fix P::"'s \<Rightarrow> real" and Q and s::'s
  assume uP: "unitary P" and uQ: "unitary Q" and le: "P \<tturnstile> Q"
  hence "wlp f P s \<le> wlp f Q s" and "wlp g P s \<le> wlp g Q s"
    by(auto intro:le_funD[OF nearly_healthy_monoD, OF hf]
                  le_funD[OF nearly_healthy_monoD, OF hg])
  thus "max (wlp f P s) (wlp g P s) \<le> max (wlp f Q s) (wlp g Q s)" by(auto)
qed

lemma healthy_wp_Embed:
  "healthy t \<Longrightarrow> healthy (wp (Embed t))"
  unfolding wp_def Embed_def by(simp)

lemma nearly_healthy_wlp_Embed:
  "nearly_healthy t \<Longrightarrow> nearly_healthy (wlp (Embed t))"
  unfolding wlp_def Embed_def by(simp)

lemma healthy_wp_repeat:
  assumes h_a: "healthy (wp a)"
  shows "healthy (wp (repeat n a))" (is "?X n")
proof(induct n)
  show "?X 0" by(auto simp:wp_eval)
next
  fix n assume IH: "?X n"
  thus "?X (Suc n)" by(simp add:healthy_wp_Seq h_a)
qed

lemma healthy_wp_SetDC:
  fixes prog::"'b \<Rightarrow> 'a prog" and S::"'a \<Rightarrow> 'b set"
  assumes healthy:  "\<And>x s. x \<in> S s \<Longrightarrow> healthy (wp (prog x))"
      and nonempty: "\<And>s. \<exists>x. x \<in> S s"
  shows "healthy (wp (SetDC prog S))" (is "healthy ?T")
proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all only:wp_eval)
  fix b and P::"'a \<Rightarrow> real" and s::'a
  assume bP: "bounded_by b P" and nP: "nneg P"
  hence sP: "sound P" by(auto)

  from nonempty obtain x where xin: "x \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(blast)
  moreover from sP and healthy
  have "\<forall>x\<in>(\<lambda>a. wp (prog a) P s) ` S s. 0 \<le> x" by(auto)
  ultimately have "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> x"
    by(intro cInf_lower bdd_belowI, auto)
  also from xin and healthy and sP and bP have "x \<le> b" by(blast)
  finally show "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> b" .

  from xin and sP and healthy
  show "0 \<le> Inf ((\<lambda>a. wp (prog a) P s) ` S s)" by(blast intro:cInf_greatest)
next
  fix P::"'a \<Rightarrow> real" and Q and s::'a
  assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"

  from nonempty obtain x where xin: "x \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(blast)
  moreover from sP and healthy
  have "\<forall>x\<in>(\<lambda>a. wp (prog a) P s) ` S s. 0 \<le> x" by(auto)
  moreover
  have "\<forall>x\<in>(\<lambda>a. wp (prog a) Q s) ` S s. \<exists>y\<in>(\<lambda>a. wp (prog a) P s) ` S s. y \<le> x"
  proof(rule ballI, clarify, rule bexI)
    fix x and a assume ain: "a \<in> S s"
    with healthy and sP and sQ and le show "wp (prog a) P s \<le> wp (prog a) Q s"
      by(auto dest:mono_transD[OF healthy_monoD])
    from ain show "wp (prog a) P s \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(simp)
  qed
  ultimately
  show "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> Inf ((\<lambda>a. wp (prog a) Q s) ` S s)"
    by(intro cInf_mono, blast+)
next
  fix P::"'a \<Rightarrow> real" and c::real and s::'a
  assume sP: "sound P" and pos: "0 \<le> c"
  from nonempty obtain x where xin: "x \<in> (\<lambda>a. wp (prog a) P s) ` S s" by(blast)
  have "c * Inf ((\<lambda>a. wp (prog a) P s) ` S s) =
        Inf (op * c ` ((\<lambda>a. wp (prog a) P s) ` S s))" (is "?U = ?V")
  proof(rule antisym)
    show "?U \<le> ?V"
    proof(rule cInf_greatest)
      from nonempty show "op * c ` (\<lambda>a. wp (prog a) P s) ` S s \<noteq> {}" by(auto)
      fix x assume "x \<in> op * c ` (\<lambda>a. wp (prog a) P s) ` S s"
      then obtain y where yin: "y \<in> (\<lambda>a. wp (prog a) P s) ` S s" and rwx: "x = c * y" by(auto)
      have "Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> y"
      proof(intro cInf_lower[OF yin] bdd_belowI)
        fix z assume zin: "z \<in> (\<lambda>a. wp (prog a) P s) ` S s"
        then obtain a where "a \<in> S s" and "z = wp (prog a) P s" by(auto)
        with sP show "0 \<le> z" by(auto dest:healthy)
      qed
      with pos rwx show "c * Inf ((\<lambda>a. wp (prog a) P s) ` S s) \<le> x" by(auto intro:mult_left_mono)
    qed
    show "?V \<le> ?U"
    proof(cases)
      assume cz: "c = 0"
      moreover {
        from nonempty obtain c where "c \<in> S s" by(auto)
        hence "\<exists>x. \<exists>xa\<in>S s. x = wp (prog xa) P s" by(auto)
      }
      ultimately show ?thesis by(simp add:image_def)
    next
      assume cnz: "c \<noteq> 0"
      have "inverse c * ?V \<le> inverse c * ?U"
      proof(simp add:mult.assoc[symmetric] cnz del:Inf_image_eq, rule cInf_greatest)
        from nonempty show "(\<lambda>a. wp (prog a) P s) ` S s \<noteq> {}" by(auto)
        fix x assume "x \<in> (\<lambda>a. wp (prog a) P s) ` S s"
        then obtain a where ain: "a \<in> S s" and rwx: "x = wp (prog a) P s" by(auto)
        have "Inf (op * c ` (\<lambda>a. wp (prog a) P s) ` S s) \<le> c * x"
        proof(intro cInf_lower bdd_belowI)
          from ain show "c * x \<in> op * c ` (\<lambda>a. wp (prog a) P s) ` S s"
            by(auto simp:rwx)
          fix z assume "z \<in> op * c ` (\<lambda>a. wp (prog a) P s) ` S s"
          then obtain b where "b \<in> S s" and rwz: "z = c * wp (prog b) P s" by(auto)
          with sP have "0 \<le> wp (prog b) P s" by(auto dest:healthy)
          with pos show "0 \<le> z" by(auto simp:rwz intro:mult_nonneg_nonneg)
        qed
        moreover from pos have "0 \<le> inverse c" by(simp)
        ultimately
        have "inverse c * Inf (op * c ` (\<lambda>a. wp (prog a) P s) ` S s) \<le> inverse c * (c * x)"
          by(auto intro:mult_left_mono)
        also from cnz have "... = x" by(simp)
        finally show "inverse c * Inf (op * c ` (\<lambda>a. wp (prog a) P s) ` S s) \<le> x" .
      qed
      with pos have "c * (inverse c * ?V) \<le> c * (inverse c * ?U)"
        by(auto intro:mult_left_mono)
      with cnz show ?thesis by(simp add:mult.assoc[symmetric])
    qed
  qed
  also have "... = Inf ((\<lambda>a. c * wp (prog a) P s) ` S s)"
    by(simp add:image_comp[symmetric] o_def)
  also from sP and pos have "... = Inf ((\<lambda>a. wp (prog a) (\<lambda>s. c * P s) s) ` S s)"
    by(simp add:scalingD[OF healthy_scalingD, OF healthy] cong:image_cong)
  finally show "c * Inf ((\<lambda>a. wp (prog a) P s) ` S s) =
                Inf ((\<lambda>a. wp (prog a) (\<lambda>s. c * P s) s) ` S s)" .
qed

lemma nearly_healthy_wlp_SetDC:
  fixes prog::"'b \<Rightarrow> 'a prog" and S::"'a \<Rightarrow> 'b set"
  assumes healthy:  "\<And>x s. x \<in> S s \<Longrightarrow> nearly_healthy (wlp (prog x))"
      and nonempty: "\<And>s. \<exists>x. x \<in> S s"
  shows "nearly_healthy (wlp (SetDC prog S))" (is "nearly_healthy ?T")
proof(intro nearly_healthyI unitaryI2 bounded_byI nnegI le_funI, simp_all only:wp_eval)
  fix b and P::"'a \<Rightarrow> real" and s::'a
  assume uP: "unitary P"

  from nonempty obtain x where xin: "x \<in> (\<lambda>a. wlp (prog a) P s) ` S s" by(blast)
  moreover {
    from uP healthy
    have "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. unitary x" by(auto)
    hence "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. 0 \<le> x s" by(auto)
    hence "\<forall>y\<in>(\<lambda>a. wlp (prog a) P s) ` S s. 0 \<le> y" by(auto)
  }
  ultimately have "Inf ((\<lambda>a. wlp (prog a) P s) ` S s) \<le> x" by(intro cInf_lower bdd_belowI, auto)
  also from xin healthy uP have "x \<le> 1" by(blast)
  finally show "Inf ((\<lambda>a. wlp (prog a) P s) ` S s) \<le> 1" .

  from xin uP healthy
  show "0 \<le> Inf ((\<lambda>a. wlp (prog a) P s) ` S s)"
    by(blast dest!:unitary_sound[OF nearly_healthy_unitaryD[OF _ uP]]
             intro:cInf_greatest)
next
  fix P::"'a \<Rightarrow> real" and Q and s::'a
  assume uP: "unitary P" and uQ: "unitary Q" and le: "P \<tturnstile> Q"

  from nonempty obtain x where xin: "x \<in> (\<lambda>a. wlp (prog a) P s) ` S s" by(blast)
  moreover {
    from uP healthy
    have "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. unitary x" by(auto)
    hence "\<forall>x\<in>(\<lambda>a. wlp (prog a) P) ` S s. 0 \<le> x s" by(auto)
    hence "\<forall>y\<in>(\<lambda>a. wlp (prog a) P s) ` S s. 0 \<le> y" by(auto)
  }
  moreover
  have "\<forall>x\<in>(\<lambda>a. wlp (prog a) Q s) ` S s. \<exists>y\<in>(\<lambda>a. wlp (prog a) P s) ` S s. y \<le> x"
  proof(rule ballI, clarify, rule bexI)
    fix x and a assume ain: "a \<in> S s"
    from uP uQ le show "wlp (prog a) P s \<le> wlp (prog a) Q s"
      by(auto intro:le_funD[OF nearly_healthy_monoD[OF healthy, OF ain]])
    from ain show "wlp (prog a) P s \<in> (\<lambda>a. wlp (prog a) P s) ` S s" by(simp)
  qed
  ultimately
  show "Inf ((\<lambda>a. wlp (prog a) P s) ` S s) \<le> Inf ((\<lambda>a. wlp (prog a) Q s) ` S s)"
    by(intro cInf_mono, blast+)
qed

lemma healthy_wp_SetPC:
  fixes p::"'s \<Rightarrow> 'a \<Rightarrow> real"
  and   f::"'a \<Rightarrow> 's prog"
  assumes healthy: "\<And>a s. a \<in> supp (p s) \<Longrightarrow> healthy (wp (f a))"
      and sound: "\<And>s. sound (p s)"
      and sub_dist: "\<And>s. (\<Sum>a\<in>supp (p s). p s a) \<le> 1"
  shows "healthy (wp (SetPC f p))" (is "healthy ?X")
proof(intro healthy_parts bounded_byI nnegI le_funI, simp_all add:wp_eval)
  fix b and P::"'s \<Rightarrow> real" and s::'s
  assume bP: "bounded_by b P" and nP: "nneg P"
  hence sP: "sound P" by(auto)

  from sP and bP and healthy have "\<And>a s. a \<in> supp (p s) \<Longrightarrow> wp (f a) P s \<le> b"
    by(blast dest:healthy_bounded_byD)
  with sound have "(\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) \<le> (\<Sum>a\<in>supp (p s). p s a * b)"
    by(blast intro:setsum_mono mult_left_mono)
  also have "... = (\<Sum>a\<in>supp (p s). p s a) * b"
    by(simp add:setsum_left_distrib)
  also {
    from bP and nP have "0 \<le> b" by(blast)
    with sub_dist have "(\<Sum>a\<in>supp (p s). p s a) * b \<le> 1 * b"
      by(rule mult_right_mono)
  }
  also have "1 * b = b" by(simp)
  finally show "(\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) \<le> b" .

  show "0 \<le> (\<Sum>a\<in>supp (p s). p s a * wp (f a) P s)"
  proof(rule setsum_nonneg, clarify, rule mult_nonneg_nonneg)
    fix x
    from sound show "0 \<le> p s x" by(blast)
    assume "x \<in> supp (p s)" with sP and healthy
    show "0 \<le> wp (f x) P s" by(blast)
  qed
next
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s
  assume s_P: "sound P" and s_Q: "sound Q" and ent: "P \<tturnstile> Q"
  with healthy have "\<And>a. a \<in> supp (p s) \<Longrightarrow> wp (f a) P s \<le> wp (f a) Q s"
    by(blast)
  with sound show "(\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) \<le>
                   (\<Sum>a\<in>supp (p s). p s a * wp (f a) Q s)"
    by(blast intro:setsum_mono mult_left_mono)
next
  fix P::"'s \<Rightarrow> real" and c::real and s::'s
  assume sound: "sound P" and pos: "0 \<le> c"
  have "c * (\<Sum>a\<in>supp (p s). p s a * wp (f a) P s) =
        (\<Sum>a\<in>supp (p s). p s a * (c * wp (f a) P s))"
       (is "?A = ?B")
    by(simp add:setsum_right_distrib ac_simps)
  also from sound and pos and healthy
  have "... = (\<Sum>a\<in>supp (p s). p s a * wp (f a) (\<lambda>s. c * P s) s)"
    by(auto simp:scalingD[OF healthy_scalingD])
  finally show "?A = ..." .
qed

lemma nearly_healthy_wlp_SetPC:
  fixes p::"'s \<Rightarrow> 'a \<Rightarrow> real"
  and   f::"'a \<Rightarrow> 's prog"
  assumes healthy: "\<And>a s. a \<in> supp (p s) \<Longrightarrow> nearly_healthy (wlp (f a))"
      and sound: "\<And>s. sound (p s)"
      and sub_dist: "\<And>s. (\<Sum>a\<in>supp (p s). p s a) \<le> 1"
  shows "nearly_healthy (wlp (SetPC f p))" (is "nearly_healthy ?X")
proof(intro nearly_healthyI unitaryI2 bounded_byI nnegI le_funI, simp_all only:wp_eval)
  fix b and P::"'s \<Rightarrow> real" and s::'s
  assume uP: "unitary P"

  from uP healthy have "\<And>a. a \<in> supp (p s) \<Longrightarrow> unitary (wlp (f a) P)" by(auto)
  hence "\<And>a. a \<in> supp (p s) \<Longrightarrow> wlp (f a) P s \<le> 1" by(auto)
  with sound have "(\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s) \<le> (\<Sum>a\<in>supp (p s). p s a * 1)"
    by(blast intro:setsum_mono mult_left_mono)
  also have "... = (\<Sum>a\<in>supp (p s). p s a)"
    by(simp add:setsum_left_distrib)
  also note sub_dist
  finally show "(\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s) \<le> 1" .
  show "0 \<le> (\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s)"
  proof(rule setsum_nonneg, clarify, rule mult_nonneg_nonneg)
    fix x
    from sound show "0 \<le> p s x" by(blast)
    assume "x \<in> supp (p s)" with uP healthy
    show "0 \<le> wlp (f x) P s" by(blast)
  qed
next
  fix P::"'s expect" and Q::"'s expect" and s
  assume uP: "unitary P" and uQ: "unitary Q" and le: "P \<tturnstile> Q"
  hence "\<And>a. a \<in> supp (p s) \<Longrightarrow> wlp (f a) P s \<le> wlp (f a) Q s"
    by(blast intro:le_funD[OF nearly_healthy_monoD, OF healthy])
  with sound show "(\<Sum>a\<in>supp (p s). p s a * wlp (f a) P s) \<le>
                   (\<Sum>a\<in>supp (p s). p s a * wlp (f a) Q s)"
    by(blast intro:setsum_mono mult_left_mono)
qed

lemma healthy_wp_Apply:
  "healthy (wp (Apply f))"
  unfolding Apply_def wp_def by(blast)

lemma nearly_healthy_wlp_Apply:
  "nearly_healthy (wlp (Apply f))"
  by(intro nearly_healthyI unitaryI2 nnegI bounded_byI, auto simp:o_def wp_eval)

lemma healthy_wp_Bind:
  fixes f::"'s \<Rightarrow> 'a"
  assumes hsub: "\<And>s. healthy (wp (p (f s)))"
  shows "healthy (wp (Bind f p))"
proof(intro healthy_parts nnegI bounded_byI le_funI, simp_all only:wp_eval)
  fix b and P::"'s expect" and s::'s
  assume bP: "bounded_by b P" and nP: "nneg P"
  with hsub have "bounded_by b (wp (p (f s)) P)" by(auto)
  thus "wp (p (f s)) P s \<le> b" by(auto)
  from bP nP hsub have "nneg (wp (p (f s)) P)" by(auto)
  thus "0 \<le> wp (p (f s)) P s" by(auto)
next
  fix P Q::"'s expect" and s::'s
  assume "sound P" "sound Q" "P \<tturnstile> Q"
  thus "wp (p (f s)) P s \<le> wp (p (f s)) Q s"
    by(rule le_funD[OF mono_transD, OF healthy_monoD, OF hsub])
next
  fix P::"'s expect" and c::real and s::'s
  assume "sound P" and "0 \<le> c"
  thus "c * wp (p (f s)) P s = wp (p (f s)) (\<lambda>s. c * P s) s"
    by(simp add:scalingD[OF healthy_scalingD, OF hsub])
qed

lemma nearly_healthy_wlp_Bind:
  fixes f::"'s \<Rightarrow> 'a"
  assumes hsub: "\<And>s. nearly_healthy (wlp (p (f s)))"
  shows "nearly_healthy (wlp (Bind f p))"
proof(intro nearly_healthyI unitaryI2 nnegI bounded_byI le_funI, simp_all only:wp_eval)
  fix P::"'s expect" and s::'s assume uP: "unitary P"
  with hsub have "unitary (wlp (p (f s)) P)" by(auto)
  thus "0 \<le> wlp (p (f s)) P s" "wlp (p (f s)) P s \<le> 1" by(auto)

  fix Q::"'s expect"
  assume "unitary Q" "P \<tturnstile> Q"
  with uP show "wlp (p (f s)) P s \<le> wlp (p (f s)) Q s"
    by(blast intro:le_funD[OF nearly_healthy_monoD, OF hsub])
qed

subsection {* Healthiness for Loops *}

lemma wp_loop_step_mono:
  fixes t u::"'s trans"
  assumes hb: "healthy (wp body)"
      and le: "le_trans t u"
      and ht: "\<And>P. sound P \<Longrightarrow> sound (t P)"
      and hu: "\<And>P. sound P \<Longrightarrow> sound (u P)"
  shows "le_trans (wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))
                  (wp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
proof(intro le_transI le_funI, simp add:wp_eval)
  fix P::"'s expect" and s::'s
  assume sP: "sound P"
  with le have "t P \<tturnstile> u P" by(auto)
  moreover from sP ht hu have "sound (t P)" "sound (u P)" by(auto)
  ultimately have "wp body (t P) s \<le> wp body (u P) s"
    by(auto intro:le_funD[OF mono_transD, OF healthy_monoD, OF hb])
  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

lemma wlp_loop_step_mono:
  fixes t u::"'s trans"
  assumes mb: "nearly_healthy (wlp body)"
      and le: "le_utrans t u"
      and ht: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
      and hu: "\<And>P. unitary P \<Longrightarrow> unitary (u P)"
  shows "le_utrans (wlp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))
                   (wlp (body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))"
proof(intro le_utransI le_funI, simp add:wp_eval)
  fix P::"'s expect" and s::'s
  assume uP: "unitary P"
  with le have "t P \<tturnstile> u P" by(auto)
  moreover from uP ht hu have "unitary (t P)" "unitary (u P)" by(auto)
  ultimately have "wlp body (t P) s \<le> wlp body (u P) s"
    by(rule le_funD[OF nearly_healthy_monoD[OF mb]])
  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

text {* For each sound expectation, we have a pre fixed point of the loop body.
This lets us use the relevant fixed-point lemmas. *}
lemma lfp_loop_fp:
  assumes hb: "healthy (wp body)"
      and sP: "sound P"
  shows "\<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"
proof(rule le_funI)
  fix s
  from sP have "sound (\<lambda>s. bound_of P)" by(auto)
  moreover hence "bounded_by (bound_of P) (\<lambda>s. bound_of P)" by(auto)
  ultimately have "bounded_by (bound_of P) (wp body (\<lambda>s. bound_of P))"
    using hb by(auto)
  hence "wp body (\<lambda>s. bound_of P) s \<le> bound_of P" by(auto)
  moreover from sP have "P s \<le> bound_of P" by(auto)
  ultimately have "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>a. bound_of P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
                   \<guillemotleft>G\<guillemotright> s * bound_of P + (1 - \<guillemotleft>G\<guillemotright> s) * bound_of P"
    by(blast intro:add_mono mult_left_mono)
  thus "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>a. bound_of P) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> bound_of P"
    by(simp add:algebra_simps negate_embed)
qed

lemma lfp_loop_greatest:
  fixes P::"'s expect"
  assumes lb: "\<And>R. \<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile> R \<Longrightarrow> sound R \<Longrightarrow> Q \<tturnstile> R"
      and hb: "healthy (wp body)"
      and sP: "sound P"
      and sQ: "sound Q"
  shows "Q \<tturnstile> lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
  using sP by(auto intro!:lfp_exp_greatest[OF lb sQ] sP lfp_loop_fp hb)

lemma wlp_loop_step_unitary:
  fixes t u::"'s trans"
  assumes hb: "nearly_healthy (wlp body)"
      and ht: "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
      and uP: "unitary P"
  shows "unitary (wlp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
proof(intro unitaryI2 nnegI bounded_byI, simp_all add:wp_eval)
  fix s::'s
  from ht uP have utP: "unitary (t P)" by(auto)
  with hb have "unitary (wlp body (t P))" by(auto)
  hence "0 \<le> wlp body (t P) s" by(auto)
  with uP show "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 ht uP have "bounded_by 1 (t P)" by(auto)
  with utP hb have "bounded_by 1 (wlp body (t P))" by(auto)
  hence "wlp body (t P) s \<le> 1" by(auto)
  with uP have "\<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)
  finally show "\<guillemotleft>G\<guillemotright> s * wlp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le> 1" .
qed

lemma wp_loop_step_sound:
  fixes t u::"'s trans"
  assumes hb: "healthy (wp body)"
      and ht: "\<And>P. sound P \<Longrightarrow> sound (t P)"
      and sP: "sound P"
  shows "sound (wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P)"
proof(intro soundI2 nnegI bounded_byI, simp_all add:wp_eval)
  fix s::'s
  from ht sP have stP: "sound (t P)" by(auto)
  with hb have "0 \<le> wp body (t P) s" by(auto)
  with sP show "0 \<le> \<guillemotleft> G \<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft> G \<guillemotright> s) * P s"
    by(auto intro!:add_nonneg_nonneg mult_nonneg_nonneg)

  from ht sP have "sound (t P)" by(auto)
  moreover hence "bounded_by (bound_of (t P)) (t P)" by(auto)
  ultimately have "wp body (t P) s \<le> bound_of (t P)" using hb by(auto)
  hence "wp body (t P) s \<le> max (bound_of P) (bound_of (t P))" by(auto)
  moreover {
    from sP have "P s \<le> bound_of P" by(auto)
    hence "P s \<le> max (bound_of P) (bound_of (t P))" by(auto)
  }
  ultimately
  have "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
        \<guillemotleft>G\<guillemotright> s * max (bound_of P) (bound_of (t P)) +
        (1 - \<guillemotleft>G\<guillemotright> s) * max (bound_of P) (bound_of (t P))"
    by(blast intro:add_mono mult_left_mono)
  also have "... = max (bound_of P) (bound_of (t P))" by(simp add:algebra_simps)
  finally show "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<le>
                max (bound_of P) (bound_of (t P))" .
qed

text {* This gives the equivalence with the alternative definition for
  loops\citep[\S7, p.~198, footnote 23]{McIver_M_04}. *}

lemma wlp_Loop1:
  fixes body :: "'s prog"
  assumes unitary: "unitary P"
      and healthy: "nearly_healthy (wlp body)"
  shows "wlp (do G \<longrightarrow> body od) P =
   gfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
  (is "?X = gfp_exp (?Y P)")
proof -
  let "?Z u" = "(body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"
  show ?thesis
  proof(unfold wp_eval, intro gfp_pulldown assms le_funI)
    fix u P
    show "wlp (?Z u) P = ?Y P (u P)" by(simp add:wp_eval negate_embed)
  next
    fix t::"'s trans" and P::"'s expect"
    assume ut: "\<And>Q. unitary Q \<Longrightarrow> unitary (t Q)" and uP: "unitary P"
    thus "unitary (wlp (?Z t) P)"
      by(rule wlp_loop_step_unitary[OF healthy])
  next
    fix P Q::"'s expect"
    assume uP: "unitary P" and uQ: "unitary Q"
    show "unitary (\<lambda>a. \<guillemotleft> G \<guillemotright> a * wlp body Q a + \<guillemotleft> \<N> G \<guillemotright> a * P a)"
    proof(intro unitaryI2 nnegI bounded_byI)
      fix s::'s
      from healthy uQ
      have "unitary (wlp body Q)" by(auto)
      hence "0 \<le> wlp body Q s" by(auto)
      with uP show "0 \<le> \<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
        by(auto intro!:add_nonneg_nonneg mult_nonneg_nonneg)

      from healthy uQ have "bounded_by 1 (wlp body Q)" by(auto)
      with uP have "\<guillemotleft>G\<guillemotright> s * wlp body Q 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)
      finally show "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> 1"
        by(simp add:negate_embed)
    qed
  next
    fix P Q R::"'s expect" and s::'s
    assume uP: "unitary P" and uQ: "unitary Q" and uR: "unitary R"
       and le: "Q \<tturnstile> R"
    hence "wlp body Q s \<le> wlp body R s"
      by(blast intro:le_funD[OF nearly_healthy_monoD, OF healthy])
    thus "\<guillemotleft>G\<guillemotright> s * wlp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
          \<guillemotleft>G\<guillemotright> s * wlp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
      by(auto intro:mult_left_mono)
  next
    fix t u::"'s trans"
    assume "le_utrans t u"
           "\<And>P. unitary P \<Longrightarrow> unitary (t P)"
           "\<And>P. unitary P \<Longrightarrow> unitary (u P)"
    thus "le_utrans (wlp (?Z t)) (wlp (?Z u))"
      by(blast intro!:wlp_loop_step_mono[OF healthy])
  qed
qed

lemma wp_loop_sound:
  assumes sP: "sound P"
      and hb: "healthy (wp body)"
  shows "sound (wp do G \<longrightarrow> body od P)"
  unfolding wp_eval
proof(intro lfp_trans_sound sP)
  let ?v = "\<lambda>P s. bound_of P"
  show "le_trans (wp (body ;; Embed ?v \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) ?v"
    by(intro le_transI, simp add:wp_eval lfp_loop_fp[unfolded negate_embed] hb)
  show "\<And>P. sound P \<Longrightarrow> sound (?v P)" by(auto)
qed

text {* Likewise, we can rewrite strict loops. *}
lemma wp_Loop1:
  fixes body :: "'s prog"
  assumes sP: "sound P"
      and healthy: "healthy (wp body)"
  shows "wp (do G \<longrightarrow> body od) P =
   lfp_exp (\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
  (is "?X = lfp_exp (?Y P)")
proof -
  let "?Z u" = "(body ;; Embed u \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)"
  show ?thesis
  proof(unfold wp_eval, intro lfp_pulldown assms le_funI sP mono_transI)
    fix u P
    show "wp (?Z u) P = ?Y P (u P)" by(simp add:wp_eval negate_embed)
  next
    fix t::"'s trans" and P::"'s expect"
    assume ut: "\<And>Q. sound Q \<Longrightarrow> sound (t Q)" and uP: "sound P"
    with healthy show "sound (wp (?Z t) P)" by(rule wp_loop_step_sound)
  next
    fix P Q::"'s expect"
    assume sP: "sound P" and sQ: "sound Q"
    show "sound (\<lambda>a. \<guillemotleft> G \<guillemotright> a * wp body Q a + \<guillemotleft> \<N> G \<guillemotright> a * P a)"
    proof(intro soundI2 nnegI bounded_byI)
      fix s::'s
      from sQ have "nneg Q" "bounded_by (bound_of Q) Q" by(auto)
      with healthy have "bounded_by (bound_of Q) (wp body Q)" by(auto)
      hence "wp body Q s \<le> bound_of Q" by(auto)
      hence "wp body Q s \<le> max (bound_of P) (bound_of Q)" by(auto)
      moreover {
        from sP have "P s \<le> bound_of P" by(auto)
        hence "P s \<le> max (bound_of P) (bound_of Q)" by(auto)
      }
      ultimately have "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
                       \<guillemotleft>G\<guillemotright> s * max (bound_of P) (bound_of Q) +
                       \<guillemotleft>\<N> G\<guillemotright> s * max (bound_of P) (bound_of Q)"
        by(auto intro!:add_mono mult_left_mono)
      also have "... = max (bound_of P) (bound_of Q)" by(simp add:algebra_simps negate_embed)
      finally show "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> max (bound_of P) (bound_of Q)" .

      from sP have "0 \<le> P s" by(auto)
      moreover from sQ healthy have "0 \<le> wp body Q s" by(auto)
      ultimately show "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
        by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
    qed
  next
    fix P Q R::"'s expect" and s::'s
    assume sQ: "sound Q" and sR: "sound R"
       and le: "Q \<tturnstile> R"
    hence "wp body Q s \<le> wp body R s"
      by(blast intro:le_funD[OF mono_transD, OF healthy_monoD, OF healthy])
    thus "\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
          \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s"
      by(auto intro:mult_left_mono)
  next
    fix t u::"'s trans"
    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)"
    with healthy show "le_trans (wp (?Z t)) (wp (?Z u))"
      by(rule wp_loop_step_mono)
  next
    from healthy show "le_trans (wp (?Z (\<lambda>P s. bound_of P))) (\<lambda>P s. bound_of P)"
      by(intro le_transI, simp add:wp_eval lfp_loop_fp[unfolded negate_embed])
  next
    fix P::"'s expect" and s::'s
    assume "sound P"
    thus "sound (\<lambda>s. bound_of P)" by(auto)
  qed
qed

lemma nearly_healthy_wlp_loop:
  fixes body::"'s prog"
  assumes hb: "nearly_healthy (wlp body)"
  shows "nearly_healthy (wlp (do G \<longrightarrow> body od))"
proof(intro nearly_healthyI unitaryI2 nnegI2 bounded_byI2, simp_all add:wlp_Loop1 hb)
  fix P::"'s expect"
  assume uP: "unitary P"
  let "?X R" = "\<lambda>Q s. \<guillemotleft> G \<guillemotright> s * wlp body Q s + \<guillemotleft> \<N> G \<guillemotright> s * R s"

  show "\<lambda>s. 0 \<tturnstile> gfp_exp (?X P)"
  proof(rule gfp_exp_upperbound)
    show "unitary (\<lambda>s. 0::real)" by(auto)
    with hb have "unitary (wlp body (\<lambda>s. 0))" by(auto)
    with uP show "\<lambda>s. 0 \<tturnstile> (?X P (\<lambda>s. 0))"
      by(blast intro!:le_funI add_nonneg_nonneg mult_nonneg_nonneg)
  qed

  show "gfp_exp (?X P) \<tturnstile> \<lambda>s. 1"
  proof(rule gfp_exp_least)
    show "unitary (\<lambda>s. 1::real)" by(auto)
    fix Q::"'s expect"
    assume "unitary Q"
    thus "Q \<tturnstile> \<lambda>s. 1" by(auto)
  qed

  fix Q::"'s expect"
  assume uQ: "unitary Q" and le: "P \<tturnstile> Q"
  show "gfp_exp (?X P) \<tturnstile> gfp_exp (?X Q)"
  proof(rule gfp_exp_least)
    fix R::"'s expect" assume uR: "unitary R"
    assume fp: "R \<tturnstile> ?X P R"
    also from le have "... \<tturnstile> ?X Q R"
      by(blast intro:add_mono mult_left_mono le_funI)
    finally show "R \<tturnstile> gfp_exp (?X Q)"
      using uR by(auto intro:gfp_exp_upperbound)
  next
    show "unitary (gfp_exp (?X Q))"
    proof(rule gfp_exp_unitary, intro unitaryI2 nnegI bounded_byI)
      fix R::"'s expect" and s::'s assume uR: "unitary R"
      with hb have ubP: "unitary (wlp body R)" by(auto)
      with uQ show "0 \<le> \<guillemotleft> G \<guillemotright> s * wlp body R s + \<guillemotleft> \<N> G \<guillemotright> s * Q s"
        by(blast intro:add_nonneg_nonneg mult_nonneg_nonneg)

      from ubP uQ have "wlp body R s \<le> 1" "Q s \<le> 1" by(auto)
      hence "\<guillemotleft> G \<guillemotright> s * wlp body R s + \<guillemotleft> \<N> G \<guillemotright> s * Q s \<le> \<guillemotleft>G\<guillemotright> s * 1 + \<guillemotleft>\<N> G\<guillemotright> s * 1"
        by(blast intro:add_mono mult_left_mono)
      thus "\<guillemotleft> G \<guillemotright> s * wlp body R s + \<guillemotleft> \<N> G \<guillemotright> s * Q s \<le> 1"
        by(simp add:negate_embed)
    qed
  qed
qed

text {* We show healthiness by appealing to the properties of expectation fixed points, applied
to the alternative loop definition. *}
lemma healthy_wp_loop:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
  shows "healthy (wp (do G \<longrightarrow> body od))"
proof -
  let "?X P" = "(\<lambda>Q s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * P s)"
  show ?thesis
  proof(intro healthy_parts bounded_byI2 nnegI2, simp_all add:wp_Loop1 hb soundI2 sound_intros)
    fix P::"'s expect" and c::real and s::'s
    assume sP: "sound P" and nnc: "0 \<le> c"
    show "c * (lfp_exp (?X P)) s = lfp_exp (?X (\<lambda>s. c * P s)) s"
    proof(cases)
      assume "c = 0" thus ?thesis
      proof(simp, intro antisym)
        from hb have fp: "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>_. 0) s \<tturnstile> \<lambda>s. 0" by(simp)
        hence "lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s) \<tturnstile> \<lambda>s. 0"
          by(auto intro:lfp_exp_lowerbound)
        thus "lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s) s \<le> 0" by(auto)
        have "\<lambda>s. 0 \<tturnstile> lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s)"
          by(auto intro:lfp_exp_greatest fp)
        thus "0 \<le> lfp_exp (\<lambda>P s. \<guillemotleft>G\<guillemotright> s * wp body P s) s" by(auto)
      qed
    next
      have onesided: "\<And>P c. c \<noteq> 0 \<Longrightarrow> 0 \<le> c \<Longrightarrow> sound P \<Longrightarrow>
            \<lambda>a. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) a \<tturnstile>
                    lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * (c * P b))"
      proof -
        fix P::"'s expect" and c::real
        assume cnz: "c \<noteq> 0" and nnc: "0 \<le> c" and sP: "sound P"
        with nnc have cpos: "0 < c" by(auto)
        hence nnic: "0 \<le> inverse c" by(auto)
        show "\<lambda>a. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) a \<tturnstile>
              lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * (c * P b))"
        proof(rule lfp_exp_greatest)
          fix Q::"'s expect"
          assume sQ: "sound Q"
             and fp: "\<lambda>b. \<guillemotleft>G\<guillemotright> b * wp body Q b + \<guillemotleft>\<N> G\<guillemotright> b * (c * P b) \<tturnstile> Q"
          hence "\<And>s. \<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * (c * P s) \<le> Q s" by(auto)
          with nnic
          have "\<And>s. inverse c * (\<guillemotleft>G\<guillemotright> s * wp body Q s + \<guillemotleft>\<N> G\<guillemotright> s * (c * P s)) \<le>
                     inverse c * Q s"
            by(auto intro:mult_left_mono)
          hence "\<And>s. \<guillemotleft>G\<guillemotright> s * (inverse c * wp body Q s) + (inverse c * c) * \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
                     inverse c * Q s"
            by(simp add:algebra_simps)
          hence "\<And>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. inverse c * Q s) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le>
                     inverse c * Q s"
            by(simp add:cnz scalingD[OF healthy_scalingD, OF hb sQ nnic])
          hence "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. inverse c * Q s) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile>
                 \<lambda>s. inverse c * Q s" by(rule le_funI)
          moreover from nnic sQ have "sound (\<lambda>s. inverse c * Q s)"
            by(iprover intro:sound_intros)
          ultimately have "lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) \<tturnstile>
                           \<lambda>s. inverse c * Q s"
            by(rule lfp_exp_lowerbound)
          hence "\<And>s. lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) s \<le> inverse c * Q s"
            by(rule le_funD)
          with nnc
          have "\<And>s. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) s \<le>
                     c * (inverse c * Q s)"
            by(auto intro:mult_left_mono)
          also from cnz have "\<And>s. ... s = Q s" by(simp)
          finally show "\<lambda>a. c * lfp_exp (\<lambda>a b. \<guillemotleft>G\<guillemotright> b * wp body a b + \<guillemotleft>\<N> G\<guillemotright> b * P b) a \<tturnstile> Q"
            by(rule le_funI)
        next
          from sP have "sound (\<lambda>s. bound_of P)" by(auto)
          with hb sP have "sound (lfp_exp (?X P))"
            by(blast intro:lfp_exp_sound lfp_loop_fp)
          with nnc show "sound (\<lambda>s. c * lfp_exp (?X P) s)"
            by(auto intro!:sound_intros)

          from hb sP nnc
          show "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. bound_of (\<lambda>s. c * P s)) s +
                    \<guillemotleft>\<N> G\<guillemotright> s * (c * P s) \<tturnstile> \<lambda>s. bound_of (\<lambda>s. c * P s)"
            by(iprover intro:lfp_loop_fp sound_intros)

          from sP nnc show "sound (\<lambda>s. bound_of (\<lambda>s. c * P s))"
            by(auto intro!:sound_intros)
        qed
      qed

      assume nzc: "c \<noteq> 0"
      show ?thesis (is "?X P c s = ?Y P c s")
      proof(rule fun_cong[where x=s], rule antisym)
        from nzc nnc sP show "?X P c \<tturnstile> ?Y P c" by(rule onesided)

        from nzc have nzic: "inverse c \<noteq> 0" by(auto)
        moreover with nnc have nnic: "0 \<le> inverse c" by(auto)
        moreover from nnc sP have scP: "sound (\<lambda>s. c * P s)" by(auto intro!:sound_intros)
        ultimately have "?X (\<lambda>s. c * P s) (inverse c) \<tturnstile> ?Y (\<lambda>s. c * P s) (inverse c)"
          by(rule onesided)
        with nnc have "\<lambda>s. c * ?X (\<lambda>s. c * P s) (inverse c) s \<tturnstile>
                       \<lambda>s. c * ?Y (\<lambda>s. c * P s) (inverse c) s"
          by(blast intro:mult_left_mono)
        with nzc show "?Y P c \<tturnstile> ?X P c" by(simp add:mult.assoc[symmetric])
      qed
    qed
  next
    fix P::"'s expect" and b::real
    assume bP: "bounded_by b P" and nP: "nneg P"
    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 hb have "bounded_by b (wp body (\<lambda>s. b))" by(auto)
      hence "wp body (\<lambda>s. b) s \<le> b" by(auto)
      moreover from bP have "P s \<le> b" by(auto)
      ultimately have "\<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)
      also have "... = b" by(simp add:negate_embed field_simps)
      finally show "\<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. b) s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<le> b" .
      from bP nP have "0 \<le> b" by(auto)
      thus "sound (\<lambda>s. b)" by(auto)
    qed
    from hb bP nP 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(auto dest!:sound_nneg intro!:lfp_loop_greatest)
  next
    fix P Q::"'s expect"
    assume sP: "sound P" and sQ: "sound Q" and le: "P \<tturnstile> Q"
    show "lfp_exp (?X P) \<tturnstile> lfp_exp (?X Q)"
    proof(rule lfp_exp_greatest)
      fix R::"'s expect"
      assume sR: "sound R"
         and fp: "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * Q s \<tturnstile> R"
      from le have "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s \<tturnstile>
                    \<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * Q s"
        by(auto intro:le_funI add_left_mono mult_left_mono)
      also note fp
      finally show "lfp_exp (\<lambda>R s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s) \<tturnstile> R"
        using sR by(auto intro:lfp_exp_lowerbound)
    next
      from hb sP show "sound (lfp_exp (\<lambda>R s. \<guillemotleft>G\<guillemotright> s * wp body R s + \<guillemotleft>\<N> G\<guillemotright> s * P s))"
        by(rule lfp_loop_sound)
      from hb sQ show "\<lambda>s. \<guillemotleft>G\<guillemotright> s * wp body (\<lambda>s. bound_of Q) s +  \<guillemotleft>\<N> G\<guillemotright> s * Q s \<tturnstile> \<lambda>s. bound_of Q"
        by(rule lfp_loop_fp)
      from sQ show "sound (\<lambda>s. bound_of Q)" by(auto)
    qed
  qed
qed

text {* Use 'simp add:healthy\_intros' or 'blast intro:healthy\_intros' as
        appropriate to discharge healthiness side-contitions for primitive
        programs automatically. *}
lemmas healthy_intros =
  healthy_wp_Abort nearly_healthy_wlp_Abort healthy_wp_Skip   nearly_healthy_wlp_Skip
  healthy_wp_Seq   nearly_healthy_wlp_Seq   healthy_wp_PC     nearly_healthy_wlp_PC
  healthy_wp_DC    nearly_healthy_wlp_DC    healthy_wp_AC     nearly_healthy_wlp_AC
  healthy_wp_Embed nearly_healthy_wlp_Embed healthy_wp_Apply  nearly_healthy_wlp_Apply
  healthy_wp_SetDC nearly_healthy_wlp_SetDC healthy_wp_SetPC  nearly_healthy_wlp_SetPC
  healthy_wp_Bind  nearly_healthy_wlp_Bind  healthy_wp_repeat nearly_healthy_wlp_repeat
  healthy_wp_loop  nearly_healthy_wlp_loop

end


section "Hash-Tables"
theory Hash_Table
imports
  Collections.HashCode
  Collections.Code_Target_ICF
  "../Sep_Main"
begin

subsection \<open>Datatype\<close>

subsubsection \<open>Definition\<close>

datatype ('k, 'v) hashtable = HashTable "('k \<times> 'v) list array" nat

primrec the_array :: "('k, 'v) hashtable \<Rightarrow> ('k \<times> 'v) list array"
  where "the_array (HashTable a _) = a"

primrec the_size :: "('k, 'v) hashtable \<Rightarrow> nat"
  where "the_size (HashTable _ n) = n"

subsubsection \<open>Storable on Heap\<close>

fun hs_encode :: "('k::countable, 'v::countable) hashtable \<Rightarrow> nat"
  where "hs_encode (HashTable a n) = to_nat (n, a)"

instance hashtable :: (countable, countable) countable
proof (rule countable_classI[of "hs_encode"])
  fix x y :: "('a, 'b) hashtable"
  assume "hs_encode x = hs_encode y"
  then show "x = y" by (cases x, cases y) auto
qed

instance hashtable :: (heap, heap) heap ..

subsection \<open>Assertions\<close>

subsubsection \<open>Assertion for Hashtable\<close>

definition ht_table :: "('k::heap \<times> 'v::heap) list list \<Rightarrow> ('k, 'v) hashtable \<Rightarrow> assn"
  where "ht_table l ht = (the_array ht) \<mapsto>\<^sub>a l"

definition ht_size :: "'a list list \<Rightarrow> nat \<Rightarrow> bool"
  where "ht_size l n \<equiv> n = sum_list (map length l)"

definition ht_hash :: "('k::hashable \<times> 'v) list list \<Rightarrow> bool" where
  "ht_hash l \<equiv> \<forall>i<length l. \<forall>x\<in>set (l!i).
    bounded_hashcode_nat (length l) (fst x) = i"

definition ht_distinct :: "('k \<times> 'v) list list \<Rightarrow> bool" where
  "ht_distinct l \<equiv> \<forall>i<length l. distinct (map fst (l!i))"

definition is_hashtable :: "('k::{heap,hashable} \<times> 'v::heap) list list
    \<Rightarrow> ('k, 'v) hashtable \<Rightarrow> assn"
where
  "is_hashtable l ht =
  (the_array ht \<mapsto>\<^sub>a l) *
  \<up>(ht_size l (the_size ht)
    \<and> ht_hash l
    \<and> ht_distinct l
    \<and> 1 < length l)"

lemma is_hashtable_prec: "precise is_hashtable"
  apply (rule preciseI)
  unfolding is_hashtable_def
  apply (auto simp add: preciseD[OF snga_prec])
  done

text \<open>These rules are quite useful for automated methods, to avoid unfolding
  of definitions, that might be used folded in other lemmas,
  like induction hypothesis. However, they show in some sense a possibility for
  modularization improvement, as it should be enough to show an implication
  and know that the \<open>nth\<close> and \<open>len\<close> operations do not change
  the heap.\<close>
lemma ht_array_nth_rule[sep_heap_rules]:
    "i<length l \<Longrightarrow> <is_hashtable l ht>
      Array.nth (the_array ht) i
      <\<lambda>r. is_hashtable l ht * \<up>(r = l!i)>"
  unfolding is_hashtable_def
  by sep_auto

lemma ht_array_length_rule[sep_heap_rules]:
    "<is_hashtable l ht>
      Array.len (the_array ht)
      <\<lambda>r. is_hashtable l ht * \<up>(r = length l)>"
  unfolding is_hashtable_def
  by sep_auto

subsection \<open>New\<close>

subsubsection \<open>Definition\<close>

definition ht_new_sz :: "nat \<Rightarrow> ('k::{heap,hashable}, 'v::heap) hashtable Heap"
where
  "ht_new_sz n \<equiv> do { let l = replicate n [];
  a \<leftarrow> Array.of_list l;
  return (HashTable a 0) }"

definition ht_new :: "('k::{heap,hashable}, 'v::heap) hashtable Heap"
  where "ht_new \<equiv> ht_new_sz (def_hashmap_size TYPE('k))"

subsubsection \<open>Complete Correctness\<close>

lemma ht_hash_replicate[simp, intro!]: "ht_hash (replicate n [])"
  apply (induct n)
  apply (auto simp add: ht_hash_def)
  apply (case_tac i)
  apply auto
  done

lemma ht_size_replicate[simp, intro!]: "ht_size (replicate n []) 0"
  by (simp add: ht_size_def)

 \<comment> \<open>We can't create hash tables with a size of zero\<close>
lemma complete_ht_new_sz: "1 < n \<Longrightarrow> <emp> ht_new_sz n <is_hashtable (replicate n [])>"
  apply (unfold ht_new_sz_def)
  apply (simp del: replicate.simps)
  apply (rule bind_rule)
  apply (rule of_list_rule)
  apply (rule return_cons_rule)
  apply (simp add: is_hashtable_def)
  done

lemma complete_ht_new:
  "<emp>
     ht_new::('k::{heap,hashable}, 'v::heap) hashtable Heap
   <is_hashtable (replicate (def_hashmap_size TYPE('k)) [])>"
  unfolding ht_new_def
  by (simp add: complete_ht_new_sz[OF def_hashmap_size])

subsection \<open>Lookup\<close>

subsubsection \<open>Definition\<close>

fun ls_lookup :: "'k \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> 'v option"
where
  "ls_lookup x [] = None" |
  "ls_lookup x ((k, v) # l) = (if x = k then Some v else ls_lookup x l)"

definition ht_lookup :: "'k \<Rightarrow> ('k::{heap,hashable}, 'v::heap) hashtable \<Rightarrow> 'v option Heap"
where
  "ht_lookup x ht = do {
    m \<leftarrow> Array.len (the_array ht);
    let i = bounded_hashcode_nat m x;
    l \<leftarrow> Array.nth (the_array ht) i;
    return (ls_lookup x l)
  }"

subsubsection \<open>Complete Correctness\<close>

lemma complete_ht_lookup:
  "<is_hashtable l ht> ht_lookup x ht
     <\<lambda>r. is_hashtable l ht *
        \<up>(r = ls_lookup x (l!(bounded_hashcode_nat (length l) x))) >"
  apply (cases ht)
  apply (clarsimp simp: is_hashtable_def)
  apply (simp add: ht_lookup_def)
  apply (rule bind_rule)
  apply (rule length_rule)
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule nth_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule norm_pre_pure_rule)
  apply (rule return_cons_rule)
  apply simp
  done

text \<open>Alternative, more automatic proof\<close>
lemma complete_ht_lookup_alt_proof:
  "<is_hashtable l ht> ht_lookup x ht
    <\<lambda>r. is_hashtable l ht *
      \<up>(r = ls_lookup x (l!(bounded_hashcode_nat (length l) x)))>"
  unfolding is_hashtable_def ht_lookup_def
  apply (cases ht)
  apply (sep_auto simp: bounded_hashcode_nat_bounds)
  done

subsection \<open>Update\<close>

subsubsection \<open>Definition\<close>

fun ls_update :: "'k \<Rightarrow> 'v \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> (('k \<times> 'v) list \<times> bool)"
where
  "ls_update k v [] = ([(k, v)], False)" |
  "ls_update k v ((l, w) # ls) = (
    if k = l then
      ((k, v) # ls, True)
    else
      (let r = ls_update k v ls in ((l, w) # fst r, snd r))
  )"

definition abs_update
  :: "'k::hashable \<Rightarrow> 'v \<Rightarrow> ('k \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
  where
  "abs_update k v l =
    l[bounded_hashcode_nat (length l) k
      := fst (ls_update k v (l ! bounded_hashcode_nat (length l) k))]"

lemma ls_update_snd_set: "snd (ls_update k v l) \<longleftrightarrow> k \<in> set (map fst l)"
  by (induct l rule: ls_update.induct) simp_all

lemma ls_update_fst_set: "set (fst (ls_update k v l)) \<subseteq> insert (k, v) (set l)"
  apply (induct l rule: ls_update.induct)
  apply simp
  apply (auto simp add: Let_def)
  done

lemma ls_update_fst_map_set: "set (map fst (fst (ls_update k v l))) = insert k (set (map fst l))"
  apply (induct l rule: ls_update.induct)
  apply simp
  apply (auto simp add: Let_def)
  done

lemma ls_update_distinct: "distinct (map fst l) \<Longrightarrow> distinct (map fst (fst (ls_update k v l)))"
proof (induct l rule: ls_update.induct)
  case 1 thus ?case by simp
next
  case (2 k v l w ls) show ?case
  proof (cases "k = l")
    case True
    with 2 show ?thesis by simp
  next
    case False
    with 2 have d: "distinct (map fst (fst (ls_update k v ls)))"
      by simp
    from 2(2) have "l \<notin> set (map fst ls)" by simp
    with False have "l \<notin> set (map fst (fst (ls_update k v ls)))"
      by (simp only: ls_update_fst_map_set) simp
    with d False show ?thesis by (simp add: Let_def)
  qed
qed

lemma ls_update_length: "length (fst (ls_update k v l))
  = (if (k \<in> set (map fst l)) then length l else Suc (length l))"
  by (induct l rule: ls_update.induct) (auto simp add: Let_def)

lemma ls_update_length_snd_True:
  "snd (ls_update k v l) \<Longrightarrow> length (fst (ls_update k v l)) = length l"
  by (simp add: ls_update_length ls_update_snd_set)

lemma ls_update_length_snd_False:
  "\<not> snd (ls_update k v l) \<Longrightarrow> length (fst (ls_update k v l)) = Suc (length l)"
  by (simp add: ls_update_length ls_update_snd_set)

definition ht_upd
  :: "'k \<Rightarrow> 'v
    \<Rightarrow> ('k::{heap,hashable}, 'v::heap) hashtable
    \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_upd k v ht = do {
      m \<leftarrow> Array.len (the_array ht);
      let i = bounded_hashcode_nat m k;
      l \<leftarrow> Array.nth (the_array ht) i;
      let l = ls_update k v l;
      Array.upd i (fst l) (the_array ht);
      let n = (if (snd l) then the_size ht else Suc (the_size ht));
      return (HashTable (the_array ht) n)
    }"

subsubsection \<open>Complete Correctness\<close>

lemma ht_hash_update:
  assumes "ht_hash ls"
  shows "ht_hash (abs_update k v ls)"
  unfolding ht_hash_def abs_update_def
  apply (intro allI ballI impI)
  apply simp
  subgoal premises prems for i x
  proof (cases "i = bounded_hashcode_nat (length ls) k")
    case True
    note i = True
    show ?thesis
    proof (cases "fst x = k")
      case True
      with i show ?thesis by simp
    next
      case False
      with prems i
      have
        "x \<in> set (fst (ls_update k v
                         (ls ! bounded_hashcode_nat (length ls) k)))"
        by auto
      with
        ls_update_fst_set[
          of k v "ls ! bounded_hashcode_nat (length ls) k"]
        False
      have "x \<in> insert (k, v)
                  (set (ls ! bounded_hashcode_nat (length ls) k))"
        by auto
      with False have "x \<in> set (ls ! bounded_hashcode_nat (length ls) k)"
        by auto
      with i prems assms[unfolded ht_hash_def] show ?thesis by simp
    qed
  next
    case False
    with prems have "x \<in> set (ls ! i)" by simp
    with prems assms[unfolded ht_hash_def] show ?thesis by simp
  qed
  done

lemma ht_distinct_update:
  assumes "ht_distinct l"
  shows "ht_distinct (abs_update k v l)"
  unfolding ht_distinct_def abs_update_def
  apply (intro allI impI)
  apply simp
  subgoal premises prems for i
  proof (cases "i = bounded_hashcode_nat (length l) k")
    case True
    with prems assms[unfolded ht_distinct_def]
    have "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
      by simp
    from ls_update_distinct[OF this, of k v] True prems
    show ?thesis by simp
  next
    case False
    with prems assms[unfolded ht_distinct_def] show ?thesis by simp
  qed
  done

lemma length_update:
  assumes "1 < length l"
  shows "1 < length (abs_update k v l)"
  using assms
  by (simp add: abs_update_def)

lemma ht_size_update1:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "snd (ls_update k v (l ! i))"
  shows "ht_size (l[i := fst (ls_update k v (l!i))]) n"
proof -
  have "(map length (l[i := fst (ls_update k v (l ! i))]))
    = (map length l)[i := length (fst (ls_update k v (l ! i)))]"
    by (simp add: map_update) also
  from sum_list_update[of i "map length l", simplified, OF i,
    of "length (fst (ls_update k v (l ! i)))"]
    ls_update_length_snd_True[OF snd]
  have
    "sum_list ((map length l)[i := length (fst (ls_update k v (l ! i)))])
    = sum_list (map length l)" by simp
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma ht_size_update2:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "\<not> snd (ls_update k v (l ! i))"
  shows "ht_size (l[i := fst (ls_update k v (l!i))]) (Suc n)"
proof -
  have "(map length (l[i := fst (ls_update k v (l ! i))]))
    = (map length l)[i := length (fst (ls_update k v (l ! i)))]"
    by (simp add: map_update) also
  from sum_list_update[of i "map length l", simplified, OF i,
    of "length (fst (ls_update k v (l ! i)))"]
    ls_update_length_snd_False[OF snd]
  have
    "sum_list ((map length l)[i := length (fst (ls_update k v (l ! i)))])
    = Suc (sum_list (map length l))" by simp
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma complete_ht_upd: "<is_hashtable l ht> ht_upd k v ht
  <is_hashtable (abs_update k v l)>"
  unfolding ht_upd_def is_hashtable_def
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule length_rule)
  apply (rule norm_pre_pure_rule)
  apply (simp add: Let_def)
  apply (rule bind_rule)
  apply (rule nth_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule upd_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule return_cons_rule)
  apply (auto
    simp add: ht_size_update1 ht_size_update2 bounded_hashcode_nat_bounds
              is_hashtable_def ht_hash_update[unfolded abs_update_def]
              ht_distinct_update[unfolded abs_update_def] abs_update_def)
  done

text \<open>Alternative, more automatic proof\<close>
lemma complete_ht_upd_alt_proof:
  "<is_hashtable l ht> ht_upd k v ht <is_hashtable (abs_update k v l)>"
  unfolding ht_upd_def is_hashtable_def Let_def
  (* TODO: Is this huge simp-step really necessary? *)
  apply (sep_auto
    simp: ht_size_update1 ht_size_update2 bounded_hashcode_nat_bounds
              is_hashtable_def ht_hash_update[unfolded abs_update_def]
              ht_distinct_update[unfolded abs_update_def] abs_update_def)
  done

subsection \<open>Delete\<close>

subsubsection \<open>Definition\<close>

fun ls_delete :: "'k \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> (('k \<times> 'v) list \<times> bool)" where
  "ls_delete k [] = ([], False)" |
  "ls_delete k ((l, w) # ls) = (
    if k = l then
      (ls, True)
    else
      (let r = ls_delete k ls in ((l, w) # fst r, snd r)))"

lemma ls_delete_snd_set: "snd (ls_delete k l) \<longleftrightarrow> k \<in> set (map fst l)"
  by (induct l rule: ls_delete.induct) simp_all

lemma ls_delete_fst_set: "set (fst (ls_delete k l)) \<subseteq> set l"
  apply (induct l rule: ls_delete.induct)
  apply simp
  apply (auto simp add: Let_def)
  done

lemma ls_delete_fst_map_set:
  "distinct (map fst l) \<Longrightarrow>
  set (map fst (fst (ls_delete k l))) = (set (map fst l)) - {k}"
  apply (induct l rule: ls_delete.induct)
  apply simp
  apply (auto simp add: Let_def)
  done

lemma ls_delete_distinct: "distinct (map fst l) \<Longrightarrow> distinct (map fst (fst (ls_delete k l)))"
proof (induct l rule: ls_delete.induct)
  case 1 thus ?case by simp
next
  case (2 k l w ls) show ?case
  proof (cases "k = l")
    case True
    with 2 show ?thesis by simp
  next
    case False
    with 2 have d: "distinct (map fst (fst (ls_delete k ls)))"
      by simp
    from 2 have d2: "distinct (map fst ls)" by simp
    from 2(2) have "l \<notin> set (map fst ls)" by simp
    with False 2 ls_delete_fst_map_set[OF d2, of k]
    have "l \<notin> set (map fst (fst (ls_delete k ls)))"
      by simp
    with d False show ?thesis by (simp add: Let_def)
  qed
qed

lemma ls_delete_length:
  "length (fst (ls_delete k l)) = (
    if (k \<in> set (map fst l)) then
      (length l - 1)
    else
      length l)"
proof (induct l rule: ls_delete.induct)
  case 1
  then show ?case by simp
next
  case (2 k l w ls)
  then show ?case by (cases ls) (auto simp add: Let_def)
qed

lemma ls_delete_length_snd_True:
  "snd (ls_delete k l) \<Longrightarrow> length (fst (ls_delete k l)) = length l - 1"
  by (simp add: ls_delete_length ls_delete_snd_set)

lemma ls_delete_length_snd_False:
  "\<not> snd (ls_delete k l) \<Longrightarrow> length (fst (ls_delete k l)) = length l"
  by (simp add: ls_delete_length ls_delete_snd_set)

definition ht_delete
  :: "'k
    \<Rightarrow> ('k::{heap,hashable}, 'v::heap) hashtable
    \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_delete k ht = do {
      m \<leftarrow> Array.len (the_array ht);
      let i = bounded_hashcode_nat m k;
      l \<leftarrow> Array.nth (the_array ht) i;
      let l = ls_delete k l;
      Array.upd i (fst l) (the_array ht);
      let n = (if (snd l) then (the_size ht - 1) else the_size ht);
      return (HashTable (the_array ht) n)
    }"

subsubsection \<open>Complete Correctness\<close>

lemma ht_hash_delete:
  assumes "ht_hash ls"
  shows "ht_hash (
    ls[bounded_hashcode_nat (length ls) k
      := fst (ls_delete k
               (ls ! bounded_hashcode_nat (length ls) k)
             )
      ]
  )"
  unfolding ht_hash_def
  apply (intro allI ballI impI)
  apply simp
  subgoal premises prems for i x
  proof (cases "i = bounded_hashcode_nat (length ls) k")
    case i: True
    show ?thesis
    proof (cases "fst x = k")
      case True
      with i show ?thesis by simp
    next
      case False
      with prems i
      have
        "x \<in> set (fst (ls_delete k
                        (ls ! bounded_hashcode_nat (length ls) k)))"
        by auto
      with
        ls_delete_fst_set[
          of k "ls ! bounded_hashcode_nat (length ls) k"]
        False
      have "x \<in> (set (ls ! bounded_hashcode_nat (length ls) k))" by auto
      with i prems assms[unfolded ht_hash_def] show ?thesis by simp
    qed
  next
    case False
    with prems have "x \<in> set (ls ! i)" by simp
    with prems assms[unfolded ht_hash_def] show ?thesis by simp
  qed
  done

lemma ht_distinct_delete:
  assumes "ht_distinct l"
  shows "ht_distinct (
    l[bounded_hashcode_nat (length l) k
      := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])"
  unfolding ht_distinct_def
  apply (intro allI impI)
  apply simp
  subgoal premises prems for i
  proof (cases "i = bounded_hashcode_nat (length l) k")
    case True
    with prems assms[unfolded ht_distinct_def]
    have "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
      by simp
    from ls_delete_distinct[OF this, of k] True prems
    show ?thesis by simp
  next
    case False
    with prems assms[unfolded ht_distinct_def] show ?thesis by simp
  qed
  done

lemma ht_size_delete1:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "snd (ls_delete k (l ! i))"
  shows "ht_size (l[i := fst (ls_delete k (l!i))]) (n - 1)"
proof -
  have "(map length (l[i := fst (ls_delete k (l ! i))]))
    = (map length l)[i := length (fst (ls_delete k (l ! i)))]"
    by (simp add: map_update) also
  from sum_list_update[of i "map length l", simplified, OF i,
    of "length (fst (ls_delete k (l ! i)))"]
    ls_delete_length_snd_True[OF snd] snd
  have "sum_list ((map length l)[i := length (fst (ls_delete k (l ! i)))])
    = sum_list (map length l) - 1"
    by (cases "length (l ! i)") (simp_all add: ls_delete_snd_set)
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma ht_size_delete2:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "\<not> snd (ls_delete k (l ! i))"
  shows "ht_size (l[i := fst (ls_delete k (l!i))]) n"
proof -
  have "(map length (l[i := fst (ls_delete k (l ! i))]))
    = (map length l)[i := length (fst (ls_delete k (l ! i)))]"
    by (simp add: map_update) also
  from sum_list_update[of i "map length l", simplified, OF i,
    of "length (fst (ls_delete k (l ! i)))"]
    ls_delete_length_snd_False[OF snd]
  have "sum_list ((map length l)[i := length (fst (ls_delete k (l ! i)))])
    = sum_list (map length l)" by simp
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma complete_ht_delete: "<is_hashtable l ht> ht_delete k ht
  <is_hashtable (l[bounded_hashcode_nat (length l) k
    := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])>"
  unfolding ht_delete_def is_hashtable_def
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule length_rule)
  apply (rule norm_pre_pure_rule)
  apply (simp add: Let_def)
  apply (rule bind_rule)
  apply (rule nth_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule upd_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule return_cons_rule)
  apply (auto
    simp add: ht_size_delete1 ht_size_delete2 bounded_hashcode_nat_bounds
              is_hashtable_def ht_hash_delete ht_distinct_delete)
  using ht_size_delete1[OF _ bounded_hashcode_nat_bounds[of "length l" k], of "the_size ht"]
  apply simp
  done

text \<open>Alternative, more automatic proof\<close>
lemma "<is_hashtable l ht> ht_delete k ht
  <is_hashtable (l[bounded_hashcode_nat (length l)
    k := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])>"
  unfolding ht_delete_def is_hashtable_def Let_def
  using ht_size_delete1[OF _ bounded_hashcode_nat_bounds[of "length l" k],
    of "the_size ht"]
  apply (sep_auto simp:
    ht_size_delete1 ht_size_delete2 bounded_hashcode_nat_bounds
    is_hashtable_def ht_hash_delete ht_distinct_delete)
  done

subsection \<open>Re-Hashing\<close>

subsubsection \<open>Auxiliary Functions\<close>

text \<open>\paragraph{Insert List}\<close>
fun ht_insls
  :: "('k \<times> 'v) list
    \<Rightarrow> ('k::{heap,hashable}, 'v::heap) hashtable
    \<Rightarrow> ('k, 'v::heap) hashtable Heap"
  where
  "ht_insls [] ht = return ht" |
  "ht_insls ((k, v) # l) ht = do { h \<leftarrow> ht_upd k v ht; ht_insls l h }"

text "Abstract version"
fun ls_insls :: "('k::hashable \<times> 'v) list
  \<Rightarrow> ('k \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
where
  "ls_insls [] l = l" |
  "ls_insls ((k, v) # ls) l =
    ls_insls ls (abs_update k v l)"

lemma ht_hash_ls_insls:
  assumes "ht_hash l"
  shows "ht_hash (ls_insls ls l)"
  using assms
  apply (induct l rule: ls_insls.induct)
  apply simp
  apply (simp add: ht_hash_update)
  done

lemma ht_distinct_ls_insls:
  assumes "ht_distinct l"
  shows "ht_distinct (ls_insls ls l)"
  using assms
  apply (induct l rule: ls_insls.induct)
  apply simp
  apply (simp add: ht_distinct_update)
  done

lemma length_ls_insls:
  assumes "1 < length l"
  shows "1 < length (ls_insls ls l)"
  using assms
proof (induct l rule: ls_insls.induct)
  case 1
  then show ?case by simp
next
  case (2 k v ls l)
  from 2(1)[OF length_update[OF 2(2), of k v]] show ?case
    by simp
qed

lemma complete_ht_insls:
  "<is_hashtable ls ht> ht_insls xs ht <is_hashtable (ls_insls xs ls)>"
proof (induct xs arbitrary: ls ht)
  case Nil
  show ?case by (auto intro: return_cons_rule)
next
  case (Cons x xs)
  show ?case
  proof (cases x)
    case (Pair k v)
    then show ?thesis
      apply simp
      apply (rule bind_rule)
      apply (rule complete_ht_upd)
      apply (simp add: Cons)
      done
  qed
qed

text \<open>\paragraph{Copy}\<close>
fun ht_copy :: "nat \<Rightarrow> ('k::{heap,hashable}, 'v::heap) hashtable
  \<Rightarrow> ('k, 'v) hashtable \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_copy 0 src dst = return dst" |
  "ht_copy (Suc n) src dst = do {
    l \<leftarrow> Array.nth (the_array src) n;
    ht \<leftarrow> ht_insls l dst;
    ht_copy n src ht
  }"

text "Abstract version"
fun ls_copy :: "nat \<Rightarrow> ('k::hashable \<times> 'v) list list
  \<Rightarrow> ('k \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
  where
  "ls_copy 0 ss ds = ds" |
  "ls_copy (Suc n) ss ds = ls_copy n ss (ls_insls (ss ! n) ds)"

lemma ht_hash_ls_copy:
  assumes "ht_hash l"
  shows "ht_hash (ls_copy n ss l)"
  using assms
  apply (induct n arbitrary: l)
  apply simp
  apply (simp add: ht_hash_ls_insls)
  done

lemma ht_distinct_ls_copy:
  assumes "ht_distinct l"
  shows "ht_distinct (ls_copy n ss l)"
  using assms
  apply (induct n arbitrary: l)
  apply simp
  apply (simp add: ht_distinct_ls_insls)
  done

lemma length_ls_copy:
  assumes "1 < length l"
  shows "1 < length (ls_copy n ss l)"
  using assms
proof (induct n arbitrary: l)
  case 0
  then show ?case by simp
next
  case (Suc n)
  from Suc(1)[OF length_ls_insls[OF Suc(2)]] show ?case by simp
qed

lemma complete_ht_copy: "n \<le> List.length ss \<Longrightarrow>
  <is_hashtable ss src * is_hashtable ds dst>
  ht_copy n src dst
  <\<lambda>r. is_hashtable ss src * is_hashtable (ls_copy n ss ds) r>"
proof (induct n arbitrary: ds dst)
  case 0
  show ?case by (auto intro!: return_cons_rule)
next
  case (Suc n)
  then have n: "n < length ss" by simp
  then have "n \<le> length ss" by simp
  note IH = Suc(1)[OF this]
  show ?case
    apply simp
    apply (rule bind_rule)
    apply (rule frame_rule)
    apply (subgoal_tac "<is_hashtable ss src>
      Array.nth (the_array src) n
      <\<lambda>r. is_hashtable ss src * \<up>(r = ss ! n)>")
    apply simp
    apply (simp add: is_hashtable_def)
    apply (auto intro!: nth_rule simp add: n)[]
    apply clarsimp
    apply (rule bind_rule)
    apply (rule frame_rule_left)
    apply (rule complete_ht_insls)
    apply (simp add: IH)
    done
qed

text \<open>Alternative, more automatic proof\<close>
lemma complete_ht_copy_alt_proof: "n \<le> List.length ss \<Longrightarrow>
  <is_hashtable ss src * is_hashtable ds dst>
  ht_copy n src dst
  <\<lambda>r. is_hashtable ss src * is_hashtable (ls_copy n ss ds) r>"
proof (induct n arbitrary: ds dst)
  case 0
  show ?case by (sep_auto)
next
  case (Suc n)
  then have N_LESS: "n < length ss" by simp
  then have N_LE: "n \<le> length ss" by simp
  note IH = Suc(1)[OF this]
  show ?case
    by (sep_auto simp: N_LESS N_LE heap: complete_ht_insls IH)
qed

definition ht_rehash
  :: "('k::{heap,hashable}, 'v::heap) hashtable \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_rehash ht = do {
    n \<leftarrow> Array.len (the_array ht);
    h \<leftarrow> ht_new_sz (2 * n);
    ht_copy n ht h
  }"

text "Operation on Abstraction"
definition ls_rehash :: "('k::hashable \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
  where "ls_rehash l = ls_copy (List.length l) l (replicate (2 * length l) [])"

lemma ht_hash_ls_rehash: "ht_hash (ls_rehash l)"
  by (simp add: ht_hash_ls_copy ls_rehash_def)

lemma ht_distinct_ls_rehash: "ht_distinct (ls_rehash l)"
  by (simp add: ht_distinct_ls_copy ls_rehash_def)

lemma length_ls_rehash:
  assumes "1 < length l"
  shows "1 < length (ls_rehash l)"
proof -
  from assms have "1 < length (replicate (2 * length l) [])" by simp
  from length_ls_copy[OF this, of "length l" l] show ?thesis
    by (simp add: ls_rehash_def)
qed

lemma ht_imp_len: "is_hashtable l ht \<Longrightarrow>\<^sub>A is_hashtable l ht * \<up>(length l > 0)"
  unfolding is_hashtable_def
  by sep_auto

lemma complete_ht_rehash:
  "<is_hashtable l ht> ht_rehash ht
  <\<lambda>r. is_hashtable l ht * is_hashtable (ls_rehash l) r>"
  apply (rule cons_pre_rule[OF ht_imp_len])
  unfolding ht_rehash_def
  apply (sep_auto heap: complete_ht_new_sz)
  apply (cases l; simp)
  apply (sep_auto heap: complete_ht_copy simp: ls_rehash_def)
  done

definition load_factor :: nat \<comment> \<open>in percent\<close>
  where "load_factor = 75"

definition ht_update
  :: "'k::{heap,hashable} \<Rightarrow> 'v::heap \<Rightarrow> ('k, 'v) hashtable
  \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_update k v ht = do {
    m \<leftarrow> Array.len (the_array ht);
    ht \<leftarrow> (if m * load_factor \<le> (the_size ht) * 100 then
        ht_rehash ht
      else return ht);
    ht_upd k v ht
  }"

lemma complete_ht_update_normal:
  "\<not> length l * load_factor \<le> (the_size ht)* 100 \<Longrightarrow>
  <is_hashtable l ht>
  ht_update k v ht
  <is_hashtable (abs_update k v l)>"
  unfolding ht_update_def
  apply (sep_auto simp: is_hashtable_def)
  apply (rule cons_pre_rule[where P' = "is_hashtable l ht"])
  apply (simp add: is_hashtable_def)
  apply (simp add: complete_ht_upd)
  done

lemma complete_ht_update_rehash:
  "length l * load_factor \<le> (the_size ht)* 100 \<Longrightarrow>
  <is_hashtable l ht>
  ht_update k v ht
  <\<lambda>r. is_hashtable l ht
    * is_hashtable (abs_update k v (ls_rehash l)) r>"
  unfolding ht_update_def
  by (sep_auto heap: complete_ht_rehash complete_ht_upd)

subsection \<open>Conversion to List\<close>

definition ht_to_list ::
  "('k::heap, 'v::heap) hashtable \<Rightarrow> ('k \<times> 'v) list Heap" where
  "ht_to_list ht = do {
    l \<leftarrow> (Array.freeze (the_array ht));
    return (concat l)
  }"

lemma complete_ht_to_list: "<is_hashtable l ht> ht_to_list ht
  <\<lambda>r. is_hashtable l ht * \<up>(r = concat l)>"
  unfolding ht_to_list_def is_hashtable_def
  by sep_auto

end


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

header {* User guide for native words *}

(*<*)
theory Uint_Userguide imports
  Uint32
  Uint16
  Code_Target_Bits_Int
begin
(*>*)

text {*
  This tutorial explains how to best use the types for native
  words like @{typ "uint32"} in your formalisation.
  You can base your formalisation
  \begin{enumerate}
  \item either directly on these types,
  \item or on the generic @{typ "'a word"} and only introduce native
    words a posteriori via code generator refinement.
  \end{enumerate}

  The first option causes the least overhead if you have to prove only
  little about the words you use and start a fresh formalisation.
  Just use the native type @{typ uint32} instead of @{typ "32 word"}
  and similarly for @{text uint16} and @{text uint8}.
  As native word types are meant only for code generation, the lemmas
  about @{typ "'a word"}  have not been duplicated, but you can transfer
  theorems between native word types and @{typ "'a word"} using the
  transfer package.

  Note, however, that this option restricts your work a bit:
  your own functions cannot be ``polymorphic'' in the word length,
  but you have to define a separate function for every word length you need.

  The second option is recommended if you already have a formalisation
  based on @{typ "'a word"} or if your proofs involve words and their
  properties. It separates code generation from modelling and proving,
  i.e., you can work with words as usual. Consequently, you have to
  manually setup the code generator to use the native types wherever
  you want. The following describes how to achieve this with moderate
  effort.

  Note, however, that some target languages of the code generator
  (especially OCaml) do not support all the native word types provided.
  Therefore, you should only import those types that you need -- the
  theory file for each type mentions at the top the restrictions for
  code generation. For example, PolyML does not provide the Word16
  structure, and OCaml provides neither Word8 nor Word16.
  You can still use these theories provided that you also import
  the theory @{theory "Code_Target_Bits_Int"} (which implements
  @{typ int} by target-language integers), but these words will
  be implemented via Isabelle's @{text "HOL-Word"} library, i.e.,
  you do not gain anything in terms of efficiency.

  \textbf{There is a separate code target @{text "SML_word"} for SML.}
  If you use one of the native words that PolyML does not support
  (such as @{text "uint16"}), but would like to map its operations
  to the Standard Basis Library functions, make sure to use the target
  @{text "SML_word"} instead of @{text "SML"};  if you only use native
  word sizes that PolyML supports, you can stick with @{text "SML"}.
  This ensures that code generation within Isabelle as used by
  @{text Quickcheck}, @{text value} and @\{code\} in ML blocks
  continues to work.
*}

section {* Lifting functions from @{typ "'a word"} to native words *}

text {*
  This section shows how to convert functions from @{typ "'a word"} to native
  words. For example, the following function @{text sum_squares} computes
  the sum of the first @{term n} square numbers in 16 bit arithmetic using
  a tail-recursive function @{text gen_sum_squares} with accumulator;
  for convenience, @{text sum_squares_int} takes an integer instead of a word.
*}

function gen_sum_squares :: "16 word \<Rightarrow> 16 word \<Rightarrow> 16 word" where (*<*)[simp del]:(*>*)

  "gen_sum_squares accum n =
   (if n = 0 then accum else gen_sum_squares (accum + n * n) (n - 1))"
(*<*)by pat_completeness simp
termination by(relation "measure (nat \<circ> uint \<circ> snd)")
  (simp_all, metis (hide_lams, mono_tags) uint_1 uint_eq_0 uint_minus_simple_alt uint_sub_ge word_le_sub1 word_less_def word_neq_0_conv word_zero_le zle_diff1_eq)(*>*)

definition sum_squares :: "16 word \<Rightarrow> 16 word" where
   "sum_squares = gen_sum_squares 0"

definition sum_squares_int :: "int \<Rightarrow> 16 word" where
  "sum_squares_int n = sum_squares (word_of_int n)"

text {*
  The generated code for @{term sum_squares} and @{term sum_squares_int}
  emulates words with unbounded integers and explicit modulus as specified
  in the theory @{theory Word}. But for efficiency, we want that the
  generated code uses machine words and machine arithmetic. Unfortunately,
  as @{typ "'a word"} is polymorphic in the word length, the code generator
  can only do this if we use another type for machine words. The theory
  @{theory Uint16} defines the type @{typ uint16} for machine words of
  16~bits. We just have to follow two steps to use it:

  First, we lift all our functions from @{typ "16 word"} to @{typ uint16},
  i.e., @{term sum_squares}, @{term gen_sum_squares}, and
  @{term sum_squares_int} in our case. The theory @{theory Uint16} sets
  up the lifting package for this and has already taken care of the
  arithmetic and bit-wise operations.
*}
lift_definition gen_sum_squares_uint :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
  is gen_sum_squares .
lift_definition sum_squares_uint :: "uint16 \<Rightarrow> uint16" is sum_squares .
lift_definition sum_squares_int_uint :: "int \<Rightarrow> uint16" is sum_squares_int .

text {*
  Second, we also have to transfer the code equations for our functions.
  The attribute @{text Transfer.transferred} takes care of that, but it is
  better to check that the transfer succeeded: inspect the theorem to check
  that the new constants are used throughout.
*}

lemmas [Transfer.transferred, code] =
  gen_sum_squares.simps
  sum_squares_def
  sum_squares_int_def

text {*
  Finally, we export the code to standard ML.  We use the target
  @{text "SML_word"} instead of @{text "SML"} to have the operations
  on @{typ uint16} mapped to the Standard Basis Library. As PolyML
  does not provide a Word16 type, the mapping for @{typ uint16} is only
  active in the refined target @{text "SML_word"}.
*}
export_code sum_squares_int_uint in SML_word

text {*
  Nevertheless, we can still evaluate terms with @{term "uint16"} within
  Isabelle, i.e., PolyML, but this will be translated to @{typ "16 word"}
  and therefore less efficient.
*}

value "sum_squares_int_uint 40"

section {* Storing native words in datatypes *}

text {*
  The above lifting is necessary for all functions whose type mentions
  the word type. Fortunately, we do not have to duplicate functions that
  merely operate on datatypes that contain words. Nevertheless, we have
  to tell the code generator that these functions should call the new ones,
  which operate on machine words. This section shows how to achieve this
  with data refinement.
*}

subsection {* Example: expressions and two semantics *}

text {*
  As the running example, we consider a language of expressions (literal values, less-than comparisions and conditional) where values are either booleans or 32-bit words.
  The original specification uses the type @{typ "32 word"}.
*}

datatype val = Bool bool | Word "32 word"
datatype expr = Lit val | LT expr expr | IF expr expr expr

abbreviation (input) word :: "32 word \<Rightarrow> expr" where "word i \<equiv> Lit (Word i)"
abbreviation (input) bool :: "bool \<Rightarrow> expr" where "bool i \<equiv> Lit (Bool i)"

-- {* Denotational semantics of expressions, @{term None} denotes a type error *}
fun eval :: "expr \<Rightarrow> val option" where
  "eval (Lit v) = Some v"
| "eval (LT e\<^sub>1 e\<^sub>2) =
  (case (eval e\<^sub>1, eval e\<^sub>2)
   of (Some (Word i\<^sub>1), Some (Word i\<^sub>2)) \<Rightarrow> Some (Bool (i\<^sub>1 < i\<^sub>2))
   | _ \<Rightarrow> None)"
| "eval (IF e\<^sub>1 e\<^sub>2 e\<^sub>3) =
  (case eval e\<^sub>1 of Some (Bool b) \<Rightarrow> if b then eval e\<^sub>2 else eval e\<^sub>3
   | _ \<Rightarrow> None)"

-- {* Small-step semantics of expressions, it gets stuck upon type errors. *}
inductive step :: "expr \<Rightarrow> expr \<Rightarrow> bool" ("_ \<rightarrow> _" [50, 50] 60) where
  "e \<rightarrow> e' \<Longrightarrow> LT e e\<^sub>2 \<rightarrow> LT e' e\<^sub>2"
| "e \<rightarrow> e' \<Longrightarrow> LT (word i) e \<rightarrow> LT (word i) e'"
| "LT (word i\<^sub>1) (word i\<^sub>2) \<rightarrow> bool (i\<^sub>1 < i\<^sub>2)"
| "e \<rightarrow> e' \<Longrightarrow> IF e e\<^sub>1 e\<^sub>2 \<rightarrow> IF e' e\<^sub>1 e\<^sub>2"
| "IF (bool True) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>1"
| "IF (bool False) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>2"

-- {* Compile the inductive definition with the predicate compiler *}
code_pred (modes: i \<Rightarrow> o \<Rightarrow> bool as reduce, i \<Rightarrow> i \<Rightarrow> bool as step') step .

subsection {* Change the datatype to use machine words *}

text {*
  Now, we want to use @{typ uint32} instead of @{typ "32 word"}.
  The goal is to make the code generator use the new type without
  duplicating any of the types (@{typ val}, @{typ expr}) or the
  functions (@{term eval}, @{term reduce}) on such types.

  The constructor @{term Word} has @{typ "32 word"} in its type, so
  we have to lift it to @{text "Word'"}, and the same holds for the
  case combinator @{term case_val}, which @{term case_val'} replaces.%
  \footnote{%
    Note that we should not declare a case translation for the new
    case combinator because this will break parsing case expressions
    with old case combinator.
  }
  Next, we set up the code generator accordingly:
  @{term Bool} and @{term Word'} are the new constructors for @{typ val},
  and @{term case_val'} is the new case combinator with an appropriate
  case certificate.%
  \footnote{%
    Case certificates tell the code generator to replace the HOL
    case combinator for a datatype with the case combinator of the
    target language.  Without a case certificate, the code generator
    generates a function that re-implements the case combinator;
    in a strict languages like ML or Scala, this means that the code
    evaluates all possible cases before it decides which one is taken.

    Case certificates are described in Haftmann's PhD thesis
    \cite[Def.\ 27]{Haftmann2009PhD}. For a datatype @{text dt}
    with constructors @{text "C\<^sub>1"} to @{text "C\<^sub>n"}
    where each constructor @{text "C\<^sub>i"} takes @{text "k\<^sub>i"} parameters,
    the certificate for the case combinator @{text "case_dt"}
    looks as follows:

    {
      \isamarkuptrue\isacommand{lemma}\isamarkupfalse\isanewline%
      \ \ \isakeyword{assumes}\ {\isachardoublequoteopen}CASE\ {\isasymequiv}\ dt{\isacharunderscore}case\ c\isactrlsub {\isadigit{1}}\ c\isactrlsub {\isadigit{2}}\ \ldots\ c\isactrlsub{n}{\isachardoublequoteclose}\isanewline
      \ \ \isakeyword{shows}\ {\isachardoublequoteopen}{\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ \ldots\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}{\isachardoublequoteclose}\isanewline
    }
  }
  We delete the code equations for the old constructor @{term Word}
  and case combinator @{term case_val} such that the code generator
  reports missing adaptations.
*}

lift_definition Word' :: "uint32 \<Rightarrow> val" is Word .

code_datatype Bool Word'

lift_definition case_val' :: "(bool \<Rightarrow> 'a) \<Rightarrow> (uint32 \<Rightarrow> 'a) \<Rightarrow> val \<Rightarrow> 'a" is case_val .

lemmas [code, simp] = val.case [Transfer.transferred]

lemma case_val'_cert:
  fixes bool word' b w
  assumes "CASE \<equiv> case_val' bool word'"
  shows "(CASE (Bool b) \<equiv> bool b) &&& (CASE (Word' w) \<equiv> word' w)"
by(simp_all add: assms)
setup {* Code.add_case @{thm case_val'_cert} *}

lemma [code, code del]: "case_val = case_val" ..
lemma [code, code del]: "Word = Word" ..

subsection {* Make functions use functions on machine words *}

text {*
  Finally, we merely have to change the code equations to use the
  new functions that operate on @{typ uint32}. As before, the
  attribute @{text Transfer.transferred} does the job. In our example,
  we adapt the equality test on @{typ val} (code equations
  @{thm [source] val.eq.simps}) and the denotational and small-step
  semantics (code equations @{thm [source] eval.simps} and
  @{thm [source] step.equation}, respectively).

  We check that the adaptation has suceeded by exporting the functions.
  As we only use native word sizes that PolyML supports, we can use
  the usual target @{text "SML"} instead of @{text "SML_word"}.
*}

lemmas [code] =
  val.eq.simps[THEN meta_eq_to_obj_eq, Transfer.transferred, THEN eq_reflection]
  eval.simps[Transfer.transferred]
  step.equation[Transfer.transferred]

export_code reduce step' eval in SML

section {* Troubleshooting *}

text {*
  This section explains some possible problems when using native words.
  If you experience other difficulties, please contact the author.
*}

subsection {* @{text export_code} raises an exception \label{section:export_code:exception} *}

text {*
  Probably, you have defined and are using a function on a native word type,
  but the code equation refers to emulated words. For example, the following
  defines a function @{text double} that doubles a word. When we try to export
  code for @{text double} without any further setup, @{text export_code} will
  raise an exception or generate code that does not compile.
*}

lift_definition double :: "uint32 \<Rightarrow> uint32" is "\<lambda>x. x + x" .

text {*
  We have to prove a code equation that only uses the existing operations on
  @{typ uint32}. Then, @{text export_code} works again.
*}

lemma double_code [code]: "double n = n + n"
by transfer simp

subsection {* The generated code does not compile *}

text {*
  Probably, you have been exporting to a target language for which there
  is no setup, or your compiler does not provide the required API. Every
  theory for native words mentions at the start the limitations on code
  generation. Check that your concrete application meets all the
  requirements.

  Alternatively, this might be an instance of the problem described
  in \S\ref{section:export_code:exception}.

  For Haskell, you have to enable the extension TypeSynonymInstances with \texttt{-XTypeSynonymInstances}
  if you are using polymorphic bit operations on the native word types.
*}

subsection {* The generated code is too slow *}

text {*
  The generated code will most likely not be as fast as a direct implementation in the target language with manual tuning.
  This is because we want the configuration of the code generation to be sound (as it can be used to prove theorems in Isabelle).
  Therefore, the bit operations sometimes perform range checks before they call the target language API.
  Here are some examples:
  \begin{itemize}
  \item Shift distances and bit indices in target languages are often expected to fit into a bounded integer or word.
    However, the size of these types varies across target languages and platforms.
    Hence, no Isabelle/HOL type can model uniformly all of them.
    Instead, the bit operations use arbitrary-precision integers for such quantities and check at run-time that the values fit into a bounded integer or word, respectively -- if not, they raise an exception.

  \item Division and modulo operations explicitly test whether the divisor is $0$ and return the HOL value of division by $0$ in that case.
    This is necessary because some languages leave the behaviour of division by 0 unspecified.
  \end{itemize}

  If you have better ideas how to eliminate such checks and speed up the generated code without sacrificing soundness, please contact the author!
*}

(*<*)end(*>*)