(* uses Isabelle2017 and autocorres version 1.0 *)
theory myGraph
  imports
  "checker-verification/Library/Autocorres_Misc"
  "checker-verification/Witness_Property/Connected_Components"
  "checker-verification/Witness_Property/ShortestPath"
begin
(* Parse the input file. *)
install_C_file "Graph_copy.c"

autocorres "Graph_copy.c"

context Graph_copy begin

thm "is_wellformed_body_def"
thm "trian_body_def"
thm "just_body_def"
thm "no_path_body_def"
thm "pos_cost_body_def"
thm "check_basic_just_sp_body_def"
thm "check_sp_body_def"

thm "is_wellformed'_def"
thm "trian'_def"
thm "just'_def"
thm "no_path'_def"
thm "pos_cost'_def"
thm "check_basic_just_sp'_def"
thm "check_sp'_def"

(*Implementation Graph Types*)

type_synonym IVertex = "32 word"
type_synonym IEdge_Id = "32 word"
type_synonym IEdge = "IVertex \<times> IVertex"
type_synonym IPEdge = "IVertex \<Rightarrow> 32 word"
type_synonym INum = "IVertex \<Rightarrow> 32 word"
type_synonym IDist = "IVertex \<Rightarrow> 32 word"
type_synonym ICost = "IVertex \<Rightarrow> 32 word"
type_synonym IGraph = "32 word \<times> 32 word \<times> (IEdge_Id \<Rightarrow> IEdge)"

abbreviation
  ivertex_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "ivertex_cnt G \<equiv> fst G"

abbreviation
  iedge_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "iedge_cnt G \<equiv> fst (snd G)"

abbreviation
  iedges :: "IGraph \<Rightarrow> IEdge_Id \<Rightarrow> IEdge"
where
  "iedges G \<equiv> snd (snd G)"

(* Make List - makes a list containing the result of a function *)
fun
  bool::"32 word \<Rightarrow> bool"
where
  "bool b = (if b=0 then False else True)"

fun
  mk_list' :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> 'b list"
where
  "mk_list' n f = map f  (map of_nat [0..<n])"

fun
  mk_list'_temp :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b list"
where
  "mk_list'_temp 0 _ _ = []" |
  "mk_list'_temp (Suc x) f i = (f (of_nat i)) # mk_list'_temp x f (Suc i)"

(* Make graph lists *)
fun
  mk_iedge_list :: "IGraph \<Rightarrow> IEdge list"
where
  "mk_iedge_list G = mk_list' (unat (iedge_cnt G)) (iedges G)"

fun
  mk_inum_list :: "IGraph \<Rightarrow> INum \<Rightarrow> 32 word list"
where
  "mk_inum_list G num = mk_list' (unat (ivertex_cnt G)) num"

fun
  mk_ipedge_list :: "IGraph \<Rightarrow> IPEdge \<Rightarrow> 32 word list"
where
  "mk_ipedge_list G pedge = mk_list' (unat (ivertex_cnt G)) pedge"

fun
  mk_idist_list :: "IGraph \<Rightarrow> IDist \<Rightarrow> 32 word list"
where
  "mk_idist_list G dis = mk_list' (unat (ivertex_cnt G)) dis"

fun
  mk_icost_list :: "IGraph \<Rightarrow> ICost \<Rightarrow> 32 word list"
where
  "mk_icost_list G cost = mk_list' (unat (iedge_cnt G)) cost"

(* Equate to Implementation *)

lemma sint_ucast:
  "sint (ucast (x ::word32) :: sword32) = sint x"
  by (clarsimp simp: sint_uint uint_up_ucast is_up)

fun
  to_edge :: "IEdge \<Rightarrow> IEdge_C"
where
  "to_edge (u,v) = IEdge_C u v"

lemma s_C_pte[simp]:
  "first_C (to_edge e) = fst e"
  by (cases e) auto

lemma t_C_pte[simp]:
  "second_C (to_edge e) = snd e"
  by (cases e) auto

definition is_graph where
  "is_graph h iG p \<equiv>
    is_valid_IGraph_C h p \<and>
    ivertex_cnt iG = num_vertices_C (heap_IGraph_C h p) \<and>
    iedge_cnt iG = num_edges_C (heap_IGraph_C h p) \<and>
    arrlist (heap_IEdge_C h) (is_valid_IEdge_C h)
      (map to_edge (mk_iedge_list iG)) (arcs_C (heap_IGraph_C h p))"

definition
  "is_numm h iG iN (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_inum_list iG iN) p"

definition
  "is_pedge h iG iP (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_ipedge_list iG iP) p"

definition
  "is_dist h iG iD (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_idist_list iG iD) p"

definition
  "is_cost h iG iC p \<equiv> arrlist (heap_w32 h) (is_valid_w32 h) (mk_icost_list iG iC) p"

(* Abstract Graph *)

definition
  no_loops :: "('a, 'b) pre_digraph \<Rightarrow> bool"
where
  "no_loops G \<equiv> \<forall>e \<in> arcs G. tail G e \<noteq> head G e"

definition
  abs_IGraph :: "IGraph \<Rightarrow> (32 word, 32 word) pre_digraph"
where
  "abs_IGraph G \<equiv> \<lparr> verts = {0..<ivertex_cnt G}, arcs = {0..<iedge_cnt G},
    tail = fst o iedges G, head = snd o iedges G \<rparr>"

lemma verts_absI[simp]: "verts (abs_IGraph G) = {0..<ivertex_cnt G}"
  and edges_absI[simp]: "arcs (abs_IGraph G) = {0..<iedge_cnt G}"
  and start_absI[simp]: "tail (abs_IGraph G) e = fst (iedges G e)"
  and target_absI[simp]: "head (abs_IGraph G) e = snd (iedges G e)"
  by (auto simp: abs_IGraph_def)

definition
  abs_pedge :: "(32 word \<Rightarrow> 32 word) \<Rightarrow> 32 word \<Rightarrow> 32 word option"
where
  "abs_pedge p \<equiv> (\<lambda>v. if sint (p v) < 0 then None else Some (p v))"

lemma None_abs_pedgeI[simp]:
  "((abs_pedge p) v = None) = (sint (p v) < 0)"
  using abs_pedge_def by auto

lemma Some_abs_pedgeI[simp]:
  "(\<exists>e. (abs_pedge p) v = Some e) = (sint (p v) \<ge> 0)"
  using None_not_eq None_abs_pedgeI
  by (metis abs_pedge_def linorder_not_le option.simps(3))

(*Helper Lemmas*)

lemma wellformed_iGraph:
  assumes "wf_digraph (abs_IGraph G)"
  shows "\<And>e. e < iedge_cnt G \<Longrightarrow>
        fst (iedges G e) < ivertex_cnt G \<and>
        snd (iedges G e) < ivertex_cnt G"
  using assms unfolding wf_digraph_def by simp

lemma unat_image_upto:
  fixes n :: "32 word"
  shows "unat ` {0..<n} = {unat 0..<unat n}" (is "?A = ?B")
proof
  show "?B \<subseteq> ?A"
  proof
    fix i assume a: "i \<in> ?B"
    then obtain i':: "32 word" where ii: "i=  unat i'"
      by (metis atLeastLessThan_iff le_unat_uoi less_or_eq_imp_le)
    then have "i' \<in> {0..<n}"
      using a word_less_nat_alt by auto
    thus  "i \<in> ?A" using ii by fast
  qed
next
  show "?A \<subseteq> ?B"
  proof
     fix i assume a: "i \<in> ?A"
    then obtain i':: "32 word" where ii: "i=  unat i'" by blast
    then have "i' \<in> {0..<n}" using a by force
    thus  "i \<in> ?B"
      by (metis Un_iff atLeast0LessThan ii ivl_disj_un(8)
          lessThan_iff unat_0 unat_mono word_zero_le)
  qed
qed

lemma path_length:
  assumes "vpath p (abs_IGraph iG)"
  shows "vwalk_length p < unat (ivertex_cnt iG)"
proof -
  have pne: "p \<noteq> []" and dp: "distinct p" using assms by fast+
  have "unat (ivertex_cnt iG) = card (unat ` {0..<(fst iG)})"
    using unat_image_upto by simp
  then have "unat (ivertex_cnt iG) = card ((verts (abs_IGraph iG)))"
     by (simp add: inj_on_def card_image)
  hence "length p  \<le> unat (ivertex_cnt iG)"
      by (metis finite_code card_mono vwalk_def
          distinct_card[OF dp] vpath_def assms)
  hence "length p - 1 < unat (ivertex_cnt iG)"
    by (metis pne Nat.diff_le_self le_neq_implies_less
        less_imp_diff_less minus_eq one_neq_zero length_0_conv)
  thus "vwalk_length p < unat (fst iG)"
    using  assms
    unfolding vpath_def vwalk_def by simp
qed

lemma ptr_coerce_ptr_add_uint[simp]:
  "ptr_coerce (p +\<^sub>p uint x) =  p +\<^sub>p  (uint x)"
  by auto

lemma pedge_num_dist_heap:
  "\<lbrakk>arrlist (\<lambda>p. heap_w32 h p) (\<lambda>p. is_valid_w32 h p)
  (map (iL \<circ> of_nat) [0..<unat n]) l; i < n\<rbrakk> \<Longrightarrow>
    iL i = heap_w32 h (l +\<^sub>p int (unat i))"
  apply (subgoal_tac
  "heap_w32 h (l +\<^sub>p int (unat i)) = map (iL \<circ> of_nat) [0..<unat n] ! unat i")
   apply (subgoal_tac "map (iL \<circ> of_nat) [0..<unat n] ! unat i = iL i")
    apply fastforce
   apply (metis (hide_lams, mono_tags) unat_mono word_unat.Rep_inverse
    minus_nat.diff_0 nth_map_upt o_apply plus_nat.add_0)
  apply (simp add: arrlist_nth_value unat_mono)
  done

lemma pedge_num_dist_heap_ptr_coerce:
  "\<lbrakk>arrlist (\<lambda>p. heap_w32 h (ptr_coerce p)) (\<lambda>p. is_valid_w32 h (ptr_coerce p))
  (map (iL \<circ> of_nat) [0..<unat n]) l; i < n; 0 \<le> i\<rbrakk> \<Longrightarrow>
    iL i = heap_w32 h (ptr_coerce (l +\<^sub>p int (unat i)))"
  apply (subgoal_tac
  "heap_w32 h (ptr_coerce (l +\<^sub>p int (unat i))) = map (iL \<circ> of_nat) [0..<unat n] ! unat i")
   apply (subgoal_tac "map (iL \<circ> of_nat) [0..<unat n] ! unat i = iL i")
    apply fastforce
   apply (metis (hide_lams, mono_tags) unat_mono word_unat.Rep_inverse
    minus_nat.diff_0 nth_map_upt o_apply plus_nat.add_0)
  apply (drule arrlist_nth_value[where i="int (unat i)"], (simp add:unat_mono)+)
  done

lemma edge_heap:
  "\<lbrakk> arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep;
  e < m\<rbrakk> \<Longrightarrow> to_edge ((iedges iG) e) = h (ep +\<^sub>p (int (unat e)))"
  apply (subgoal_tac "h (ep +\<^sub>p (int (unat e))) =
  (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
   apply (subgoal_tac "to_edge ((iedges iG) e) =
   (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
    apply presburger
   apply (metis (hide_lams, mono_tags) length_map length_upt o_apply
      map_upt_eq_vals_D minus_nat.diff_0 unat_mono word_unat.Rep_inverse)
  apply (fastforce simp: unat_mono arrlist_nth_value)
  done

lemma head_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  snd ((iedges iG) e) = second_C (h (ep +\<^sub>p (uint e)))"
  using edge_heap to_edge.simps t_C_pte by (metis uint_nat)

lemma tail_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  fst ((iedges iG) e) =  first_C (h (ep +\<^sub>p  (uint e)))"
  using edge_heap to_edge.simps s_C_pte uint_nat by metis

thm "is_wellformed'_def"

definition is_wellformed_inv :: "IGraph \<Rightarrow> 32 word \<Rightarrow> bool" where
  "is_wellformed_inv G i \<equiv> \<forall>k < i. ivertex_cnt G > fst (iedges G k)
        \<and> ivertex_cnt G > snd (iedges G k)"

lemma is_wellformed_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g) \<rbrace>
   is_wellformed' g
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> is_wellformed_inv iG (iedge_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: is_wellformed'_def)
  apply (subst whileLoopE_add_inv [where
        M="\<lambda>(ee, s). unat (iedge_cnt iG - ee)" and
        I="\<lambda>ee s. P s \<and> is_wellformed_inv iG ee \<and>
                   ee \<le> iedge_cnt iG \<and>
                   wf_digraph (abs_IGraph iG) \<and>
                   is_graph s iG g"])
  apply (simp add: skipE_def)
  apply wp
  unfolding is_graph_def is_wellformed_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
         apply (rule_tac x = "ee" in exI)
         apply (subgoal_tac "num_vertices_C (heap_IGraph_C s g) \<le> fst (snd (snd iG) ee)")
          apply force
         apply (subgoal_tac "first_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint ee)) = fst (snd (snd iG) ee)")
          apply simp
         apply (subst tail_heap[where iG=iG], simp)
          apply blast
         apply blast
        apply(rule_tac x = "ee" in exI)
        apply (subgoal_tac "num_vertices_C (heap_IGraph_C s g) \<le> snd (snd (snd iG) ee)")
         apply force
        apply (subgoal_tac "second_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint ee)) = snd (snd (snd iG) ee)")
         apply simp
        apply (subst head_heap[where iG=iG], simp)
         apply blast
        apply blast
       apply (metis edge_heap s_C_pte le_cases le_step uint_nat word_le_less_eq)
      apply (metis head_heap le_step not_less)
     apply (simp add: le_step word_not_le)
  using le_step not_less
     apply blast
    apply (metis (mono_tags, hide_lams) diff_diff_add diff_self_eq_0 eq_iff_diff_eq_0 measure_unat not_less0 word_less_nat_alt zero_less_diff)
   apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)
  apply wp
  apply fast
  done

definition trian_inv :: "IGraph \<Rightarrow> IDist \<Rightarrow> ICost \<Rightarrow> 32 word \<Rightarrow> bool" where
  "trian_inv G d c m \<equiv>
    \<forall>i < m. d (snd (iedges G i)) \<le> d (fst (iedges G i)) + c i"

lemma trian_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and>
          is_dist s iG iD d \<and>
          is_cost s iG iC c)\<rbrace>
   trian' g d c
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> trian_inv iG iD iC (iedge_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: trian'_def)
  apply (subst whileLoopE_add_inv [where
        M="\<lambda>(ee, s). unat (iedge_cnt iG - ee)" and
        I="\<lambda>ee s. P s \<and> trian_inv iG iD iC ee \<and>
                   ee \<le> iedge_cnt iG \<and>
                   wf_digraph (abs_IGraph iG) \<and>
                   is_graph s iG g \<and>
                   is_dist s iG iD d \<and>
                   is_cost s iG iC c"])
  apply (simp add: skipE_def)
  apply wp
  unfolding is_graph_def is_dist_def is_cost_def trian_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
          apply (rule_tac x = "ee" in exI)
          apply (rule conjI, simp+)
          apply (subst pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD])
             apply fast
            apply (subst head_heap[where iG=iG], simp+)
            apply (metis head_heap wellformed_iGraph, simp+)
          apply (subst pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD])
             apply fast
            apply (subst tail_heap[where iG=iG], simp+)
            apply (metis tail_heap wellformed_iGraph, simp+)
          apply (drule wellformed_iGraph[where G=iG])
           apply simp+
          apply (subst head_heap[where iG=iG], simp+)
          apply (subst tail_heap[where iG=iG], simp+)
          apply (subgoal_tac "heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (second_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint ee))))))
             > heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (first_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint ee)))))) + iC ee")
           apply simp+
          apply (subst pedge_num_dist_heap[where l=c and iL=iC])
            apply simp+
          apply (metis uint_nat)
         apply (subst pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD])
            apply fast
           apply (subst head_heap[where iG=iG], simp+)
  using le_step less_trans
            apply blast
           apply (metis (no_types, hide_lams) head_heap wellformed_iGraph le_step less_trans)
  using word_zero_le
          apply blast
         apply (subst pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD])
            apply fast
           apply (subst tail_heap[where iG=iG], simp+)
  using le_step less_trans
            apply blast
           apply (metis (no_types, hide_lams) tail_heap wellformed_iGraph le_step less_trans)
          apply simp
         apply (subst pedge_num_dist_heap[where l=c and iL=iC])
           apply (simp add: uint_nat)+
  using le_step less_trans
          apply blast
         apply (subst head_heap[where iG=iG], simp+)
  using le_step less_trans
          apply blast
         apply (subst tail_heap[where iG=iG], simp+)
  using le_step less_trans
          apply blast
         apply (subgoal_tac "i < num_edges_C (heap_IGraph_C s g)")
          apply (subgoal_tac "\<And>w. \<not> w < num_edges_C (heap_IGraph_C s g) \<or> heap_w32 s (c +\<^sub>p uint w) = iC w")
           apply (subgoal_tac "\<And>w. \<not> w < num_edges_C (heap_IGraph_C s g) \<or> heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint w) = to_edge (snd (snd iG) w)")
            apply (subgoal_tac "\<And>w. \<not> w < fst iG \<or> heap_w32 s (ptr_coerce (d +\<^sub>p uint w)) = iD w")
             apply (subgoal_tac "\<And>w. \<not> w < num_edges_C (heap_IGraph_C s g) \<or> snd (snd (snd iG) w) < fst iG")
              apply (subgoal_tac "\<And>w. \<not> w < num_edges_C (heap_IGraph_C s g) \<or> fst (snd (snd iG) w) < fst iG")
               apply (subgoal_tac "heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (second_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint i)))))) \<le> heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (first_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint i)))))) + heap_w32 s (c +\<^sub>p int (unat i))")
                apply metis
               apply (subgoal_tac "\<forall>w. heap_w32 s (ptr_coerce (d +\<^sub>p int (unat w))) = iD w \<or> \<not> w < fst iG")
                apply (subgoal_tac "heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (second_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p int (unat i))))))) \<le> heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (first_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p int (unat i))))))) + iC i")
                 apply (subgoal_tac "heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (second_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint i)))))) \<le> heap_w32 s (ptr_coerce (d +\<^sub>p int (unat (first_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint i)))))) + heap_w32 s (c +\<^sub>p int (unat i))")
                  apply (simp add:uint_nat)+
                apply (metis (no_types, hide_lams) le_step word_not_le)
               apply (metis uint_nat)
              apply (simp add: wf_digraph_def)
             apply (simp add: wf_digraph_def)
            apply (simp add: pedge_num_dist_heap_ptr_coerce uint_nat)
           apply (simp add: edge_heap uint_nat)
          apply (simp add: pedge_num_dist_heap uint_nat)
  using le_step less_trans
         apply blast
  using le_step not_less
        apply blast
       apply (metis (no_types, hide_lams) diff_diff_add eq_iff_diff_eq_0 measure_unat word_not_le)
      apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)
      apply (metis tail_heap wellformed_iGraph uint_nat word_less_nat_alt)
     apply (rule_tac i="uint ee" in arrlist_nth_valid, simp+)
     apply (simp add:uint_nat)
  using word_less_nat_alt
     apply blast
    apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)
    apply (metis head_heap wellformed_iGraph uint_nat word_less_nat_alt)
   apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)
  apply wp
  apply fast
  done

definition just_inv ::
  "IGraph \<Rightarrow> IDist \<Rightarrow> ICost \<Rightarrow> IVertex \<Rightarrow> INum \<Rightarrow> IPEdge \<Rightarrow> 32 word \<Rightarrow> bool" where
  "just_inv G d c s n p k \<equiv>
    \<forall>v < k. v \<noteq> s \<and> n v \<ge> 0 \<longrightarrow>
      (\<exists> e. e = p v (*\<and> p v \<ge> 0*) \<and> e < iedge_cnt G \<and>
        v = snd (iedges G e) \<and>
        d v = d (fst (iedges G e)) + c e \<and>
        n v = n (fst (iedges G e)) + 1)"

lemma just_inv_step:
  assumes v_less_max: "v < max_word"
  shows "just_inv G d c s n p (v + 1) \<longleftrightarrow> just_inv G d c s n p v
    \<and> (v \<noteq> s \<and> n v \<ge> 0 \<longrightarrow>
      (\<exists> e. e =  (p v) \<and> e < iedge_cnt G \<and>
        v = snd (iedges G e) \<and>
        d v = d (fst (iedges G e)) +  c e \<and>
        n v = n (fst (iedges G e)) +  1))"
  unfolding just_inv_def using v_less_max
  by (auto simp add : less_x_plus_1)

lemma just_inv_le:
  assumes leq: "j \<le> i"
  assumes just_i: "just_inv G d c s n p i"
  shows "just_inv G d c s n p j"
  using assms
  by (induct j) (auto simp add: just_inv_def)

lemma not_just_verts:
  fixes G R c d n p s v
  assumes v_less_max: "v < max_word"
  assumes "v < ivertex_cnt G"
  assumes "v \<noteq> s \<and> n v \<ge> 0 \<and>
        (iedge_cnt G \<le> p v \<or>
        snd (iedges G (p v)) \<noteq> v \<or>
        d v \<noteq>
          d (fst (iedges G (p v))) + c (p v) \<or>
        n v \<noteq> n (fst (iedges G (p v))) + 1)"
  shows "\<not> just_inv G d c s n p (ivertex_cnt G)"
proof (rule notI)
  assume jv: "just_inv G d c s n p (ivertex_cnt G)"
  have "just_inv G d c s n p (v + 1)"
    by (metis le_step order.asym word_not_le just_inv_le[OF _ jv] assms(2))
  then have "(v \<noteq> s \<and> n v \<ge> 0 \<longrightarrow>
      (\<exists> e. e = p v \<and> e < iedge_cnt G \<and>
        v = snd (iedges G e) \<and>
        d v = d (fst (iedges G e)) + c e \<and>
        n v = n (fst (iedges G e)) + 1))"
    unfolding just_inv_def
    using v_less_max just_inv_step
    by (auto simp add : less_x_plus_1)
  with assms show False by force
qed

lemma just_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and>
          is_dist s iG iD d \<and>
          is_cost s iG iC c \<and>
          sc < ivertex_cnt iG \<and>
          is_numm s iG iN n \<and>
          is_pedge s iG iP p)\<rbrace>
   just' g d c sc n p
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> just_inv iG iD iC sc iN iP (ivertex_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: just'_def)
  apply (subst whileLoopE_add_inv [where
        M="\<lambda>(vv, s). unat (ivertex_cnt iG - vv)" and
        I="\<lambda>vv s. P s \<and> just_inv iG iD iC sc iN iP vv \<and>
                   vv \<le> ivertex_cnt iG \<and>
                   wf_digraph (abs_IGraph iG) \<and>
                   is_graph s iG g \<and>
                   is_dist s iG iD d \<and>
                   is_cost s iG iC c \<and>
                   sc < ivertex_cnt iG \<and>
                   is_numm s iG iN n \<and>
                   is_pedge s iG iP p"])
  apply (simp add: skipE_def)
  apply wp
  unfolding is_graph_def is_dist_def is_cost_def is_numm_def is_pedge_def just_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: if_split_asm, simp_all add: arrlist_nth)
    apply (safe)
                                                       apply (metis pedge_num_dist_heap_ptr_coerce uint_nat word_not_le word_zero_le)
                                                      apply (metis (no_types) head_heap pedge_num_dist_heap_ptr_coerce uint_nat word_zero_le)
                                                     prefer 52
                                                     apply wp
                                                     apply force
                                                    prefer 51
                                                    apply force
                                                   prefer 50
                                                   apply (rule_tac i="(uint sc)" in arrlist_nth_valid, simp+)
                                                   apply (simp add: uint_nat word_less_def)
                                                  prefer 49
                                                  apply (metis (no_types, hide_lams) diff_diff_add eq_iff_diff_eq_0 measure_unat word_not_le)
                                                 prefer 48
                                                 apply argo
                                                prefer 47
                                                apply argo
                                               prefer 46
                                               apply argo
                                              prefer 45
                                              apply argo
                                             prefer 44
                                             apply argo
                                            prefer 43
                                            apply (metis (mono_tags, hide_lams) le_step not_less)
                                           prefer 42
  using le_step
                                           apply blast
                                          prefer 41
  using le_step
                                          apply blast
                                         prefer 40
  using le_step
                                        apply blast
                                       prefer 39
  using le_step
                                       apply metis
                                      prefer 38
                                      apply (rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
                                      apply (simp add: uint_nat word_less_def)
                                     prefer 37
                                     apply (rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
                                     apply (simp add: uint_nat word_less_def)
                                    prefer 36
                                    apply (metis (no_types, hide_lams) diff_diff_add eq_iff_diff_eq_0 measure_unat word_not_le)
                                   prefer 35
                                   apply argo
                                  prefer 34
                                  apply argo
                                 prefer 33
                                 apply presburger
                                prefer 32
                                apply argo
                               prefer 31
                               apply argo
                              prefer 30
                              apply presburger
                             prefer 29
                             apply (metis (mono_tags, hide_lams) le_step not_less)
                            prefer 28
                            prefer 27
                            prefer 26
                            prefer 25
                            prefer 24
                            apply (rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
                            apply (simp add: uint_nat word_less_def)
                           prefer 23
                           prefer 22
                           prefer 21
                           apply (rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
                           apply (simp add: uint_nat word_less_def)
                          prefer 20
                          apply (metis (mono_tags, hide_lams) diff_diff_add eq_iff_diff_eq_0 measure_unat word_not_le)
                         prefer 19
                         apply argo
                        prefer 18
                        apply argo
                       prefer 17
                       apply presburger
                      prefer 16
                      apply argo
                      prefer 15
                      apply argo
                     prefer 14
                     apply argo
                    prefer 13
                    apply (metis le_step not_less)
                   prefer 12
                   prefer 11
                   apply (metis (no_types) edge_heap pedge_num_dist_heap_ptr_coerce t_C_pte le_step not_less uint_nat word_zero_le)
                  prefer 10
                  apply (metis (no_types) pedge_num_dist_heap_ptr_coerce le_step not_less uint_nat word_zero_le)
                 prefer 9
                 apply (subgoal_tac "\<forall>w. heap_w32 s (ptr_coerce (p +\<^sub>p int (unat w))) = iP w \<or> \<not> w < fst iG")
                  apply (subgoal_tac "\<forall>w. heap_w32 s (ptr_coerce (n +\<^sub>p int (unat w))) = iN w \<or> \<not> w < fst iG")
                   apply (subgoal_tac "\<exists>w<num_vertices_C (heap_IGraph_C s g). w \<noteq> sc \<and> (iD w = iD (fst (snd (snd iG) (iP w))) + iC (iP w) \<longrightarrow> w = snd (snd (snd iG) (iP w)) \<longrightarrow> iP w < num_edges_C (heap_IGraph_C s g) \<longrightarrow> iN w \<noteq> iN (fst (snd (snd iG) (iP w))) + 1)")
                    apply (metis (no_types))
                   apply (metis (no_types, hide_lams) tail_heap wellformed_iGraph uint_nat)
                  apply (metis pedge_num_dist_heap_ptr_coerce word_zero_le)
                 apply (metis pedge_num_dist_heap_ptr_coerce word_zero_le)
                apply (subst pedge_num_dist_heap_ptr_coerce[where l=p and iL=iP])
                   apply simp+
  using le_step less_trans
                  apply blast
                 apply fastforce
                apply (subst pedge_num_dist_heap_ptr_coerce[where l=n and iL=iN])
                   apply simp+
  using le_step less_trans
                  apply blast
                 apply fastforce
                apply (subst pedge_num_dist_heap_ptr_coerce[where l=n and iL=iN])
                   apply simp+
                  apply (metis (no_types) pedge_num_dist_heap_ptr_coerce wellformed_iGraph le_step uint_nat word_not_le word_zero_le)
                 apply fastforce
                apply (subgoal_tac "\<forall>w. heap_w32 s (ptr_coerce (p +\<^sub>p int (unat w))) = iP w \<or> \<not> w < fst iG")
                 apply (subgoal_tac "\<forall>w. heap_w32 s (ptr_coerce (n +\<^sub>p int (unat w))) = iN w \<or> \<not> w < fst iG")
                  apply (subgoal_tac "heap_w32 s (ptr_coerce (p +\<^sub>p int (unat vv))) < fst (snd iG)")
                   apply (subgoal_tac "heap_w32 s (ptr_coerce (n +\<^sub>p int (unat v))) = heap_w32 s (ptr_coerce (n +\<^sub>p int (unat (fst (snd (snd iG) (heap_w32 s (ptr_coerce (p +\<^sub>p int (unat v))))))))) + 1")
                    apply (metis (no_types))
                   apply (metis (no_types, hide_lams) edge_heap s_C_pte wellformed_iGraph le_step uint_nat)
                  apply (simp add:uint_nat)
                 apply (metis pedge_num_dist_heap_ptr_coerce word_zero_le)
                apply (metis pedge_num_dist_heap_ptr_coerce word_zero_le)
               prefer 8
               apply (subst pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD], simp+)
  using le_step less_trans
                 apply blast
                apply simp
               apply (subst pedge_num_dist_heap_ptr_coerce[where l=p and iL=iP], simp+)
  using le_step less_trans
                 apply blast
                apply simp
               apply (subst tail_heap[where iG=iG], simp+)
                apply (subgoal_tac "\<forall>w. w < num_vertices_C (heap_IGraph_C s g) \<or> \<not> w < vv")
                 apply (subgoal_tac "heap_w32 s (ptr_coerce (p +\<^sub>p int (unat v))) < num_edges_C (heap_IGraph_C s g)")
                  apply (meson less_trans)
                 apply (metis (no_types) pedge_num_dist_heap_ptr_coerce le_step not_less uint_nat word_zero_le)
                apply fastforce
               apply (subst pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD], simp+)
                 apply (subgoal_tac "\<forall>w. heap_w32 s (ptr_coerce (p +\<^sub>p int (unat w))) = iP w \<or> \<not> w < fst iG")
                  apply (subgoal_tac "first_C (heap_IEdge_C s (arcs_C (heap_IGraph_C s g) +\<^sub>p uint (heap_w32 s (ptr_coerce (p +\<^sub>p int (unat v)))))) < num_vertices_C (heap_IGraph_C s g)")
  using pedge_num_dist_heap_ptr_coerce
                   apply fastforce
                  apply (metis (no_types) tail_heap wellformed_iGraph le_step not_less uint_nat)
                 apply (metis pedge_num_dist_heap_ptr_coerce word_zero_le)
                apply force
               apply (subst pedge_num_dist_heap_ptr_coerce[where l=p and iL=iP], simp+)
  using le_step less_trans
                 apply blast
                apply simp
               apply (subst pedge_num_dist_heap[where l=c and iL=iC], simp+)
                apply (subgoal_tac "\<forall>w. w < num_vertices_C (heap_IGraph_C s g) \<or> \<not> w < vv")
                 apply (subgoal_tac "heap_w32 s (ptr_coerce (p +\<^sub>p int (unat v))) < num_edges_C (heap_IGraph_C s g)")
  using less_trans
                  apply blast
                 apply (metis (no_types) pedge_num_dist_heap_ptr_coerce le_step not_less uint_nat word_zero_le)
  using less_trans
                apply (blast, clarsimp)

  sorry

definition no_path_inv :: "IGraph \<Rightarrow> IDist \<Rightarrow> INum \<Rightarrow> 32 word \<Rightarrow> bool" where
  "no_path_inv G d n k \<equiv>  \<forall>v < k. (d v < 0 \<longleftrightarrow> n v < 0)"

lemma no_path_inv_step:
  "no_path_inv G d n (v + 1) \<longleftrightarrow> no_path_inv G d n v
    \<and> (d v < 0 \<longleftrightarrow> n v < 0)"
  by (auto simp add: no_path_inv_def)

lemma no_path_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and>
          is_dist s iG iD d \<and>
          is_numm s iG iN n)\<rbrace>
   no_path' g d n
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> no_path_inv iG iD iN (ivertex_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: no_path'_def)
  apply (subst whileLoopE_add_inv [where
        M="\<lambda>(vv, s). unat (ivertex_cnt iG - vv)" and
        I="\<lambda>vv s. P s \<and> no_path_inv iG iD iN vv \<and>
                   vv \<le> ivertex_cnt iG \<and>
                   wf_digraph (abs_IGraph iG) \<and>
                   is_graph s iG g \<and>
                   is_dist s iG iD d \<and>
                   is_numm s iG iN n"])
  apply (simp add: skipE_def)
  apply wp
  unfolding is_graph_def is_dist_def is_numm_def no_path_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
           prefer 10
           apply wp
           apply fast
          prefer 9
          apply (rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
          apply (simp add: uint_nat word_less_def)
         prefer 6
  using le_step not_less
         apply blast
        prefer 6
        apply (metis (no_types, hide_lams) diff_diff_add eq_iff_diff_eq_0 measure_unat word_not_le)
       prefer 2
  using le_step not_less
       apply blast
      prefer 2
      apply (metis (no_types, hide_lams) diff_diff_add eq_iff_diff_eq_0 measure_unat word_not_le)
     prefer 2
     apply (rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
     apply (simp add:uint_nat word_less_def)
    prefer 3
    apply(rule_tac i="(uint vv)" in arrlist_nth_valid, simp+)
    apply (simp add:uint_nat word_less_def)
   prefer 2
   apply (simp add: uint_nat sint_ucast)
   apply (rule classical, erule notE, simp)

(*
   apply (subgoal_tac "sint (heap_w32 s (ptr_coerce (d +\<^sub>p int (unat vv)))) < 0")
    apply force
   apply (thin_tac "\<not> sint (heap_w32 s (ptr_coerce (d +\<^sub>p int (unat vv)))) < 0")

   apply (drule_tac i=vv in pedge_num_dist_heap_ptr_coerce[where l=d and iL=iD])
     apply simp+
   apply (drule_tac i=vv in pedge_num_dist_heap_ptr_coerce[where l=n and iL=iN])
     apply simp+
*)
(*
  apply (subst "sint_eq_uint")
  apply (rule not_msb_from_less)
  find_theorems(99) "sint _ = uint _"
  find_theorems "msb"
*)

  sorry

definition pos_cost_inv :: "IGraph \<Rightarrow> ICost \<Rightarrow> 32 word \<Rightarrow> bool" where
  "pos_cost_inv G c m \<equiv>  \<forall>e < m. c e \<ge> 0"

lemma pos_cost_spc':
  "\<lbrace> P and
     (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and>
          is_cost s iG iC c)\<rbrace>
   pos_cost' g c
   \<lbrace> (\<lambda>_ s. P s) And
     (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> pos_cost_inv iG iC (iedge_cnt iG)) \<rbrace>!"
  apply (clarsimp simp: pos_cost'_def)
  apply (subst whileLoop_add_inv [where
        M="\<lambda>(ee, s). unat (iedge_cnt iG - ee)" and
        I="\<lambda>ee s. P s \<and> pos_cost_inv iG iC ee \<and>
                   ee \<le> iedge_cnt iG \<and>
                   wf_digraph (abs_IGraph iG) \<and>
                   is_graph s iG g \<and>
                   is_cost s iG iC c"])
  apply wp
  unfolding is_graph_def is_cost_def pos_cost_inv_def
    apply (simp split: if_split_asm, safe, simp_all add: arrlist_nth)
  using le_step not_less
     apply blast
    apply (subgoal_tac "num_edges_C (heap_IGraph_C s g) - ee \<noteq> 0")
     apply simp
     apply (subgoal_tac "\<And>w wa. (w::32 word) - wa = 0 \<or> unat (w - 1 - wa) < unat (w - wa)")
      apply (subgoal_tac "unat (num_edges_C (heap_IGraph_C s g) - 1 - ee) < unat (num_edges_C (heap_IGraph_C s g) - ee)")
       apply (subgoal_tac "unat (num_edges_C (heap_IGraph_C s g) - (ee + 1)) < unat (num_edges_C (heap_IGraph_C s g) - ee)")
        apply (simp add: add.commute diff_diff_add)
       apply (simp add: diff_add_eq_diff_diff_swap)
      apply fastforce
     apply (metis (no_types) add.commute diff_diff_add measure_unat)
    apply simp
   apply (rule_tac i="(uint ee)" in arrlist_nth_valid, simp+)
   apply (simp add: uint_nat word_less_def)
  apply wp
  apply fast
  done

end

end


(*  Title:      HOL/Record.thy
    Author:     Wolfgang Naraschewski, TU Muenchen
    Author:     Markus Wenzel, TU Muenchen
    Author:     Norbert Schirmer, TU Muenchen
    Author:     Thomas Sewell, NICTA
    Author:     Florian Haftmann, TU Muenchen
*)

section {* Extensible records with structural subtyping *}

theory Record
imports Quickcheck_Exhaustive
keywords "record" :: thy_decl
begin

subsection {* Introduction *}

text {*
  Records are isomorphic to compound tuple types. To implement
  efficient records, we make this isomorphism explicit. Consider the
  record access/update simplification @{text "alpha (beta_update f
  rec) = alpha rec"} for distinct fields alpha and beta of some record
  rec with n fields. There are @{text "n ^ 2"} such theorems, which
  prohibits storage of all of them for large n. The rules can be
  proved on the fly by case decomposition and simplification in O(n)
  time. By creating O(n) isomorphic-tuple types while defining the
  record, however, we can prove the access/update simplification in
  @{text "O(log(n)^2)"} time.

  The O(n) cost of case decomposition is not because O(n) steps are
  taken, but rather because the resulting rule must contain O(n) new
  variables and an O(n) size concrete record construction. To sidestep
  this cost, we would like to avoid case decomposition in proving
  access/update theorems.

  Record types are defined as isomorphic to tuple types. For instance,
  a record type with fields @{text "'a"}, @{text "'b"}, @{text "'c"}
  and @{text "'d"} might be introduced as isomorphic to @{text "'a \<times>
  ('b \<times> ('c \<times> 'd))"}. If we balance the tuple tree to @{text "('a \<times>
  'b) \<times> ('c \<times> 'd)"} then accessors can be defined by converting to the
  underlying type then using O(log(n)) fst or snd operations.
  Updators can be defined similarly, if we introduce a @{text
  "fst_update"} and @{text "snd_update"} function. Furthermore, we can
  prove the access/update theorem in O(log(n)) steps by using simple
  rewrites on fst, snd, @{text "fst_update"} and @{text "snd_update"}.

  The catch is that, although O(log(n)) steps were taken, the
  underlying type we converted to is a tuple tree of size
  O(n). Processing this term type wastes performance. We avoid this
  for large n by taking each subtree of size K and defining a new type
  isomorphic to that tuple subtree. A record can now be defined as
  isomorphic to a tuple tree of these O(n/K) new types, or, if @{text
  "n > K*K"}, we can repeat the process, until the record can be
  defined in terms of a tuple tree of complexity less than the
  constant K.

  If we prove the access/update theorem on this type with the
  analogous steps to the tuple tree, we consume @{text "O(log(n)^2)"}
  time as the intermediate terms are @{text "O(log(n))"} in size and
  the types needed have size bounded by K.  To enable this analogous
  traversal, we define the functions seen below: @{text
  "iso_tuple_fst"}, @{text "iso_tuple_snd"}, @{text "iso_tuple_fst_update"}
  and @{text "iso_tuple_snd_update"}. These functions generalise tuple
  operations by taking a parameter that encapsulates a tuple
  isomorphism.  The rewrites needed on these functions now need an
  additional assumption which is that the isomorphism works.

  These rewrites are typically used in a structured way. They are here
  presented as the introduction rule @{text "isomorphic_tuple.intros"}
  rather than as a rewrite rule set. The introduction form is an
  optimisation, as net matching can be performed at one term location
  for each step rather than the simplifier searching the term for
  possible pattern matches. The rule set is used as it is viewed
  outside the locale, with the locale assumption (that the isomorphism
  is valid) left as a rule assumption. All rules are structured to aid
  net matching, using either a point-free form or an encapsulating
  predicate.
*}

subsection {* Operators and lemmas for types isomorphic to tuples *}

datatype (dead 'a, dead 'b, dead 'c) tuple_isomorphism =
  Tuple_Isomorphism "'a \<Rightarrow> 'b \<times> 'c" "'b \<times> 'c \<Rightarrow> 'a"

primrec
  repr :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" where
  "repr (Tuple_Isomorphism r a) = r"

primrec
  abst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a" where
  "abst (Tuple_Isomorphism r a) = a"

definition
  iso_tuple_fst :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'b" where
  "iso_tuple_fst isom = fst \<circ> repr isom"

definition
  iso_tuple_snd :: "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'a \<Rightarrow> 'c" where
  "iso_tuple_snd isom = snd \<circ> repr isom"

definition
  iso_tuple_fst_update ::
    "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "iso_tuple_fst_update isom f = abst isom \<circ> apfst f \<circ> repr isom"

definition
  iso_tuple_snd_update ::
    "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> ('c \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "iso_tuple_snd_update isom f = abst isom \<circ> apsnd f \<circ> repr isom"

definition
  iso_tuple_cons ::
    "('a, 'b, 'c) tuple_isomorphism \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a" where
  "iso_tuple_cons isom = curry (abst isom)"

subsection {* Logical infrastructure for records *}

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

definition
  iso_tuple_update_accessor_cong_assist ::
    "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "iso_tuple_update_accessor_cong_assist upd ac \<longleftrightarrow>
     (\<forall>f v. upd (\<lambda>x. f (ac v)) v = upd f v) \<and> (\<forall>v. upd id v = v)"

definition
  iso_tuple_update_accessor_eq_assist ::
    "(('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<longleftrightarrow>
     upd f v = v' \<and> ac v = x \<and> iso_tuple_update_accessor_cong_assist upd ac"

lemma update_accessor_congruence_foldE:
  assumes uac: "iso_tuple_update_accessor_cong_assist upd ac"
    and r: "r = r'" and v: "ac r' = v'"
    and f: "\<And>v. v' = v \<Longrightarrow> f v = f' v"
  shows "upd f r = upd f' r'"
  using uac r v [symmetric]
  apply (subgoal_tac "upd (\<lambda>x. f (ac r')) r' = upd (\<lambda>x. f' (ac r')) r'")
   apply (simp add: iso_tuple_update_accessor_cong_assist_def)
  apply (simp add: f)
  done

lemma update_accessor_congruence_unfoldE:
  "iso_tuple_update_accessor_cong_assist upd ac \<Longrightarrow>
    r = r' \<Longrightarrow> ac r' = v' \<Longrightarrow> (\<And>v. v = v' \<Longrightarrow> f v = f' v) \<Longrightarrow>
    upd f r = upd f' r'"
  apply (erule(2) update_accessor_congruence_foldE)
  apply simp
  done

lemma iso_tuple_update_accessor_cong_assist_id:
  "iso_tuple_update_accessor_cong_assist upd ac \<Longrightarrow> upd id = id"
  by rule (simp add: iso_tuple_update_accessor_cong_assist_def)

lemma update_accessor_noopE:
  assumes uac: "iso_tuple_update_accessor_cong_assist upd ac"
    and ac: "f (ac x) = ac x"
  shows "upd f x = x"
  using uac
  by (simp add: ac iso_tuple_update_accessor_cong_assist_id [OF uac, unfolded id_def]
    cong: update_accessor_congruence_unfoldE [OF uac])

lemma update_accessor_noop_compE:
  assumes uac: "iso_tuple_update_accessor_cong_assist upd ac"
    and ac: "f (ac x) = ac x"
  shows "upd (g \<circ> f) x = upd g x"
  by (simp add: ac cong: update_accessor_congruence_unfoldE[OF uac])

lemma update_accessor_cong_assist_idI:
  "iso_tuple_update_accessor_cong_assist id id"
  by (simp add: iso_tuple_update_accessor_cong_assist_def)

lemma update_accessor_cong_assist_triv:
  "iso_tuple_update_accessor_cong_assist upd ac \<Longrightarrow>
    iso_tuple_update_accessor_cong_assist upd ac"
  by assumption

lemma update_accessor_accessor_eqE:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow> ac v = x"
  by (simp add: iso_tuple_update_accessor_eq_assist_def)

lemma update_accessor_updator_eqE:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow> upd f v = v'"
  by (simp add: iso_tuple_update_accessor_eq_assist_def)

lemma iso_tuple_update_accessor_eq_assist_idI:
  "v' = f v \<Longrightarrow> iso_tuple_update_accessor_eq_assist id id v f v' v"
  by (simp add: iso_tuple_update_accessor_eq_assist_def update_accessor_cong_assist_idI)

lemma iso_tuple_update_accessor_eq_assist_triv:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow>
    iso_tuple_update_accessor_eq_assist upd ac v f v' x"
  by assumption

lemma iso_tuple_update_accessor_cong_from_eq:
  "iso_tuple_update_accessor_eq_assist upd ac v f v' x \<Longrightarrow>
    iso_tuple_update_accessor_cong_assist upd ac"
  by (simp add: iso_tuple_update_accessor_eq_assist_def)

lemma iso_tuple_surjective_proof_assistI:
  "f x = y \<Longrightarrow> iso_tuple_surjective_proof_assist x y f"
  by (simp add: iso_tuple_surjective_proof_assist_def)

lemma iso_tuple_surjective_proof_assist_idE:
  "iso_tuple_surjective_proof_assist x y id \<Longrightarrow> x = y"
  by (simp add: iso_tuple_surjective_proof_assist_def)

locale isomorphic_tuple =
  fixes isom :: "('a, 'b, 'c) tuple_isomorphism"
  assumes repr_inv: "\<And>x. abst isom (repr isom x) = x"
    and abst_inv: "\<And>y. repr isom (abst isom y) = y"
begin

lemma repr_inj: "repr isom x = repr isom y \<longleftrightarrow> x = y"
  by (auto dest: arg_cong [of "repr isom x" "repr isom y" "abst isom"]
    simp add: repr_inv)

lemma abst_inj: "abst isom x = abst isom y \<longleftrightarrow> x = y"
  by (auto dest: arg_cong [of "abst isom x" "abst isom y" "repr isom"]
    simp add: abst_inv)

lemmas simps = Let_def repr_inv abst_inv repr_inj abst_inj

lemma iso_tuple_access_update_fst_fst:
  "f o h g = j o f \<Longrightarrow>
    (f o iso_tuple_fst isom) o (iso_tuple_fst_update isom o h) g =
      j o (f o iso_tuple_fst isom)"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_fst_def simps
    fun_eq_iff)

lemma iso_tuple_access_update_snd_snd:
  "f o h g = j o f \<Longrightarrow>
    (f o iso_tuple_snd isom) o (iso_tuple_snd_update isom o h) g =
      j o (f o iso_tuple_snd isom)"
  by (clarsimp simp: iso_tuple_snd_update_def iso_tuple_snd_def simps
    fun_eq_iff)

lemma iso_tuple_access_update_fst_snd:
  "(f o iso_tuple_fst isom) o (iso_tuple_snd_update isom o h) g =
    id o (f o iso_tuple_fst isom)"
  by (clarsimp simp: iso_tuple_snd_update_def iso_tuple_fst_def simps
    fun_eq_iff)

lemma iso_tuple_access_update_snd_fst:
  "(f o iso_tuple_snd isom) o (iso_tuple_fst_update isom o h) g =
    id o (f o iso_tuple_snd isom)"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_def simps
    fun_eq_iff)

lemma iso_tuple_update_swap_fst_fst:
  "h f o j g = j g o h f \<Longrightarrow>
    (iso_tuple_fst_update isom o h) f o (iso_tuple_fst_update isom o j) g =
      (iso_tuple_fst_update isom o j) g o (iso_tuple_fst_update isom o h) f"
  by (clarsimp simp: iso_tuple_fst_update_def simps apfst_compose fun_eq_iff)

lemma iso_tuple_update_swap_snd_snd:
  "h f o j g = j g o h f \<Longrightarrow>
    (iso_tuple_snd_update isom o h) f o (iso_tuple_snd_update isom o j) g =
      (iso_tuple_snd_update isom o j) g o (iso_tuple_snd_update isom o h) f"
  by (clarsimp simp: iso_tuple_snd_update_def simps apsnd_compose fun_eq_iff)

lemma iso_tuple_update_swap_fst_snd:
  "(iso_tuple_snd_update isom o h) f o (iso_tuple_fst_update isom o j) g =
    (iso_tuple_fst_update isom o j) g o (iso_tuple_snd_update isom o h) f"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def
    simps fun_eq_iff)

lemma iso_tuple_update_swap_snd_fst:
  "(iso_tuple_fst_update isom o h) f o (iso_tuple_snd_update isom o j) g =
    (iso_tuple_snd_update isom o j) g o (iso_tuple_fst_update isom o h) f"
  by (clarsimp simp: iso_tuple_fst_update_def iso_tuple_snd_update_def simps
    fun_eq_iff)

lemma iso_tuple_update_compose_fst_fst:
  "h f o j g = k (f o g) \<Longrightarrow>
    (iso_tuple_fst_update isom o h) f o (iso_tuple_fst_update isom o j) g =
      (iso_tuple_fst_update isom o k) (f o g)"
  by (clarsimp simp: iso_tuple_fst_update_def simps apfst_compose fun_eq_iff)

lemma iso_tuple_update_compose_snd_snd:
  "h f o j g = k (f o g) \<Longrightarrow>
    (iso_tuple_snd_update isom o h) f o (iso_tuple_snd_update isom o j) g =
      (iso_tuple_snd_update isom o k) (f o g)"
  by (clarsimp simp: iso_tuple_snd_update_def simps apsnd_compose fun_eq_iff)

lemma iso_tuple_surjective_proof_assist_step:
  "iso_tuple_surjective_proof_assist v a (iso_tuple_fst isom o f) \<Longrightarrow>
    iso_tuple_surjective_proof_assist v b (iso_tuple_snd isom o f) \<Longrightarrow>
    iso_tuple_surjective_proof_assist v (iso_tuple_cons isom a b) f"
  by (clarsimp simp: iso_tuple_surjective_proof_assist_def simps
    iso_tuple_fst_def iso_tuple_snd_def iso_tuple_cons_def)

lemma iso_tuple_fst_update_accessor_cong_assist:
  assumes "iso_tuple_update_accessor_cong_assist f g"
  shows "iso_tuple_update_accessor_cong_assist
    (iso_tuple_fst_update isom o f) (g o iso_tuple_fst isom)"
proof -
  from assms have "f id = id"
    by (rule iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
      iso_tuple_fst_update_def iso_tuple_fst_def)
qed

lemma iso_tuple_snd_update_accessor_cong_assist:
  assumes "iso_tuple_update_accessor_cong_assist f g"
  shows "iso_tuple_update_accessor_cong_assist
    (iso_tuple_snd_update isom o f) (g o iso_tuple_snd isom)"
proof -
  from assms have "f id = id"
    by (rule iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_cong_assist_def simps
      iso_tuple_snd_update_def iso_tuple_snd_def)
qed

lemma iso_tuple_fst_update_accessor_eq_assist:
  assumes "iso_tuple_update_accessor_eq_assist f g a u a' v"
  shows "iso_tuple_update_accessor_eq_assist
    (iso_tuple_fst_update isom o f) (g o iso_tuple_fst isom)
    (iso_tuple_cons isom a b) u (iso_tuple_cons isom a' b) v"
proof -
  from assms have "f id = id"
    by (auto simp add: iso_tuple_update_accessor_eq_assist_def
      intro: iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
      iso_tuple_fst_update_def iso_tuple_fst_def
      iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
qed

lemma iso_tuple_snd_update_accessor_eq_assist:
  assumes "iso_tuple_update_accessor_eq_assist f g b u b' v"
  shows "iso_tuple_update_accessor_eq_assist
    (iso_tuple_snd_update isom o f) (g o iso_tuple_snd isom)
    (iso_tuple_cons isom a b) u (iso_tuple_cons isom a b') v"
proof -
  from assms have "f id = id"
    by (auto simp add: iso_tuple_update_accessor_eq_assist_def
      intro: iso_tuple_update_accessor_cong_assist_id)
  with assms show ?thesis
    by (clarsimp simp: iso_tuple_update_accessor_eq_assist_def
      iso_tuple_snd_update_def iso_tuple_snd_def
      iso_tuple_update_accessor_cong_assist_def iso_tuple_cons_def simps)
qed

lemma iso_tuple_cons_conj_eqI:
  "a = c \<and> b = d \<and> P \<longleftrightarrow> Q \<Longrightarrow>
    iso_tuple_cons isom a b = iso_tuple_cons isom c d \<and> P \<longleftrightarrow> Q"
  by (clarsimp simp: iso_tuple_cons_def simps)

lemmas intros =
  iso_tuple_access_update_fst_fst
  iso_tuple_access_update_snd_snd
  iso_tuple_access_update_fst_snd
  iso_tuple_access_update_snd_fst
  iso_tuple_update_swap_fst_fst
  iso_tuple_update_swap_snd_snd
  iso_tuple_update_swap_fst_snd
  iso_tuple_update_swap_snd_fst
  iso_tuple_update_compose_fst_fst
  iso_tuple_update_compose_snd_snd
  iso_tuple_surjective_proof_assist_step
  iso_tuple_fst_update_accessor_eq_assist
  iso_tuple_snd_update_accessor_eq_assist
  iso_tuple_fst_update_accessor_cong_assist
  iso_tuple_snd_update_accessor_cong_assist
  iso_tuple_cons_conj_eqI

end

lemma isomorphic_tuple_intro:
  fixes repr abst
  assumes repr_inj: "\<And>x y. repr x = repr y \<longleftrightarrow> x = y"
    and abst_inv: "\<And>z. repr (abst z) = z"
    and v: "v \<equiv> Tuple_Isomorphism repr abst"
  shows "isomorphic_tuple v"
proof
  fix x have "repr (abst (repr x)) = repr x"
    by (simp add: abst_inv)
  then show "Record.abst v (Record.repr v x) = x"
    by (simp add: v repr_inj)
next
  fix y
  show "Record.repr v (Record.abst v y) = y"
    by (simp add: v) (fact abst_inv)
qed

definition
  "tuple_iso_tuple \<equiv> Tuple_Isomorphism id id"

lemma tuple_iso_tuple:
  "isomorphic_tuple tuple_iso_tuple"
  by (simp add: isomorphic_tuple_intro [OF _ _ reflexive] tuple_iso_tuple_def)

lemma refl_conj_eq: "Q = R \<Longrightarrow> P \<and> Q \<longleftrightarrow> P \<and> R"
  by simp

lemma iso_tuple_UNIV_I: "x \<in> UNIV \<equiv> True"
  by simp

lemma iso_tuple_True_simp: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
  by simp

lemma prop_subst: "s = t \<Longrightarrow> PROP P t \<Longrightarrow> PROP P s"
  by simp

lemma K_record_comp: "(\<lambda>x. c) \<circ> f = (\<lambda>x. c)"
  by (simp add: comp_def)

subsection {* Concrete record syntax *}

nonterminal
  ident and
  field_type and
  field_types and
  field and
  fields and
  field_update and
  field_updates

syntax
  "_constify"           :: "id => ident"                        ("_")
  "_constify"           :: "longid => ident"                    ("_")

  "_field_type"         :: "ident => type => field_type"        ("(2_ ::/ _)")
  ""                    :: "field_type => field_types"          ("_")
  "_field_types"        :: "field_type => field_types => field_types"    ("_,/ _")
  "_record_type"        :: "field_types => type"                ("(3'(| _ |'))")
  "_record_type_scheme" :: "field_types => type => type"        ("(3'(| _,/ (2... ::/ _) |'))")

  "_field"              :: "ident => 'a => field"               ("(2_ =/ _)")
  ""                    :: "field => fields"                    ("_")
  "_fields"             :: "field => fields => fields"          ("_,/ _")
  "_record"             :: "fields => 'a"                       ("(3'(| _ |'))")
  "_record_scheme"      :: "fields => 'a => 'a"                 ("(3'(| _,/ (2... =/ _) |'))")

  "_field_update"       :: "ident => 'a => field_update"        ("(2_ :=/ _)")
  ""                    :: "field_update => field_updates"      ("_")
  "_field_updates"      :: "field_update => field_updates => field_updates"  ("_,/ _")
  "_record_update"      :: "'a => field_updates => 'b"          ("_/(3'(| _ |'))" [900, 0] 900)

syntax (xsymbols)
  "_record_type"        :: "field_types => type"                ("(3\<lparr>_\<rparr>)")
  "_record_type_scheme" :: "field_types => type => type"        ("(3\<lparr>_,/ (2\<dots> ::/ _)\<rparr>)")
  "_record"             :: "fields => 'a"                       ("(3\<lparr>_\<rparr>)")
  "_record_scheme"      :: "fields => 'a => 'a"                 ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")
  "_record_update"      :: "'a => field_updates => 'b"          ("_/(3\<lparr>_\<rparr>)" [900, 0] 900)

subsection {* Record package *}

ML_file "Tools/record.ML"

hide_const (open) Tuple_Isomorphism repr abst iso_tuple_fst iso_tuple_snd
  iso_tuple_fst_update iso_tuple_snd_update iso_tuple_cons
  iso_tuple_surjective_proof_assist iso_tuple_update_accessor_cong_assist
  iso_tuple_update_accessor_eq_assist tuple_iso_tuple

end