section\<open>Higher-Order Modal Logic in HOL (cf.~\<^cite>\<open>"J23"\<close> and Fig.~1 in \<^cite>\<open>"C85"\<close>).\<close>

theory HOML imports Main
begin
nitpick_params[user_axioms,expect=genuine]

text\<open>Type i is associated with possible worlds and type e with entities:\<close>
typedecl i \<comment>\<open>Possible worlds\<close>
typedecl e \<comment>\<open>Individuals\<close>
type_synonym \<sigma> = "i\<Rightarrow>bool" \<comment>\<open>World-lifted propositions\<close>
type_synonym \<gamma> = "e\<Rightarrow>\<sigma>" \<comment>\<open>Lifted predicates\<close>
type_synonym \<mu> = "\<sigma>\<Rightarrow>\<sigma>" \<comment>\<open>Unary modal connectives\<close>
type_synonym \<nu> = "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" \<comment>\<open>Binary modal connectives\<close>

text\<open>Logical connectives (operating on truth-sets):\<close>
abbreviation c1::\<sigma> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation c2::\<sigma> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation c3::\<mu> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w.\<not>(\<phi> w)"
abbreviation c4::\<nu> (infix"\<^bold>\<and>"50) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<and>(\<psi> w)"
abbreviation c5::\<nu> (infix"\<^bold>\<or>"49) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<or>(\<psi> w)"
abbreviation c6::\<nu> (infix"\<^bold>\<rightarrow>"48) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longrightarrow>(\<psi> w)"
abbreviation c7::\<nu> (infix"\<^bold>\<leftrightarrow>"47) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longleftrightarrow>(\<psi> w)"
consts R::"i\<Rightarrow>i\<Rightarrow>bool" ("_\<^bold>r_")  \<comment>\<open>Accessibility relation\<close>
abbreviation c8::\<mu> ("\<^bold>\<box>_"[54]55) where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v.(w\<^bold>rv)\<longrightarrow>(\<phi> v)"
abbreviation c9::\<mu> ("\<^bold>\<diamond>_"[54]55) where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v.(w\<^bold>rv)\<and>(\<phi> v)"
abbreviation c10::"\<gamma>\<Rightarrow>\<gamma>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<Phi> \<equiv> \<lambda>x.\<lambda>w.\<not>(\<Phi> x w)"
abbreviation c11::"\<gamma>\<Rightarrow>\<gamma>" ("\<^bold>\<rightharpoondown>_") where "\<^bold>\<rightharpoondown>\<Phi> \<equiv> \<lambda>x.\<lambda>w.\<not>(\<Phi> x w)"
abbreviation c12::"e\<Rightarrow>e\<Rightarrow>\<sigma>" ("_\<^bold>=_") where "x\<^bold>=y \<equiv> \<lambda>w.(x=y)"
abbreviation c13::"e\<Rightarrow>e\<Rightarrow>\<sigma>" ("_\<^bold>\<noteq>_") where "x\<^bold>\<noteq>y \<equiv> \<lambda>w.(x\<noteq>y)"

text\<open>Polymorphic possibilist quantification:\<close>
abbreviation q1::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x.(\<Phi> x w)"
abbreviation q2 (binder"\<^bold>\<forall>"[10]11) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation q3::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x.(\<Phi> x w)"
abbreviation q4 (binder"\<^bold>\<exists>"[10]11) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

text\<open>Actualist quantification for individuals/entities:\<close>
consts existsAt::\<gamma> ("_\<^bold>@_")
abbreviation q5::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<forall>\<^sup>E") where "\<^bold>\<forall>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<forall>x.(x\<^bold>@w)\<longrightarrow>(\<Phi> x w)"
abbreviation q6 (binder"\<^bold>\<forall>\<^sup>E"[8]9) where "\<^bold>\<forall>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<forall>\<^sup>E\<phi>"
abbreviation q7::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<exists>\<^sup>E") where "\<^bold>\<exists>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<exists>x.(x\<^bold>@w)\<and>(\<Phi> x w)"
abbreviation q8 (binder"\<^bold>\<exists>\<^sup>E"[8]9) where "\<^bold>\<exists>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<exists>\<^sup>E\<phi>"

text\<open>Meta-logical predicate for global validity:\<close>
abbreviation g1::"\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w. \<psi> w"

text\<open>Barcan and converse Barcan formula:\<close>
lemma True nitpick[satisfy] oops  \<comment>\<open>Model found by Nitpick\<close>
lemma "\<lfloor>(\<^bold>\<forall>\<^sup>Ex.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex.(\<phi> x))\<rfloor>" nitpick oops \<comment>\<open>Ctm\<close>
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ex.(\<phi> x)) \<^bold>\<rightarrow> (\<^bold>\<forall>\<^sup>Ex.\<^bold>\<box>(\<phi> x))\<rfloor>" nitpick oops \<comment>\<open>Ctm\<close>
lemma "\<lfloor>(\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. \<phi> x)\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x)) \<^bold>\<rightarrow> (\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x))\<rfloor>" by simp
end


theory BTree_ImpSplit
  imports
    BTree_ImpSet
    BTree_Split
    Imperative_Loops
begin

section "Imperative split operations"

text "So far, we have only given a functional specification of a possible split.
      We will now provide imperative split functions that refine the functional specification.
      However, rather than tracing the execution of the abstract specification,
      the imperative versions are implemented using while-loops."

subsection "Linear split"

text "The linear split is the most simple split function for binary trees.
      It serves a good example on how to use while-loops in Imperative/HOL
      and how to prove Hoare-Triples about its application using loop invariants."

definition lin_split :: "('a::heap \<times> 'b::{heap,linorder}) pfarray \<Rightarrow> 'b \<Rightarrow> nat Heap"
  where
    "lin_split \<equiv> \<lambda> (a,n) p. do {

  i \<leftarrow> heap_WHILET
    (\<lambda>i. if i<n then do {
      (_,s) \<leftarrow> Array.nth a i;
      return (s<p)
    } else return False)
    (\<lambda>i. return (i+1))
    0;

  return i
}"

lemma lin_split_rule: "
< is_pfa c xs (a,n)>
 lin_split (a,n) p
 <\<lambda>i. is_pfa c xs (a,n) * \<up>(i\<le>n \<and> (\<forall>j<i. snd (xs!j) < p) \<and> (i<n \<longrightarrow> snd (xs!i)\<ge>p))>\<^sub>t"
  unfolding lin_split_def

  supply R = heap_WHILET_rule''[where
      R = "measure (\<lambda>i. n - i)"
      and I = "\<lambda>i. is_pfa c xs (a,n) * \<up>(i\<le>n \<and> (\<forall>j<i. snd (xs!j) < p))"
      and b = "\<lambda>i. i<n \<and> snd (xs!i) < p"
      and Q="\<lambda>i. is_pfa c xs (a,n) * \<up>(i\<le>n \<and> (\<forall>j<i. snd (xs!j) < p) \<and> (i<n \<longrightarrow> snd (xs!i)\<ge>p))"
      ]
  thm R

  apply (sep_auto  decon: R simp: less_Suc_eq is_pfa_def) []
       apply (metis nth_take snd_eqD)
      apply (metis nth_take snd_eqD)
     apply (sep_auto simp: is_pfa_def less_Suc_eq)+
     apply (metis nth_take)
    apply(sep_auto simp: is_pfa_def)
     apply (metis le_simps(3) less_Suc_eq less_le_trans nth_take)
    apply(sep_auto simp: is_pfa_def)+
  done

subsection "Binary split"

text "To obtain an efficient B-Tree implementation, we prefer a binary split
function.
To explore the searching procedure
and the resulting proof, we first implement the split on singleton arrays."

definition bin'_split :: "'b::{heap,linorder} array_list \<Rightarrow> 'b \<Rightarrow> nat Heap"
  where
    "bin'_split \<equiv> \<lambda>(a,n) p. do {
  (low',high') \<leftarrow> heap_WHILET
    (\<lambda>(low,high). return (low < high))
    (\<lambda>(low,high). let mid = ((low  + high) div 2) in
     do {
      s \<leftarrow> Array.nth a mid;
      if p < s then
         return (low, mid)
      else if p > s then
         return (mid+1, high)
      else return (mid,mid)
     })
    (0::nat,n);
  return low'
}"

thm sorted_wrt_nth_less

(* alternative: replace (\<forall>j<l. xs!j < p) by (l > 0 \<longrightarrow> xs!(l-1) < p)*)
lemma bin'_split_rule: "
sorted_less xs \<Longrightarrow>
< is_pfa c xs (a,n)>
 bin'_split (a,n) p
 <\<lambda>l. is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. xs!j < p) \<and> (l<n \<longrightarrow> xs!l\<ge>p)) >\<^sub>t"
  unfolding bin'_split_def

  supply R = heap_WHILET_rule''[where
      R = "measure (\<lambda>(l,h). h-l)"
      and I = "\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l\<le>h \<and> h \<le> n \<and> (\<forall>j<l. xs!j < p) \<and> (h<n \<longrightarrow> xs!h\<ge>p))"
      and b = "\<lambda>(l,h). l<h"
      and Q="\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. xs!j < p) \<and> (l<n \<longrightarrow> xs!l\<ge>p))"
      ]
  thm R

  apply (sep_auto decon: R simp: less_Suc_eq is_pfa_def) []
  subgoal for l' aa l'a aaa ba j
  proof -
    assume 0: "n \<le> length l'a"
    assume a: "l'a ! ((aa + n) div 2) < p"
    moreover assume "aa < n"
    ultimately have b: "((aa+n)div 2) < n"
      by linarith
    then have "(take n l'a) ! ((aa + n) div 2) < p"
      using a by auto
    moreover assume "sorted_less (take n l'a)"
    ultimately have "\<And>j. j < (aa+n)div 2 \<Longrightarrow> (take n l'a) ! j < (take n l'a) ! ((aa + n) div 2)"
      using
        sorted_wrt_nth_less[where ?P="(<)" and xs="(take n l'a)" and ?j="((aa + n) div 2)"]
        a b "0" by auto
    moreover fix j assume "j < (aa+n) div 2"
    ultimately show "l'a ! j < p" using "0" b
      using \<open>take n l'a ! ((aa + n) div 2) < p\<close> dual_order.strict_trans by auto
  qed
  subgoal for l' aa b l'a aaa ba j
  proof -
    assume t0: "n \<le> length l'a"
    assume t1: "aa < b"
    assume a: "l'a ! ((aa + b) div 2) < p"
    moreover assume "b \<le> n"
    ultimately have b: "((aa+b)div 2) < n" using t1
      by linarith
    then have "(take n l'a) ! ((aa + b) div 2) < p"
      using a by auto
    moreover assume "sorted_less (take n l'a)"
    ultimately have "\<And>j. j < (aa+b)div 2 \<Longrightarrow> (take n l'a) ! j < (take n l'a) ! ((aa + b) div 2)"
      using
        sorted_wrt_nth_less[where ?P="(<)" and xs="(take n l'a)" and ?j="((aa + b) div 2)"]
        a b t0 by auto
    moreover fix j assume "j < (aa+b) div 2"
    ultimately show "l'a ! j < p" using t0 b
      using \<open>take n l'a ! ((aa + b) div 2) < p\<close> dual_order.strict_trans by auto
  qed
     apply sep_auto
      apply (metis le_less nth_take)
     apply (metis le_less nth_take)
    apply sep_auto
  subgoal for l' aa l'a aaa ba j
  proof -
    assume t0: "aa < n"
    assume t1: " n \<le> length l'a"
    assume t4: "sorted_less (take n l'a)"
    assume t5: "j < (aa + n) div 2"
    have "(aa+n) div 2 < n" using t0 by linarith
    then have "(take n l'a) ! j < (take n l'a) ! ((aa + n) div 2)"
      using t0 sorted_wrt_nth_less[where xs="take n l'a" and ?j="((aa + n) div 2)"]
        t1 t4 t5 by auto
    then show ?thesis
      using \<open>(aa + n) div 2 < n\<close> t5 by auto
  qed
  subgoal for l' aa b l'a aaa ba j
  proof -
    assume t0: "aa < b"
    assume t1: " n \<le> length l'a"
    assume t3: "b \<le> n"
    assume t4: "sorted_less (take n l'a)"
    assume t5: "j < (aa + b) div 2"
    have "(aa+b) div 2 < n" using t3 t0 by linarith
    then have "(take n l'a) ! j < (take n l'a) ! ((aa + b) div 2)"
      using t0 sorted_wrt_nth_less[where xs="take n l'a" and ?j="((aa + b) div 2)"]
        t1 t4 t5 by auto
    then show ?thesis
      using \<open>(aa + b) div 2 < n\<close> t5 by auto
  qed
    apply (metis nth_take order_mono_setup.refl)
   apply sep_auto
  apply (sep_auto simp add: is_pfa_def)
  done

text "Then, using the same loop invariant, a binary split for B-tree-like arrays
is derived in a straightforward manner."

definition bin_split :: "('a::heap \<times> 'b::{heap,linorder}) pfarray \<Rightarrow> 'b \<Rightarrow> nat Heap"
  where
    "bin_split \<equiv> \<lambda>(a,n) p. do {
  (low',high') \<leftarrow> heap_WHILET
    (\<lambda>(low,high). return (low < high))
    (\<lambda>(low,high). let mid = ((low  + high) div 2) in
     do {
      (_,s) \<leftarrow> Array.nth a mid;
      if p < s then
         return (low, mid)
      else if p > s then
         return (mid+1, high)
      else return (mid,mid)
     })
    (0::nat,n);
  return low'
}"

thm nth_take

lemma nth_take_eq: "take n ls = take n ls' \<Longrightarrow> i < n \<Longrightarrow> ls!i = ls'!i"
  by (metis nth_take)

lemma map_snd_sorted_less: "\<lbrakk>sorted_less (map snd xs); i < j; j < length xs\<rbrakk>
       \<Longrightarrow> snd (xs ! i) < snd (xs ! j)"
  by (metis (mono_tags, opaque_lifting) length_map less_trans nth_map sorted_wrt_iff_nth_less)

lemma map_snd_sorted_lesseq: "\<lbrakk>sorted_less (map snd xs); i \<le> j; j < length xs\<rbrakk>
       \<Longrightarrow> snd (xs ! i) \<le> snd (xs ! j)"
  by (metis eq_iff less_imp_le map_snd_sorted_less order.not_eq_order_implies_strict)

lemma bin_split_rule: "
sorted_less (map snd xs) \<Longrightarrow>
< is_pfa c xs (a,n)>
 bin_split (a,n) p
 <\<lambda>l. is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. snd(xs!j) < p) \<and> (l<n \<longrightarrow> snd(xs!l)\<ge>p)) >\<^sub>t"
  (* this works in principle, as demonstrated above *)
  unfolding bin_split_def

  supply R = heap_WHILET_rule''[where
      R = "measure (\<lambda>(l,h). h-l)"
      and I = "\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l\<le>h \<and> h \<le> n \<and> (\<forall>j<l. snd (xs!j) < p) \<and> (h<n \<longrightarrow> snd (xs!h)\<ge>p))"
      and b = "\<lambda>(l,h). l<h"
      and Q="\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. snd (xs!j) < p) \<and> (l<n \<longrightarrow> snd (xs!l)\<ge>p))"
      ]
  thm R

  apply (sep_auto decon: R simp: less_Suc_eq is_pfa_def) []

      apply(auto dest!: sndI nth_take_eq[of n _ _ "(_ + _) div 2"])[]
     apply(auto dest!: sndI nth_take_eq[of n _ _ "(_ + _) div 2"])[]
    apply (sep_auto dest!: sndI )
  subgoal for ls i ls' _ _ j
    using map_snd_sorted_lesseq[of "take n ls'" j "(i + n) div 2"]
      less_mult_imp_div_less apply(auto)[]
    done
  subgoal for ls i j ls' _ _ j'
    using map_snd_sorted_lesseq[of "take n ls'" j' "(i + j) div 2"]
      less_mult_imp_div_less apply(auto)[]
    done
    apply sep_auto
  subgoal for ls i ls' _ _ j
    using map_snd_sorted_less[of "take n ls'" j "(i + n) div 2"]
      less_mult_imp_div_less
    apply(auto)[]
    done
  subgoal for ls i j ls' _ _ j'
    using map_snd_sorted_less[of "take n ls'" j' "(i + j) div 2"]
      less_mult_imp_div_less
    apply(auto)[]
    done
    apply (metis le_less nth_take_eq)
   apply sep_auto
  apply (sep_auto simp add: is_pfa_def)
  done

subsection "Refinement of an abstract split"

text "We provide a certain abstract split function
that is particularly easy to analyse. The idea of this function is due to Peter Lammich."

definition "abs_split xs x = (takeWhile (\<lambda>(_,s). s<x) xs, dropWhile (\<lambda>(_,s). s<x) xs)"

interpretation btree_abs_search: split abs_split
  unfolding abs_split_def sym[OF linear_split_alt]
  by unfold_locales

text \<open>Any function that yields the heap rule
we have obtained for bin\_split and lin\_split also
refines this abstract split.\<close>

locale imp_split_smeq =
  fixes split_fun :: "('a::{heap,default,linorder} btnode ref option \<times> 'a) array \<times> nat \<Rightarrow> 'a \<Rightarrow> nat Heap"
  assumes split_rule: "sorted_less (separators xs) \<Longrightarrow>
 <is_pfa c xs (a, n)>
   split_fun (a, n) (p::'a)
  <\<lambda>r. is_pfa c xs (a, n) *
                 \<up> (r \<le> n \<and>
                   (\<forall>j<r. snd (xs ! j) < p) \<and>
                   (r < n \<longrightarrow> p \<le> snd (xs ! r)))>\<^sub>t"
begin

lemma abs_split_full: "\<forall>(_,s) \<in> set xs. s < p \<Longrightarrow> abs_split xs p = (xs,[])"
  by (simp add: abs_split_def)

lemma abs_split_split:
  assumes "n < length xs"
    and "(\<forall>(_,s) \<in> set (take n xs). s < p)"
    and " (case (xs!n) of (_,s) \<Rightarrow> \<not>(s < p))"
  shows "abs_split xs p = (take n xs, drop n xs)"
  using assms  apply (auto simp add: abs_split_def)
   apply (metis (mono_tags, lifting) id_take_nth_drop old.prod.case takeWhile_eq_all_conv takeWhile_tail)
  by (metis (no_types, lifting) Cons_nth_drop_Suc case_prod_conv dropWhile.simps(2) dropWhile_append2 id_take_nth_drop)

lemma split_rule_abs_split:
  shows
    "sorted_less (separators ts) \<Longrightarrow> <
    is_pfa c tsi (a,n)
  * list_assn (A \<times>\<^sub>a id_assn) ts tsi>
    split_fun (a,n) p
  <\<lambda>i.
    is_pfa c tsi (a,n)
    * list_assn (A \<times>\<^sub>a id_assn) ts tsi
    * \<up>(split_relation ts (abs_split ts p) i)>\<^sub>t"
  apply(rule hoare_triple_preI)
  apply (sep_auto heap: split_rule dest!: mod_starD id_assn_list
      simp add: list_assn_prod_map split_ismeq)
    apply(auto simp add: is_pfa_def)
proof -

  fix h l' assume heap_init:
    "h \<Turnstile> a \<mapsto>\<^sub>a l'"
    "map snd ts = (map snd (take n l'))"
    "n \<le> length l'"

  show full_thm: "\<forall>j<n. snd (l' ! j) < p \<Longrightarrow>
       split_relation ts (abs_split ts p) n"
  proof -
    assume sm_list: "\<forall>j<n. snd (l' ! j) < p"
    then have "\<forall>j < length (map snd (take n l')). ((map snd (take n l'))!j) < p"
      by simp
    then have "\<forall>j<length (map snd ts). ((map snd ts)!j) < p"
      using heap_init by simp
    then have "\<forall>(_,s) \<in> set ts. s < p"
      by (metis case_prod_unfold in_set_conv_nth length_map nth_map)
    then have "abs_split ts p = (ts, [])"
      using abs_split_full[of ts p] by simp
    then show "split_relation ts (abs_split ts p) n"
      using split_relation_length
      by (metis heap_init(2) heap_init(3) length_map length_take min.absorb2)

  qed
  then show "\<forall>j<n. snd (l' ! j) < p \<Longrightarrow>
       p \<le> snd (take n l' ! n) \<Longrightarrow>
       split_relation ts (abs_split ts p) n"
    by simp

  show part_thm: "\<And>x. x < n \<Longrightarrow>
       \<forall>j<x. snd (l' ! j) < p \<Longrightarrow>
       p \<le> snd (l' ! x) \<Longrightarrow> split_relation ts (abs_split ts p) x"
  proof -
    fix x assume x_sm_len: "x < n"
    moreover assume sm_list: "\<forall>j<x. snd (l' ! j) < p"
    ultimately have "\<forall>j<x. ((map snd l') ! j) < p"
      using heap_init
      by auto
    then have "\<forall>j<x. ((map snd ts)!j) < p"
      using heap_init  x_sm_len
      by auto
    moreover have x_sm_len_ts: "x < n"
      using heap_init x_sm_len by auto
    ultimately have "\<forall>(_,x) \<in> set (take x ts). x < p"
      by (auto simp add: in_set_conv_nth  min.absorb2)+
    moreover assume "p \<le> snd (l' ! x)"
    then have "case l'!x of (_,s) \<Rightarrow> \<not>(s < p)"
      by (simp add: case_prod_unfold)
    then have "case ts!x of (_,s) \<Rightarrow> \<not>(s < p)"
      using heap_init x_sm_len x_sm_len_ts
      by (metis (mono_tags, lifting) case_prod_unfold length_map length_take min.absorb2 nth_take snd_map_help(2))
    ultimately have "abs_split ts p = (take x ts, drop x ts)"
      using x_sm_len_ts abs_split_split[of x ts p] heap_init
      by (metis length_map length_take min.absorb2)
    then show "split_relation ts (abs_split ts p) x"
      using x_sm_len_ts
      by (metis append_take_drop_id heap_init(2) heap_init(3) length_map length_take less_imp_le_nat min.absorb2 split_relation_alt)
  qed
qed

sublocale imp_split abs_split split_fun
  apply(unfold_locales)
  apply(sep_auto heap: split_rule_abs_split)
  done

end

subsection "Obtaining executable code"

text "In order to obtain fully defined functions,
we need to plug our split function implementations
into the locales we introduced previously."

interpretation btree_imp_linear_split: imp_split_smeq lin_split
  apply unfold_locales
  apply(sep_auto heap: lin_split_rule)
  done

text "Obtaining actual code turns out to be slightly more difficult
  due to the use of locales. However, we successfully obtain
the B-tree insertion and membership query with binary search splitting."

global_interpretation btree_imp_binary_split: imp_split_smeq bin_split
  defines btree_isin = btree_imp_binary_split.isin
    and btree_ins = btree_imp_binary_split.ins
    and btree_insert = btree_imp_binary_split.insert
    and btree_del = btree_imp_binary_split.del
    and btree_split_max = btree_imp_binary_split.split_max
    and btree_delete = btree_imp_binary_split.delete
    and btree_empty = btree_imp_binary_split.empty
  apply unfold_locales
  apply(sep_auto heap: bin_split_rule)
  done

declare btree_imp_binary_split.ins.simps[code]
declare btree_imp_binary_split.isin.simps[code]
declare btree_imp_binary_split.del.simps[code] btree_imp_binary_split.split_max.simps[code]

export_code btree_empty btree_isin btree_insert btree_delete checking OCaml SML Scala
export_code btree_empty btree_isin btree_insert btree_delete in OCaml module_name BTree
export_code btree_empty btree_isin btree_insert btree_delete in SML module_name BTree
export_code btree_empty btree_isin btree_insert btree_delete in Scala module_name BTree

end


(*
  Author: Jørgen Villadsen, DTU Compute, 2020
*)

section \<open>Appendix: Completeness\<close>

theory Sequent_Calculus_Verifier imports Sequent1 SeCaV begin

primrec from_tm and from_tm_list where
  \<open>from_tm (Var n) = FOL_Fitting.Var n\<close> |
  \<open>from_tm (Fun a ts) = App a (from_tm_list ts)\<close> |
  \<open>from_tm_list [] = []\<close> |
  \<open>from_tm_list (t # ts) = from_tm t # from_tm_list ts\<close>

primrec from_fm where
  \<open>from_fm (Pre b ts) = Pred b (from_tm_list ts)\<close> |
  \<open>from_fm (Con p q) = And (from_fm p) (from_fm q)\<close> |
  \<open>from_fm (Dis p q) = Or (from_fm p) (from_fm q)\<close> |
  \<open>from_fm (Imp p q) = Impl (from_fm p) (from_fm q)\<close> |
  \<open>from_fm (Neg p) = FOL_Fitting.Neg (from_fm p)\<close> |
  \<open>from_fm (Uni p) = Forall (from_fm p)\<close> |
  \<open>from_fm (Exi p) = Exists (from_fm p)\<close>

primrec to_tm and to_tm_list where
  \<open>to_tm (FOL_Fitting.Var n) = Var n\<close> |
  \<open>to_tm (App a ts) = Fun a (to_tm_list ts)\<close> |
  \<open>to_tm_list [] = []\<close> |
  \<open>to_tm_list (t # ts) = to_tm t # to_tm_list ts\<close>

primrec to_fm where
  \<open>to_fm \<bottom> = Neg (Imp (Pre 0 []) (Pre 0 []))\<close> |
  \<open>to_fm \<top> = Imp (Pre 0 []) (Pre 0 [])\<close> |
  \<open>to_fm (Pred b ts) = Pre b (to_tm_list ts)\<close> |
  \<open>to_fm (And p q) = Con (to_fm p) (to_fm q)\<close> |
  \<open>to_fm (Or p q) = Dis (to_fm p) (to_fm q)\<close> |
  \<open>to_fm (Impl p q) = Imp (to_fm p) (to_fm q)\<close> |
  \<open>to_fm (FOL_Fitting.Neg p) = Neg (to_fm p)\<close> |
  \<open>to_fm (Forall p) = Uni (to_fm p)\<close> |
  \<open>to_fm (Exists p) = Exi (to_fm p)\<close>

theorem to_from_tm [simp]: \<open>to_tm (from_tm t) = t\<close> \<open>to_tm_list (from_tm_list ts) = ts\<close>
  by (induct t and ts rule: from_tm.induct from_tm_list.induct) simp_all

theorem to_from_fm [simp]: \<open>to_fm (from_fm p) = p\<close>
  by (induct p) simp_all

lemma Truth [simp]: \<open>\<tturnstile> Imp (Pre 0 []) (Pre 0 []) # z\<close>
  using AlphaImp Basic Ext ext.simps member.simps(2) by metis

lemma paramst [simp]:
  \<open>FOL_Fitting.new_term c t = new_term c (to_tm t)\<close>
  \<open>FOL_Fitting.new_list c l = new_list c (to_tm_list l)\<close>
  by (induct t and l rule: FOL_Fitting.paramst.induct FOL_Fitting.paramsts.induct) simp_all

lemma params [iff]: \<open>FOL_Fitting.new c p \<longleftrightarrow> new c (to_fm p)\<close>
  by (induct p) simp_all

lemma list_params [iff]: \<open>FOL_Fitting.news c z \<longleftrightarrow> news c (map to_fm z)\<close>
  by (induct z) simp_all

lemma liftt [simp]:
  \<open>to_tm (FOL_Fitting.liftt t) = inc_term (to_tm t)\<close>
  \<open>to_tm_list (FOL_Fitting.liftts l) = inc_list (to_tm_list l)\<close>
  by (induct t and l rule: FOL_Fitting.liftt.induct FOL_Fitting.liftts.induct) simp_all

lemma substt [simp]:
  \<open>to_tm (FOL_Fitting.substt t s v) = sub_term v (to_tm s) (to_tm t)\<close>
  \<open>to_tm_list (FOL_Fitting.substts l s v) = sub_list v (to_tm s) (to_tm_list l)\<close>
  by (induct t and l rule: FOL_Fitting.substt.induct FOL_Fitting.substts.induct) simp_all

lemma subst [simp]: \<open>to_fm (FOL_Fitting.subst A t s) = sub s (to_tm t) (to_fm A)\<close>
  by (induct A arbitrary: t s) simp_all

lemma sim: \<open>(\<turnstile> x) \<Longrightarrow> (\<tturnstile> (map to_fm x))\<close>
  by (induct rule: SC.induct) (force intro: sequent_calculus.intros)+

lemma evalt [simp]:
  \<open>semantics_term e f t = evalt e f (from_tm t)\<close>
  \<open>semantics_list e f ts = evalts e f (from_tm_list ts)\<close>
  by (induct t and ts rule: from_tm.induct from_tm_list.induct) simp_all

lemma shift [simp]: \<open>shift e 0 x = e\<langle>0:x\<rangle>\<close>
  unfolding shift_def FOL_Fitting.shift_def by simp

lemma semantics [iff]: \<open>semantics e f g p \<longleftrightarrow> eval e f g (from_fm p)\<close>
  by (induct p arbitrary: e) simp_all

abbreviation valid ("\<then> _" 0) where
  \<open>(\<then> p) \<equiv> \<forall>(e :: _ \<Rightarrow> nat hterm) f g. semantics e f g p\<close>

theorem complete_sound: \<open>\<then> p \<Longrightarrow> \<tturnstile> [p]\<close> \<open>\<tturnstile> [q] \<Longrightarrow> semantics e f g q\<close>
  by (metis to_from_fm sim semantics list.map SC_completeness) (use sound in force)

corollary \<open>(\<then> p) \<longleftrightarrow> (\<tturnstile> [p])\<close>
  using complete_sound by fast

section \<open>Reference\<close>

text \<open>Asta Halkjær From (2019): Sequent Calculus \<^url>\<open>https://www.isa-afp.org/entries/FOL_Seq_Calc1.html\<close>\<close>

end


theory BlockchainNew
  imports Main "HOL.List"
begin

(* -- TYPES / Hash / Block Datatype / BlockTree Datatype --*)
type_synonym Transactions = nat
type_synonym Party = nat
type_synonym Slot = nat
datatype Hash = H nat nat
definition "Slotzero = 0"
type_synonym Parties = "Party list"

fun Winner :: "Party \<Rightarrow> Slot \<Rightarrow> bool" where
"Winner P S = (if P = S then True else False)"

record Block =
  sl :: Slot
  txs :: Transactions
  pred :: Hash
  bid :: Party

type_synonym Chain = "Block list"
type_synonym Chains = "Chain list"
type_synonym BlockPool = "Block list"

definition "GenBlock = \<lparr>sl = 0, txs = 0, pred = H 0 0 ,bid = 0\<rparr>"
definition "Block1 = \<lparr>sl = 1, txs =1, pred = H 0 0, bid = 1\<rparr>"
definition "Block2 = \<lparr> sl = 2, txs = 0, pred = H 1 1, bid = 1\<rparr>"
definition "Block3 = \<lparr> sl = 3, txs = 0, pred = H 2 1, bid = 1\<rparr>"

datatype T = Leaf Block | Node Block T  | Node2 Block T T

definition "tree0 = Leaf GenBlock"

(*-- Functions for valid_chain --*)
fun HashCompare' :: "Hash \<Rightarrow> Block \<Rightarrow> bool" where
"HashCompare' (H a b) bl1 = ((a = sl bl1) \<and> (b = bid bl1))"

fun HashCompare :: "Block \<Rightarrow> Block \<Rightarrow> bool" where
"HashCompare bl1 bl2 = HashCompare' (pred bl2) bl1"

fun valid_blocks ::"Block \<Rightarrow> Block \<Rightarrow> bool" where
"valid_blocks b1 b2 =  ( HashCompare b2 b1 \<and>(sl b2 < sl b1))"

fun valid_chain :: "Chain \<Rightarrow> bool" where
"valid_chain [] = False"|
"valid_chain [b1] = (if b1 = GenBlock then True else False)"|
"valid_chain (b1#b2#c) = (if valid_blocks b1 b2 \<and> (b1 \<noteq> GenBlock) then valid_chain (b2#c) else False)"

fun block_get :: "T \<Rightarrow> Block" where
"block_get (Node2 m l r) = m"|
"block_get (Node m l) = m"|
"block_get (Leaf m) = m"

fun valid_t_weak where
"valid_t_weak (Node2 m l r) =
(valid_blocks (block_get l) m  \<and> valid_blocks (block_get r) m \<and> valid_t_weak r \<and> valid_t_weak l)"|
"valid_t_weak (Node m l) = (valid_blocks (block_get l) m  \<and> valid_t_weak l)"|
"valid_t_weak (Leaf m) = True"

fun hash_t where
"hash_t(Node2 m l r) =
(HashCompare m (block_get l)  \<and> HashCompare m (block_get r)  \<and> hash_t r \<and> hash_t l)"|
"hash_t (Node m l) = (HashCompare m (block_get l) \<and> hash_t l)"|
"hash_t (Leaf m) = True"

fun sl_t where
"sl_t(Node2 m l r) =
(sl m < sl (block_get l)  \<and> sl m < sl (block_get r)  \<and> sl_t r \<and> sl_t l)"|
"sl_t (Node m l) = (sl m < sl (block_get l) \<and> sl_t l)"|
"sl_t (Leaf m) = True"

(*-- Functions for allBlocks/allBlocks' and extendTree --*)

fun allBlocks :: "T \<Rightarrow> BlockPool" where
"allBlocks (Node2 m l r) = allBlocks l @ allBlocks r @ [m]"|
"allBlocks (Node m l ) = allBlocks l @ [m]"|
"allBlocks (Leaf m) = [m]"

fun allBlocksAppend :: "Block \<Rightarrow>BlockPool list\<Rightarrow> BlockPool list" where
"allBlocksAppend Bl BlP = (map (\<lambda> bl. bl @ [Bl]) BlP)"

fun allBlocks' :: "T \<Rightarrow> BlockPool list" where
"allBlocks' (Node2 m l r) =( allBlocksAppend m (allBlocks' l) @allBlocksAppend m (allBlocks' r))"|
"allBlocks' (Node m l) =( allBlocksAppend m (allBlocks' l) @[[m]])"|
"allBlocks' (Leaf m)= [[m]]"

fun extendTree :: "T \<Rightarrow> Block \<Rightarrow> T" where
"extendTree (Leaf Bl1) Bl2 =
  (if valid_blocks Bl2 Bl1 then (Node Bl1 (Leaf Bl2)) else (Leaf Bl1))"|
"extendTree (Node Bl1 l) Bl2 =
  (if valid_blocks Bl2 Bl1 then (Node2 Bl1 l (Leaf Bl2)) else (Node Bl1 (extendTree l Bl2)))"|
"extendTree (Node2 m l r) Bl2 = (Node2 m (extendTree l Bl2) (extendTree r Bl2))"

fun valid_t where
"valid_t t = (\<forall>c\<in>set(allBlocks' t).valid_chain c)"
(*-- Functions for finding best_chain --*)

fun best_c :: "Slot \<Rightarrow> BlockPool list \<Rightarrow> (Block list \<times> nat \<times> bool) option"where
"best_c slot list = (let list' = map (\<lambda> l. (l,sl (hd l), valid_chain l)) list
  in find (\<lambda> (c,s,v).v\<and>(s\<le>slot)) list')"

fun get_first :: "(Block list \<times> nat \<times> bool) option \<Rightarrow>Block list" where
"get_first a = (case a of None \<Rightarrow> [] | Some a \<Rightarrow> fst a)"

fun best_chain :: "Slot \<Rightarrow> T \<Rightarrow> Chain" where
"best_chain s (Node x l) = (if s > 0 then get_first ( best_c s (allBlocks' (Node x l)))else [GenBlock])"|
"best_chain s (Node2 x l r) = (if s > 0 then get_first ( best_c s (allBlocks' (Node2 x l r)))else [GenBlock])"|
"best_chain s (Leaf m) = (if s > 0 then get_first ( best_c s (allBlocks' (Leaf m)))else [GenBlock])"

(*-- Second Attempt at finding the best chain without using find--*)

fun allChains' :: "T\<Rightarrow>Slot \<Rightarrow>BlockPool list" where
"allChains' (Node2 m l r) s = (if sl m \<le> s then (allBlocksAppend m (allChains' l s) @allBlocksAppend m (allChains' r s))else[[]])"|
"allChains' (Node m l) s = (if sl m \<le> s then (allBlocksAppend m (allChains' l s) @[[m]])else [[]])"|
"allChains' (Leaf m) s = (if sl m \<le> s then [[m]] else [[]])"

fun return_first :: "Chain list \<Rightarrow> Chain" where
"return_first (x#xs) = x"|
"return_first [] = undefined"

fun best_chain_new :: "T \<Rightarrow> Slot \<Rightarrow> Chain"  where
"best_chain_new t s = return_first (allChains' t s)"

(*-- Functions for equality --*)
fun block_eq :: "Block \<Rightarrow> Block \<Rightarrow> bool" where
"block_eq bl1 b2 = ((sl bl1 = sl b2)\<and>(txs bl1 = txs b2)\<and>(pred bl1 = pred b2)\<and>(bid bl1 = bid b2))"

fun blockpool_eq_set :: "BlockPool \<Rightarrow> BlockPool \<Rightarrow> bool" where
"blockpool_eq_set bpl1 bpl2 = (set(bpl1) = set(bpl2)) "

fun blockpool_eq :: "BlockPool \<Rightarrow> BlockPool \<Rightarrow> bool" where
"blockpool_eq Nil Nil= True"|
"blockpool_eq a b = (((set a \<inter> set b) =set a)\<and>((set a \<inter> set b) =set b))"

fun blocktree_eq :: "T \<Rightarrow> T \<Rightarrow> bool" where
"blocktree_eq (Node2 t1 t2 t3) (Node2 t_1 t_2 t_3) =((Node2 t1 t2 t3) = (Node2 t_1 t_2 t_3))"|
"blocktree_eq (Node t1 t2) (Node t_1 t_2) =((Node t1 t2) = (Node t_1 t_2))"|
"blocktree_eq (Leaf m) (Leaf n) = (Leaf m = Leaf n)"|
"blocktree_eq (T.Leaf v) (T.Node va vb) = False"|
"blocktree_eq (T.Leaf v) (Node2 va vb vc) = False"|
"blocktree_eq (T.Node v va) (T.Leaf vb) = False"|
"blocktree_eq (T.Node v va) (Node2 vb vc vd) = False"|
"blocktree_eq (Node2 va vb vc) (T.Leaf v) = False"|
"blocktree_eq (Node2 vb vc vd) (T.Node v va) = False"

(*-- LEMMAS + PROOFS -- *)

export_code HashCompare' HashCompare GenBlock  blockpool_eq_set  block_eq valid_blocks valid_chain  allBlocks allBlocksAppend allBlocks' tree0 extendTree valid_t valid_t_weak best_c get_first best_chain blocktree_eq  in Haskell

lemma initialTree : "allBlocks tree0 = [GenBlock]"
  by (simp add: GenBlock_def tree0_def)

lemma initialExtend : "(extendTree tree0 b \<noteq> tree0)
\<Longrightarrow> set (allBlocks (extendTree tree0 b)) = set ([b]@ allBlocks tree0)"
  apply(simp add : GenBlock_def tree0_def)
  by auto

lemma base_best_valid :"valid_chain(best_chain s tree0)"
  apply(simp add : tree0_def GenBlock_def) done

lemma initialExtendValid : "valid_t tree0 \<Longrightarrow>valid_t (extendTree tree0 b)"
  apply(simp add: GenBlock_def tree0_def) done

lemma initialExtendweakValid : "valid_t_weak tree0 \<Longrightarrow>valid_t_weak (extendTree tree0 b)"
  by (simp add: tree0_def)

lemma initialBestChain : "valid_t (extendTree tree0 b)
\<Longrightarrow> valid_chain( best_chain s (extendTree tree0 b)) "
  apply(simp add: GenBlock_def tree0_def) done

lemma ExtendInitial : "(extendTree tree0 Block1) = (Node GenBlock (Leaf Block1))"
  by (simp add: GenBlock_def tree0_def Block1_def)

lemma ExtendLeaf : assumes "valid_blocks B m" shows "extendTree (Leaf m) B = (Node m (Leaf B))"
  using assms by auto

lemma SameBlock : assumes "block_eq bl1 bl2" shows "bl1 = bl2"
  using assms apply(auto) done

lemma SamePool : assumes "blockpool_eq (x) (y)" shows "set x = set y"
  using assms
  by (smt (verit, best) blockpool_eq.elims(2))

lemma SameTreeBase : assumes "blocktree_eq T1 T2" shows "T1 = T2"
  using assms SameBlock
  using blocktree_eq.elims(2) by blast

lemma SameTree : assumes "blocktree_eq T1 T2" shows "blockpool_eq (allBlocks T1) (allBlocks T2)"
  using assms SamePool
  by (metis (no_types, opaque_lifting) SameTreeBase blockpool_eq.simps(1) blockpool_eq.simps(3) inf.idem valid_chain.cases)

lemma find_in : \<open>find p ls = Some l\<Longrightarrow> l\<in> set(ls)\<close>
proof(induction ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  then show ?case
    by (metis find_Some_iff nth_mem)
qed

lemma best_c_in : "best_c n bl \<noteq> None \<Longrightarrow> get_first(best_c n bl) \<in> set(bl)"
  apply(simp add: find_in)
proof(induction bl)
  case Nil
  then show ?case
    by simp
next
  case (Cons a bl)
  then show ?case
    by auto
qed

lemma slThan : assumes "valid_t_weak t \<and> t = (Node2 m l r)"
  shows "( sl m < sl (block_get r) \<and> sl m < sl(block_get l))"
  using assms by auto

lemma predThan : assumes "valid_t_weak t \<and> t = (Node2 m l r)"
  shows "( HashCompare m (block_get r) \<and> HashCompare m (block_get l))"
  using assms by auto

lemma slThan2 : assumes "sl_t t \<and> t = (Node2 m l r)"
  shows "( sl m < sl (block_get r) \<and> sl m < sl(block_get l))"
  using assms by auto

lemma predThan2 : assumes "hash_t t \<and> t = (Node2 m l r)"
  shows "( HashCompare m (block_get r) \<and> HashCompare m (block_get l))"
  using assms by auto

lemma BaseExtend : "(extendTree t b \<noteq> t)
\<Longrightarrow> set (allBlocks (extendTree t b)) = set ([b]@ allBlocks t)"
proof(induction t)
  case (Leaf x)
  then show ?case
    by auto
next
  case (Node x1a t)
  then show ?case
    by auto
next
  case (Node2 x1a t1 t2)
  then show ?case
    by fastforce
qed

lemma best_valid_new:assumes "s\<ge>0\<and>block_get t = GenBlock\<and>valid_t_weak t " shows" valid_chain (best_chain_new t s)"
proof(cases "t")
  case (Leaf x1)
  then show ?thesis using assms apply(simp add: GenBlock_def) done
next
  case (Node x21 x22)
  then show ?thesis using assms apply(simp add: GenBlock_def) apply(auto) apply(simp add: append_def) oops
next
  case (Node2 x31 x32 x33)
  then show ?thesis oops
qed

lemma hashAll : assumes "valid_t_weak t" shows "hash_t t"
  using assms oops

lemma validSame : assumes "valid_t_weak t" shows "sl_t t \<and> hash_t t"
  using assms oops

lemma slExtend :  "sl_t t \<and> block_get t = GenBlock \<Longrightarrow> sl_t(extendTree t b)"
proof(induction "t")
  case (Leaf x)
  then show ?case
    by simp
next
  case (Node x1a t)
  then show ?case apply(simp add: GenBlock_def) oops
next
  case (Node2 x1a t1 t2)
  then show ?case oops
qed

lemma validExtend : assumes "valid_t_weak t \<and> block_get t = GenBlock" shows "valid_t_weak (extendTree t b)"
  using assms oops

lemma best_valid: assumes "s>0\<and>block_get t = GenBlock\<and>valid_t_weak t"
  shows "valid_chain (best_chain s t)"
proof(cases "t")
  case (Leaf x1)
  then show ?thesis apply(simp add: GenBlock_def)
    using GenBlock_def assms by auto
next
  case (Node x21 x22)
  then show ?thesis apply(simp add: GenBlock_def) using GenBlock_def assms oops
next
  case (Node2 x31 x32 x33)
  then show ?thesis sorry
qed