\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
\<^marker>\<open>creator "Larry Paulson"\<close>
section \<open>Restricted Comprehension\<close>
theory Comprehension
  imports
    Finite_Sets
    Order_Set
begin

definition collect :: \<open>set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> set\<close>
  where "collect A P \<equiv> \<Union>{if P x then {x} else {} | x \<in> A}"

bundle hotg_collect_syntax
begin
syntax "_collect" :: \<open>idt \<Rightarrow> set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> set\<close> ("(1{_ \<in> _ |/ _})")
end
bundle no_hotg_collect_syntax
begin
no_syntax "_collect" :: \<open>idt \<Rightarrow> set \<Rightarrow> (set \<Rightarrow> bool) \<Rightarrow> set\<close> ("(1{_ \<in> _ |/ _})")
end
unbundle hotg_collect_syntax

translations
  "{x \<in> A | P}" \<rightleftharpoons> "CONST collect A (\<lambda>x. P)"

(*TOOD: simp_proc to apply one point rules (see Provers/quantifier1.ML)*)

lemma mem_collect_iff [iff]: "x \<in> {y \<in> A | P y} \<longleftrightarrow> x \<in> A \<and> P x"
  by (auto simp: collect_def)

lemma mem_collectI [intro]: "\<lbrakk>x \<in> A; P x\<rbrakk> \<Longrightarrow> x \<in> {y \<in> A | P y}" by auto

lemma mem_collectD: "x \<in> {y \<in> A | P y} \<Longrightarrow> x \<in> A" by auto

lemma mem_collectD': "x \<in> {y \<in> A | P y} \<Longrightarrow> P x" by auto

lemma collect_subset: "{x \<in> A | P x} \<subseteq> A" by blast

lemma collect_cong [cong]:
  "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> P x = Q x) \<Longrightarrow> {x \<in> A | P x} = {x \<in> B | Q x}"
  unfolding collect_def by simp

lemma collect_collect_eq [simp]: "collect (collect A P) Q = {x \<in> A | P x \<and> Q x}"
  by auto

lemma collect_insert_eq:
  "{x \<in> insert a B | P x} = (if P a then insert a {x \<in> B | P x} else {x \<in> B | P x})"
  by auto

lemma mono_collect_set: "mono (\<lambda>A. {x \<in> A | P x})"
  by (intro monoI) auto

lemma mono_collect_pred: "mono (\<lambda>P. {x \<in> A | P x})"
  by (intro monoI) auto

end


theory Round_User
imports Round_Specification Round_Declaration

begin

lemma uint_word_of_int_id:
  assumes "0 <= (x::int)"
  assumes "x <= 4294967295"
  shows"uint(word_of_int x::word32) = x"
  unfolding int_word_uint
  using assms
  by (simp add:int_mod_eq')

lemma steps_step: "steps X cc (Suc i) = step_both X (steps X cc i) i"
  unfolding steps_def
  by (induct i) simp_all

lemma from_to_id: "from_chain_pair (to_chain_pair CC) = CC"
proof (cases CC)
  fix a::chain
  fix b c d e f::word32
  assume "CC = (a, b, c, d, e, f)"
  thus ?thesis by (cases a) simp
qed

lemma steps_to_steps':
  "F A (steps X cc i) B =
   F A (from_chain_pair (to_chain_pair (steps X cc i))) B"
  unfolding from_to_id ..

lemma steps'_step:
  assumes "0 <= i"
  shows
  "steps' cc (i + 1) X = to_chain_pair (
     step_both
       (\<lambda>n. word_of_int (X (int n)))
       (from_chain_pair (steps' cc i X))
       (nat i))"
proof -
  have "nat (i + 1) = Suc (nat i)" using assms by simp
  show ?thesis
    unfolding `nat (i + 1) = Suc (nat i)` steps_step steps_to_steps'
    ..
qed

lemma step_from_hyp:
  fixes a b c d e
  fixes a' b' c' d' e'
  fixes a_0 b_0 c_0 d_0 e_0
  fixes x
  fixes j
  assumes
  step_hyp:
  "chain_pair___default_rcd''
     \<lparr>left'chain_pair := chain___default_rcd''
        \<lparr>h0'chain := a, h1'chain := b, h2'chain := c, h3'chain := d,
         h4'chain := e\<rparr>,
      right'chain_pair := chain___default_rcd''
        \<lparr>h0'chain := a', h1'chain := b', h2'chain := c', h3'chain := d',
         h4'chain := e'\<rparr>\<rparr> =
   steps'
     (chain_pair___default_rcd''
        \<lparr>left'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := a_0, h1'chain := b_0, h2'chain := c_0,
            h3'chain := d_0, h4'chain := e_0\<rparr>,
         right'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := a_0, h1'chain := b_0, h2'chain := c_0,
            h3'chain := d_0, h4'chain := e_0\<rparr>\<rparr>)
     j x"
  assumes a_borders:  "0 <= a " "a <= 4294967295" (is "_ <= ?M")
  assumes b_borders:  "0 <= b " "b  <= ?M"
  assumes c_borders:  "0 <= c " "c  <= ?M"
  assumes d_borders:  "0 <= d " "d  <= ?M"
  assumes e_borders:  "0 <= e " "e  <= ?M"
  assumes a'_borders: "0 <= a'" "a' <= ?M"
  assumes b'_borders: "0 <= b'" "b' <= ?M"
  assumes c'_borders: "0 <= c'" "c' <= ?M"
  assumes d'_borders: "0 <= d'" "d' <= ?M"
  assumes e'_borders: "0 <= e'" "e' <= ?M"
  assumes x_borders: "0 <= x (r_l' j)" "x (r_l' j) <= ?M"
                     "0 <= x (r_r' j)" "x (r_r' j) <= ?M"
  assumes j_borders: "0 <= j" "j <= 79"
  shows
  "chain_pair___default_rcd''
    \<lparr>left'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := e,
          h1'chain :=
            (wordops__rotate_left' (s_l' j)
              ((((a + f' j b c d) mod 4294967296 +
                 x (r_l' j)) mod
                4294967296 +
                k_l' j) mod
               4294967296) +
             e) mod
            4294967296,
          h2'chain := b, h3'chain := wordops__rotate_left' 10 c,
          h4'chain := d\<rparr>,
       right'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := e',
            h1'chain :=
              (wordops__rotate_left' (s_r' j)
                ((((a' + f' (79 - j) b' c' d') mod
                   4294967296 +
                   x (r_r' j)) mod
                  4294967296 +
                  k_r' j) mod
                 4294967296) +
               e') mod
              4294967296,
            h2'chain := b', h3'chain := wordops__rotate_left' 10 c',
            h4'chain := d'\<rparr>\<rparr> =
    steps'
     (chain_pair___default_rcd''
      \<lparr>left'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := a_0, h1'chain := b_0, h2'chain := c_0,
            h3'chain := d_0, h4'chain := e_0\<rparr>,
         right'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := a_0, h1'chain := b_0, h2'chain := c_0,
              h3'chain := d_0, h4'chain := e_0\<rparr>\<rparr>)
     (j + 1) x"
proof -
  let ?MM = 4294967296
  have AL: "uint(word_of_int e::word32) = e"
    by (rule uint_word_of_int_id[OF `0 <= e` `e <= ?M`])
  have CL: "uint(word_of_int b::word32) = b"
    by (rule uint_word_of_int_id[OF `0 <= b` `b <= ?M`])
  have DL: "True" ..
  have EL: "uint(word_of_int d::word32) = d"
    by (rule uint_word_of_int_id[OF `0 <= d` `d <= ?M`])
  have AR: "uint(word_of_int e'::word32) = e'"
    by (rule uint_word_of_int_id[OF `0 <= e'` `e' <= ?M`])
  have CR: "uint(word_of_int b'::word32) = b'"
    by (rule uint_word_of_int_id[OF `0 <= b'` `b' <= ?M`])
  have DR: "True" ..
  have ER: "uint(word_of_int d'::word32) = d'"
    by (rule uint_word_of_int_id[OF `0 <= d'` `d' <= ?M`])
  have BL: "(uint
      (word_rotl (s (nat j))
        ((word_of_int::int\<Rightarrow>word32)
          ((((a + f' j b c d) mod 4294967296 +
             x (r_l' j)) mod
            4294967296 +
            k_l' j) mod
           4294967296))) +
     e) mod
    4294967296 =
    uint
     (word_rotl (s (nat j))
       (word_of_int a +
        f (nat j) (word_of_int b) (word_of_int c) (word_of_int d) +
        word_of_int (x (r_l' j)) +
        K (nat j)) +
      word_of_int e)"
    (is "(uint (word_rotl _ (_ ((((_ + ?F) mod _ + ?X) mod _ + _) mod _))) + _)
          mod _ = _")
  proof -
    have "a mod ?MM = a" using `0 <= a` `a <= ?M`
      by (simp add: int_mod_eq')
    have "?X mod ?MM = ?X" using `0 <= ?X` `?X <= ?M`
      by (simp add: int_mod_eq')
    have "e mod ?MM = e" using `0 <= e` `e <= ?M`
      by (simp add: int_mod_eq')
    have "(?MM::int) = 2 ^ len_of TYPE(32)" by simp
    show ?thesis
      unfolding
        word_add_def
        uint_word_of_int_id[OF `0 <= a` `a <= ?M`]
        uint_word_of_int_id[OF `0 <= ?X` `?X <= ?M`]
        int_word_uint
      unfolding `?MM = 2 ^ len_of TYPE(32)`
      unfolding word_uint.Abs_norm
      by (simp add:
        `a mod ?MM = a`
        `e mod ?MM = e`
        `?X mod ?MM = ?X`)
  qed

  have BR: "(uint
      (word_rotl (s' (nat j))
        ((word_of_int::int\<Rightarrow>word32)
          ((((a' + f' (79 - j) b' c' d') mod
             4294967296 +
             x (r_r' j)) mod
            4294967296 +
            k_r' j) mod
           4294967296))) +
     e') mod
    4294967296 =
    uint
     (word_rotl (s' (nat j))
       (word_of_int a' +
        f (79 - nat j) (word_of_int b') (word_of_int c') (word_of_int d') +
        word_of_int (x (r_r' j)) +
        K' (nat j)) +
      word_of_int e')"
    (is "(uint (word_rotl _ (_ ((((_ + ?F) mod _ + ?X) mod _ + _) mod _))) + _)
          mod _ = _")
  proof -
    have "a' mod ?MM = a'" using `0 <= a'` `a' <= ?M`
      by (simp add: int_mod_eq')
    have "?X mod ?MM = ?X" using `0 <= ?X` `?X <= ?M`
      by (simp add: int_mod_eq')
    have "e' mod ?MM = e'" using `0 <= e'` `e' <= ?M`
      by (simp add: int_mod_eq')
    have "(?MM::int) = 2 ^ len_of TYPE(32)" by simp
    have nat_transfer: "79 - nat j = nat (79 - j)"
      using nat_diff_distrib `0 <= j`  `j <= 79`
      by simp
    show ?thesis
      unfolding
        word_add_def
        uint_word_of_int_id[OF `0 <= a'` `a' <= ?M`]
        uint_word_of_int_id[OF `0 <= ?X` `?X <= ?M`]
        int_word_uint
        nat_transfer
      unfolding `?MM = 2 ^ len_of TYPE(32)`
      unfolding word_uint.Abs_norm
      by (simp add:
        `a' mod ?MM = a'`
        `e' mod ?MM = e'`
        `?X mod ?MM = ?X`)
  qed

  show ?thesis
    unfolding steps'_step[OF `0 <= j`] step_hyp[symmetric]
      step_both_def step_r_def step_l_def
    by (simp add: AL BL CL DL EL AR BR CR DR ER)
qed

abbreviation
  "f_0_result == (((ca'' + f_spark' 0 cb'' cc'' cd'') mod 4294967296 +
        x'' (r_l_spark' 0)) mod 4294967296 + k_l_spark' 0) mod 4294967296"
abbreviation
  "f_79_result == (((ca'' + f_spark' 79 cb'' cc'' cd'') mod 4294967296 +
        x'' (r_r_spark' 0)) mod 4294967296 + k_r_spark' 0) mod 4294967296"

lemma goal61'1:
  assumes ca_borders: "0 <= ca''" "ca'' <= 4294967295" (is "_ <= ?M")
  assumes cb_borders: "0 <= cb''" "cb'' <= ?M"
  assumes cc_borders: "0 <= cc''" "cc'' <= ?M"
  assumes cd_borders: "0 <= cd''" "cd'' <= ?M"
  assumes ce_borders: "0 <= ce''" "ce'' <= ?M"
  assumes r_l_0_borders: "0 <= r_l_spark' 0" "r_l_spark' 0 <= 15"
  assumes r_r_0_borders: "0 <= r_r_spark' 0" "r_r_spark' 0 <= 15"
  assumes returns:
  "wordops__rotate' (s_l_spark' 0) f_0_result =
    wordops__rotate_left' (s_l_spark' 0) f_0_result"
  "wordops__rotate' (s_r_spark' 0) f_79_result =
    wordops__rotate_left' (s_r_spark' 0) f_79_result"
  "wordops__rotate' 10 cc'' = wordops__rotate_left' 10 cc''"
  "f_spark' 0 cb'' cc'' cd'' = f' 0 cb'' cc'' cd''"
  "f_spark' 79 cb'' cc'' cd'' = f' 79 cb'' cc'' cd''"
  "k_l_spark' 0 = k_l' 0"
  "k_r_spark' 0 = k_r' 0"
  "r_l_spark' 0 = r_l' 0"
  "r_r_spark' 0 = r_r' 0"
  "s_l_spark' 0 = s_l' 0"
  "s_r_spark' 0 = s_r' 0"
assumes x_borders: " \<forall>i. 0 \<le> i \<and> i \<le> 15 \<longrightarrow> 0 \<le> x'' i \<and> x'' i \<le> ?M"
shows "chain_pair___default_rcd''
    \<lparr>left'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := ce'',
          h1'chain :=
            (wordops__rotate' (s_l_spark' 0)
              ((((ca'' + f_spark' 0 cb'' cc'' cd'') mod 4294967296 +
                 x'' (r_l_spark' 0)) mod
                4294967296 +
                k_l_spark' 0) mod
               4294967296) +
             ce'') mod
            4294967296,
          h2'chain := cb'', h3'chain := wordops__rotate' 10 cc'',
          h4'chain := cd''\<rparr>,
       right'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ce'',
            h1'chain :=
              (wordops__rotate' (s_r_spark' 0)
                ((((ca'' + f_spark' 79 cb'' cc'' cd'') mod 4294967296 +
                   x'' (r_r_spark' 0)) mod
                  4294967296 +
                  k_r_spark' 0) mod
                 4294967296) +
               ce'') mod
              4294967296,
            h2'chain := cb'', h3'chain := wordops__rotate' 10 cc'',
            h4'chain := cd''\<rparr>\<rparr> =
    steps'
     (chain_pair___default_rcd''
      \<lparr>left'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ca'', h1'chain := cb'', h2'chain := cc'',
            h3'chain := cd'', h4'chain := ce''\<rparr>,
         right'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := ca'', h1'chain := cb'', h2'chain := cc'',
              h3'chain := cd'', h4'chain := ce''\<rparr>\<rparr>)
     1 x''"
proof -
  have step_hyp:
  "chain_pair___default_rcd''
    \<lparr>left'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := ca'', h1'chain := cb'', h2'chain := cc'',
          h3'chain := cd'', h4'chain := ce''\<rparr>,
       right'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ca'', h1'chain := cb'', h2'chain := cc'',
            h3'chain := cd'', h4'chain := ce''\<rparr>\<rparr> =
    steps'
     (chain_pair___default_rcd''
      \<lparr>left'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ca'', h1'chain := cb'', h2'chain := cc'',
            h3'chain := cd'', h4'chain := ce''\<rparr>,
         right'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := ca'', h1'chain := cb'', h2'chain := cc'',
              h3'chain := cd'', h4'chain := ce''\<rparr>\<rparr>)
     0 x''"
    unfolding steps_def
    by (simp add:
      uint_word_of_int_id[OF ca_borders]
      uint_word_of_int_id[OF cb_borders]
      uint_word_of_int_id[OF cc_borders]
      uint_word_of_int_id[OF cd_borders]
      uint_word_of_int_id[OF ce_borders])

  from r_l_0_borders x_borders
  have "0 \<le> x'' (r_l_spark' 0)" by blast
  hence x_lower: "0 <= x'' (r_l' 0)" unfolding returns .

  from r_l_0_borders x_borders x_borders
  have "x'' (r_l_spark' 0) <= ?M" by blast
  hence x_upper: "x'' (r_l' 0) <= ?M" unfolding returns .

  from r_r_0_borders x_borders
  have "0 \<le> x'' (r_r_spark' 0)" by blast
  hence x_lower': "0 <= x'' (r_r' 0)" unfolding returns .

  from r_r_0_borders x_borders
  have "x'' (r_r_spark' 0) <= ?M" by blast
  hence x_upper': "x'' (r_r' 0) <= ?M" unfolding returns .

  have "0 <= (0::int)" by simp
  have "0 <= (79::int)" by simp
  note step_from_hyp [OF
    step_hyp
    ca_borders  cb_borders  cc_borders  cd_borders  ce_borders
    ca_borders  cb_borders  cc_borders  cd_borders  ce_borders
  ]
  note this[OF x_lower x_upper x_lower' x_upper' `0 <= 0` `0 <= 79`]
  thus ?thesis unfolding returns(1) returns(2) unfolding returns
    by simp
qed

abbreviation "rotate_arg_l ==
    ((((cla'' + f_spark' (loop__1__j'' + 1) clb'' clc'' cld'') mod 4294967296 +
         x'' (r_l_spark' (loop__1__j'' + 1))) mod 4294967296 +
         k_l_spark' (loop__1__j'' + 1)) mod 4294967296)"
abbreviation "rotate_arg_r ==((((cra'' + f_spark' (79 - (loop__1__j'' + 1)) crb'' crc'' crd'') mod
         4294967296 + x'' (r_r_spark' (loop__1__j'' + 1))) mod 4294967296 +
         k_r_spark' (loop__1__j'' + 1)) mod 4294967296)"

lemma goal62'1:
  assumes cla_borders: "0 <= cla''" "cla'' <= 4294967295" (is "_ <= ?M")
  assumes clb_borders: "0 <= clb''" "clb'' <= ?M"
  assumes clc_borders: "0 <= clc''" "clc'' <= ?M"
  assumes cld_borders: "0 <= cld''" "cld'' <= ?M"
  assumes cle_borders: "0 <= cle''" "cle'' <= ?M"
  assumes cra_borders: "0 <= cra''" "cra'' <= ?M"
  assumes crb_borders: "0 <= crb''" "crb'' <= ?M"
  assumes crc_borders: "0 <= crc''" "crc'' <= ?M"
  assumes crd_borders: "0 <= crd''" "crd'' <= ?M"
  assumes cre_borders: "0 <= cre''" "cre'' <= ?M"
  assumes step_hyp:
  "chain_pair___default_rcd''
    \<lparr>left'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := cla'', h1'chain := clb'', h2'chain := clc'',
          h3'chain := cld'', h4'chain := cle''\<rparr>,
       right'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := cra'', h1'chain := crb'', h2'chain := crc'',
          h3'chain := crd'', h4'chain := cre''\<rparr>\<rparr> =
      steps'
   (chain_pair___default_rcd''
      \<lparr>left'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ca___init'', h1'chain := cb___init'',
            h2'chain := cc___init'', h3'chain := cd___init'',
            h4'chain := ce___init''\<rparr>,
         right'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := ca___init'', h1'chain := cb___init'',
              h2'chain := cc___init'', h3'chain := cd___init'',
              h4'chain := ce___init''\<rparr>\<rparr>)
     (loop__1__j'' + 1) x''"
  assumes returns:
    "wordops__rotate' (s_l_spark' (loop__1__j'' + 1)) rotate_arg_l =
     wordops__rotate_left' (s_l_spark' (loop__1__j'' + 1)) rotate_arg_l"
    "wordops__rotate' (s_r_spark' (loop__1__j'' + 1)) rotate_arg_r =
     wordops__rotate_left' (s_r_spark' (loop__1__j'' + 1)) rotate_arg_r"
    "f_spark' (loop__1__j'' + 1) clb'' clc'' cld'' =
     f' (loop__1__j'' + 1) clb'' clc'' cld''"
    "f_spark' (78 - loop__1__j'') crb'' crc'' crd'' =
     f' (78 - loop__1__j'') crb'' crc'' crd''" (*[simplified s]*)
    "wordops__rotate' 10 clc'' = wordops__rotate_left' 10 clc''"
    "wordops__rotate' 10 crc'' = wordops__rotate_left' 10 crc''"
    "k_l_spark' (loop__1__j'' + 1) = k_l' (loop__1__j'' + 1)"
    "k_r_spark' (loop__1__j'' + 1) = k_r' (loop__1__j'' + 1)"
    "r_l_spark' (loop__1__j'' + 1) = r_l' (loop__1__j'' + 1)"
    "r_r_spark' (loop__1__j'' + 1) = r_r' (loop__1__j'' + 1)"
    "s_l_spark' (loop__1__j'' + 1) = s_l' (loop__1__j'' + 1)"
    "s_r_spark' (loop__1__j'' + 1) = s_r' (loop__1__j'' + 1)"
  assumes x_borders: "\<forall>i. 0 \<le> i \<and> i \<le> 15 \<longrightarrow> 0 \<le> x'' i \<and> x'' i \<le> ?M"
  assumes r_l_borders:
    "0 <= r_l_spark' (loop__1__j'' + 1)" "r_l_spark' (loop__1__j'' + 1) <= 15"
  assumes r_r_borders:
    "0 <= r_r_spark' (loop__1__j'' + 1)" "r_r_spark' (loop__1__j'' + 1) <= 15"
  assumes j_loop_1_borders: "0 <= loop__1__j''" "loop__1__j'' <= 78"
  shows "chain_pair___default_rcd''
    \<lparr>left'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := cle'',
          h1'chain :=
            (wordops__rotate' (s_l_spark' (loop__1__j'' + 1))
              ((((cla'' + f_spark' (loop__1__j'' + 1) clb'' clc'' cld'') mod
                 4294967296 +
                 x'' (r_l_spark' (loop__1__j'' + 1))) mod
                4294967296 +
                k_l_spark' (loop__1__j'' + 1)) mod
               4294967296) +
             cle'') mod
            4294967296,
          h2'chain := clb'', h3'chain := wordops__rotate' 10 clc'',
          h4'chain := cld''\<rparr>,
       right'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := cre'',
            h1'chain :=
              (wordops__rotate' (s_r_spark' (loop__1__j'' + 1))
                ((((cra'' +
                    f_spark' (79 - (loop__1__j'' + 1)) crb'' crc''
                     crd'') mod
                   4294967296 +
                   x'' (r_r_spark' (loop__1__j'' + 1))) mod
                  4294967296 +
                  k_r_spark' (loop__1__j'' + 1)) mod
                 4294967296) +
               cre'') mod
              4294967296,
            h2'chain := crb'', h3'chain := wordops__rotate' 10 crc'',
            h4'chain := crd''\<rparr>\<rparr> =
    steps'
     (chain_pair___default_rcd''
      \<lparr>left'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ca___init'', h1'chain := cb___init'',
            h2'chain := cc___init'', h3'chain := cd___init'',
            h4'chain := ce___init''\<rparr>,
         right'chain_pair := chain___default_rcd''
           \<lparr>h0'chain := ca___init'', h1'chain := cb___init'',
              h2'chain := cc___init'', h3'chain := cd___init'',
              h4'chain := ce___init''\<rparr>\<rparr>)
     (loop__1__j'' + 2) x''"
proof -
  have s: "78 - loop__1__j'' = (79 - (loop__1__j'' + 1))" by simp

  from r_l_borders x_borders
  have "0 \<le> x'' (r_l_spark' (loop__1__j'' + 1))" by blast
  hence x_lower: "0 <= x'' (r_l' (loop__1__j'' + 1))" unfolding returns .

  from r_l_borders x_borders
  have "x'' (r_l_spark' (loop__1__j'' + 1)) <= ?M" by blast
  hence x_upper: "x'' (r_l' (loop__1__j'' + 1)) <= ?M" unfolding returns .

  from r_r_borders x_borders
  have "0 \<le> x'' (r_r_spark' (loop__1__j'' + 1))" by blast
  hence x_lower': "0 <= x'' (r_r' (loop__1__j'' + 1))" unfolding returns .

  from r_r_borders x_borders
  have "x'' (r_r_spark' (loop__1__j'' + 1)) <= ?M" by blast
  hence x_upper': "x'' (r_r' (loop__1__j'' + 1)) <= ?M" unfolding returns .

  from j_loop_1_borders have "0 <= loop__1__j'' + 1" by simp
  from j_loop_1_borders have "loop__1__j'' + 1 <= 79" by simp

  have "loop__1__j'' + 1 + 1 = loop__1__j'' + 2" by simp

  have "f' (79 - (loop__1__j'' + 1)) crb'' crc'' crd'' =
    f_spark' (79 - (loop__1__j'' + 1)) crb'' crc'' crd''"
    using returns by simp
  note returns = returns this

  note step_from_hyp[OF step_hyp
    cla_borders
    clb_borders
    clc_borders
    cld_borders
    cle_borders
    cra_borders
    crb_borders
    crc_borders
    crd_borders
    cre_borders]
  from this[OF
    x_lower x_upper x_lower' x_upper'
    `0 <= loop__1__j'' + 1` `loop__1__j'' + 1 <= 79`]
  show ?thesis unfolding `loop__1__j'' + 1 + 1 = loop__1__j'' + 2`
    unfolding returns(1) returns(2) unfolding returns
    by simp
qed

abbreviation "INIT_CHAIN == chain___default_rcd''
      \<lparr>h0'chain := ca___init'', h1'chain := cb___init'',
         h2'chain := cc___init'', h3'chain := cd___init'',
         h4'chain := ce___init''\<rparr>"

lemma goal76'1:
  assumes cla_borders: "0 <= cla''" "cla'' <= 4294967295" (is "_ <= ?M")
  assumes clb_borders: "0 <= clb''" "clb'' <= ?M"
  assumes clc_borders: "0 <= clc''" "clc'' <= ?M"
  assumes cld_borders: "0 <= cld''" "cld'' <= ?M"
  assumes cle_borders: "0 <= cle''" "cle'' <= ?M"
  assumes cra_borders: "0 <= cra''" "cra'' <= ?M"
  assumes crb_borders: "0 <= crb''" "crb'' <= ?M"
  assumes crc_borders: "0 <= crc''" "crc'' <= ?M"
  assumes crd_borders: "0 <= crd''" "crd'' <= ?M"
  assumes cre_borders: "0 <= cre''" "cre'' <= ?M"
  assumes ca_init_borders: "0 <= ca___init''" "ca___init'' <= ?M"
  assumes cb_init_borders: "0 <= cb___init''" "cb___init'' <= ?M"
  assumes cc_init_borders: "0 <= cc___init''" "cc___init'' <= ?M"
  assumes cd_init_borders: "0 <= cd___init''" "cd___init'' <= ?M"
  assumes ce_init_borders: "0 <= ce___init''" "ce___init'' <= ?M"
  assumes step_hyp:
  "chain_pair___default_rcd''
  \<lparr>left'chain_pair := chain___default_rcd''
     \<lparr>h0'chain := cla'', h1'chain := clb'', h2'chain := clc'', h3'chain := cld'', h4'chain := cle''\<rparr>,
     right'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := cra'', h1'chain := crb'', h2'chain := crc'', h3'chain := crd'', h4'chain := cre''\<rparr>\<rparr> =
  steps'
   (chain_pair___default_rcd''
    \<lparr>left'chain_pair := chain___default_rcd''
       \<lparr>h0'chain := ca___init'', h1'chain := cb___init'', h2'chain := cc___init'', h3'chain := cd___init'',
          h4'chain := ce___init''\<rparr>,
       right'chain_pair := chain___default_rcd''
         \<lparr>h0'chain := ca___init'', h1'chain := cb___init'', h2'chain := cc___init'', h3'chain := cd___init'',
            h4'chain := ce___init''\<rparr>\<rparr>)
   80 x''"
  shows "chain___default_rcd''
    \<lparr>h0'chain := ((cb___init'' + clc'') mod 4294967296 + crd'') mod 4294967296,
       h1'chain := ((cc___init'' + cld'') mod 4294967296 + cre'') mod 4294967296,
       h2'chain := ((cd___init'' + cle'') mod 4294967296 + cra'') mod 4294967296,
       h3'chain := ((ce___init'' + cla'') mod 4294967296 + crb'') mod 4294967296,
       h4'chain := ((ca___init'' + clb'') mod 4294967296 + crc'') mod 4294967296\<rparr> =
    round'
     (chain___default_rcd''
      \<lparr>h0'chain := ca___init'', h1'chain := cb___init'', h2'chain := cc___init'', h3'chain := cd___init'',
         h4'chain := ce___init''\<rparr>)
     x''"
proof -
  have steps_to_steps':
    "steps
       (\<lambda>n\<Colon>nat. word_of_int (x'' (int n)))
       (from_chain INIT_CHAIN, from_chain INIT_CHAIN)
       80 =
    from_chain_pair (
      steps'
      (chain_pair___default_rcd''
        \<lparr>left'chain_pair := INIT_CHAIN, right'chain_pair := INIT_CHAIN\<rparr>)
      80
      x'')"
    unfolding from_to_id by simp
  show ?thesis
    unfolding round_def
    unfolding steps_to_steps'
    unfolding step_hyp[symmetric]
    by (simp add: uint_word_ariths(1) rdmods
      uint_word_of_int_id[OF ca_init_borders]
      uint_word_of_int_id[OF cb_init_borders]
      uint_word_of_int_id[OF cc_init_borders]
      uint_word_of_int_id[OF cd_init_borders]
      uint_word_of_int_id[OF ce_init_borders]
      uint_word_of_int_id[OF cla_borders]
      uint_word_of_int_id[OF clb_borders]
      uint_word_of_int_id[OF clc_borders]
      uint_word_of_int_id[OF cld_borders]
      uint_word_of_int_id[OF cle_borders]
      uint_word_of_int_id[OF cra_borders]
      uint_word_of_int_id[OF crb_borders]
      uint_word_of_int_id[OF crc_borders]
      uint_word_of_int_id[OF crd_borders]
      uint_word_of_int_id[OF cre_borders])
qed

lemmas userlemmas = goal61'1 goal62'1 goal76'1

end


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

section "Words of Length 32"

theory Word_32
  imports
    Word_Lemmas
    Word_Syntax
    Word_Names
    Rsplit
    More_Word_Operations
    Bitwise
begin

type_synonym word32 = "32 word"
lemma len32: "len_of (x :: 32 itself) = 32" by simp

type_synonym sword32 = "32 sword"

type_synonym machine_word_len = 32
type_synonym machine_word = "machine_word_len word"

definition word_bits :: nat
where
  "word_bits = LENGTH(machine_word_len)"

text \<open>The following two are numerals so they can be used as nats and words.\<close>
definition word_size_bits :: "'a :: numeral"
where
  "word_size_bits = 2"

definition word_size :: "'a :: numeral"
where
  "word_size = 4"

lemma word_bits_conv[code]:
  "word_bits = 32"
  unfolding word_bits_def by simp

lemma word_size_word_size_bits:
  "(word_size::nat) = 2 ^ word_size_bits"
  unfolding word_size_def word_size_bits_def by simp

lemma word_bits_word_size_conv:
  "word_bits = word_size * 8"
  unfolding word_bits_def word_size_def by simp

lemma ucast_8_32_inj:
  "inj (ucast ::  8 word \<Rightarrow> 32 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 32 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_32 = upper_bits_unset_is_l2p [where 'a=32, folded word_bits_def]
lemmas le_2p_upper_bits_32 = le_2p_upper_bits [where 'a=32, folded word_bits_def]
lemmas le2p_bits_unset_32 = le2p_bits_unset[where 'a=32, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (32) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower32' = unat_power_lower[where 'a=32]
lemmas unat_power_lower32 [simp] = unat_power_lower32'[unfolded word_bits_len_of]

lemmas word32_less_sub_le' = word_less_sub_le[where 'a = 32]
lemmas word32_less_sub_le[simp] = word32_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word32) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word32_power_less_1' = word_power_less_1[where 'a = 32]
lemmas word32_power_less_1[simp] = word32_power_less_1'[folded word_bits_def]

lemma of_nat32_0:
  "\<lbrakk>of_nat n = (0::word32); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word32) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_eq)
  done

lemmas unat_of_nat32' = unat_of_nat_eq[where 'a=32]
lemmas unat_of_nat32 = unat_of_nat32'[unfolded word_bits_len_of]

lemmas word_power_nonzero_32 = word_power_nonzero [where 'a=32, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 32, unfolded word_bits_len_of]]

lemmas div_power_helper_32 = div_power_helper [where 'a=32, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 32)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_32 = of_nat_power [where 'a=32, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word32
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word32' = unat_mask[where 'a=32]
lemmas unat_mask_word32 = unat_mask_word32'[folded word_bits_def]

lemma unat_less_2p_word_bits:
  "unat (x :: 32 word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size::word32)) = 2 ^ (min sz word_bits - 2)"
  apply (case_tac "sz < word_bits")
   apply (case_tac "2 \<le> sz")
    apply (clarsimp simp: word_size_def word_bits_def min_def mask_eq)
    apply (drule (2) Suc_div_unat_helper
           [where 'a=32 and sz=sz and us=2, simplified, symmetric])
   apply (simp add: not_le word_size_def word_bits_def)
   apply (case_tac sz, simp add: unat_word_ariths)
   apply (case_tac nat, simp add: unat_word_ariths
                                  unat_mask_word32 min_def word_bits_def)
   apply simp
  apply (simp add: unat_word_ariths
                   unat_mask_word32 min_def word_bits_def word_size_def)
  done

lemmas word32_minus_one_le' = word_minus_one_le[where 'a=32]
lemmas word32_minus_one_le = word32_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::"8 word"
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word32)"
proof
  assume "ucast a = (0xFF::word32)"
  also
  have "(0xFF::word32) = ucast (0xFF::8 word)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word32) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma unat_ucast_8_32:
  fixes x :: "8 word"
  shows "unat (ucast x :: word32) = unat x"
  by transfer simp

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word32)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word32)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_32:
  "(ucast x \<le> (ucast y :: word32)) = (x \<le> (y :: 8 word))"
  by (simp add: ucast_le_ucast)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word32)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word32. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_32_0:
  "(2 ^ 32 :: word32) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word32 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_32_max_word  = max_word_mask [symmetric, where 'a=32, simplified]

lemma of_nat32_n_less_equal_power_2:
 "n < 32 \<Longrightarrow> ((of_nat n)::32 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word32) = [0, 0, 0, 0 :: 8 word]"
  by (simp add: word_rsplit_def bin_rsplit_def)

lemma unat_ucast_10_32 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word32) = unat x"
  by transfer simp

lemma bool_mask [simp]:
  fixes x :: word32
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word32_bounds:
  "- (2 ^ (size (x :: word32) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (x :: word32) - 1)) - 1) = (2147483647 :: int)"
  "- (2 ^ (size (y :: 32 signed word) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (y :: 32 signed word) - 1)) - 1) = (2147483647 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::32 word) \<ge> -2147483648"
  by (metis sint_ge word32_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word32'
    = signed_arith_ineq_checks_to_eq[where 'a=32]
      signed_arith_ineq_checks_to_eq[where 'a="32 signed"]

lemmas signed_arith_ineq_checks_to_eq_word32
    = signed_arith_ineq_checks_to_eq_word32' [unfolded word32_bounds]

lemmas signed_mult_eq_checks32_to_64'
    = signed_mult_eq_checks_double_size[where 'a=32 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="32 signed" and 'b=64]

lemmas signed_mult_eq_checks32_to_64 = signed_mult_eq_checks32_to_64'[simplified]

lemmas sdiv_word32_max' = sdiv_word_max [where 'a=32] sdiv_word_max [where 'a="32 signed"]
lemmas sdiv_word32_max = sdiv_word32_max'[simplified word_size, simplified]

lemmas sdiv_word32_min' = sdiv_word_min [where 'a=32] sdiv_word_min [where 'a="32 signed"]
lemmas sdiv_word32_min = sdiv_word32_min' [simplified word_size, simplified]

lemmas sint32_of_int_eq' = sint_of_int_eq [where 'a=32]
lemmas sint32_of_int_eq = sint32_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word32) :: sword32) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: 16 sword) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: 8 sword) = (of_nat x)"
  "(ucast (of_nat x :: 16 word) :: 16 sword) = (of_nat x)"
  "(ucast (of_nat x :: 16 word) :: 8 sword) = (of_nat x)"
  "(ucast (of_nat x :: 8 word) :: 8 sword) = (of_nat x)"
  by (simp_all add: of_nat_take_bit take_bit_word_eq_self)

lemmas signed_shift_guard_simpler_32'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_32 = signed_shift_guard_simpler_32'[simplified]

lemma word32_31_less:
  "31 < len_of TYPE (32 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (32)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_32
    = signed_shift_guard_to_word[OF word32_31_less(1-2)]
    signed_shift_guard_to_word[OF word32_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "32 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 32 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word32) >> 1 = 0 \<Longrightarrow> x < 2"
  by transfer (simp add: take_bit_drop_bit drop_bit_Suc)

lemma has_zero_byte:
  "~~ (((((v::word32) && 0x7f7f7f7f) + 0x7f7f7f7f) || v) || 0x7f7f7f7f) \<noteq> 0
    \<Longrightarrow> v && 0xff000000 = 0 \<or> v && 0xff0000 = 0 \<or> v && 0xff00 = 0 \<or> v && 0xff = 0"
  by word_bitwise auto

lemma mask_step_down_32:
  \<open>\<exists>x. mask x = b\<close> if \<open>b && 1 = 1\<close>
    and \<open>\<exists>x. x < 32 \<and> mask x = b >> 1\<close> for b :: \<open>32word\<close>
proof -
  from \<open>b && 1 = 1\<close> have \<open>odd b\<close>
    by (auto simp add: mod_2_eq_odd and_one_eq)
  then have \<open>b mod 2 = 1\<close>
    using odd_iff_mod_2_eq_one by blast
  from \<open>\<exists>x. x < 32 \<and> mask x = b >> 1\<close> obtain x where \<open>x < 32\<close> \<open>mask x = b >> 1\<close> by blast
  then have \<open>mask x = b div 2\<close>
    using shiftr1_is_div_2 [of b] by simp
  with \<open>b mod 2 = 1\<close> have \<open>2 * mask x + 1 = 2 * (b div 2) + b mod 2\<close>
    by (simp only:)
  also have \<open>\<dots> = b\<close>
    by (simp add: mult_div_mod_eq)
  finally have \<open>2 * mask x + 1 = b\<close> .
  moreover have \<open>mask (Suc x) = 2 * mask x + (1 :: 'a::len word)\<close>
    by (simp add: mask_Suc_rec)
  ultimately show ?thesis
    by auto
qed

lemma unat_of_int_32:
  "\<lbrakk>i \<ge> 0; i \<le>2 ^ 31\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword32)) = nat i"
  unfolding unat_eq_nat_uint
  apply (subst eq_nat_nat_iff)
    apply (auto simp add: take_bit_int_eq_self)
  done

lemmas word_ctz_not_minus_1_32 = word_ctz_not_minus_1[where 'a=32, simplified]

(* Helper for packing then unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64[simp]:
  "(((ucast ((ucast (x::64 word))::32 word))::64 word) || (((ucast ((ucast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_assemble_id)

(* Another variant of packing and unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64'[simp]:
  "(((ucast ((scast (x::64 word))::32 word))::64 word) || (((ucast ((scast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_scast_assemble_id)

(* Specialisations of down_cast_same for adding to local simpsets. *)
lemma cast_down_u64: "(scast::64 word \<Rightarrow> 32 word) = (ucast::64 word \<Rightarrow> 32 word)"
  by (subst down_cast_same[symmetric]; simp add:is_down)+

lemma cast_down_s64: "(scast::64 sword \<Rightarrow> 32 word) = (ucast::64 sword \<Rightarrow> 32 word)"
  by (subst down_cast_same[symmetric]; simp add:is_down)

lemma word32_and_max_simp:
  \<open>x AND 0xFFFFFFFF = x\<close> for x :: \<open>32 word\<close>
  using word_and_full_mask_simp [of x]
  by (simp add: numeral_eq_Suc mask_Suc_exp)

end


(* Author: Lukas Bulwahn, TU Muenchen *)

section \<open>Lazy sequences\<close>

theory Lazy_Sequence
imports Predicate
begin

subsection \<open>Type of lazy sequences\<close>

datatype (plugins only: code extraction) (dead 'a) lazy_sequence =
  lazy_sequence_of_list "'a list"

primrec list_of_lazy_sequence :: "'a lazy_sequence \<Rightarrow> 'a list"
where
  "list_of_lazy_sequence (lazy_sequence_of_list xs) = xs"

lemma lazy_sequence_of_list_of_lazy_sequence [simp]:
  "lazy_sequence_of_list (list_of_lazy_sequence xq) = xq"
  by (cases xq) simp_all

lemma lazy_sequence_eqI:
  "list_of_lazy_sequence xq = list_of_lazy_sequence yq \<Longrightarrow> xq = yq"
  by (cases xq, cases yq) simp

lemma lazy_sequence_eq_iff:
  "xq = yq \<longleftrightarrow> list_of_lazy_sequence xq = list_of_lazy_sequence yq"
  by (auto intro: lazy_sequence_eqI)

lemma case_lazy_sequence [simp]:
  "case_lazy_sequence f xq = f (list_of_lazy_sequence xq)"
  by (cases xq) auto

lemma rec_lazy_sequence [simp]:
  "rec_lazy_sequence f xq = f (list_of_lazy_sequence xq)"
  by (cases xq) auto

definition Lazy_Sequence :: "(unit \<Rightarrow> ('a \<times> 'a lazy_sequence) option) \<Rightarrow> 'a lazy_sequence"
where
  "Lazy_Sequence f = lazy_sequence_of_list (case f () of
    None \<Rightarrow> []
  | Some (x, xq) \<Rightarrow> x # list_of_lazy_sequence xq)"

code_datatype Lazy_Sequence

declare list_of_lazy_sequence.simps [code del]
declare lazy_sequence.case [code del]
declare lazy_sequence.rec [code del]

lemma list_of_Lazy_Sequence [simp]:
  "list_of_lazy_sequence (Lazy_Sequence f) = (case f () of
    None \<Rightarrow> []
  | Some (x, xq) \<Rightarrow> x # list_of_lazy_sequence xq)"
  by (simp add: Lazy_Sequence_def)

definition yield :: "'a lazy_sequence \<Rightarrow> ('a \<times> 'a lazy_sequence) option"
where
  "yield xq = (case list_of_lazy_sequence xq of
    [] \<Rightarrow> None
  | x # xs \<Rightarrow> Some (x, lazy_sequence_of_list xs))"

lemma yield_Seq [simp, code]:
  "yield (Lazy_Sequence f) = f ()"
  by (cases "f ()") (simp_all add: yield_def split_def)

lemma case_yield_eq [simp]: "case_option g h (yield xq) =
  case_list g (\<lambda>x. curry h x \<circ> lazy_sequence_of_list) (list_of_lazy_sequence xq)"
  by (cases "list_of_lazy_sequence xq") (simp_all add: yield_def)

lemma equal_lazy_sequence_code [code]:
  "HOL.equal xq yq = (case (yield xq, yield yq) of
    (None, None) \<Rightarrow> True
  | (Some (x, xq'), Some (y, yq')) \<Rightarrow> HOL.equal x y \<and> HOL.equal xq yq
  | _ \<Rightarrow> False)"
  by (simp_all add: lazy_sequence_eq_iff equal_eq split: list.splits)

lemma [code nbe]:
  "HOL.equal (x :: 'a lazy_sequence) x \<longleftrightarrow> True"
  by (fact equal_refl)

definition empty :: "'a lazy_sequence"
where
  "empty = lazy_sequence_of_list []"

lemma list_of_lazy_sequence_empty [simp]:
  "list_of_lazy_sequence empty = []"
  by (simp add: empty_def)

lemma empty_code [code]:
  "empty = Lazy_Sequence (\<lambda>_. None)"
  by (simp add: lazy_sequence_eq_iff)

definition single :: "'a \<Rightarrow> 'a lazy_sequence"
where
  "single x = lazy_sequence_of_list [x]"

lemma list_of_lazy_sequence_single [simp]:
  "list_of_lazy_sequence (single x) = [x]"
  by (simp add: single_def)

definition append :: "'a lazy_sequence \<Rightarrow> 'a lazy_sequence \<Rightarrow> 'a lazy_sequence"
where
  "append xq yq = lazy_sequence_of_list (list_of_lazy_sequence xq @ list_of_lazy_sequence yq)"

lemma list_of_lazy_sequence_append [simp]:
  "list_of_lazy_sequence (append xq yq) = list_of_lazy_sequence xq @ list_of_lazy_sequence yq"
  by (simp add: append_def)

lemma append_code [code]:
  "append xq yq = Lazy_Sequence (\<lambda>_. case yield xq of
    None \<Rightarrow> yield yq
  | Some (x, xq') \<Rightarrow> Some (x, append xq' yq))"
  by (simp_all add: lazy_sequence_eq_iff split: list.splits)

definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a lazy_sequence \<Rightarrow> 'b lazy_sequence"
where
  "map f xq = lazy_sequence_of_list (List.map f (list_of_lazy_sequence xq))"

lemma list_of_lazy_sequence_map [simp]:
  "list_of_lazy_sequence (map f xq) = List.map f (list_of_lazy_sequence xq)"
  by (simp add: map_def)

lemma map_code [code]:
  "map f xq =
    Lazy_Sequence (\<lambda>_. map_option (\<lambda>(x, xq'). (f x, map f xq')) (yield xq))"
  by (simp_all add: lazy_sequence_eq_iff split: list.splits)

definition flat :: "'a lazy_sequence lazy_sequence \<Rightarrow> 'a lazy_sequence"
where
  "flat xqq = lazy_sequence_of_list (concat (List.map list_of_lazy_sequence (list_of_lazy_sequence xqq)))"

lemma list_of_lazy_sequence_flat [simp]:
  "list_of_lazy_sequence (flat xqq) = concat (List.map list_of_lazy_sequence (list_of_lazy_sequence xqq))"
  by (simp add: flat_def)

lemma flat_code [code]:
  "flat xqq = Lazy_Sequence (\<lambda>_. case yield xqq of
    None \<Rightarrow> None
  | Some (xq, xqq') \<Rightarrow> yield (append xq (flat xqq')))"
  by (simp add: lazy_sequence_eq_iff split: list.splits)

definition bind :: "'a lazy_sequence \<Rightarrow> ('a \<Rightarrow> 'b lazy_sequence) \<Rightarrow> 'b lazy_sequence"
where
  "bind xq f = flat (map f xq)"

definition if_seq :: "bool \<Rightarrow> unit lazy_sequence"
where
  "if_seq b = (if b then single () else empty)"

definition those :: "'a option lazy_sequence \<Rightarrow> 'a lazy_sequence option"
where
  "those xq = map_option lazy_sequence_of_list (List.those (list_of_lazy_sequence xq))"

function iterate_upto :: "(natural \<Rightarrow> 'a) \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> 'a lazy_sequence"
where
  "iterate_upto f n m =
    Lazy_Sequence (\<lambda>_. if n > m then None else Some (f n, iterate_upto f (n + 1) m))"
  by pat_completeness auto

termination by (relation "measure (\<lambda>(f, n, m). nat_of_natural (m + 1 - n))")
  (auto simp add: less_natural_def)

definition not_seq :: "unit lazy_sequence \<Rightarrow> unit lazy_sequence"
where
  "not_seq xq = (case yield xq of
    None \<Rightarrow> single ()
  | Some ((), xq) \<Rightarrow> empty)"

subsection \<open>Code setup\<close>

code_reflect Lazy_Sequence
  datatypes lazy_sequence = Lazy_Sequence

ML \<open>
signature LAZY_SEQUENCE =
sig
  datatype 'a lazy_sequence = Lazy_Sequence of (unit -> ('a * 'a Lazy_Sequence.lazy_sequence) option)
  val map: ('a -> 'b) -> 'a lazy_sequence -> 'b lazy_sequence
  val yield: 'a lazy_sequence -> ('a * 'a lazy_sequence) option
  val yieldn: int -> 'a lazy_sequence -> 'a list * 'a lazy_sequence
end;

structure Lazy_Sequence : LAZY_SEQUENCE =
struct

datatype lazy_sequence = datatype Lazy_Sequence.lazy_sequence;

fun map f = @{code Lazy_Sequence.map} f;

fun yield P = @{code Lazy_Sequence.yield} P;

fun yieldn k = Predicate.anamorph yield k;

end;
\<close>

subsection \<open>Generator Sequences\<close>

subsubsection \<open>General lazy sequence operation\<close>

definition product :: "'a lazy_sequence \<Rightarrow> 'b lazy_sequence \<Rightarrow> ('a \<times> 'b) lazy_sequence"
where
  "product s1 s2 = bind s1 (\<lambda>a. bind s2 (\<lambda>b. single (a, b)))"

subsubsection \<open>Small lazy typeclasses\<close>

class small_lazy =
  fixes small_lazy :: "natural \<Rightarrow> 'a lazy_sequence"

instantiation unit :: small_lazy
begin

definition "small_lazy d = single ()"

instance ..

end

instantiation int :: small_lazy
begin

text \<open>maybe optimise this expression -> append (single x) xs == cons x xs
Performance difference?\<close>

function small_lazy' :: "int \<Rightarrow> int \<Rightarrow> int lazy_sequence"
where
  "small_lazy' d i = (if d < i then empty
    else append (single i) (small_lazy' d (i + 1)))"
    by pat_completeness auto

termination
  by (relation "measure (%(d, i). nat (d + 1 - i))") auto

definition
  "small_lazy d = small_lazy' (int (nat_of_natural d)) (- (int (nat_of_natural d)))"

instance ..

end

instantiation prod :: (small_lazy, small_lazy) small_lazy
begin

definition
  "small_lazy d = product (small_lazy d) (small_lazy d)"

instance ..

end

instantiation list :: (small_lazy) small_lazy
begin

fun small_lazy_list :: "natural \<Rightarrow> 'a list lazy_sequence"
where
  "small_lazy_list d = append (single [])
    (if d > 0 then bind (product (small_lazy (d - 1))
      (small_lazy (d - 1))) (\<lambda>(x, xs). single (x # xs)) else empty)"

instance ..

end

subsection \<open>With Hit Bound Value\<close>
text \<open>assuming in negative context\<close>

type_synonym 'a hit_bound_lazy_sequence = "'a option lazy_sequence"

definition hit_bound :: "'a hit_bound_lazy_sequence"
where
  "hit_bound = Lazy_Sequence (\<lambda>_. Some (None, empty))"

lemma list_of_lazy_sequence_hit_bound [simp]:
  "list_of_lazy_sequence hit_bound = [None]"
  by (simp add: hit_bound_def)

definition hb_single :: "'a \<Rightarrow> 'a hit_bound_lazy_sequence"
where
  "hb_single x = Lazy_Sequence (\<lambda>_. Some (Some x, empty))"

definition hb_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a hit_bound_lazy_sequence \<Rightarrow> 'b hit_bound_lazy_sequence"
where
  "hb_map f xq = map (map_option f) xq"

lemma hb_map_code [code]:
  "hb_map f xq =
    Lazy_Sequence (\<lambda>_. map_option (\<lambda>(x, xq'). (map_option f x, hb_map f xq')) (yield xq))"
  using map_code [of "map_option f" xq] by (simp add: hb_map_def)

definition hb_flat :: "'a hit_bound_lazy_sequence hit_bound_lazy_sequence \<Rightarrow> 'a hit_bound_lazy_sequence"
where
  "hb_flat xqq = lazy_sequence_of_list (concat
    (List.map ((\<lambda>x. case x of None \<Rightarrow> [None] | Some xs \<Rightarrow> xs) \<circ> map_option list_of_lazy_sequence) (list_of_lazy_sequence xqq)))"

lemma list_of_lazy_sequence_hb_flat [simp]:
  "list_of_lazy_sequence (hb_flat xqq) =
    concat (List.map ((\<lambda>x. case x of None \<Rightarrow> [None] | Some xs \<Rightarrow> xs) \<circ> map_option list_of_lazy_sequence) (list_of_lazy_sequence xqq))"
  by (simp add: hb_flat_def)

lemma hb_flat_code [code]:
  "hb_flat xqq = Lazy_Sequence (\<lambda>_. case yield xqq of
    None \<Rightarrow> None
  | Some (xq, xqq') \<Rightarrow> yield
     (append (case xq of None \<Rightarrow> hit_bound | Some xq \<Rightarrow> xq) (hb_flat xqq')))"
  by (simp add: lazy_sequence_eq_iff split: list.splits option.splits)

definition hb_bind :: "'a hit_bound_lazy_sequence \<Rightarrow> ('a \<Rightarrow> 'b hit_bound_lazy_sequence) \<Rightarrow> 'b hit_bound_lazy_sequence"
where
  "hb_bind xq f = hb_flat (hb_map f xq)"

definition hb_if_seq :: "bool \<Rightarrow> unit hit_bound_lazy_sequence"
where
  "hb_if_seq b = (if b then hb_single () else empty)"

definition hb_not_seq :: "unit hit_bound_lazy_sequence \<Rightarrow> unit lazy_sequence"
where
  "hb_not_seq xq = (case yield xq of
    None \<Rightarrow> single ()
  | Some (x, xq) \<Rightarrow> empty)"

hide_const (open) yield empty single append flat map bind
  if_seq those iterate_upto not_seq product

hide_fact (open) yield_def empty_def single_def append_def flat_def map_def bind_def
  if_seq_def those_def not_seq_def product_def

end