section \<open>The Voting Model\<close>

theory Voting imports Refinement Consensus_Misc Quorums
begin

subsection \<open>Model definition\<close>
(******************************************************************************)

record v_state =
  (* We want 0 to be the first round, and we also have to use something in the initial state
     - hence next_round *)
  next_round :: round
  votes :: "round \<Rightarrow> (process, val) map"
  decisions :: "(process, val)map"

text \<open>Initially, no rounds have been executed (the next round is 0), no votes have been
  cast, and no decisions have been made.\<close>

definition v_init :: "v_state set" where
  "v_init = { \<lparr> next_round = 0, votes = \<lambda>r a. None, decisions = Map.empty \<rparr> }"

context quorum_process begin

definition quorum_for :: "process set \<Rightarrow> val \<Rightarrow> (process, val)map \<Rightarrow> bool" where
  quorum_for_def':
  "quorum_for Q v v_f \<equiv> Q \<in> Quorum \<and> v_f ` Q = {Some v}"

text \<open>The following definition of @{term quorum_for} is easier to reason about in Isabelle.\<close>

lemma quorum_for_def:
  "quorum_for Q v v_f = (Q \<in> Quorum \<and> (\<forall>p \<in> Q. v_f p = Some v))"
  by(auto simp add: quorum_for_def' image_def dest: quorum_non_empty)

definition locked_in_vf :: "(process, val)map \<Rightarrow> val \<Rightarrow> bool" where
  "locked_in_vf v_f v \<equiv> \<exists>Q. quorum_for Q v v_f"

definition locked_in :: "v_state \<Rightarrow> round \<Rightarrow> val \<Rightarrow> bool" where
  "locked_in s r v = locked_in_vf (votes s r) v"

definition d_guard :: "(process \<Rightarrow> val option) \<Rightarrow> (process \<Rightarrow> val option) \<Rightarrow> bool" where
  "d_guard r_decisions r_votes \<equiv> \<forall>p v.
    r_decisions p = Some v \<longrightarrow> locked_in_vf r_votes v"

definition no_defection :: "v_state \<Rightarrow> (process, val)map \<Rightarrow> round \<Rightarrow> bool" where
  no_defection_def':
  "no_defection s r_votes r \<equiv>
    \<forall>r' < r. \<forall>Q \<in> Quorum. \<forall>v. (votes s r') ` Q = {Some v} \<longrightarrow> r_votes ` Q \<subseteq> {None, Some v}"

text \<open>The following definition of @{term no_defection} is easier to reason about in Isabelle.\<close>

lemma no_defection_def:
  "no_defection s round_votes r =
    (\<forall>r' < r. \<forall>a Q v. quorum_for Q v (votes s r') \<and> a \<in> Q \<longrightarrow> round_votes a \<in> {None, Some v})"
  apply(auto simp add: no_defection_def' Ball_def quorum_for_def')
   apply(blast)
  by (metis option.discI option.inject)

definition locked :: "v_state \<Rightarrow> val set" where
  "locked s = {v. \<exists>r. locked_in s r v}"

text \<open>The sole system event.\<close>

definition v_round :: "round \<Rightarrow> (process, val)map \<Rightarrow> (process, val)map \<Rightarrow> (v_state \<times> v_state) set" where
  "v_round r r_votes r_decisions = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s
     \<and> no_defection s r_votes r
     \<and> d_guard r_decisions r_votes
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       next_round := Suc r,
       votes := (votes s)(r := r_votes),
       decisions := (decisions s) ++ r_decisions
     \<rparr>
  }"

lemmas v_evt_defs = v_round_def

definition v_trans :: "(v_state \<times> v_state) set" where
  "v_trans = (\<Union>r v_f d_f. v_round r v_f d_f) \<union> Id"

definition v_TS :: "v_state TS" where
  "v_TS = \<lparr> init = v_init, trans = v_trans \<rparr>"

lemmas v_TS_defs = v_TS_def v_init_def v_trans_def

subsection \<open>Invariants\<close>
(******************************************************************************)

text \<open>The only rounds where votes could have been cast are the ones
  preceding the next round.\<close>
definition Vinv1 where
  "Vinv1 = {s. \<forall>r. next_round s \<le> r \<longrightarrow> votes s r = Map.empty }"

lemmas Vinv1I = Vinv1_def [THEN setc_def_to_intro, rule_format]
lemmas Vinv1E [elim] = Vinv1_def [THEN setc_def_to_elim, rule_format]
lemmas Vinv1D = Vinv1_def [THEN setc_def_to_dest, rule_format]

text \<open>The votes cast must respect the @{term no_defection} property.\<close>
definition Vinv2 where
  "Vinv2 = {s. \<forall>r. no_defection s (votes s r) r }"

lemmas Vinv2I = Vinv2_def [THEN setc_def_to_intro, rule_format]
lemmas Vinv2E [elim] = Vinv2_def [THEN setc_def_to_elim, rule_format]
lemmas Vinv2D = Vinv2_def [THEN setc_def_to_dest, rule_format]

definition Vinv3 where
  "Vinv3 = {s. ran (decisions s) \<subseteq> locked s}"

lemmas Vinv3I = Vinv3_def [THEN setc_def_to_intro, rule_format]
lemmas Vinv3E [elim] = Vinv3_def [THEN setc_def_to_elim, rule_format]
lemmas Vinv3D = Vinv3_def [THEN setc_def_to_dest, rule_format]

subsubsection \<open>Proofs of invariants\<close>
(******************************************************************************)

(*************************)
lemma Vinv1_v_round:
  "{Vinv1} v_round r v_f d_f {> Vinv1}"
  by(auto simp add: PO_hoare_defs v_round_def intro!: Vinv1I)

lemmas Vinv1_event_pres = Vinv1_v_round

lemma Vinv1_inductive:
  "init v_TS \<subseteq> Vinv1"
  "{Vinv1} trans v_TS {> Vinv1}"
  apply (simp add: v_TS_defs Vinv1_def)
  by (auto simp add: v_TS_defs Vinv1_event_pres)

lemma Vinv1_invariant: "reach v_TS \<subseteq> Vinv1"
  by (rule inv_rule_basic, auto intro!: Vinv1_inductive)

text \<open>The following two lemmas will be useful later, when we
  start taking votes with the maximum timestamp.\<close>

lemma Vinv1_finite_map_graph:
   "s \<in> Vinv1 \<Longrightarrow> finite (map_graph (case_prod (votes s)))"
  apply(rule finite_dom_finite_map_graph)
  apply(rule finite_subset[where B="{0..< v_state.next_round s} \<times> UNIV"])
   apply(auto simp add: Vinv1_def dom_def not_le[symmetric])
  done

lemma Vinv1_finite_vote_set:
   "s \<in> Vinv1 \<Longrightarrow> finite (vote_set (votes s) Q)"
   apply(drule Vinv1_finite_map_graph)
   apply(clarsimp simp add: map_graph_def fun_graph_def vote_set_def)
   apply(erule finite_surj[where f="\<lambda>((r, a), v). (r, v)"])
   by(force simp add: image_def)

lemma process_mru_map_add:
  assumes
    "s \<in> Vinv1"
  shows
    "process_mru ((votes s)(next_round s := v_f)) =
    (process_mru (votes s) ++ (\<lambda>p. map_option (Pair (next_round s)) (v_f p)))"
proof-
  from assms[THEN Vinv1D] have empty: "\<forall>r' \<ge> next_round s. votes s r' = Map.empty"
    by simp
  show ?thesis
    by(auto  simp add: process_mru_new_votes[OF empty] map_add_def split: option.split)
qed

(*************************)

lemma no_defection_empty:
  "no_defection s Map.empty r'"
  by(auto simp add: no_defection_def)

lemma no_defection_preserved:
assumes
  "s \<in> Vinv1"
  "r = next_round s"
  "no_defection s v_f r"
  "no_defection s (votes s r') r'"
  "votes s' = (votes s)(r := v_f)"
shows
  "no_defection s' (votes s' r') r'" using assms
  by(force simp add: no_defection_def)

(********)

lemma Vinv2_v_round:
  "{Vinv2 \<inter> Vinv1} v_round r v_f d_f {> Vinv2}"
  apply(auto simp add: PO_hoare_defs intro!: Vinv2I)
  apply(rename_tac s' r' s)
  apply(erule no_defection_preserved)
      apply(auto simp add: v_round_def intro!: v_state.equality)
  done

lemmas Vinv2_event_pres = Vinv2_v_round

lemma Vinv2_inductive:
  "init v_TS \<subseteq> Vinv2"
  "{Vinv2 \<inter> Vinv1} trans v_TS {> Vinv2}"
  apply(simp add: v_TS_defs Vinv2_def no_defection_def)
  by (auto simp add: v_TS_defs Vinv2_event_pres)

lemma Vinv2_invariant: "reach v_TS \<subseteq> Vinv2"
  by (rule inv_rule_incr, auto intro: Vinv2_inductive Vinv1_invariant del: subsetI)

(*************************)
lemma locked_preserved:
assumes
  "s \<in> Vinv1"
  "r = next_round s"
  "votes s' = (votes s)(r := v_f)"
shows
  "locked s \<subseteq> locked s'" using assms
  apply(auto simp add: locked_def locked_in_def locked_in_vf_def quorum_for_def dest!: Vinv1D)
  by (metis option.distinct(1))

(*************************)

lemma Vinv3_v_round:
  "{Vinv3 \<inter> Vinv1} v_round r v_f d_f {> Vinv3}"
proof(clarsimp simp add: PO_hoare_defs, intro Vinv3I, safe)
  fix s s' v
  assume step: "(s, s') \<in> v_round r v_f d_f" and inv3: "s \<in> Vinv3" and inv1: "s \<in> Vinv1"
  and dec: "v \<in> ran (decisions s')"
  have "locked s \<subseteq> locked s'" using step
    by(intro locked_preserved[OF inv1, where s'=s']) (auto simp add: v_round_def)
  with Vinv3D[OF inv3] step dec
  show "v \<in> locked s'"
    apply(auto simp add: v_round_def dest!: ran_map_addD)
    apply(auto simp add: locked_def locked_in_def d_guard_def ran_def)
    done
qed

lemmas Vinv3_event_pres = Vinv3_v_round

lemma Vinv3_inductive:
  "init v_TS \<subseteq> Vinv3"
  "{Vinv3 \<inter> Vinv1} trans v_TS {> Vinv3}"
  apply(simp add: v_TS_defs Vinv3_def no_defection_def)
  by (auto simp add: v_TS_defs Vinv3_event_pres)

lemma Vinv3_invariant: "reach v_TS \<subseteq> Vinv3"
  by (rule inv_rule_incr, auto intro: Vinv3_inductive Vinv1_invariant del: subsetI)

subsection \<open>Agreement and stability\<close>
(******************************************************************************)

text \<open>Only a singe value can be locked within the votes for one round.\<close>
lemma locked_in_vf_same:
  "\<lbrakk> locked_in_vf v_f v; locked_in_vf v_f w \<rbrakk> \<Longrightarrow> v = w" using qintersect
  apply(auto simp add: locked_in_vf_def quorum_for_def image_iff)
  by (metis Int_iff all_not_in_conv option.inject)

text \<open>In any reachable state, no two different values can be locked in
  different rounds.\<close>
theorem locked_in_different:
assumes
  "s \<in> Vinv2"
  "locked_in s r1 v"
  "locked_in s r2 w"
  "r1 < r2"
shows
  "v = w"
proof-
  \<comment> \<open>To be locked, @{term v} and @{term w} must each have received votes from a quorum.\<close>
  from assms(2-3) obtain Q1 Q2
  where Q12: "Q1 \<in> Quorum" "Q2 \<in> Quorum" "quorum_for Q1 v (votes s r1)" "quorum_for Q2 w (votes s r2)"
    by(auto simp add: locked_in_def locked_in_vf_def quorum_for_def)
  \<comment> \<open>By the quorum intersection property, some process from @{term Q1} voted for @{term w}:\<close>
  then obtain a where "a \<in> Q1" "votes s r2 a = Some w"
    using qintersect[OF \<open>Q1 \<in> Quorum\<close> \<open>Q2 \<in> Quorum\<close>]
    by(auto simp add: quorum_for_def)
  \<comment> \<open>But from @{term Vinv2} we conclude that @{term a} could not have defected by voting
        @{term w}, so @{term ?thesis}:\<close>
  thus ?thesis using \<open>s \<in> Vinv2\<close> \<open>quorum_for Q1 v (votes s r1)\<close> \<open>r1 < r2\<close>
    by(fastforce simp add: Vinv2_def no_defection_def quorum_for_def')
qed

text \<open>It is simple to extend the previous theorem to any two (not necessarily different) rounds.\<close>
theorem locked_unique:
assumes
  "s \<in> Vinv2"
  "v \<in> locked s" "w \<in> locked s"
shows
  "v = w"
proof -
  from assms(2-3) obtain r1 r2 where quoIn: "locked_in s r1 v" "locked_in s r2 w"
    by (auto simp add: locked_def)
  have "r1 < r2 \<or> r1 = r2 \<or> r2 < r1" by (rule linorder_less_linear)
  thus ?thesis
  proof (elim disjE)
    assume "r1 = r2"
    with quoIn show ?thesis
      by(simp add: locked_in_def locked_in_vf_same)
  qed(auto intro: locked_in_different[OF \<open>s \<in> Vinv2\<close>] quoIn sym)
qed

text \<open>We now prove that decisions are stable; once a process makes a decision, it never
  changes it, and it does not go back to an undecided state. Note that behaviors grow at
  the front; hence @{term "tr ! (i-j)"} is later in the trace than @{term "tr ! i"}.\<close>
lemma stable_decision:
  assumes beh: "tr \<in> beh v_TS"
  and len: "i < length tr"
  and s: "s = nth tr i"
  and t: "t = nth tr (i - j)"
  and dec:
    "decisions s p = Some v"
  shows
    "decisions t p = Some v"
proof-
  \<comment> \<open>First, we show that the both @{term s} and @{term t} respect the invariants.\<close>
  have reach: "s \<in> reach v_TS" "t \<in> reach v_TS" using beh s t len
     apply(simp_all add: reach_equiv_beh_states)
     apply (metis len nth_mem)
    apply (metis less_imp_diff_less nth_mem)
    done
  hence invs2: "s \<in> Vinv2" and invs3: "s \<in> Vinv3"
    by(blast dest: Vinv2_invariant[THEN subsetD] Vinv3_invariant[THEN subsetD])+

  show ?thesis using t
  proof(induction j arbitrary: t)
    case (Suc j)
    hence dec_j: "decisions (tr ! (i - j)) p = Some v"
      by simp
    thus "decisions t p = Some v" using Suc
    \<comment> \<open>As @{term "(-)"} is a total function on naturals, we perform a case distinction;
          if @{term "i < j"}, the induction step is trivial.\<close>
    proof(cases "i \<le> j")
      \<comment> \<open>The non-trivial case.\<close>
      case False
      define t' where "t' = tr ! (i - j)"
      \<comment> \<open>Both @{term t} and @{term t'} are reachable, thus respect the invariants, and
        they are related by the transition relation.\<close>
      hence "t' \<in> reach v_TS" "t \<in> reach v_TS" using beh len Suc
        by (metis beh_in_reach less_imp_diff_less nth_mem)+
      hence invs: "t' \<in> Vinv1" "t' \<in> Vinv3" "t \<in> Vinv2" "t \<in> Vinv3"
        by(blast dest: Vinv1_invariant[THEN subsetD] Vinv2_invariant[THEN subsetD]
          Vinv3_invariant[THEN subsetD])+
      hence locked_v: "v \<in> locked t'" using Suc
        by(auto simp add: t'_def intro: ranI)
      have "i - j = Suc (i - (Suc j))" using False
        by simp
      hence trans: "(t', t) \<in> trans v_TS" using beh len Suc
        by(auto simp add: t'_def intro!: beh_consecutive_in_trans)
      \<comment> \<open>Thus @{term v} also remains locked in @{term t}, and @{term p} does not
        revoke, nor change its decision.\<close>
      hence locked_v_t: "v \<in> locked t" using locked_v
        by(auto simp add: v_TS_defs v_round_def
          intro: locked_preserved[OF invs(1), THEN subsetD, OF _ _ locked_v])
      from trans obtain w where "decisions t p = Some w" using dec_j
        by(fastforce simp add: t'_def v_TS_defs v_round_def
          split: option.split option.split_asm)
      thus ?thesis using invs(4)[THEN Vinv3D] locked_v_t locked_unique[OF invs(3)]
        by (metis contra_subsetD ranI)
    qed(auto)
  next
    case 0
    thus "decisions t p = Some v" using assms
      by auto
  qed
qed

text \<open>Finally, we prove that the Voting model ensures agreement. Without a loss
  of generality, we assume that \<open>t\<close> preceeds \<open>s\<close> in the trace.\<close>
lemma Voting_agreement:
  assumes beh: "tr \<in> beh v_TS"
  and len: "i < length tr"
  and s: "s = nth tr i"
  and t: "t = nth tr (i - j)"
  and dec:
    "decisions s p = Some v"
    "decisions t q = Some w"
  shows "w = v"
proof-
  \<comment> \<open>Again, we first prove that the invariants hold for @{term s}.\<close>
  have reach: "s \<in> reach v_TS" using beh s t len
    apply(simp_all add: reach_equiv_beh_states)
    by (metis nth_mem)
  hence invs2: "s \<in> Vinv2" and invs3: "s \<in> Vinv3"
    by(blast dest: Vinv2_invariant[THEN subsetD] Vinv3_invariant[THEN subsetD])+

  \<comment> \<open>We now proceed to prove the thesis by induction.\<close>
  thus ?thesis using assms
  proof(induction j arbitrary: t)
    case 0
    hence
      "v \<in> locked (tr ! i)"
      "w \<in> locked (tr ! i)"
      by(auto intro: ranI)
    thus ?thesis using invs2 using assms 0
      by(auto dest: locked_unique)
  next
    case (Suc j)
    thus ?thesis
    \<comment> \<open>Again, the totality of @{term "(-)"} makes the claim trivial if @{term "i < j"}.\<close>
    proof(cases "i \<le> j")
      case False
      \<comment> \<open>In the non-trivial case, the proof follows from the decision stability theorem
        and the uniqueness of locked values.\<close>
      have dec_t: "decisions t p = Some v" using Suc
        by(auto intro: stable_decision[OF beh len s ])
      have "t \<in> reach v_TS" using beh len Suc
        by (metis beh_in_reach less_imp_diff_less nth_mem)
      hence invs: "t \<in> Vinv2" "t \<in> Vinv3"
        by(blast dest: Vinv2_invariant[THEN subsetD] Vinv3_invariant[THEN subsetD])+
      from dec_t have "v \<in> locked t" using invs(2)
        by(auto intro: ranI)
      moreover have locked_w_t: "w \<in> locked t" using Suc \<open>t \<in> Vinv3\<close>[THEN Vinv3D]
        by(auto intro: ranI)
      ultimately show ?thesis using locked_unique[OF \<open>t \<in> Vinv2\<close>]
        by blast
    qed(auto)
  qed
qed

end (* context quorum *)

end


section\<open>Algebra problems\<close>

subsection \<open>IMO 2008 SL - A1\<close>

theory IMO_2008_SL_A1
imports Complex_Main
begin

theorem IMO_2008_SL_A1:
  fixes f :: "real \<Rightarrow> real"
  assumes "\<forall> p q r s :: real. p > 0 \<and> q > 0 \<and> r > 0 \<and> s > 0 \<and> pq = rs \<longrightarrow>
   ((f p)\<^sup>2 + (f q)\<^sup>2) / (f (r\<^sup>2) + f (s\<^sup>2)) = (p\<^sup>2 + q\<^sup>2) / (r\<^sup>2 + s\<^sup>2)"
  shows "(\<forall> x > 0. f x = x) \<or> (\<forall> x > 0. f x = 1 / x)"
  sorry

end


(*  Title:      CCL/Hered.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section {* Hereditary Termination -- cf. Martin Lo\"f *}

theory Hered
imports Type
begin

text {*
  Note that this is based on an untyped equality and so @{text "lam
  x. b(x)"} is only hereditarily terminating if @{text "ALL x. b(x)"}
  is.  Not so useful for functions!
*}

definition HTTgen :: "i set \<Rightarrow> i set" where
  "HTTgen(R) ==
    {t. t=true | t=false | (EX a b. t= <a, b> \<and> a : R \<and> b : R) |
      (EX f. t = lam x. f(x) \<and> (ALL x. f(x) : R))}"

definition HTT :: "i set"
  where "HTT == gfp(HTTgen)"

subsection {* Hereditary Termination *}

lemma HTTgen_mono: "mono(\<lambda>X. HTTgen(X))"
  apply (unfold HTTgen_def)
  apply (rule monoI)
  apply blast
  done

lemma HTTgenXH:
  "t : HTTgen(A) \<longleftrightarrow> t=true | t=false | (EX a b. t=<a,b> \<and> a : A \<and> b : A) |
                                        (EX f. t=lam x. f(x) \<and> (ALL x. f(x) : A))"
  apply (unfold HTTgen_def)
  apply blast
  done

lemma HTTXH:
  "t : HTT \<longleftrightarrow> t=true | t=false | (EX a b. t=<a,b> \<and> a : HTT \<and> b : HTT) |
                                   (EX f. t=lam x. f(x) \<and> (ALL x. f(x) : HTT))"
  apply (rule HTTgen_mono [THEN HTT_def [THEN def_gfp_Tarski], THEN XHlemma1, unfolded HTTgen_def])
  apply blast
  done

subsection {* Introduction Rules for HTT *}

lemma HTT_bot: "\<not> bot : HTT"
  by (blast dest: HTTXH [THEN iffD1])

lemma HTT_true: "true : HTT"
  by (blast intro: HTTXH [THEN iffD2])

lemma HTT_false: "false : HTT"
  by (blast intro: HTTXH [THEN iffD2])

lemma HTT_pair: "<a,b> : HTT \<longleftrightarrow> a : HTT \<and> b : HTT"
  apply (rule HTTXH [THEN iff_trans])
  apply blast
  done

lemma HTT_lam: "lam x. f(x) : HTT \<longleftrightarrow> (ALL x. f(x) : HTT)"
  apply (rule HTTXH [THEN iff_trans])
  apply auto
  done

lemmas HTT_rews1 = HTT_bot HTT_true HTT_false HTT_pair HTT_lam

lemma HTT_rews2:
  "one : HTT"
  "inl(a) : HTT \<longleftrightarrow> a : HTT"
  "inr(b) : HTT \<longleftrightarrow> b : HTT"
  "zero : HTT"
  "succ(n) : HTT \<longleftrightarrow> n : HTT"
  "[] : HTT"
  "x$xs : HTT \<longleftrightarrow> x : HTT \<and> xs : HTT"
  by (simp_all add: data_defs HTT_rews1)

lemmas HTT_rews = HTT_rews1 HTT_rews2

subsection {* Coinduction for HTT *}

lemma HTT_coinduct: "\<lbrakk>t : R; R <= HTTgen(R)\<rbrakk> \<Longrightarrow> t : HTT"
  apply (erule HTT_def [THEN def_coinduct])
  apply assumption
  done

lemma HTT_coinduct3: "\<lbrakk>t : R; R <= HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))\<rbrakk> \<Longrightarrow> t : HTT"
  apply (erule HTTgen_mono [THEN [3] HTT_def [THEN def_coinduct3]])
  apply assumption
  done

lemma HTTgenIs:
  "true : HTTgen(R)"
  "false : HTTgen(R)"
  "\<lbrakk>a : R; b : R\<rbrakk> \<Longrightarrow> <a,b> : HTTgen(R)"
  "\<And>b. (\<And>x. b(x) : R) \<Longrightarrow> lam x. b(x) : HTTgen(R)"
  "one : HTTgen(R)"
  "a : lfp(\<lambda>x. HTTgen(x) Un R Un HTT) \<Longrightarrow> inl(a) : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "b : lfp(\<lambda>x. HTTgen(x) Un R Un HTT) \<Longrightarrow> inr(b) : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "zero : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "n : lfp(\<lambda>x. HTTgen(x) Un R Un HTT) \<Longrightarrow> succ(n) : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "[] : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  "\<lbrakk>h : lfp(\<lambda>x. HTTgen(x) Un R Un HTT); t : lfp(\<lambda>x. HTTgen(x) Un R Un HTT)\<rbrakk> \<Longrightarrow>
    h$t : HTTgen(lfp(\<lambda>x. HTTgen(x) Un R Un HTT))"
  unfolding data_defs by (genIs HTTgenXH HTTgen_mono)+

subsection {* Formation Rules for Types *}

lemma UnitF: "Unit <= HTT"
  by (simp add: subsetXH UnitXH HTT_rews)

lemma BoolF: "Bool <= HTT"
  by (fastforce simp: subsetXH BoolXH iff: HTT_rews)

lemma PlusF: "\<lbrakk>A <= HTT; B <= HTT\<rbrakk> \<Longrightarrow> A + B  <= HTT"
  by (fastforce simp: subsetXH PlusXH iff: HTT_rews)

lemma SigmaF: "\<lbrakk>A <= HTT; \<And>x. x:A \<Longrightarrow> B(x) <= HTT\<rbrakk> \<Longrightarrow> SUM x:A. B(x) <= HTT"
  by (fastforce simp: subsetXH SgXH HTT_rews)

(*** Formation Rules for Recursive types - using coinduction these only need ***)
(***                                          exhaution rule for type-former ***)

(*Proof by induction - needs induction rule for type*)
lemma "Nat <= HTT"
  apply (simp add: subsetXH)
  apply clarify
  apply (erule Nat_ind)
   apply (fastforce iff: HTT_rews)+
  done

lemma NatF: "Nat <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI] dest: NatXH [THEN iffD1])
  done

lemma ListF: "A <= HTT \<Longrightarrow> List(A) <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
    subsetD [THEN HTTgen_mono [THEN ci3_AI]]
    dest: ListXH [THEN iffD1])
  done

lemma ListsF: "A <= HTT \<Longrightarrow> Lists(A) <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
    subsetD [THEN HTTgen_mono [THEN ci3_AI]] dest: ListsXH [THEN iffD1])
  done

lemma IListsF: "A <= HTT \<Longrightarrow> ILists(A) <= HTT"
  apply clarify
  apply (erule HTT_coinduct3)
  apply (fast intro!: HTTgenIs elim!: HTTgen_mono [THEN ci3_RI]
    subsetD [THEN HTTgen_mono [THEN ci3_AI]] dest: IListsXH [THEN iffD1])
  done

end


theory prop_85b
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
datatype NPair = Pairn Nat Nat
datatype PList = PNil | PCons NPair PList
datatype Nlist = NNil | NCons Nat Nlist

fun ptake :: "Nat => PList => PList" where
"ptake Z     xs           = PNil"
| "ptake (S _) PNil         = PNil"
| "ptake (S n) (PCons x xs) = PCons x (ptake n xs)"
  fun ntake :: "Nat => Nlist => Nlist" where
  "ntake (Z) y = NNil"
  | "ntake (S z) (NNil) = NNil"
  | "ntake (S z) (NCons x2 x3) = NCons x2 (ntake z x3)"
  fun pzip :: "Nlist => Nlist => PList" where
  "pzip (NNil) y = PNil"
  | "pzip (NCons z x2) (NNil) = PNil"
  | "pzip (NCons z x2) (NCons x3 x4) = PCons (Pairn z x3) (pzip x2 x4)"

  fun len :: "Nlist => Nat" where
  "len (NNil) = Z"
  | "len (NCons y xs) = S (len xs)"
  fun append :: "Nlist => Nlist => Nlist" where
  "append (NNil) y = y"
  | "append (NCons z xs) y = NCons z (append xs y)"
  fun rev :: "Nlist => Nlist" where
  "rev (NNil) = NNil"
  | "rev (NCons y xs) = append (rev xs) (NCons y (NNil))"
  fun pappend :: "PList => PList => PList" where
  "pappend (PNil) y = y"
  | "pappend (PCons z xs) y = PCons z (pappend xs y)"
  fun prev :: "PList => PList" where
  "prev (PNil) = PNil"
  | "prev (PCons y xs) = pappend (prev xs) (PCons y (PNil))"

  (*hipster pzip len append rev *)
  (*hipster rev*)
lemma lemma_a [thy_expl]: "append x2 NNil = x2"
by (hipster_induct_schemes rev.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes rev.simps)

lemma lemma_ab [thy_expl]: "append (rev x5) (rev y5) = rev (append y5 x5)"
by (hipster_induct_schemes rev.simps)

(*hipster len pzip*)
lemma lemma_ac [thy_expl]: "pzip NNil x1 = pzip x1 NNil"
by (hipster_induct_schemes len.simps pzip.simps)

lemma lemma_ad [thy_expl]: "pzip NNil x1 = pzip y1 NNil"
by (hipster_induct_schemes len.simps pzip.simps)

(*hipster rev pzip*)
lemma lemma_ae [thy_expl]: "pzip x2 (append x2 y2) = pzip x2 x2"
by (hipster_induct_schemes rev.simps pzip.simps)

lemma lemma_af [thy_expl]: "pzip (append x1 y1) x1 = pzip x1 x1"
by (hipster_induct_schemes rev.simps pzip.simps)

(*hipster pzip append*)
lemma lemma_ah [thy_expl]: "pzip (append x4 x4) (NCons y4 NNil) = pzip x4 (NCons y4 NNil)"
by (hipster_induct_schemes pzip.simps append.simps)

lemma lemma_ai [thy_expl]: "pzip (NCons x1 NNil) (append y1 y1) = pzip (NCons x1 NNil) y1"
by (hipster_induct_schemes pzip.simps append.simps)

(*hipster len rev append*)
lemma lemma_aj [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes len.simps rev.simps append.simps)

(*hipster prev pappend*)
lemma lemma_ag [thy_expl]: "pappend x2 PNil = x2"
by (hipster_induct_schemes prev.simps pappend.simps)

lemma lemma_ak [thy_expl]: "pappend (pappend x1 y1) z1 = pappend x1 (pappend y1 z1)"
by (hipster_induct_schemes prev.simps pappend.simps)

lemma lemma_al [thy_expl]: "pappend (prev x9) (prev y9) = prev (pappend y9 x9)"
by (hipster_induct_schemes prev.simps pappend.simps)

lemma lemma_am [thy_expl]: "prev (prev x8) = x8"
by (hipster_induct_schemes prev.simps pappend.simps)

lemma unknown []: "pzip (append x y) (rev x) = pzip x (rev x)"
oops

lemma unknown []: "pzip (rev x) (append x y) = pzip (rev x) x"
oops

(*hipster len rev append pzip*)
(*lemma lemma_ag [thy_expl]: "len (append x4 y4) = len (append y4 x4)"
by (hipster_induct_schemes len.simps rev.simps append.simps pzip.simps Nat.exhaust)*)

lemma unknown []: "pzip (append x y) (rev x) = pzip x (rev x)"
oops

lemma unknown []: "pzip (rev x) (append x y) = pzip (rev x) x"
oops

lemma unknown []: "pzip (append x x) (rev x) = pzip x (rev x)"
oops

lemma unknown []: "pzip (rev x) (append x x) = pzip (rev x) x"
oops

(*hipster pzip pappend prev rev append len*)
lemma lemma_an [thy_expl]: "pappend (pzip x1 x1) (pzip y1 z1) = pzip (append x1 y1) (append x1 z1)"
by (hipster_induct_schemes pzip.simps pappend.simps prev.simps rev.simps append.simps len.simps)

lemma unknown [thy_expl]: "len (append x y) = len (append y x)"
oops

lemma unknown [thy_expl]: "len (rev x) = len x"
oops

lemma unknown [thy_expl]: "pzip (append x y) (rev x) = pzip x (rev x)"
oops

lemma unknown [thy_expl]: "pzip (rev x) (append x y) = pzip (rev x) x"
oops

lemma unknown [thy_expl]: "pzip (append x x) (rev x) = pzip x (rev x)"
oops

lemma unknown [thy_expl]: "pzip (rev x) (append x x) = pzip (rev x) x"
oops

lemma unknown [thy_expl]: "pzip (rev x) (rev x) = prev (pzip x x)"
oops

(*hipster len *)

fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
| "equal2 (Z) (S z) = False"
| "equal2 (S x2) (Z) = False"
| "equal2 (S x2) (S y2) = equal2 x2 y2"

(*hipster equal2*)
lemma lemma_ao [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ap [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aq [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

(*hipster_cond equal2 len*)
lemma lemma_ar [thy_expl]: "equal2 y2 x2 \<Longrightarrow> x2 = y2"
by (hipster_induct_schemes equal2.simps len.simps)

(*hipster pappend prev pzip append rev len*)
lemma lemma_aw [thy_expl]: "pappend (pzip x1 x1) (pzip y1 z1) = pzip (append x1 y1) (append x1 z1)"
by (hipster_induct_schemes pappend.simps prev.simps pzip.simps append.simps rev.simps len.simps)

lemma unknown [thy_expl]: "len (append x y) = len (append y x)"
oops

lemma unknown [thy_expl]: "len (rev x) = len x"
oops

lemma unknown [thy_expl]: "pzip (append x y) (rev x) = pzip x (rev x)"
oops

lemma unknown [thy_expl]: "pzip (rev x) (append x y) = pzip (rev x) x"
oops

lemma unknown [thy_expl]: "pzip (append x x) (rev x) = pzip x (rev x)"
oops

lemma unknown [thy_expl]: "pzip (rev x) (append x x) = pzip (rev x) x"
oops

lemma unknown [thy_expl]: "pzip (rev x) (rev x) = prev (pzip x x)"
oops

(*hipster append len*)
(*
lemma xx[thy_expl]: "len (append xs (NCons y ys)) = S (len (append xs ys))"
by (hipster_induct_schemes append.simps len.simps list.exhaust)

lemma lemma_applen [thy_expl]: "len (append x y) = len (append y x)"
by (hipster_induct_schemes append.simps len.simps list.exhaust)*)
(*
apply(induction x y rule: pzip.induct)
apply(simp_all)
apply(metis thy_expl append.simps len.simps list.exhaust)
apply(metis thy_expl pzip.simps append.simps len.simps list.exhaust)
apply(metis (full_types) thy_expl pzip.simps append.simps len.simps list.exhaust)
by (hipster_induct_schemes append.simps len.simps list.exhaust)*)
(*
lemma lemma_at [thy_expl]: "len (rev x3) = len x3"
by (hipster_induct_schemes len.simps rev.simps append.simps)
*)
(*
len (x++y) == len (y++x) proved by induction on  y, x

zip (x++y) (rev x) == zip x (rev x) failed to be proved
zip (rev x) (x++y) == zip (rev x) x failed to be proved

zip x x++++zip y z == zip (x++y) (x++z) proved by induction on  x

zip (rev x) (rev x) == prev (zip x x) proved by induction on  x

zip (x++y) (rev x) == zip x (rev x) failed to be proved
zip (rev x) (x++y) == zip (rev x) x failed to be proved
zip (rev x) (x++x) == zip (rev x) x failed to be proved
zip (x++x) (rev x) == zip x (rev x) failed to be proved

prop_85 failed to be proved

*)

fun lenq:: "Nlist \<Rightarrow> Nlist \<Rightarrow> bool" where
"lenq xs ys = equal2 (len xs) (len ys)"

hipster lenq equal2 append

(*hipster_cond lenq rev equal2 append prev pappend*)

  theorem x0 :
    "((len xs) = (len ys)) ==>
       ((pzip (rev xs) (rev ys)) = (prev (pzip xs ys)))"
       apply(induction xs)
       apply(simp)
       apply(case_tac ys)
       apply simp

       sledgehammer

       (*by (hipster_induct_schemes len.simps pzip.simps rev.simps prev.simps pappend.simps append.simps PList.exhaust Nlist.exhaust)*)

(*
    apply(induction xs ys rule: pzip.induct)
apply simp_all
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


theory Laplace_Transform_Library
  imports
    "HOL-Analysis.Analysis"
begin

section \<open>References\<close>

text \<open>
Much of this formalization is based on Schiff's textbook @{cite "Schiff2013"}.
Parts of this formalization are inspired by the HOL-Light formalization
(@{cite "Taqdees2013"}, @{cite "Rashid2017"}, @{cite "Rashid2018"}), but stated more generally for
piecewise continuous (instead of piecewise continuously differentiable) functions.
\<close>

section \<open>Library Additions\<close>

subsection \<open>Derivatives\<close>

lemma DERIV_compose_FDERIV:\<comment>\<open>TODO: generalize and move from HOL-ODE\<close>
  assumes "DERIV f (g x) :> f'"
  assumes "(g has_derivative g') (at x within s)"
  shows "((\<lambda>x. f (g x)) has_derivative (\<lambda>x. g' x * f')) (at x within s)"
  using assms has_derivative_compose[of g g' x s f "(*) f'"]
  by (auto simp: has_field_derivative_def ac_simps)

lemmas has_derivative_sin[derivative_intros] = DERIV_sin[THEN DERIV_compose_FDERIV]
  and  has_derivative_cos[derivative_intros] = DERIV_cos[THEN DERIV_compose_FDERIV]
  and  has_derivative_exp[derivative_intros] = DERIV_exp[THEN DERIV_compose_FDERIV]

subsection \<open>Integrals\<close>

lemma negligible_real_ivlI:
  fixes a b::real
  assumes "a \<ge> b"
  shows "negligible {a .. b}"
proof -
  from assms have "{a .. b} = {a} \<or> {a .. b} = {}"
    by auto
  then show ?thesis
    by auto
qed

lemma absolutely_integrable_on_combine:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "f absolutely_integrable_on {a..c}"
    and "f absolutely_integrable_on {c..b}"
    and "a \<le> c"
    and "c \<le> b"
  shows "f absolutely_integrable_on {a..b}"
  using assms
  unfolding absolutely_integrable_on_def integrable_on_def
  by (auto intro!: has_integral_combine)

lemma dominated_convergence_at_top:
  fixes f :: "real \<Rightarrow> 'n::euclidean_space \<Rightarrow> 'm::euclidean_space"
  assumes f: "\<And>k. (f k) integrable_on s" and h: "h integrable_on s"
    and le: "\<And>k x. x \<in> s \<Longrightarrow> norm (f k x) \<le> h x"
    and conv: "\<forall>x \<in> s. ((\<lambda>k. f k x) \<longlongrightarrow> g x) at_top"
  shows "g integrable_on s" "((\<lambda>k. integral s (f k)) \<longlongrightarrow> integral s g) at_top"
proof -
  have 3: "set_integrable lebesgue s h"
    unfolding absolutely_integrable_on_def
  proof
    show "(\<lambda>x. norm (h x)) integrable_on s"
    proof (intro integrable_spike_finite[OF _ _ h, where S="{}"] ballI)
      fix x assume "x \<in> s - {}" then show "norm (h x) = h x"
        using order_trans[OF norm_ge_zero le[of x]] by auto
    qed auto
  qed fact
  have 2: "set_borel_measurable lebesgue s (f k)" for k
    using f[of k]
    using has_integral_implies_lebesgue_measurable[of "f k"]
    by (auto intro:  simp: integrable_on_def set_borel_measurable_def)
  have conv': "\<forall>x \<in> s. ((\<lambda>k. f k x) \<longlongrightarrow> g x) sequentially"
    using conv filterlim_filtermap filterlim_compose filterlim_real_sequentially by blast
  from 2 have 1: "set_borel_measurable lebesgue s g"
    unfolding set_borel_measurable_def
    by (rule borel_measurable_LIMSEQ_metric) (use conv' in \<open>auto split: split_indicator\<close>)
  have 4: "AE x in lebesgue. ((\<lambda>i. indicator s x *\<^sub>R f i x) \<longlongrightarrow> indicator s x *\<^sub>R g x) at_top"
    "\<forall>\<^sub>F i in at_top. AE x in lebesgue. norm (indicator s x *\<^sub>R f i x) \<le> indicator s x *\<^sub>R h x"
    using conv le by (auto intro!: always_eventually split: split_indicator)

  note 1 2 3 4
  note * = this[unfolded set_borel_measurable_def set_integrable_def]
  have g: "g absolutely_integrable_on s"
    unfolding set_integrable_def
    by (rule integrable_dominated_convergence_at_top[OF *])
  then show "g integrable_on s"
    by (auto simp: absolutely_integrable_on_def)
  have "((\<lambda>k. (LINT x:s|lebesgue. f k x)) \<longlongrightarrow> (LINT x:s|lebesgue. g x)) at_top"
    unfolding set_lebesgue_integral_def
    using *
    by (rule integral_dominated_convergence_at_top)
  then show "((\<lambda>k. integral s (f k)) \<longlongrightarrow> integral s g) at_top"
    using g absolutely_integrable_integrable_bound[OF le f h]
    by (subst (asm) (1 2) set_lebesgue_integral_eq_integral) auto
qed

lemma has_integral_dominated_convergence_at_top:
  fixes f :: "real \<Rightarrow> 'n::euclidean_space \<Rightarrow> 'm::euclidean_space"
  assumes "\<And>k. (f k has_integral y k) s" "h integrable_on s"
    "\<And>k x. x\<in>s \<Longrightarrow> norm (f k x) \<le> h x" "\<forall>x\<in>s. ((\<lambda>k. f k x) \<longlongrightarrow> g x) at_top"
    and x: "(y \<longlongrightarrow> x) at_top"
  shows "(g has_integral x) s"
proof -
  have int_f: "\<And>k. (f k) integrable_on s"
    using assms by (auto simp: integrable_on_def)
  have "(g has_integral (integral s g)) s"
    by (intro integrable_integral dominated_convergence_at_top[OF int_f assms(2)]) fact+
  moreover have "integral s g = x"
  proof (rule tendsto_unique)
    show "((\<lambda>i. integral s (f i)) \<longlongrightarrow> x) at_top"
      using integral_unique[OF assms(1)] x by simp
    show "((\<lambda>i. integral s (f i)) \<longlongrightarrow> integral s g) at_top"
      by (intro dominated_convergence_at_top[OF int_f assms(2)]) fact+
  qed simp
  ultimately show ?thesis
    by simp
qed

lemma integral_indicator_eq_restriction:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::banach"
  assumes f: "f integrable_on R"
    and "R \<subseteq> S"
  shows "integral S (\<lambda>x. indicator R x *\<^sub>R f x) = integral R f"
proof -
  let ?f = "\<lambda>x. indicator R x *\<^sub>R f x"
  have "?f integrable_on R"
    using f negligible_empty
    by (rule integrable_spike) auto
  from integrable_integral[OF this]
  have "(?f has_integral integral R ?f) S"
    by (rule has_integral_on_superset) (use \<open>R \<subseteq> S\<close> in \<open>auto simp: indicator_def\<close>)
  also have "integral R ?f = integral R f"
    using negligible_empty
    by (rule integral_spike) auto
  finally show ?thesis
    by blast
qed

lemma
  improper_integral_at_top:
  fixes f::"real \<Rightarrow> 'a::euclidean_space"
  assumes "f absolutely_integrable_on {a..}"
  shows "((\<lambda>x. integral {a..x} f) \<longlongrightarrow> integral {a..} f) at_top"
proof -
  let ?f = "\<lambda>(k::real) (t::real). indicator {a..k} t *\<^sub>R f t"
  have f: "f integrable_on {a..k}" for k
    using set_lebesgue_integral_eq_integral(1)[OF assms]
    by (rule integrable_on_subinterval) simp
  from this negligible_empty have "?f k integrable_on {a..k}" for k
    by (rule integrable_spike) auto
  from this have "?f k integrable_on {a..}" for k
    by (rule integrable_on_superset) auto
  moreover
  have "(\<lambda>x. norm (f x)) integrable_on {a..}"
    using assms by (simp add: absolutely_integrable_on_def)
  moreover
  note _
  moreover
  have "\<forall>\<^sub>F k in at_top. k \<ge> x" for x::real
    by (simp add: eventually_ge_at_top)
  then have "\<forall>x\<in>{a..}. ((\<lambda>k. ?f k x) \<longlongrightarrow> f x) at_top"
    by (auto intro!: Lim_transform_eventually[OF tendsto_const] simp: indicator_def eventually_at_top_linorder)
  ultimately
  have "((\<lambda>k. integral {a..} (?f k)) \<longlongrightarrow> integral {a ..} f) at_top"
    by (rule dominated_convergence_at_top) (auto simp: indicator_def)
  also have "(\<lambda>k. integral {a..} (?f k)) = (\<lambda>k. integral {a..k} f)"
    by (auto intro!: ext integral_indicator_eq_restriction f)
  finally show ?thesis .
qed

lemma norm_integrable_onI: "(\<lambda>x. norm (f x)) integrable_on S"
  if "f absolutely_integrable_on S"
  for f::"'a::euclidean_space\<Rightarrow>'b::euclidean_space"
  using that by (auto simp: absolutely_integrable_on_def)

lemma
  has_integral_improper_at_topI:
  fixes f::"real \<Rightarrow> 'a::banach"
  assumes I: "\<forall>\<^sub>F k in at_top. (f has_integral I k) {a..k}"
  assumes J: "(I \<longlongrightarrow> J) at_top"
  shows "(f has_integral J) {a..}"
  apply (subst has_integral')
proof (auto, goal_cases)
  case (1 e)
  from tendstoD[OF J \<open>0 < e\<close>]
  have "\<forall>\<^sub>F x in at_top. dist (I x) J < e" .
  moreover have "\<forall>\<^sub>F x in at_top. (x::real) > 0" by simp
  moreover have "\<forall>\<^sub>F x in at_top. (x::real) > - a"\<comment>\<open>TODO: this seems to be strange?\<close>
    by simp
  moreover note I
  ultimately have "\<forall>\<^sub>F x in at_top. x > 0 \<and> x > - a \<and> dist (I x) J < e \<and>
    (f has_integral I x) {a..x}" by eventually_elim auto
  then obtain k where k: "\<forall>b\<ge>k. norm (I b - J) < e" "k > 0" "k > - a"
    and I: "\<And>c. c \<ge> k \<Longrightarrow> (f has_integral I c) {a..c}"
    by (auto simp: eventually_at_top_linorder dist_norm)
  show ?case
    apply (rule exI[where x=k])
    apply (auto simp: \<open>0 < k\<close>)
    subgoal premises prems for b c
    proof -
      have ball_eq: "ball 0 k = {-k <..< k}" by (auto simp: abs_real_def split: if_splits)
      from prems \<open>0 < k\<close> have "c \<ge> 0" "b \<le> 0"
        by (auto simp: subset_iff)
      with prems \<open>0 < k\<close> have "c \<ge> k"
        apply (auto simp: ball_eq)
        apply (auto simp: subset_iff)
        apply (drule spec[where x="(c + k)/2"])
        apply (auto simp: algebra_split_simps not_less)
        using \<open>0 \<le> c\<close> by linarith
      then have "norm (I c - J) < e" using k by auto
      moreover
      from prems \<open>0 < k\<close> \<open>c \<ge> 0\<close> \<open>b \<le> 0\<close> \<open>c \<ge> k\<close> \<open>k > - a\<close> have "a \<ge> b"
        apply (auto simp: ball_eq)
        apply (auto simp: subset_iff)
        by (meson \<open>b \<le> 0\<close> less_eq_real_def minus_less_iff not_le order_trans)
      have "((\<lambda>x. if x \<in> cbox a c then f x else 0) has_integral I c) (cbox b c)"
        apply (subst has_integral_restrict_closed_subintervals_eq)
        using I[of c] prems \<open>a \<ge> b\<close> \<open>k \<le> c\<close>
        by (auto )
      from negligible_empty _ this have "((\<lambda>x. if a \<le> x then f x else 0) has_integral I c) (cbox b c)"
        by (rule has_integral_spike) auto
      ultimately
      show ?thesis
        by (intro exI[where x="I c"]) auto
    qed
    done
qed

subsection \<open>Miscellaneous\<close>

lemma AE_BallI: "AE x\<in>X in F. P x" if "\<forall>x \<in> X. P x"
  using that by (intro always_eventually) auto

lemma bounded_le_Sup:
  assumes "bounded (f ` S)"
  shows "\<forall>x\<in>S. norm (f x) \<le> Sup (norm ` f ` S)"
  by (auto intro!: cSup_upper bounded_imp_bdd_above simp: bounded_norm_comp assms)

end


(*  Title:      A state based hotel key card system

    Author:     Tobias Nipkow, TU Muenchen
*)

(*<*)
theory State
imports Basis
begin

declare if_split_asm[split]
(*>*)

section\<open>A state based model\<close>

text\<open>The model is based on three opaque types @{typ guest},
@{typ key} and @{typ room}. Type @{typ card} is just an abbreviation
for @{typ"key \<times> key"}.

The state of the system is modelled as a record which combines the
information about the front desk, the rooms and the guests.
\<close>

record state =
 owns :: "room \<Rightarrow> guest option"
 currk :: "room \<Rightarrow> key"
 issued :: "key set"
 cards :: "guest \<Rightarrow> card set"
 roomk :: "room \<Rightarrow> key"
 isin :: "room \<Rightarrow> guest set"
 safe :: "room \<Rightarrow> bool"

text\<open>\noindent Reception records who @{const owns} a room (if anybody, hence
@{typ"guest option"}), the current key @{const currk} that has been
issued for a room, and which keys have been @{const issued} so
far. Each guest has a set of @{const cards}. Each room has a key
@{const roomk} recorded in the lock and a set @{const isin} of
occupants. The auxiliary variable @{const safe} is explained further
below; we ignore it for now.

In specification languages like Z, VDM and B we would now define a
number of operations on this state space. Since they are the only
permissible operations on the state, this defines a set of
\emph{reachable} states. In a purely logical environment like
Isabelle/HOL this set can be defined directly by an inductive
definition. Each clause of the definition corresponds to a
transition/operation/event. This is the standard approach to modelling
state machines in theorem provers.

The set of reachable states of the system (called \<open>reach\<close>) is
defined by four transitions: initialization, checking in, entering a room,
and leaving a room:\<close>

(*<*)
inductive_set reach :: "state set"
where
(*>*)
init:
"inj initk \<Longrightarrow>
\<lparr> owns = (\<lambda>r. None), currk = initk, issued = range initk,
  cards = (\<lambda>g. {}), roomk = initk, isin = (\<lambda>r. {}),
  safe = (\<lambda>r. True) \<rparr> \<in> reach"

| check_in:
"\<lbrakk> s \<in> reach; k \<notin> issued s \<rbrakk> \<Longrightarrow>
s\<lparr> currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g),
   safe := (safe s)(r := False) \<rparr> \<in> reach"

| enter_room:
"\<lbrakk> s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'} \<rbrakk> \<Longrightarrow>
s\<lparr> isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = \<lfloor>g\<rfloor> \<and> isin s r = {} \<and> k' = currk s r
                              \<or> safe s r)
  \<rparr> \<in> reach"

| exit_room:
"\<lbrakk> s \<in> reach;  g \<in> isin s r \<rbrakk> \<Longrightarrow>
s\<lparr> isin := (isin s)(r := isin s r - {g}) \<rparr> \<in> reach"

text\<open>\bigskip There is no check-out event because it is implicit in the next
check-in for that room: this covers the cases where a guest leaves without checking out (in which case the room should not be blocked forever) or where
the hotel decides to rent out a room prematurely, probably by accident.
Neither do guests have to return their cards at any point because they may
loose cards or may pretended to have lost them.
We will now explain the events.
\begin{description}
\item[\<open>init\<close>]
Initialization requires that every room has a different key, i.e.\
that @{const currk} is injective. Nobody
owns a room, the keys of all rooms are recorded as issued, nobody has
a card, and all rooms are empty.
\item[@{thm[source] enter_room}]
A guest may enter if either of the two keys on his card equal the room key.
Then \<open>g\<close> is added to the occupants of \<open>r\<close> and
the room key is set to the second key on the card.
Normally this has no effect because the second key is already the room key.
But when entering for the first time, the first key on the card equals
the room key and then the lock is actually recoded.
\item[\<open>exit_room\<close>]
removes an occupant from the occupants of a room.
\item[\<open>check_in\<close>] for room \<open>r\<close> and guest \<open>g\<close>
issues the card @{term"(currk s r, k)"}
to \<open>g\<close>, where \<open>k\<close> is new, makes \<open>g\<close> the owner of the room,
and sets @{term"currk s r"} to the new key \<open>k\<close>.
\end{description}

The reader can easily check that our specification allows the intended
distributed implementation: entering only reads and writes the key in
that lock, and check-in only reads and writes the information at
reception.

In contrast to Jackson we require that initially distinct rooms have
distinct keys. This protects the hotel from its guests: otherwise a
guest may be able to enter rooms he does not own, potentially stealing
objects from those rooms. Of course he can also steal objects from his
own room, but in that case it is easier to hold him responsible. In
general, the hotel may just want to minimize the opportunity for
theft.

The main difference to Jackson's model is that his can talk about
transitions between states rather than merely about reachable
states. This means that he can specify that unauthorized entry into a
room should not occur. Because our specification does not formalize
the transition relation itself, we need to include the \<open>isin\<close>
component in order to
express the same requirement. In the end, we would like to establish
that the system is \emph{safe}: only the owner of a room can be in a
room:
\begin{center}
@{prop"s \<in> reach \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"}
\end{center}
Unfortunately, this is just not true. It does not take a PhD in
computer science to come up with the following scenario: because
guests can retain their cards, there is nothing to stop a guest from
reentering his old room after he has checked out (in our model: after
the next guest has checked in), but before the next guest has entered
his room. Hence the best we can do is to prove a conditional safety
property: under certain conditions, the above safety property
holds. The question is: which conditions? It is clear that the room
must be empty when its owner enters it, or all bets
are off. But is that sufficient? Unfortunately not. Jackson's Alloy tool
took 2 seconds~\cite[p.~303]{Jackson06}
to find the following ``guest-in-the-middle'' attack:

\begin{enumerate}

\item Guest 1 checks in and obtains a card $(k_1,k_2)$ for room 1 (whose key
in the lock is $k_1$). Guest 1 does not enter room 1.

\item Guest 2 checks in, obtains a card $(k_2,k_3)$ for room 1, but
does not enter room 1 either.

\item Guest 1 checks in again, obtains a card $(k_3,k_4)$, goes to
room 1, opens it with his old card $(k_1,k_2)$, finds the room empty,
and feels safe \ldots

\end{enumerate}
After Guest~1 has left his room, Guest~2 enters and makes off with the
luggage.

Jackson now assumes that guests return their cards upon
check-out, which can be modelled as follows: upon check-in, the new card
is not added to the guest's set of cards but it replaces his previous
set of cards, i.e.\ guests return old cards the next time they check
in.  Under this assumption, Alloy finds no more counterexamples to
safety --- at least not up to 6 cards and keys and 3 guests and
rooms. This is not a proof but a strong indication that the given
assumptions suffice for safety. We prove that this is indeed the case.

It should be noted that the system also suffers from a liveness
problem: if a guest never enters the room he checked in to, that room
is forever blocked. In practice this is dealt with by a master key. We
ignore liveness.

\subsection{Formalizing safety}
\label{sec:formalizing-safety}

It should be clear that one cannot force guests to always return their
cards (or, equivalently, never to use an old card). We can only prove that if
they do, their room is safe. However, we do not follow Jackson's
approach of globally assuming everybody returns their old cards upon
check-in. Instead we would like to take a local approach where it is up
to each guest whether he follows this safety policy. We allow
guests to keep their cards but make safety dependent on how they use
them.  This generality requires a finer grained model: we need to
record if a guest has entered his room in a safe manner,
i.e.\ if it was empty and if he used the latest key for the room, the
one stored at reception.
The auxiliary variable @{const safe} records for each room if this
was the case at some point between his last check-in and now.
The main theorem will be that if a room is safe in this
manner, then only the owner can be in the room.
Now we explain how @{const safe} is modified with each event:

\begin{description}
\item[\<open>init\<close>] sets @{const safe} to @{const True} for every room.
\item[\<open>check_in\<close>] for room \<open>r\<close> resets @{prop"safe s r"}
because it is not safe for the new owner yet.
\item[@{thm[source] enter_room}] for room \<open>r\<close> sets @{prop"safe s r"} if
the owner entered an empty room using the latest card issued for that room
by reception, or if the room was already safe.
\item[\<open>exit_room\<close>] does not modify @{const safe}.
\end{description}

The reader should convince his or herself that @{const safe}
corresponds to the informal safety policy set out above.  Note that a
guest may find his room non-empty the first time he enters, and
@{const safe} will not be set, but he may come back later, find the
room empty, and then @{const safe} will be set. Furthermore, it is
important that @{thm[source] enter_room} cannot reset @{const safe}
due to the disjunct \<open>\<or> safe s r\<close>.  Hence \<open>check_in\<close> is
the only event that can reset @{const safe}.  That is, a room stays
safe until the next \<open>check_in\<close>.  Additionally @{const safe} is
initially @{const True}, which is fine because initially injectivity
of \<open>initk\<close> prohibits illegal entries by non-owners.

Note that because none of the other state components depend on @{const
safe}, it is truly auxiliary: it can be deleted from the system and
the same set of reachable states is obtained, modulo the absence of
@{const safe}.

We have formalized a very general safety policy of always using the
latest card. A special case of this policy is the one called
\emph{NoIntervening} by Jackson~\cite[p.~200]{Jackson06}: every \<open>check_in\<close> must immediately be followed by the corresponding @{thm[source]
enter_room}.
\<close>

(*<*)
lemma currk_issued[simp]: "s : reach \<Longrightarrow> currk s r : issued s"
by (induct set: reach) auto

lemma key1_issued[simp]: "s : reach \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k : issued s"
by (induct set: reach) auto

lemma key2_issued[simp]: "s : reach \<Longrightarrow> (k,k') : cards s g \<Longrightarrow> k' : issued s"
by (induct set: reach) auto

lemma roomk_issued[simp]: "s : reach \<Longrightarrow> roomk s k : issued s"
by (induct set: reach) auto

lemma currk_inj[simp]:
 "s : reach \<Longrightarrow> \<forall>r r'. (currk s r = currk s r') = (r = r')"
by (induct set: reach) (auto simp:inj_on_def)

lemma key1_not_currk[simp]:
 "s : reach \<Longrightarrow> (currk s r,k') \<notin> cards s g"
by (induct set: reach) auto

lemma guest_key2_disj[simp]:
 "\<lbrakk> s : reach; (k\<^sub>1,k) \<in> cards s g\<^sub>1; (k\<^sub>2,k) \<in> cards s g\<^sub>2 \<rbrakk> \<Longrightarrow> g\<^sub>1=g\<^sub>2"
by (induct set: reach) auto

lemma safe_roomk_currk[simp]:
 "s : reach \<Longrightarrow> safe s r \<Longrightarrow> roomk s r = currk s r"
by (induct set: reach) auto

lemma safe_only_owner_enter_normal_aux[simp]:
 "\<lbrakk> s : reach; safe s r; (k',roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g"
by (induct set: reach) (auto)

lemma safe_only_owner_enter_normal:
assumes "s : reach"
shows "\<lbrakk> safe s r; (k',roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g"
using assms
proof induct
  case (enter_room s k k1 g1 r1)
  let ?s' = "s\<lparr>isin := (isin s)(r1 := isin s r1 \<union> {g1}),
               roomk := (roomk s)(r1 := k1),
               safe := (safe s)
                 (r1 :=
                    owns s r1 = Some g1 \<and> isin s r1 = {} \<and> k1 = currk s r1 \<or>
                    safe s r1)\<rparr>"
  note s = \<open>s \<in> reach\<close>
  and IH = \<open>\<lbrakk> safe s r; (k', roomk s r) \<in> cards s g \<rbrakk> \<Longrightarrow> owns s r = Some g\<close>
  and card_g1 = \<open>(k,k1) \<in> cards s g1\<close> and safe = \<open>safe ?s' r\<close>
  and card_g = \<open>(k',roomk ?s' r) \<in> cards ?s' g\<close>
  have "roomk s r1 = k \<or> roomk s r1 = k1" using \<open>roomk s r1 \<in> {k,k1}\<close> by simp
  thus ?case
  proof
    assume [symmetric,simp]: "roomk s r1 = k"
    show ?thesis
    proof (cases "r1 = r")
      assume "r1 \<noteq> r" with IH safe card_g show ?thesis by simp
    next
      assume [simp]: "r1 = r"
      hence safe': "owns s r = Some g1 \<or> safe s r"
        using safe by auto
      thus ?thesis
      proof
        assume "safe s r"
        with s card_g1 have False by simp
        thus ?thesis ..
      next
        assume [simp]: "owns s r = Some g1"
        thus "owns ?s' r = Some g"
          using s card_g card_g1 by simp
      qed
    qed
  next
    assume "roomk s r1 = k1"
    with enter_room show ?case by auto
  qed
qed auto

theorem "s : reach \<Longrightarrow> safe s r \<Longrightarrow> g : isin s r \<Longrightarrow> owns s r = Some g"
by (induct set: reach) auto

theorem safe: assumes "s : reach"
shows "safe s r \<Longrightarrow> g : isin s r \<Longrightarrow> owns s r = Some g"
using assms
proof induct
  case (enter_room s k1 k2 g1 r1)
  let ?s' = "s\<lparr>isin := (isin s)(r1 := isin s r1 \<union> {g1}),
               roomk := (roomk s)(r1 := k2),
               safe := (safe s)
                 (r1 :=
                    owns s r1 = Some g1 \<and> isin s r1 = {} \<and> k2 = currk s r1 \<or>
                    safe s r1)\<rparr>"
  note s = \<open>s \<in> reach\<close>
  and IH = \<open>\<lbrakk> safe s r; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g\<close>
  and card_g1 = \<open>(k1,k2) \<in> cards s g1\<close> and safe = \<open>safe ?s' r\<close>
  and isin = \<open>g \<in> isin ?s' r\<close>
  show ?case
    proof (cases "r1 = r")
      assume "r1 \<noteq> r" with IH isin safe show ?thesis by simp
    next
      assume [simp]: "r1 = r"
      have "g \<in> isin s r \<or> g = g1" using isin by auto
      thus ?thesis
      proof
        assume g: "g \<in> isin s r"
        then have "safe s r" using safe by auto
        with g show ?thesis using IH by simp
      next
        assume [simp]: "g = g1"
        have "k2 = roomk s r1 \<or> k1 = roomk s r1"
          using \<open>roomk s r1 \<in> {k1,k2}\<close> by auto
        thus ?thesis
        proof
          assume "k2 = roomk s r1"
          with card_g1 s safe show ?thesis
            by auto
      next
        assume [simp]: "k1 = roomk s r1"
        have "owns s r = Some g1 \<or> safe s r" using safe by auto
        thus ?thesis
        proof
          assume "owns s r = Some g1" thus ?thesis by simp
        next
          assume "safe s r"
          hence False using s card_g1 by auto
          thus ?thesis ..
        qed
      qed
    qed
  qed
qed auto
(*>*)

text\<open>

\subsection{Verifying safety}
\label{sec:verisafe}

All of our lemmas are invariants of @{const reach}.
The complete list, culminating in the main theorem, is this:
\begin{lemma}\label{state-lemmas}
\begin{enumerate}
\item @{thm currk_issued}
\item @{thm key1_issued}
\item @{thm key2_issued}
\item @{thm roomk_issued}
\item \label{currk_inj} @{thm currk_inj}
\item \label{key1_not_currk} @{thm key1_not_currk}
\item @{thm guest_key2_disj}
\item \label{safe_roomk_currk} @{thm[display] safe_roomk_currk}
\item \label{safe_only_owner_enter_normal} @{thm safe_only_owner_enter_normal}
\end{enumerate}
\end{lemma}
\begin{theorem}\label{safe-state}
@{thm[mode=IfThen] safe}
\end{theorem}
The lemmas and the theorem are proved in this order, each one is marked as a
simplification rule, and each proof is a one-liner: induction on
@{prop"s \<in> reach"} followed by \<open>auto\<close>.

Although, or maybe even because these proofs work so smoothly one may
like to understand why. Hence we examine the proof of
Theorem~\ref{safe-state} in more detail. The only interesting case is
@{thm[source] enter_room}. We assume that guest \<open>g\<^sub>1\<close> enters room
\<open>r\<^sub>1\<close> with card @{term"(k\<^sub>1,k\<^sub>2)"} and call the new state \<open>t\<close>.
We assume @{prop"safe t r"} and @{prop"g \<in> isin t r"} and prove
@{prop"owns t r = \<lfloor>g\<rfloor>"} by case distinction.
If @{prop"r\<^sub>1 \<noteq> r"}, the claim follows directly from the induction hypothesis
using \mbox{@{prop"safe s r"}} and @{prop"g \<in> isin t r"}
because @{prop"owns t r = owns s r"} and @{prop"safe t r = safe s r"}.
If @{prop"r\<^sub>1 = r"} then @{prop"g \<in> isin t r"} is equivalent with
@{prop"g \<in> isin s r \<or> g = g\<^sub>1"}. If @{prop"g \<in> isin s r"} then
\mbox{@{prop"safe s r"}} follows from @{prop"safe t r"} by
definition of @{thm[source]enter_room} because @{prop"g \<in> isin s r"}
implies @{prop"isin s r \<noteq> {}"}. Hence the induction hypothesis implies the
claim.  If @{prop"g = g\<^sub>1"} we make another case distinction.
If @{prop"k\<^sub>2 = roomk s r"}, the claim follows immediately from
Lemma~\ref{state-lemmas}.\ref{safe_only_owner_enter_normal} above:
only the owner of a room can possess a card where the second
key is the room key.
If @{prop"k\<^sub>1 = roomk s r"} then, by definition of @{thm[source]enter_room},
@{prop"safe t r"} implies @{prop"owns s r = \<lfloor>g\<rfloor> \<or> safe s r"}.
In the first case the claim is immediate. If @{prop"safe s r"}
then @{prop"roomk s r = currk s r"}
(by Lemma~\ref{state-lemmas}.\ref{safe_roomk_currk})
and thus @{prop"(currk s r, k\<^sub>2) \<in> cards s g"} by assumption
@{prop"(k\<^sub>1,k\<^sub>2) \<in> cards s g\<^sub>1"}, thus contradicting
Lemma~\ref{state-lemmas}.\ref{key1_not_currk}.

This detailed proof shows that a number of case distinctions are
required. Luckily, they all suggest themselves to Isabelle via the
definition of function update (\<open>:=\<close>) or via disjunctions that
arise automatically.
\<close>

(*<*)
end
(*>*)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Normalising Word Numerals"

theory Norm_Words
imports "Signed_Words"
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval \<open>[0..2^len_of 'a)\<close>. Only for concrete word lengths.
\<close>

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (LENGTH('a)) (-numeral x))"
  by (simp only: word_ubin.Abs_norm word_neg_numeral_alt)

ML \<open>
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT (Type (@{type_name word}, [Type (@{type_name signed}, [T])])) = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

declare word_pow_0 [simp]

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ LENGTH('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

lemma "f (7 :: 2 word) = f 3" by simp

lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

lemma "(-1 :: 2 word) = 3" by simp

lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

lemma "f (-1) = f (15 :: 4 word)" by simp

lemma "f (-1) = f (7 :: 3 word)" by simp

lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end


theory Example
  imports NuStd_Base NuInstructions "HOL-Library.Permutation" "List_Index"
begin

text \<open>
  For the \<nu>-type variant of a Hoare triple " {\<PP>} f {\<QQ>} ", the \<PP> and \<QQ> are sets of \<nu>-types.
  In Isabelle/HOL, a set is represented by indicating explicitly the quantified variables to
    distinguish with fixed free variables, e.g. \<^term>\<open>{ (x,y) |x. x < y }\<close>,
    where the 'x' is a quantified variable but the 'y' is a fixed free variable,
    and this set represents all pairs where the second element equals to the fixed y and the first
    element is less than y.
  In this case, the set of \<nu>-types \<PP> and \<QQ> are of form \<^term>\<open>{ X x |x. P x }\<close> and \<^term>\<open>{ Y y |y. Q y }\<close>.
  Upon this, in the implementation we represent the Hoare triple "{ X x |x. P x } f { Y y |y. Q y }"
  by the proposition \<^prop>\<open>\<^bold>p\<^bold>r\<^bold>o\<^bold>c f \<blangle> X x \<^bold>s\<^bold>u\<^bold>b\<^bold>j x. P x \<longmapsto> Y y \<^bold>s\<^bold>u\<^bold>b\<^bold>j y. Q y \<brangle>\<close>.
  For example, the function that generates a random 32-bits integer less than 10 can be specified by,
  \<^prop>\<open>\<^bold>p\<^bold>r\<^bold>o\<^bold>c rand \<blangle> Void \<longmapsto> x \<tycolon> \<nat>[32] \<^bold>s\<^bold>u\<^bold>b\<^bold>j x. x < 10 \<brangle>\<close>.
\<close>

declare Nat.One_nat_def[simp del] Num.add_2_eq_Suc'[simp del] split_paired_All[simp del]
lemmas add1_le_eq[simp] = Suc_le_eq[unfolded Suc_eq_plus1]

section\<open>Subtraction by 1\<close>

text \<open>There are some options to enable a verbose printing giving details about the intermediate
  steps of the reasoning.\<close>
(* declare [[\<nu>trace_reasoning, \<nu>trace_processing]] *)
text \<open>And this version gives an even more verbose printing.\<close>
(* declare [[\<nu>trace_reasoning, \<nu>trace_reasoning_candicates, \<nu>trace_processing, \<nu>trace_application]]  *)

proc sub1:  \<open>x \<tycolon> \<nat>[32]\<close> \<longmapsto> \<open>x - 1 \<tycolon> \<nat>[32]\<close>
  premises \<open>0 < x\<close>
  \<bullet> 1 -
  finish

thm sub1_\<nu>app
thm sub1_\<nu>compilation

term "if f_C then f_T else f_F"

term "(v1,(v2,(v3,void)))"

text \<open>The command `\<bullet>`  leads a construction statement, and the construction state by this statement is printed.
  You can insert command `\<bullet>` at any intermediate place to split it into two statements,
    to see what the construction state respectively is in those two parts.\<close>

section\<open>Fibonacci\<close>

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

(* int fib (int i) { if (i \<le> 1) return 1; else return fib (i-2) + fib (i-1); } *)
rec_proc Fib: \<open>i \<tycolon> \<nat>[32]\<close> \<longmapsto> \<open>fib i \<tycolon> \<nat>\<^sup>r[32]\<close> var i
    (* The (i \<tycolon> \<nat>\<^sup>r[32]) is the rounding abstraction which represents the integer \<open>i mod 2^32\<close>,
        so we do not need to consider the arithmetic overflow *)
  \<bullet> \<rightarrow> i
  \<bullet> i 1 \<le>
  \<bullet> if  \<medium_left_bracket> \<open>1\<tycolon> \<nat>\<^sup>r[32]\<close> \<medium_right_bracket> \<medium_left_bracket>
    \<bullet> i 2 - Fib \<rightarrow> f2
    \<bullet> i 1 - Fib \<rightarrow> f1
    \<bullet> f1 f2 +
    \<bullet> \<medium_right_bracket>
    \<bullet> goal affirm by (cases i rule: fib.cases) auto
  finish

thm Fib_\<nu>app \<comment> \<open>The specification theorem\<close>
thm Fib_\<nu>compilation \<comment> \<open>The definition of the procedure\<close>

proc Fib2: \<open>i \<tycolon> \<nat>[32]\<close> \<longmapsto> \<open>fib i \<tycolon> \<nat>\<^sup>r[32]\<close>
  \<bullet> \<rightarrow> i
  \<bullet> \<open>1\<tycolon> \<nat>\<^sup>r[32]\<close> 1
  \<bullet> i times y, y' \<open>\<lambda>i. y' = fib (Suc i) \<and> y = fib i\<close> \<medium_left_bracket> \<lambda>(y, y', i)
  \<bullet>   y' y y' +
  \<bullet> \<medium_right_bracket>
  \<bullet> drop
  finish

\<nu>interface my_fib = Fib \<comment> \<open>To export the procedure Fib to an LLVM function with name my_fib.\<close>
\<nu>interface my_fib2 = Fib2

thm Fib_\<nu>app \<comment> \<open>The specification theorem\<close>
thm Fib_\<nu>compilation \<comment> \<open>The definition of the procedure\<close>

section\<open>Binary Search\<close>

proc bin_search:
  argument \<open>ptr \<tycolon> Pointer \<heavy_asterisk> len \<tycolon> \<nat>[size_t] \<heavy_asterisk> x \<tycolon> \<nat>['b::len] \<heavy_asterisk> ptr \<R_arr_tail> xs \<tycolon> Array \<nat>['b]\<close>
  return \<open>?index \<tycolon> \<nat>[size_t] \<heavy_asterisk> ptr \<R_arr_tail> xs \<tycolon> Array \<nat>['b]\<close>
  where ?index = "find_index (\<lambda>y. x \<le> y) xs"
  premises "length xs = len" and "sorted xs"
  \<bullet> \<rightarrow> ptr, len, x
  \<bullet> len 0
  \<bullet>  while h, l always \<open>l \<le> ?index \<and> ?index \<le> h \<and> h \<le> len\<close>
      \<comment> \<open>the \<open>always\<close> clause indicates the invariant\<close>
  \<bullet> \<medium_left_bracket> \<lambda>'(h, l) l h < \<medium_right_bracket> \<comment> \<open>The loop condition\<close>
  \<bullet> \<medium_left_bracket> \<lambda>(h, l) h l - 2 / l + \<rightarrow> m ptr m \<up> x < if \<medium_left_bracket> h m 1 + \<medium_right_bracket> \<medium_left_bracket> m l \<medium_right_bracket> \<medium_right_bracket> \<comment> \<open>The loop body\<close>
    (* (h - l) / 2 + l \<rightarrow> m ;  if ( ptr[m] < x ) { h, m + 1 } { m, l }  *)
  \<bullet> drop
  finish
(* The command \<rightarrow> assigns and moves stack elements to local values,
  and the command \<open>--\<close> assigns and loads back those stack elements from local values,
  e.g. \<open>-- (x,y)\<close> is identical to \<open>\<rightarrow> (x,y) x y\<close>, and it loads x, y back after assigning them
  to local values. The command \<open>\<lambda>\<close> is a syntax equivalent of \<open>\<rightarrow>\<close>, and \<open>\<lambda>'\<close> is that of \<open>--\<close>*)

\<nu>interface bin_search = bin_search : \<open>32 word \<times> size_t word \<times> memptr\<close> \<longmapsto> \<open>size_t word\<close>

thm bin_search_\<nu>app \<comment> \<open>The specification theorem\<close>
thm bin_search_\<nu>compilation \<comment> \<open>The definition of the procedure\<close>

section\<open>Quick-sort\<close>

text \<open>The order of separation cells may be different with the paper, but they are equivalent.
  In this implementation, the stack together with the separation cell list is written from
  left to right, where the bottom of the stack is at the left-most and the top is at the right-most,
  and separation cells are left associative i.e. \<^term>\<open>(((C1 \<heavy_asterisk> C2) \<heavy_asterisk> C3) \<heavy_asterisk> C4)\<close>.
  It is because this nature follows the left-to-right order of English writing and most of math.
  Though the order of separations cells should not matter in logic, the VCG processes cells from
  right to left, from the out-most C4 to the inner-most C1.
  Stack elements are recommended to put at the right-most to let the VCG process those stack
  elements first and then heap objects, because stack element cells are easier to be processed because
  stack cells are ordered while heap cells are unordered, and the VCG does not need to permute
  stack cells to attempt different possible matching solutions when converting cells of caller to
  match cells of callee.
   \<close>

proc swap:
  argument \<open>ptr \<R_arr_tail> xs \<tycolon> Array \<nat>[32] \<heavy_asterisk> ptr \<tycolon> Pointer \<heavy_asterisk> i \<tycolon> \<nat>[size_t] \<heavy_asterisk> j \<tycolon> \<nat>[size_t]\<close>
  return \<open>ptr \<R_arr_tail> xs[i := xs ! j, j := xs ! i] \<tycolon> Array \<nat>[32]\<close>
  premises \<open>i < length xs\<close> and \<open>j < length xs\<close>
  \<bullet> \<rightarrow> ptr, i, j ptr i \<up>\<rightarrow> i' ptr j \<up> \<rightarrow> j' ptr i j' \<down> ptr j i' \<down>
  finish

abbreviation "permuted x y \<equiv> x <~~> y"

proc partition:
  argument \<open>ptr \<R_arr_tail> xs \<tycolon> Array \<nat>[32] \<heavy_asterisk> ptr \<tycolon> Pointer \<heavy_asterisk> n \<tycolon> \<nat>[size_t]\<close>
  return \<open>ptr \<R_arr_tail> ys \<tycolon> Array \<nat>[32] \<heavy_asterisk> j \<tycolon> \<nat>[size_t]
      \<^bold>s\<^bold>u\<^bold>b\<^bold>j j ys. j < length xs \<and> permuted ys xs \<and>
          (\<forall>k. k < j \<longrightarrow> ys ! k \<le> ys ! j) \<and> (\<forall>k. j < k \<and> k < n \<longrightarrow> ys ! j < ys ! k)\<close>
  premises \<open>length xs = n\<close> and \<open>0 < n\<close>
  note nth_list_update[simp] not_le[simp] perm_length[simp]

  \<bullet> -- ptr, n 1 - \<up> \<rightarrow> pivot
  \<bullet> \<open>0 \<tycolon> \<nat>[size_t]\<close> n 1 - times var j, ys in "ptr \<R_arr_tail> ys", j
  \<bullet> \<open>\<lambda>i. j \<le> i \<and> permuted ys xs \<and> (ys ! (n-1) = ?pivot) \<and>
    (\<forall>k. k < j \<longrightarrow> ys ! k \<le> ?pivot) \<and> (\<forall>k. j \<le> k \<and> k < i \<longrightarrow> ?pivot < ys ! k)\<close> \<medium_left_bracket> \<lambda>(j,i)
  \<bullet> ptr j \<up>\<rightarrow> j'  ptr i \<up> -- i' pivot \<le> if \<medium_left_bracket> ptr i j' \<down> ptr j i' \<down> j 1 + \<medium_right_bracket> \<medium_left_bracket> j \<medium_right_bracket>
  \<bullet> goal affirm using \<nu> by (auto simp add: less_Suc_eq intro!: perm_swap[THEN perm.trans])
  \<bullet> \<medium_right_bracket>
  have [useful]: "j < n" using \<nu> by linarith
  \<bullet> \<rightarrow> j ptr j n 1 - swap j
  \<bullet> goal affirm using \<nu> by (smt (z3) Suc_diff_1 Suc_leI diff_less leD length_list_update
        less_numeral_extra(1) less_or_eq_imp_le mset_eq_perm mset_swap nat_neq_iff nth_list_update_eq
         nth_list_update_neq perm_length)
    (*Albeit it is long, it is generated by sledgehammer fully-automatically!
    Actually `auto intro!: perm_swap[THEN perm.trans]` should has been enough to solve this,
    however I do not know why it is stuck at some simple condition.*)
  finish

rec_proc qsort:
  argument \<open>ptr \<R_arr_tail> xs \<tycolon> Array \<nat>[32] \<heavy_asterisk> ptr \<tycolon> Pointer \<heavy_asterisk> n \<tycolon> \<nat>[size_t]\<close>
  return \<open>ptr \<R_arr_tail> ys \<tycolon> Array \<nat>[32] \<^bold>s\<^bold>u\<^bold>b\<^bold>j ys. sorted ys \<and> permuted ys xs\<close>
  var ptr xs n
  premises "n = length xs"
  note perm_length[simp]

  \<bullet> -- ptr, n 0 = if \<medium_left_bracket> drop \<medium_right_bracket> \<medium_left_bracket> n partition \<rightarrow> j
  let ?pivot = "ys ! j" have a1[simp]: " hd (drop j ys) = ?pivot " using \<nu> by (metis hd_drop_conv_nth perm_length)

  \<bullet> ptr j split pop n 1 - j - qsort \<exists>high
      \<comment> \<open>the annotation '\<exists>high' indicates the name of  the existential quantified variable to be instantiated\<close>
  \<bullet> ptr j qsort \<exists>low
  \<bullet> push merge

  \<bullet> !! subj \<open>low @ ?pivot # high <~~> xs \<and> sorted (low @ ?pivot # high)\<close> affirm unfolding sorted_append using \<nu>
  by (auto simp add: perm_set_eq in_set_conv_nth nth_tl Suc_eq_plus1)
     (metis (no_types, hide_lams) \<nu>lemmata(1) a1 append_take_drop_id cons_perm_eq drop_all_iff dual_order.strict_trans1
      list.collapse not_less_iff_gr_or_eq perm.trans perm_append1 perm_append2 perm_length add.left_commute add1_le_eq le_add2 le_less_trans less_diff_conv less_or_eq_imp_le)+

  \<bullet> \<medium_right_bracket>
  finish

\<nu>interface my_qsort = qsort

section\<open>KMP\<close>

subsection\<open>An algebra for sub-string matching\<close>

definition "matches' a1 i1 a2 i2 n \<longleftrightarrow>
    i1 + n \<le> length a1 \<and> i2 + n \<le> length a2 \<and> (\<forall>i. i < n \<longrightarrow> a1 ! (i1 + i) = a2 ! (i2 + i)) "

definition "is_next p j n \<longleftrightarrow> n < j \<and> matches' p (j - n) p 0 n \<and> (\<forall> z. n < z \<and> z < j \<longrightarrow> \<not> (matches' p (j - z) p 0 z))"

definition "kmp_table n ktab xs \<longleftrightarrow> (\<forall>j. 0 < j \<and> j < n \<longrightarrow> is_next xs j (ktab ! j))"

lemma matches_empty[simp]:
  "i1 \<le> length a1 \<Longrightarrow> i2 \<le> length a2 \<Longrightarrow> matches' a1 i1 a2 i2 0"
 unfolding matches'_def by auto

lemma matches'_right_extension:
    "matches' a1 i1 a2 i2 n \<Longrightarrow> i1 + n + 1 \<le> length a1 \<Longrightarrow> i2 + n + 1 \<le> length a2 \<Longrightarrow>
    a1 ! (i1 + n) = a2 ! (i2 + n) \<Longrightarrow> matches' a1 i1 a2 i2 (n + 1)"
  unfolding matches'_def by (metis add.assoc add_le_imp_le_right discrete le_neq_implies_less)

lemma matches'_contradiction_at_first:
    "0 < n \<Longrightarrow> a1 ! i1 \<noteq> a2 ! i2 \<Longrightarrow> \<not> (matches' a1 i1 a2 i2 n)"
  using matches'_def by force

lemma matches_contradiction_at_i :
    "0 < n \<Longrightarrow> i < n \<Longrightarrow> a1 ! (i1 + i) \<noteq> a2 ! (i2 + i) \<Longrightarrow> \<not> matches' a1 i1 a2 i2 n"
  using matches'_def by blast

lemma matches_right_weakening:
    "matches' a1 i1 a2 i2 n \<Longrightarrow> n' < n \<Longrightarrow> matches' a1 i1 a2 i2 n'"
    unfolding matches'_def  by auto

lemma matches_left_weakening:
    "matches' a1 i1 a2 i2 (n + d) \<Longrightarrow> matches' a1 (i1 + d) a2 (i2 + d) n "
unfolding matches'_def by auto (metis add.commute add.left_commute nat_add_left_cancel_less)

lemma matches'_sym:
    "matches' a1 i1 a2 i2 n \<Longrightarrow> matches' a2 i2 a1 i1 n"
    unfolding matches'_def by simp

lemma matches_trans:
    "matches' a1 i1 a2 i2 n \<Longrightarrow> matches' a2 i2 a3 i3 n \<Longrightarrow> matches' a1 i1 a3 i3 n"
    unfolding matches'_def by simp

lemma next_iteration:
    "0 < j \<Longrightarrow> j < length p \<Longrightarrow>
    j \<le> i \<Longrightarrow> i \<le> length a \<Longrightarrow>
    matches' a (i - j) p 0 j \<Longrightarrow> is_next p j n \<Longrightarrow> matches' a (i - n) p 0 n"
  unfolding matches'_def is_next_def apply auto
  subgoal premises prems for ia proof -
    from prems have A: "j + ia - n < j" by linarith
    from prems A show ?thesis using Nat.add_diff_assoc2 Nat.diff_diff_right by fastforce
  qed done

lemma next_is_maximal:
    "0 < j \<Longrightarrow> j < length p \<Longrightarrow>
    j \<le> i \<Longrightarrow> i \<le> length a \<Longrightarrow>
    i - j < k \<and> k < i - n \<Longrightarrow>
    matches' a (i - j) p 0 j \<Longrightarrow>
    is_next p j n \<Longrightarrow> \<not> matches' a k p 0 (length p)"
    unfolding is_next_def matches'_def apply auto
    subgoal premises prems proof -
      from prems(9)[THEN spec, of "i - k"] prems show ?thesis
        by (smt (verit, ccfv_SIG) Nat.add_diff_assoc2 Nat.diff_diff_right add.commute add_diff_cancel_left' diff_le_self le_trans less_add_eq_less less_or_eq_imp_le less_trans ordered_cancel_comm_monoid_diff_class.diff_add)
    qed done

definition "first_substr p a r \<longleftrightarrow>
    (r < length a \<longrightarrow> matches' a r p 0 (length p)) \<and> (\<forall>k < r. \<not> (matches' a k p 0 (length p)))"

subsection\<open>Procedure Constructions\<close>

proc mk_kmp_table:
  argument \<open>px \<R_arr_tail> xs \<tycolon> Array \<nat>[8] \<heavy_asterisk> px \<tycolon> Pointer \<heavy_asterisk> nx \<tycolon> \<nat>[size_t]\<close>
  return \<open>px \<R_arr_tail> xs \<tycolon> Array \<nat>[8] \<heavy_asterisk> pk \<R_arr_tail> ktab \<tycolon> Array \<nat>[size_t] \<heavy_asterisk> pk \<tycolon> Pointer
      \<^bold>s\<^bold>u\<^bold>b\<^bold>j pk ktab. kmp_table nx ktab xs \<and> length ktab = nx \<close>
  premises \<open>1 \<le> nx\<close> and \<open>length xs = nx\<close>
  note  kmp_table_def[simp]

  \<bullet> \<rightarrow> px, nx
  \<bullet> nx alloc_array \<open>\<nat>[size_t]\<close> \<rightarrow> pk
  \<bullet> \<open>1 \<tycolon> \<nat>[size_t]\<close> nx < if \<medium_left_bracket>
  \<bullet> pk \<open>1\<tycolon>\<nat>[size_t]\<close> 0 \<down>
  note is_next_def [simp] nth_list_update[simp]
  \<bullet> \<open>1\<tycolon>\<nat>[size_t]\<close> 0 while var i j ktab in \<open>c \<R_arr_tail> ktab\<close>, i, j
    always \<open>j < i \<and> i < nx
    \<and> matches' xs (i - j) xs 0 j
    \<and> (\<forall>z. j < z \<and> z < i \<longrightarrow> \<not>matches' xs (i - z) xs 0 (z + 1))
    \<and> (\<forall>k. 0 < k \<and> k \<le> i \<longrightarrow> is_next xs k (ktab ! k))
    \<and> length ktab = nx\<close>
  note is_next_def [simp del] nth_list_update[simp del]
  \<bullet> \<medium_left_bracket> \<lambda>'(i, j) i nx 1 - < \<medium_right_bracket>
  \<bullet> \<medium_left_bracket> \<lambda>(i, j) px i \<up> px j \<up> = if
  \<bullet> \<medium_left_bracket> i 1 + j 1 + -- i, j pk i j \<down>\<medium_right_bracket>
  \<bullet> \<medium_left_bracket> j 0 = if \<medium_left_bracket> i 1 + -- i pk i 0 \<down>j \<medium_right_bracket> \<medium_left_bracket> i pk j \<up> \<medium_right_bracket> \<medium_right_bracket>

  have CC: "(\<forall>z. j + 1 < z \<and> z < i + 1 \<longrightarrow> \<not> matches' xs (i + 1 - z) xs 0 z)" using \<nu>
    by (metis leI le_add_diff_inverse2 less_diff_conv less_diff_conv2 less_nat_zero_code nat_diff_split_asm ordered_cancel_comm_monoid_diff_class.diff_diff_right)
  have A1: "i + 1 < nx" using \<nu> by auto
  have AA2: "\<And>k. k \<le> i + 1 \<longleftrightarrow> k \<le> i \<or> k = i + 1" by auto
  \<bullet> goal affirm
    apply (cases "xs ! i = xs ! j") using \<nu> apply auto[1]
    apply (smt (z3) Nat.le_diff_conv2 add_cancel_left_left le_add_diff_inverse2 less_imp_le less_trans matches'_right_extension \<nu>)
    apply (metis (full_types) Nat.diff_diff_right add_lessD1 le_add_diff_inverse2 less_add_one less_diff_conv less_diff_conv2 less_one matches_right_weakening not_less \<nu>)
    apply (smt (verit, ccfv_threshold) AA2 CC Nat.add_0_right Nat.diff_diff_right add.commute add_diff_cancel_right' dual_order.strict_iff_order is_next_def le_add_diff_inverse2 less_add_same_cancel2 less_diff_conv less_trans matches'_right_extension neq0_conv nth_list_update_eq nth_list_update_neq \<nu>)
  apply (cases "j = 0") using \<nu> apply auto[1]
  apply (metis CC One_nat_def Suc_leI add.commute add_diff_cancel_right' antisym_conv2 less_add_one matches'_contradiction_at_first matches_right_weakening plus_1_eq_Suc)
  subgoal for k apply (cases "k = i + 1")
    apply (smt (verit, ccfv_threshold) CC Suc_eq_plus1 Suc_leI add_diff_cancel_right' diff_diff_cancel diff_is_0_eq' is_next_def le_neq_implies_less le_trans less_imp_le matches'_contradiction_at_first matches_empty nth_list_update_eq zero_le_one)
    by (metis AA2 nth_list_update_neq)
 using \<nu> apply auto[1]
  apply (meson is_next_def less_imp_le less_le_trans \<nu>)
  apply (metis (no_types, lifting) \<nu> less_imp_le less_le_trans next_iteration)
  subgoal for z
    apply (cases "j < z") using \<nu>(1) apply blast apply (simp add: not_less)
    apply (cases "z = j") using \<nu> apply (metis le0 le_add_diff_inverse2 less_add_one less_imp_le matches'_def plus_nat.add_0)
    subgoal premises prems proof -
      from prems \<nu> have A: " is_next xs j (ktab ! j)" by (metis less_le less_nat_zero_code neq0_conv)
      from \<nu> prems have X1: "z + (j - z) = j" "i - j + (j - z) = i - z" apply (meson le_add_diff_inverse) by (simp add: order.strict_implies_order prems(13) prems(5))
      note X2 = matches_left_weakening[where n = z and d = \<open>j - z\<close>, simplified X1]
      thm matches_left_weakening[where n = z and d = \<open>j - z\<close>, simplified X1]
      from A[unfolded is_next_def] prems \<nu> show ?thesis
        by (metis (no_types, lifting) X1(2) X2 add.left_neutral le_neq_implies_less less_add_one matches'_sym matches_right_weakening matches_trans)
    qed done
  done
  \<bullet> \<medium_right_bracket> drop drop subj \<open>kmp_table nx ktab xs \<and> length ktab = nx\<close> \<medium_right_bracket>
  \<bullet> \<medium_left_bracket> \<medium_right_bracket>
  \<bullet> pk
  finish

proc kmp:
  argument \<open>px \<R_arr_tail> xs \<tycolon> Array \<nat>[8] \<heavy_asterisk> py \<R_arr_tail> ys \<tycolon> Array \<nat>[8] \<heavy_asterisk>
    px \<tycolon> Pointer \<heavy_asterisk> py \<tycolon> Pointer \<heavy_asterisk> nx \<tycolon> \<nat>[size_t] \<heavy_asterisk> ny \<tycolon> \<nat>[size_t]\<close>
  return \<open> i \<tycolon> \<nat>[size_t] \<heavy_asterisk> px \<R_arr_tail> xs \<tycolon> Array \<nat>[8] \<heavy_asterisk> py \<R_arr_tail> ys \<tycolon> Array \<nat>[8]
    \<^bold>s\<^bold>u\<^bold>b\<^bold>j i. first_substr xs ys i\<close>
  premises \<open>length xs = nx\<close> and \<open>length ys = ny\<close> and "1 \<le> nx"

  \<bullet> \<rightarrow> px,py,nx,ny
  \<bullet> px nx mk_kmp_table \<rightarrow> pk
  \<bullet> \<open>0 \<tycolon> \<nat>[size_t]\<close>0 while var i j in i, j
    always \<open> j \<le> nx \<and> j \<le> i \<and> i \<le> ny
      \<and> matches' ys (i - j) xs 0 j
      \<and> (\<forall>k < i - j.  \<not> (matches' ys k xs 0 nx))\<close>
  \<bullet> \<medium_left_bracket> \<lambda>'(i, j) i ny < j nx < \<and> \<medium_right_bracket>
  \<bullet> \<medium_left_bracket> \<lambda>(i, j) py i \<up> px j \<up> = if
  \<bullet> \<medium_left_bracket> i 1 + j 1 + \<medium_right_bracket>
  \<bullet> \<medium_left_bracket> j 0 = if \<medium_left_bracket> i 1 + j \<medium_right_bracket> \<medium_left_bracket> i pk j \<up>\<medium_right_bracket> \<medium_right_bracket>
  \<bullet> goal affirm using \<nu> apply auto
  apply (metis One_nat_def Suc_eq_plus1 \<nu>lemmata \<open>i < ny \<and> j < nx\<close> add.right_neutral diff_zero discrete matches'_right_extension)
  apply (metis Suc_eq_plus1 \<open>i < ny \<and> j < nx\<close> less_Suc_eq matches'_contradiction_at_first)
  apply (metis add.commute add.right_neutral discrete le_add_diff_inverse2 matches'_right_extension \<nu>)
  apply (simp add: is_next_def kmp_table_def matches'_def)
  apply (meson dual_order.trans is_next_def kmp_table_def le_less \<nu>)
  apply (metis kmp_table_def next_iteration \<nu>)
  by (smt (verit, ccfv_threshold) \<nu> add.commute add.left_neutral diff_add_inverse kmp_table_def le0 le_Suc_ex linorder_neqE_nat matches'_def next_is_maximal)
  \<bullet> \<medium_right_bracket>
  \<bullet> nx = if \<medium_left_bracket> nx - \<medium_right_bracket> \<medium_left_bracket> \<medium_right_bracket>
  \<bullet> drop_array
  \<bullet> goal affirm unfolding first_substr_def using \<nu> apply auto
  by (metis add_mono_thms_linordered_field(2) antisym_conv1 dual_order.strict_trans1 less_diff_conv matches'_def)
  finish

\<nu>interface kmp = kmp

section \<open>Link List\<close>

subsection \<open>Link List Library\<close>

text \<open>Though still need a lot of proof engineering optimization,
  recursive \<nu>-type like linked list is indeed supported.\<close>

definition Separation' :: " heap set \<Rightarrow> heap set \<Rightarrow> heap set" (infixr "\<^emph>''" 70)
  where "A \<^emph>' B = {h. (\<exists>h2 h1. h = h2 ++ h1 \<and> dom h2 \<perpendicular> dom h1 \<and> h1 \<in> A \<and> h2 \<in> B)}"

function LinkLst :: " ('a::field,'b) \<nu> \<Rightarrow> (heap, (nat memaddr \<times> nat memaddr) \<R_arr_tail> 'b list) \<nu> "
  where "LinkLst T ((a1,a2) \<R_arr_tail> []) = (if a1 = a2 then {Map.empty} else {})"
    | "LinkLst T ((a1,a2) \<R_arr_tail> x#ls) = (\<exists>*a3. Ref \<lbrace> Pointer \<cross_product> T \<rbrace> (a1 \<R_arr_tail> (a3,x)) \<^emph>' LinkLst T ((a3,a2) \<R_arr_tail> ls))"
  apply (metis map_tailrec_rev.elims object.exhaust old.prod.exhaust)
  apply simp
  apply fastforce
  by fastforce
termination
  by (relation "measure (\<lambda>x. case x of (T, a2 \<R_arr_tail> ls) \<Rightarrow> length ls)") auto

lemma LinkLst_alt:
    "\<tort_lbrace> (as,at) \<R_arr_tail> [] \<tycolon> LinkLst T\<tort_rbrace> = (if as = at then {Map.empty} else {})"
    "\<tort_lbrace> (as,at) \<R_arr_tail> x#ls \<tycolon> LinkLst T\<tort_rbrace> = (\<exists>* a2. (as \<R_arr_tail> (a2,x), (a2,at) \<R_arr_tail> ls) \<tycolon> Ref \<lbrace> Pointer \<cross_product> T \<rbrace> \<^emph> LinkLst T)"
  unfolding RepSet_def by (simp_all add: HeapSeparation_def Separation'_def Ref_def Refining_def)

declare LinkLst.simps[simp del]

text \<open>Then we prove casts between refinement levels. The proofs are almost automatic.\<close>

lemma open_linklst_\<nu>app:
  "\<^bold>c\<^bold>a\<^bold>s\<^bold>t OBJ (as,at) \<R_arr_tail> x#ls \<tycolon> LinkLst T \<longmapsto> (\<exists>* a2. as \<R_arr_tail> (a2,x) \<tycolon> Ref \<lbrace> Pointer \<cross_product> T \<rbrace> \<heavy_asterisk> (a2,at) \<R_arr_tail> ls \<tycolon> LinkLst T)"
  unfolding Cast_def LinkLst_alt SepNu_to_SepSet by (auto simp add: nu_exps)

lemma open_linklst'_\<nu>app:
  "\<^bold>p\<^bold>r\<^bold>e\<^bold>m\<^bold>i\<^bold>s\<^bold>e ls \<noteq> [] \<Longrightarrow>
  \<^bold>c\<^bold>a\<^bold>s\<^bold>t OBJ (as,at) \<R_arr_tail> ls \<tycolon> LinkLst T \<longmapsto> (as \<R_arr_tail> (a2,x) \<tycolon> Ref \<lbrace> Pointer \<cross_product> T \<rbrace> \<heavy_asterisk> (a2,at) \<R_arr_tail> ls' \<tycolon> LinkLst T \<^bold>s\<^bold>u\<^bold>b\<^bold>j a2 x ls'. ls = x # ls')"
  unfolding Cast_def SepNu_to_SepSet by (cases ls) (auto simp add: nu_exps LinkLst_alt)

lemma close_linklst_\<nu>app:
  "\<^bold>c\<^bold>a\<^bold>s\<^bold>t a \<R_arr_tail> (a2,x) \<tycolon> Ref \<lbrace> Pointer \<cross_product> T \<rbrace> \<heavy_asterisk> (a2,at) \<R_arr_tail> ls \<tycolon> LinkLst T \<longmapsto> OBJ (a,at) \<R_arr_tail> x#ls \<tycolon> LinkLst T"
  unfolding Cast_def LinkLst_alt SepNu_to_SepSet by (auto simp add: nu_exps) blast

lemma empty_linklst_\<nu>app:
  "\<^bold>p\<^bold>a\<^bold>r\<^bold>a\<^bold>m a \<Longrightarrow> \<^bold>c\<^bold>a\<^bold>s\<^bold>t R \<longmapsto> R \<heavy_asterisk> (a,a) \<R_arr_tail> [] \<tycolon> LinkLst T"
  unfolding Cast_def LinkLst_alt SepNu_to_SepSet by (auto simp add: nu_exps)

text \<open>By using casts proved above, operations of linked list are verified almost automatically.\<close>

rec_proc get_linklst_at_i[\<nu>overload \<up>]:
  argument \<open>(a,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> a \<tycolon> Pointer \<heavy_asterisk> i \<tycolon> \<nat>[size_t]\<close>
  return \<open>(a,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> l!i \<tycolon> T\<close>
  var i a l
  premises \<open>i < length l\<close>
  \<bullet> \<rightarrow> ptr, i
  \<bullet> open_linklst'
  \<bullet> i 0 = if \<medium_left_bracket> ptr \<up>: 2 \<medium_right_bracket> \<medium_left_bracket> ptr \<up>: 1 i 1 - get_linklst_at_i \<medium_right_bracket> \<rightarrow> ret
  \<bullet> close_linklst ret
  finish

rec_proc updt_linklst_at[\<nu>overload \<down>]:
  argument \<open>(a,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> a \<tycolon> Pointer \<heavy_asterisk> i \<tycolon> \<nat>[size_t] \<heavy_asterisk> x \<tycolon> T\<close>
  return \<open>(a,at) \<R_arr_tail> l[i:=x] \<tycolon> LinkLst T\<close>
  var i a l
  premises \<open>i < length l\<close>
  \<bullet> \<rightarrow> ptr, i, x
  \<bullet> open_linklst'
  \<bullet> i 0 = if \<medium_left_bracket> ptr x \<down>:  2 \<medium_right_bracket> \<medium_left_bracket> ptr \<up>: 1 i 1 - x updt_linklst_at \<medium_right_bracket>
  \<bullet> close_linklst
    goal affirm using \<nu> by (smt (z3) Suc_diff_1 list_update_code(2) list_update_code(3) neq0_conv)
  finish

proc pop_linklst[\<nu>overload pop]:
  argument \<open>(a,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> a \<tycolon> Pointer\<close>
  return \<open>\<exists>*a2. (a2,at) \<R_arr_tail> tl l \<tycolon> LinkLst T \<heavy_asterisk> a \<R_arr_tail> (a2, hd l) \<tycolon> Ref \<lbrace> Pointer \<cross_product> T \<rbrace> \<heavy_asterisk> a2 \<tycolon> Pointer \<close>
  premises \<open>l \<noteq> []\<close>
  \<bullet> \<rightarrow> ptr open_linklst' ptr \<up>: 1
  finish

lemma push_linklst_\<nu>app[\<nu>overload push]:
  "\<^bold>c\<^bold>a\<^bold>s\<^bold>t (a2,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> a \<R_arr_tail> (a2, x) \<tycolon> Ref \<lbrace> Pointer \<cross_product> T \<rbrace> \<longmapsto> ELE (a,at) \<R_arr_tail> x#l \<tycolon> LinkLst T"
  unfolding LinkLst_alt(2) Cast_def
  by (auto simp add: nu_exps) (meson disjoint_def disjoint_rewR map_add_comm)

proc prepend_linklst:
  argument \<open>(a,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> a \<tycolon> Pointer \<heavy_asterisk> x \<tycolon> T\<close>
  return \<open>\<exists>*a2. (a2,at) \<R_arr_tail> x#l \<tycolon> LinkLst T \<heavy_asterisk> a2 \<tycolon> Pointer \<close>
  for T :: "('a::{field,zero},'b) \<nu>"
  requires [\<nu>reason on \<open>\<nu>Zero T ?t0\<close>]: \<open>\<nu>Zero T t0\<close>
  \<bullet> \<rightarrow> ptr, x
  \<bullet> alloc \<open>\<lbrace> Pointer \<cross_product> T \<rbrace>\<close> \<rightarrow> p2
  \<bullet> p2 ptr \<down>: 1
  \<bullet> p2 x \<down>: 2
  \<bullet> close_linklst
  \<bullet> p2
  finish

rec_proc split_linklst_at[\<nu>overload split]:
  argument \<open>(a,at) \<R_arr_tail> l \<tycolon> LinkLst T \<heavy_asterisk> a \<tycolon> Pointer \<heavy_asterisk> n \<tycolon> \<nat>[size_t]\<close>
  return \<open>\<exists>*a2. (a2,at) \<R_arr_tail> drop n l \<tycolon> LinkLst T \<heavy_asterisk> (a,a2) \<R_arr_tail> take n l \<tycolon> LinkLst T \<heavy_asterisk> a2 \<tycolon> Pointer\<close>
  var a l n
  premises \<open>n \<le> length l\<close>
  \<bullet> \<rightarrow> ptr, n
  obtain y l' where [simp]: "n \<noteq>0 \<Longrightarrow> l = y#l'" using \<nu> by (cases l) auto
  \<bullet> n 0 = if \<medium_left_bracket> empty_linklst a ptr
      as' \<open>\<^bold>(\<exists>* a2. (a2,at) \<R_arr_tail> drop n l \<tycolon> LinkLst T \<heavy_asterisk> (a,a2) \<R_arr_tail> take n l \<tycolon> LinkLst T \<heavy_asterisk> a2 \<tycolon> Pointer \<^bold>)\<close> \<medium_right_bracket>
  \<bullet> \<medium_left_bracket> open_linklst ptr \<up>: 1 n 1 - split_linklst_at close_linklst \<medium_right_bracket>
  note drop_Cons'[simp] take_Cons'[simp]
  finish

lemma merge_linklst[\<nu>overload merge]:
  "\<^bold>c\<^bold>a\<^bold>s\<^bold>t (a2,at) \<R_arr_tail> l2 \<tycolon> LinkLst T \<heavy_asterisk> (a,a2) \<R_arr_tail> l1 \<tycolon> LinkLst T \<longmapsto> ELE (a,at) \<R_arr_tail> l1@l2 \<tycolon> LinkLst T"
  by (induct l1 arbitrary: a, auto simp add: nu_exps Cast_def LinkLst_alt pair_forall)
    (smt (z3) Un_iff disjoint_def disjoint_rewL dom_map_add map_add_assoc map_add_comm)

subsection \<open>Demos using linked list\<close>

text \<open>Note the code body of the bin_search is not modified at all, because
  we overload linked list operation and plain array operation on the same symbol.
  Only the \<nu>-type in the specification is changed.\<close>

proc bin_search':
  argument \<open>ptr \<tycolon> Pointer \<heavy_asterisk> len \<tycolon> \<nat>[size_t] \<heavy_asterisk> x \<tycolon> \<nat>['b::len] \<heavy_asterisk> (ptr,pt) \<R_arr_tail> xs \<tycolon> LinkLst \<nat>['b]\<close>
  return \<open>?index \<tycolon> \<nat>[size_t] \<heavy_asterisk> (ptr,pt) \<R_arr_tail> xs \<tycolon> LinkLst \<nat>['b]\<close>
  where ?index = "find_index (\<lambda>y. x \<le> y) xs"
  premises "length xs = len" and "sorted xs"
  \<bullet> \<rightarrow> ptr, len, x
  \<bullet> len 0
  \<bullet>  while h, l always \<open>l \<le> ?index \<and> ?index \<le> h \<and> h \<le> len\<close>
      \<comment> \<open>the \<open>always\<close> clause indicates the invariant\<close>
  \<bullet> \<medium_left_bracket> \<lambda>'(h, l) l h < \<medium_right_bracket> \<comment> \<open>The loop condition\<close>
  \<bullet> \<medium_left_bracket> \<lambda>(h, l) h l - 2 / l + \<rightarrow> m ptr m \<up>  x < if \<medium_left_bracket> h m 1 + \<medium_right_bracket> \<medium_left_bracket> m l \<medium_right_bracket> \<medium_right_bracket> \<comment> \<open>The loop body\<close>
    (* (h - l) / 2 + l \<rightarrow> m ;  if ( ptr[m] < x ) { h, m + 1 } { m, l }  *)
  \<bullet> drop
  finish

\<nu>interface bin_search2 = bin_search' : \<open>32 word \<times> size_t word \<times> memptr\<close> \<longmapsto> \<open>size_t word\<close>

proc swap':
  argument \<open>(ptr, pt) \<R_arr_tail> xs \<tycolon> LinkLst \<nat>[32] \<heavy_asterisk> ptr \<tycolon> Pointer \<heavy_asterisk> i \<tycolon> \<nat>[size_t] \<heavy_asterisk> j \<tycolon> \<nat>[size_t]\<close>
  return \<open>(ptr, pt) \<R_arr_tail> xs[i := xs ! j, j := xs ! i] \<tycolon> LinkLst \<nat>[32]\<close>
  premises \<open>i < length xs\<close> and \<open>j < length xs\<close>
  \<bullet> \<rightarrow> ptr, i, j ptr i \<up>\<rightarrow> i' ptr j \<up> \<rightarrow> j' ptr i j' \<down> ptr j i' \<down>
  finish

proc partition':
  argument \<open>(ptr, pt) \<R_arr_tail> xs \<tycolon> LinkLst \<nat>[32] \<heavy_asterisk> ptr \<tycolon> Pointer \<heavy_asterisk> n \<tycolon> \<nat>[size_t]\<close>
  return \<open>(ptr, pt) \<R_arr_tail> ys \<tycolon> LinkLst \<nat>[32] \<heavy_asterisk> j \<tycolon> \<nat>[size_t]
      \<^bold>s\<^bold>u\<^bold>b\<^bold>j j ys. j < length xs \<and> permuted ys xs \<and>
          (\<forall>k. k < j \<longrightarrow> ys ! k \<le> ys ! j) \<and> (\<forall>k. j < k \<and> k < n \<longrightarrow> ys ! j < ys ! k)\<close>
  premises \<open>length xs = n\<close> and \<open>0 < n\<close>
  note nth_list_update[simp] not_le[simp] perm_length[simp]

  \<bullet> -- ptr, n 1 - \<up> \<rightarrow> pivot
  \<bullet> \<open>0 \<tycolon> \<nat>[size_t]\<close> n 1 - times var j, ys in "(ptr,pt) \<R_arr_tail> ys", j
  \<bullet> \<open>\<lambda>i. j \<le> i \<and> permuted ys xs \<and> (ys ! (n-1) = ?pivot) \<and>
    (\<forall>k. k < j \<longrightarrow> ys ! k \<le> ?pivot) \<and> (\<forall>k. j \<le> k \<and> k < i \<longrightarrow> ?pivot < ys ! k)\<close> \<medium_left_bracket> \<lambda>(j,i)
  \<bullet> ptr j \<up>\<rightarrow> j'  ptr i \<up> -- i' pivot \<le> if \<medium_left_bracket> ptr i j' \<down> ptr j i' \<down> j 1 + \<medium_right_bracket> \<medium_left_bracket> j \<medium_right_bracket>
  \<bullet> goal affirm using \<nu> by (auto simp add: less_Suc_eq intro!: perm_swap[THEN perm.trans])
  \<bullet> \<medium_right_bracket>
  have [useful]: "j < n" using \<nu> by linarith
  \<bullet> \<rightarrow> j ptr j n 1 - swap' j
  \<bullet> goal affirm using \<nu> by (smt (z3) Suc_diff_1 Suc_leI diff_less leD length_list_update
        less_numeral_extra(1) less_or_eq_imp_le mset_eq_perm mset_swap nat_neq_iff nth_list_update_eq
         nth_list_update_neq perm_length)
    (*Albeit it is long, it is generated by sledgehammer fully-automatically!
    Actually `auto intro!: perm_swap[THEN perm.trans]` should has been enough to solve this,
    however I do not know why it is stuck at some simple condition.*)
  finish

rec_proc qsort':
  argument \<open>(ptr,pt) \<R_arr_tail> xs \<tycolon> LinkLst \<nat>[32] \<heavy_asterisk> ptr \<tycolon> Pointer \<heavy_asterisk> n \<tycolon> \<nat>[size_t]\<close>
  return \<open>(ptr,pt) \<R_arr_tail> ys \<tycolon> LinkLst \<nat>[32] \<^bold>s\<^bold>u\<^bold>b\<^bold>j ys. sorted ys \<and> permuted ys xs\<close>
  var ptr pt xs n
  premises "n = length xs"
  note perm_length[simp]

  \<bullet> -- ptr, n 0 = if \<medium_left_bracket> drop \<medium_right_bracket> \<medium_left_bracket> n partition' \<rightarrow> j
  let ?pivot = "ys ! j" have a1[simp]: " hd (drop j ys) = ?pivot " using \<nu> by (metis hd_drop_conv_nth perm_length)

  \<bullet> ptr j split pop_linklst n 1 - j - qsort' \<exists>high
      \<comment> \<open>the annotation '\<exists>high' indicates the name of  the existential quantified variable to be instantiated\<close>
  \<bullet> ptr j qsort' \<exists>low
  \<bullet> push_linklst
  \<bullet> merge_linklst

  \<bullet> !! subj \<open>low @ ?pivot # high <~~> xs \<and> sorted (low @ ?pivot # high)\<close> affirm unfolding sorted_append using \<nu>
  by (auto simp add: perm_set_eq in_set_conv_nth nth_tl Suc_eq_plus1)
     (metis (no_types, hide_lams) \<nu>lemmata(1) a1 append_take_drop_id cons_perm_eq drop_all_iff dual_order.strict_trans1
      list.collapse not_less_iff_gr_or_eq perm.trans perm_append1 perm_append2 perm_length add.left_commute add1_le_eq le_add2 le_less_trans less_diff_conv less_or_eq_imp_le)+

  \<bullet> \<medium_right_bracket>
  finish

\<nu>interface my_qsort2 = qsort'

section\<open>Ending\<close>

text \<open>In the end, we output the desired LLVM IR. It is generated at \<open>./Example.ll\<close>\<close>

\<nu>export_llvm

end