Theory SetMark


section ‹Marking Using a Set›

theory SetMark
imports Graph DataRefinementIBP.DataRefinement
begin

text‹
We construct in this theory a diagram which computes all reachable nodes
from a given root node in a graph. The graph is defined in the theory
Graph and is given by a relation $next$ on the nodes of the graph.

The diagram has only three ordered situation 
($\mathit{init} > \mathit{loop} > \mathit{final}$). The termination
variant is a pair of a situation and a natural number with the lexicographic
ordering. The idea of this ordering is that we can go from a bigger situation
to a smaller one, however if we stay in the same situation the second
component of the variant must decrease.

The idea of the algorithm is that it starts with a set $X$ containing the
root element and the root is marked. As long as $X$ is not empty, if $x\in X$ 
and $y$ is an unmarked sucessor of $x$ we add $y$ to $X$. If $x\in X$ has
no unmarked sucessors it is removed from $X$. 
The algorithm terminates when $X$ is empty.  
›

datatype I = init | loop | final

declare I.split [split]


instantiation I :: well_founded_transitive
begin

definition
  less_I_def: "i < j ≡  (j = init ∧ (i = loop ∨ i = final)) ∨ (j = loop ∧ i = final)"

definition
  less_eq_I_def:  "(i::I) ≤ (j::I) ≡ i = j ∨ i < j"

instance
proof
  fix x y z :: I
  assume "x < y" and "y < z" then  show  "x < z"
    apply (simp add: less_I_def)
    by auto
next
  fix x y :: I
  show  "x ≤ y ⟷ x = y ∨ x < y"
    by (simp add: less_eq_I_def)
next
  fix P fix a::I
  show "P a" when "∀x. (∀ y. y < x ⟶ P y) ⟶ P x"
    apply (insert that)
    apply (case_tac "P final")
    apply (case_tac "P loop")
    apply (simp_all add: less_I_def)
    by blast
qed (simp)

end


text‹
The set $\mathit{path}\ S \ \mathit{mrk}$ contains all reachable nodes from S along paths with
unmarked nodes.
›

lemma trascl_less: "x ≠ y ⟹ (a, x) ∈ R* ⟹ 
    ((a,x) ∈ (R ∩ (-{y})×(-{y}))* ∨  (y,x) ∈ R O (R ∩ (-{y})×(-{y}))* )"
  apply (drule_tac 
    b = x and a = a and r = R and 
    P = "λ x. (x ≠ y ⟶((a,x) ∈ (R ∩ (-{y})×(-{y}))* ∨ (y,x) ∈ R O (R ∩ (-{y})×(-{y}))* ))"
    in rtrancl_induct)
  apply (auto simp: Compl_insert)
  apply (case_tac "ya = y")
  apply auto
  apply (rule_tac x = a and y = ya and z = z and r = "R ∩ ((UNIV - {y}) × (UNIV - {y}))" in rtrancl_trans)
  apply auto
  apply (case_tac "za = y")
  apply auto
  apply (drule_tac x = ya and y = za and z = z and r = "(R ∩ (UNIV - {y}) × (UNIV - {y}))" in rtrancl_trans)
  by auto

lemma (in graph) add_set [simp]: "x ≠ y ⟹ x ∈ path S mrk ⟹ x ∈ path (insert y S) (insert y mrk)"
  apply (simp add: path_def)
  apply clarify
  apply (drule_tac x = x and y = y and a = ya and R = "next ∩ (- mrk) × (- mrk)" in trascl_less)
  apply simp_all
  apply (case_tac "(ya, x) ∈ (next ∩ (- mrk) × - mrk ∩ (- {y}) × - {y})*")
  apply (rule_tac x = xa in exI)
  apply simp_all
  apply (simp add: relcomp_unfold)
  apply (rule_tac x = ya in exI)
  apply simp
  apply (case_tac "(next ∩ (- mrk) × - mrk ∩ (- {y}) × - {y}) = (next ∩ (- insert y mrk) × - insert y mrk)")
  apply simp_all
  apply safe
  apply simp_all
  apply (rule_tac x = y in exI)
  apply simp  
  apply (simp add: relcomp_unfold)
  apply (rule_tac x = yaa in exI)
  apply simp
  apply (case_tac "(next ∩ (- mrk) × - mrk ∩ (- {y}) × - {y}) = (next ∩ (- insert y mrk) × - insert y mrk)")
  apply simp_all
  by auto

lemma (in graph) add_set2: "x ∈ path S mrk ⟹ x ∉ path (insert y S) (insert y mrk) ⟹ x = y"
  apply (case_tac "x ≠ y")
  apply (frule add_set)
  by simp_all

lemma (in graph) del_stack [simp]: "(∀ y . (t, y) ∈ next ⟶ y ∈ mrk) ⟹ x ∉  mrk ⟹ x ∈ path S mrk ⟹ x ∈ path (S - {t}) mrk"
  apply (simp add: path_def)
  apply clarify
  apply (rule_tac x = xa in exI)
  apply (case_tac "x = y")
  apply auto
  apply (drule_tac a = y and b = x and R = "(next ∩ (- mrk) × - mrk)" in rtranclD)
  apply safe
  apply (drule_tac x = y and y = x in tranclD)
  by auto

lemma (in graph) init_set [simp]: "x ∈ reach root ⟹ x ≠ root ⟹ x ∈ path {root} {root}"
  apply (simp add: reach_def path_def)
  apply (case_tac "root ≠ x")
  apply (drule_tac a = root and x = x and y = root and R = "next" in trascl_less)
  apply (simp_all add: Compl_insert)
  apply safe
  apply (drule_tac a = root and b = x and R = "(next ∩ (UNIV - {root}) × (UNIV - {root}))" in rtranclD)
  apply safe
  apply (drule_tac x = root and y = x in tranclD)
  by auto

lemma (in graph)  init_set2: "x ∈ reach root ⟹ x ∉ path {root} {root} ⟹ x = root"
  apply (case_tac "root ≠ x")
  apply (drule init_set)
  by simp_all

subsection ‹Transitions›

definition (in graph)
  "Q1_a ≡ [: X, mrk ↝ X', mrk'. (root::'node) = nil ∧ X' = {} ∧ mrk' = mrk :]"

definition (in graph)
  "Q2_a ≡ [: X, mrk ↝ X', mrk' . 
       (root::'node) ≠ nil ∧ X' = {root::'node} ∧ mrk' = {root::'node} :]"

definition (in graph)
  "Q3_a ≡ [: X, mrk ↝ X', mrk' . 
        (∃ x ∈ X . ∃ y . (x, y) ∈ next ∧ y ∉ mrk ∧ X' = X ∪ {y} ∧ mrk' = mrk ∪ {y}):]"

definition (in graph)
  "Q4_a ≡ [: X, mrk ↝ X', mrk' .  
        (∃ x ∈ X . (∀ y . (x, y) ∈ next ⟶ y ∈ mrk) ∧ X' = X - {x} ∧ mrk' = mrk):]"

definition (in graph)
  "Q5_a ≡ [: X, mrk ↝ X', mrk' . X = {} ∧ mrk = mrk' :]"

subsection ‹Invariants›

definition (in graph) 
  "Loop ≡ { (X, mrk) .
      finite (-mrk) ∧ finite X ∧ X ⊆ mrk ∧ 
      mrk ⊆ reach root ∧ reach root ∩ -mrk ⊆ path X mrk}"

definition
  "trm ≡ λ (X, mrk) . 2 * card (-mrk) + card X"

definition
  "term_eq t w = {s . t s = w}"
  
definition
  "term_less t w = {s . t s < w}"

lemma union_term_eq [simp]:  "(⋃ w . term_eq t w) = UNIV"
  apply (simp add: term_eq_def)
  by auto

lemma union_less_term_eq [simp]: "(⋃v∈{v. v < w}. term_eq t v) = term_less t w"
  apply (simp add: term_eq_def term_less_def)
  by auto

definition (in graph) 
  "Init ≡ { (X::('node set), mrk::('node set)) . finite (-mrk) ∧ mrk = {}}"

definition (in graph) 
  "Final ≡ { (X::('node set), mrk::('node set)) . mrk = reach root}"

definition (in graph) 
  "SetMarkInv i = (case i of
      I.init  ⇒ Init |
      I.loop  ⇒ Loop |
      I.final ⇒ Final)"

definition (in graph) 
  "SetMarkInvFinal i = (case i of
      I.final  ⇒ Final |
      _  ⇒ {})"

definition  (in graph) [simp]:
  "SetMarkInvTerm w i = (case i of
      I.init  ⇒ Init |
      I.loop  ⇒ Loop ∩ {s . trm s = w} |
      I.final ⇒ Final)"

subsection ‹Diagram›

definition (in graph) 
  "SetMark ≡ λ (i, j) . (case (i, j) of
      (I.init, I.loop)  ⇒ Q1_a ⊓ Q2_a |
      (I.loop, I.loop)  ⇒ Q3_a ⊓ Q4_a |
      (I.loop, I.final) ⇒ Q5_a |
       _ ⇒ top)"

lemma (in graph)  SetMark_dmono [simp]:
  "dmono SetMark"
  apply (unfold dmono_def SetMark_def Q1_a_def Q2_a_def Q3_a_def Q4_a_def Q5_a_def)
  by simp

subsection ‹Correctness of the transitions›


lemma  (in graph) init_loop_1_a[simp]: "⊨ Init {| Q1_a |} Loop"
  apply (unfold hoare_demonic Init_def Q1_a_def Loop_def)
  by auto

lemma  (in graph) init_loop_2_a[simp]: "⊨ Init {| Q2_a |} Loop"
  apply (simp add: hoare_demonic Init_def Q2_a_def Loop_def)
  apply auto
  apply (simp_all add: reach_def)
  apply (rule init_set2)
  by (simp_all add: reach_def)

lemma  (in graph) loop_loop_1_a [simp]: "⊨ (Loop ∩  {s . trm s = w}) {| Q3_a |} (Loop ∩ {s. trm s < w})"
  apply (simp add: hoare_demonic Q3_a_def Loop_def trm_def)
  apply safe
  apply (simp_all)
  apply (simp_all add: reach_def subset_eq)
  apply safe
  apply (simp_all add: Compl_insert)
  apply (rule rtrancl_into_rtrancl)
  apply (simp_all add: Int_def)
  apply (rule add_set2)
  apply simp_all
  apply (case_tac "card (-b) > 0")
  by auto

 lemma  (in graph) loop_loop_2_a[simp]: "⊨ (Loop ∩  {s . trm s = w}) {| Q4_a |} (Loop ∩ {s. trm s < w})"
  apply (simp add: hoare_demonic Q4_a_def Loop_def trm_def)
  apply auto
  apply (case_tac "card a > 0")
  by auto

 lemma  (in graph) loop_final_a [simp]: "⊨ (Loop ∩ {s . trm s = w}) {| Q5_a |} Final"
  apply (simp add: hoare_demonic Q5_a_def Loop_def Final_def subset_eq Int_def path_def)
  by auto

lemma union_term_w[simp]:  "(⋃w. {s. t s = w}) = UNIV"
  by auto

lemma union_less_term_w[simp]: "(⋃v∈{v. v < w}. {s. t s = v}) = {s . t s < w}"
  by auto

lemma sup_union[simp]: "Sup (range A) i =  (⋃ w . A w i)"
  by (simp_all add: Sup_fun_def)

lemma forall_simp [simp]: "(∀a b. ∀x∈A. (a = (t x)) ⟶ (h x) ∨ b ≠ u x) = (∀x∈ A . h x)"
  by auto

lemma forall_simp2 [simp]: "(∀a b. ∀x∈A. ∀y. (a  = t x y) ⟶ (h x y) ⟶ (g x y) ∨ b ≠ u x y) = (∀x∈A. ∀y. h x y ⟶ g x y)"
  by auto

subsection ‹Diagram correctness›

text‹
The termination ordering for the $\mathit{SetMark}$ diagram is the lexicographic
ordering on pairs $(i,\, n)$ where $i\in I$ and $n\in \mathit{nat}$.
›

interpretation  DiagramTermination "λ (n::nat) (i :: I) . (i, n)"
  done

theorem (in graph) SetMark_correct:
  "⊨ SetMarkInv {|pt SetMark|} SetMarkInvFinal"
proof (rule_tac X = "SetMarkInvTerm" in hoare_diagram3)
  show "dmono SetMark" by simp
  show "∀u i j. ⊨ SetMarkInvTerm u i{| SetMark (i, j) |}
    DiagramTermination.SUP_L_P (λn i. (i, n)) SetMarkInvTerm (i, u) j"
    by (auto simp add: SUP_L_P_def  less_pair_def less_I_def hoare_choice SetMark_def)
  show "SetMarkInv ≤ Sup (range SetMarkInvTerm)"
    apply (simp add: le_fun_def, safe)
    apply (simp_all add: SetMarkInv_def)
    apply (case_tac x)
    apply auto
    done
  show "Sup (range SetMarkInvTerm) ⊓ - grd (step SetMark) ≤ SetMarkInvFinal"
    apply (simp add: le_fun_def inf_fun_def SetMarkInvFinal_def)
    apply safe
    apply simp_all
    apply (drule_tac x="I.loop" in spec)
    apply (simp add: SetMark_def)
    apply (simp add: Q1_a_def Q2_a_def)
    apply (frule_tac x="I.loop" in spec)
    apply (drule_tac x="I.final" in spec)
    apply (simp add: SetMark_def)
    apply (simp add: Q3_a_def Q4_a_def Q5_a_def)
    apply (auto)
    done
qed

theorem (in graph) SetMark_correct1 [simp]:
  "Hoare_dgr SetMarkInv SetMark (SetMarkInv ⊓ (- grd (step SetMark)))"
  apply (simp add: Hoare_dgr_def)
  apply (rule_tac x = SetMarkInvTerm in exI)
  apply (subgoal_tac "SetMarkInv = ⨆range SetMarkInvTerm")
  apply simp
  apply safe
  apply (simp_all add: SetMark_def SUP_L_P_def
       less_pair_def less_I_def hoare_choice)
  apply (simp_all add: fun_eq_iff)
  apply safe
  apply (unfold SetMarkInv_def)
  by auto

theorem (in graph) stack_not_nil [simp]:
  "(mrk, S) ∈ Loop ⟹ x ∈ S ⟹ x ≠ nil"
  apply (simp add: Loop_def reach_def)
  by auto

end