(* Authors: Lammich, Wimmer *)
theory FW_Code
  imports
    Recursion_Combinators
    Floyd_Warshall.Floyd_Warshall
  "../../Refine_Imperative_HOL/IICF/IICF_Misc"
  "Imperative_HOL_Time.Asymptotics_1D"
begin

section \<open>Refinement to Efficient Imperative Code\<close>

text \<open>
  We will now refine the recursive version of the \fw to an efficient imperative version.
  To this end, we use the Imperative Refinement Framework, yielding an implementation in Imperative HOL.
\<close>

definition fw_upd' :: "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nrest" where
  "fw_upd' m k i j =
    do {
        mij \<leftarrow> mop_matrix_get 1 m (i, j);
        mik \<leftarrow> mop_matrix_get 1 m (i, k);
        mkj \<leftarrow> mop_matrix_get 1 m (k, j);
        s \<leftarrow> mop_plus 1 mik mkj;
        ss \<leftarrow> mop_min 1 mij s;
        mop_matrix_set 1 m (i, j) ss
  }"

definition fwi' ::  "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nrest"
where
  "fwi' m n k i j = RECT (\<lambda> fw (m, k, i, j).
      case (i, j) of
        (0, 0) \<Rightarrow> fw_upd' m k 0 0 |
        (Suc i, 0) \<Rightarrow> do {m' \<leftarrow> fw (m, k, i, n); fw_upd' m' k (Suc i) 0} |
        (i, Suc j) \<Rightarrow> do {m' \<leftarrow> fw (m, k, i, j); fw_upd' m' k i (Suc j)}
    ) (m, k, i, j)"

lemma fwi'_simps:
  "fwi' m n k 0       0        = fw_upd' m k 0 0"
  "fwi' m n k (Suc i) 0        = do {m' \<leftarrow> fwi' m n k i n; fw_upd' m' k (Suc i) 0}"
  "fwi' m n k i       (Suc j)  = do {m' \<leftarrow> fwi' m n k i j; fw_upd' m' k i (Suc j)}"
unfolding fwi'_def by (subst RECT_unfold, (refine_mono; fail), (auto split: nat.split; fail))+

lemma fw_upd'_spec: "fw_upd' m k i j \<le> SPEC (\<lambda>r. r = uncurry (fw_upd (curry m) k i j)) (\<lambda>_. enat 6)"
  unfolding SPEC_def
  unfolding fw_upd'_def fw_upd_def upd_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: matrix_set matrix_get mop_min mop_plus)
  by(auto split: if_splits )

lemma
  "fwi' m n k i j \<le> SPEC (\<lambda> r. r = uncurry (fwi (curry m) n k i j)) (\<lambda>_. 6*((j+1)+i*(n+1)))"
proof (induction "curry m" n k i j arbitrary: m rule: fwi.induct)
  case (1 n k)
  then show ?case apply (simp add:   fwi'_simps)  by (rule fw_upd'_spec)
next
  case (2 n k i)
  show ?case apply (simp add:   fwi'_simps)
    unfolding SPEC_def
    apply(rule T_specifies_I)
    apply(vcg' \<open>simp\<close> rules: 2(1)[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]
               fw_upd'_spec[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]       )
    by(auto split: if_splits)
next
  case (3 n k i j)
  show ?case  apply (simp add:   fwi'_simps)
    unfolding SPEC_def
    apply(rule T_specifies_I)
    apply(vcg' \<open>simp\<close> rules: 3(1)[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]
               fw_upd'_spec[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]       )
    by(auto split: if_splits)
qed

definition "fw_time (n::nat) = 6*((n+1)*(n+1))*(n+1)"
definition "fwi_time (i::nat) (j::nat) (n::nat) = 6*((j+1)+i*(n+1))"

lemma fw_time_fwi_time: "fw_time n = (n+1)* fwi_time n n n" unfolding fw_time_def fwi_time_def
  by auto

lemma for_rec2_fwi:
  "for_rec2 (\<lambda> M. fw_upd' M k) M n i j \<le> SPEC (\<lambda> M'. M' = uncurry (fwi (curry M) n k i j)) (\<lambda>_. fwi_time i j n)"
  unfolding fwi_time_def
proof (induction "\<lambda> M. fw_upd' (M :: (nat \<times> nat \<Rightarrow> 'a)) k" M n i j rule: for_rec2.induct)
  case (1 a n)
  then show ?case apply simp  by (rule fw_upd'_spec)
next
  case (2 a n i)
  show ?case apply simp
    unfolding SPEC_def
    apply(rule T_specifies_I)
    apply(vcg' \<open>simp\<close> rules:  2[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]
               fw_upd'_spec[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]       )
    by(auto split: if_splits)
next
  case (3 a n i j)
  show ?case apply simp
    unfolding SPEC_def
    apply(rule T_specifies_I)
    apply(vcg' \<open>simp\<close> rules:  3[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]
               fw_upd'_spec[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]       )
    by(auto split: if_splits)
qed

definition fw' ::  "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nrest" where
  "fw' m n k = nfoldli [0..<k + 1] (\<lambda> _. True) (\<lambda> k M. do { for_rec2 (\<lambda> M. fw_upd' M k) M n n n }) m"

lemma fw'_spec:
  "fw' m n k \<le> SPEC (\<lambda> M'. M' = uncurry (fw (curry m) n k))  (\<lambda>_. (k+1)*fwi_time n n n)"
  unfolding fw'_def
proof (induction k)
  case 0
  then show ?case apply simp unfolding SPEC_def
    apply(rule T_specifies_I)
    apply(vcg' \<open>simp\<close> rules:
               for_rec2_fwi[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]       )
    apply simp apply (vcg' \<open>-\<close>) by(auto split: if_splits simp: curry_def)
next
  case (Suc k)
  have dec: "[0..<Suc k + 1] = [0..<k + 1] @ [k+1]" by auto
  show ?case apply(simp only: dec nfoldli_append)  unfolding SPEC_def
    apply(rule T_specifies_I)
    apply(vcg' \<open>simp\<close> rules:
               Suc(1)[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4]
                     )
    apply simp apply (vcg' \<open>-\<close> rules: for_rec2_fwi[unfolded SPEC_def, THEN T_specifies_rev, THEN T_conseq4] )
    apply simp apply (vcg' \<open>-\<close>) by(auto split: if_splits simp: curry_def)
qed

context
  fixes n :: nat
  fixes dummy :: "'a::{linordered_ab_monoid_add,zero,heap}"
begin

(*lemma [sepref_import_param]: "((+),(+)::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp
lemma [sepref_import_param]: "(min,min::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp*)

abbreviation "node_assn \<equiv> nat_assn"
abbreviation "mtx_assn \<equiv> asmtx_assn (Suc n) id_assn::('a mtx \<Rightarrow>_)"

lemma ff: "(bb ::\<^sub>iTYPE('a i_mtx)) \<Longrightarrow> (bb ::\<^sub>iTYPE(nat \<times> nat \<Rightarrow>'a))" by auto

sepref_definition fw_upd_impl is
  "uncurry2 (uncurry fw_upd')" ::
  "[\<lambda> (((_,k),i),j). k \<le> n \<and> i \<le> n \<and> j \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k
  \<rightarrow> mtx_assn"
  unfolding fw_upd'_def[abs_def]
  apply sepref_dbg_preproc
   apply sepref_dbg_cons_init
  apply(drule ff)       (* ----------------- TODO -------------- *)
     apply sepref_dbg_id
     apply sepref_dbg_monadify
     apply sepref_dbg_opt_init
      apply sepref_dbg_trans
  apply sepref_dbg_opt
  apply sepref_dbg_cons_solve \<comment> \<open>Frame rule, recovering the invalidated list
    or pure elements, propagating recovery over the list structure\<close>
  apply sepref_dbg_cons_solve \<comment> \<open>Trivial frame rule\<close>
  apply sepref_dbg_constraints
  done

declare fw_upd_impl.refine[sepref_fr_rules]

sepref_register fw_upd' :: "'a i_mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a i_mtx nrest"

definition
  "fwi_impl' (M :: 'a mtx) k = for_rec2 (\<lambda> M. fw_upd' M k) M n n n"

definition
  "fw_impl' (M :: 'a mtx) = fw' M n n"

context
  notes [id_rules] = itypeI[of n "TYPE (nat)"]
    and [sepref_import_param] = IdI[of n]
begin

sepref_definition fw_impl is
  "fw_impl'" :: "mtx_assn\<^sup>d \<rightarrow>\<^sub>a mtx_assn"      using [[id_debug, goals_limit = 1]]
  unfolding fw_impl'_def[abs_def] fw'_def
  unfolding for_rec2_eq apply(subst (2) nfoldli_assert'[symmetric])
      apply(subst (1) nfoldli_assert'[symmetric])
      apply(subst (0) nfoldli_assert'[symmetric])
    unfolding nfoldli_def
    by sepref

sepref_definition fwi_impl is
  "uncurry fwi_impl'" :: "[\<lambda> (_,k). k \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k \<rightarrow> mtx_assn"
unfolding fwi_impl'_def[abs_def] for_rec2_eq
      apply(subst (1) nfoldli_assert'[symmetric])
      apply(subst (0) nfoldli_assert'[symmetric])
    unfolding nfoldli_def
    by sepref

end (* End of sepref setup *)

end (* End of n *)

export_code fw_impl checking SML_imp

text \<open>
  A compact specification for the characteristic property of the \fw.
\<close>
definition fw_spec where
  "fw_spec n M \<equiv> SPEC (\<lambda> M'.
    if (\<exists> i \<le> n. M' i i < 0)
    then \<not> cyc_free M n
    else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n) (\<lambda>_. fw_time n)"

lemma D_diag_nonnegI:
  assumes "cycle_free M n" "i \<le> n"
  shows "D M i i n \<ge> 0"
using assms D_dest''[OF refl, of M i i n] unfolding cycle_free_def by auto

lemma fw_fw_spec:
  "SPECT [FW M n \<mapsto> enat (fw_time n)] \<le> fw_spec n M"
unfolding fw_spec_def cycle_free_diag_equiv SPEC_def apply (simp add: le_fun_def)
proof (safe, goal_cases)
  case prems: (1 i)
  with fw_shortest_path[unfolded cycle_free_diag_equiv, OF prems(3)] D_diag_nonnegI show ?case
    by fastforce
next
  case 2 then show ?case using FW_neg_cycle_detect[unfolded cycle_free_diag_equiv]
    by (force intro: fw_shortest_path[symmetric, unfolded cycle_free_diag_equiv])
next
  case 3 then show ?case using FW_neg_cycle_detect[unfolded cycle_free_diag_equiv] by blast
qed

definition
  "mat_curry_rel = {(Mu, Mc). curry Mu = Mc}"

definition
  "mtx_curry_assn n = hr_comp (mtx_assn n) (br curry (\<lambda>_. True))"

declare mtx_curry_assn_def[symmetric, fcomp_norm_unfold]

lemma fw_impl'_correct:
  "(fw_impl', fw_spec) \<in> Id \<rightarrow> br curry (\<lambda> _. True) \<rightarrow> \<langle>br curry (\<lambda> _. True)\<rangle> nrest_rel"
 unfolding fw_impl'_def[abs_def]  using fw'_spec fw_fw_spec
 by (fastforce simp: in_br_conv pw_le_iff refine_pw_simps fw_time_fwi_time intro!: nrest_relI )

subsection \<open>Main Result\<close>

text \<open>This is one way to state that \<open>fw_impl\<close> fulfills the specification \<open>fw_spec\<close>.\<close>
theorem fw_impl_correct:
  "(fw_impl n, fw_spec n) \<in> (mtx_curry_assn n)\<^sup>d \<rightarrow>\<^sub>a mtx_curry_assn n"
using fw_impl.refine[FCOMP fw_impl'_correct[THEN fun_relD, OF IdI]] .

text \<open>An alternative version: a Hoare triple for total correctness.\<close>
corollary fw_correct:
  "<mtx_curry_assn n M Mi * $(fw_time n)> fw_impl n Mi <\<lambda> Mi'. \<exists>\<^sub>A M'. mtx_curry_assn n M' Mi' * \<up>
    (if (\<exists> i \<le> n. M' i i < 0)
    then \<not> cyc_free M n
    else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n)>\<^sub>t"
unfolding cycle_free_diag_equiv
  thm fw_impl_correct[THEN hfrefD] fw_spec_def
  apply (rule ht_cons_rule[OF _ _ extract_cost_ub_SPEC[OF fw_impl_correct[THEN hfrefD, unfolded fw_spec_def[unfolded cycle_free_diag_equiv]] ]])
  by sep_auto+

lemma fw_time_n_cube: "fw_time \<in> \<Theta>(\<lambda>n. n*n*n)"
  unfolding fw_time_def by auto2

subsection \<open>Alternative Versions for Uncurried Matrices.\<close>

definition "FWI' = uncurry ooo FWI o curry"

lemma fwi_impl'_refine_FWI':
  "(fwi_impl' n, (\<lambda>x. SPECT [ x \<mapsto> fwi_time n n n])  oo PR_CONST (\<lambda> M. FWI' M n)) \<in> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle> nrest_rel"
unfolding fwi_impl'_def[abs_def] FWI_def[abs_def] FWI'_def using for_rec2_fwi
by (force simp: pw_nrest_rel_iff pw_le_iff refine_pw_simps fw_time_fwi_time)

lemmas fwi_impl_refine_FWI' = fwi_impl.refine[FCOMP fwi_impl'_refine_FWI']

definition "FW' = uncurry oo FW o curry"

definition "FW'' n M = FW' M n"

lemma fw_impl'_refine_FW'':
  "(fw_impl' n, (\<lambda>x. SPECT [ x \<mapsto> fw_time n]) o PR_CONST (FW'' n)) \<in> Id \<rightarrow> \<langle>Id\<rangle> nrest_rel"
unfolding fw_impl'_def[abs_def] FW''_def[abs_def] FW'_def using fw'_spec
by (force simp: pw_le_iff pw_nrest_rel_iff refine_pw_simps fw_time_fwi_time)

lemmas fw_impl_refine_FW'' = fw_impl.refine[FCOMP fw_impl'_refine_FW'']

end


theory Lib_Word_toString
imports Lib_Numbers_toString
        "../Word_Lib/Word_Lemmas"
begin

section\<open>Printing Machine Words\<close>

(*imitation of http://stackoverflow.com/questions/23864965/string-of-nat-in-isabelle*)
(*parameters:
    lc = lower-case
    w  = word to print*)
definition string_of_word_single :: "bool \<Rightarrow> 'a::len word \<Rightarrow> string" where
  "string_of_word_single lc w \<equiv>
    (if
       w < 10
     then
       [char_of_nat (48 + unat w)]
     else if
       w < 36
     then
       [char_of_nat ((if lc then 87 else 55) + unat w)]
     else
       undefined)"

text\<open>Example:\<close>
lemma "let word_upto = ((\<lambda> i j. map (of_nat \<circ> nat) [i .. j]) :: int \<Rightarrow> int \<Rightarrow> 32 word list)
       in map (string_of_word_single False) (word_upto 1 35) =
  [''1'', ''2'', ''3'', ''4'', ''5'', ''6'', ''7'', ''8'', ''9'',
   ''A'', ''B'', ''C'', ''D'', ''E'', ''F'', ''G'', ''H'', ''I'',
   ''J'', ''K'', ''L'', ''M'', ''N'', ''O'', ''P'', ''Q'', ''R'',
   ''S'', ''T'', ''U'', ''V'', ''W'', ''X'', ''Y'', ''Z'']" by eval

(* parameters: lowercase, base, minimum length - 1, to-be-serialized word *)
function string_of_word :: "bool \<Rightarrow> ('a :: len) word \<Rightarrow> nat \<Rightarrow> ('a :: len) word \<Rightarrow> string" where
  "string_of_word lc base ml w =
    (if
       base < 2 \<or> len_of TYPE('a) < 2
     then
       undefined
     else if
       w < base \<and> ml = 0
     then
       string_of_word_single lc w
     else
       string_of_word lc base (ml - 1) (w div base) @ string_of_word_single lc (w mod base)
     )"
by pat_completeness auto

definition "hex_string_of_word l \<equiv> string_of_word True (16 :: ('a::len) word) l"
definition "hex_string_of_word0 \<equiv> hex_string_of_word 0"
(* be careful though, these functions only make sense with words > length 4.
   With 4 bits, base 16 is not representable. *)
definition "dec_string_of_word0 \<equiv> string_of_word True 10 0"

termination string_of_word
	apply(relation "measure (\<lambda>(a,b,c,d). unat d + c)")
	 apply(rule wf_measure)
	apply(subst in_measure)
	apply(clarsimp)
	subgoal for base ml n
    apply(case_tac "ml \<noteq> 0")
     apply(simp add: less_eq_Suc_le unat_div)
    apply(simp)
    apply(subgoal_tac "(n div base) < n")
     apply(blast intro: unat_mono)
    apply(rule div_less_dividend_word)
     subgoal by(metis Word_Lemmas.power_not_zero linorder_neqE_nat numeral_less_iff
                      power_zero_numeral semiring_norm(76) word_neq_0_conv)
    apply(clarsimp)
    apply(thin_tac "n \<noteq> 0")
    subgoal by (metis One_nat_def mult.right_neutral power_0 power_Suc unat_1
                      unat_power_lower Suc_1 inc_induct le_def less_eq_Suc_le lt1_neq0
                      not_degenerate_imp_2_neq_0 word_le_less_eq)
  done
done

declare string_of_word.simps[simp del]

lemma "hex_string_of_word0 (0xdeadbeef42 :: 42 word) = ''deadbeef42''" by eval

lemma "hex_string_of_word 1 (0x1 :: 5 word) = ''01''" by eval
lemma "hex_string_of_word 8 (0xff::32 word) = ''0000000ff''" by eval

lemma "dec_string_of_word0 (8::32 word) = ''8''" by eval
lemma "dec_string_of_word0 (3::2 word) = ''11''" by eval
lemma "dec_string_of_word0 (-1::8 word) = ''255''" by eval

lemma string_of_word_single_atoi:
  "n < 10 \<Longrightarrow> string_of_word_single True n = [char_of_nat (48 + unat n)]"
  by(simp add: string_of_word_single_def)

(*TODO: move!*)
lemma bintrunc_pos_eq: "x \<ge> 0 \<Longrightarrow> bintrunc n x = x \<longleftrightarrow> x < 2^n"
apply(rule iffI)
 subgoal using bintr_lt2p by metis
by (simp add: mod_pos_pos_trivial no_bintr_alt1; fail)

(*The following lemma [symmetric] as [code_unfold] may give some cool speedup*)
lemma string_of_word_base_ten_zeropad:
  fixes w ::"'a::len word"
  assumes lena: "len_of TYPE('a) \<ge> 5" (*word must be long enough to encode 10 = 0xA*)
  shows "base = 10 \<Longrightarrow> zero = 0 \<Longrightarrow> string_of_word True base zero w = string_of_nat (unat w)"
  proof(induction True base zero w rule: string_of_word.induct)
  case (1 base ml n)

  note  Word.word_less_no[simp del]
  note  Word.uint_bintrunc[simp del]

  have "5 \<le> n \<Longrightarrow> bintrunc n 10 = 10" for n
   apply(subst bintrunc_pos_eq)
    apply(simp; fail)
   apply(induction rule: Nat.dec_induct)
    by simp+
  with lena have unat_ten: "unat (0xA::'a::len word) = 10" by(simp)

  have "5 \<le> n \<Longrightarrow> bintrunc n 2 = 2" for n
   apply(subst bintrunc_pos_eq)
    apply(simp; fail)
   apply(induction rule: Nat.dec_induct)
    by simp+
  with lena have unat_two: "unat (2::'a::len word) = 2" by(simp)

  have unat_mod_ten: "unat (n mod 0xA) = unat n mod 10"
    apply(subst Word.unat_mod)
    apply(subst unat_ten)
    by(simp)

  have unat_div_ten: "(unat (n div 0xA)) = unat n div 10"
    apply(subst Word.unat_div)
    apply(subst unat_ten)
    by simp
  have n_less_ten_unat: "n < 0xA \<Longrightarrow> (unat n < 10)"
    apply(rule Word_Lemmas.unat_less_helper)
    by(simp)
  have "0xA \<le> n \<Longrightarrow> 10 \<le> unat n"
    apply(subst(asm) Word.word_le_nat_alt)
    apply(subst(asm) unat_ten)
    by(simp)
  hence n_less_ten_unat_not: "\<not> n < 0xA \<Longrightarrow> \<not> unat n < 10" by fastforce
  have not_wordlength_too_small: "\<not> len_of TYPE('a) < 2" using lena by fastforce
  have "2 \<le> (0xA::'a word)"
    apply(subst word_le_nat_alt)
    apply(subst unat_ten unat_two)
    apply(subst unat_two)
    by(simp)
  hence ten_not_less_two: "\<not> (0xA::'a word) < 2" by (simp add: Word.word_less_no Word.uint_bintrunc)
  with 1(2,3) have " \<not> (base < 2 \<or> len_of TYPE(32) < 2)"
    by(simp)
  with 1 not_wordlength_too_small have IH: "\<not> n < 0xA \<Longrightarrow> string_of_word True 0xA 0 (n div 0xA) = string_of_nat (unat (n div 0xA))"
    by(simp)
  show ?case
    apply(simp add: 1)
    apply(cases "n < 0xA")
     subgoal
     apply(subst(1) string_of_word.simps)
     apply(subst(1) string_of_nat.simps)
     apply(simp add: n_less_ten_unat)
     by(simp add: not_wordlength_too_small ten_not_less_two string_of_word_single_atoi)
    using sym[OF IH] apply(simp)
    apply(subst(1) string_of_word.simps)
    apply(simp)
    apply(subst(1) string_of_nat.simps)
    apply(simp)
    apply(simp add: not_wordlength_too_small ten_not_less_two)
    apply(subst string_of_word_single_atoi)
     apply(rule Word.word_mod_less_divisor)
     using unat_ten word_gt_0_no apply fastforce
    apply(simp add: unat_mod_ten)
    apply(rule sym)
    apply(drule n_less_ten_unat_not)
    apply(simp add: unat_div_ten)
    by (simp add: string_of_nat.simps)
qed

(*TODO: one for all words?*)
lemma dec_string_of_word0:
  "dec_string_of_word0 (w8:: 8 word) = string_of_nat (unat w8)"
  "dec_string_of_word0 (w16:: 16 word) = string_of_nat (unat w16)"
  "dec_string_of_word0 (w32:: 32 word) = string_of_nat (unat w32)"
  "dec_string_of_word0 (w64:: 64 word) = string_of_nat (unat w64)"
  "dec_string_of_word0 (w128:: 128 word) = string_of_nat (unat w128)"
  unfolding dec_string_of_word0_def
  using string_of_word_base_ten_zeropad by force+

end


(*by Lammich and Ammer*)
section \<open>Interface Usage Example\<close>
theory VEBT_Example
imports VEBT_Intf_Imperative VEBT_Example_Setup
begin

  subsection \<open>Test Program\<close>

  definition "test n xs ys \<equiv> do {
    t \<leftarrow> vebt_buildupi n;
    t \<leftarrow> mfold (\<lambda>x s. vebt_inserti s x) (0#xs) t;

    let f = (\<lambda>x. if\<^sub>m vebt_memberi t x then return x else the $\<^sub>m (vebt_predi t x));

    mmap f ys
  }"

  subsection \<open>Correctness without Time\<close>
  text \<open>The non-time part of our datastructure is fully integrated into sep-auto\<close>

  lemma fold_list_rl[sep_heap_rules]: "\<forall>x\<in>set xs. x<2^n \<Longrightarrow> hoare_triple
    (vebt_assn n s t)
    (mfold (\<lambda>x s. vebt_inserti s x) xs t)
    (\<lambda>t'. vebt_assn n (s \<union> set xs) t')"
  proof (induction xs arbitrary: s t)
    case Nil
    then show ?case by sep_auto
  next
    case (Cons a xs)

    note Cons.IH[sep_heap_rules]

    show ?case using Cons.prems
      by sep_auto

  qed

  lemma test_hoare: "\<lbrakk>\<forall>x\<in>set xs. x<2^n; n>0\<rbrakk> \<Longrightarrow>
      <emp> (test n xs ys) <\<lambda>r. \<up>(r = map (\<lambda>y. (GREATEST y'. y'\<in>insert 0 (set xs) \<and> y'\<le>y)) ys) >\<^sub>t "
    unfolding test_def
      supply R = mmap_pure_aux[where f="(\<lambda>y. (GREATEST y'. y'\<in>insert 0 (set xs) \<and> y'\<le>y))"]
      apply (sep_auto decon: R)
      subgoal
        by (metis (mono_tags, lifting) GreatestI_ex_nat zero_le_numeral)
      subgoal
        by (metis (no_types, lifting) Greatest_equality le_eq_less_or_eq)
      apply sep_auto
      subgoal
        apply (auto simp: is_pred_in_set_def)
        subgoal
          by (smt (z3) GreatestI_nat le_neq_implies_less less_eq_nat.simps(1))
        subgoal
          by (smt (z3) GreatestI_nat mult.right_neutral nat_less_le power_eq_0_iff power_mono_iff)
        subgoal
          by (metis (no_types, lifting) Greatest_le_nat less_imp_le)
      done
      apply sep_auto
    done

subsection \<open>Time Bound Reasoning\<close>
text \<open>
  We use some ad-hoc reasoning to also show the time-bound of our test program.
  A generalization of such methods, or the integration of this entry into existing
  reasoning frameworks with time is left to future work.
\<close>

lemma insert_time_pure[cond_TBOUND]:"a < 2^n \<Longrightarrow>
  \
vebt_assn n S ti\
 TBOUND (vebt_inserti ti a) (13 + 13 * nat \<lceil>log 2 (real n)\<rceil>)"
  by(rule htt_elim, rule vebt_inserti_rule, simp)

lemma member_time_pure[cond_TBOUND]:"\
vebt_assn n S ti\
 TBOUND (vebt_memberi ti a) (5 + 5 * nat \<lceil>log 2 (real n)\<rceil>)"
  by(rule htt_elim, rule  vebt_memberi_rule)

lemma pred_time_pure[cond_TBOUND]:"\
vebt_assn n S ti\
 TBOUND (vebt_predi ti a) (7 + 7 * nat \<lceil>log 2 (real n)\<rceil>)"
   by(rule htt_elim, rule  vebt_predi_rule)

lemma TBOUND_mfold[cond_TBOUND]:"
  (\<And> x. x \<in> set xs \<Longrightarrow> x < 2^n) \<Longrightarrow>
         \
 vebt_assn n S ti \
 TBOUND (mfold (\<lambda>x s. vebt_inserti s x) xs ti)  (length xs  * (13 + 13 * nat \<lceil>log 2 n \<rceil>) + 1)"
  apply(induction xs arbitrary: ti S)
   apply(subst mfold.simps)
   apply(cond_TBOUND, simp)
  apply sep_auto
  subgoal for a xs ti S
    apply(rule cond_TBOUND_mono[where b = "(13 + 13 * nat \<lceil>log 2 (real n)\<rceil>) + (length xs * (13 + 13 * nat \<lceil>log 2 (real n)\<rceil>) + 1)"])
    apply(rule cond_TBOUND, auto|(rule vebt_heap_rules(3), auto))+
    done
  done

lemma TBOUND_mmap[cond_TBOUND]:
  defines b_def: "b ys n \<equiv> 1 + length ys * ( 5 + 5 * nat \<lceil>log 2 (real n)\<rceil> + 9 + 7 * nat \<lceil>log 2 (real n)\<rceil>)"
  shows "\
 vebt_assn n S ti \
 TBOUND
        (mmap (\<lambda>x. if\<^sub>m vebt_memberi ti x then return x
                   else vebt_predi ti x \<bind> (\<lambda>x. return (the x))) ys) (b ys n)"
  apply(induction ys arbitrary:)
   apply(subst mmap.simps)
  subgoal
    unfolding b_def
    apply(rule cond_TBOUND_mono[where b = 1], rule cond_TBOUND_return, simp)
    done
  apply sep_auto
  subgoal for a ys
   apply(rule cond_TBOUND_mono[
       where b = "((5 + 5 * nat \<lceil>log 2 (real n)\<rceil>) + max  1 ((7 + 7 * nat \<lceil>log 2 (real n)\<rceil>) + 1))
        +(b ys n + 1)"])
     apply(rule cond_TBOUND_bind[where Q = "\<lambda> r. vebt_assn n S ti"])
    apply(rule cond_TBOUND | rule mmap_pres | sep_auto | rule cond_TBOUND_cons)+
    unfolding b_def
    apply simp
    done
  done

lemma TBOUND_test[cond_TBOUND]: "\<lbrakk>\<forall>x\<in>set xs. x<2^n; n>0 \<rbrakk> \<Longrightarrow>
       \
 \<up> (n> 0) \
 TBOUND (test n xs ys) (10 * 2^n  + (
                              ( length (0#xs)  * (13 + 13 * nat \<lceil>log 2 n \<rceil>) + 1) +
                              (1 + length ys * ( 5 + 5 * nat \<lceil>log 2 (real n)\<rceil> +  9 + 7 * nat \<lceil>log 2 (real n)\<rceil>))))"
  unfolding test_def
  apply(cond_TBOUND| rule htt_elim[OF vebt_buildupi_rule] | sep_auto)+
  done

lemma test_hoare_with_time: "\<lbrakk>\<forall>x\<in>set xs. x<2^n; n>0\<rbrakk> \<Longrightarrow>
    <emp> (test n xs ys) <\<lambda>r. \<up>(r = map (\<lambda>y. (GREATEST y'. y'\<in>insert 0 (set xs) \<and> y'\<le>y)) ys) * true >
    T[10 * 2 ^ n +
       (length (0 # xs) * (13 + 13 * nat \<lceil>log 2 (real n)\<rceil>) + 1 +
        (1 + length ys * (5 + 5 * nat \<lceil>log 2 (real n)\<rceil> + 9 + 7 * nat \<lceil>log 2 (real n)\<rceil>)))]"
  apply(rule htt_intro, rule test_hoare, simp+)
  apply(rule cond_TBOUND_mono, rule cond_TBOUND_cons)
  defer
  apply(rule TBOUND_test, simp+)
  done

end


(* Title: Refinement KAT
   Author: Georg Struth
*)

section \<open>Refinement KAT\<close>

theory RC
  imports HL

begin

subsection \<open>Order Preservation of Conditionals and Loops\<close>

context kat
begin

lemma cond_iso:
  assumes "x \<le> x'"
  and "y \<le> y'"
shows "if p then x else y fi \<le> if p then x' else y' fi"
  sorry

lemma while_iso:
  assumes "x \<le> y"
  shows "while p do x od \<le> while p do y od"
  sorry
end

subsection \<open>Definition of refinement KAT\<close>

text \<open>A refinement KAT is a KAT expanded by Morgan's specification statement.\<close>

class rkat = kat +
  fixes Re :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes spec_def:  "(x \<le> Re p q) = Ho p x q"

begin

lemma R1: "Ho p (Re p q) q"
  sorry

lemma R2: "Ho p x q \<Longrightarrow> x \<le> Re p q"
  sorry

lemma R_demmod: "(x \<le> Re p q) = (\<tau> p \<cdot> x \<le> x \<cdot> \<tau> q)"
  sorry

subsection \<open>Propositional Refinement Calculus\<close>

lemma R_skip: "1 \<le> Re p p"
  sorry

lemma R_cons:
  assumes "\<tau> p \<le> \<tau> p'"
  and "\<tau> q' \<le> \<tau> q"
  shows "Re p' q' \<le> Re p q"
  sorry

lemma R_seq: "Re p r \<cdot> Re r q \<le> Re p q"
  sorry

lemma R_cond: "if v then Re (\<tau> p \<cdot> \<tau> v) q else Re (\<tau> p \<cdot> \<alpha> v) q fi \<le> Re p q"
  sorry

lemma R_while: "while q do Re (\<tau> p \<cdot> \<tau> q) p od \<le> Re p (\<tau> p \<cdot> \<alpha> q)"
  sorry

lemma R_zero_one: "x \<le> Re 0 1"
  sorry

lemma R_one_zero: "Re 1 0 = 0"
  sorry

lemma R_while_inv: "\<tau> p \<le> \<tau> i \<Longrightarrow>  \<alpha> t \<cdot> \<tau> i \<le> \<tau> q \<Longrightarrow> while t do Re (\<tau> t \<cdot> \<tau> i) i od \<le> Re p q"
  sorry

end

subsection \<open>Models of Refinement KAT\<close>

definition rel_Re :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_Re P Q = \<Union>{R. rel_kat.Ho P R Q}"

interpretation rel_rkat: rkat "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl "\<alpha>\<^sub>r" rel_Re
  sorry

definition sta_Re :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" where
  "(sta_Re P Q) x = \<Union>{f x|f. sta_kat.Ho P f Q}"

interpretation sta_rkat: rkat "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar "\<alpha>\<^sub>s" sta_Re
  sorry

subsection \<open>Specialised Refinement Laws\<close>

text \<open>First we consider the relational model.\<close>

abbreviation rR :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel" ("R\<^sub>r") where
   "R\<^sub>r P Q \<equiv> rel_Re \<lceil>P\<rceil>\<^sub>r \<lceil>Q\<rceil>\<^sub>r"

lemma rR_unfold: "R\<^sub>r P Q = \<Union>{R. \<forall>x y. P x \<longrightarrow> (x,y) \<in> R \<longrightarrow> Q y}"
  sorry

lemma rR_cons1:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  shows "R\<^sub>r P' Q \<subseteq> R\<^sub>r P Q"
  sorry

lemma rR_cons2:
  assumes "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>r P Q' \<subseteq> R\<^sub>r P Q"
  sorry

lemma rR_cons:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  and "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>r P' Q' \<subseteq> R\<^sub>r P Q"
  sorry

lemma rR_skip [simp]: "(Id \<subseteq> R\<^sub>r P Q) = (\<forall>s. P s \<longrightarrow> Q s)"
  sorry

lemma rR_cond: "rif T then R\<^sub>r (\<lambda>s. P s \<and> T s) Q else R\<^sub>r (\<lambda>s. P s \<and> \<not>T s) Q fi \<subseteq> R\<^sub>r P Q"
  sorry

lemma rR_cond_var:
  assumes "R \<subseteq> R\<^sub>r (\<lambda>s. P s \<and> T s) Q"
  and "S \<subseteq> R\<^sub>r (\<lambda>s. P s \<and> \<not>T s) Q"
  shows "rif T then R else S fi \<subseteq> R\<^sub>r P Q"
  sorry

lemma rR_while: "rwhile Q do R\<^sub>r (\<lambda>s. P s \<and> Q s) P od \<subseteq> R\<^sub>r P (\<lambda>s. P s \<and> \<not> Q s)"
  sorry

lemma rR_while_var:
  assumes "R \<subseteq> R\<^sub>r (\<lambda>s. P s \<and> Q s) P"
  shows "rwhile Q do R od \<subseteq> R\<^sub>r P (\<lambda>s. P s \<and> \<not> Q s)"
  sorry

text \<open>Next we consider the state transformer model.\<close>

abbreviation sR :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a sta" ("R\<^sub>s") where
   "R\<^sub>s P Q \<equiv> sta_Re \<lceil>P\<rceil>\<^sub>s \<lceil>Q\<rceil>\<^sub>s"

lemma sR_unfold: "(R\<^sub>s P Q) x = \<Union>{f x |f.  \<forall>y z. P y \<longrightarrow> z \<in> f y \<longrightarrow> Q z}"
  sorry

lemma sR_cons1:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  shows "R\<^sub>s P' Q \<sqsubseteq> R\<^sub>s P Q"
  sorry

lemma sR_cons2:
  assumes "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>s P Q' \<sqsubseteq> R\<^sub>s P Q"
  sorry

lemma sR_cons:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  and "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>s P' Q' \<sqsubseteq> R\<^sub>s P Q"
  sorry

lemma scond_iso:
  assumes "f \<sqsubseteq> f'"
  and "g \<sqsubseteq> g'"
  shows "sif P then f else g fi \<sqsubseteq> sif P then f' else g' fi"
  sorry

lemma swhile_iso:
  assumes "f \<sqsubseteq> f'"
  shows "swhile P do f od \<sqsubseteq> swhile P do f' od"
  sorry

lemma sR_skip: "\<eta> \<sqsubseteq> R\<^sub>s P Q = (\<forall>s. P s \<longrightarrow> Q s)"
  sorry

lemma sR_cond: "sif T then R\<^sub>s (\<lambda>s. P s \<and> T s) Q else R\<^sub>s (\<lambda>s. P s \<and> \<not>T s) Q fi \<sqsubseteq> R\<^sub>s P Q"
  sorry

lemma sR_cond_var:
  assumes "f \<sqsubseteq> R\<^sub>s (\<lambda>s. P s \<and> T s) Q"
  and "g \<sqsubseteq> R\<^sub>s (\<lambda>s. P s \<and> \<not>T s) Q"
  shows "sif T then f else g fi \<sqsubseteq> R\<^sub>s P Q"
  sorry

lemma sR_while: "swhile Q do R\<^sub>s (\<lambda>s. P s \<and> Q s) P od \<sqsubseteq> R\<^sub>s P (\<lambda>s. P s \<and> \<not> Q s)"
  sorry

lemma sR_while_var:
  assumes "f \<sqsubseteq> R\<^sub>s (\<lambda>s. P s \<and> Q s) P"
  shows "swhile Q do f od \<sqsubseteq> R\<^sub>s P (\<lambda>s. P s \<and> \<not> Q s)"
  sorry

subsection \<open>Assignment Laws\<close>

text \<open>The store model is from KAT\<close>

lemma rR_assign [simp]: "((v :=\<^sub>r e) \<subseteq> R\<^sub>r P Q) = (\<forall>s. P s \<longrightarrow> Q (set v e s))"
  sorry

lemma rR_assignl:
  assumes "\<forall>s. P s \<longrightarrow> P' (set v e s)"
  shows "(v :=\<^sub>r e) ; (R\<^sub>r P' Q) \<subseteq> R\<^sub>r P Q"
  sorry

lemma rR_assignr:
  assumes "\<forall>s. Q' s \<longrightarrow> Q (set v e s)"
  shows "(R\<^sub>r P Q') ; (v :=\<^sub>r e) \<subseteq> R\<^sub>r P Q"
  sorry

lemma sR_assign [simp]: "(\<forall>s. P s \<longrightarrow> Q (set v e s)) = ((v :=\<^sub>s e) \<sqsubseteq> R\<^sub>s P Q)"
  sorry

lemma sR_assignr:
  assumes "\<forall>s. Q' s \<longrightarrow> Q (set v e s)"
  shows "(R\<^sub>s P Q') \<circ>\<^sub>K (v :=\<^sub>s e) \<sqsubseteq> R\<^sub>s P Q"
  sorry

lemma sR_assignl:
  assumes "\<forall>s. P s \<longrightarrow> P' (set v e s)"
  shows "(v :=\<^sub>s e) \<circ>\<^sub>K (R\<^sub>s P' Q) \<sqsubseteq> R\<^sub>s P Q"
  sorry

subsection \<open>Refinement Examples\<close>

text \<open>Variable Swap\<close>

lemma var_swap_ref1:
  "R\<^sub>r (\<lambda>s. s ''x'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''z'' :=\<^sub>r (\<lambda>s. s ''x'')); R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  sorry

lemma var_swap_ref2:
  "R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''x'' :=\<^sub>r (\<lambda>s. s ''y'')); R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''x'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  sorry

lemma var_swap_ref3:
  "R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''x'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''y'' :=\<^sub>r (\<lambda>s. s ''z'')); R\<^sub>r (\<lambda>s. s ''x'' = b \<and> s ''y'' = a) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  sorry

lemma var_swap_ref:
  "R\<^sub>r (\<lambda>s. s ''x'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''z'' :=\<^sub>r (\<lambda>s. s ''x'')) ; (''x'' :=\<^sub>r (\<lambda>s. s ''y'')) ; (''y'' :=\<^sub>r (\<lambda>s. s ''z''))"
  sorry

text \<open>Maximum\<close>

lemma max1:
  "R\<^sub>r (\<lambda>s::int store. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
   \<supseteq> R\<^sub>r (\<lambda>s. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''y'' \<le> s ''x'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''x''))"
sorry
lemma max11:
  "R\<^sub>r (\<lambda>s. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''y'' \<le> s ''x'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''x''))
  \<supseteq> ''z'' :=\<^sub>r (\<lambda>s. s ''x'')"
  sorry
lemma max2:
  "R\<^sub>r (\<lambda>s::int store. s ''x'' < s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
   \<supseteq> R\<^sub>r (\<lambda>s. s ''x'' < s ''y'') (\<lambda>s. s ''x'' < s ''y'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''y''))"
  sorry
lemma max21:
  "R\<^sub>r (\<lambda>s. s ''x'' < s ''y'') (\<lambda>s. s ''x'' < s ''y'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''y''))
  \<supseteq> ''z'' :=\<^sub>r (\<lambda>s. s ''y'')"
  sorry
lemma max_cond:
"R\<^sub>r (\<lambda>s::int store. True) (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
\<supseteq> rif (\<lambda>s. s ''x'' \<ge> s ''y'')
     then (R\<^sub>r (\<lambda>s. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')))
     else (R\<^sub>r (\<lambda>s. s ''x'' < s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')))
   fi"
  sorry
lemma maximum:
   "R\<^sub>r (\<lambda>s::int store. True) (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
   \<supseteq> (rif (\<lambda>s. s ''x'' \<ge> s ''y'')
         then (''z'' :=\<^sub>r (\<lambda>s. s ''x''))
         else (''z'' :=\<^sub>r (\<lambda>s. s ''y''))
       fi)"
  sorry

text \<open>Integer Division\<close>

abbreviation "Idiv s \<equiv> s ''x'' = s ''q'' * s ''y'' + s ''r''"

abbreviation "Tdiv s \<equiv> s ''y'' \<le> s ''r''"

lemma div_init1: "R\<^sub>r (\<lambda>s::nat store. 0 < s ''y'') (\<lambda>s. Idiv s  \<and> \<not>Tdiv s) \<supseteq>
  (''r'' :=\<^sub>r (\<lambda>s. s ''x''));
  R\<^sub>r (\<lambda>s. s ''r'' = s ''x'' \<and> s ''x'' \<ge> 0) (\<lambda>s. Idiv s \<and> \<not>Tdiv s)"
  sorry

lemma div_init2: "R\<^sub>r (\<lambda>s::nat store. s ''r'' = s ''x'') (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  (''q'' :=\<^sub>r (\<lambda>s. 0));
  R\<^sub>r (\<lambda>s. s ''r'' = s ''x'' \<and> s ''q'' = 0) (\<lambda>s. Idiv s \<and> \<not> Tdiv s)"
  sorry

lemma div_init3:
  "R\<^sub>r (\<lambda>s::nat store. s ''r'' = s ''x'' \<and> s ''q'' = 0) (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  R\<^sub>r Idiv (\<lambda>s. Idiv s \<and> \<not> Tdiv s)"
  sorry

lemma div_loop: "R\<^sub>r Idiv (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  rwhile Tdiv do (R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) Idiv) od"
  sorry

lemma div_body1: "R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) Idiv \<supseteq>
  R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) (\<lambda>s::nat store. s ''x'' = s ''q'' * s ''y'' + (s ''r'' - s ''y'')) ;
  (''r'' :=\<^sub>r (\<lambda>s. s ''r'' - s ''y''))"
  sorry

lemma div_body2:
  "R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) (\<lambda>s::nat store. s ''x'' = s ''q'' * s ''y'' + (s ''r'' - s ''y'')) \<supseteq>
  R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) (\<lambda>s. Idiv s \<and>  Tdiv s) ; (''q'' :=\<^sub>r (\<lambda>s. s ''q'' + 1))"
  sorry

lemma div_while: "rwhile Tdiv do R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) Idiv od \<supseteq>
  rwhile Tdiv do
    (''q'' :=\<^sub>r (\<lambda>f. f ''q'' + (1::nat)));
    (''r'' :=\<^sub>r (\<lambda>f. f ''r'' - f ''y''))
  od"
  sorry

lemma integer_division: "R\<^sub>r (\<lambda>s::nat store. 0 < s ''y'') (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  (''r'' :=\<^sub>r (\<lambda>s. s ''x''));
  (''q'' :=\<^sub>r (\<lambda>s. 0));
  (rwhile Tdiv do
      (''q'' :=\<^sub>r (\<lambda>s::nat store. s ''q'' + 1));
      (''r'' :=\<^sub>r (\<lambda>s. s ''r'' - s ''y''))
  od)"
  sorry

end


(* Author: Various *)

section {* Combination and Cancellation Simprocs for Numeral Expressions *}

theory Numeral_Simprocs
imports Divides
begin

ML_file "~~/src/Provers/Arith/assoc_fold.ML"
ML_file "~~/src/Provers/Arith/cancel_numerals.ML"
ML_file "~~/src/Provers/Arith/combine_numerals.ML"
ML_file "~~/src/Provers/Arith/cancel_numeral_factor.ML"
ML_file "~~/src/Provers/Arith/extract_common_term.ML"

lemmas semiring_norm =
  Let_def arith_simps diff_nat_numeral rel_simps
  if_False if_True
  add_0 add_Suc add_numeral_left
  add_neg_numeral_left mult_numeral_left
  numeral_One [symmetric] uminus_numeral_One [symmetric] Suc_eq_plus1
  eq_numeral_iff_iszero not_iszero_Numeral1

declare split_div [of _ _ "numeral k", arith_split] for k
declare split_mod [of _ _ "numeral k", arith_split] for k

text {* For @{text combine_numerals} *}

lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
by (simp add: add_mult_distrib)

text {* For @{text cancel_numerals} *}

lemma nat_diff_add_eq1:
     "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
by (simp split add: nat_diff_split add: add_mult_distrib)

lemma nat_diff_add_eq2:
     "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
by (simp split add: nat_diff_split add: add_mult_distrib)

lemma nat_eq_add_iff1:
     "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
by (auto split add: nat_diff_split simp add: add_mult_distrib)

lemma nat_eq_add_iff2:
     "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
by (auto split add: nat_diff_split simp add: add_mult_distrib)

lemma nat_less_add_iff1:
     "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
by (auto split add: nat_diff_split simp add: add_mult_distrib)

lemma nat_less_add_iff2:
     "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
by (auto split add: nat_diff_split simp add: add_mult_distrib)

lemma nat_le_add_iff1:
     "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
by (auto split add: nat_diff_split simp add: add_mult_distrib)

lemma nat_le_add_iff2:
     "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
by (auto split add: nat_diff_split simp add: add_mult_distrib)

text {* For @{text cancel_numeral_factors} *}

lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
by auto

lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
by auto

lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
by auto

lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
by auto

lemma nat_mult_dvd_cancel_disj[simp]:
  "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
by (auto simp: dvd_eq_mod_eq_0 mod_mult_mult1)

lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
by(auto)

text {* For @{text cancel_factor} *}

lemmas nat_mult_le_cancel_disj = mult_le_cancel1

lemmas nat_mult_less_cancel_disj = mult_less_cancel1

lemma nat_mult_eq_cancel_disj:
  fixes k m n :: nat
  shows "k * m = k * n \<longleftrightarrow> k = 0 \<or> m = n"
  by auto

lemma nat_mult_div_cancel_disj [simp]:
  fixes k m n :: nat
  shows "(k * m) div (k * n) = (if k = 0 then 0 else m div n)"
  by (fact div_mult_mult1_if)

ML_file "Tools/numeral_simprocs.ML"

simproc_setup semiring_assoc_fold
  ("(a::'a::comm_semiring_1_cancel) * b") =
  {* fn phi => Numeral_Simprocs.assoc_fold *}

(* TODO: see whether the type class can be generalized further *)
simproc_setup int_combine_numerals
  ("(i::'a::comm_ring_1) + j" | "(i::'a::comm_ring_1) - j") =
  {* fn phi => Numeral_Simprocs.combine_numerals *}

simproc_setup field_combine_numerals
  ("(i::'a::{field_inverse_zero,ring_char_0}) + j"
  |"(i::'a::{field_inverse_zero,ring_char_0}) - j") =
  {* fn phi => Numeral_Simprocs.field_combine_numerals *}

simproc_setup inteq_cancel_numerals
  ("(l::'a::comm_ring_1) + m = n"
  |"(l::'a::comm_ring_1) = m + n"
  |"(l::'a::comm_ring_1) - m = n"
  |"(l::'a::comm_ring_1) = m - n"
  |"(l::'a::comm_ring_1) * m = n"
  |"(l::'a::comm_ring_1) = m * n"
  |"- (l::'a::comm_ring_1) = m"
  |"(l::'a::comm_ring_1) = - m") =
  {* fn phi => Numeral_Simprocs.eq_cancel_numerals *}

simproc_setup intless_cancel_numerals
  ("(l::'a::linordered_idom) + m < n"
  |"(l::'a::linordered_idom) < m + n"
  |"(l::'a::linordered_idom) - m < n"
  |"(l::'a::linordered_idom) < m - n"
  |"(l::'a::linordered_idom) * m < n"
  |"(l::'a::linordered_idom) < m * n"
  |"- (l::'a::linordered_idom) < m"
  |"(l::'a::linordered_idom) < - m") =
  {* fn phi => Numeral_Simprocs.less_cancel_numerals *}

simproc_setup intle_cancel_numerals
  ("(l::'a::linordered_idom) + m \<le> n"
  |"(l::'a::linordered_idom) \<le> m + n"
  |"(l::'a::linordered_idom) - m \<le> n"
  |"(l::'a::linordered_idom) \<le> m - n"
  |"(l::'a::linordered_idom) * m \<le> n"
  |"(l::'a::linordered_idom) \<le> m * n"
  |"- (l::'a::linordered_idom) \<le> m"
  |"(l::'a::linordered_idom) \<le> - m") =
  {* fn phi => Numeral_Simprocs.le_cancel_numerals *}

simproc_setup ring_eq_cancel_numeral_factor
  ("(l::'a::{idom,ring_char_0}) * m = n"
  |"(l::'a::{idom,ring_char_0}) = m * n") =
  {* fn phi => Numeral_Simprocs.eq_cancel_numeral_factor *}

simproc_setup ring_less_cancel_numeral_factor
  ("(l::'a::linordered_idom) * m < n"
  |"(l::'a::linordered_idom) < m * n") =
  {* fn phi => Numeral_Simprocs.less_cancel_numeral_factor *}

simproc_setup ring_le_cancel_numeral_factor
  ("(l::'a::linordered_idom) * m <= n"
  |"(l::'a::linordered_idom) <= m * n") =
  {* fn phi => Numeral_Simprocs.le_cancel_numeral_factor *}

(* TODO: remove comm_ring_1 constraint if possible *)
simproc_setup int_div_cancel_numeral_factors
  ("((l::'a::{semiring_div,comm_ring_1,ring_char_0}) * m) div n"
  |"(l::'a::{semiring_div,comm_ring_1,ring_char_0}) div (m * n)") =
  {* fn phi => Numeral_Simprocs.div_cancel_numeral_factor *}

simproc_setup divide_cancel_numeral_factor
  ("((l::'a::{field_inverse_zero,ring_char_0}) * m) / n"
  |"(l::'a::{field_inverse_zero,ring_char_0}) / (m * n)"
  |"((numeral v)::'a::{field_inverse_zero,ring_char_0}) / (numeral w)") =
  {* fn phi => Numeral_Simprocs.divide_cancel_numeral_factor *}

simproc_setup ring_eq_cancel_factor
  ("(l::'a::idom) * m = n" | "(l::'a::idom) = m * n") =
  {* fn phi => Numeral_Simprocs.eq_cancel_factor *}

simproc_setup linordered_ring_le_cancel_factor
  ("(l::'a::linordered_idom) * m <= n"
  |"(l::'a::linordered_idom) <= m * n") =
  {* fn phi => Numeral_Simprocs.le_cancel_factor *}

simproc_setup linordered_ring_less_cancel_factor
  ("(l::'a::linordered_idom) * m < n"
  |"(l::'a::linordered_idom) < m * n") =
  {* fn phi => Numeral_Simprocs.less_cancel_factor *}

simproc_setup int_div_cancel_factor
  ("((l::'a::semiring_div) * m) div n"
  |"(l::'a::semiring_div) div (m * n)") =
  {* fn phi => Numeral_Simprocs.div_cancel_factor *}

simproc_setup int_mod_cancel_factor
  ("((l::'a::semiring_div) * m) mod n"
  |"(l::'a::semiring_div) mod (m * n)") =
  {* fn phi => Numeral_Simprocs.mod_cancel_factor *}

simproc_setup dvd_cancel_factor
  ("((l::'a::idom) * m) dvd n"
  |"(l::'a::idom) dvd (m * n)") =
  {* fn phi => Numeral_Simprocs.dvd_cancel_factor *}

simproc_setup divide_cancel_factor
  ("((l::'a::field_inverse_zero) * m) / n"
  |"(l::'a::field_inverse_zero) / (m * n)") =
  {* fn phi => Numeral_Simprocs.divide_cancel_factor *}

ML_file "Tools/nat_numeral_simprocs.ML"

simproc_setup nat_combine_numerals
  ("(i::nat) + j" | "Suc (i + j)") =
  {* fn phi => Nat_Numeral_Simprocs.combine_numerals *}

simproc_setup nateq_cancel_numerals
  ("(l::nat) + m = n" | "(l::nat) = m + n" |
   "(l::nat) * m = n" | "(l::nat) = m * n" |
   "Suc m = n" | "m = Suc n") =
  {* fn phi => Nat_Numeral_Simprocs.eq_cancel_numerals *}

simproc_setup natless_cancel_numerals
  ("(l::nat) + m < n" | "(l::nat) < m + n" |
   "(l::nat) * m < n" | "(l::nat) < m * n" |
   "Suc m < n" | "m < Suc n") =
  {* fn phi => Nat_Numeral_Simprocs.less_cancel_numerals *}

simproc_setup natle_cancel_numerals
  ("(l::nat) + m \<le> n" | "(l::nat) \<le> m + n" |
   "(l::nat) * m \<le> n" | "(l::nat) \<le> m * n" |
   "Suc m \<le> n" | "m \<le> Suc n") =
  {* fn phi => Nat_Numeral_Simprocs.le_cancel_numerals *}

simproc_setup natdiff_cancel_numerals
  ("((l::nat) + m) - n" | "(l::nat) - (m + n)" |
   "(l::nat) * m - n" | "(l::nat) - m * n" |
   "Suc m - n" | "m - Suc n") =
  {* fn phi => Nat_Numeral_Simprocs.diff_cancel_numerals *}

simproc_setup nat_eq_cancel_numeral_factor
  ("(l::nat) * m = n" | "(l::nat) = m * n") =
  {* fn phi => Nat_Numeral_Simprocs.eq_cancel_numeral_factor *}

simproc_setup nat_less_cancel_numeral_factor
  ("(l::nat) * m < n" | "(l::nat) < m * n") =
  {* fn phi => Nat_Numeral_Simprocs.less_cancel_numeral_factor *}

simproc_setup nat_le_cancel_numeral_factor
  ("(l::nat) * m <= n" | "(l::nat) <= m * n") =
  {* fn phi => Nat_Numeral_Simprocs.le_cancel_numeral_factor *}

simproc_setup nat_div_cancel_numeral_factor
  ("((l::nat) * m) div n" | "(l::nat) div (m * n)") =
  {* fn phi => Nat_Numeral_Simprocs.div_cancel_numeral_factor *}

simproc_setup nat_dvd_cancel_numeral_factor
  ("((l::nat) * m) dvd n" | "(l::nat) dvd (m * n)") =
  {* fn phi => Nat_Numeral_Simprocs.dvd_cancel_numeral_factor *}

simproc_setup nat_eq_cancel_factor
  ("(l::nat) * m = n" | "(l::nat) = m * n") =
  {* fn phi => Nat_Numeral_Simprocs.eq_cancel_factor *}

simproc_setup nat_less_cancel_factor
  ("(l::nat) * m < n" | "(l::nat) < m * n") =
  {* fn phi => Nat_Numeral_Simprocs.less_cancel_factor *}

simproc_setup nat_le_cancel_factor
  ("(l::nat) * m <= n" | "(l::nat) <= m * n") =
  {* fn phi => Nat_Numeral_Simprocs.le_cancel_factor *}

simproc_setup nat_div_cancel_factor
  ("((l::nat) * m) div n" | "(l::nat) div (m * n)") =
  {* fn phi => Nat_Numeral_Simprocs.div_cancel_factor *}

simproc_setup nat_dvd_cancel_factor
  ("((l::nat) * m) dvd n" | "(l::nat) dvd (m * n)") =
  {* fn phi => Nat_Numeral_Simprocs.dvd_cancel_factor *}

declaration {*
  K (Lin_Arith.add_simprocs
      [@{simproc semiring_assoc_fold},
       @{simproc int_combine_numerals},
       @{simproc inteq_cancel_numerals},
       @{simproc intless_cancel_numerals},
       @{simproc intle_cancel_numerals},
       @{simproc field_combine_numerals}]
  #> Lin_Arith.add_simprocs
      [@{simproc nat_combine_numerals},
       @{simproc nateq_cancel_numerals},
       @{simproc natless_cancel_numerals},
       @{simproc natle_cancel_numerals},
       @{simproc natdiff_cancel_numerals}])
*}

end


section \<open>Shorter Solution\<close>
theory Challenge1_short
imports "lib/VTcomp"
begin

text \<open>Small specification of textbuffer ADT,
  and its implementation by a gap buffer.

  Annotated and elaborated version of just the challenge requirements.
\<close>
subsection \<open>Abstract Specification\<close>

  datatype 'a textbuffer = BUF ("pos": "nat") ("text": "'a list")
  \<comment> \<open>Note that we do not model the abstract invariant --- pos in range --- here,
    as it is not strictly required for the challenge spec.\<close>

  text \<open>These are the operations that were specified in the challenge.
    Note: Isabelle has type inference, so we do not need to specify types.
    Note: We exploit that, in Isabelle, we have @{lemma "(0::nat)-1=0" by simp}.
  \<close>
  primrec move_left where "move_left (BUF p t) = BUF (p-1) t"
  primrec move_right where "move_right (BUF p t) = BUF (min (length t) (p+1)) t"
  primrec insert where "insert x (BUF p t) = BUF (p+1) (take p t@x#drop p t)"
  primrec delete where "delete (BUF p t) = BUF (p-1) (take (p-1) t@drop p t)"

subsection \<open>Refinement 1: List with Gap\<close>

  subsection \<open>Implementation on List-Level\<close>
  type_synonym 'a gap_buffer = "nat \<times> nat \<times> 'a list"

  subsubsection \<open>Abstraction Relation\<close>
  text \<open>We define an invariant on the concrete gap-buffer, and its mapping to the
    abstract model. From these two, we define a relation \<open>gap_rel\<close> between
    concrete and abstract buffers. \<close>
  definition "gap_\<alpha> \<equiv> \<lambda>(l,r,buf). BUF l (take l buf @ drop r buf)"
  definition "gap_invar \<equiv> \<lambda>(l,r,buf). l\<le>r \<and> r\<le>length buf"
  abbreviation "gap_rel \<equiv> br gap_\<alpha> gap_invar"

  subsubsection \<open>Left\<close>

  text \<open>For the operations, we insert assertions. These are not required to prove
    the list-level specification correct (during the proof, they are inferred easily).
    However, they are required in the subsequent automatic refinement step to arrays,
    to give our tool the information that all indexes are, indeed, in bounds.\<close>

  definition "move_left1 \<equiv> \<lambda>(l,r,buf). doN {
    if l\<noteq>0 then doN {
      ASSERT(r-1<length buf \<and> l-1<length buf);
      RETURN (l-1,r-1,buf[r-1:=buf!(l-1)])
    } else RETURN (l,r,buf)
  }"

  lemma move_left1_correct:
    "(move_left1, RETURN o move_left) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding move_left1_def
    apply refine_vcg
    apply (auto
      simp: in_br_conv gap_\<alpha>_def gap_invar_def move_left1_def
      split: prod.splits)
    (* sledgehammer! *)
    by (smt Cons_nth_drop_Suc Suc_pred append.assoc append_Cons append_Nil
      diff_Suc_less drop_update_cancel hd_drop_conv_nth length_list_update
      less_le_trans nth_list_update_eq take_hd_drop)

  subsubsection \<open>Right\<close>
  definition "move_right1 \<equiv> \<lambda>(l,r,buf). doN {
    if r<length buf then doN {
      ASSERT (l<length buf);
      RETURN (l+1,r+1,buf[l:=buf!r])
    } else RETURN (l,r,buf)
  }"

  lemma move_right1_correct:
    "(move_right1,RETURN o move_right) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding move_right1_def
    apply refine_vcg
    unfolding gap_\<alpha>_def gap_invar_def
    apply (auto simp: in_br_conv split: prod.split)
    (* sledgehammer *)
    by (metis Cons_eq_appendI Cons_nth_drop_Suc append_eq_append_conv2
      atd_lem drop_0 dual_order.strict_trans2 take_eq_Nil take_update_last)
    (* Manual: by (simp add: hd_drop_conv_nth take_update_last Cons_nth_drop_Suc) *)

  subsubsection \<open>Insert and Grow\<close>

  definition "can_insert \<equiv> \<lambda>(l,r,buf). l<r"

  definition "grow1 K \<equiv> \<lambda>(l,r,buf). doN {
    let b = op_array_replicate (length buf + K) default;
    b \<leftarrow> mop_list_blit buf 0 b 0 l;
    b \<leftarrow> mop_list_blit buf r b (r+K) (length buf - r);
    RETURN (l,r+K,b)
  }"
  \<comment> \<open>Note: Most operations have also a variant prefixed with \<open>mop\<close>.
    These are defined in the refinement monad and already contain the assertion
    of their precondition. The backside is that they cannot be easily used in as part
    of expressions, e.g., in @{term "buf[l:=buf!r]"}, we would have to explicitly bind
    each intermediate value: @{term "doN { v \<leftarrow> mop_list_get buf r; mop_list_set buf l v }"}.
  \<close>

  lemma grow1_correct[THEN SPEC_trans, refine_vcg]:
    \<comment> \<open>Declares this as a rule to be used by the VCG\<close>
    assumes "gap_invar gb"
    shows "grow1 K gb \<le> (SPEC (\<lambda>gb'.
        gap_invar gb'
      \<and> gap_\<alpha> gb' = gap_\<alpha> gb
      \<and> (K>0 \<longrightarrow> can_insert gb')))"
    unfolding grow1_def
    apply refine_vcg
    using assms
    unfolding gap_\<alpha>_def gap_invar_def can_insert_def
    apply clarsimp_all
    apply (auto simp: op_list_blit_def)
    by (simp add: min_def)

  definition "insert1 x \<equiv> \<lambda>(l,r,buf). doN {
    (l,r,buf) \<leftarrow>
      if (l=r) then grow1 (length buf+1) (l,r,buf) else RETURN (l,r,buf);
    ASSERT (l<length buf);
    RETURN (l+1,r,buf[l:=x])
  }"

  lemma insert1_correct:
    "(insert1,RETURN oo insert) \<in> Id \<rightarrow> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding insert1_def
    apply refine_vcg \<comment> \<open>VCG knows the rule for grow1 already\<close>
    unfolding insert_def gap_\<alpha>_def gap_invar_def can_insert_def
    apply (auto simp: in_br_conv take_update_last split: prod.split)
    done

  subsubsection \<open>Delete\<close>
  definition "delete1
    \<equiv> \<lambda>(l,r,buf). if l>0 then RETURN (l-1,r,buf) else RETURN (l,r,buf)"
  lemma delete1_correct:
    "(delete1,RETURN o delete) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding delete1_def
    apply refine_vcg
    unfolding gap_\<alpha>_def gap_invar_def
    by (auto simp: in_br_conv butlast_take split: prod.split)

subsection \<open>Imperative Arrays\<close>
  text \<open>The following indicates how we will further refine the gap-buffer:
    The list will become an array, the indices and the content will not be
    refined (expressed by @{const nat_assn} and @{const id_assn}).
  \<close>
  abbreviation "gap_impl_assn \<equiv> nat_assn \<times>\<^sub>a nat_assn \<times>\<^sub>a array_assn id_assn"

  sepref_definition move_left_impl
    is move_left1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
    unfolding move_left1_def by sepref

  sepref_definition move_right_impl
    is move_right1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
    unfolding move_right1_def by sepref

  sepref_definition insert_impl
    is "uncurry insert1" :: "id_assn\<^sup>k*\<^sub>agap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
    unfolding insert1_def grow1_def by sepref
    \<comment> \<open>We inline @{const grow1} here\<close>

  sepref_definition delete_impl
    is delete1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
    unfolding delete1_def by sepref

  text \<open>Finally, we combine the two refinement steps, to get overall correctness theorems\<close>
  definition "gap_assn \<equiv> hr_comp gap_impl_assn gap_rel"
    \<comment> \<open>@{const hr_comp} is composition of refinement relations\<close>
  context notes gap_assn_def[symmetric,fcomp_norm_unfold] begin
    lemmas move_left_impl_correct = move_left_impl.refine[FCOMP move_left1_correct]
       and move_right_impl_correct = move_right_impl.refine[FCOMP move_right1_correct]
       and insert_impl_correct = insert_impl.refine[FCOMP insert1_correct]
       and delete_impl_correct = delete_impl.refine[FCOMP delete1_correct]
    text \<open>Proves:
      @{thm [display] move_left_impl_correct}
      @{thm [display] move_right_impl_correct}
      @{thm [display] insert_impl_correct}
      @{thm [display] delete_impl_correct}
    \<close>

  end

subsection \<open>Executable Code\<close>
  text \<open>Isabelle/HOL can generate code in various target languages.\<close>

  export_code move_left_impl move_right_impl insert_impl delete_impl
    in SML_imp module_name Gap_Buffer
    in OCaml_imp module_name Gap_Buffer
    in Haskell module_name Gap_Buffer
    in Scala module_name Gap_Buffer

end


(*  Title:      HOL/ATP.thy
    Author:     Fabian Immler, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Author:     Martin Desharnais, UniBw Muenchen
*)

section \<open>Automatic Theorem Provers (ATPs)\<close>

theory ATP
  imports Meson Hilbert_Choice
begin

subsection \<open>ATP problems and proofs\<close>

ML_file \<open>Tools/ATP/atp_util.ML\<close>
ML_file \<open>Tools/ATP/atp_problem.ML\<close>
ML_file \<open>Tools/ATP/atp_proof.ML\<close>
ML_file \<open>Tools/ATP/atp_proof_redirect.ML\<close>

subsection \<open>Higher-order reasoning helpers\<close>

definition fFalse :: bool where
"fFalse \<longleftrightarrow> False"

definition fTrue :: bool where
"fTrue \<longleftrightarrow> True"

definition fNot :: "bool \<Rightarrow> bool" where
"fNot P \<longleftrightarrow> \<not> P"

definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"fComp P = (\<lambda>x. \<not> P x)"

definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fconj P Q \<longleftrightarrow> P \<and> Q"

definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fdisj P Q \<longleftrightarrow> P \<or> Q"

definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"

definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fAll P \<longleftrightarrow> All P"

definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fEx P \<longleftrightarrow> Ex P"

definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
"fequal x y \<longleftrightarrow> (x = y)"

definition fChoice :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "fChoice \<equiv> Hilbert_Choice.Eps"

lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
unfolding fFalse_def fTrue_def by simp

lemma fNot_table:
"fNot fFalse = fTrue"
"fNot fTrue = fFalse"
unfolding fFalse_def fTrue_def fNot_def by auto

lemma fconj_table:
"fconj fFalse P = fFalse"
"fconj P fFalse = fFalse"
"fconj fTrue fTrue = fTrue"
unfolding fFalse_def fTrue_def fconj_def by auto

lemma fdisj_table:
"fdisj fTrue P = fTrue"
"fdisj P fTrue = fTrue"
"fdisj fFalse fFalse = fFalse"
unfolding fFalse_def fTrue_def fdisj_def by auto

lemma fimplies_table:
"fimplies P fTrue = fTrue"
"fimplies fFalse P = fTrue"
"fimplies fTrue fFalse = fFalse"
unfolding fFalse_def fTrue_def fimplies_def by auto

lemma fAll_table:
"Ex (fComp P) \<or> fAll P = fTrue"
"All P \<or> fAll P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fAll_def by auto

lemma fEx_table:
"All (fComp P) \<or> fEx P = fTrue"
"Ex P \<or> fEx P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fEx_def by auto

lemma fequal_table:
"fequal x x = fTrue"
"x = y \<or> fequal x y = fFalse"
unfolding fFalse_def fTrue_def fequal_def by auto

lemma fNot_law:
"fNot P \<noteq> P"
unfolding fNot_def by auto

lemma fComp_law:
"fComp P x \<longleftrightarrow> \<not> P x"
unfolding fComp_def ..

lemma fconj_laws:
"fconj P P \<longleftrightarrow> P"
"fconj P Q \<longleftrightarrow> fconj Q P"
"fNot (fconj P Q) \<longleftrightarrow> fdisj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fdisj_laws:
"fdisj P P \<longleftrightarrow> P"
"fdisj P Q \<longleftrightarrow> fdisj Q P"
"fNot (fdisj P Q) \<longleftrightarrow> fconj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fimplies_laws:
"fimplies P Q \<longleftrightarrow> fdisj (\<not> P) Q"
"fNot (fimplies P Q) \<longleftrightarrow> fconj P (fNot Q)"
unfolding fNot_def fconj_def fdisj_def fimplies_def by auto

lemma fAll_law:
"fNot (fAll R) \<longleftrightarrow> fEx (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fEx_law:
"fNot (fEx R) \<longleftrightarrow> fAll (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fequal_laws:
"fequal x y = fequal y x"
"fequal x y = fFalse \<or> fequal y z = fFalse \<or> fequal x z = fTrue"
"fequal x y = fFalse \<or> fequal (f x) (f y) = fTrue"
unfolding fFalse_def fTrue_def fequal_def by auto

lemma fChoice_iff_Ex: "P (fChoice P) \<longleftrightarrow> HOL.Ex P"
  unfolding fChoice_def
  by (fact some_eq_ex)

text \<open>
We use the @{const HOL.Ex} constant on the right-hand side of @{thm [source] fChoice_iff_Ex} because
we want to use the TPTP-native version if fChoice is introduced in a logic that supports FOOL.
In logics that don't support it, it gets replaced by fEx during processing.
Notice that we cannot use @{term "\<exists>x. P x"}, as existentials are not skolimized by the metis proof
method but @{term "Ex P"} is eta-expanded if FOOL is supported.\<close>

subsection \<open>Basic connection between ATPs and HOL\<close>

ML_file \<open>Tools/lambda_lifting.ML\<close>
ML_file \<open>Tools/monomorph.ML\<close>
ML_file \<open>Tools/ATP/atp_problem_generate.ML\<close>
ML_file \<open>Tools/ATP/atp_proof_reconstruct.ML\<close>

end


section \<open>Invariants for Tarjan's Algorithm\<close>
theory Tarjan_LowLink
imports
  "../DFS_Framework"
  "../Invars/DFS_Invars_SCC"
begin

context param_DFS_defs begin

  definition
    "lowlink_path s v p w \<equiv> path E v p w \<and> p \<noteq> []
                          \<and> (last p, w) \<in> cross_edges s \<union> back_edges s
                          \<and> (length p > 1 \<longrightarrow>
                                p!1 \<in> dom (finished s)
                              \<and> (\<forall>k < length p - 1. (p!k, p!Suc k) \<in> tree_edges s))"

  definition
    "lowlink_set s v \<equiv> {w \<in> dom (discovered s).
                         v = w
                        \<or> (v,w) \<in> E\<^sup>+ \<and> (w,v) \<in> E\<^sup>+
                          \<and> (\<exists>p. lowlink_path s v p w)}"

context begin interpretation timing_syntax .
  abbreviation LowLink where
    "LowLink s v \<equiv> Min (\<delta> s ` lowlink_set s v)"
end

end

context DFS_invar begin

  lemma lowlink_setI:
    assumes "lowlink_path s v p w"
    and "w \<in> dom (discovered s)"
    and "(v,w) \<in> E\<^sup>*" "(w,v) \<in> E\<^sup>*"
    shows "w \<in> lowlink_set s v"
  proof (cases "v = w")
    case True thus ?thesis by (simp add: lowlink_set_def assms)
  next
    case False with assms have "(v,w) \<in> E\<^sup>+" "(w,v) \<in> E\<^sup>+" by (metis rtrancl_eq_or_trancl)+
    with assms show ?thesis by (auto simp add: lowlink_set_def)
  qed

  lemma lowlink_set_discovered:
    "lowlink_set s v \<subseteq> dom (discovered s)"
    unfolding lowlink_set_def
    by blast

  lemma lowlink_set_finite[simp, intro!]:
    "finite (lowlink_set s v)"
    using lowlink_set_discovered discovered_finite
    by (metis finite_subset)

  lemma lowlink_set_not_empty:
    assumes "v \<in> dom (discovered s)"
    shows "lowlink_set s v \<noteq> {}"
    unfolding lowlink_set_def
    using assms by auto

  lemma lowlink_path_single:
    assumes "(v,w) \<in> cross_edges s \<union> back_edges s"
    shows "lowlink_path s v [v] w"
    unfolding lowlink_path_def
    using assms cross_edges_ssE back_edges_ssE
    by (auto simp add: path_simps)

  lemma lowlink_path_Cons:
    assumes "lowlink_path s v (x#xs) w"
    and "xs \<noteq> []"
    shows "\<exists>u. lowlink_path s u xs w"
  proof -
    from assms have path: "path E v (x#xs) w"
      and cb: "(last xs, w) \<in> cross_edges s \<union> back_edges s"
      and f: "(x#xs)!1 \<in> dom (finished s)"
      and t: "(\<forall>k < length xs. ((x#xs)!k, (x#xs)!Suc k) \<in> tree_edges s)"
      unfolding lowlink_path_def
      by auto

    from path obtain u where "path E u xs w" by (auto simp add: path_simps)
    moreover note cb \<open>xs \<noteq> []\<close>
    moreover { fix k define k' where "k' = Suc k"
      assume "k < length xs - 1"
      with k'_def have "k' < length xs" by simp
      with t have "((x#xs)!k', (x#xs)!Suc k') \<in> tree_edges s" by simp
      hence "(xs!k,xs!Suc k) \<in> tree_edges s" by (simp add: k'_def nth_Cons')
    } note t' = this
    moreover {
      assume *: "length xs > 1"
      from f have "xs!0 \<in> dom (finished s)" by auto
      moreover from t'[of 0] * have "(xs!0,xs!1) \<in> tree_edges s" by simp
      ultimately have "xs!1 \<in> dom (finished s)" using tree_edge_impl_parenthesis by metis
    }

    ultimately have "lowlink_path s u xs w" by (auto simp add: lowlink_path_def)
    thus ?thesis ..
  qed

  lemma lowlink_path_in_tree:
    assumes p: "lowlink_path s v p w"
    and j: "j < length p"
    and k: "k < j"
    shows "(p!k, p!j) \<in> (tree_edges s)\<^sup>+"
  proof -
    from p have "p \<noteq> []" by (auto simp add: lowlink_path_def)
    thus ?thesis using p j k
    proof (induction arbitrary: v j k rule: list_nonempty_induct)
      case single thus ?case by auto
    next
      case (cons x xs)
      define j' where "j' = j - 1"
      with cons have j'_le: "j' < length xs" and "k \<le> j'"  and j: "j = Suc j'" by auto

      from cons lowlink_path_Cons obtain u where p: "lowlink_path s u xs w" by blast

      show ?case
      proof (cases "k=0")
        case True
        from cons have "\<And>k. k < length (x#xs) - 1 \<Longrightarrow> ((x#xs)!k,(x#xs)!Suc k) \<in> tree_edges s"
          unfolding lowlink_path_def
          by auto
        moreover from True cons have "k < length (x#xs) - 1" by auto
        ultimately have *: "((x#xs)!k,(x#xs)!Suc k) \<in> tree_edges s" by metis

        show ?thesis
        proof (cases "j' = 0")
          case True with * j \<open>k=0\<close> show ?thesis by simp
        next
          case False with True have "j' > k" by simp
          with cons.IH[OF p j'_le] have "(xs!k, xs!j') \<in> (tree_edges s)\<^sup>+" .
          with j have "((x#xs)!Suc k, (x#xs)!j) \<in> (tree_edges s)\<^sup>+" by simp
          with * show ?thesis by (metis trancl_into_trancl2)
        qed
      next
        case False
        define k' where "k' = k - 1"
        with False \<open>k \<le> j'\<close> have "k' < j'" and k: "k = Suc k'" by simp_all
        with cons.IH[OF p j'_le] have "(xs!k', xs!j') \<in> (tree_edges s)\<^sup>+" by metis
        hence "((x#xs)!Suc k', (x#xs)!Suc j') \<in> (tree_edges s)\<^sup>+" by simp
        with k j show ?thesis by simp
      qed
    qed
  qed

  lemma lowlink_path_finished:
    assumes p: "lowlink_path s v p w"
    and j: "j < length p" "j > 0"
    shows "p!j \<in> dom (finished s)"
  proof -
    from j have "length p > 1" by simp
    with p have f: "p!1 \<in> dom (finished s)" by (simp add: lowlink_path_def)
    thus ?thesis
    proof (cases "j=1")
      case False with j have "j > 1" by simp
      with assms lowlink_path_in_tree[where k=1] have "(p!1,p!j) \<in> (tree_edges s)\<^sup>+" by simp
      with f tree_path_impl_parenthesis show ?thesis by simp
    qed simp
  qed

  lemma lowlink_path_tree_prepend:
    assumes p: "lowlink_path s v p w"
    and tree_edges: "(u,v) \<in> (tree_edges s)\<^sup>+"
    and fin: "u \<in> dom (finished s) \<or> (stack s \<noteq> [] \<and> u = hd (stack s))"
    shows "\<exists>p. lowlink_path s u p w"
  proof -
    note lowlink_path_def[simp]

    from tree_edges trancl_is_path obtain tp where
      tp: "path (tree_edges s) u tp v" "tp \<noteq> []"
      by metis

    from tree_path_impl_parenthesis assms hd_stack_tree_path_finished have
      v_fin: "v \<in> dom (finished s)" by blast

    from p have "p!0 = hd p" by (simp add: hd_conv_nth)
    with p have p_0: "p!0 = v" by (auto simp add: path_hd)

    let ?p = "tp @ p"

    {
      from tp path_mono[OF tree_edges_ssE] have "path E u tp v" by simp
      also from p have "path E v p w" by simp
      finally have "path E u ?p w" .
    }

    moreover from p have "?p \<noteq> []" by simp

    moreover
    from p have "(last ?p, w) \<in> cross_edges s \<union> back_edges s" by simp

    moreover {
      assume "length ?p > 1"

      have "?p ! 1 \<in> dom (finished s)"
      proof (cases "length tp > 1")
        case True hence tp1: "?p ! 1 = tp ! 1" by (simp add: nth_append)
        from tp True have "(tp ! 0, tp ! 1) \<in> (tree_edges s)\<^sup>+"
          by (auto simp add: path_nth_conv nth_append elim: allE[where x=0])
        also from True have "tp ! 0 = hd tp" by (simp add: hd_conv_nth)
        also from tp have "hd tp = u" by (simp add: path_hd)
        finally have "tp ! 1 \<in> dom (finished s)"
          using tree_path_impl_parenthesis fin hd_stack_tree_path_finished by blast
        thus ?thesis by (subst tp1)
      next
        case False with tp have "length tp = 1" by (cases tp) auto
        with p_0 have "?p ! 1 = v" by (simp add: nth_append)
        thus ?thesis by (simp add: v_fin)
      qed

      also have "\<forall>k < length ?p - 1. (?p!k, ?p!Suc k) \<in> tree_edges s"
      proof (safe)
        fix k
        assume A: "k < length ?p - 1"
        show "(?p!k, ?p!Suc k) \<in> tree_edges s"
        proof (cases "k < length tp")
          case True hence k: "?p ! k = tp ! k" by (simp add: nth_append)
          show ?thesis
          proof (cases "Suc k < length tp")
            case True hence "?p ! Suc k = tp ! Suc k" by (simp add: nth_append)
            moreover from True tp have "(tp ! k, tp ! Suc k) \<in> tree_edges s"
              by (auto simp add: path_nth_conv nth_append
                       elim: allE[where x=k])
            ultimately show ?thesis using k by simp
          next
            case False with True have *: "Suc k = length tp" by simp
            with tp True have "(tp ! k, v) \<in> tree_edges s"
              by (auto simp add: path_nth_conv nth_append
                       elim: allE[where x=k])
            also from * p_0 have "v = ?p ! Suc k" by (simp add: nth_append)
            finally show ?thesis by (simp add: k)
          qed
        next
          case False hence *: "Suc k - length tp = Suc (k - length tp)" by simp
          define k' where "k' = k - length tp"
          with False * have k': "?p ! k = p ! k'" "?p ! Suc k = p ! Suc k'"
            by (simp_all add: nth_append)
          from k'_def False A have "k' < length p - 1" by simp
          with p have "(p!k', p!Suc k') \<in> tree_edges s" by simp (* p is lowlink_path *)
          with k' show ?thesis by simp
        qed
      qed

      also (conjI) note calculation
    }

    ultimately have "lowlink_path s u ?p w" by simp
    thus ?thesis ..
  qed

  lemma lowlink_path_complex:
    assumes "(u,v) \<in> (tree_edges s)\<^sup>+"
    and "u \<in> dom (finished s) \<or> (stack s \<noteq> [] \<and> u = hd (stack s))"
    and "(v,w) \<in> cross_edges s \<union> back_edges s"
    shows "\<exists>p. lowlink_path s u p w"
  proof -
    from assms lowlink_path_single have "lowlink_path s v [v] w" by simp
    with assms lowlink_path_tree_prepend show ?thesis by simp
  qed

  lemma no_path_imp_no_lowlink_path:
    assumes "edges s `` {v} = {}"
    shows "\<not>lowlink_path s v p w"
  proof
    assume p: "lowlink_path s v p w"
    hence [simp]: "p\<noteq>[]" by (simp add: lowlink_path_def)

    from p have "hd p = v" by (auto simp add: lowlink_path_def path_hd)
    with hd_conv_nth[OF \<open>p\<noteq>[]\<close>] have v: "p!0 = v" by simp

    show False
    proof (cases "length p > 1")
      case True with p have "(p!0,p!1) \<in> tree_edges s" by (simp add: lowlink_path_def)
      with v assms show False by auto
    next
      case False with \<open>p\<noteq>[]\<close> have "length p = 1" by (cases p) auto
      hence "last p = v" by (simp add: last_conv_nth v)
      with p have "(v,w) \<in> edges s" by (simp add: lowlink_path_def)
      with assms show False by auto
    qed
  qed

context begin interpretation timing_syntax .

  lemma LowLink_le_disc:
    assumes "v \<in> dom (discovered s)"
    shows "LowLink s v \<le> \<delta> s v"
    using assms
    unfolding lowlink_set_def
    by clarsimp

  lemma LowLink_lessE:
    assumes "LowLink s v < x"
    and "v \<in> dom (discovered s)"
    obtains w where "\<delta> s w < x" "w \<in> lowlink_set s v"
  proof -
    let ?L = "\<delta> s ` lowlink_set s v"

    note assms
    moreover from lowlink_set_finite have "finite ?L" by auto
    moreover from lowlink_set_not_empty assms have "?L \<noteq> {}" by auto
    ultimately show ?thesis using that by (auto simp: Min_less_iff)
  qed

  lemma LowLink_lessI:
    assumes "y \<in> lowlink_set s v"
    and "\<delta> s y < \<delta> s v"
    shows "LowLink s v < \<delta> s v"
  proof -
    let ?L = "\<delta> s ` lowlink_set s v"

    from assms have "\<delta> s y \<in> ?L" by simp
    moreover hence "?L \<noteq> {}" by auto
    moreover from lowlink_set_finite have "finite ?L" by auto
    ultimately show ?thesis
      by (metis Min_less_iff assms(2))
  qed

  lemma LowLink_eqI:
    assumes "DFS_invar G param s'"
    assumes sub_m: "discovered s \<subseteq>\<^sub>m discovered s'"
    assumes sub: "lowlink_set s w \<subseteq> lowlink_set s' w"
    and rev_sub: "lowlink_set s' w \<subseteq> lowlink_set s w \<union> X"
    and w_disc: "w \<in> dom (discovered s)"
    and X: "\<And>x. \<lbrakk>x \<in> X; x \<in> lowlink_set s' w\<rbrakk> \<Longrightarrow> \<delta> s' x \<ge> LowLink s w"
    shows "LowLink s w = LowLink s' w"
  proof (rule ccontr)
    interpret s': DFS_invar where s=s' by fact
    assume A: "LowLink s w \<noteq> LowLink s' w"

    from lowlink_set_discovered sub sub_m w_disc have
           sub': "\<delta> s ` lowlink_set s w \<subseteq> \<delta> s' ` lowlink_set s' w"
      and  w_disc': "w \<in> dom (discovered s')"
      and  eq: "\<And>ll. ll \<in> lowlink_set s w \<Longrightarrow> \<delta> s' ll = \<delta> s ll"
      by (force simp: map_le_def)+

    from lowlink_set_not_empty[OF w_disc] A Min_antimono[OF sub'] s'.lowlink_set_finite have
      "LowLink s' w < LowLink s w" by fastforce
    then obtain ll where ll: "ll \<in> lowlink_set s' w" and ll_le: "\<delta> s' ll < LowLink s w"
      by (metis s'.LowLink_lessE w_disc')
    with rev_sub have "ll \<in> lowlink_set s w \<or> ll \<in> X" by auto
    hence "LowLink s w \<le> \<delta> s' ll"
    proof
      assume "ll \<in> lowlink_set s w" with lowlink_set_finite eq show ?thesis by force
    next
      assume "ll \<in> X" with ll show ?thesis by (metis X)
    qed
    with ll_le show False by simp
  qed

  lemma LowLink_eq_disc_iff_scc_root:
    assumes "v \<in> dom (finished s) \<or> (stack s \<noteq> [] \<and> v = hd (stack s) \<and> pending s `` {v} = {})"
    shows "LowLink s v = \<delta> s v \<longleftrightarrow> scc_root s v (scc_of E v)"
  proof
    let ?scc = "scc_of E v"
    assume scc: "scc_root s v ?scc"
    show "LowLink s v = \<delta> s v"
    proof (rule ccontr)
      assume A: "LowLink s v \<noteq> \<delta> s v"

      from assms finished_discovered stack_discovered hd_in_set have disc: "v \<in> dom (discovered s)" by blast
      with assms LowLink_le_disc A have "LowLink s v < \<delta> s v" by force
      with disc obtain w where
        w: "\<delta> s w < \<delta> s v" "w \<in> lowlink_set s v"
        by (metis LowLink_lessE)
      with lowlink_set_discovered have wdisc: "w \<in> dom (discovered s)" by auto

      from w have "(v,w) \<in> E\<^sup>*" "(w,v) \<in> E\<^sup>*" by (auto simp add: lowlink_set_def)
      moreover have "is_scc E ?scc" "v \<in> ?scc" by simp_all
      ultimately have "w \<in> ?scc" by (metis is_scc_closed)
      with wdisc scc_root_disc_le[OF scc] have "\<delta> s v \<le> \<delta> s w" by simp
      with w show False by auto
    qed
  next
    assume LL: "LowLink s v = \<delta> s v"

    from assms finished_discovered stack_discovered hd_in_set have
      v_disc: "v \<in> dom (discovered s)" by blast

    from assms finished_no_pending have
      v_no_p: "pending s `` {v} = {}" by blast

    let ?scc = "scc_of E v"
    have is_scc: "is_scc E ?scc" by simp

    {
      fix r
      assume "r \<noteq> v"
      and "r \<in> ?scc" "r \<in> dom (discovered s)"

      have "v \<in> ?scc" by simp
      with \<open>r \<in> ?scc\<close> is_scc have "(v,r) \<in> (Restr E ?scc)\<^sup>*"
        by (simp add: is_scc_connected')

      hence "(v,r) \<in> (tree_edges s)\<^sup>+" using \<open>r\<noteq>v\<close>
      proof (induction rule: rtrancl_induct)
        case (step y z) hence "(v,z) \<in> (Restr E ?scc)\<^sup>*"
          by (metis rtrancl_into_rtrancl)
        hence "(v,z) \<in> E\<^sup>*" by (metis Restr_rtrancl_mono)

        from step have "(z,v) \<in> E\<^sup>*" by (simp add: is_scc_connected[OF is_scc])

        {
          assume z_disc: "z \<in> dom (discovered s)"
          and "\<exists>p. lowlink_path s v p z"
          with \<open>(z,v)\<in>E\<^sup>*\<close> \<open>(v,z)\<in>E\<^sup>*\<close> have ll: "z \<in> lowlink_set s v"
            by (metis lowlink_setI)
          have "\<delta> s v < \<delta> s z"
          proof (rule ccontr)
            presume "\<delta> s v \<ge> \<delta> s z" with \<open>z\<noteq>v\<close> v_disc z_disc disc_unequal have "\<delta> s z < \<delta> s v" by fastforce
            with ll have "LowLink s v < \<delta> s v" by (metis LowLink_lessI)
            with LL show False by simp
          qed simp
        } note \<delta>z = this

        show ?case
        proof (cases "y=v")
          case True note [simp] = this
          with step v_no_p v_disc no_pending_imp_succ_discovered have
            z_disc: "z \<in> dom (discovered s)" by blast

          from step edges_covered v_no_p v_disc have "(v,z) \<in> edges s" by auto
          thus ?thesis
          proof (rule edgesE_CB)
            assume "(v,z) \<in> tree_edges s" thus ?thesis ..
          next
            assume CB: "(v,z) \<in> cross_edges s \<union> back_edges s"
            hence "lowlink_path s v [v] z"
              by (simp add: lowlink_path_single)
            with \<delta>z[OF z_disc] no_pending_succ_impl_path_in_tree v_disc v_no_p step show ?thesis
              by auto
          qed
        next
          case False with step.IH have T: "(v,y) \<in> (tree_edges s)\<^sup>+" .
          with tree_path_impl_parenthesis assms hd_stack_tree_path_finished tree_path_disc have
            y_fin: "y \<in> dom (finished s)"
            and y_\<delta> : "\<delta> s v < \<delta> s y" by blast+
          with step have z_disc: "z \<in> dom (discovered s)"
            using finished_imp_succ_discovered
            by auto

          from step edges_covered finished_no_pending[of y] y_fin finished_discovered have
            "(y,z) \<in> edges s"
            by fast
          thus ?thesis
          proof (rule edgesE_CB)
            assume "(y,z) \<in> tree_edges s" with T show ?thesis ..
          next
            assume CB: "(y,z) \<in> cross_edges s \<union> back_edges s"
            with lowlink_path_complex[OF T] assms have
              "\<exists>p. lowlink_path s v p z" by blast
            with \<delta>z z_disc have \<delta>z: "\<delta> s v < \<delta> s z" by simp

            show ?thesis
            proof (cases "v \<in> dom (finished s)")
              case True with tree_path_impl_parenthesis T have y_f: "\<phi> s y < \<phi> s v" by blast

              from CB show ?thesis
              proof
                assume C: "(y,z) \<in> cross_edges s"
                with cross_edges_finished_decr y_fin y_f have "\<phi> s z < \<phi> s v"
                  by force
                moreover note \<delta>z
                moreover from C cross_edges_target_finished have
                  "z \<in> dom (finished s)" by simp
                ultimately show ?thesis
                  using parenthesis_impl_tree_path[OF True] by metis
              next
                assume B: "(y,z) \<in> back_edges s"
                with back_edge_disc_lt_fin y_fin y_f have "\<delta> s z < \<phi> s v"
                  by force
                moreover note \<delta>z z_disc
                ultimately have "z \<in> dom (finished s)" "\<phi> s z < \<phi> s v"
                  using parenthesis_contained[OF True] by simp_all
                with \<delta>z show ?thesis
                  using parenthesis_impl_tree_path[OF True] by metis
              qed
            next
              case False \<comment> \<open>\<open>v \<notin> dom (finished s)\<close>\<close>
              with assms have st: "stack s \<noteq> []" "v = hd (stack s)" "pending s `` {v} = {}" by blast+

              have "z \<in> dom (finished s)"
              proof (rule ccontr)
                assume "z \<notin> dom (finished s)"
                with z_disc have "z \<in> set (stack s)" by (simp add: stack_set_def)
                with \<open>z\<noteq>v\<close> st have "z \<in> set (tl (stack s))" by (cases "stack s") auto
                with st tl_lt_stack_hd_discover \<delta>z show False by force
              qed
              with \<delta>z parenthesis_impl_tree_path_not_finished v_disc False show ?thesis by simp
            qed
          qed
        qed
      qed simp
      hence "r \<in> (tree_edges s)\<^sup>* `` {v}" by auto
    }
    hence "?scc \<inter> dom (discovered s) \<subseteq> (tree_edges s)\<^sup>* `` {v}"
      by fastforce
    thus "scc_root s v ?scc" by (auto intro!: scc_rootI v_disc)
  qed
end end
end


section "Immutable Arrays with Code Generation"

theory IArray
imports Main
begin

text\<open>Immutable arrays are lists wrapped up in an additional constructor.
There are no update operations. Hence code generation can safely implement
this type by efficient target language arrays.  Currently only SML is
provided. Should be extended to other target languages and more operations.

Note that arrays cannot be printed directly but only by turning them into
lists first. Arrays could be converted back into lists for printing if they
were wrapped up in an additional constructor.\<close>

context
begin

datatype 'a iarray = IArray "'a list"

qualified primrec list_of :: "'a iarray \<Rightarrow> 'a list" where
"list_of (IArray xs) = xs"

qualified definition of_fun :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a iarray" where
[simp]: "of_fun f n = IArray (map f [0..<n])"

qualified definition sub :: "'a iarray \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
[simp]: "as !! n = IArray.list_of as ! n"

qualified definition length :: "'a iarray \<Rightarrow> nat" where
[simp]: "length as = List.length (IArray.list_of as)"

qualified fun all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
"all p (IArray as) = (ALL a : set as. p a)"

qualified fun exists :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
"exists p (IArray as) = (EX a : set as. p a)"

lemma list_of_code [code]:
"IArray.list_of as = map (\<lambda>n. as !! n) [0 ..< IArray.length as]"
by (cases as) (simp add: map_nth)

end

subsection "Code Generation"

code_reserved SML Vector

code_printing
  type_constructor iarray \<rightharpoonup> (SML) "_ Vector.vector"
| constant IArray \<rightharpoonup> (SML) "Vector.fromList"
| constant IArray.all \<rightharpoonup> (SML) "Vector.all"
| constant IArray.exists \<rightharpoonup> (SML) "Vector.exists"

lemma [code]:
  "size_iarray f as = Suc (size_list f (IArray.list_of as))"
  by (cases as) simp

lemma [code]:
  "rec_iarray f as = f (IArray.list_of as)"
  by (cases as) simp

lemma [code]:
  "case_iarray f as = f (IArray.list_of as)"
  by (cases as) simp

lemma [code]:
  "set_iarray as = set (IArray.list_of as)"
  by (cases as) auto

lemma [code]:
  "map_iarray f as = IArray (map f (IArray.list_of as))"
  by (cases as) auto

lemma [code]:
  "rel_iarray r as bs = list_all2 r (IArray.list_of as) (IArray.list_of bs)"
  by (cases as, cases bs) auto

lemma [code]:
  "HOL.equal as bs \<longleftrightarrow> HOL.equal (IArray.list_of as) (IArray.list_of bs)"
  by (cases as, cases bs) (simp add: equal)

context
begin

qualified primrec tabulate :: "integer \<times> (integer \<Rightarrow> 'a) \<Rightarrow> 'a iarray" where
  "tabulate (n, f) = IArray (map (f \<circ> integer_of_nat) [0..<nat_of_integer n])"

end

lemma [code]:
  "IArray.of_fun f n = IArray.tabulate (integer_of_nat n, f \<circ> nat_of_integer)"
  by simp

code_printing
  constant IArray.tabulate \<rightharpoonup> (SML) "Vector.tabulate"

context
begin

qualified primrec sub' :: "'a iarray \<times> integer \<Rightarrow> 'a" where
  [code del]: "sub' (as, n) = IArray.list_of as ! nat_of_integer n"

end

lemma [code]:
  "IArray.sub' (IArray as, n) = as ! nat_of_integer n"
  by simp

lemma [code]:
  "as !! n = IArray.sub' (as, integer_of_nat n)"
  by simp

code_printing
  constant IArray.sub' \<rightharpoonup> (SML) "Vector.sub"

context
begin

qualified definition length' :: "'a iarray \<Rightarrow> integer" where
  [code del, simp]: "length' as = integer_of_nat (List.length (IArray.list_of as))"

end

lemma [code]:
  "IArray.length' (IArray as) = integer_of_nat (List.length as)"
  by simp

lemma [code]:
  "IArray.length as = nat_of_integer (IArray.length' as)"
  by simp

context term_syntax
begin

lemma [code]:
  "Code_Evaluation.term_of (as :: 'a::typerep iarray) =
    Code_Evaluation.Const (STR ''IArray.iarray.IArray'') (TYPEREP('a list \<Rightarrow> 'a iarray)) <\<cdot>> (Code_Evaluation.term_of (IArray.list_of as))"
  by (subst term_of_anything) rule

end

code_printing
  constant IArray.length' \<rightharpoonup> (SML) "Vector.length"

end