(*  Title:      HOL/MicroJava/BV/JVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section {* Kildall for the JVM \label{sec:JVM} *}

theory JVM
imports Typing_Framework_JVM
begin

definition kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow>
             instr list \<Rightarrow> JVMType.state list \<Rightarrow> JVMType.state list" where
  "kiljvm G maxs maxr rT et bs ==
  kildall (JVMType.le G maxs maxr) (JVMType.sup G maxs maxr) (exec G maxs rT et bs)"

definition wt_kil :: "jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
             exception_table \<Rightarrow> instr list \<Rightarrow> bool" where
  "wt_kil G C pTs rT mxs mxl et ins ==
   check_bounded ins et \<and> 0 < size ins \<and>
   (let first  = Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err));
        start  = OK first#(replicate (size ins - 1) (OK None));
        result = kiljvm G mxs (1+size pTs+mxl) rT et ins start
    in \<forall>n < size ins. result!n \<noteq> Err)"

definition wt_jvm_prog_kildall :: "jvm_prog \<Rightarrow> bool" where
  "wt_jvm_prog_kildall G ==
  wf_prog (\<lambda>G C (sig,rT,(maxs,maxl,b,et)). wt_kil G C (snd sig) rT maxs maxl et b) G"

theorem is_bcv_kiljvm:
  "\<lbrakk> wf_prog wf_mb G; bounded (exec G maxs rT et bs) (size bs) \<rbrakk> \<Longrightarrow>
      is_bcv (JVMType.le G maxs maxr) Err (exec G maxs rT et bs)
             (size bs) (states G maxs maxr) (kiljvm G maxs maxr rT et bs)"
  apply (unfold kiljvm_def sl_triple_conv)
  apply (rule is_bcv_kildall)
       apply (simp (no_asm) add: sl_triple_conv [symmetric])
       apply (force intro!: semilat_JVM_slI dest: wf_acyclic
         simp add: symmetric sl_triple_conv)
      apply (simp (no_asm) add: JVM_le_unfold)
      apply (blast intro!: order_widen wf_converse_subcls1_impl_acc_subtype
                   dest: wf_subcls1 wf_acyclic wf_prog_ws_prog)
     apply (simp add: JVM_le_unfold)
    apply (erule exec_pres_type)
   apply assumption
  apply (drule wf_prog_ws_prog, erule exec_mono, assumption)
  done

lemma subset_replicate: "set (replicate n x) \<subseteq> {x}"
  by (induct n) auto

lemma in_set_replicate:
  "x \<in> set (replicate n y) \<Longrightarrow> x = y"
proof -
  assume "x \<in> set (replicate n y)"
  also have "set (replicate n y) \<subseteq> {y}" by (rule subset_replicate)
  finally have "x \<in> {y}" .
  thus ?thesis by simp
qed

theorem wt_kil_correct:
  assumes wf:  "wf_prog wf_mb G"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  assumes wtk: "wt_kil G C pTs rT maxs mxl et bs"

  shows "\<exists>phi. wt_method G C pTs rT maxs mxl bs et phi"
proof -
  let ?start = "OK (Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err)))
                #(replicate (size bs - 1) (OK None))"

  from wtk obtain maxr r where
    bounded: "check_bounded bs et" and
    result:  "r = kiljvm G maxs maxr rT et bs ?start" and
    success: "\<forall>n < size bs. r!n \<noteq> Err" and
    instrs:  "0 < size bs" and
    maxr:    "maxr = Suc (length pTs + mxl)"
    by (unfold wt_kil_def) simp

  from bounded have "bounded (exec G maxs rT et bs) (size bs)"
    by (unfold exec_def) (intro bounded_lift check_bounded_is_bounded)
  with wf have bcv:
    "is_bcv (JVMType.le G maxs maxr) Err (exec G maxs rT et bs)
    (size bs) (states G maxs maxr) (kiljvm G maxs maxr rT et bs)"
    by (rule is_bcv_kiljvm)

  from C pTs instrs maxr
  have "?start \<in> list (length bs) (states G maxs maxr)"
    apply (unfold JVM_states_unfold)
    apply (rule listI)
    apply (auto intro: list_appendI dest!: in_set_replicate)
    apply force
    done

  with bcv success result have
    "\<exists>ts\<in>list (length bs) (states G maxs maxr).
         ?start <=[JVMType.le G maxs maxr] ts \<and>
         wt_step (JVMType.le G maxs maxr) Err (exec G maxs rT et bs) ts"
    by (unfold is_bcv_def) auto
  then obtain phi' where
    phi': "phi' \<in> list (length bs) (states G maxs maxr)" and
    s: "?start <=[JVMType.le G maxs maxr] phi'" and
    w: "wt_step (JVMType.le G maxs maxr) Err (exec G maxs rT et bs) phi'"
    by blast
  hence wt_err_step:
    "wt_err_step (sup_state_opt G) (exec G maxs rT et bs) phi'"
    by (simp add: wt_err_step_def exec_def JVM_le_Err_conv)

  from s have le: "JVMType.le G maxs maxr (?start ! 0) (phi'!0)"
    by (drule_tac p=0 in le_listD) (simp add: lesub_def)+

  from phi' have l: "size phi' = size bs" by simp
  with instrs w have "phi' ! 0 \<noteq> Err" by (unfold wt_step_def) simp
  with instrs l have phi0: "OK (map ok_val phi' ! 0) = phi' ! 0"
    by auto

  from phi' have "check_types G maxs maxr phi'" by(simp add: check_types_def)
  also from w have "phi' = map OK (map ok_val phi')"
    by (auto simp add: wt_step_def intro!: nth_equalityI)
  finally
  have check_types:
    "check_types G maxs maxr (map OK (map ok_val phi'))" .

  from l bounded
  have "bounded (\<lambda>pc. eff (bs!pc) G pc et) (length phi')"
    by (simp add: exec_def check_bounded_is_bounded)
  hence bounded': "bounded (exec G maxs rT et bs) (length bs)"
    by (auto intro: bounded_lift simp add: exec_def l)
  with wt_err_step
  have "wt_app_eff (sup_state_opt G) (\<lambda>pc. app (bs!pc) G maxs rT pc et)
                   (\<lambda>pc. eff (bs!pc) G pc et) (map ok_val phi')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l exec_def)
  with instrs l le bounded bounded' check_types maxr
  have "wt_method G C pTs rT maxs mxl bs et (map ok_val phi')"
    apply (unfold wt_method_def wt_app_eff_def)
    apply simp
    apply (rule conjI)
     apply (unfold wt_start_def)
     apply (rule JVM_le_convert [THEN iffD1])
     apply (simp (no_asm) add: phi0)
    apply clarify
    apply (erule allE, erule impE, assumption)
    apply (elim conjE)
    apply (clarsimp simp add: lesub_def wt_instr_def)
    apply (simp add: exec_def)
    apply (drule bounded_err_stepD, assumption+)
    apply blast
    done

  thus ?thesis by blast
qed

theorem wt_kil_complete:
  assumes wf:  "wf_prog wf_mb G"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  assumes wtm: "wt_method G C pTs rT maxs mxl bs et phi"

  shows "wt_kil G C pTs rT maxs mxl et bs"
proof -
  let ?mxr = "1+size pTs+mxl"

  from wtm obtain
    instrs:   "0 < length bs" and
    len:      "length phi = length bs" and
    bounded:  "check_bounded bs et" and
    ck_types: "check_types G maxs ?mxr (map OK phi)" and
    wt_start: "wt_start G C pTs mxl phi" and
    wt_ins:   "\<forall>pc. pc < length bs \<longrightarrow>
                    wt_instr (bs ! pc) G rT phi maxs (length bs) et pc"
    by (unfold wt_method_def) simp

  from ck_types len
  have istype_phi:
    "map OK phi \<in> list (length bs) (states G maxs (1+size pTs+mxl))"
    by (auto simp add: check_types_def intro!: listI)

  let ?eff  = "\<lambda>pc. eff (bs!pc) G pc et"
  let ?app   = "\<lambda>pc. app (bs!pc) G maxs rT pc et"

  from bounded
  have bounded_exec: "bounded (exec G maxs rT et bs) (size bs)"
    by (unfold exec_def) (intro bounded_lift check_bounded_is_bounded)

  from wt_ins
  have "wt_app_eff (sup_state_opt G) ?app ?eff phi"
    apply (unfold wt_app_eff_def wt_instr_def lesub_def)
    apply (simp (no_asm) only: len)
    apply blast
    done
  with bounded_exec
  have "wt_err_step (sup_state_opt G) (err_step (size phi) ?app ?eff) (map OK phi)"
    by - (erule wt_app_eff_imp_wt_err,simp add: exec_def len)
  hence wt_err:
    "wt_err_step (sup_state_opt G) (exec G maxs rT et bs) (map OK phi)"
    by (unfold exec_def) (simp add: len)

  from wf bounded_exec
  have is_bcv:
    "is_bcv (JVMType.le G maxs ?mxr) Err (exec G maxs rT et bs)
            (size bs) (states G maxs ?mxr) (kiljvm G maxs ?mxr rT et bs)"
    by (rule is_bcv_kiljvm)

  let ?start = "OK (Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err)))
                #(replicate (size bs - 1) (OK None))"

  from C pTs instrs
  have start: "?start \<in> list (length bs) (states G maxs ?mxr)"
    apply (unfold JVM_states_unfold)
    apply (rule listI)
    apply (auto intro!: list_appendI dest!: in_set_replicate)
    apply force
    done

  let ?phi = "map OK phi"
  have less_phi: "?start <=[JVMType.le G maxs ?mxr] ?phi"
  proof -
    from len instrs
    have "length ?start = length (map OK phi)" by simp
    moreover
    { fix n
      from wt_start
      have "G \<turnstile> ok_val (?start!0) <=' phi!0"
        by (simp add: wt_start_def)
      moreover
      from instrs len
      have "0 < length phi" by simp
      ultimately
      have "JVMType.le G maxs ?mxr (?start!0) (?phi!0)"
        by (simp add: JVM_le_Err_conv Err.le_def lesub_def)
      moreover
      { fix n'
        have "JVMType.le G maxs ?mxr (OK None) (?phi!n)"
          by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
            split: err.splits)
        hence "\<lbrakk> n = Suc n'; n < length ?start \<rbrakk>
          \<Longrightarrow> JVMType.le G maxs ?mxr (?start!n) (?phi!n)"
          by simp
      }
      ultimately
      have "n < length ?start \<Longrightarrow> (?start!n) <=_(JVMType.le G maxs ?mxr) (?phi!n)"
        by (unfold lesub_def) (cases n, blast+)
    }
    ultimately show ?thesis by (rule le_listI)
  qed

  from wt_err
  have "wt_step (JVMType.le G maxs ?mxr) Err (exec G maxs rT et bs) ?phi"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  with start istype_phi less_phi is_bcv
  have "\<forall>p. p < length bs \<longrightarrow> kiljvm G maxs ?mxr rT et bs ?start ! p \<noteq> Err"
    by (unfold is_bcv_def) auto
  with bounded instrs
  show "wt_kil G C pTs rT maxs mxl et bs" by (unfold wt_kil_def) simp
qed

theorem jvm_kildall_sound_complete:
  "wt_jvm_prog_kildall G = (\<exists>Phi. wt_jvm_prog G Phi)"
proof
  let ?Phi = "\<lambda>C sig. let (C,rT,(maxs,maxl,ins,et)) = the (method (G,C) sig) in
              SOME phi. wt_method G C (snd sig) rT maxs maxl ins et phi"

  assume "wt_jvm_prog_kildall G"
  hence "wt_jvm_prog G ?Phi"
    apply (unfold wt_jvm_prog_def wt_jvm_prog_kildall_def)
    apply (erule jvm_prog_lift)
    apply (auto dest!: wt_kil_correct intro: someI)
    done
  thus "\<exists>Phi. wt_jvm_prog G Phi" by fast
next
  assume "\<exists>Phi. wt_jvm_prog G Phi"
  thus "wt_jvm_prog_kildall G"
    apply (clarify)
    apply (unfold wt_jvm_prog_def wt_jvm_prog_kildall_def)
    apply (erule jvm_prog_lift)
    apply (auto intro: wt_kil_complete)
    done
qed

end


theory BPlusTree_Iter_OneWay
  imports
    BPlusTree_Imp
    "HOL-Real_Asymp.Inst_Existentials"
    "Separation_Logic_Imperative_HOL.Imp_List_Spec"
    Flatten_Iter
    Partially_Filled_Array_Iter
begin

fun leaf_nodes_assn :: "nat \<Rightarrow> ('a::heap) bplustree list \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btnode ref option \<Rightarrow> assn" where
  "leaf_nodes_assn k ((Leaf xs)#lns) (Some r) z =
 (\<exists>\<^sub>A xsi fwd.
      r \<mapsto>\<^sub>r Btleaf xsi fwd
    * is_pfa (2*k) xs xsi
    * leaf_nodes_assn k lns fwd z
  )" |
  "leaf_nodes_assn k [] r z = \<up>(r = z)" |
  "leaf_nodes_assn _ _ _ _ = false"

fun inner_nodes_assn :: "nat \<Rightarrow> ('a::heap) bplustree \<Rightarrow> 'a btnode ref \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btnode ref option \<Rightarrow> assn" where
  "inner_nodes_assn k (Leaf xs) a r z = \<up>(r = Some a)" |
  "inner_nodes_assn k (Node ts t) a r z =
 (\<exists>\<^sub>A tsi ti tsi' tsi'' rs.
      a \<mapsto>\<^sub>r Btnode tsi ti
    * inner_nodes_assn k t ti (last (r#rs)) (last (rs@[z]))
    * is_pfa (2*k) tsi' tsi
    * \<up>(length tsi' = length rs)
    * \<up>(tsi'' = zip (zip (map fst tsi') (zip (butlast (r#rs)) (butlast (rs@[z])))) (map snd tsi'))
    * list_assn ((\<lambda> t (ti,r',z'). inner_nodes_assn k t (the ti) r' z') \<times>\<^sub>a id_assn) ts tsi''
    )"

lemma leaf_nodes_assn_aux_append:
   "leaf_nodes_assn k (xs@ys) r z = (\<exists>\<^sub>Al. leaf_nodes_assn k xs r l * leaf_nodes_assn k ys l z)"
  apply(induction k xs r z rule: leaf_nodes_assn.induct)
  apply(sep_auto intro!: ent_iffI)+
  done

declare last.simps[simp del] butlast.simps[simp del]
declare mult.left_assoc[simp add]
lemma bplustree_leaf_nodes_help:
  "bplustree_assn k t ti r z \<Longrightarrow>\<^sub>A leaf_nodes_assn k (leaf_nodes t) r z * inner_nodes_assn k t ti r z"
proof(induction arbitrary: r rule: bplustree_assn.induct)
  case (1 k xs a r z)
  then show ?case
    by (sep_auto)
next
  case (2 k ts t a r z ra)
  show ?case
    apply(auto)
    apply(rule ent_ex_preI)+
  proof (goal_cases)
    case (1 tsi ti tsi' tsi'' rs)
    have *: "
        length tsi's = length rss \<Longrightarrow>
        length rss = length tss \<Longrightarrow>
        set tsi's \<subseteq> set tsi' \<Longrightarrow>
        set rss \<subseteq> set rs \<Longrightarrow>
        set tss \<subseteq> set ts \<Longrightarrow>
       bplustree_assn k t ti (last (ra # rss)) z *
       blist_assn k tss
        (zip (zip (subtrees tsi's) (zip (butlast (ra # rss)) rss)) (separators tsi's)) \<Longrightarrow>\<^sub>A
       leaf_nodes_assn k (concat (map (leaf_nodes \<circ> fst) tss) @ leaf_nodes t) ra z *
      inner_nodes_assn k t ti (last (ra#rss)) z *
       list_assn ((\<lambda> t (ti,r',z'). inner_nodes_assn k t (the ti) r' z') \<times>\<^sub>a id_assn) tss
        (zip (zip (subtrees tsi's) (zip (butlast (ra # rss)) rss)) (separators tsi's))
"
      for rss tsi's tss
    proof (induct arbitrary: ra rule: list_induct3)
      case (Nil r)
      then show ?case
        apply sep_auto
        using 2(1)[of ti r "[]"]
      apply (simp add: last.simps butlast.simps)
      done
    next
      case (Cons subsepi tsi's subleaf rss subsep tss r)
      show ?case
        apply (sep_auto
                simp add: butlast_double_Cons last_double_Cons)
        apply(subst prod_assn_def)
        apply(simp split!: prod.splits add: mult.left_assoc)
        apply(subst leaf_nodes_assn_aux_append)
        apply simp
        apply(inst_ex_assn subleaf)
      proof (goal_cases)
        case (1 sub sep)
        have "(sub,sep) \<in> set ts"
          using "1" Cons.prems(3) by force
        moreover have "set tsi's \<subseteq> set tsi' \<and> set rss \<subseteq> set rs \<and> set tss \<subseteq> set ts"
          by (meson Cons.prems set_subset_Cons subset_trans)
        moreover obtain temp1 temp2 where "((fst subsepi, (temp1:: 'a btnode ref option), subleaf), (temp2::'a)) \<in> set [((fst subsepi, temp1, subleaf), temp2)]"
          by auto
        ultimately  show ?case
          using
           Cons(3)[of subleaf]
           "2.IH"(2)[of "(sub,sep)"
                "((fst subsepi, (temp1, subleaf)),temp2)" "[((fst subsepi, (temp1, subleaf)),temp2)]"
                "fst subsepi" "(temp1, subleaf)" temp1 subleaf r]
          apply auto
          thm mult.commute
          thm star_aci
          apply(subst mult.commute)
          thm mult.commute[where b="inner_nodes_assn k sub (the (fst subsepi)) r subleaf"]
          apply(subst mult.commute[where b="inner_nodes_assn k sub (the (fst subsepi)) r subleaf"])
          find_theorems "_ * _ = _ * _"
          apply(simp)
          thm ent_star_mono
          supply R=ent_star_mono[where
P="bplustree_assn k sub (the (fst subsepi)) r subleaf" and P'="inner_nodes_assn k sub (the (fst subsepi)) r subleaf *
 leaf_nodes_assn k (leaf_nodes sub) r subleaf"
and Q="bplustree_assn k t ti (last (subleaf # rss)) z *
    id_assn sep (snd subsepi) *
    blist_assn k tss
     (zip (zip (subtrees tsi's) (zip (butlast (subleaf # rss)) rss)) (separators tsi's))"
and Q'="leaf_nodes_assn k (concat (map (\<lambda>a. leaf_nodes (fst a)) tss) @ leaf_nodes t) subleaf
     z *
    inner_nodes_assn k t ti (last (subleaf # rss)) z *
    id_assn sep (snd subsepi) *
    list_assn ((\<lambda>t (ti, x, y). inner_nodes_assn k t (the ti) x y) \<times>\<^sub>a id_assn) tss
     (zip (zip (subtrees tsi's) (zip (butlast (subleaf # rss)) rss)) (separators tsi's))"
          ,simplified]
          thm R
          apply(rule R)
          subgoal
            apply(subst mult.commute)
            by simp
          subgoal
            thm mult.commute
            apply(subst mult.commute[where b="id_assn _ _"], simp)+
            find_theorems "_ * _ = _* _"
            apply(subst mult.commute)
            supply R = ent_star_mono[where
              P="id_assn sep (snd subsepi)" and P'="id_assn sep (snd subsepi)"
and Q="bplustree_assn k t ti (last (subleaf # rss)) z *
    blist_assn k tss
     (zip (zip (subtrees tsi's) (zip (butlast (subleaf # rss)) rss))
       (separators tsi's))" and
Q'="leaf_nodes_assn k (concat (map (\<lambda>a. leaf_nodes (fst a)) tss) @ leaf_nodes t) subleaf
     z *
    inner_nodes_assn k t ti (last (subleaf # rss)) z *
    list_assn ((\<lambda>t (ti, x, y). inner_nodes_assn k t (the ti) x y) \<times>\<^sub>a id_assn) tss
     (zip (zip (subtrees tsi's) (zip (butlast (subleaf # rss)) rss))
       (separators tsi's))"
, simplified]
            thm R
            apply(rule R)
            apply simp
            done
      done
      qed
    qed
    show ?case
      apply(rule entails_preI)
        using 1 apply (auto dest!: mod_starD list_assn_len)
        using *[of tsi' rs ts, simplified]
        apply(inst_ex_assn tsi ti tsi' tsi'' rs)
        by (smt (z3) assn_aci(10) assn_times_comm fr_refl mult.right_neutral pure_true)
  qed
qed
declare last.simps[simp add] butlast.simps[simp add]
declare mult.left_assoc[simp del]

lemma bplustree_leaf_nodes:
  "bplustree_assn k t ti r z \<Longrightarrow>\<^sub>A leaf_nodes_assn k (leaf_nodes t) r z * inner_nodes_assn k t ti r z"
  using bplustree_leaf_nodes_help[of k t ti r z] by simp

fun leaf_node:: "('a::heap) bplustree \<Rightarrow> 'a list \<Rightarrow> assn" where
  "leaf_node (Leaf xs) xsi = \<up>(xs = xsi)" |
  "leaf_node _ _ = false"

fun leafs_assn :: "('a::heap) pfarray list \<Rightarrow> 'a btnode ref option \<Rightarrow> 'a btnode ref option \<Rightarrow> assn" where
  "leafs_assn (ln#lns) (Some r) z =
 (\<exists>\<^sub>A fwd.
      r \<mapsto>\<^sub>r Btleaf ln fwd
    * leafs_assn lns fwd z
  )" |
  "leafs_assn [] r z = \<up>(r = z)" |
  "leafs_assn _ _ _ = false"

lemma leafs_assn_aux_append:
   "leafs_assn (xs@ys) r z = (\<exists>\<^sub>Al. leafs_assn xs r l * leafs_assn ys l z)"
  apply(induction xs r z rule: leafs_assn.induct)
  apply(sep_auto intro!: ent_iffI)+
  done

lemma leaf_nodes_assn_split:
  "leaf_nodes_assn k ts r z = (\<exists>\<^sub>Aps. list_assn leaf_node ts (map bplustree.vals ts) * list_assn (is_pfa (2*k)) (map bplustree.vals ts) ps * leafs_assn ps r z)"
proof (induction ts arbitrary: r)
  case Nil
  then show ?case
  apply(intro ent_iffI)
    subgoal by sep_auto
    subgoal by sep_auto
    done
next
  case (Cons a xs)
  then show ?case
  proof(intro ent_iffI, goal_cases)
    case 1
    show ?case
      apply(cases r; cases a)
      apply simp_all
      find_theorems "\<exists>\<^sub>A_._ \<Longrightarrow>\<^sub>A_"
      apply(rule ent_ex_preI)+
      subgoal for aa x1 xsi fwd
      apply (subst "Cons.IH"[of fwd])
        apply simp
      apply(rule ent_ex_preI)+
        subgoal for ps
          apply(inst_ex_assn "xsi#ps")
          apply simp_all
          apply(inst_ex_assn fwd)
          apply (sep_auto)
          done
        done
      done
  next
    case 2
    have *: "list_assn leaf_node xs (map bplustree.vals xs) * list_assn (is_pfa (2 * k)) (map bplustree.vals xs) ps' * leafs_assn ps' r' z
          \<Longrightarrow>\<^sub>A leaf_nodes_assn k xs r' z"
      for ps' r'
      using assn_eq_split(1)[OF sym[OF "Cons.IH"[of r']]]
             ent_ex_inst[where Q="leaf_nodes_assn k xs r' z" and y=ps']
      by blast
    show ?case
      apply(rule ent_ex_preI)+
      subgoal for ps
        apply(cases ps; cases r; cases a)
      apply simp_all
      apply(rule ent_ex_preI)+
        subgoal for aa list aaa x1 fwd
          apply(inst_ex_assn aa fwd)
          apply sep_auto
          using *[of list fwd]
          by (smt (z3) assn_aci(9) assn_times_comm fr_refl)
        done
      done
  qed
qed

lemma inst_same: "(\<And>x. P x = Q x) \<Longrightarrow> (\<exists>\<^sub>A x. P x) = (\<exists>\<^sub>A x. Q x)"
  by simp

lemma inst_same2: "(\<And>x. P = Q x) \<Longrightarrow> P = (\<exists>\<^sub>A x. Q x)"
  by simp

lemma pure_eq_pre: "(P \<Longrightarrow> Q = R) \<Longrightarrow> (Q * \<up>P = R * \<up>P)"
  by fastforce

lemma bplustree_leaf_nodes_sep:
  "leaf_nodes_assn k (leaf_nodes t) r z * (leaf_nodes_assn k (leaf_nodes t) r z -* bplustree_assn k t ti r z) \<Longrightarrow>\<^sub>A bplustree_assn k t ti r z"
  by (simp add: ent_mp)

declare last.simps[simp del] butlast.simps[simp del]
lemma bplustree_leaf_nodes_sep:
  "bplustree_assn k t ti r z = leaf_nodes_assn k (leaf_nodes t) r z * (leaf_nodes_assn k (leaf_nodes t) r z -* bplustree_assn k t ti r z)"
  oops

(* this doesn't hold, we need to know more about the remaining list,
specifically because inner_nodes_assn doesn't say anything about next pointers *)
lemma leaf_nodes_assn_split_spec: "leaf_nodes_assn k
        (leaf_nodes x @ ys) r z *
       inner_nodes_assn k x a r m =
      leaf_nodes_assn k (leaf_nodes x) r m * leaf_nodes_assn k ys m z *
       inner_nodes_assn k x a r m"
    oops

(* TODO find a statement that cleanly separates the heap *)
declare last.simps[simp del] butlast.simps[simp del]
lemma bplustree_leaf_nodes_sep:
  "bplustree_assn k t ti r z = leaf_nodes_assn k (leaf_nodes t) r z * inner_nodes_assn k t ti r z"
  oops
(*
proof(induction arbitrary: r rule: bplustree_assn.induct)
  case (1 k xs a r z)
  then show ?case
    apply(intro ent_iffI)
    apply sep_auto+
    done
next
  case (2 k ts t a r z ra)
  show ?case
      apply simp
    apply(rule inst_same)+
    apply(rule pure_eq_pre)
    proof(goal_cases)
      case (1 tsi ti tsi' tsi'' rs)
      have *: "
          length tsi's = length rss \<Longrightarrow>
          length rss = length tss \<Longrightarrow>
          set tsi's \<subseteq> set tsi' \<Longrightarrow>
          set rss \<subseteq> set rs \<Longrightarrow>
          set tss \<subseteq> set ts \<Longrightarrow>
         bplustree_assn k t ti (last (ra # rss)) z *
         blist_assn k tss
          (zip (zip (subtrees tsi's) (zip (butlast (ra # rss)) rss)) (separators tsi's)) =
         leaf_nodes_assn k (concat (map (leaf_nodes \<circ> fst) tss) @ leaf_nodes t) ra z *
         list_assn ((\<lambda>t (ti, x, y). inner_nodes_assn k t (the ti) x y) \<times>\<^sub>a id_assn) tss
         (zip (zip (subtrees tsi's) (zip (butlast (ra # rss)) rss)) (separators tsi's)) *
        inner_nodes_assn k t ti (last (ra#rss)) z"
        for rss tsi's tss
      proof (induct arbitrary: ra rule: list_induct3)
        case (Nil r)
        then show ?case
          apply sep_auto
          using 2(1)[of ti r]
          apply (simp add: last.simps)
          done
      next
        case (Cons subsepi tsi's subleaf rss subsep tss r)
        show ?case
        apply (sep_auto
                simp add: butlast_double_Cons last_double_Cons)
          apply(subst prod_assn_def)
        apply(simp split!: prod.splits add: mult.left_assoc)
        (*apply(subst leaf_nodes_assn_split_spec)*)
        proof(goal_cases)
          case (1 sub sep)
          moreover have p: "set tsi's \<subseteq> set tsi'"
               "set rss \<subseteq> set rs"
               "set tss \<subseteq> set ts"
            using Cons.prems by auto
          moreover have "(sub,sep) \<in> set ts"
            using "1" Cons.prems(3) by force
          moreover obtain temp1 temp2 where "((fst subsepi, (temp1:: 'a btnode ref option), subleaf), (temp2::'a)) \<in> set [((fst subsepi, temp1, subleaf), temp2)]"
            by auto
          ultimately show ?case
            apply(inst_ex_assn subleaf)
            using "Cons.hyps"(3)[of subleaf, OF p]
            apply (auto simp add: algebra_simps)
            using "2.IH"(2)[of subsep "((fst subsepi, (temp1, subleaf)),temp2)" "[((fst subsepi, (temp1, subleaf)),temp2)]"
                "fst subsepi" "(temp1, subleaf)" temp1 subleaf r]
            apply auto
            using assn_times_assoc ent_refl by presburger
        qed
      qed
      show ?case
        apply(intro ent_iffI)
        subgoal
         apply(rule entails_preI)
          using 1
        apply(auto dest!: mod_starD list_assn_len)
        using *[of tsi' rs ts, simplified]
        apply (smt (z3) assn_aci(10) assn_times_comm entails_def)
        done
      subgoal
         apply(rule entails_preI)
        using 1
        apply(auto dest!: mod_starD list_assn_len)
        using *[of tsi' rs ts, simplified]
        apply (smt (z3) assn_aci(10) assn_times_comm entails_def)
        done
      done
    qed
  qed
declare last.simps[simp add] butlast.simps[simp add]
*)

subsection "Iterator"

partial_function (heap) first_leaf :: "('a::heap) btnode ref \<Rightarrow> 'a btnode ref option Heap"
  where
    "first_leaf p = do {
  node \<leftarrow> !p;
  (case node of
    Btleaf _ _ \<Rightarrow> do { return (Some p) } |
    Btnode tsi ti \<Rightarrow> do {
        s \<leftarrow> pfa_get tsi 0;
        let (sub,sep) = s in do {
          first_leaf (the sub)
        }
  }
)}"

partial_function (heap) last_leaf :: "('a::heap) btnode ref \<Rightarrow> 'a btnode ref option Heap"
  where
    "last_leaf p = do {
  node \<leftarrow> !p;
  (case node of
    Btleaf _ z \<Rightarrow> do { return z } |
    Btnode tsi ti \<Rightarrow> do {
        last_leaf ti
  }
)}"

declare last.simps[simp del] butlast.simps[simp del]
lemma first_leaf_rule[sep_heap_rules]:
  assumes "k > 0" "root_order k t"
  shows "<bplustree_assn k t ti r z>
  first_leaf ti
  <\<lambda>u. bplustree_assn k t ti r z * \<up>(u = r)>\<^sub>t"
  using assms
proof(induction t arbitrary: ti z)
  case (Leaf x)
  then show ?case
    apply(subst first_leaf.simps)
    apply (sep_auto dest!: mod_starD)
    done
next
  case (Node ts t)
  then obtain sub sep tts where Cons: "ts = (sub,sep)#tts"
    apply(cases ts) by auto
  then show ?case
    apply(subst first_leaf.simps)
    apply (sep_auto simp add: butlast.simps)
    subgoal for tsia tsil ti tsi' rs subi sepi
    apply(cases rs; cases tsi')
    apply simp_all
      subgoal for subleaf rrs _ ttsi'
        supply R = "Node.IH"(1)[of "(sub,sep)" sub "(the subi)" subleaf]
        thm R
    using  "Node.prems"(1)
    apply (sep_auto heap add: R)
    subgoal by (metis Node.prems(2) assms(1) bplustree.inject(2) bplustree.simps(4) Cons list.set_intros(1) order_impl_root_order root_order.elims(2) some_child_sub(1))
    apply (sep_auto eintros del: exI)
    apply(inst_existentials tsia tsil ti "(subi, sepi) # ttsi'" "((subi, (r, subleaf)),sepi)#(zip (zip (subtrees ttsi') (zip (butlast (subleaf # rrs)) rrs)) (separators ttsi'))" "subleaf # rrs")
    apply (sep_auto simp add: last.simps butlast.simps)+
    done
  done
  done
qed
declare last.simps[simp add] butlast.simps[simp add]

declare last.simps[simp del] butlast.simps[simp del]
lemma last_leaf_rule[sep_heap_rules]:
  assumes "k > 0" "root_order k t"
  shows "<bplustree_assn k t ti r z>
  last_leaf ti
  <\<lambda>u. bplustree_assn k t ti r z * \<up>(u = z)>\<^sub>t"
  using assms
proof(induction t arbitrary: ti r)
  case (Leaf x)
  then show ?case
    apply(subst last_leaf.simps)
    apply (sep_auto dest!: mod_starD)
    done
next
  case (Node ts t)
  show ?case
    apply(subst last_leaf.simps)
        supply R = "Node.IH"(2)
    apply (sep_auto heap add: R)
    subgoal using "Node.prems" by simp
    subgoal by (metis Node.prems(2) assms(1) bplustree.inject(2) bplustree.simps(4) Cons list.set_intros(1) order_impl_root_order root_order.elims(2) some_child_sub(1))
    apply (sep_auto eintros del: exI)
    subgoal for tsia tsil ti tsi' rs
    apply(inst_existentials tsia tsil ti "tsi'" " (zip (zip (subtrees tsi') (zip (butlast (r # rs)) rs)) (separators tsi'))" rs)
    apply (sep_auto simp add: last.simps butlast.simps)+
    done
  done
qed
declare last.simps[simp add] butlast.simps[simp add]

definition tree_leaf_iter_init where
"tree_leaf_iter_init p = do {
  r \<leftarrow> first_leaf (the p);
  z \<leftarrow> last_leaf (the p);
  return  (r, z)
}"

lemma tree_leaf_iter_init_rule:
  assumes "k > 0" "root_order k t"
  shows "<bplustree_assn k t ti r z>
  tree_leaf_iter_init (Some ti)
  <\<lambda>(u,v). leaf_nodes_assn k (leaf_nodes t) u v * inner_nodes_assn k t ti r z * \<up>(u = r \<and> v = z)>\<^sub>t"
  using assms
  using bplustree_leaf_nodes_help[of k t ti r z]
  unfolding tree_leaf_iter_init_def
  apply (sep_auto)
  using ent_star_mono ent_true by blast

definition leaf_iter_next where
"leaf_iter_next = (\<lambda>(r,z). do {
  p \<leftarrow> !(the r);
  return (vals p, (fwd p, z))
})"

lemma leaf_iter_next_rule_help:
  "<leafs_assn (x#xs) r z>
      leaf_iter_next (r,z)
   <\<lambda>(p,(n,z')). leafs_assn [x] r n * leafs_assn xs n z' * \<up>(p = x) * \<up>(z=z')>"
  apply(subst leaf_iter_next_def)
  apply(cases r; cases x)
  apply(sep_auto)+
  done

definition leaf_iter_assn where "leaf_iter_assn xs r xs2 = (\<lambda>(n,z).
  (\<exists>\<^sub>Axs1. \<up>(xs = xs1@xs2) * leafs_assn xs1 r n * leafs_assn xs2 n z * \<up>(z=None)))"

lemma leaf_nodes_assn_imp_iter_assn: "leafs_assn xs r None \<Longrightarrow>\<^sub>A leaf_iter_assn xs r xs (r,None)"
  unfolding leaf_iter_assn_def
  by sep_auto

definition leaf_iter_init where
"leaf_iter_init p = do {
  return  (p, None)
}"

lemma leaf_iter_init_rule:
  shows "<leafs_assn xs r None>
  leaf_iter_init r
  <\<lambda>u. leaf_iter_assn xs r xs u>"
  unfolding leaf_iter_init_def
  using leaf_nodes_assn_imp_iter_assn
  by (sep_auto)

lemma leaf_iter_next_rule: "<leaf_iter_assn xs r (x#xs2) it>
leaf_iter_next it
<\<lambda>(p, it'). leaf_iter_assn xs r xs2 it' * \<up>(p = x)>"
  unfolding leaf_iter_assn_def
  apply(cases it)
  by (sep_auto heap add: leaf_iter_next_rule_help simp add: leafs_assn_aux_append)

definition leaf_iter_has_next where
"leaf_iter_has_next  = (\<lambda>(r,z). return (r \<noteq> z))"

(* TODO this so far only works for the whole tree (z = None)
for subintervals, we would need to show that the list of pointers is indeed distinct,
hence r = z can only occur at the end *)
lemma leaf_iter_has_next_rule:
  "<leaf_iter_assn xs r xs2 it> leaf_iter_has_next it <\<lambda>u. leaf_iter_assn xs r xs2 it * \<up>(u \<longleftrightarrow> xs2 \<noteq> [])>"
  unfolding leaf_iter_has_next_def
  apply(cases it)
  apply(sep_auto simp add: leaf_iter_assn_def split!: prod.splits dest!: mod_starD)
  subgoal for a
  apply(cases xs2; cases a)
    by auto
  done

(* copied from peter lammichs lseg_prec2 *)
declare mult.left_commute[simp add]
lemma leafs_assn_prec2:
  "\<forall>l l'. (h\<Turnstile>
      (leafs_assn l p None * F1) \<and>\<^sub>A (leafs_assn l' p None * F2))
    \<longrightarrow> l=l'"
  apply (intro allI)
  subgoal for l l'
  proof (induct l arbitrary: p l' F1 F2)
    case Nil thus ?case
      apply simp_all
      apply (cases l')
      apply simp
      apply (cases p)
      apply auto
      done
  next
    case (Cons y l)
    from Cons.prems show ?case
      apply (cases p)
      apply simp
      apply (cases l')
      apply (auto) []
      apply (clarsimp)
      apply (rule)
      apply (drule_tac p=a in prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      subgoal for a aa b list fwd fwda
        apply(subgoal_tac "fwd=fwda")
      using Cons.hyps[of fwd "a \<mapsto>\<^sub>r Btleaf y fwda * F1" list "a \<mapsto>\<^sub>r Btleaf (aa, b) fwd * F2", simplified]
       apply (simp add: mult.left_assoc mod_and_dist)
      apply (simp add: ab_semigroup_mult_class.mult.commute)
      apply (drule_tac p=a in prec_frame[OF sngr_prec])
      apply frame_inference
      apply frame_inference
      apply simp
      done
    done
  qed
  done
declare mult.left_commute[simp del]

interpretation leaf_node_it: imp_list_iterate
    "\<lambda>x y. leafs_assn x y None"
    leaf_iter_assn
    leaf_iter_init
    leaf_iter_has_next
    leaf_iter_next
  apply(unfold_locales)
  subgoal
    by (simp add: leafs_assn_prec2 precise_def)
  subgoal for l p
    by (sep_auto heap add: leaf_iter_init_rule)
  subgoal for l' l p it
    thm leaf_iter_next_rule
    apply(cases l'; cases it)
    by (sep_auto heap add: leaf_iter_next_rule)+
  subgoal for l p l' it'
    thm leaf_iter_has_next_rule
    apply(cases it')
    apply(rule hoare_triple_preI)
    apply(sep_auto heap add: leaf_iter_has_next_rule)
    done
  subgoal for l p l' it
  unfolding leaf_iter_assn_def
  apply(cases it)
    apply simp_all
  apply(rule ent_ex_preI)
  by (sep_auto simp add: leafs_assn_aux_append)
  done

interpretation leaf_elements_iter: flatten_iter
  "\<lambda>x y. leafs_assn x y None" leaf_iter_assn leaf_iter_init leaf_iter_has_next leaf_iter_next
  "is_pfa (2*k)" "pfa_is_it (2*k)" pfa_it_init pfa_it_has_next pfa_it_next
  by (unfold_locales)

thm leaf_elements_iter.is_flatten_list.simps
thm leaf_elements_iter.is_flatten_it.simps
thm tree_leaf_iter_init_def
thm leaf_elements_iter.flatten_it_init_def
print_theorems

fun leaf_elements_iter_init :: "('a::heap) btnode ref \<Rightarrow> _" where
  "leaf_elements_iter_init ti = do {
        rz \<leftarrow> tree_leaf_iter_init (Some ti);
        it \<leftarrow> leaf_elements_iter.flatten_it_init (fst rz);
        return it
}"

(* NOTE: the other direction does not work, we are loosing information here
  workaround: introduce specialized is_flatten_list assumption, show that all operations
  preserve its correctness
*)
lemma leaf_nodes_imp_flatten_list:
  "leaf_nodes_assn k ts r None \<Longrightarrow>\<^sub>A
   list_assn leaf_node ts (map bplustree.vals ts) *
   leaf_elements_iter.is_flatten_list k (concat (map bplustree.vals ts)) r"
  apply(simp add: leaf_nodes_assn_split)
  apply(rule ent_ex_preI)+
  subgoal for ps
    apply(inst_ex_assn ps "map bplustree.vals ts")
    apply sep_auto
    done
  done

lemma concat_leaf_nodes_leaves: "(concat (map bplustree.vals (leaf_nodes t))) = leaves t"
  apply(induction t rule: leaf_nodes.induct)
  subgoal by auto
  subgoal for ts t
    apply(induction ts)
    subgoal by simp
    subgoal by auto
    done
  done

lemma leaf_elements_iter_init_rule:
  assumes "k > 0" "root_order k t"
  shows "<bplustree_assn k t ti r None>
leaf_elements_iter_init ti
<leaf_elements_iter.is_flatten_it k (leaves t) r (leaves t)>\<^sub>t"
  unfolding leaf_elements_iter_init.simps
  using assms
  apply (sep_auto heap add:
      tree_leaf_iter_init_rule
  )
    supply R = Hoare_Triple.cons_pre_rule[OF leaf_nodes_imp_flatten_list[of k "leaf_nodes t" r],
        where Q="\<lambda>it. leaf_elements_iter.is_flatten_it k (leaves t) r (leaves t) it * true"
        and c="leaf_elements_iter.flatten_it_init r"]
    thm R
    apply(sep_auto heap add: R)
    subgoal
      apply(simp add: concat_leaf_nodes_leaves)
      apply sep_auto
        done
    subgoal by sep_auto
    done

end


theory BiStateTransformers
  imports "../Algebra/PartialQuantales" "../Algebra/BBI"
begin

no_notation plus (infixl "+" 65)
no_notation pmult (infixl "*" 80)
no_notation pmult_one ("1")
notation pmult (infixl "\<oplus>" 80)
notation times (infixl "*" 70)
notation sup (infixl "+" 65)
notation inf (infixl "\<sqinter>" 70)
notation one_class.one ("1")

text {*
  We extend the state transformers to two dimensions (to accommodate store and heap)
*}

declare [[coercion_enabled]]
typedef ('a, 'b, 'c) bifun = "{f :: ('a \<times> 'b \<Rightarrow> 'c). True}" by auto
declare [[coercion Rep_bifun]]
setup_lifting type_definition_bifun

instantiation bifun :: (type, type, complete_lattice) bounded_lattice
begin
lift_definition bot_bifun :: "('a, 'b, 'c) bifun" is bot ..
lift_definition sup_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun" is sup ..
lift_definition top_bifun :: "('a, 'b, 'c) bifun" is top ..
lift_definition inf_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun" is inf ..
lift_definition less_eq_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun \<Rightarrow> bool" is less_eq .
lift_definition less_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun \<Rightarrow> bool" is less .
instance
  by default (transfer, auto)+
end

instantiation bifun :: (type, type, complete_lattice) complete_lattice
begin
lift_definition Inf_bifun :: "('a, 'b, 'c) bifun set \<Rightarrow> ('a, 'b, 'c) bifun" is Inf ..
lift_definition Sup_bifun :: "('a, 'b, 'c) bifun set \<Rightarrow> ('a, 'b, 'c) bifun" is Sup ..
instance
  by default (transfer, auto intro: Sup_least Sup_upper Inf_greatest Inf_lower)+
end

instance bifun :: (type, type, complete_distrib_lattice) complete_distrib_lattice
apply default
apply (unfold INF_def)
apply transfer
apply auto
apply (metis sup_Inf)
apply (unfold SUP_def)
apply transfer
apply auto
by (metis inf_Sup)

instantiation bifun :: (type, partial_semigroup, quantale_Sup) quantale_Sup
begin

lift_definition times_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun"
  is "\<lambda>f g (x, y). \<Squnion> {f (x, y1) * g (x, y2) | y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2}" ..

lemma ext_bifun [intro]: "(\<And>x y. Rep_bifun f (x, y) = Rep_bifun g (x, y)) \<Longrightarrow> (f :: ('a, 'b, 'c) bifun) = g"
  apply transfer
  by auto

lemma le_bifunI [intro]: "(\<And>x y. Rep_bifun f (x, y) \<le> Rep_bifun g (x, y)) \<Longrightarrow> f \<le> g"
  apply transfer
  by (metis PairE le_funI)

lemma qmult_bifun_apply [simp, code]:
  "((f :: ('a, 'b, 'c) bifun) * g) (x, y) = \<Squnion> {f (x, y1) * g (x, y2) | y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2}"
  by transfer auto

lemma sup_distrib_left_bifun: "((f :: ('a, 'b, 'c) bifun) * (g + h)) (x, y) = (f * g + f * h) (x, y)"
  apply transfer
  apply auto
  apply (subst Sup.qdistl)
  by simp

lemma sup_distrib_right_bifun: "(((f :: ('a, 'b, 'c) bifun) + g) * h) x = (f * h + g * h) x"
  apply transfer
  apply auto
  apply (subst Sup.qdistr)
  by simp

lemma qSup_distl_bifun: "((f :: ('a, 'b, 'c) bifun) * \<Squnion>G) x = (\<Squnion>(op * f ` G)) x"
  apply transfer
  apply (auto simp add: qSUP_distl intro!: antisym Sup_least SUP_mono)
  apply (rule_tac x=xa in bexI)
  apply (rule Sup_upper)
  apply auto
  apply (rule SUP_least)
  apply (rule Sup_mono)
  apply auto
  by (metis (mono_tags) SUP_upper)

lemma qSup_distr_bifun: "(\<Squnion>G * (f :: ('a, 'b, 'c) bifun)) x = (\<Squnion>((\<lambda>g. g * f) ` G)) x"
  apply transfer
  apply (auto simp add: qSUP_distr intro!: antisym Sup_least SUP_mono)
  apply (rule_tac x=xa in bexI)
  apply (rule Sup_upper)
  apply auto
  apply (rule SUP_least)
  apply (rule Sup_mono)
  apply auto
  by (metis (mono_tags) SUP_upper)

lemma Sup_distl_assoc_bifun: "(f :: ('a, 'b, 'c) bifun) (x, y1) * \<Squnion>{g (x, y2) * h (x, y3) |y2 y3. y = y2 \<oplus> y3 \<and> y2 ## y3} = \<Squnion>{f (x, y1) * (g (x, y2) * h (x, y3)) |y2 y3. y = y2 \<oplus> y3 \<and> y2 ## y3}"
  by (auto simp only: Sup.Join_distl intro: Sup.Join_eqI2)

lemma qSup_distr_assoc_bifun: "\<Squnion>{((f :: ('a, 'b, 'c) bifun) (x, y1) * g (x, y2)) | y1 y2. y = (y1 \<oplus> y2) \<and> y1 ## y2} * h (x, y3) = \<Squnion>{(f (x, y1) * g (x, y2)) * h (x, y3) | y1 y2. y = (y1 \<oplus> y2) \<and> y1 ## y2}"
  by (auto simp only: qSup_distr intro: Sup.Join_eqI2)

lemma qmult_assoc_bifun: "((f :: ('a, 'b, 'c) bifun) * (g * h)) (x, y) = ((f * g) * h) (x, y)"
proof simp
  have "\<Squnion>{f (x, y1) * \<Squnion>{g (x, y1) * h (x, y2a) |y1 y2a. y2 = y1 \<oplus> y2a \<and> y1 ## y2a} |y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2} =
    \<Squnion>{\<Squnion>{f (x, y1) * (g (x, y1a) * h (x, y2a)) |y1a y2a. y2 = y1a \<oplus> y2a \<and> y1a ## y2a} |y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2}"
    by (unfold Sup_distl_assoc_bifun) simp
  also have "... = \<Squnion>{\<Squnion>{(f (x, y1) * g (x, y1a)) * h (x, y2a) |y1a y2a. y2 = y1a \<oplus> y2a \<and> y1a ## y2a} |y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2}"
    by (subst mult.assoc) simp
  also have "... = \<Squnion>{(f (x, y1) * g (x, y1a)) * h (x, y2a) |y1a y2a y1 y2. y2 = y1a \<oplus> y2a \<and> y1a ## y2a \<and> y = y1 \<oplus> y2 \<and> y1 ## y2}"
    apply (rule antisym)
    apply (rule Sup_least)
    apply safe
    apply (rule Sup_mono)
    apply auto
    apply (rule Sup_least)
    apply auto
    apply transfer
    apply auto
    proof -
      fix y1a :: 'b and y2a :: 'b and y1 :: 'b and fa :: "'a \<times> 'b \<Rightarrow> 'c" and xa :: 'a and ga :: "'a \<times> 'b \<Rightarrow> 'c" and ha :: "'a \<times> 'b \<Rightarrow> 'c"
      assume a1: "y1a ## y2a"
      assume a2: "y1 ## y1a \<oplus> y2a"
      obtain sk\<^sub>8\<^sub>2 :: "'b \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'b" and sk\<^sub>8\<^sub>1 :: "'b \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'b" where "\<exists>y1aa y2aa. fa (xa, y1) * ga (xa, y1a) * ha (xa, y2a) = fa (xa, y1) * ga (xa, y1aa) * ha (xa, y2aa) \<and> y1a \<oplus> y2a = y1aa \<oplus> y2aa \<and> y1aa ## y2aa" using a1 by blast
      hence "fa (xa, y1) * ga (xa, y1a) * ha (xa, y2a) \<le> \<Squnion>{fa (xa, y1) * ga (xa, y1aa) * ha (xa, y2aa) |y1aa y2aa. y1a \<oplus> y2a = y1aa \<oplus> y2aa \<and> y1aa ## y2aa}" by (simp add: Sup.Join_Collect_upper)
      then obtain sk\<^sub>7 :: "'c \<Rightarrow> 'b" and sk\<^sub>6 :: "'c \<Rightarrow> 'b" where "\<exists>x\<^sub>0\<ge>fa (xa, y1) * ga (xa, y1a) * ha (xa, y2a). x\<^sub>0 \<in> {\<Squnion>{fa (xa, y1b) * ga (xa, y1a) * ha (xa, y2a) |y1a y2a. y2 = y1a \<oplus> y2a \<and> y1a ## y2a} | y1b y2. y1 \<oplus> (y1a \<oplus> y2a) = y1b \<oplus> y2 \<and> y1b ## y2}" using a2 by blast
      thus "fa (xa, y1) * ga (xa, y1a) * ha (xa, y2a) \<le> \<Squnion>{\<Squnion>{fa (xa, y1b) * ga (xa, y1a) * ha (xa, y2a) |y1a y2a. y2 = y1a \<oplus> y2a \<and> y1a ## y2a} | y1b y2. y1 \<oplus> (y1a \<oplus> y2a) = y1b \<oplus> y2 \<and> y1b ## y2}" by (smt Sup_upper2) (* > 2 s, timed out *)
    qed
  also have "... = \<Squnion>{(f (x, y1) * g (x, y1a)) * h (x, y2a) |y1a y2a y1. y1a ## y2a \<and> y = y1 \<oplus> (y1a \<oplus> y2a) \<and> y1 ## (y1a \<oplus> y2a)}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion>{(f (x, y1) * g (x, y1a)) * h (x, y2a) |y1a y2a y1. y1 ## y1a \<and> y = (y1 \<oplus> y1a) \<oplus> y2a \<and> (y1 \<oplus> y1a) ## y2a}"
    by (metis (erased, lifting) partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
  also have "... = \<Squnion>{(f (x, y1) * g (x, y1a)) * h (x, y2) |y1a y2a y1 y2. y1 ## y1a \<and> y2a = y1 \<oplus> y1a \<and> y = y2a \<oplus> y2 \<and> y2a ## y2}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion>{\<Squnion>{f (x, y1) * g (x, y1a) |y1 y1a. y2a = y1 \<oplus> y1a \<and> y1 ## y1a} * h (x, y2) |y2a y2. y = y2a \<oplus> y2 \<and> y2a ## y2}"
    apply (rule antisym)
    apply (rule Sup_least)
    apply auto
    defer
    apply (rule Sup_least)
    apply auto
    apply (subst qSup_distr_assoc_bifun)
    apply (rule Sup_mono)
    apply auto
    apply (subgoal_tac "\<exists>y2a y2b. y1 \<oplus> y1a \<oplus> y2 = y2a \<oplus> y2b \<and> y2a ## y2b \<and> f (x, y1) * g (x, y1a) * h (x, y2) \<le> \<Squnion>{f (x, y1) * g (x, y1a) |y1 y1a. y2a = y1 \<oplus> y1a \<and> y1 ## y1a} * h (x, y2b) ")
    apply (smt Sup_upper2 mem_Collect_eq)
    apply (subst qSup_distr_assoc_bifun)
    by (smt Sup_le_iff dual_order.refl mem_Collect_eq)
  finally show "\<Squnion>{f (x, y1) * \<Squnion>{g (x, y1) * h (x, y2a) |y1 y2a. y2 = y1 \<oplus> y2a \<and> y1 ## y2a} |y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2} =
                 \<Squnion>{\<Squnion>{f (x, y1a) * g (x, y2) |y1a y2. y1 = y1a \<oplus> y2 \<and> y1a ## y2} * h (x, y2) |y1 y2. y = y1 \<oplus> y2 \<and> y1 ## y2}"
   by auto
qed

instance
  apply default
  apply (rule ext_bifun,rule qmult_assoc_bifun[symmetric])
  apply (rule ext_bifun, rule qSup_distr_bifun)
  by (metis (lifting, mono_tags) qSup_distl_bifun eq_iff le_bifunI)+

end

text {* Unit is also lifted *}

instantiation bifun :: (type, partial_monoid, quantale_Sup_unital) quantale_Sup_unital
begin

lift_definition one_bifun :: "('a, 'b, 'c) bifun" is "\<lambda>(x, y). if y = 1' then 1 else \<bottom>" ..

lemma qunitl_bifun[simp]: "Rep_bifun (1 * f) (x, y) = Rep_bifun f (x, y)"
  apply transfer
  by (auto simp: pmult_onel one_bifun_def intro!: Sup_eqI)

lemma qunitr_bifun[simp]: "Rep_bifun (f * 1) (x, y) = Rep_bifun f (x, y)"
  apply transfer
  by (auto simp: pmult_oner one_bifun_def intro!: Sup_eqI)

instance
  by default (auto intro: qunitr_bifun qunitl_bifun)

end

text {* Commutativity is also lifted *}

instance bifun :: (type, partial_ab_semigroup, comm_quantale_Sup) comm_quantale_Sup
apply default
apply (rule ext_bifun)
apply transfer
by (auto simp: mult.commute intro: pmult_comm pmult_comm_def Sup.Join_eqI2)

instance bifun :: (type, partial_comm_monoid, comm_quantale_Sup_unital) comm_quantale_Sup_unital
  by default auto

text {* Distributivity is also lifted *}

instance bifun :: (type, partial_semigroup, distrib_quantale_Sup) distrib_quantale_Sup ..

instance bifun :: (type, partial_comm_monoid, distrib_comm_quantale_Sup_unital) distrib_comm_quantale_Sup_unital ..

instantiation bifun :: (type, partial_comm_monoid, bbi) bbi
begin

lift_definition minus_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun"
  is "\<lambda>f g (x, y). f (x, y) - g (x, y)" ..
lift_definition uminus_bifun :: "('a, 'b, 'c) bifun \<Rightarrow> ('a, 'b, 'c) bifun" is "\<lambda>f (x, y). - f(x, y)" ..

instance
  apply default
  apply transfer
  apply (rule ext)
  apply auto
  apply (metis inf_compl_bot)
  apply transfer
  apply (rule ext)
  apply auto
  apply (metis sup_compl_top)
  apply transfer
  apply (rule ext)
  apply auto
  by (metis diff_eq)
end

end


theory prop_46
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype ('a, 'b) Pair2 = Pair "'a" "'b"
  fun zip :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip (Nil2) y = Nil2"
  | "zip (Cons2 z x2) (Nil2) = Nil2"
  | "zip (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair z x3) (zip x2 x4)"
  (*hipster zip *)
  theorem x0 :
    "(zip (Nil2) xs) = (Nil2)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*******************************************************************************

  Project: Development of Security Protocols by Refinement

  Module:   Key_establish/m1_ds.thy (Isabelle/HOL 2016-1)
  ID:       $Id: m1_ds.thy 133856 2017-03-20 18:05:54Z csprenge $
  Author:   Ivano Somaini, ETH Zurich <somainii@student.ethz.ch>
            Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Key distribution protocols
  abstract version of Denning-Sacco with non-injective server authentication
  using timestamps

  Copyright (c) 2009-2016 Ivano Somaini, Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Abstract Denning-Sacco protocol (L1)\<close>

theory m1_ds imports m1_keydist_inrn "../Refinement/a0n_agree"
begin

text \<open>We augment the basic abstract key distribution model such that
the server sends a timestamp along with the session key. We check the
timestamp's validity to ensure recentness of the session key.

We establish one refinement for this model, namely that this model refines
the basic authenticated key transport model \<open>m1_keydist_inrn\<close>,
which guarantees non-injective agreement with the server on the session key
and the server-generated timestamp.
\<close>

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

text \<open>We extend the basic key distribution by adding timestamps.
We add a clock variable modeling the current time.  The frames, runs, and
observations remain the same as in the previous model, but we will use
the @{typ "nat list"}'s to store timestamps.
\<close>

type_synonym
  time = "nat"                     \<comment> \<open>for clock and timestamps\<close>

consts
  Ls :: "time"                     \<comment> \<open>life time for session keys\<close>

text \<open>State and observations\<close>

record
  m1_state = "m1x_state" +
    clk :: "time"

type_synonym
  m1_obs = "m1_state"

type_synonym
  'x m1_pred = "'x m1_state_scheme set"

type_synonym
  'x m1_trans = "('x m1_state_scheme \<times> 'x m1_state_scheme) set"

text \<open>Instantiate parameters regarding list of freshness identifiers stored
at server.\<close>

overloading is_len' \<equiv> "is_len" rs_len' \<equiv> "rs_len" begin
definition is_len_def [simp]: "is_len' \<equiv> 1::nat"
definition rs_len_def [simp]: "rs_len' \<equiv> 1::nat"
end

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

definition         \<comment> \<open>by @{term "A"}, refines @{term "m1x_step1"}\<close>
  m1_step1 :: "[rid_t, agent, agent] \<Rightarrow> 'x m1_trans"
where
  "m1_step1 \<equiv> m1a_step1"

definition       \<comment> \<open>by @{term "B"}, refines @{term "m1x_step2"}\<close>
  m1_step2 :: "[rid_t, agent, agent] \<Rightarrow> 'x m1_trans"
where
  "m1_step2 \<equiv> m1a_step2"

definition       \<comment> \<open>by @{term "Server"}, refines @{term m1x_step3}\<close>
  m1_step3 :: "[rid_t, agent, agent, key, time] \<Rightarrow> 'x m1_trans"
where
  "m1_step3 Rs A B Kab Ts \<equiv> {(s, s').
     \<comment> \<open>new guards:\<close>
     Ts = clk s \<and>                      \<comment> \<open>fresh timestamp\<close>

     \<comment> \<open>rest as before:\<close>
     (s, s') \<in> m1a_step3 Rs A B Kab [aNum Ts]
  }"

definition         \<comment> \<open>by @{text "A"}, refines @{term m1x_step5}\<close>
  m1_step4 :: "[rid_t, agent, agent, key, time] \<Rightarrow> 'x m1_trans"
where
  "m1_step4 Ra A B Kab Ts \<equiv> {(s, s').
     \<comment> \<open>new guards:\<close>
     clk s < Ts + Ls \<and>                \<comment> \<open>ensure session key recentness\<close>

     \<comment> \<open>rest as before\<close>
     (s, s') \<in> m1a_step4 Ra A B Kab [aNum Ts]
  }"

definition         \<comment> \<open>by @{term "B"}, refines @{term m1x_step4}\<close>
  m1_step5 :: "[rid_t, agent, agent, key, time] \<Rightarrow> 'x m1_trans"
where
  "m1_step5 Rb A B Kab Ts \<equiv> {(s, s').
     \<comment> \<open>new guards:\<close>
     \<comment> \<open>ensure freshness of session key\<close>
     clk s < Ts + Ls \<and>

     \<comment> \<open>rest as before\<close>
     (s, s') \<in> m1a_step5 Rb A B Kab [aNum Ts]
  }"

definition     \<comment> \<open>refines @{term skip}\<close>
  m1_tick :: "time \<Rightarrow> 'x m1_trans"
where
  "m1_tick T \<equiv> {(s, s').
     s' = s\<lparr> clk := clk s + T \<rparr>
  }"

definition         \<comment> \<open>by attacker, refines @{term m1x_leak}\<close>
  m1_leak :: "[rid_t] \<Rightarrow> 'x m1_trans"
where
  "m1_leak \<equiv> m1a_leak"

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

definition
  m1_init :: "unit m1_pred"
where
  "m1_init \<equiv> { \<lparr> runs = Map.empty, leak = corrKey, clk = 0 \<rparr> }"

definition
  m1_trans :: "'x m1_trans" where
  "m1_trans \<equiv> (\<Union>A B Ra Rb Rs Kab Ts T.
        m1_step1 Ra A B \<union>
        m1_step2 Rb A B \<union>
        m1_step3 Rs A B Kab Ts \<union>
        m1_step4 Ra A B Kab Ts \<union>
        m1_step5 Rb A B Kab Ts \<union>
        m1_tick T \<union>
        m1_leak Rs \<union>
        Id
  )"

definition
  m1 :: "(m1_state, m1_obs) spec" where
  "m1 \<equiv> \<lparr>
      init = m1_init,
      trans = m1_trans,
      obs = id
  \<rparr>"

lemmas m1_loc_defs =
  m1_def m1_init_def m1_trans_def
  m1_step1_def m1_step2_def m1_step3_def m1_step4_def m1_step5_def
  m1_leak_def m1_tick_def

lemmas m1_defs = m1_loc_defs m1a_defs

lemma m1_obs_id [simp]: "obs m1 = id"
by (simp add: m1_def)

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

subsubsection \<open>inv0: Finite domain\<close>
(******************************************************************************)

text \<open>There are only finitely many runs. This is needed to establish
the responder/initiator agreement.\<close>

definition
  m1_inv0_fin :: "'x m1_pred"
where
  "m1_inv0_fin \<equiv> {s. finite (dom (runs s))}"

lemmas m1_inv0_finI = m1_inv0_fin_def [THEN setc_def_to_intro, rule_format]
lemmas m1_inv0_finE [elim] = m1_inv0_fin_def [THEN setc_def_to_elim, rule_format]
lemmas m1_inv0_finD = m1_inv0_fin_def [THEN setc_def_to_dest, rule_format]

text \<open>Invariance proofs.\<close>

lemma PO_m1_inv0_fin_init [iff]:
  "init m1 \<subseteq> m1_inv0_fin"
by (auto simp add: m1_defs intro!: m1_inv0_finI)

lemma PO_m1_inv0_fin_trans [iff]:
  "{m1_inv0_fin} trans m1 {> m1_inv0_fin}"
by (auto simp add: PO_hoare_defs m1_defs intro!: m1_inv0_finI)

lemma PO_m1_inv0_fin [iff]: "reach m1 \<subseteq> m1_inv0_fin"
by (rule inv_rule_incr, auto del: subsetI)

(******************************************************************************)
subsection \<open>Refinement of \<open>m1a\<close>\<close>
(******************************************************************************)

subsubsection \<open>Simulation relation\<close>
(******************************************************************************)

text \<open>R1a1: The simulation relation and mediator function are identities.\<close>

definition
  med1a1 :: "m1_obs \<Rightarrow> m1a_obs" where
  "med1a1 t \<equiv> \<lparr> runs = runs t, leak = leak t \<rparr>"

definition
  R1a1 :: "(m1a_state \<times> m1_state) set" where
  "R1a1 \<equiv> {(s, t). s = med1a1 t}"

lemmas R1a1_defs = R1a1_def med1a1_def

subsubsection \<open>Refinement proof\<close>
(******************************************************************************)

lemma PO_m1_step1_refines_m1a_step1:
  "{R1a1}
     (m1a_step1 Ra A B), (m1_step1 Ra A B)
   {> R1a1}"
by (auto simp add: PO_rhoare_defs R1a1_defs m1_defs)

lemma PO_m1_step2_refines_m1a_step2:
  "{R1a1}
     (m1a_step2 Rb A B), (m1_step2 Rb A B)
   {> R1a1}"
by (auto simp add: PO_rhoare_defs R1a1_defs m1_defs)

lemma PO_m1_step3_refines_m1a_step3:
  "{R1a1}
     (m1a_step3 Rs A B Kab [aNum Ts]), (m1_step3 Rs A B Kab Ts)
   {> R1a1}"
by (auto simp add: PO_rhoare_defs R1a1_defs m1_defs)

lemma PO_m1_step4_refines_m1a_step4:
  "{R1a1}
     (m1a_step4 Ra A B Kab [aNum Ts]), (m1_step4 Ra A B Kab Ts)
   {> R1a1}"
by (auto simp add: PO_rhoare_defs R1a1_defs m1_defs)

lemma PO_m1_step5_refines_m1a_step5:
  "{R1a1}
     (m1a_step5 Rb A B Kab [aNum Ts]), (m1_step5 Rb A B Kab Ts)
   {> R1a1}"
by (auto simp add: PO_rhoare_defs R1a1_defs m1_defs)

lemma PO_m1_tick_refines_m1a_skip:
  "{R1a1}
     Id, (m1_tick T)
   {> R1a1}"
by (auto simp add: PO_rhoare_defs R1a1_defs m1_defs)

text \<open>All together now...\<close>

lemmas PO_m1_trans_refines_m1a_trans =
  PO_m1_step1_refines_m1a_step1 PO_m1_step2_refines_m1a_step2
  PO_m1_step3_refines_m1a_step3 PO_m1_step4_refines_m1a_step4
  PO_m1_step5_refines_m1a_step5 PO_m1_leak_refines_m1a_leak
  PO_m1_tick_refines_m1a_skip

lemma PO_m1_refines_init_m1a [iff]:
  "init m1 \<subseteq>  R1a1``(init m1a)"
by (auto simp add: R1a1_defs m1_defs intro!: s0g_secrecyI)

lemma PO_m1_refines_trans_m1a [iff]:
  "{R1a1}
     (trans m1a), (trans m1)
   {> R1a1}"
apply (auto simp add: m1_def m1_trans_def m1a_def m1a_trans_def
         intro!: PO_m1_trans_refines_m1a_trans)
apply (force intro!: PO_m1_trans_refines_m1a_trans)+
done

text \<open>Observation consistency.\<close>

lemma obs_consistent_med1a1 [iff]:
  "obs_consistent R1a1 med1a1 m1a m1"
by (auto simp add: obs_consistent_def R1a1_def m1a_def m1_def)

text \<open>Refinement result.\<close>

lemma PO_m1_refines_m1a [iff]:
  "refines R1a1 med1a1 m1a m1"
by (rule Refinement_basic) (auto del: subsetI)

lemma  m1_implements_m1: "implements med1a1 m1a m1"
by (rule refinement_soundness) (fast)

end