theory Kruskal_Impl
  imports Kruskal_Refine
    "../../Refine_Imperative_HOL/IICF/Impl/IICF_DArray_List"
        UnionFind_Impl
begin

context
  fixes t ::  "nat \<Rightarrow> nat"
begin
  definition mop_sortEdges   where
    "mop_sortEdges l = (SPECT (emb (\<lambda>(L,n). n= Max (insert 0 (set (map fst L) \<union> set (map (snd o snd) L))) \<and> sorted_wrt edges_less_eq L \<and> distinct L \<and> set L = set l) (enat (t (length l)))))"

    sepref_register "mop_sortEdges"
end

locale sortMaxnode =
  fixes sortEdges_impl :: "(nat \<times> int \<times> nat) list \<Rightarrow> ((nat \<times> int \<times> nat) list * nat) Heap"
    and sort_time' :: "nat \<Rightarrow> nat"
  assumes
      sortEdges_impl[sepref_fr_rules]: "\<And>t. (sortEdges_impl, PR_CONST (mop_sortEdges t)) \<in>
        [\<lambda>l. sort_time' (length l) \<le> t (length l)]\<^sub>a
      (list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn))\<^sup>k \<rightarrow> (list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)\<times>\<^sub>a nat_assn)"

lemma set_uprod_nonempty[simp]: "set_uprod x \<noteq> {}"
  apply(cases x) by auto

locale Kruskal_intermediate_Impl0 = Kruskal_intermediate E forest connected path weight for E forest connected path
      and weight :: "nat uprod \<Rightarrow> int"  +
    fixes getEdges  :: "(nat \<times> int \<times> nat) list nrest"
      and getEdges_impl :: "(nat \<times> int \<times> nat) list Heap"
      and getEdges_time sort_time :: nat
(*      and sortEdges  :: "(nat \<times> int \<times> nat) list \<Rightarrow> ((nat \<times> int \<times> nat) list * nat) nrest"
      and sortEdges_impl :: "(nat \<times> int \<times> nat) list \<Rightarrow> ((nat \<times> int \<times> nat) list * nat) Heap" *)
      and empty_uf_time indep_test_time insert_uf_time :: nat
    assumes
        E_nonempty: "E\<noteq>{}"
      and
        getEdges_refine: "getEdges \<le> \<Down> Id (SPECT (emb (\<lambda>L. lst_graph_P' weight L E) (enat getEdges_time)))"
      and
        getEdges_impl[sepref_fr_rules]: "(uncurry0 getEdges_impl, uncurry0 getEdges) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
(*       and
        sortEdges_refine': "sortEdges l \<le> (SPECT (emb (\<lambda>(L,n). n= Max (set (map fst l) \<union> set (map (snd o snd) l)) \<and> sorted_wrt edges_less_eq L \<and> distinct L \<and> set L = set l) (enat sort_time)))"
     and
        sortEdges_impl[sepref_fr_rules]: "(sortEdges_impl, sortEdges) \<in>
                (list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn))\<^sup>k \<rightarrow>\<^sub>a (list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)\<times>\<^sub>a nat_assn)"

*)

begin

thm conc_fun_br

abbreviation "sortEdges \<equiv> mop_sortEdges (\<lambda>_. sort_time)"

(*
lemma sortEdges_refine:
  assumes a: "V = set (map fst l) \<union> set (map (snd o snd) l)"
    shows "sortEdges l = \<Down> (br fst (\<lambda>(l,n). n= Max V)) (SPECT (emb (\<lambda>L. sorted_wrt edges_less_eq L \<and> distinct L \<and> set L = set l) (enat sort_time)))"
proof -
  have gg: "(\<lambda>x. (case x of (l, n) \<Rightarrow> n = Max V) \<and> sorted_wrt edges_less_eq (fst x) \<and> distinct (fst x) \<and> set (fst x) = set l)
        =(\<lambda>(L, n). n = Max (set (map fst l) \<union> set (map (snd o snd) l)) \<and> sorted_wrt edges_less_eq L \<and> distinct L \<and> set L = set l)"
    unfolding a by auto
  show ?thesis
    apply(simp only: conc_fun_br gg) by(rule sortEdges_refine')
qed *)

abbreviation "insert_time \<equiv> 23"
abbreviation "empty_forest_time \<equiv> 12"

sublocale Kruskal_intermediate_time  E forest connected  path weight
        empty_forest_time empty_uf_time indep_test_time insert_time insert_uf_time getEdges_time sort_time
  apply unfold_locales .

term obtain_sorted_carrier''

definition (in -) obtain_sorted_carrier'''_aux  where
  "obtain_sorted_carrier'''_aux gE sE c =
      do {
    l \<leftarrow> gE;
    ASSERT (length l = card c);
    sE l
}"

abbreviation "obtain_sorted_carrier''' \<equiv> obtain_sorted_carrier'''_aux getEdges sortEdges E"

lemma distinct_mset_eq:"distinct a \<Longrightarrow> mset a = mset b \<Longrightarrow> distinct b"
  by (metis card_distinct distinct_card set_mset_mset size_mset)

lemma quicksort_by_rel_distinct: "distinct l \<Longrightarrow> distinct (quicksort_by_rel edges_less_eq [] l)"
  by (auto intro: distinct_mset_eq)

definition "add_size_rel   = br fst (\<lambda>(l,n). n= Max V)"

lemma max_node_is_Max_V: " E = (\<lambda>(a, _, y). Upair a y) ` set la \<Longrightarrow> max_node la = Max V"
proof -
  assume E: "E = (\<lambda>(a, _, y). Upair a y) ` set la"
  have pff: "fst ` set la \<union>  (\<lambda>x. snd (snd x)) ` set la = (\<Union>x\<in>set la. case x of (x1, x1a, x2a) \<Rightarrow> {x1, x2a})"
    by (auto simp add: rev_image_eqI)
  have "V \<noteq> {}" using E_nonempty V_def by auto
  then have Mo: "Max V = Max (insert 0 V)" by auto
  show ?thesis unfolding Mo unfolding V_def
  unfolding E apply simp
  by (auto simp add:  max_node_def prod.case_distrib pff )
qed

lemma lst_graph_P_V: "lst_graph_P la E \<Longrightarrow> V = (fst ` set la \<union> (\<lambda>x. snd (snd x)) ` set la)"
  by (auto simp: emb_eq_Some_conv lst_graph_P_def V_def rev_image_eqI)

lemma  k: "\<And>V::nat set. finite V \<Longrightarrow> V \<noteq> {} \<Longrightarrow> Max V = Max (insert 0 V)" by auto

lemma *: "(la::((nat*int*nat) list)) \<noteq> [] \<Longrightarrow> Max (insert 0 (fst ` set la \<union> (\<lambda>x. snd (snd x)) ` set la)) = Max (fst ` set la \<union> (\<lambda>x. snd (snd x)) ` set la)"
proof -
  assume "la \<noteq> []"
  then have "fst ` set la \<union> (snd \<circ> snd) ` set la \<noteq> {}" by auto
  then show ?thesis apply(intro k[symmetric])  apply simp by simp
qed

lemma obtain_sorted_carrier'''_refine: "obtain_sorted_carrier''' \<le> \<Down>add_size_rel obtain_sorted_carrier''"
  unfolding obtain_sorted_carrier'''_aux_def  add_size_rel_def
  apply(rule bindT_refine')
   apply(rule getEdges_refine) apply safe
  apply(auto simp: emb_eq_Some_conv  dest!:  split: if_splits)
  unfolding conc_fun_br  mop_sortEdges_def
  apply(auto  simp: le_fun_def emb'_def dest: lst_graph_P_V split: if_splits)
  apply(rule le_R_ASSERTI)
  apply(rule ASSERT_leI) apply simp
  apply(rule SPECT_refine) apply (auto split: if_splits)
  apply(subst * ) subgoal apply auto using E_nonempty by auto
  by (metis (mono_tags) fst_conv in_br_conv lst_graph_P_V prod_case_simp)

definition (in -) initState''_aux where
  "initState''_aux mn eft eut\<equiv> do {
    initial_union_find \<leftarrow> mop_per_init (\<lambda>_. eut) (mn + 1);
    ASSERT ( card (Domain initial_union_find) = mn + 1);
    e \<leftarrow> mop_empty_list (\<lambda>_. eft);
    RETURNT (initial_union_find, e)
    }"

abbreviation "initState'' mn == initState''_aux mn empty_forest_time empty_uf_time"

 definition (in -) "addEdge''_aux uf a w b T iut it = do {
  uf \<leftarrow> mop_per_union (\<lambda>_. iut) uf a b;
  T' \<leftarrow> mop_push_list (\<lambda>_.  it) (a,w,b) T;
  RETURNT (uf, T')
  }"

abbreviation "addEdge'' uf a w b T == addEdge''_aux uf a w b T insert_uf_time insert_time"

definition (in -) "notcompare uf a b itt = do {
      i \<leftarrow> mop_per_compare (\<lambda>_. itt) uf a b;
      RETURNT (\<not>i)
     }"

 definition (in -) kruskal3_aux
   where "kruskal3_aux E gE sE eft eut iut it   itt \<equiv> do {
    (sl,mn) \<leftarrow> obtain_sorted_carrier'''_aux gE sE E;
    ASSERT (mn = Max (Kruskal_intermediate_defs.V E));
    s \<leftarrow> initState''_aux mn eft eut ;
    (per, spanning_forest) \<leftarrow> nfoldli sl (\<lambda>_. True)
        (\<lambda>(a,w,b) (uf, T). do {
            ASSERT (a \<in> Domain uf \<and> b \<in> Domain uf);
            ASSERT ( card (Domain uf) = Max (Kruskal_intermediate_defs.V E) + 1);
            i \<leftarrow> notcompare uf a b itt;
            if i then
              do {
                ASSERT ((a,w,b)\<notin>set T);
                addEdge''_aux uf a w b T iut it
              }
            else
              RETURNT (uf,T)
        }) s;
        RETURNT spanning_forest
      }"

abbreviation "kruskal3 \<equiv> kruskal3_aux E getEdges sortEdges  empty_forest_time empty_uf_time
                      insert_uf_time  insert_time  indep_test_time"

  definition per_supset_rel :: "('a per \<times> 'a per) set" where
    "per_supset_rel
      \<equiv> {(p1,p2). p1 \<inter> Domain p2 \<times> Domain p2 = p2 \<and> p1 - (Domain p2 \<times> Domain p2) \<subseteq> Id}"

 definition "kk_rel n \<equiv> per_supset_rel \<inter> ({p. Domain p = {0..<n}} \<times> UNIV)"

lemma kk_relD: "x\<in> kk_rel n \<Longrightarrow> x\<in>per_supset_rel" unfolding kk_rel_def by auto

  lemma per_supset_rel_dom: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> Domain p1 \<supseteq> Domain p2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_compare:
    "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow> per_compare p1 x1 x2 \<longleftrightarrow> per_compare p2 x1 x2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_union: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow>
    (per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
    apply (clarsimp simp: per_supset_rel_def per_union_def Domain_unfold )
    apply (intro subsetI conjI)
    apply blast
    apply force
    done

  lemma per_kk_rel_union:
    assumes "(p1, p2) \<in> kk_rel n" and inDom: "x1\<in>Domain p2" "x2\<in>Domain p2"
    shows "(per_union p1 x1 x2, per_union p2 x1 x2) \<in> kk_rel n"
  proof -
    from assms(1) have "(p1, p2) \<in> per_supset_rel" by(auto dest: kk_relD)
    with inDom have ss: "(per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
      by(auto intro: per_supset_union)

    from assms(1) have "Domain p1 = {0..<n}" by (auto simp: kk_rel_def)
    then have "Domain (per_union p1 x1 x2) = {0..<n}" by simp
    with ss show ?thesis unfolding kk_rel_def by auto
  qed

lemma per_initN_refine: "(per_init' (Max V + 1), per_init V) \<in> per_supset_rel"
  unfolding per_supset_rel_def per_init'_def per_init_def max_node_def
  by (auto simp: less_Suc_eq_le  )

lemma per_init'_refine: "SPECT [per_init' (Max V  + 1) \<mapsto> enat empty_uf_time] \<le> \<Down> per_supset_rel (SPECT [per_init V \<mapsto> enat empty_uf_time])"
  apply(rule SPECT_refine)   using per_initN_refine by (auto split: if_splits)

lemma gg: "{(i, i) |i. i < X} = (\<lambda>i. (i,i)) ` {i. i < X}" by auto

lemma ff: "\<And>X. card (Domain {(i, i) |i. i < X}) = X"
  unfolding Domain_fst apply(subst card_image)
  subgoal by (smt fst_conv inj_onI mem_Collect_eq)
  subgoal unfolding gg apply(subst card_image) by auto
  done

lemma initState''_refine: "initState'' (Max V) \<le> \<Down>(kk_rel (Max V + 1) \<times>\<^sub>r Id) initState'"
  unfolding initState'_aux_def initState''_aux_def mop_empty_list_def  kk_rel_def
  unfolding mop_per_init_def
  apply(rule bindT_refine') apply(rule per_init'_refine)

  apply(refine_rcg  )
  subgoal by (auto split: if_splits simp: ff   per_init'_def )
  unfolding conc_fun_RES
    apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close>  )
  apply(rule Sup_upper)  by (auto simp: per_init'_def numeral_eq_enat split: if_splits)

lemma SPECT_bind_RETURNT: "SPECT [x \<mapsto> t] \<bind> (\<lambda>i. RETURNT (f i)) = SPECT [f x \<mapsto> t]"
  unfolding bindT_def by(auto split: nrest.split)

theorem kruskal3_refine: "kruskal3 \<le> \<Down> Id kruskal2"
  unfolding kruskal2_aux_def kruskal3_aux_def Let_def
  apply (refine_rcg obtain_sorted_carrier'''_refine   )
            (*supply RELATESI[where R="per_supset_rel::(nat per \<times> _) set", refine_dref_RELATES]*)
            supply RELATESI[where R="kk_rel (Max V + 1)::(nat per \<times> _) set", refine_dref_RELATES]
             apply refine_dref_type
  subgoal unfolding add_size_rel_def by (auto simp: in_br_conv)
  subgoal apply (simp add: add_size_rel_def in_br_conv  )
    using initState''_refine  by simp
          apply (auto simp add: add_size_rel_def in_br_conv per_supset_compare
                        per_supset_union
                      dest: per_supset_rel_dom
                      simp del: per_compare_def )
  subgoal by(auto dest!: kk_relD per_supset_rel_dom)
  subgoal by(auto dest!: kk_relD per_supset_rel_dom)
  subgoal by(auto simp: kk_rel_def)
  subgoal apply(auto dest!: kk_relD simp: SPECT_bind_RETURNT le_fun_def notcompare_def mop_per_compare_def)
    by (meson Domain.simps local.per_supset_compare per_compare_def)+
  subgoal unfolding addEdge'_aux_def addEdge''_aux_def mop_per_union_def mop_push_list_def
    apply(refine_rcg)
     apply refine_dref_type
    subgoal apply (rule SPECT_refine) by (auto  split: if_splits intro: per_kk_rel_union)
    subgoal apply (rule RETURNT_refine) by(auto split: if_splits)
    done
  done

end

locale Kruskal_intermediate_Impl = Kruskal_intermediate_Impl0
  + UnionFind_Impl + sortMaxnode   +
  assumes
  [simp]:  "uf_init_time (Suc (Max V)) \<le> empty_uf_time"
    "uf_cmp_time (Suc (Max V)) \<le> indep_test_time"
    "uf_union_time (Suc (Max V)) \<le> insert_uf_time"
    "sort_time' (card E) \<le> sort_time"
begin

section \<open>Kruskal\<close>

  lemma [fcomp_norm_simps]: "list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn) = id_assn"
    by (auto simp: list_assn_pure_conv)
  lemma [fcomp_norm_simps]: " (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn) = id_assn"
    by (auto simp: )

  lemma [sepref_import_param]: "(sort_edges,sort_edges)\<in>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel" by simp
  lemma [sepref_import_param]: "(max_node, max_node) \<in> \<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow> nat_rel" by simp

  sepref_register "getEdges" :: "(nat \<times> int \<times> nat) list nrest"
  sepref_register uf_init :: "nat \<Rightarrow> uf Heap"
  sepref_register uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap"
  sepref_register uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap"

declare getEdges_impl [sepref_fr_rules]

sepref_definition kruskal is
  "uncurry0 kruskal3" :: "(unit_assn)\<^sup>k \<rightarrow>\<^sub>a da_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
  unfolding kruskal3_aux_def obtain_sorted_carrier'''_aux_def initState''_aux_def
      addEdge''_aux_def notcompare_def nfoldli_def
  using [[goals_limit = 2]]

  apply sepref_dbg_preproc
  apply sepref_dbg_cons_init
  apply sepref_dbg_id
     apply sepref_dbg_monadify

         apply sepref_dbg_opt_init

  apply sepref_dbg_trans

  apply sepref_dbg_opt
  apply sepref_dbg_cons_solve \<comment> \<open>Frame rule, recovering the invalidated list
    or pure elements, propagating recovery over the list structure\<close>
  apply sepref_dbg_cons_solve \<comment> \<open>Trivial frame rule\<close>
  apply sepref_dbg_constraints
      done

  concrete_definition (in -) kruskal'
    uses Kruskal_intermediate_Impl.kruskal_def

thm kruskal3_refine kruskal2_refine   kruskal1_refine kruskal0_refine minWeightBasis3_refine

thm kruskal.refine kruskal3_refine kruskal2_refine   kruskal1_refine kruskal0_refine minWeightBasis3_refine

abbreviation "MST == minBasis"

term minWeightBasis3

(* TODO: *)

lemma k3: "(kruskal3,kruskal2) \<in> \<langle>Id\<rangle>nrest_rel"
  apply(rule nrest_relI) by (rule kruskal3_refine)
lemma k2: "(kruskal2,kruskal1) \<in> \<langle>lst_graph_rel\<rangle>nrest_rel"
  apply(rule nrest_relI) by (rule kruskal2_refine)
lemma k1: "(kruskal1,kruskal0) \<in> \<langle>Id\<rangle>nrest_rel"
  apply(rule nrest_relI) by (rule kruskal1_refine)
lemma k0: "(kruskal0,minWeightBasis3) \<in> \<langle>Id\<rangle>nrest_rel"
  apply(rule nrest_relI) by (rule kruskal0_refine)
lemma kmw: "(minWeightBasis3,SPECT (emb minBasis (enat minBasis_time))) \<in> \<langle>Id\<rangle>nrest_rel"
  apply(rule nrest_relI)
  by (rule minWeightBasis3_refine)

lemmas k_ref_spec = k3[FCOMP k2, FCOMP k1, FCOMP k0, FCOMP kmw]

  lemma [fcomp_norm_simps]: "list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn) = id_assn"
    by (auto simp: list_assn_pure_conv)
lemmas kruskal_ref_spec = kruskal.refine[FCOMP k_ref_spec]

thm minBasis_time_def
lemma kruskal_correct_forest:
  shows "<$ minBasis_time> kruskal <\<lambda>r. (\<exists>\<^sub>Ara. hr_comp (da_assn id_assn) lst_graph_rel ra r * \<up> (MST ra))>\<^sub>t"
proof -
  thm extract_cost_ub
  note l= hn_refine_ref[OF _  kruskal_ref_spec[to_hnr] ]
  thm extract_cost_ub[OF l, where Cost_ub="minBasis_time", simplified in_ran_emb_special_case]
  have ht: "<emp * $ minBasis_time> kruskal <\<lambda>r. emp * (\<exists>\<^sub>Ara. hr_comp (da_assn id_assn) lst_graph_rel ra r * \<up> (ra \<in> dom ((emb MST (enat minBasis_time)))))>\<^sub>t"
    apply(rule extract_cost_ub[OF l, where Cost_ub="minBasis_time" ])
    by (auto simp: in_ran_emb_special_case)

  from ht show ?thesis by auto
qed
thm minBasis_time_def
end
(*
thm extract_cost_ub[where M= "(emb Pr t)", no_vars]

lemma "hn_refine \<Gamma> c \<Gamma>' R (SPECT (emb Pr t))  \<Longrightarrow>
<\<Gamma> * $ t> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (Pr ra))>\<^sub>t"
proof -
  assume "hn_refine \<Gamma> c \<Gamma>' R (SPECT (emb Pr t))"
  from extract_cost_ub[OF this, of t]
  show ?thesis by (simp add: ran_emb')
qed

lemma array_length_rule_raw [hoare_triple]:
  "<dyn_array_raw (xs, n) p * $1>
   array_length p
   <\<lambda>r. dyn_array_raw (xs, n) p * \<up>(r = n)>"
  unfolding dyn_array'_def array_length_def
  apply(cases p)
  by (sep_auto simp: zero_time)

lemma array_max_rule_raw [hoare_triple]:
  "<dyn_array_raw (xs, n) p * $1>
   array_max p
   <\<lambda>r. dyn_array_raw (xs, n) p * \<up>(r = length xs)>"
  unfolding array_max_def
  apply (cases p)
  by (sep_auto heap: length_rule simp: zero_time)

lemma double_length_raw_rule2 [hoare_triple]:
  "length xs = n \<Longrightarrow>
   <dyn_array_raw (xs, length xs) p * $(length xs * 5 + 5)>
   double_length p
   <dyn_array_raw (double_length_fun (xs, n))>\<^sub>t"
  using double_length_raw_rule[of xs n p] by(simp add: mult.commute)

lemma push_array_raw_rule [hoare_triple]:
  "n \<le> length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p * $( length xs *5+9)>
   push_array x p
   <dyn_array_raw (push_array_fun x (xs, n))>\<^sub>t"
  unfolding
    push_array_def
  apply(sep_auto heap: array_max_rule_raw push_array_basic_raw_rule
          array_length_rule_raw  double_length_raw_rule2)
  subgoal apply(subst array_copy_length) by simp_all
  by sep_auto

lemma push_array_rule''' [hoare_triple]:
  "n \<le> length xs \<Longrightarrow>
   <dyn_array' (xs, n) p * $19>
   push_array x p
   <dyn_array' (push_array_fun x (xs, n))>\<^sub>t"
  unfolding
    push_array_def
  apply(sep_auto heap: array_max_rule' array_length_rule' push_array_basic_rule')
   apply(sep_auto heap: double_length_rule' )
  using push_array_basic_rule'
  unfolding double_length_fun.simps
  apply(sep_auto simp only: heap: push_array_basic_rule')
  subgoal apply(subst array_copy_length) by simp_all
  by sep_auto

thm array_max_rule'

*)
end


(*
   Copyright 2017 Myriam Begel

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
*)

theory "BasicBlocks"

imports "../lem/Evm"
"Apply_Trace_Cmd"

begin
(* Types definitions *)
datatype tblock =
Next | Jump | Jumpi | Terminal

type_synonym position = "int"
type_synonym pos_inst = "position * inst"
type_synonym vert = "pos_inst list * tblock"
type_synonym vertex = "int * vert"
type_synonym basic_blocks = "vertex list"

type_synonym stack_value = "w256 option"

(* Auxiliary functions *)

abbreviation block_lookup :: "basic_blocks \<Rightarrow> int \<Rightarrow> vert option" where
"block_lookup bb == map_of bb"

abbreviation v_ind :: "vertex \<Rightarrow> int" where
"v_ind v == fst v"

abbreviation v_ty :: "vertex \<Rightarrow> tblock" where
"v_ty v == snd (snd v)"

abbreviation v_insts :: "vertex \<Rightarrow> pos_inst list" where
"v_insts v == fst (snd v)"

definition byteListInt :: "8 word list \<Rightarrow> int" where
"byteListInt l = uint ((word_rcat l):: 32 word)"

definition next_i :: "basic_blocks \<Rightarrow> int \<Rightarrow> int" where
 "next_i v n = v_ind (hd (dropWhile (\<lambda>u. (v_ind u)\<le>n) v))"
(*  "next_i (i#j#l) n = (if fst i=n then fst j else next_i (j#l) n)"*)

definition find_block :: "int \<Rightarrow> vertex \<Rightarrow> bool" where
"find_block n bl ==  n=v_ind bl"

fun good_dest :: "int \<Rightarrow> basic_blocks \<Rightarrow> bool" where
  "good_dest m [] = False"
| "good_dest m ((n,[],_)#l) = good_dest m l"
| "good_dest m ((n,(_,i)#inst,_)#l) = (if m = n then (i = Pc JUMPDEST) else good_dest m l )"

definition blocks_indexes :: "basic_blocks \<Rightarrow> int list" where
"blocks_indexes xs = map v_ind xs"

fun extract_blocks :: "basic_blocks \<Rightarrow> int \<Rightarrow> vert option" where
"extract_blocks [] = Map.empty"
|"extract_blocks (x#xs) = (extract_blocks xs)(fst x:= Some (snd x))"

fun rebuild_basic_blocks :: "int list \<Rightarrow> (int \<Rightarrow> vert option) \<Rightarrow> basic_blocks" where
"rebuild_basic_blocks [] m = []"
|"rebuild_basic_blocks (x#xs) m = (x,the (m x)) # (rebuild_basic_blocks xs m)"

(* Stack manipulations *)

definition stack_swap :: "stack_value list \<Rightarrow> nat \<Rightarrow> stack_value list" where
"stack_swap st n = (let first = hd st in
  let unchanged = take (n -2) (tl st) in
  let to_swap = hd (drop (max (n-1) 1) st) in
  (to_swap # unchanged) @ (first # (drop n st))
)"

value "stack_swap [Value 1, Value 2, Value 3, Value 4] 2"

definition stack_dup :: "stack_value list \<Rightarrow> nat \<Rightarrow> stack_value list" where
"stack_dup st n = (st ! (n-1)) # st"

value "stack_dup [Value 1, Value 2, Value 3, Value 4] 2"

definition block_pt :: "pos_inst list \<Rightarrow> pos_inst \<Rightarrow> int" where
 "block_pt bl pt = (case bl of
   [] \<Rightarrow> fst pt
  | _ \<Rightarrow> fst (hd bl))"

(* Main functions *)

(* Add the address of each instruction *)

fun add_address' :: "inst list \<Rightarrow> int \<Rightarrow> pos_inst list" where
"add_address' [] n = []"
| "add_address' (x#xs) n = (n,x)#(add_address' xs (n + inst_size x))"

definition add_address :: "inst list \<Rightarrow> pos_inst list" where
"add_address xs = add_address' xs 0"

(* The execution of a basic block must be sequential. *)
(* We remove JUMP and JUMPI instructions and cut after them or a stopping instruction *)
(* and before a Jump destination. *)
fun aux_basic_block :: "pos_inst list \<Rightarrow> pos_inst list \<Rightarrow> basic_blocks" where
 "aux_basic_block [] [] = []"
|"aux_basic_block [] block = [(fst (hd block), block, Next)]"
|"aux_basic_block ((i)#tl1) block =
	(let bl_pt = block_pt block i in
  (case snd i of
    Pc JUMPDEST \<Rightarrow> (if block = [] then (aux_basic_block tl1 [i])
    else (bl_pt, block, Next) # (aux_basic_block tl1 [i]))
  | Pc JUMP \<Rightarrow>(bl_pt, block, Jump) # ( aux_basic_block tl1 [])
  | Pc JUMPI \<Rightarrow>(bl_pt, block, Jumpi) # ( aux_basic_block tl1 [])
  | Misc _ \<Rightarrow>(bl_pt, block @ [i], Terminal) # ( aux_basic_block tl1 [])
  | Unknown a \<Rightarrow> (bl_pt, block @ [i], Terminal) # ( aux_basic_block tl1 [])
  | _ \<Rightarrow> aux_basic_block tl1 (block@[i])))"
declare aux_basic_block.simps[simp del]

definition build_basic_blocks :: "inst list \<Rightarrow> basic_blocks" where
"build_basic_blocks prog == aux_basic_block (add_address prog) []"

definition build_blocks :: "inst list \<Rightarrow> basic_blocks" where
"build_blocks prog = build_basic_blocks prog"

(* Verification *)
lemmas reg_inst_splits = inst.splits misc_inst.splits pc_inst.splits

(* Define how BLOCKSs should be for the program logic to be sound *)

fun reg_inst :: "inst \<Rightarrow> bool" where
 "reg_inst (Pc JUMP) = False"
| "reg_inst (Pc JUMPI) = False"
|"reg_inst (Pc _) = True"
|"reg_inst (Misc _) = False"
|"reg_inst (Unknown a) = False"
|"reg_inst _ = True"

definition reg_block :: "pos_inst list \<Rightarrow> bool" where
"reg_block xs = list_all reg_inst (map snd xs)"

definition reg_vertex :: "vertex \<Rightarrow> bool" where
"reg_vertex v = (case v_ty v of
Terminal \<Rightarrow> reg_block (butlast (v_insts v))
| _ \<Rightarrow> reg_block (v_insts v))"

definition reg_basic_blocks :: "basic_blocks \<Rightarrow> bool" where
"reg_basic_blocks xs = list_all reg_vertex xs"

fun seq_block :: "pos_inst list \<Rightarrow> bool" where
"seq_block [] = True"
| "seq_block [x] = True"
| "seq_block (x#y#ys) = (fst y = fst x + inst_size (snd x) \<and> seq_block (y#ys))"
declare seq_block.simps[simp del]

definition last_no::"pos_inst list \<Rightarrow> bool" where
"last_no insts == (\<exists>a. snd (last insts) = Misc a) \<or> (\<exists>a. snd (last insts) = Unknown a)"

definition wf_blocks:: "basic_blocks \<Rightarrow> bool" where
"wf_blocks c ==
(\<forall>n insts ty.
(block_lookup c n = Some (insts, ty) \<longrightarrow>
	n \<in> set (blocks_indexes c) \<and> reg_vertex (n, insts, ty) \<and>
  (insts \<noteq> [] \<longrightarrow> (fst (hd insts) = n)) \<and> seq_block insts \<and>
  0 \<le> n \<and> n < 2 ^ 256) \<and>
(block_lookup c n = Some (insts, Next) \<longrightarrow>
	 insts \<noteq> []) \<and>
(block_lookup c n = Some (insts, Terminal) \<longrightarrow>
	 insts \<noteq> [] \<and> last_no insts)
)"

(* Proof that we build well formed BLOCKSs *)

lemma index_have_blocks:
"c = build_blocks bytecode \<Longrightarrow>
 \<not> block_lookup c n = None \<Longrightarrow>
 n \<in> set (blocks_indexes c)"
by(simp add: Let_def build_blocks_def blocks_indexes_def map_of_eq_None_iff)

lemma index_block_eq:
"(n, (j,i)#b, t)#xs = aux_basic_block insts block \<Longrightarrow>
j=n"
apply(induction insts arbitrary: block n j i t xs b)
 apply(case_tac block)
  apply(simp add: aux_basic_block.simps block_pt_def split:if_splits list.splits)
  apply(clarsimp)
 apply(simp add: aux_basic_block.simps block_pt_def split:if_splits list.splits)
 apply(clarsimp)
apply(simp add: aux_basic_block.simps Let_def)
apply(simp split: inst.splits add: inst_size_def inst_code.simps)
  apply(clarsimp simp add: block_pt_def split: list.splits)
 apply(clarsimp simp add: block_pt_def split: pc_inst.splits list.splits if_splits)
apply(clarsimp simp add: block_pt_def split: misc_inst.splits list.splits)
done

lemma seq_block_compose:
"seq_block bl \<Longrightarrow>
 \<forall>i j. bl \<noteq> [] \<longrightarrow> last bl = (j, i) \<longrightarrow> m = j + inst_size i \<Longrightarrow>
 seq_block (bl @ [(m, a)])"
apply(induction bl)
 apply(simp add: seq_block.simps)
apply(case_tac bl; simp)
 apply(simp add: seq_block.simps)
apply(simp add: seq_block.simps)
done

lemma in_aux_bb_intermediate:
"(n, b, t) \<in> set (aux_basic_block insts block) \<Longrightarrow>
\<exists>ys bl xs. (n, b, t)#xs = aux_basic_block ys bl"
apply(induction insts arbitrary: block)
 apply(rule_tac x="[]" in exI)
 apply(case_tac block)
 apply(simp add: aux_basic_block.simps split: if_splits)+
 apply(rule_tac x=block in exI, simp add: aux_basic_block.simps)
apply(subgoal_tac "(n, b, t) \<in> set
			(aux_basic_block (a # insts) block)")
 apply(drule subst[OF aux_basic_block.simps(3)])
 apply(simp add: Let_def)
  apply(clarsimp split: inst.splits simp add: inst_size_def inst_code.simps)
   apply(erule disjE, rule_tac x="(a,Unknown x1) # insts" in exI, rule_tac x=block in exI,
				simp add: aux_basic_block.simps Let_def, fastforce)
  apply(simp split: pc_inst.splits if_splits add: inst_size_def inst_code.simps;
				erule disjE, rule_tac x="(a,Pc x9) # insts" in exI, rule_tac x=block in exI,
				simp add: aux_basic_block.simps Let_def, fastforce)
 apply(erule disjE, rule_tac x="(a,Misc x13) # insts" in exI, rule_tac x=block in exI,
				simp add: aux_basic_block.simps Let_def, fastforce)
apply(assumption)
done

(* Lemmas to show that build blocks are regular *)
lemma list_all_in:
"x \<in> set xs \<Longrightarrow> list_all P xs \<Longrightarrow> P x"
 apply(induction xs)
  apply(simp)
 apply(case_tac "x=a"; simp)
done

lemma reg_block_butlast:
"reg_block xs \<Longrightarrow> reg_block (butlast xs)"
 apply(induction xs)
  apply(simp)
 apply(simp add: reg_block_def List.List.list.pred_map)
done

lemmas reg_simps =
reg_basic_blocks_def reg_vertex_def reg_block_def

lemma reg_aux_bb:
"reg_block block \<Longrightarrow>
 reg_basic_blocks (aux_basic_block insts block)"
 apply(induction insts arbitrary: block)
  apply(case_tac block)
   apply(simp add: reg_simps aux_basic_block.simps)
  apply(simp add: reg_basic_blocks_def reg_vertex_def aux_basic_block.simps)
 apply(simp add:Let_def aux_basic_block.simps)
 apply(case_tac block; clarsimp)
  apply(simp split: inst.split pc_inst.split misc_inst.split)
  apply(simp add:reg_simps)
 apply(simp split: inst.split pc_inst.split misc_inst.split)
 apply(simp add:reg_simps)
done

lemma reg_bb:
"reg_basic_blocks (build_basic_blocks insts)"
 apply(simp add: build_basic_blocks_def)
 apply(rule reg_aux_bb)
 apply(simp add: reg_simps)
done
value "sum_list (map inst_size [Pc JUMP, Pc PC])"

lemma seq_block_tl:
"seq_block (x#xs) \<Longrightarrow> seq_block xs"
apply(case_tac xs)
 apply(simp add: seq_block.simps)+
done

lemma seq_block_append:
"seq_block bl \<Longrightarrow>
bl \<noteq> [] \<longrightarrow> fst a = fst (last bl) + inst_size (snd (last bl))\<Longrightarrow>
seq_block (bl@[a])"
apply(induction bl; simp add: seq_block.simps)
apply(simp add: seq_block_tl)
apply(case_tac bl; simp add: seq_block.simps)
done

lemma seq_block_tl':
"seq_block (xs@ys) \<Longrightarrow> seq_block ys"
apply(induction xs; simp add: seq_block.simps)
apply(simp add: seq_block_tl)
done

lemma inst_size_pos:
"inst_size x > 0"
apply(simp add: inst_size_def)
apply(case_tac x; clarsimp simp add: inst_code.simps)
apply(case_tac x10; clarsimp simp add: stack_inst_code.simps)
apply(simp split: if_splits)
done

abbreviation bound where
"bound mini maxi n == mini \<le> (fst n) \<and> (fst n) < maxi"

lemma sequential_basic_blocks:
"seq_block ys \<Longrightarrow>
 seq_block bl \<Longrightarrow>
 list_all (bound 0 m) ys \<Longrightarrow>
 list_all (bound 0 m) bl \<Longrightarrow>
 ys \<noteq> [] \<and> bl \<noteq> [] \<longrightarrow> fst (hd ys) = fst (last bl) + inst_size (snd (last bl))\<Longrightarrow>
 (n, insts, ty) \<in> set (aux_basic_block ys bl) \<Longrightarrow>
 seq_block insts \<and> 0 \<le> n \<and> n < m"
apply(induction ys arbitrary: bl)
 apply(case_tac bl; simp add: aux_basic_block.simps)
apply(simp add: aux_basic_block.simps Let_def)
 apply(case_tac "reg_inst (snd a) \<and> (snd a) \<noteq> Pc JUMPDEST")
 apply(drule_tac x="bl@[a]" in meta_spec)
 apply(simp add: seq_block_tl seq_block_append)
 apply(drule meta_mp; clarsimp; case_tac ys; simp add: seq_block.simps;
       simp split: reg_inst_splits)
apply(case_tac "(snd a) = Pc JUMPDEST")
 apply(clarsimp)
 apply(drule_tac x="[(a, Pc JUMPDEST)]" in meta_spec)
 apply(simp add: seq_block_tl seq_block.simps)
 apply(drule meta_mp; case_tac ys; simp add: seq_block.simps)
  apply(case_tac "bl=[]"; simp split: if_splits)
  apply(erule disjE; clarsimp simp add: block_pt_def split: list.splits)
 apply(case_tac "bl=[]"; simp split: if_splits)
 apply(erule disjE; clarsimp simp add: block_pt_def split: list.splits)
apply(drule meta_spec[where x="[]"])
apply(simp add: seq_block_tl seq_block_append seq_block.simps)
apply(simp split: reg_inst_splits)
    apply(erule disjE; clarsimp simp add: block_pt_def seq_block_append split: list.splits)+
done

lemma seq_block_add_address:
"seq_block (add_address' insts k)"
apply(induction insts arbitrary:k)
 apply(simp add: seq_block.simps)
apply(simp)
apply(case_tac insts; simp add: seq_block.simps)
done

lemma bound_add_address':
"(x,y) \<in> set (add_address' xs k) \<Longrightarrow>
k \<le> x \<and> x \<le> fst (last (add_address' xs k))"
apply(induction xs arbitrary: k x y)
 apply(simp)
apply(simp)
apply(erule disjE; simp)
 apply(case_tac "add_address' xs (k + inst_size a)"; clarsimp)
 apply(drule_tac x="k + inst_size a" in meta_spec; drule_tac x="aa" and y="b" in meta_spec2)
 apply(simp split: list.splits if_splits)
  apply(case_tac xs; simp)
  apply(drule conjunct1; drule sym[where s="_ + _"]; simp add: inst_size_pos Orderings.order_class.order.strict_implies_order)
 apply(erule conjE)
 apply(subgoal_tac "k \<le> k + inst_size a"; simp)
 apply(simp add: inst_size_pos Orderings.order_class.order.strict_implies_order)
apply(drule_tac x="k + inst_size a" in meta_spec; drule_tac x="x" and y="y" in meta_spec2)
apply(simp)
apply(erule conjE)
apply(rule conjI; clarsimp)
apply(subgoal_tac "k \<le> k + inst_size a"; simp)
apply(simp add: inst_size_pos Orderings.order_class.order.strict_implies_order)
done

lemma non_empty_block_next:
"(n, [], Next) # xs = aux_basic_block ys bl \<Longrightarrow> False"
apply(induction ys arbitrary:bl)
 apply(case_tac bl; simp add: aux_basic_block.simps)
apply(simp add: aux_basic_block.simps Let_def)
apply(simp split: reg_inst_splits if_splits; fastforce)
done

lemma block_no:
"(n, insts, Terminal) \<in> set (aux_basic_block ys bl) \<Longrightarrow>
 reg_block bl \<Longrightarrow>
 insts \<noteq> [] \<and> last_no insts"
apply(induction ys arbitrary:bl)
 apply(case_tac bl; simp add: aux_basic_block.simps last_no_def)
apply(simp add: aux_basic_block.simps Let_def)
apply(case_tac "reg_inst (snd a) \<and> snd a \<noteq> Pc JUMPDEST")
 apply(drule_tac x="bl @ [a]" in meta_spec; simp add: reg_block_def)
 apply(simp split: reg_inst_splits if_splits)
apply(case_tac "snd a = Pc JUMPDEST")
 apply(simp; case_tac bl; simp split: if_splits)
  apply(drule_tac x="[a]" in meta_spec; simp add: reg_block_def)
 apply(drule_tac x="[a]" in meta_spec; simp add: reg_block_def)
apply(drule_tac x="[]" in meta_spec; simp add: reg_block_def)
apply(simp split: reg_inst_splits if_splits)
  apply(erule disjE; simp add: last_no_def)+
done

(* Main theorem *)

lemma wf_build_blocks:
"fst (last (add_address bytecode)) < 2^256 \<Longrightarrow>
wf_blocks (build_blocks bytecode)"
 apply(simp add: wf_blocks_def)
 apply(clarsimp)
 apply(rule conjI)
  apply(clarsimp; rule conjI)
   apply(case_tac "\<not> block_lookup (build_blocks bytecode) n = None")
    apply(simp add: index_have_blocks)
   apply(simp)
  apply(simp add: build_blocks_def Let_def)
  apply(drule map_of_SomeD)
  apply(rule conjI)
    apply(cut_tac reg_bb[where insts=bytecode])
     apply(simp add: reg_basic_blocks_def list_all_in)
  apply(rule conjI)
	 apply(simp add: build_basic_blocks_def)
	 apply(drule in_aux_bb_intermediate, clarify)
	 apply(case_tac insts; clarsimp simp add: index_block_eq)
	apply(simp add: build_basic_blocks_def)
  apply(rule_tac ty=ty in sequential_basic_blocks[where ys="add_address bytecode" and bl="[]"])
       apply(simp add: seq_block_add_address add_address_def)
      apply(simp add: seq_block.simps)
     apply(clarsimp simp add: list_all_def add_address_def)
     apply(cut_tac x=a and y=b in bound_add_address'[where xs=bytecode and k=0]; simp)
    apply(simp)+
 apply(thin_tac "_ < _")
 apply(rule conjI)
  apply(simp add: build_blocks_def Let_def build_basic_blocks_def)
  apply(rule impI)
  apply(drule map_of_SomeD)
  apply(drule in_aux_bb_intermediate, clarify)
  apply(drule non_empty_block_next; simp)
 apply(rule impI)
 apply(simp add: build_blocks_def Let_def build_basic_blocks_def)
 apply(drule map_of_SomeD)
 apply(drule block_no; simp add: reg_block_def)
done

(* Check that we can rebuild the initial list of instructions from basic blocks *)
fun inst_size_list::"pos_inst list \<Rightarrow> int" where
"inst_size_list [] = 0"
| "inst_size_list (x#xs) = inst_size (snd x) + inst_size_list xs"

lemma seq_block_sumC:
"seq_block ((i,j) # list @ (a, b) # xs) \<Longrightarrow>
 i + (inst_size j + inst_size_list list) = a"
apply(induction list arbitrary: i j; clarsimp)
 apply(simp add: seq_block.simps)
apply(simp add: seq_block.simps)
apply(fastforce)
done

fun rebuild_with_add :: "basic_blocks \<Rightarrow> pos_inst list" where
 "rebuild_with_add [] = []"
| "rebuild_with_add ((n,b,Jump)#q) = b@[(n+inst_size_list b,Pc JUMP)] @ (rebuild_with_add q)"
| "rebuild_with_add ((n,b,Jumpi)#q) = b@[(n+inst_size_list b,Pc JUMPI)] @ (rebuild_with_add q)"
| "rebuild_with_add ((n,b,_)#q) = b @ (rebuild_with_add q)"

lemma rev_rebuild_with_add_aux:
notes if_split[split del]
shows
"seq_block (b@c) \<Longrightarrow>
rebuild_with_add (aux_basic_block c b) =
    b@c"
apply(induction c arbitrary: b)
  apply(case_tac b; simp add: aux_basic_block.simps)
apply(simp add: aux_basic_block.simps Let_def)
apply(case_tac "reg_inst (snd a) \<and> snd a \<noteq> Pc JUMPDEST")
 apply(simp split: reg_inst_splits)
 apply(drule conjunct1; rule conjI, clarsimp)
 apply(rule conjI)
  apply(rule allI; clarify; rule conjI; clarsimp)
 apply(clarsimp)
apply(case_tac "snd a = Pc JUMPDEST"; clarsimp)
 apply(simp split: if_splits)
 apply(drule_tac x="[(a, Pc JUMPDEST)]" in meta_spec)
 apply(simp add: seq_block_tl')
apply(drule_tac x="[]" in meta_spec)
apply(drule meta_mp)
apply(simp add: seq_block_tl'[where xs="_ @ [(_,_)]"])
apply(case_tac b; simp)
 apply(rename_tac x; case_tac x; simp add: block_pt_def; case_tac ba; simp add: seq_block_sumC)+
done

lemma rev_rebuild_with_add:
"rebuild_with_add (build_blocks c) = add_address c"
apply(simp add: build_blocks_def Let_def)
apply(simp add: build_basic_blocks_def)
apply(subst rev_rebuild_with_add_aux)
 apply(simp add: seq_block_add_address add_address_def)
apply(simp)
done

fun reconstruct_bytecode :: "basic_blocks \<Rightarrow> inst list" where
 "reconstruct_bytecode [] = []"
| "reconstruct_bytecode ((n,b,Jump)#q) = (map snd b)@[Pc JUMP] @ (reconstruct_bytecode q)"
| "reconstruct_bytecode ((n,b,Jumpi)#q) = (map snd b)@[Pc JUMPI] @ (reconstruct_bytecode q)"
| "reconstruct_bytecode ((n,b,_)#q) = (map snd b) @ (reconstruct_bytecode q)"

lemma rev_basic_blocks: "reconstruct_bytecode (aux_basic_block i b) = (map snd b)@(map snd i)"
apply(induction i arbitrary: b)
apply(case_tac b)
apply(auto simp: Let_def aux_basic_block.simps split: reg_inst_splits)
done

lemma remove_address:
"map snd (add_address' i k) = i"
by(induction i arbitrary: k; simp)

lemma reverse_basic_blocks: "reconstruct_bytecode (build_basic_blocks i) = i"
apply(simp add: rev_basic_blocks build_basic_blocks_def add_address_def remove_address)
done

definition blocks_insts :: "basic_blocks \<Rightarrow> pos_inst set" where
"blocks_insts b = set (rebuild_with_add b)"

end


theory Proof_1_500
  imports Proofs1
begin

abbreviation s where " s s0 PdOut'value paid'value opened'value \<equiv>
(toEnv
   (setPstate
     (setVarBool (setVarBool (setVarBool s0 PdOut' PdOut'value) paid' paid'value) opened' opened'value)
     Init'init' Controller'isOpened'))"

theorem proof_1_500: "VC500 inv1 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC500_def inv1_def R1_def)
 apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply(unfold extraInv_def)
   apply(erule conjE)
   apply(erule conjE)
   apply((rule allI)+)
  subgoal premises vc_prems for s1 s2
    apply(insert vc_prems(2))
    apply(erule conjE)
    subgoal premises invs0
      apply(rule impI)
      apply((erule conjE)+)
      apply(erule le_imp_less_or_eq[THEN disjE])
      apply(rule cut_rl[of "    \<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4 s0 \<and>
         toEnvNum s2 s4 \<le> 10 - 1 \<and>
         \<not> getVarBool s4 Controller'minimalOpened' \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 Controller'minimalOpened')"])
      apply(erule exE)
    subgoal for s4
      apply(rule exI[of _ s4])
      by simp
     apply(insert invs0(1))[1]
     apply(erule conjE)
     apply(erule allE[of _ s1])
     apply(erule allE[of _ s2])
     apply(simp split: if_splits)
      apply(rule cut_rl[of "\<forall> s5. toEnvP s5 \<and> substate s2 s5 \<and> substate s5 (s s0 PdOut_value paid_value opened_value) \<longrightarrow>
pred1 s1 s2 (s s0 PdOut_value paid_value opened_value) s5"])
     apply(erule allE[of _ s2])
     apply(erule impE)
    using substate_refl apply blast
     apply(unfold pred1_def)
     apply(erule impE)
      apply(insert substate_refl substate_trans substate_antisym)[1]
     apply blast
     apply assumption
      apply(rule allI)
      subgoal premises prems for s5
        apply(induction rule: state_ind)
        using prems apply simp
         apply(rule impI)

         apply(rule impE[OF minimalOpened_not_passed_R1[of s1 s2 s0 s0]])
        using vc_prems(1) apply(simp split: if_splits)
        using invs0(2) substate_refl
          apply (smt (verit))
         apply(erule exE)
        subgoal for s3
          apply((erule conjE)+)
          apply(erule allE[of _ s3])
          apply(erule impE)
          using substate_antisym[of s3 s0] substate_refl  apply auto[1]
          by blast

        subgoal for s5
          apply(rule impI)
          apply(cases "getVarBool (predEnv s5) open' = False")
           apply(rule exI[of _ "predEnv s5"])
           apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
            apply blast
       apply(rule conjI)
          using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 PdOut_value paid_value opened_value) "]
       apply fastforce
     apply(rule conjI)
        apply blast
      using substate_antisym apply blast
      apply(drule impE)
        prefer 3
        apply assumption
       apply(((rule conjI),blast)+)
      using substate_imp_substatete_predEnv_or_eq apply blast
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
       apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        using predEnv_substate_imp_substate_or_eq by blast
      done
    done
  done
  done


theory Finite_Linear_Priority_Tick

imports
  Finite_Linear_Priority
  Finite_Linear_Tick_Param
  Finite_Linear_Induction
begin

lemma prirelacc_not_in_imp [simp]:
  assumes "prirelacc p A Z" "e \<notin>\<^sub>\<F>\<^sub>\<L> Z"
  shows "e \<notin>\<^sub>\<F>\<^sub>\<L> A"
  using assms by(induct p A Z rule:prirelacc.induct, auto)

lemma pri_tickWF:
  assumes "prirel p x Z" "tickWF tick Z"
  shows "tickWF tick x"
  using assms apply (induct p x Z arbitrary:tick rule:prirel.induct, auto)
  by (case_tac aa, auto, case_tac x1, auto)

lemma FLTick0_pri:
  assumes "FLTick0 tick P"
  shows "FLTick0 tick (Pri p P)"
  using assms unfolding FLTick0_def Pri_def apply auto
  by (simp add: pri_tickWF)

lemma prirel_extend_both_last_null_imp:
  assumes "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) (\<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>)" "length \<beta> = length \<Gamma>" "a \<in>\<^sub>\<F>\<^sub>\<L> A" "last \<beta> = \<bullet>" "last \<Gamma> = \<bullet>"
  shows "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (\<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  using assms by (induct \<beta> \<Gamma> rule:prirel.induct, auto)

lemma prirel_extend_both_last_null_imp2:
  assumes "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) (\<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>B\<rangle>\<^sub>\<F>\<^sub>\<L>)" "length \<beta> = length \<Gamma>" "a \<in>\<^sub>\<F>\<^sub>\<L> A" "last \<beta> = \<bullet>" "last \<Gamma> = \<bullet>" "\<forall>e. e \<in>\<^sub>\<F>\<^sub>\<L> A  \<longrightarrow> e \<in>\<^sub>\<F>\<^sub>\<L> B"
  shows "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (\<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>(B,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  using assms by (induct \<beta> \<Gamma> rule:prirel.induct, auto)

lemma prirel_eq_length_imp_last_member:
  assumes "length xs = length ys" "last xs = \<bullet>" "last ys \<noteq> \<bullet>" "prirel p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>) ys"
  shows  "\<forall>e. e \<in>\<^sub>\<F>\<^sub>\<L> x  \<longrightarrow> e \<in>\<^sub>\<F>\<^sub>\<L> last ys"
  using assms
proof(induct p xs ys rule:prirel.induct)
  case (1 p A Z)
  then show ?case apply auto
    apply (cases x, auto)
    apply (cases A, auto)
    by (cases Z, auto)
next
  case (2 p A Z zz)
then show ?case by auto
next
  case (3 p A aa Z)
  then show ?case by auto
next
  case (4 p A aa Z zz)
  then show ?case by auto
qed

lemma pri_FL2:
  assumes "FL2 P" "a \<in>\<^sub>\<F>\<^sub>\<L> A" "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) Z" "Z \<in> P"
  shows "\<exists>Z. prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) Z \<and> Z \<in> P"
  using assms
proof (cases "last \<beta> = \<bullet>")
  case True
  then obtain \<Gamma> where pGama:"prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) (\<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> = Z \<and> length \<beta> = length \<Gamma>"
    using assms
    by (metis Finite_Linear_Model.last.simps(1) acceptance.distinct(1) add_cancel_right_right amember.elims(2) concat_FL_last_not_bullet_absorb last_bullet_then_last_cons length.simps(1) length_cons prirel_cons_eq_length_imp_prirel_acceptances_last_bullet_eq prirel_cons_eq_length_imp_prirel_acceptances_last_not_bullet prirel_same_length)
  then show ?thesis
  proof (cases "last \<Gamma> = \<bullet>")
    case True
    then show ?thesis
      by (metis FL2_def pGama assms(1) assms(2) assms(4) concat_FL_last_not_bullet_absorb prirel_extend_both_last_null_imp)
  next
    case False
    then have "\<Gamma> = Z"
      using concat_FL_last_not_bullet_absorb pGama by fastforce
    then have "\<forall>e. e \<in>\<^sub>\<F>\<^sub>\<L> A \<longrightarrow> e \<in>\<^sub>\<F>\<^sub>\<L> last \<Gamma>"
      using True pGama False assms(3) prirel_eq_length_imp_last_member by blast
    then have "\<Gamma> = butlast \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>last \<Gamma>\<rangle>\<^sub>\<F>\<^sub>\<L>"
      by (simp add: butlast_last_cons2_FL)
    then have "butlast \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>(last \<Gamma>,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P"
      by (metis FL2_def \<open>\<Gamma> = Z\<close> \<open>\<forall>e. e \<in>\<^sub>\<F>\<^sub>\<L> A \<longrightarrow> e \<in>\<^sub>\<F>\<^sub>\<L> Finite_Linear_Model.last \<Gamma>\<close> assms(1) assms(2) assms(4))

    have "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) \<Gamma>"
      using pGama \<open>\<Gamma> = Z\<close> by auto
    then have "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) (butlast \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>last \<Gamma>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
      by (simp add: butlast_last_cons2_FL)
    have "length \<beta> = length (butlast \<Gamma>)"
      by (metis butlast_last_cons2_FL pGama rev_rev_butlast strong_less_eq_fltrace_cons_imp_lhs strong_less_eq_fltrace_eq_length strong_less_eq_fltrace_refl)

    then have "prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (butlast \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>(last \<Gamma>,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
      using True \<open>\<forall>e. e \<in>\<^sub>\<F>\<^sub>\<L> A \<longrightarrow> e \<in>\<^sub>\<F>\<^sub>\<L> Finite_Linear_Model.last \<Gamma>\<close> \<open>prirel p (\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>) (Finite_Linear_Model.butlast \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>Finite_Linear_Model.last \<Gamma>\<rangle>\<^sub>\<F>\<^sub>\<L>)\<close> assms(2) last_butlast_cons_bullet prirel_extend_both_last_null_imp2 by fastforce
    then show ?thesis
      using \<open>Finite_Linear_Model.butlast \<Gamma> &\<^sub>\<F>\<^sub>\<L> \<langle>(Finite_Linear_Model.last \<Gamma>,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P\<close> by blast
  qed
next
case False
  then show ?thesis
    using assms
    by (metis concat_FL_last_not_bullet_absorb)
qed

lemma FL2_pri:
  assumes "FL2 P"
  shows "FL2 (Pri p P)"
  using assms unfolding FL2_def Pri_def apply auto
  by (simp add: assms pri_FL2)

text \<open>Does Pri distribute through sequential composition in this model?\<close>

lemma prirel_consFL_both_imp:
  assumes "prirel p (x &\<^sub>\<F>\<^sub>\<L>y) (s &\<^sub>\<F>\<^sub>\<L> t)" "length x = length s" "last x = \<bullet>" "last s = \<bullet>"
  shows "prirel p x s"
  using assms by(induct x s rule:prirel.induct, auto)

lemma prirel_consFL_both_imp':
  assumes "prirel p x s" "prirel p y t"
  shows "prirel p (x &\<^sub>\<F>\<^sub>\<L>y) (s &\<^sub>\<F>\<^sub>\<L> t)"
  using assms apply(induct x s rule:prirel.induct, auto)
   apply (case_tac A, auto, case_tac Z, auto)
  apply (smt Collect_cong Finite_Linear_Model.last.simps(1) acceptance.distinct(1) concat_FL_last_not_bullet_absorb prirel.simps(1) prirelacc.simps(2))
  by (case_tac A, auto)

lemma prirel_consFL_exists:
  assumes "prirel p x (s &\<^sub>\<F>\<^sub>\<L> t)"
  shows "\<exists>y. prirel p y s"
  using assms apply(induct x s rule:prirel.induct, auto)
        apply (metis Finite_Linear_Model.last.simps(1) concat_FL_last_not_bullet_absorb prirelAlt_bullet_refl prirelAlt_imp_prirel)
       apply (metis Finite_Linear_Model.last.simps(1) concat_FL_last_not_bullet_absorb prirelAlt_bullet_refl prirelAlt_imp_prirel)
  using prirel.simps(4) apply fastforce
     apply (metis prirel.simps(4))
  using prirel.simps(4) apply fastforce
  using prirel.simps(4) apply fastforce
  by (metis prirel.simps(4) prirelacc.simps(1))

lemma prirel_consFL_last_bullet_exists:
  assumes "prirel p x (s &\<^sub>\<F>\<^sub>\<L> t)" "last s = \<bullet>"
  shows "\<exists>s0 t0. x = s0 &\<^sub>\<F>\<^sub>\<L> t0 \<and> prirel p s0 s \<and> prirel p t0 t"
  using assms apply(induct x s rule:prirel.induct, auto)
        apply (metis bullet_left_zero2 prirelAlt_bullet_refl prirelAlt_imp_prirel)
       apply (metis bullet_left_zero2 prirelAlt_bullet_refl prirelAlt_imp_prirel)
      apply (metis fltrace_concat2.simps(2) prirel.simps(4))
     apply (metis acceptance.rep_eq amember.simps(1) event.rep_eq fltrace_concat2.simps(2) prirel.simps(4))
    apply (metis acceptance.rep_eq event.rep_eq fltrace_concat2.simps(2) prirel.simps(4))
   apply (metis acceptance.rep_eq fltrace_concat2.simps(2) prirel.simps(4) prirelacc.simps(1))
  by (metis fltrace_concat2.simps(2) prirel.simps(4) prirelacc.simps(1))

lemma prirel_consFL_last_bullet_exists':
  assumes "prirel p (s &\<^sub>\<F>\<^sub>\<L> t) x" "last s = \<bullet>"
  shows "\<exists>s0 t0. x = s0 &\<^sub>\<F>\<^sub>\<L> t0 \<and> prirel p s s0 \<and> prirel p t t0"
  using assms apply(induct x s rule:prirel.induct, auto)
  apply (metis bullet_left_zero2 prirelAlt_bullet_refl prirelAlt_imp_prirel)
       apply (metis bullet_left_zero2 prirelAlt_bullet_refl prirelAlt_imp_prirel)
      apply (metis fltrace_concat2.simps(2) prirel.simps(4))
     apply (metis acceptance.rep_eq amember.simps(1) event.rep_eq fltrace_concat2.simps(2) prirel.simps(4))
    apply (metis acceptance.rep_eq event.rep_eq fltrace_concat2.simps(2) prirel.simps(4))
   apply (metis acceptance.rep_eq fltrace_concat2.simps(2) prirel.simps(4) prirelacc.simps(1))
  by (metis fltrace_concat2.simps(2) prirel.simps(4) prirelacc.simps(1))
(* non trivial *)

lemma prirel_not_events:
  assumes "prirel p x s" "tick \<notin> events s"
  shows "tick \<notin> events x"
  using assms by (induct p x s rule:prirel.induct, auto)

lemma prirel_not_events':
  assumes "prirel p x s" "tick \<notin> events x"
  shows "tick \<notin> events s"
  using assms by (induct p x s rule:prirel.induct, auto)

lemma prirel_consFL_both_imp_prirel:
  assumes "prirel p (s &\<^sub>\<F>\<^sub>\<L> t) (u &\<^sub>\<F>\<^sub>\<L> v)" "last s = \<bullet>" "last u = \<bullet>" "length s = length u"
  shows "prirel p t v"
  using assms by(induct p s u rule:prirel.induct, auto)

lemma prirel_consFL_last_bullet_both:
  assumes "prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,b)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>(a,c)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "last s = \<bullet>" "last ys = \<bullet>" "maximal(p,b)" "c \<in>\<^sub>\<F>\<^sub>\<L> a \<or> a = \<bullet>"
  shows "b = c"
  using assms apply(induct p s ys rule:prirel.induct, auto)
         apply (case_tac Z, auto)
          apply (metis (no_types, hide_lams) Finite_Linear_Model.butlast.simps(1) butlast_last_cons2_FL concat_FL_last_not_bullet_absorb fltrace.exhaust prirel.simps(1) prirel.simps(2) rev3.simps(1) rev3_little_more_extra)
         apply (metis fltrace.distinct(1) fltrace.exhaust prirel.simps(2) rev3.simps(1) rev3_little_more_extra)
  apply (metis Finite_Linear_Model.butlast.simps(1) bullet_left_zero2 butlast_last_cons2_FL fltrace.exhaust fltrace_concat2.simps(2) prirel.simps(2))
  by (metis Finite_Linear_Model.butlast.simps(1) bullet_right_zero2 butlast_last_cons2_FL fltrace.exhaust fltrace_concat2.simps(2) prirel.simps(3) s_and_tick_iff)+

lemma tickWF_consFL_tick_imp_bullet:
  assumes "tickWF tick (ys &\<^sub>\<F>\<^sub>\<L> \<langle>(y,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "last ys = \<bullet>" "tick \<in>\<^sub>\<F>\<^sub>\<L> y \<or> y = \<bullet>"
  shows "y = \<bullet>"
  using assms apply (induct ys rule:tickWF.induct, auto)
  by (metis fltrace.distinct(1) rev3.simps(1) rev3_little_more)

lemma prirel_exists_tick_max:
  assumes "prirel p S Z" "last s = \<bullet>" "maximal(p,tick)" "S = (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "tickWF tick Z"
  shows "\<exists>z. last z = \<bullet> \<and> Z = (z &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> length s = length z"
  using assms
proof (induct S Z rule:ftrace_cons_induct_both_eq_length)
  case 1
  then show ?case
    using assms(1) prirel_same_length by blast
next
  case (2 x y)
  then show ?case
    by (metis fltrace.distinct(1) rev3.simps(1) rev3_little_more)
next
  case (3 x y xs ys)
  then show ?case
    by (metis Finite_Linear_Model.last.simps(1) bullet_right_zero2 last_bullet_then_last_cons last_cons_bullet_iff prirel.simps(1) prirel_consFL_both_imp_prirel)
next
  case (4 x y xs ys)
  then have "prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
    by auto
  then obtain yA yEvent where yA:"y = (yA,yEvent)\<^sub>\<F>\<^sub>\<L> \<and> (yEvent \<in>\<^sub>\<F>\<^sub>\<L> yA \<or> yA = \<bullet>)"
    proof -
      assume a1: "\<And>yA yEvent. y = (yA,yEvent)\<^sub>\<F>\<^sub>\<L> \<and> (yEvent \<in>\<^sub>\<F>\<^sub>\<L> yA \<or> yA = \<bullet>) \<Longrightarrow> thesis"
      have "y \<le> (acceptance y,event y)\<^sub>\<F>\<^sub>\<L>"
        by (simp add: less_eq_aevent_def)
      then show ?thesis
        using a1 by (metis aevent_less_eq_iff_components event_in_acceptance)
    qed
  then have "prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>(yA,yEvent)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
    using "4.prems"(1) "4.prems"(4) by auto
  then have "yEvent = tick"
            "yA = \<bullet>"
    using prirel_consFL_last_bullet_both "4.hyps"(4) yA assms(2) assms(3) apply fastforce
    using 4 tickWF_consFL_tick_imp_bullet
    by (metis prirel_consFL_last_bullet_both yA)
  then have "ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> = ys &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<and> Finite_Linear_Model.length s = Finite_Linear_Model.length ys"
    by (metis "4.hyps"(2) "4.hyps"(3) "4.prems"(4) assms(2) fltrace.inject(2) rev3_little_more rev3_rev3_const2_last yA)
  then show ?case
    using "4.hyps"(4) by blast
qed

lemma pri_dist_SeqComp:
  assumes "FLTick0 tick P" "maximal(p,tick)"
  shows "Pri p (P (tick);\<^sub>\<F>\<^sub>\<L> Q) = ((Pri p P) (tick);\<^sub>\<F>\<^sub>\<L> (Pri p Q))"
  using assms unfolding Pri_def SeqComp_def
proof (auto)
  fix "x" "s" "t"
  assume  assm0:"FLTick0 tick P"
      and assm1:"prirel p x (s &\<^sub>\<F>\<^sub>\<L> t)"
      and assm2:"s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P"
      and assm3:"t \<in> Q"
  show "\<exists>s. (\<exists>Z. prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) Z \<and> Z \<in> P) \<and> (\<exists>t. (\<exists>Z. prirel p t Z \<and> Z \<in> Q) \<and> x = s &\<^sub>\<F>\<^sub>\<L> t) \<or>
           (\<exists>Z. prirel p s Z \<and> Z \<in> P) \<and> tick \<notin> events s \<and> x = s"
  proof (cases "last s = \<bullet>")
    case True
    then obtain s0 t0 where s0t0:"x = s0 &\<^sub>\<F>\<^sub>\<L> t0 \<and> prirel p s0 s \<and> prirel p t0 t"
      using assm1 prirel_consFL_last_bullet_exists by blast
    then have "prirel p \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
      using assms(2) by auto
    then have "prirel p (s0 &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
      using s0t0 prirel_consFL_both_imp' by blast
    then show ?thesis
      using assm2 assm3 s0t0 by blast
  next
    case False
    then show ?thesis
      by (smt FLTick0_def assm1 assm2 assms bullet_right_zero2 concat_FL_last_not_bullet_absorb last_rev3_is_bullet length.simps(1) length_cons pri_tickWF prirel.simps(1) prirel_cons_eq_length_imp_prirel_acceptances_eq prirel_same_length rev3_rev3_const2_last tickWF_last_x_is_emptyset)
  qed
next
  fix "x" "s"
  assume  assm0:"FLTick0 tick P"
    and   assm1:"maximal(p,tick)"
    and   assm2:"prirel p x s"
    and   assm3:"s \<in> P"
    and   assm4:"tick \<notin> events s"
  show "\<exists>s. (\<exists>Z. prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) Z \<and> Z \<in> P) \<and> (\<exists>t. (\<exists>Z. prirel p t Z \<and> Z \<in> Q) \<and> x = s &\<^sub>\<F>\<^sub>\<L> t) \<or>
            (\<exists>Z. prirel p s Z \<and> Z \<in> P) \<and> tick \<notin> events s \<and> x = s"
  proof -
    have "tick \<notin> events x"
      using assm2 assm4 prirel_not_events
      by fastforce
    then show ?thesis
      using assm2 assm3 by blast
  qed
next
  fix "s" "t" "Z" "Za"
  assume
      assm0: "FLTick0 tick P"
  and assm1: "maximal(p,tick)"
  and assm2: "prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) Z"
  and assm3: "Z \<in> P"
  and assm4: "prirel p t Za"
  and assm5: "Za \<in> Q"
  show "\<exists>Z. prirel p (s &\<^sub>\<F>\<^sub>\<L> t) Z \<and> (\<exists>s. s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> (\<exists>t. t \<in> Q \<and> Z = s &\<^sub>\<F>\<^sub>\<L> t) \<or> s \<in> P \<and> tick \<notin> events s \<and> Z = s)"
  proof (cases "last s = \<bullet>")
    case True
    then obtain s0 where s0:"prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (s0 &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> last s0 = \<bullet> \<and> length s = length s0 \<and> Z = (s0 &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
      by (metis FLTick0_def assm0 assm1 assm2 assm3 prirel_exists_tick_max)
    then have "prirel p s s0"
      using True prirel_consFL_both_imp by blast
    then have "prirel p (s &\<^sub>\<F>\<^sub>\<L> t) (s0 &\<^sub>\<F>\<^sub>\<L> Za)"
      by (simp add: assm4 prirel_consFL_both_imp')
    then have "\<exists>Z. prirel p (s &\<^sub>\<F>\<^sub>\<L> t) (s0 &\<^sub>\<F>\<^sub>\<L> Za) \<and> s0 &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> Za \<in> Q \<and> Z = s0 &\<^sub>\<F>\<^sub>\<L> Za"
      using s0 assm5 assm3 by blast
    then show ?thesis
      by blast
  next
    case False
    then show ?thesis
      by (metis FLTick0_def \<open>Z \<in> P\<close> \<open>prirel p (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) Z\<close> assms(1) concat_FL_last_not_bullet_absorb prirel_cons_eq_length_imp_prirel_acceptances_last_bullet_eq prirel_cons_eq_length_imp_prirel_acceptances_last_not_bullet prirel_same_length tickWF_last_x_is_emptyset)
  qed
next
  fix "s" "Z"
  assume
       assm0: "FLTick0 tick P"
  and  assm1: "maximal(p,tick)"
  and  assm2: "tick \<notin> events s"
  and  assm3: "prirel p s Z"
  and  assm4: "Z \<in> P"
  show "\<exists>Z. prirel p s Z \<and> (\<exists>s. s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> (\<exists>t. t \<in> Q \<and> Z = s &\<^sub>\<F>\<^sub>\<L> t) \<or> s \<in> P \<and> tick \<notin> events s \<and> Z = s)"
    using assm3 assm4 assm2 apply (rule_tac x="Z" in exI, auto)
    apply (rule_tac x="Z" in exI, auto)
    by (simp add: prirel_not_events')+
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory Sep_Tactic_Examples
imports
  "SepDSpec.Sep_Tactic_Helper"
  KHeap_DP
begin

(* Thesis : Automated Tactics for Seperation Logic *)

(* seperation logic *)

(* after we show that addition and disjointedness on our heap obeys certain laws, we get a seperation algebra *)

(* connectives *)

term "P \<and>* Q"

term "P \<longrightarrow>* Q"

lemma frame_rule:
  "\<And>R. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. Q\<rbrace> \<Longrightarrow> \<lbrace>P \<and>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace>"
  oops

thm swap_cap_wp[no_vars]

lemma
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  apply (simp add: move_cap_def)
  apply (wp swap_parents_wp set_cap_wp) (* set_cap doesn't apply *)
thm set_cap_wp[no_vars]
   apply (rule hoare_strengthen_post)
    apply (wp set_cap_wp)
   apply (clarsimp simp: sep_conj_ac )
oops

(* tactics we had pre-thesis *)

lemma "(A \<and>* B \<and>* C \<and>* D) s  \<Longrightarrow>  (A \<and>* B \<and>* C \<and>* D) s"
  apply (sep_select 4)
  apply (sep_select_asm 3)
  apply (sep_select 2)
  apply (sep_cancel)
  apply (sep_cancel)
  apply (sep_cancel)
done

(* forward reasoning *)

lemma example_drule:
  "(ptr \<mapsto>o obj) s
  \<Longrightarrow> (ptr \<mapsto>S obj \<and>* ptr \<mapsto>f obj) s"
  by (metis sep_conj_commute sep_map_o_decomp)

lemma sep_drule_example:
  "(ptr \<mapsto>o obj \<and>* A \<and>* B ) s
  \<Longrightarrow> (A \<and>* B \<and>* ptr \<mapsto>f obj \<and>* ptr \<mapsto>S obj) s"
  apply (sep_drule  example_drule)
  apply (sep_solve)
done

(* backwards reasoning *)

lemma example_rule:
  "(ptr \<mapsto>f obj \<and>* ptr \<mapsto>S obj) s
  \<Longrightarrow> (ptr \<mapsto>o obj) s"
  by (metis sep_map_o_decomp)

lemma sep_rule_example: "(ptr \<mapsto>f obj \<and>* A \<and>* B \<and>* ptr \<mapsto>S obj ) s \<Longrightarrow> (ptr \<mapsto>o obj \<and>* A \<and>* B) s"
  apply (sep_rule example_rule)
  apply (sep_solve)
done

(* the state of proving before new stuff *)

lemma swap_cap_wp_old:
  "\<lbrace><dest \<mapsto>c cap \<and>*  src \<mapsto>c cap' \<and>* R>\<rbrace>
    swap_cap cap' src cap dest
   \<lbrace>\<lambda>_.<dest \<mapsto>c cap' \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp add: swap_cap_def)
  apply (wp swap_parents_wp set_cap_wp)
  apply (rule hoare_chain)
    apply (rule set_cap_wp)
    apply (sep_solve)+
done

lemma move_cap_wp_old:
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  including no_pre
  apply (simp add: move_cap_def)
  apply (wp swap_parents_wp)
   apply (rule hoare_strengthen_post)
    apply (rule set_cap_wp)
   apply (sep_select 2)
   apply (sep_solve)
  apply (rule hoare_chain)
    apply (rule insert_cap_orphan_wp)
   apply (sep_solve)
  apply (sep_solve)
done

lemma invoke_cnode_rotate2_wp_old:
  "(dest) \<noteq> (rnd) \<Longrightarrow>
  \<lbrace><dest \<mapsto>c cap1 \<and>* src \<mapsto>c cap2 \<and>*
    rnd \<mapsto>c - \<and>* R>\<rbrace>
     invoke_cnode (RotateCall cap1 cap2 dest src rnd)
  \<lbrace>\<lambda>_. <dest \<mapsto>c NullCap \<and>* src \<mapsto>c cap1 \<and>*
    rnd \<mapsto>c cap2 \<and>* R>\<rbrace>"
  including no_pre
  apply (clarsimp simp: invoke_cnode_def)
  apply (wp)
   apply (rule hoare_strengthen_post)
    apply (rule move_cap_wp)
   apply (sep_solve )
  apply (rule hoare_chain)
    apply (rule move_cap_wp)
   apply (sep_select_asm 2, sep_select_asm 3)
   apply (sep_solve)
  apply (sep_solve)
done

(* new sep_select/asm *)

lemma "(A \<and>* B \<and>* C \<and>* D) s  \<Longrightarrow>  (A \<and>* B \<and>* C \<and>* D) s"
  apply (sep_select 4 3 2 1)
  apply (sep_select_asm 4 3 2 1)
  apply (sep_select_asm 2 4)
oops

(* sep_select_pre/post *)

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

(* can be made to work for arbitrary monads *)

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>, \<lbrace>E\<rbrace>"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>, -"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

lemma "(P \<and>* (P \<longrightarrow>* Q)) s \<Longrightarrow> Q s"
  apply (sep_mp, assumption )
  done

lemma "P s \<Longrightarrow> (Q \<longrightarrow>* (P \<and>* Q)) s"
  apply (erule sep_curry[rotated])
  apply (assumption)
  done

thm sep_mp[no_vars] sep_curry[rotated, no_vars]

(* wp tactic testing *)

(* sep_wand approach *)

method_setup debug = \<open>
  Attrib.thms >> (fn _ => fn ctxt =>
   let
     val wp_pre_tac = SELECT_GOAL (Method.NO_CONTEXT_TACTIC ctxt
                      (Method_Closure.apply_method ctxt @{method wp_pre} [] [] [] ctxt []))
   in
     SIMPLE_METHOD' (CHANGED o wp_pre_tac)
   end
)
\<close>

lemma move_cap_wp2:
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  apply (simp add: move_cap_def)
  apply (sep_wp set_cap_wp swap_parents_wp insert_cap_orphan_wp)+
  apply (sep_solve)
  done

lemma swap_cap_wp2:
  "\<lbrace><dest \<mapsto>c cap \<and>*  src \<mapsto>c cap' \<and>* R>\<rbrace>
    swap_cap cap' src cap dest
   \<lbrace>\<lambda>_.<dest \<mapsto>c cap' \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp: swap_cap_def)
  apply (sep_wp swap_parents_wp set_cap_wp)+
  apply (sep_solve)
  done

lemma invoke_cnode_rotate2_wp:
  "(dest) \<noteq> (rnd) \<Longrightarrow>
  \<lbrace><dest \<mapsto>c cap1 \<and>* src \<mapsto>c cap2 \<and>*
    rnd \<mapsto>c - \<and>* R>\<rbrace>
     invoke_cnode (RotateCall cap1 cap2 dest src rnd)
  \<lbrace>\<lambda>_. <dest \<mapsto>c NullCap \<and>* src \<mapsto>c cap1 \<and>*
    rnd \<mapsto>c cap2 \<and>* R>\<rbrace>"
  apply (clarsimp simp: invoke_cnode_def)
  apply (sep_wp move_cap_wp)+
  apply (sep_solve)
  done

(* sep_drule/rule *)

lemma sep_rule_example2:
 "\<lbrakk>(ptr \<mapsto>o obj) s; finite (dom (object_slots obj))\<rbrakk> \<Longrightarrow>
   (ptr \<mapsto>E obj \<and>* ptr \<mapsto>f obj \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj)) s"
  apply (subst (asm) sep_map_o_decomp)
  apply (subst (asm) sep_map_S_decomp, simp+)
  apply sep_solve
  done

lemma sep_drule_example2:
 "\<lbrakk>(ptr \<mapsto>f obj \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj) \<and>* ptr \<mapsto>E obj) s;
   finite (dom (object_slots obj))\<rbrakk>
    \<Longrightarrow>
  (ptr \<mapsto>o obj) s"
  by (metis sep_map_S_decomp sep_map_o_decomp)

(* sep_curry *)

lemma sep_drule_example_lemma:
  "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>f obj \<and>* A \<and>* B \<and>*
    (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj) \<and>* D \<and>* G \<and>* E \<and>* F \<and>* ptr \<mapsto>E obj ) s;
    finite (dom (object_slots obj))\<rbrakk>
  \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>* ptr \<mapsto>o obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B) s"
  apply (sep_drule sep_drule_example2)
   apply assumption
  apply sep_solve
  done

(* sep_back *)

lemma sep_rule_example_lemma:
 "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>o obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F ) s;
  finite (dom (object_slots obj))\<rbrakk> \<Longrightarrow>
  (D \<and>* G \<and>* E \<and>* F  \<and>* ptr \<mapsto>f obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>E obj \<and>*
   A \<and>* B \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj)) s"
  apply (sep_rule sep_rule_example2)
   apply sep_solve
  apply assumption
  done

(* works even with multiple conjuncts in assumptions and conclusions *)
lemma sep_rule_double_conjunct_example:
  "\<lbrakk>((obj_id, slot) \<mapsto>c cap \<and>* obj_id \<mapsto>f obj) s;
    object_slots obj slot = Some cap\<rbrakk>
  \<Longrightarrow> ((obj_id, slot) \<mapsto>s obj \<and>* obj_id \<mapsto>f obj) s"
  apply (sep_drule sep_map_s_sep_map_c)
   apply assumption
  apply (sep_cancel)+
  done

lemma sep_rule_double_conjunct_lemma:
  "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* obj_id \<mapsto>f obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F \<and>* (obj_id, slot) \<mapsto>c cap ) s;
    object_slots obj slot = Some cap\<rbrakk> \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>*(obj_id, slot) \<mapsto>s obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B \<and>*  obj_id \<mapsto>f obj) s"
  apply (sep_rule sep_rule_double_conjunct_example)
   apply sep_solve
  apply assumption
  done

(* side-conditions*)

lemma sep_drule_side_condition_lemma:
 "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* obj_id \<mapsto>f obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F \<and>* (obj_id, slot) \<mapsto>c cap ) s;
    object_slots obj slot = Some cap\<rbrakk> \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>*(obj_id, slot) \<mapsto>s obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B \<and>*  obj_id \<mapsto>f obj) s"
  apply (sep_drule sep_rule_double_conjunct_example, assumption)
  apply (sep_solve)
  done

schematic_goal "(P \<and>* ?A) s \<Longrightarrow> (A \<and>* B \<and>* P) s"
  apply (sep_solve)
  done

end


(* SPDX-License-Identifier: BSD-3-Clause *)
(*
 * Copyright (C) 2002 Tobias Nipkow (TUM)
 * Copyright (C) 2013--2014 Japheth Lim (NICTA)
 * Copyright (C) 2013--2014 David Greenaway (NICTA)
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 * * Redistributions of source code must retain the above copyright
 * notice, this list of conditions and the following disclaimer.
 *
 * * Redistributions in binary form must reproduce the above copyright
 * notice, this list of conditions and the following disclaimer in the
 * documentation and/or other materials provided with the distribution.
 *
 * * Neither the name of the University of Cambridge or the Technische
 * Universitaet Muenchen nor the names of their contributors may be used
 * to endorse or promote products derived from this software without
 * specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

theory CList imports
  "AutoCorres.AutoCorres"
begin

external_file "list.c"
install_C_file "list.c"
autocorres "list.c"

context list begin

thm reverse'_def
thm revappend'_def

section "The heap"

subsection "Paths in the heap"

definition node_next where "node_next s p = next_C (heap_node_C s p)"
definition node_exists where "node_exists s p = (p \<noteq> NULL \<and> is_valid_node_C s p)"

definition node_next_upd where
  "node_next_upd s p q = heap_node_C_update (\<lambda>old. old(p := next_C_update (\<lambda>_. q) (old p))) s"

lemma "p \<noteq> x \<Longrightarrow> heap_node_C (node_next_upd s x q) p = heap_node_C s p"
by (simp add: node_next_def node_next_upd_def fun_upd_apply)

primrec Path :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list \<Rightarrow> node_C ptr \<Rightarrow> bool" where
  "Path s x [] y \<longleftrightarrow> x = y"
| "Path s x (a#as) y \<longleftrightarrow> node_exists s x \<and> x = a \<and> Path s (node_next s x) as y"

lemma [simp]: "node_exists s a \<Longrightarrow> Path s a as z =
(as = [] \<and> a = z   \<or>   (\<exists>bs. as = a # bs \<and> Path s (node_next s a) bs z))"
by (case_tac as, fastforce, fastforce simp: node_exists_def)

lemma [simp]: "\<And>x. Path s x (as@bs) z =
(\<exists>y. Path s x as y \<and> Path s y bs z)"
by (induct as, simp+)

lemma Path_upd[simp]:
"\<And>x. u \<notin> set as \<Longrightarrow>
Path (node_next_upd s u v) x as y = Path s x as y"
apply (induct as, simp)
apply (simp add: node_exists_def node_next_def node_next_upd_def fun_upd_apply)
done

lemma Path_snoc:
"\<lbrakk> node_exists s a; Path (node_next_upd s a q) p as a \<rbrakk> \<Longrightarrow> Path (node_next_upd s a q) p (as @ [a]) q"
by simp

subsection "Non-repeating paths"

definition distPath ::
  "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list \<Rightarrow> node_C ptr \<Rightarrow> bool"
  where "distPath s x as y \<longleftrightarrow> Path s x as y \<and> distinct as"

text\<open>The term @{term "distPath s x as y"} expresses the fact that a
non-repeating path @{term as} connects location @{term x} to location
@{term y} over the heap @{term s}. In the case where @{text "x = y"},
and there is a cycle from @{term x} to itself, @{term as} can
be both @{term "[]"} and the non-repeating list of nodes in the
cycle.\<close>

lemma neq_dP: "p \<noteq> q \<Longrightarrow> Path s p Ps q \<Longrightarrow> distinct Ps \<Longrightarrow>
 \<exists> a Qs. p = a & Ps = a#Qs & a \<notin> set Qs"
by (case_tac Ps, auto)

lemma neq_dP_disp: "\<lbrakk> p \<noteq> q; distPath s p Ps q \<rbrakk> \<Longrightarrow>
 \<exists> a Qs. p = a \<and> Ps = a#Qs \<and> a \<notin> set Qs"
apply (simp only:distPath_def)
by (case_tac Ps, auto)

subsection "Lists on the heap"

subsubsection "Relational abstraction"

definition List :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list \<Rightarrow> bool"
  where "List s x as = Path s x as NULL"

lemma [simp]: "List s x [] = (x = NULL)"
by(simp add:List_def)

lemma List_case [simp]: "List s x (a#as) = (x = a \<and> node_exists s a \<and> List s (node_next s a) as)"
by(auto simp:List_def)

lemma [simp]: "List s NULL as = (as = [])"
by(case_tac as, simp_all add: node_exists_def)

lemma List_Ref[simp]: "node_exists s a \<Longrightarrow> List s a as = (\<exists>bs. as = a#bs \<and> List s (node_next s a) bs)"
by(case_tac as, simp_all add: node_exists_def, fast)

lemma List_unique: "\<And>x bs. List s x as \<Longrightarrow> List s x bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List s p as \<Longrightarrow> \<exists>!as. List s p as"
by(blast intro:List_unique)

lemma List_app: "\<And>x. List s x (as@bs) = (\<exists>y. Path s x as y \<and> List s y bs)"
by(induct as, simp, auto)

lemma List_hd_not_in_tl[simp]: "List s (node_next s a) as \<Longrightarrow> a \<notin> set as"
apply(clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List s x as \<Longrightarrow> distinct as"
apply(induct as, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma Path_is_List:
  "\<lbrakk>node_exists s a; Path s b Ps a; a \<notin> set Ps\<rbrakk> \<Longrightarrow> List (node_next_upd s a NULL) b (Ps @ [a])"
apply (induct Ps arbitrary: b)
apply (auto simp: node_exists_def node_next_upd_def node_next_def fun_upd_apply)
done

subsection "Functional abstraction"

definition islist :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> bool"
  where "islist s p \<longleftrightarrow> (\<exists>as. List s p as)"

definition list :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list"
  where "list s p = (SOME as. List s p as)"

lemma List_conv_islist_list: "List s p as = (islist s p \<and> as = list s p)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst some1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply(rule someI_ex)
apply fast
done

lemma [simp]: "islist s NULL"
by(simp add:islist_def)

lemma [simp]: "node_exists s a \<Longrightarrow> islist s a = islist s (node_next s a)"
by(simp add:islist_def)

lemma [simp]: "\<lbrakk> node_exists s a; islist s a \<rbrakk> \<Longrightarrow> islist s (node_next s a)"
apply (clarsimp simp: islist_def)
done

lemma [simp]: "list s NULL = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk> node_exists s a; islist s (node_next s a) \<rbrakk> \<Longrightarrow> list s a = a # list s (node_next s a)"
apply(insert List_Ref[of s])
apply(metis List_conv_islist_list)
done

lemma [simp]: "\<lbrakk> node_exists s a; islist s (node_next s a) \<rbrakk> \<Longrightarrow> a \<notin> set(list s (node_next s a))"
apply(insert List_hd_not_in_tl[of s])
apply(metis List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist s p \<Longrightarrow> y \<notin> set(list s p) \<Longrightarrow> list (node_next_upd s y q) p = list s p"
  apply (clarsimp simp: islist_def node_next_upd_def)
  by (metis (mono_tags) list.List_def list.List_unique list.Path_upd list.list_def list.node_next_upd_def some_eq_ex)

lemma islist_upd[simp]:
 "islist s p \<Longrightarrow> y \<notin> set(list s p) \<Longrightarrow> islist (node_next_upd s y q) p"
  apply (clarsimp simp: islist_def node_next_upd_def)
  by (metis (mono_tags) list.List_def list.List_unique list.Path_upd list.list_def list.node_next_upd_def some_eq_ex)

subsection "List reversal"

subsubsection "Program representation"
text \<open>This is AutoCorres's representation of revappend.\<close>
thm revappend'_def

text \<open>The heap operations are a bit too low level,
        so let's lift them using our heap accessors.\<close>
schematic_goal revappend'_abstract: "revappend' p q = ?new_definition"
  apply (subst revappend'_def)
  unfolding node_next_def[symmetric]
            node_next_upd_def[symmetric]
            modify_def
  apply (rule refl)
  done

text \<open>node_exists is a prerequisite for most of our abstraction rules.
        But we cannot extract this prerequisite from the program text because it is
        implied by our Hoare preconditions (below) which are not a part of the program
        text. Here we arrange for Isabelle's tactics to infer it when needed.\<close>

(* FIXME: figure out why we need to take this out of the simpset for
          the loop termination subgoals. *)
lemma node_exists_imp_valid[simp]: "node_exists s b \<Longrightarrow> is_valid_node_C s b"
  by (simp add: node_exists_def)

lemma List_node_exists [dest!]: "\<lbrakk> p \<noteq> NULL; List s p as \<rbrakk> \<Longrightarrow> node_exists s p"
by (case_tac as, auto simp: node_exists_def)

lemma islist_node_exists [simp]: "\<lbrakk> p \<noteq> NULL; islist s p \<rbrakk> \<Longrightarrow> node_exists s p"
  apply (clarsimp simp: islist_def)
  apply (rename_tac a, case_tac a, simp_all add: node_exists_def)
  done

subsubsection "Verification with relational abstraction"
text \<open>Almost automatic proof using the relational abstraction.
        (The termination proof uses functional abstraction.)\<close>

lemma
"\<lbrace> \<lambda>s. List s p Ps \<and> List s q Qs \<and> set Ps \<inter> set Qs = {} \<rbrace>
   revappend' p q
 \<lbrace> \<lambda>r s. List s r (rev Ps @ Qs) \<rbrace>!"
  txt \<open>We verify the abstracted version of the program.\<close>
  unfolding revappend'_abstract

  txt \<open>Add the loop invariant and measure.\<close>
  apply (subst whileLoop_add_inv
    [where I = "\<lambda>(dest', list') s.
                 \<exists>ps qs. List s list' ps \<and> List s dest' qs \<and> set ps \<inter> set qs = {} \<and>
                         rev ps @ qs = rev Ps @ Qs"
       and M = " (\<lambda>((_, list'), s). length (list s list'))"])
  apply (wp validNF_whileLoop_inv_measure_twosteps)

  txt \<open>Loop invariant.\<close>
    apply (fastforce intro: notin_List_update[THEN iffD2])

  txt \<open>Loop measure.\<close>
    apply wp
    apply (fastforce simp: List_conv_islist_list simp del: node_exists_imp_valid)

  txt \<open>Loop entrance and exit.\<close>
   apply fastforce+
  done

subsubsection "Verification with functional abstraction"
text \<open>Fully automatic proof using the functional abstraction.\<close>
lemma
"\<lbrace> \<lambda>s. islist s p \<and> islist s q \<and> Ps = list s p \<and> Qs = list s q \<and> set Ps \<inter> set Qs = {} \<rbrace>
   revappend' p q
 \<lbrace> \<lambda>r s. islist s r \<and> list s r = rev Ps @ Qs \<rbrace>!"
  unfolding revappend'_abstract

  apply (subst whileLoop_add_inv
    [where I = "\<lambda>(q, p) s. islist s p \<and> islist s q \<and>
                           set(list s p) \<inter> set(list s q) = {} \<and>
                           rev(list s p) @ (list s q) = rev Ps @ Qs"
       and M = "(\<lambda>((q, p), s). length (list s p))"])
  apply (wp validNF_whileLoop_inv_measure_twosteps)

  txt \<open>Loop invariant.\<close>
     apply clarsimp

  txt \<open>Loop measure.\<close>
    apply wp
    apply (clarsimp simp del: node_exists_imp_valid)

  txt \<open>Loop entrance and exit.\<close>
   apply clarsimp+
  done

text \<open>Provide the node_exists condition manually.\<close>
lemma
"\<lbrace> \<lambda>s. islist s p \<and> islist s q \<and> Ps = list s p \<and> Qs = list s q \<and> set Ps \<inter> set Qs = {} \<rbrace>
   revappend' p q
 \<lbrace> \<lambda>r s. islist s r \<and> list s r = rev Ps @ Qs \<rbrace>!"
  unfolding revappend'_abstract

  apply (subst whileLoop_add_inv
    [where I = "\<lambda>(q, p) s. islist s p \<and> islist s q \<and>
                           set(list s p) \<inter> set(list s q) = {} \<and>
                           rev(list s p) @ (list s q) = rev Ps @ Qs"
       and M = "(\<lambda>((q, p), s). length (list s p))"])
  apply (wp validNF_whileLoop_inv_measure_twosteps)
     apply (clarsimp simp del: islist_node_exists)
     apply (frule islist_node_exists, assumption)
     apply (clarsimp simp del: islist_node_exists)

    apply wp
    apply (clarsimp simp del: node_exists_imp_valid)

   apply clarsimp+
  done

end (* context list *)

end