(*  Title:      HOL/IMPP/Misc.thy
    Author:     David von Oheimb, TUM
*)

section \<open>Several examples for Hoare logic\<close>

theory Misc
imports Hoare
begin

overloading
  newlocs \<equiv> newlocs
  setlocs \<equiv> setlocs
  getlocs \<equiv> getlocs
  update \<equiv> update
begin

definition newlocs :: locals
  where "newlocs == %x. undefined"

definition setlocs :: "state => locals => state"
  where "setlocs s l' == case s of st g l => st g l'"

definition getlocs :: "state => locals"
  where "getlocs s == case s of st g l => l"

definition update  :: "state => vname => val => state"
  where "update s vn v ==
    case vn of
      Glb gn => (case s of st g l => st (g(gn:=v)) l)
    | Loc ln => (case s of st g l => st g (l(ln:=v)))"

end

subsection "state access"

lemma getlocs_def2: "getlocs (st g l) = l"
apply (unfold getlocs_def)
apply simp
done

lemma update_Loc_idem2 [simp]: "s[Loc Y::=s<Y>] = s"
apply (unfold update_def)
apply (induct_tac s)
apply (simp add: getlocs_def2)
done

lemma update_overwrt [simp]: "s[X::=x][X::=y] = s[X::=y]"
apply (unfold update_def)
apply (induct_tac X)
apply  auto
apply  (induct_tac [!] s)
apply  auto
done

lemma getlocs_Loc_update [simp]: "(s[Loc Y::=k])<Y'> = (if Y=Y' then k else s<Y'>)"
apply (unfold update_def)
apply (induct_tac s)
apply (simp add: getlocs_def2)
done

lemma getlocs_Glb_update [simp]: "getlocs (s[Glb Y::=k]) = getlocs s"
apply (unfold update_def)
apply (induct_tac s)
apply (simp add: getlocs_def2)
done

lemma getlocs_setlocs [simp]: "getlocs (setlocs s l) = l"
apply (unfold setlocs_def)
apply (induct_tac s)
apply auto
apply (simp add: getlocs_def2)
done

lemma getlocs_setlocs_lemma: "getlocs (setlocs s (getlocs s')[Y::=k]) = getlocs (s'[Y::=k])"
apply (induct_tac Y)
apply (rule_tac [2] ext)
apply auto
done

(*unused*)
lemma classic_Local_valid:
"\<forall>v. G|={%Z s. P Z (s[Loc Y::=v]) & s<Y> = a (s[Loc Y::=v])}.
  c .{%Z s. Q Z (s[Loc Y::=v])} ==> G|={P}. LOCAL Y:=a IN c .{Q}"
apply (unfold hoare_valids_def)
apply (simp (no_asm_use) add: triple_valid_def2)
apply clarsimp
apply (drule_tac x = "s<Y>" in spec)
apply (tactic "smp_tac \<^context> 1 1")
apply (drule spec)
apply (drule_tac x = "s[Loc Y::=a s]" in spec)
apply (simp (no_asm_use))
apply (erule (1) notE impE)
apply (tactic "smp_tac \<^context> 1 1")
apply simp
done

lemma classic_Local: "\<forall>v. G|-{%Z s. P Z (s[Loc Y::=v]) & s<Y> = a (s[Loc Y::=v])}.
  c .{%Z s. Q Z (s[Loc Y::=v])} ==> G|-{P}. LOCAL Y:=a IN c .{Q}"
apply (rule export_s)
apply (rule hoare_derivs.Local [THEN conseq1])
apply (erule spec)
apply force
done

lemma classic_Local_indep: "[| Y~=Y'; G|-{P}. c .{%Z s. s<Y'> = d} |] ==>
  G|-{%Z s. P Z (s[Loc Y::=a s])}. LOCAL Y:=a IN c .{%Z s. s<Y'> = d}"
apply (rule classic_Local)
apply clarsimp
apply (erule conseq12)
apply clarsimp
apply (drule sym)
apply simp
done

lemma Local_indep: "[| Y~=Y'; G|-{P}. c .{%Z s. s<Y'> = d} |] ==>
  G|-{%Z s. P Z (s[Loc Y::=a s])}. LOCAL Y:=a IN c .{%Z s. s<Y'> = d}"
apply (rule export_s)
apply (rule hoare_derivs.Local)
apply clarsimp
done

lemma weak_Local_indep: "[| Y'~=Y; G|-{P}. c .{%Z s. s<Y'> = d} |] ==>
  G|-{%Z s. P Z (s[Loc Y::=a s])}. LOCAL Y:=a IN c .{%Z s. s<Y'> = d}"
apply (rule weak_Local)
apply auto
done

lemma export_Local_invariant: "G|-{%Z s. Z = s<Y>}. LOCAL Y:=a IN c .{%Z s. Z = s<Y>}"
apply (rule export_s)
apply (rule_tac P' = "%Z s. s'=s & True" and Q' = "%Z s. s'<Y> = s<Y>" in conseq12)
prefer 2
apply  clarsimp
apply (rule hoare_derivs.Local)
apply clarsimp
apply (rule trueI)
done

lemma classic_Local_invariant: "G|-{%Z s. Z = s<Y>}. LOCAL Y:=a IN c .{%Z s. Z = s<Y>}"
apply (rule classic_Local)
apply clarsimp
apply (rule trueI [THEN conseq12])
apply clarsimp
done

lemma Call_invariant: "G|-{P}. BODY pn .{%Z s. Q Z (setlocs s (getlocs s')[X::=s<Res>])} ==>
  G|-{%Z s. s'=s & I Z (getlocs (s[X::=k Z])) & P Z (setlocs s newlocs[Loc Arg::=a s])}.
  X:=CALL pn (a) .{%Z s. I Z (getlocs (s[X::=k Z])) & Q Z s}"
apply (rule_tac s'1 = "s'" and
  Q' = "%Z s. I Z (getlocs (s[X::=k Z])) = I Z (getlocs (s'[X::=k Z])) & Q Z s" in
  hoare_derivs.Call [THEN conseq12])
apply  (simp (no_asm_simp) add: getlocs_setlocs_lemma)
apply force
done

end


theory Kruskal_Impl
  imports Kruskal_Refine "SeprefTime.IICF_DArray_List"
        Union_Find_Disjoint_Sets
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


(* Title: RTS/JVM_RTS/JVMSemantics.thy *)
(* Author: Susannah Mansky, UIUC 2020 *)

section "Instantiating @{term Semantics} with Jinja JVM"

theory JVMSemantics
imports "../Common/Semantics" JinjaDCI.JVMExec
begin

fun JVMsmall :: "jvm_prog \<Rightarrow> jvm_state \<Rightarrow> jvm_state set" where
"JVMsmall P \<sigma> = { \<sigma>'. exec (P, \<sigma>) = Some \<sigma>' }"

lemma JVMsmall_prealloc_pres:
assumes pre: "preallocated (fst(snd \<sigma>))"
  and "\<sigma>' \<in> JVMsmall P \<sigma>"
shows "preallocated (fst(snd \<sigma>'))"
using exec_prealloc_pres[OF pre] assms by(cases \<sigma>, cases \<sigma>', auto)

lemma JVMsmall_det: "JVMsmall P \<sigma> = {} \<or> (\<exists>\<sigma>'. JVMsmall P \<sigma> = {\<sigma>'})"
by auto

definition JVMendset :: "jvm_state set" where
"JVMendset \<equiv> { (xp,h,frs,sh). frs = [] \<or> (\<exists>x. xp = Some x) }"

lemma JVMendset_final: "\<sigma> \<in> JVMendset \<Longrightarrow> \<forall>P. JVMsmall P \<sigma> = {}"
 by(auto simp: JVMendset_def)

lemma start_state_nend:
 "start_state P \<notin> JVMendset"
 by(simp add: start_state_def JVMendset_def)

interpretation JVMSemantics: Semantics JVMsmall JVMendset
 by unfold_locales (auto dest: JVMendset_final)

end


theory flash83Rev imports flashPub
begin
section{*Main defintions*}
lemma NI_FAckVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (NI_FAck ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_InvVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Inv  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_InvAck_1VsInv83:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_InvAck_1  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_InvAck_1_HomeVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_InvAck_1_Home  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_InvAck_2VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_InvAck_2 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_GetXVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_GetX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_Nak1VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_Nak1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_Nak2VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_Nak2  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_Nak3VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_Nak3  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_PutX1VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX1 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX2VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX2 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX3VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX3 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX4VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX4 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX5VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX5 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX6VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX6 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX7VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX7 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX8VsInv83:
  (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX8 N  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1  a2  a3 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX8_homeVsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX8_home N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX9VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX9 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX10VsInv83:
  (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX10 N  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1  a2  a3 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX10_homeVsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX10_home N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX11VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_GetX_PutX11 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_Get_GetVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Get  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Nak1VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Nak1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Nak2VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Nak2  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Nak3VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Nak3  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Put1VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Put1 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Put2VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Put2  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Put3VsInv83:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Local_Get_Put3  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_PutVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (NI_Local_Put ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have allCases:"formEval  ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true ))  s  \<or>formEval   (neg ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true )) )  s  "
	                      by auto

    moreover
                       {assume b1:"formEval ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true ))  s"

      have "?P1 s"

        apply(cut_tac  b1 , auto)

        done

        then  have "?P1 s\<or> ?P2 s \<or> ?P3 s"

       by blast
    }

    moreover
                       {assume b1:"formEval  (neg ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true )) )  s"

      have "?P1 s"

        apply(cut_tac  b1 , auto)

        done

        then  have "?P1 s\<or> ?P2 s \<or> ?P3 s"

       by blast
    }
   ultimately show "?P1 s\<or> ?P2 s\<or> ?P3 s"

	                         by metis

 qed
lemma NI_Local_PutXAcksDoneVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (NI_Local_PutXAcksDone ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P3 s"

        apply(    simp)

        apply(rule_tac x=" (neg ( andForm ( eqn ( IVar ( Global ''Dir_Dirty'') )  ( Const false ))    ( eqn ( IVar ( Para ''UniMsg_Cmd'' Home) )  ( Const UNI_PutX ))  ) ) " in exI,auto)

        done

       then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

        by blast

 qed
lemma NI_NakVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Nak  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Nak_ClearVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (NI_Nak_Clear ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_Nak_HomeVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (NI_Nak_Home ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_Remote_GetX_NakVsInv83:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_GetX_Nak  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_GetX_Nak_HomeVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_GetX_Nak_Home  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_GetX_PutXVsInv83:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_GetX_PutX  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_GetX_PutX_HomeVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_GetX_PutX_Home  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Nak1VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_Get_Nak1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Nak2VsInv83:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_Get_Nak2  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Put1VsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_Get_Put1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Put2VsInv83:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_Get_Put2  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_PutVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_Put  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_PutXVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Remote_PutX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_ReplaceVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_Replace  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_ReplaceHomeVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (NI_ReplaceHome ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_ReplaceHomeShrVldVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (NI_ReplaceHomeShrVld ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_ReplaceShrVldVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (NI_ReplaceShrVld  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_ShWbVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (NI_ShWb N ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P3 s"

        apply(    simp)

        apply(rule_tac x=" (neg ( andForm ( eqn ( IVar ( Para ''CacheState'' Home) )  ( Const CACHE_E ))    ( eqn ( IVar ( Global ''ShWbMsg_Cmd'') )  ( Const SHWB_ShWb ))  ) ) " in exI,auto)

        done

       then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

        by blast

 qed
lemma NI_WbVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (NI_Wb ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P3 s"

        apply(    simp)

        apply(rule_tac x=" (neg ( andForm ( eqn ( IVar ( Global ''WbMsg_Cmd'') )  ( Const WB_Wb ))    ( eqn ( IVar ( Para ''CacheState'' Home) )  ( Const CACHE_E ))  ) ) " in exI,auto)

        done

       then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

        by blast

 qed
lemma PI_Local_GetX_GetX1VsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (PI_Local_GetX_GetX1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_GetX2VsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (PI_Local_GetX_GetX2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_PutX1VsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_GetX_PutX1 N ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma PI_Local_GetX_PutX2VsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_GetX_PutX2 N ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma PI_Local_GetX_PutX3VsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_GetX_PutX3 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma PI_Local_GetX_PutX4VsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_GetX_PutX4 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma PI_Local_Get_GetVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (PI_Local_Get_Get ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_Get_PutVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_Get_Put ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have allCases:"formEval  ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true ))  s  \<or>formEval   (neg ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true )) )  s  "
	                      by auto

    moreover
                       {assume b1:"formEval ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true ))  s"

      have "?P1 s"

        apply(cut_tac  b1 , auto)

        done

        then  have "?P1 s\<or> ?P2 s \<or> ?P3 s"

       by blast
    }

    moreover
                       {assume b1:"formEval  (neg ( eqn ( IVar ( Para ''InvMarked'' Home) )  ( Const true )) )  s"

      have "?P1 s"

        apply(cut_tac  b1 , auto)

        done

        then  have "?P1 s\<or> ?P2 s \<or> ?P3 s"

       by blast
    }
   ultimately show "?P1 s\<or> ?P2 s\<or> ?P3 s"

	                         by metis

 qed
lemma PI_Local_PutXVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_PutX ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma PI_Local_ReplaceVsInv83:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv83 ) (PI_Local_Replace ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma PI_Remote_GetVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (PI_Remote_Get  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma PI_Remote_GetXVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (PI_Remote_GetX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma PI_Remote_PutXVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (PI_Remote_PutX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma PI_Remote_ReplaceVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (PI_Remote_Replace  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma StoreVsInv83:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv83 ) (Store  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma StoreHomeVsInv83:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv83 ) (StoreHome ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  end


subsection \<open>RightShiftNode Phase\<close>

theory RightShiftPhase
  imports
    Common
    Proofs.StampEvalThms
begin

phase RightShiftNode
  terminating size
begin

(* Value level proofs *)
(* Has counter-example if x not 32-bit *)
lemma val_ReturnXOnZeroShift:
  assumes "val[x >> (IntVal 32 0)] \<noteq> UndefVal"
  and     "x = IntVal 32 xv"
  shows "val[x >> (IntVal 32 0)] = x"
  using assms apply (cases x; auto)
  sorry

(* Exp level proofs *)
lemma exp_ReturnXOnZeroShift:
  assumes "stamp_expr x = IntegerStamp 32 lo hi"
  and     "wf_stamp x"
shows "exp[x >> const(IntVal 32 0)] \<ge> exp[x]"
  apply auto
  subgoal premises p for m p xa
  proof -
    obtain xa where xa: "[m,p] \<turnstile> x \<mapsto> xa"
      using p(1) by auto
    then have 1: "intval_right_shift xa (IntVal 32 0) \<noteq> UndefVal"
      using evalDet p(1) p(2) by blast
    then have 2: "wf_value (IntVal 32 0)"
      using p(3) by auto
    then have equals: "xa = val[xa >> (IntVal 32 0)]"
      using val_ReturnXOnZeroShift apply (cases xa; auto)
      sorry
    then have 3: "[m,p] \<turnstile> x \<mapsto> intval_right_shift xa (IntVal (32::nat) (0::64 word))"
      by (simp add: xa)
    then show ?thesis
      using evalDet p(1) xa by blast
  qed
  done

text \<open>Optimisations\<close>
(* Need to prove exp_ReturnXOnZeroShift *)
optimization ReturnXOnZeroShift: "(x >> const(new_int 32 0)) \<longmapsto> x when
                                  ((stamp_expr x = IntegerStamp 32 lo hi) \<and> (wf_stamp x))"
   using exp_ReturnXOnZeroShift by fastforce

end (* End of RightShiftNode *)

end (* End of file *)


theory inEvenData

imports bundle.SB
  begin

typedef inEven="{cin}"
  by auto

instantiation inEven::"{somechan,finite}"
begin
definition "Rep = Rep_inEven"
instance
  apply(standard)
  apply(auto simp add: Rep_inEven_def cEmpty_def)
  apply(auto simp add: ctype_empty_iff)
  using ctype_empty_iff
  apply (metis Rep_inEven cMsg.simps ex_in_conv insertE insert_iff)
  apply (meson Rep_inEven_inject injI) using cMsg.elims Rep_inEven apply simp
  using type_definition.Abs_image type_definition_inEven typedef_finite_UNIV by fastforce
end

definition "Evenin \<equiv> Abs_inEven cin"

free_constructors inEven for "Evenin"
  by (metis(full_types) Abs_inEven_cases singletonD)

lemma Andin1_rep [simp]: "Rep (Evenin) = cin"
  using Rep_inEven Rep_inEven_def by auto

fun inEvenChan::"('bool::type \<Rightarrow> 'a::type) \<Rightarrow> 'bool \<Rightarrow> inEven \<Rightarrow> 'a" where
"inEvenChan Cc1 bool Evenin = Cc1 bool"

abbreviation "buildEveninSBE \<equiv> inEvenChan (Untimed o \<N>)"

lemma buildevenin_ctype: "buildEveninSBE a c \<in> ctype (Rep c)"
  sorry

lemma buildevenin_inj: "inj buildEveninSBE"
  sorry

lemma buildevenin_range: "range (\<lambda>a. buildEveninSBE a c) = ctype (Rep c)"
  sorry

lemma buildevenin_surj: assumes "sbElem_well (Some sbe)"
  shows "sbe \<in> range buildEveninSBE"
proof -
  have ctypewell:"\<And> c. sbe c\<in> ctype (Rep c)"
    using assms by auto
  hence "\<And>c. sbe c \<in> range (\<lambda>a. buildEveninSBE a c)"
    by (simp add: buildevenin_range)
  hence "\<exists>prod. sbe = buildEveninSBE prod"
    apply(subst fun_eq_iff,auto)
    sorry
  thus ?thesis
    by auto
qed

abbreviation "buildEveninSB \<equiv> inEvenChan (Rep_cfun (smap ((Untimed o \<N>))))"

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      SyntaxTest.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
(*<*)

theory SyntaxTest imports HeapList VcgCon begin

record Example1 =
  A :: "nat list"
  B :: "nat"

lemma "\<lbrace> (length \<ordmasculine>A = length \<ordfeminine>A) \<and> (\<ordmasculine>A ! i = \<ordfeminine>A ! i) \<rbrace> =
         {x. (length (A (fst x)) = length (A (snd x))) \<and>
             ((A (fst x))!i = (A (snd x))!i) }"
by auto

record "globals" =
 alloc_' :: "ref list"
 free_':: nat
 GA_' :: "ref list list"
 next_' :: "ref \<Rightarrow> ref"
 cont_' :: "ref \<Rightarrow> nat"

record localsd =
  n1_' :: "nat"
  n2_' :: "ref \<Rightarrow> nat"

record ('g,'a) vars = "'g state" +
  A_' :: "nat list"
  AA_' :: "nat list list"
  I_' :: nat
  M_' :: nat
  N_' :: nat
  R_' :: int
  R1_' :: "'a list"
  S_' :: int
  B_' :: bool
  Abr_':: string
  p_' :: ref
  q_' :: ref
  d_' :: nat

record ('g,'a) vars1 = "'g state" +
  A_' :: "nat list"
  AA_' :: "nat list list"
  I_' :: nat
  M_' :: nat
  N_' :: nat
  R_' :: int
  R1_' :: "'a list"
  S_' :: int
  B_' :: bool
  Abr_':: string
  p_' :: ref
  q_' :: ref
  d_' :: nat

lemma "{..<3::nat} = {} \<Longrightarrow> False"
by (simp add: Iio_eq_empty_iff_nat)

lemma Example1:
 "\<Gamma>,{} \<turnstile>\<^bsub>/{}\<^esub> (COBEGIN
      SCHEME [0 \<le> i < n]
     (SKIP,
     \<lbrace>\<acute>M = 0\<rbrace>,
     \<lbrace>(\<ordmasculine>M = \<ordfeminine>M)\<rbrace>\<^sub>r ,
     {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))},
     \<lbrace> True \<rbrace>,
      \<lbrace> True \<rbrace>)
    COEND)
 SAT [\<lbrace>\<acute>M = 0\<rbrace>, {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))},
     {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))}, \<lbrace> True \<rbrace>, \<lbrace> True \<rbrace>]"
apply (rule Parallel)
apply (auto simp add:Pre_def Rely_def Com_def Guar_def Post_def Abr_def)
apply (auto intro!: Conseq)
apply(rule_tac x="\<lbrace>\<acute>M = 0\<rbrace>" in exI)
apply simp
apply(rule_tac x="{(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))}" in exI)
apply simp
apply(rule_tac x="{(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))}" in exI)
apply simp
apply(rule_tac x="\<lbrace>\<acute>M = 0\<rbrace>" in exI)
apply (subgoal_tac "lrghoare \<Gamma> {} {} SKIP \<lbrace>\<acute>M = 0\<rbrace>
                 {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))}
                 {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> (M_' x1=  M_' y1))} \<lbrace>\<acute>M = 0\<rbrace> \<lbrace>\<acute>M = 0\<rbrace>")
prefer 2
by (auto simp add: Norm_def Sta_def intro!:Skip)

thm Conseq LocalRG_HoareDef.Conseq
lemma Example2:
 "\<Gamma>,{} \<turnstile>\<^bsub>/{}\<^esub> (COBEGIN
      SCHEME [0 \<le> i < n]
     (SKIP,
     \<lbrace>\<acute>M = 0\<rbrace>,
     {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> x=y)},
     {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> x=y)},
     \<lbrace> True \<rbrace>,
      \<lbrace> True \<rbrace>)
    COEND)
 SAT [\<lbrace>\<acute>M = 0\<rbrace>, {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> x=y)},
     {(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> x=y)}, \<lbrace> True \<rbrace>, \<lbrace> True \<rbrace>]"
apply (rule Parallel)
apply (auto simp add:Pre_def Rely_def Com_def Guar_def Post_def Abr_def)
apply (auto intro!: Conseq)
apply(rule_tac x="\<lbrace>\<acute>M = 0\<rbrace>" in exI)
apply simp
apply(rule_tac x="{(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> x=y)}" in exI)
apply simp
apply(rule_tac x="{(x,y). (\<exists>x1 y1. x=Normal x1 \<and> y=Normal y1 \<and> x=y)}" in exI)
apply simp
apply(rule_tac x="\<lbrace>\<acute>M = 0\<rbrace>" in exI)
apply (subgoal_tac "lrghoare \<Gamma> {} {} SKIP \<lbrace>\<acute>M = 0\<rbrace>
                {(x, y). (\<exists>x1. x = Normal x1) \<and> (\<exists>y1. y = Normal y1) \<and> x = y}
                {(x, y). (\<exists>x1. x = Normal x1) \<and> (\<exists>y1. y = Normal y1) \<and> x = y} \<lbrace>\<acute>M = 0\<rbrace> \<lbrace>\<acute>M = 0\<rbrace>")
prefer 2
apply (rule Skip)
apply (simp add: Sta_def)
apply (simp add: Norm_def)
apply (simp add: Norm_def)
by auto

lemma Example3:
 "\<Gamma>,{} \<turnstile>\<^bsub>/{}\<^esub> (COBEGIN
      SCHEME [0 \<le> i < n]
     (SKIP,
     \<lbrace> True \<rbrace>,
     \<lbrace>True \<rbrace>,
     \<lbrace> True \<rbrace>,
     \<lbrace> True \<rbrace>,
     \<lbrace> True \<rbrace>)
    COEND)
 SAT [\<lbrace> True \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> True \<rbrace>]"
apply (auto simp add: Parallel)
apply (rule Parallel)
apply (auto simp add:Pre_def Rely_def Com_def Guar_def Post_def Abr_def)
apply (rule Skip)
apply (auto intro!: Skip simp:Sta_def Norm_def)[1]
sorry

(*lemma Example1:
 "\<Gamma>,{} \<turnstile>\<^bsub>/{}\<^esub> (COBEGIN
      SCHEME [0 \<le> i < n]
     (\<acute>A :== \<acute>A [i := 0],
     \<lbrace> n < length \<acute>A \<rbrace>,
     \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
     \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
     \<lbrace> \<acute>A ! i = 0 \<rbrace>)
    COEND)
 sat [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
*)

hoarestate h = PA :: nat

hoarestate h1 = h + KA::nat
                    v::ref
                    q_' :: ref
                    free_':: nat
                    d_'::nat

procedures (imports h1)  Foo (q,d|d) = "\<acute>q :== \<acute>q;;\<acute>free:==0;;\<acute>d:==0"

context Foo_impl
begin
thm Foo_impl
thm Foo_body_def
end
context h1
begin
term  "\<acute>KA :== 3 -1 ;; \<acute>PA:==1"
end

term "\<acute>n1 :==\<^sub>g 3 - 1"
term "\<acute>I :==\<^sub>g \<acute>free"
term "\<acute>R :==\<^sub>g 3 - 1"
term "\<acute>I :==\<^sub>g \<acute>A!i"
term " \<acute>A!i :== j"
term " \<acute>AA :== \<acute>AA!![i,j]"
term " \<acute>AA!![i,j] :== \<acute>AA"
term "\<acute>A!i :==\<^sub>g j"
term "\<acute>p :==\<^sub>g \<acute>GA!i!j"
term "\<acute>p :==\<^sub>g \<acute>GA!i!j"
term "\<acute>GA!i!j :==\<^sub>g \<acute>p"
term "\<acute>p :==\<^sub>g \<acute>p \<rightarrow> \<acute>next"
term "\<acute>p \<rightarrow> \<acute>next :==\<^sub>g \<acute>p"
term "\<acute>p \<rightarrow> \<acute>next \<rightarrow> \<acute>next :==\<^sub>g \<acute>p"
term "\<acute>p :== NEW sz [\<acute>next :== Null,\<acute>cont :== 0]"
term "\<acute>p\<rightarrow>\<acute>next :==\<^sub>g NEW sz [\<acute>next :== Null,\<acute>cont :== 0]"
term "\<acute>p :== NNEW sz [\<acute>next :== Null,\<acute>cont :== 0]"
term "\<acute>p\<rightarrow>\<acute>next :==\<^sub>g NNEW sz [\<acute>next :== Null,\<acute>cont :== 0]"
term "\<acute>B :==\<^sub>g \<acute>N + 1 < 0 \<and> \<acute>M + \<acute>N < n"
term "\<acute>B :==\<^sub>g \<acute>N + 1 < 0 \<or>  \<acute>M + \<acute>N < n"
term "\<acute>I :==\<^sub>g \<acute>N mod n"
term "\<acute>I :==\<^sub>g \<acute>N div n"
term "\<acute>R :==\<^sub>g \<acute>R div n"
term "\<acute>R :==\<^sub>g \<acute>R mod n"
term "\<acute>R :==\<^sub>g \<acute>R * n"
term "\<acute>I :==\<^sub>g \<acute>I - \<acute>N"
term "\<acute>R :==\<^sub>g \<acute>R - \<acute>S"
term "\<acute>R :==\<^sub>g int \<acute>I"
term "\<acute>I :==\<^sub>g nat \<acute>R"
term "\<acute>R :==\<^sub>g -\<acute>R"
term "IF\<^sub>g \<acute>A!i < \<acute>N THEN c1 ELSE c2 FI"
term "AWAIT\<^sub>g \<acute>A!i < \<acute>N (IF True THEN SKIP ELSE SKIP FI)"
term "WHILE\<^sub>g \<acute>A!i < \<acute>N DO c OD"
term "WHILE\<^sub>g \<acute>A!i < \<acute>N INV \<lbrace>foo\<rbrace> DO c OD"
term "WHILE\<^sub>g \<acute>A!i < \<acute>N INV \<lbrace>foo\<rbrace> VAR bar x DO c OD"
term "WHILE\<^sub>g \<acute>A!i < \<acute>N INV \<lbrace>foo\<rbrace> VAR bar x DO c OD;;cd"
term "c;;WHILE\<^sub>g \<acute>A!i < \<acute>N INV \<lbrace>foo\<rbrace> VAR MEASURE \<acute>N + \<acute>M DO c;;c OD;;c"
context Foo_impl
begin
term "\<acute>q :== CALL Foo(\<acute>p,\<acute>M)"
term "\<acute>q :== CALL\<^sub>g Foo(\<acute>p,\<acute>M + 1)"
term "\<acute>q :== CALL Foo(\<acute>p\<rightarrow>\<acute>next,\<acute>M)"
term "\<acute>q \<rightarrow> \<acute>next :== CALL Foo(\<acute>p,\<acute>M)"
term "COBEGIN (\<acute>q :== CALL Foo(\<acute>p\<rightarrow>\<acute>next,\<acute>M)) \<parallel> (\<acute>q :== CALL Foo(\<acute>p\<rightarrow>\<acute>next,\<acute>M)) COEND"
end

end

(*>*)


(*<*)
theory Preliminaries
imports Abbrevs
begin

record foorecord = fld\<^sub>1 :: nat fld\<^sub>2 ::nat
datatype foodatatype = Foo
notation (latex output)
Foo ("\<^latex>\<open>\\constructor{Foo}\<close>")

(* TODO:
setup {*add_constructor_syntax "latex" "Preliminaries.foodatatype" *}
*)
(*>*)
section \<open>Preliminaries \label{sec:preliminaries}\<close>
text \<open>
The formalization presented in this papaer is mechanized and checked within the generic interactive theorem prover \emph{Isabelle}\cite{Paulson:IGTP94}.
Isabelle is called generic as it provides a framework to formalize various \emph{object logics} declared via natural deduction style inference rules.
The object logic that we employ for our formalization is the higher order logic of \emph{Isabelle/HOL}\cite{Nipkow:IHOL02}.

This article is written using Isabelle's document generation facilities, which guarantees a close correspondence between the presentation and the actual theory files.
We distinguish formal entities typographically from other text.
We use a sans serif font for types and constants (including functions and predicates), \eg @{term "map"}, a slanted serif font for free variables, \eg @{term "x"}, and a slanted sans serif font for bound variables, \eg @{term "Bind x. x"}.
Small capitals are used for data type constructors, \eg @{term[names_short] "Foo"}, and type variables have a leading tick, \eg  @{typ "'a"}. HOL keywords are typeset in type-writer font, \eg \holkeyword{let}. %We also take the freedom to borrow C notation, \eg @{term "UnsgndT"} when presenting C0.

To group common premises and to support modular reasoning Isabelle provides \emph{locales}\cite{Ballarin:TYPES03-34,Ballarin:MKM06-31}.
A locale provides a name for a context of fixed parameters and premises, together with an elaborate infrastructure to define new locales by inheriting and extending other locales, prove theorems within locales and interpret (instantiate) locales. In our formalization we employ this infrastructure to separate the memory system from the programming language semantics.

The logical and mathematical notions follow the standard notational conventions with a bias towards functional programming.
We only present the more unconventional parts here.
We prefer curried function application, \eg @{term "f a b"} instead of @{term [mode=uncurry] "f a b"}.
In this setting the latter becomes a function application to \emph{one} argument, which happens to be a pair.

Isabelle/HOL provides a library of standard types like Booleans, natural numbers, integers, total functions, pairs, lists, and sets. Moreover, there are packages to define new data types and records.
Isabelle allows polymorphic types, \eg @{typ "'a list"} is the list type with type variable @{typ "'a"}.
In HOL all functions are total, \eg @{typ "nat \<Rightarrow> nat"} is a total function on natural numbers.
A function update is @{thm fun_upd_def[of f y v]}.
To formalize partial functions the type @{typ "'a option"} is used.
It is a data type with two constructors, one to inject values of the base type, \eg @{term "Some x"}, and the additional element @{term "None"}.
A base value can be projected with the function @{term "the"}, which is defined by the sole equation @{thm option.sel [of x]}.
Since HOL is a total logic the term @{term "the None"} is still a well-defined yet un(der)specified value.
Partial functions are usually represented by the type \<open>\<^latex>\<open>\tfreeify{\<close>'a\<^latex>\<open>}\<close> \<Rightarrow> \<^latex>\<open>\tfreeify{\<close>'b\<^latex>\<open>}\<close> option\<close>, abbreviated as @{typ  "'a \<rightharpoonup> 'b"}.
They are commonly used as \emph{maps}.
%With @{term "map_of xs"} we construct a map from an association list, \ie a list of key~/~value pairs.
We denote the domain of map  @{term "m"} by @{term "dom m"}. % not used: and to its range by @{term "ran m"}.
A map update is written as @{term "m(a := Some v)"}.
%With @{term "m\<^sub>1 ++ m\<^sub>2"} we add the map @{term "m\<^sub>2"} to map @{term "m\<^sub>1"}, where entries of @{term "m\<^sub>1"} are overwritten if necessary.
We can restrict the domain of a map @{term "m"} to a set @{term "A"} by @{term "m |` A"}.
%Subsumption of maps is defined as @{thm "map_le_def" [of m\<^sub>1 m\<^sub>2]} and composition of maps as @{thm "map_comp_def" [of m\<^sub>1 m\<^sub>2]}.

%\paragraph{Lists.}
The syntax and the operations for lists are similar to functional programming languages like ML or Haskell.
The empty list is @{term "[]"}, with @{term "x#xs"} the element @{term "x"} is `consed' to the list @{term "xs"}.%, the head of list @{term "xs"} is @{term "hd xs"} and the remainder, its tail, is @{term "tl xs"}.
With @{term "xs@ys"} list @{term "ys"} is appended to list @{term "xs"}.
With the term @{term "map f xs"} the function @{term "f"} is applied to all elements in @{term "xs"}.
The length of a list is @{term "length xs"}, the @{term n}-th element of a list can be selected with @{term "xs!n"} and can be updated via @{term "xs[n:=v]"}. With @{term "dropWhile P xs"} the prefix for which all elements satisfy predicate @{term "P"} are dropped from list @{term "xs"}.
%With @{term "set xs"} we obtain the set of elements in list @{term "xs"}.
%Filtering those elements from a list for which predicate @{term "P"} holds is achieved by @{term [eta_contract=false] "[x\<in>xs. P x]"}.
%With @{term "replicate n e"} we denote a list that consists of @{term n} elements @{term e}.

%\paragraph{Sets.}
Sets come along with the standard operations like union, \ie @{term "A \<union> B"}, membership, \ie @{term "x \<in> A"} and set inversion, \ie @{term "- A"}.

%intersection, \ie @{term "A \<inter> B"} and
%The set image @{term "f ` A"} yields a new set by applying function @{term "f"} to every element in set @{term "A"}.

%\paragraph{Records.}
%A record is constructed by assigning all of its fields, \eg @{term "\<lparr>fld\<^sub>1 = v\<^sub>1, fld\<^sub>2 = v\<^sub>2\<rparr>"}.
%Field @{term [names_short]"fld\<^sub>1"} of record @{term "r"} is selected by @{term[names_short] "fld\<^sub>1 r"} and updated with a value @{term "x"} via @{term[names_short] "r\<lparr>fld\<^sub>1 := x\<rparr>"}.

%\paragraph{Tuples.}
%The first and second component of a pair can be accessed with the functions @{const fst} and @{const snd}.
Tuples with more than two components are pairs nested to the right.

\<close>
(*<*)
end
(*>*)


theory MoreCurrAutomation
imports DataRefinementMore
begin

thm T_g_specifies_I

definition (in -) mm3 where
  "mm3 t A = (case A of None \<Rightarrow> None | Some t' \<Rightarrow> if t'\<le>t then Some (t-t') else None)"

lemma Some_le_mm3_Some_conv: "Some t \<le> mm3 t' (Some t'') \<longleftrightarrow> (t'' \<le> t' \<and> t \<le> (t' - t''))"
  by (simp add: mm3_def)

lemma Some_le_emb'_conv: "Some t \<le> emb' Q ft x \<longleftrightarrow> Q x \<and> t \<le> ft x"
  by (auto simp: emb'_def)

lemma Some_eq_emb'_conv: "Some t = emb' Q ft x \<longleftrightarrow> Q x \<and> t = ft x"
        "emb' Q ft x = Some t  \<longleftrightarrow> Q x \<and> t = ft x"
  by (auto simp: emb'_def)

definition  whileIET :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> bool)
                           \<Rightarrow> ('a \<Rightarrow> ('a,'c::{complete_lattice,plus,zero}) nrest)
                           \<Rightarrow> 'a \<Rightarrow> ('a,'c) nrest" where
  "\<And>E c. whileIET I E b c = whileT b c"

subsection \<open>Progress prover\<close>

definition "progress m \<equiv> \<forall>s' M. m = SPECT M \<longrightarrow> M s' \<noteq> None \<longrightarrow> M s' > Some 0"
lemma progressD: "progress m \<Longrightarrow> m=SPECT M \<Longrightarrow> M s' \<noteq> None \<Longrightarrow> M s' > Some 0"
  by (auto simp: progress_def)

subsection \<open>Progress rules\<close>

named_theorems progress_rules

lemma progress_SELECT_iff: "progress (SELECT P t) \<longleftrightarrow> t > 0"
  unfolding progress_def SELECT_def emb'_def by (auto split: option.splits)

lemmas [progress_rules] = progress_SELECT_iff[THEN iffD2]

lemma progress_REST_iff: "progress (REST [x \<mapsto> t]) \<longleftrightarrow> t>0"
  by (auto simp: progress_def)

lemmas [progress_rules] = progress_REST_iff[THEN iffD2]

lemma progress_ASSERT_bind[progress_rules]: "\<lbrakk>\<Phi> \<Longrightarrow> progress (f ()) \<rbrakk> \<Longrightarrow> progress (ASSERT \<Phi>\<bind>f)"
  apply (cases \<Phi>)
   apply (auto simp: progress_def less_fun_def)
  sorry

lemma progress_SPECT_emb[progress_rules]: "t > 0 \<Longrightarrow> progress (SPECT (emb P t))" by(auto simp: progress_def emb'_def)

lemma Sup_Some: "Sup (S::enat option set) = Some e \<Longrightarrow> \<exists>x\<in>S. (\<exists>i. x = Some i)"
  unfolding Sup_option_def by (auto split: if_splits)

lemma progress_bind[progress_rules]: assumes "progress m \<or> (\<forall>x. progress (f x))"
  shows "progress (m\<bind>f)"
  sorry

method progress methods solver =
  (rule asm_rl[of "progress _"] , (simp add: le_fun_def less_fun_def split: prod.splits | intro allI impI conjI | determ \<open>rule progress_rules\<close> | rule disjI1; progress \<open>solver\<close>; fail | rule disjI2; progress \<open>solver\<close>; fail | solver)+) []

subsection \<open>VCG splitter\<close>

ML \<open>

  structure VCG_Case_Splitter = struct
    fun dest_case ctxt t =
      case strip_comb t of
        (Const (case_comb, _), args) =>
          (case Ctr_Sugar.ctr_sugar_of_case ctxt case_comb of
             NONE => NONE
           | SOME {case_thms, ...} =>
               let
                 val lhs = Thm.prop_of (hd (case_thms))
                   |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst;
                 val arity = length (snd (strip_comb lhs));
                 (*val conv = funpow (length args - arity) Conv.fun_conv
                   (Conv.rewrs_conv (map mk_meta_eq case_thms));*)
               in
                 SOME (nth args (arity - 1), case_thms)
               end)
      | _ => NONE;

    fun rewrite_with_asm_tac ctxt k =
      Subgoal.FOCUS (fn {context = ctxt', prems, ...} =>
        Local_Defs.unfold0_tac ctxt' [nth prems k]) ctxt;

    fun split_term_tac ctxt case_term = (
      case dest_case ctxt case_term of
        NONE => no_tac
      | SOME (arg,case_thms) => let
            val stac = asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps case_thms)
          in
          (*CHANGED o stac
          ORELSE'*)
          (
            Induct.cases_tac ctxt false [[SOME arg]] NONE []
            THEN_ALL_NEW stac
          )
        end 1

    )

    fun split_tac ctxt = Subgoal.FOCUS_PARAMS (fn {context = ctxt, ...} => ALLGOALS (
        SUBGOAL (fn (t, _) => case Logic.strip_imp_concl t of
          @{mpat "Trueprop (Some _ \<le> T_g _ ?prog)"} => split_term_tac ctxt prog
         | @{mpat "Trueprop (progress ?prog)"} => split_term_tac ctxt prog
     (*   | @{mpat "Trueprop (Case_Labeling.CTXT _ _ _ (valid _ _ ?prog))"} => split_term_tac ctxt prog *)
        | _ => no_tac
        ))
      ) ctxt
      THEN_ALL_NEW TRY o Hypsubst.hyp_subst_tac ctxt

  end
\<close>

method_setup vcg_split_case = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (CHANGED o (VCG_Case_Splitter.split_tac ctxt)))\<close>

named_theorems vcg_rules'
method vcg'_step methods solver uses rules =
    (intro rules vcg_rules' | vcg_split_case
        | (progress simp;fail)  | (solver; fail))

method vcg' methods solver uses rules = repeat_all_new \<open>vcg'_step solver rules: rules\<close>

lemma T_g_SPECT2_I[vcg_rules']:
  fixes t' :: "'b\<Rightarrow>enat" (* "'b:: {complete_lattice,minus,plus,ord}" *)
  assumes "(\<And> x. X x \<Longrightarrow> (Some (t' + t x ) \<le> Q x))"
  shows "Some t' \<le> T_g Q (SPECT (emb' X t))"
  apply(auto simp: T_g_def)
  apply(rule Inf_greatest) apply auto
  unfolding mii_g_def mm_g_def emb'_def apply (auto split: option.splits)
  subgoal using assms by force
  subgoal for x tx using assms[of x] apply simp
    by (simp add: enat_adjoint le_fun_def)
  subgoal for x tx using assms[of x] apply simp
    by (metis ab_semigroup_add_class.add_ac(1) add.commute le_iff_add)
  done

lemma T_g_bindT_I[vcg_rules']:
  "\<And>t. Some t \<le>  T_g (\<lambda>y. T_g Q (f y) ) M \<Longrightarrow>  Some t \<le> T_g Q (M \<bind> f)"
  sorry

lemma T_g_SPECT_I[vcg_rules']:  "\<And>t. (Some (t' + t ) \<le> Q x)
    \<Longrightarrow>  Some t' \<le> T_g Q (SPECT [ x \<mapsto> t])"
  sorry

lemma (in -) While[vcg_rules']:
  fixes I and E :: "'a \<Rightarrow> 'c::{complete_lattice,minus,zero,order,plus}" and b C s0
  assumes  "I s0"  "(\<And>s. I s \<Longrightarrow> b s \<Longrightarrow> Some 0 \<le> T_g (\<lambda>s'. mm3 (E s) (if I s' then Some (E s') else None)) (C s)) "
     "(\<And>s. progress (C s))"
     "(\<And>x. \<not> b x \<Longrightarrow>  I x \<Longrightarrow>  (E x) \<le> (E s0) \<Longrightarrow>   Some (t +  ((E s0) - E x)) \<le> Q x)"
   shows   "Some t \<le> T_g Q  (whileIET I E b C s0)"
  sorry

lemma (in -) if_T_g[vcg_rules']: "(b \<Longrightarrow> t \<le> T_g Q Ma) \<Longrightarrow> (\<not>b \<Longrightarrow> t \<le> T_g Q Mb) \<Longrightarrow> t  \<le> T_g Q  (if b then Ma else Mb)"
   by (simp add: split_def)

lemma (in -) T_g_ASSERT_I[vcg_rules']: "(\<Phi> \<Longrightarrow> Some t \<le> Q ()) \<Longrightarrow> \<Phi> \<Longrightarrow> Some t \<le> T_g Q (ASSERT \<Phi>)"
  sorry

lemma (in -) T_SELECT[vcg_rules']:
  assumes
    "\<forall>x. \<not> P x \<Longrightarrow> Some tt \<le> T_g Q (SPECT [None \<mapsto> tf])"
  and p: "(\<And>x. P x \<Longrightarrow> Some tt \<le> T_g Q (SPECT [Some x \<mapsto> tf]) )"
shows "Some tt \<le> T_g Q (SELECT P tf)"
  sorry

lemma (in-) RETURNT_T_I[vcg_rules']: "t \<le> Q x \<Longrightarrow> t  \<le> T_g Q (RETURNT x)"
  sorry

subsection \<open>Monotonicity rules for refine_vcg proofs\<close>

lemma RECT_mono[refine_mono]:
  assumes [simp]: "mono2 B'"
  assumes LE: "\<And>F x. (B' F x) \<le> timerefine FF (B F x) "
  shows " (RECT B' x) \<le> timerefine FF (RECT B x)"
  unfolding RECT_def
  apply clarsimp
  using LE gfp_mono le_fun_def   sorry

lemma WHILET_refine:
  assumes R0: "(x,x')\<in>R"
  assumes COND_REF: "\<And>x x'. \<lbrakk> (x,x')\<in>R \<rbrakk> \<Longrightarrow> b x = b' x'"
  assumes STEP_REF:
    "\<And>x x'. \<lbrakk> (x,x')\<in>R; b x; b' x' \<rbrakk> \<Longrightarrow> f x \<le> \<Down>R (timerefine F  (f' x'))"
  shows "whileT b f x \<le> \<Down>R (timerefine F (whileT b' f' x'))"
  sorry

lemma (in -) whileT_mono:
  assumes "\<And>x. b x \<Longrightarrow> c x \<le> timerefine F (c' x)"
  shows " (whileT b c x) \<le> timerefine F (whileT b c' x)" (*
  unfolding whileT_def apply(rule RECT_mono)
    subgoal by(refine_mono)
  apply auto apply(rule bindT_mono) using assms by auto *) sorry

thm bindT_refine'

lemma bindT_refine_g:
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' (timerefine F M')"
  assumes R2: "\<And>x x' t t'. \<lbrakk> (x,x')\<in>R';
    nofailT M; nofailT M'; inresT2 M x t;  inresT2 M' x' t';
      t \<le> (\<lambda>c. Sum_any (\<lambda>a. t' a * F a c))
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (timerefine F (f' x'))"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (timerefine F (bindT M' (\<lambda>x'. f' x')))"
    sorry

lemma bindT_refine_g':
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' (timerefine F M')"
  assumes R2: "\<And>x x' t t'. \<lbrakk> (x,x')\<in>R';
    nofailT M; nofailT M'; inresT2 M x t;  inresT2 M' x' t';
      t \<le> (\<lambda>c. Sum_any (\<lambda>a. t' a * F a c))
  \<rbrakk> \<Longrightarrow> f x \<le>   (timerefine F (f' x'))"
  shows "bindT M (\<lambda>x. f x) \<le>  (timerefine F (bindT M' (\<lambda>x'. f' x')))"
    sorry

lemma timerefine_ASSERT: "(\<Phi>' \<Longrightarrow> \<Phi>) \<Longrightarrow> ASSERT \<Phi> \<le> timerefine F (ASSERT \<Phi>')"
  by (auto simp: timerefine_def ASSERT_def iASSERT_def RETURNT_def le_fun_def)

lemma assumes "(\<And>s t. P s = Some t \<Longrightarrow> \<exists>s'. Some t \<le> Q s' \<and> (s, s') \<in> R)"
  shows SPECT_refine: "SPECT P \<le> \<Down> R (SPECT Q)"
  sorry

lemma timerefine_SPECT:
  assumes "\<And>x. P' x = None \<Longrightarrow> P x = None"
    and "\<And>x x2. P' x = Some x2 \<Longrightarrow> P x \<le> Some (\<lambda>cc. Sum_any (\<lambda>ac. x2 ac * F ac cc))"
shows "SPECT P \<le> timerefine F (SPECT P')"
  unfolding timerefine_def
  apply (auto split: option.splits simp: le_fun_def)
  using assms by auto

lemma timerefine_RETURNT:
  assumes "x=x'"
shows "RETURNT x \<le> timerefine F (RETURNT x')"
  unfolding RETURNT_def
  using assms by (auto intro!: timerefine_SPECT simp: le_fun_def)

thm SELECT_refine
lemma SELECT_refine_g:
  fixes T
  assumes "\<And>x'. P' x' \<Longrightarrow> \<exists>x. P x"
  assumes "\<And>x. P x \<Longrightarrow>   P' x"
  assumes "T \<le> (\<lambda>cc. Sum_any (\<lambda>ac. T' ac * F ac cc))"
  shows "SELECT P T \<le> timerefine F (SELECT P' T')"
  unfolding SELECT_def
  apply (auto split: if_splits)
   using assms
   by (auto intro!: timerefine_SPECT simp: emb'_def split: if_splits option.splits)
 (*
proof -
  have "SELECT P T \<le> SELECT P T'"
    using s1 assms(3) by auto
  also have "\<dots> \<le> SELECT P' T'"
    unfolding s2 apply safe
    using assms(1,2) by auto
  finally show ?thesis .
qed *)

lemma If_refine: "b = b' \<Longrightarrow>
  (b \<Longrightarrow> b' \<Longrightarrow> S1 \<le> \<Down> R (timerefine F S1')) \<Longrightarrow>
  (\<not> b \<Longrightarrow> \<not> b' \<Longrightarrow> S2 \<le> \<Down> R (timerefine F S2')) \<Longrightarrow> (if b then S1 else S2) \<le> \<Down> R (timerefine F (if b' then S1' else S2'))"
  by auto

lemma Case_prod_refine: "(x,x')\<in> \<langle>S1,S2\<rangle>prod_rel \<Longrightarrow>
  (\<And>x x' y y'. (x,x')\<in>S1 \<Longrightarrow> (y,y')\<in>S2 \<Longrightarrow> C x y  \<le> \<Down> R (timerefine F (C' x' y')))
  \<Longrightarrow> (case x of (a,b) \<Rightarrow> C a b) \<le> \<Down> R (timerefine F (case x' of (a',b') \<Rightarrow> C' a' b'))"
  by (auto split: prod.split)

lemma case_prod_refine_g2:
  fixes P Q :: "'a \<Rightarrow> 'b \<Rightarrow> ('c,_) nrest"
  assumes
    "\<And>a b. P a b \<le> \<Down>R (timerefine FF (Q a b))"
  shows
 "(case x of (a,b) \<Rightarrow> P a b) \<le> \<Down>R (timerefine FF (case x of (a,b) \<Rightarrow> Q a b))"
  using assms
  by (simp add: split_def)

lemma case_prod_refine_g:
  fixes P Q :: "'a \<Rightarrow> 'b \<Rightarrow> ('c,_) nrest"
  assumes
    "\<And>a b. P a b \<le> timerefine FF (Q a b)"
  shows
 "(case x of (a,b) \<Rightarrow> P a b) \<le> timerefine FF (case x of (a,b) \<Rightarrow> Q a b)"
  using assms
  by (simp add: split_def)

lemma bindT_mono_g:
  "m \<le> timerefine FF m' \<Longrightarrow> (\<And>x. nofailT m' \<Longrightarrow>  f x \<le> timerefine FF (f' x))
   \<Longrightarrow> bindT m f \<le> timerefine FF (bindT  m' f')"
  sorry

lemma le_ASSERTI_g2:
  fixes M :: "(_,_) nrest"
  shows "(\<Phi> \<Longrightarrow> M \<le> \<Down> R ( timerefine FF M' )) \<Longrightarrow> M \<le> \<Down> R (timerefine FF (ASSERT \<Phi> \<bind> (\<lambda>_. M')))"
  sorry

lemma le_ASSERTI_g:
  fixes M :: "(_,_) nrest"
  shows "(\<Phi> \<Longrightarrow> M \<le> timerefine FF M') \<Longrightarrow> M \<le> timerefine FF (ASSERT \<Phi> \<bind> (\<lambda>_. M'))"
  sorry

lemma ASSERT_leI2:
  fixes M :: "(_,_) nrest"
  shows "\<Phi> \<Longrightarrow> (\<Phi> \<Longrightarrow> M \<le> \<Down> R( timerefine FF M')) \<Longrightarrow>ASSERT \<Phi> \<bind> (\<lambda>_. M) \<le>  \<Down> R (timerefine FF M')"
  sorry

lemma ASSERT_leI:
  fixes M :: "(_,_) nrest"
  shows "\<Phi> \<Longrightarrow> (\<Phi> \<Longrightarrow> M \<le> timerefine FF M') \<Longrightarrow> ASSERT \<Phi> \<bind> (\<lambda>_. M) \<le> timerefine FF M'"
  sorry

thm case_option_mono
lemma case_option_mono_g:
  assumes "fn \<le> timerefine FF fn'"
  assumes "\<And>v. x=Some v \<Longrightarrow> fs v \<le> timerefine FF (fs' v)"
  shows "case_option fn fs x \<le> timerefine FF (case_option fn' fs' x)"
  using assms by (auto split: option.split)

lemma case_prod_mono_g:
  "\<lbrakk>\<And>a b. p=(a,b) \<Longrightarrow> f a b \<le> timerefine FF (f' a b)\<rbrakk> \<Longrightarrow> case_prod f p \<le> timerefine FF (case_prod f' p)"
  by (auto split: prod.split)

lemma nofailT_ASSERT_bind_g:
  fixes M :: "(_,_) nrest"
  shows "nofailT (ASSERT P \<bind> (\<lambda>_. M)) \<longleftrightarrow> (P \<and> nofailT M)"
  sorry

lemma inresT2_REST:
  "\<And>t. inresT2 (REST X) x t \<longleftrightarrow> (\<exists>t'\<ge>enat o t. X x = Some t')"
  unfolding inresT2_def
  by auto

lemma inresT2_SPEC[refine_pw_simps]: "inresT2 (SPEC a b) = (\<lambda>x t. a x \<and>  b x \<ge> t)"
  unfolding SPEC_def inresT2_REST
  apply(rule ext)
  by(auto simp: le_fun_def split:  if_splits)

lemma inresT2_SELECT:
 "inresT2 (SELECT Q tt) x t'
     \<longleftrightarrow> ((case x of None \<Rightarrow> \<not>(\<exists>x. Q x) | Some x \<Rightarrow> Q x)  \<and> (t' \<le> tt))"
  by(auto simp: inresT2_def SELECT_def le_fun_def emb'_def)

lemma pw_inresT2_bindT: "\<And>t. inresT2 (bindT m f) r t \<longleftrightarrow>
     (nofailT m \<longrightarrow> (\<exists>r' t' t''. inresT2 m r' t' \<and> inresT2 (f r') r t'' \<and> t = t' + t''))"
  sorry

lemma if_distrib2: "(if b then x else y) * z = (if b then x * z else y * z)"
  by(simp add: if_distrib)

section \<open>Trans rules\<close>

lemma conc_trans_2:
  assumes A: "C \<le> \<Down>R (timerefine F B)" and B: "B \<le> \<Down>R' (timerefine F' A)"
  shows "C \<le> \<Down>R (\<Down>R'(timerefine F (timerefine F' A)))"
  sorry

section \<open>enum setup\<close>

lemma (in enum) sum_to_foldr: "sum f UNIV
      = foldr (\<lambda>x a. a + f x) enum 0"
  (*= sum_list (map f enum_class.enum)"  *)
  unfolding UNIV_enum using enum_distinct
  apply(simp add: sum.distinct_set_conv_list  )
  apply(simp only: sum_list.eq_foldr foldr_map)
  by (metis add.commute comp_apply)

lemma (in enum) Sum_any_to_foldr: "Sum_any f
      = foldr (\<lambda>x a. a + f x) enum 0"
  apply(subst Sum_any.expand_superset[where A=UNIV])
  by (simp_all add: sum_to_foldr)

definition nfoldli where
  "nfoldli l c f s = RECT (\<lambda>D (l,s). (case l of
    [] \<Rightarrow> RETURNT s
    | x#ls \<Rightarrow> if c s then do { s\<leftarrow>f x s; D (ls, s)} else RETURNT s
  )) (l, s)"

definition nfoldliIE :: "('d list \<Rightarrow> 'd list \<Rightarrow> 'a \<Rightarrow>  bool) \<Rightarrow> ('b::{complete_lattice,plus,zero}) \<Rightarrow> 'd list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> 'a \<Rightarrow> ('a,'b) nrest) \<Rightarrow> 'a \<Rightarrow> ('a,'b) nrest" where
  "nfoldliIE I E l c f s = nfoldli l c f s"

lemma nfoldliIE_rule:
  assumes I0: "I [] l0 \<sigma>0"
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes T: "\<And>x. (body_time x * (enat (length l0))) \<le> t x"
  shows "nfoldliIE I body_time l0 c f \<sigma>0 \<le> SPECT (emb P t)"
  sorry

lemma T_conseq4:
  assumes
    "T_g Q' f \<ge> Some t'"
    "\<And>x t'' M. Q' x = Some t'' \<Longrightarrow> (Q x) \<ge> Some ((t - t') + t'')"
  shows "T_g Q f \<ge> Some t" sorry

lemma T_conseq6:
  assumes
    "T_g Q f \<ge> Some t'"
    "\<And>x t'' M. Q x = Some t'' \<Longrightarrow>   t' \<ge> t"
  shows "T_g Q f \<ge> Some (t::'a:: {complete_lattice,minus,plus})"
  oops

definition "monadic_WHILE b f s \<equiv> do {
  RECT (\<lambda>D s. do {
    bv \<leftarrow> b s;
    if bv then do {
      s \<leftarrow> f s;
      D s
    } else do {RETURNT s}
  }) s
}"
definition monadic_WHILEIE  where
  "monadic_WHILEIE I E bm c s = monadic_WHILE bm c s"

lemma monadic_WHILE_refine2:
  assumes
    "(x, x') \<in> R"
    "\<And>x x'. (x, x') \<in> R \<Longrightarrow> bm x \<le> \<Down>Id (bm' x')"
    and "\<And>x x' t. (x, x') \<in> R \<Longrightarrow> nofailT (bm' x') \<Longrightarrow> inresT2 (bm' x') True t \<Longrightarrow> c x \<le> \<Down>R (c' x')"
  shows "(monadic_WHILE bm c x) \<le> \<Down>R (monadic_WHILE bm' c' x')"
  sorry

fun Someplus where
  "Someplus None _ = None"
| "Someplus _ None = None"
| "Someplus (Some a) (Some b) = Some (a+b)"

definition mm22 :: "( ('a\<Rightarrow> enat) option) \<Rightarrow> (   ('a\<Rightarrow> enat) option) \<Rightarrow> (   ('a\<Rightarrow> enat) option)" where
  "mm22 r m = (case m  of None \<Rightarrow> Some \<infinity>
                                | Some mt \<Rightarrow>
                                  (case r of None \<Rightarrow> None | Some rt \<Rightarrow> (if mt \<le> rt then Some (rt - mt) else None)))"

lemma
  fixes s0 :: 'a and I :: "'a \<Rightarrow> bool" and E :: "'a \<Rightarrow> ('c \<Rightarrow> nat)" and t :: "'c \<Rightarrow> enat"
  assumes
  step: "(\<And>s. I s \<Longrightarrow> Some 0 \<le> T_g (\<lambda>b. if b then T_g (\<lambda>s'. if I s' \<and> E s' \<le> E s
                   then Some ((\<lambda>x. enat (E s x - E s' x))) else None)  (c s)
                    else mm22 (Q s) (Someplus (Some t) (mm3 (enat o (E s0)) (Some (enat o (E s)))))) (bm s))"
 and  progress: "\<And>s. progress (c s)"
 and  i: "I s0"
shows neueWhile_rule': "Some t \<le> T_g Q (monadic_WHILEIE I E bm c s0)"
  sorry

definition "G b d = (if b then Some d else None)"
definition "H Qs t Es0 Es = mm22 Qs (Someplus (Some t) (mm3 (Es0) (Some (Es))))"

lemma
  fixes s0 :: 'a and I :: "'a \<Rightarrow> bool" and E :: "'a \<Rightarrow> ('c \<Rightarrow> nat)" and t :: "'c \<Rightarrow> enat"
  assumes
  step: "(\<And>s. I s \<Longrightarrow> Some 0 \<le> T_g (\<lambda>b. if b then T_g  (\<lambda>s'. G (I s' \<and> E s' \<le> E s) (E s - E s')) (c s)
               else H (Q s) t (E s0) (E s))  (bm s))"
 and  progress: "\<And>s. progress (c s)"
 and  i: "I s0"
shows neueWhile_rule'': "Some t \<le> T_g Q (monadic_WHILEIE I E bm c s0)"
  apply(rule neueWhile_rule')
  unfolding monadic_WHILEIE_def
  subgoal for s using step[of s] apply (simp add: ) unfolding H_def G_def o_def by (auto cong: if_cong)
    using assms by auto

definition [to_relAPP]: "list_set_rel R \<equiv> \<langle>R\<rangle>list_rel O br set distinct"

lemma le_ASSERTI_f:
  fixes M :: "(_,_ \<Rightarrow> enat) nrest"
  shows "(\<Phi> \<Longrightarrow> M \<le> M') \<Longrightarrow> M \<le> ASSERT \<Phi> \<bind> (\<lambda>_. M')"
  sorry

section "some Monadic Refinement Automation"

ML \<open>
structure Refine = struct

  structure vcg = Named_Thms
    ( val name = @{binding refine_vcg}
      val description = "Refinement Framework: " ^
        "Verification condition generation rules (intro)" )

  structure vcg_cons = Named_Thms
    ( val name = @{binding refine_vcg_cons}
      val description = "Refinement Framework: " ^
        "Consequence rules tried by VCG" )

  structure refine0 = Named_Thms
    ( val name = @{binding refine0}
      val description = "Refinement Framework: " ^
        "Refinement rules applied first (intro)" )

  structure refine = Named_Thms
    ( val name = @{binding refine}
      val description = "Refinement Framework: Refinement rules (intro)" )

  structure refine2 = Named_Thms
    ( val name = @{binding refine2}
      val description = "Refinement Framework: " ^
        "Refinement rules 2nd stage (intro)" )

  (* If set to true, the product splitter of refine_rcg is disabled. *)
  val no_prod_split =
    Attrib.setup_config_bool @{binding refine_no_prod_split} (K false);

  fun rcg_tac add_thms ctxt =
    let
      val cons_thms = vcg_cons.get ctxt
      val ref_thms = (refine0.get ctxt
        @ add_thms @ refine.get ctxt @ refine2.get ctxt);
      val prod_ss = (Splitter.add_split @{thm prod.split}
        (put_simpset HOL_basic_ss ctxt));
      val prod_simp_tac =
        if Config.get ctxt no_prod_split then
          K no_tac
        else
          (simp_tac prod_ss THEN'
            REPEAT_ALL_NEW (resolve_tac ctxt @{thms impI allI}));
    in
      REPEAT_ALL_NEW_FWD (DETERM o FIRST' [
        resolve_tac ctxt ref_thms,
        resolve_tac ctxt cons_thms THEN' resolve_tac ctxt ref_thms,
        prod_simp_tac
      ])
    end;

  fun post_tac ctxt = REPEAT_ALL_NEW_FWD (FIRST' [
    eq_assume_tac,
    (*match_tac ctxt thms,*)
    SOLVED' (Tagged_Solver.solve_tac ctxt)])

end;
\<close>
setup \<open>Refine.vcg.setup\<close>
setup \<open>Refine.vcg_cons.setup\<close>
setup \<open>Refine.refine0.setup\<close>
setup \<open>Refine.refine.setup\<close>
setup \<open>Refine.refine2.setup\<close>
(*setup {* Refine.refine_post.setup *}*)

method_setup refine_rcg =
  \<open>Attrib.thms >> (fn add_thms => fn ctxt => SIMPLE_METHOD' (
    Refine.rcg_tac add_thms ctxt THEN_ALL_NEW_FWD (TRY o Refine.post_tac ctxt)
  ))\<close>
  "Refinement framework: Generate refinement conditions"

method_setup refine_vcg =
  \<open>Attrib.thms >> (fn add_thms => fn ctxt => SIMPLE_METHOD' (
    Refine.rcg_tac (add_thms @ Refine.vcg.get ctxt) ctxt THEN_ALL_NEW_FWD (TRY o Refine.post_tac ctxt)
  ))\<close>
  "Refinement framework: Generate refinement and verification conditions"

subsection "setup for refine_vcg"

lemma If_refine_plain[refine]: "b = b' \<Longrightarrow>
  (b \<Longrightarrow> b' \<Longrightarrow> S1 \<le> \<Down> R S1') \<Longrightarrow>
  (\<not> b \<Longrightarrow> \<not> b' \<Longrightarrow> S2 \<le> \<Down> R S2') \<Longrightarrow> (if b then S1 else S2) \<le> \<Down> R (if b' then S1' else S2')"
  by auto

lemma Case_option_refine[refine]: "(x,x')\<in> \<langle>S\<rangle>option_rel \<Longrightarrow>
  (\<And>y y'. (y,y')\<in>S \<Longrightarrow> S2 y  \<le> \<Down> R (S2' y')) \<Longrightarrow> S1 \<le> \<Down> R S1'
  \<Longrightarrow> (case x of None \<Rightarrow> S1 | Some y \<Rightarrow> S2 y) \<le> \<Down> R (case x' of None \<Rightarrow> S1' | Some y' \<Rightarrow> S2' y')"
  by(auto split: option.split)

lemma [refine0]: "\<And>S. S \<le> \<Down> Id S" by simp
lemma refine_plain_ASSERT_bind[refine0]:
    "\<Phi> \<Longrightarrow> (\<Phi> \<Longrightarrow> S \<le> \<Down> R S') \<Longrightarrow> ASSERT \<Phi> \<bind> (\<lambda>_. S) \<le> \<Down> R S'"
   sorry

lemma le_R_ASSERTI: "(\<Phi> \<Longrightarrow> M \<le> \<Down> R M') \<Longrightarrow>  M \<le> \<Down> R (ASSERT \<Phi> \<bind> (\<lambda>_. M'))"
  sorry

declare le_R_ASSERTI [refine0]

thm refine0

declare bindT_refine [refine]
declare WHILET_refine [refine]
thm refine
thm refine2
thm refine_vcg

lemma [refine_vcg_cons]: "m \<le> SPECT \<Phi> \<Longrightarrow> (\<And>x. \<Phi> x \<le> \<Psi> x) \<Longrightarrow> m \<le> SPECT \<Psi>"
  by (metis dual_order.trans le_funI nres_order_simps(2))
thm refine_vcg_cons

end


(*  Title:      HOL/Library/Phantom_Type.thy
    Author:     Andreas Lochbihler
*)

section \<open>A generic phantom type\<close>

theory Phantom_Type
imports "MainRLT"
begin

datatype ('a, 'b) phantom = phantom (of_phantom: 'b)

lemma type_definition_phantom': "type_definition of_phantom phantom UNIV"
by(unfold_locales) simp_all

lemma phantom_comp_of_phantom [simp]: "phantom \<circ> of_phantom = id"
  and of_phantom_comp_phantom [simp]: "of_phantom \<circ> phantom = id"
by(simp_all add: o_def id_def)

syntax "_Phantom" :: "type \<Rightarrow> logic" ("(1Phantom/(1'(_')))")
translations
  "Phantom('t)" => "CONST phantom :: _ \<Rightarrow> ('t, _) phantom"

typed_print_translation \<open>
  let
    fun phantom_tr' ctxt (Type (\<^type_name>\<open>fun\<close>, [_, Type (\<^type_name>\<open>phantom\<close>, [T, _])])) ts =
          list_comb
            (Syntax.const \<^syntax_const>\<open>_Phantom\<close> $ Syntax_Phases.term_of_typ ctxt T, ts)
      | phantom_tr' _ _ _ = raise Match;
  in [(\<^const_syntax>\<open>phantom\<close>, phantom_tr')] end
\<close>

lemma of_phantom_inject [simp]:
  "of_phantom x = of_phantom y \<longleftrightarrow> x = y"
by(cases x y rule: phantom.exhaust[case_product phantom.exhaust]) simp

end