section \<open>Implementation of Heaps with Arrays\<close>
theory IICF_Impl_Heap
imports
  IICF_Abs_Heap
  "../IICF_HOL_List"
  "../IICF_Array_List"
  "HOL-Library.Rewrite"
begin
  text \<open>We implement the heap data structure by an array.
    The implementation is automatically synthesized by the Sepref-tool.
    \<close>
  subsection \<open>Setup of the Sepref-Tool\<close>

  context
    fixes prio :: "'a::{heap,default} \<Rightarrow> 'b::linorder"
  begin
    interpretation heapstruct prio .
    definition "heap_rel A \<equiv> hr_comp (hr_comp (arl_assn id_assn) heap_rel1) (\<langle>the_pure A\<rangle>mset_rel)"
  end

  locale heapstruct_impl =
    fixes prio :: "'a::{heap,default} \<Rightarrow> 'b::linorder"
  begin
    sublocale heapstruct prio .

(*  locale heap_impl = heapstruct prio for prio :: "'a::heap \<Rightarrow> 'b::linorder"
  begin*)

    abbreviation "rel \<equiv> arl_assn id_assn"

    sepref_register prio
    lemma [sepref_import_param]: "(prio,prio) \<in> Id \<rightarrow> Id" by simp

    lemma [sepref_import_param]:
      "((\<le>), (\<le>)::'b \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> bool_rel"
      "((<), (<)::'b \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> bool_rel"
      by simp_all

    sepref_register
      update_op
      val_of_op
      "PR_CONST prio_of_op"
      exch_op
      valid
      "length::'a list \<Rightarrow> _"
      append_op
      butlast_op

      "PR_CONST sink_op"
      "PR_CONST swim_op"
      "PR_CONST repair_op"

  end

  context
    fixes prio :: "'a::{heap,default} \<Rightarrow> 'b::linorder"
  begin

    interpretation heapstruct_impl prio .

subsection \<open>Synthesis of operations\<close>
  text \<open>Note that we have to repeat some boilerplate per operation.
    It is future work to add more automation here.\<close>

  sepref_definition update_impl is "uncurry2 update_op" :: "rel\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a rel"
    unfolding update_op_def[abs_def]
    by sepref
  lemmas [sepref_fr_rules] = update_impl.refine

  sepref_definition val_of_impl is "uncurry val_of_op" :: "rel\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
    unfolding val_of_op_def[abs_def]
    by sepref
  lemmas [sepref_fr_rules] = val_of_impl.refine

  sepref_definition exch_impl is "uncurry2 exch_op" :: "rel\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a rel"
    unfolding exch_op_def[abs_def]
    by sepref
  lemmas [sepref_fr_rules] = exch_impl.refine

  sepref_definition valid_impl is "uncurry (RETURN oo valid)" :: "rel\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding valid_def[abs_def]
    by sepref
  lemmas [sepref_fr_rules] = valid_impl.refine

  sepref_definition prio_of_impl is "uncurry (PR_CONST prio_of_op)" :: "rel\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
    unfolding prio_of_op_def[abs_def] PR_CONST_def
    by sepref
  lemmas [sepref_fr_rules] = prio_of_impl.refine

  sepref_definition swim_impl is "uncurry (PR_CONST swim_op)" :: "rel\<^sup>d *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a rel"
    unfolding swim_op_def[abs_def] parent_def PR_CONST_def
    by sepref

  lemmas [sepref_fr_rules] = swim_impl.refine

  sepref_definition sink_impl is "uncurry (PR_CONST sink_op)" :: "rel\<^sup>d *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a rel"
    unfolding sink_op_opt_def[abs_def] sink_op_opt_eq[symmetric,abs_def]  PR_CONST_def
    by sepref
  lemmas [sepref_fr_rules] = sink_impl.refine

  lemmas [fcomp_norm_unfold] = heap_rel_def[symmetric]

  sepref_definition empty_impl is "uncurry0 empty_op" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a rel"
    unfolding empty_op_def arl.fold_custom_empty
    by sepref

  sepref_decl_impl (no_register) heap_empty: empty_impl.refine[FCOMP empty_op_refine] .

  sepref_definition is_empty_impl is "is_empty_op" :: "rel\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding is_empty_op_def[abs_def]
    by sepref

  sepref_decl_impl heap_is_empty: is_empty_impl.refine[FCOMP is_empty_op_refine] .

  sepref_definition insert_impl is "uncurry insert_op" :: "id_assn\<^sup>k *\<^sub>a rel\<^sup>d \<rightarrow>\<^sub>a rel"
    unfolding insert_op_def[abs_def] append_op_def
    by sepref
  sepref_decl_impl heap_insert: insert_impl.refine[FCOMP insert_op_refine] .

  sepref_definition pop_min_impl is "pop_min_op" :: "rel\<^sup>d \<rightarrow>\<^sub>a prod_assn id_assn rel"
    unfolding pop_min_op_def[abs_def] butlast_op_def
    by sepref

  sepref_decl_impl (no_mop) heap_pop_min: pop_min_impl.refine[FCOMP pop_min_op_refine] .

  sepref_definition peek_min_impl is "peek_min_op" :: "rel\<^sup>k \<rightarrow>\<^sub>a id_assn"
    unfolding peek_min_op_def[abs_def]
    by sepref
  sepref_decl_impl (no_mop) heap_peek_min: peek_min_impl.refine[FCOMP peek_min_op_refine] .

end

definition [simp]: "heap_custom_empty \<equiv> op_mset_empty"
interpretation heap: mset_custom_empty
  "heap_rel prio A" empty_impl heap_custom_empty for prio A
  apply unfold_locales
  apply (rule heap_empty_hnr)
  by simp

subsection \<open>Regression Test\<close>
export_code empty_impl is_empty_impl insert_impl pop_min_impl peek_min_impl checking SML

definition "sort_by_prio prio l \<equiv> do {
  q \<leftarrow> nfoldli l (\<lambda>_. True) (\<lambda>x q. mop_mset_insert x q) heap_custom_empty;
  (l,q) \<leftarrow> WHILET (\<lambda>(l,q). \<not>op_mset_is_empty q) (\<lambda>(l,q). do {
    (x,q) \<leftarrow> mop_prio_pop_min prio q;
    RETURN (l@[x],q)
  }) (op_arl_empty,q);
  RETURN l
}"

context fixes prio:: "'a::{default,heap} \<Rightarrow> 'b::linorder" begin
sepref_definition sort_impl is
  "sort_by_prio prio" :: "(list_assn (id_assn::'a::{default,heap} \<Rightarrow> _))\<^sup>k \<rightarrow>\<^sub>a arl_assn id_assn"
  unfolding sort_by_prio_def[abs_def]
  by sepref
end
definition "sort_impl_nat \<equiv> sort_impl (id::nat\<Rightarrow>nat) "

export_code sort_impl checking SML

ML \<open>
  @{code sort_impl_nat} (map @{code nat_of_integer} [4,1,7,2,3,9,8,62]) ()
\<close>

hide_const sort_impl sort_impl_nat
hide_fact sort_impl_def sort_impl_nat_def sort_impl.refine

end


(*  Title:      Sequents/S43.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge

This implements Rajeev Gore's sequent calculus for S43.
*)

theory S43
imports Modal0
begin

consts
  S43pi :: "[seq'=>seq', seq'=>seq', seq'=>seq',
             seq'=>seq', seq'=>seq', seq'=>seq'] => prop"
syntax
  "_S43pi" :: "[seq, seq, seq, seq, seq, seq] => prop"
                         ("S43pi((_);(_);(_);(_);(_);(_))" [] 5)

parse_translation {*
  let
    val tr  = seq_tr;
    fun s43pi_tr [s1, s2, s3, s4, s5, s6] =
      Const (@{const_syntax S43pi}, dummyT) $ tr s1 $ tr s2 $ tr s3 $ tr s4 $ tr s5 $ tr s6;
  in [(@{syntax_const "_S43pi"}, K s43pi_tr)] end
*}

print_translation {*
let
  val tr' = seq_tr';
  fun s43pi_tr' [s1, s2, s3, s4, s5, s6] =
    Const(@{syntax_const "_S43pi"}, dummyT) $ tr' s1 $ tr' s2 $ tr' s3 $ tr' s4 $ tr' s5 $ tr' s6;
in [(@{const_syntax S43pi}, K s43pi_tr')] end
*}

axiomatization where
(* Definition of the star operation using a set of Horn clauses  *)
(* For system S43: gamma * == {[]P | []P : gamma}                *)
(*                 delta * == {<>P | <>P : delta}                *)

  lstar0:         "|L>" and
  lstar1:         "$G |L> $H ==> []P, $G |L> []P, $H" and
  lstar2:         "$G |L> $H ==>   P, $G |L>      $H" and
  rstar0:         "|R>" and
  rstar1:         "$G |R> $H ==> <>P, $G |R> <>P, $H" and
  rstar2:         "$G |R> $H ==>   P, $G |R>      $H" and

(* Set of Horn clauses to generate the antecedents for the S43 pi rule       *)
(* ie                                                                        *)
(*           S1...Sk,Sk+1...Sk+m                                             *)
(*     ----------------------------------                                    *)
(*     <>P1...<>Pk, $G |- $H, []Q1...[]Qm                                    *)
(*                                                                           *)
(*  where Si == <>P1...<>Pi-1,<>Pi+1,..<>Pk,Pi, $G * |- $H *, []Q1...[]Qm    *)
(*    and Sj == <>P1...<>Pk, $G * |- $H *, []Q1...[]Qj-1,[]Qj+1...[]Qm,Qj    *)
(*    and 1<=i<=k and k<j<=k+m                                               *)

  S43pi0:         "S43pi $L;; $R;; $Lbox; $Rdia" and
  S43pi1:
   "[| (S43pi <>P,$L';     $L;; $R; $Lbox;$Rdia);   $L',P,$L,$Lbox |- $R,$Rdia |] ==>
       S43pi     $L'; <>P,$L;; $R; $Lbox;$Rdia" and
  S43pi2:
   "[| (S43pi $L';; []P,$R';     $R; $Lbox;$Rdia);  $L',$Lbox |- $R',P,$R,$Rdia |] ==>
       S43pi $L';;     $R'; []P,$R; $Lbox;$Rdia" and

(* Rules for [] and <> for S43 *)

  boxL:           "$E, P, $F, []P |- $G ==> $E, []P, $F |- $G" and
  diaR:           "$E |- $F, P, $G, <>P ==> $E |- $F, <>P, $G" and
  pi1:
   "[| $L1,<>P,$L2 |L> $Lbox;  $L1,<>P,$L2 |R> $Ldia;  $R |L> $Rbox;  $R |R> $Rdia;
      S43pi ; $Ldia;; $Rbox; $Lbox; $Rdia |] ==>
   $L1, <>P, $L2 |- $R" and
  pi2:
   "[| $L |L> $Lbox;  $L |R> $Ldia;  $R1,[]P,$R2 |L> $Rbox;  $R1,[]P,$R2 |R> $Rdia;
      S43pi ; $Ldia;; $Rbox; $Lbox; $Rdia |] ==>
   $L |- $R1, []P, $R2"

ML {*
structure S43_Prover = Modal_ProverFun
(
  val rewrite_rls = @{thms rewrite_rls}
  val safe_rls = @{thms safe_rls}
  val unsafe_rls = @{thms unsafe_rls} @ [@{thm pi1}, @{thm pi2}]
  val bound_rls = @{thms bound_rls} @ [@{thm boxL}, @{thm diaR}]
  val aside_rls = [@{thm lstar0}, @{thm lstar1}, @{thm lstar2}, @{thm rstar0},
    @{thm rstar1}, @{thm rstar2}, @{thm S43pi0}, @{thm S43pi1}, @{thm S43pi2}]
)
*}

method_setup S43_solve = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD
    (S43_Prover.solve_tac ctxt 2 ORELSE S43_Prover.solve_tac ctxt 3))
*}

(* Theorems of system T from Hughes and Cresswell and Hailpern, LNCS 129 *)

lemma "|- []P --> P" by S43_solve
lemma "|- [](P-->Q) --> ([]P-->[]Q)" by S43_solve   (* normality*)
lemma "|- (P--<Q) --> []P --> []Q" by S43_solve
lemma "|- P --> <>P" by S43_solve

lemma "|-  [](P & Q) <-> []P & []Q" by S43_solve
lemma "|-  <>(P | Q) <-> <>P | <>Q" by S43_solve
lemma "|-  [](P<->Q) <-> (P>-<Q)" by S43_solve
lemma "|-  <>(P-->Q) <-> ([]P--><>Q)" by S43_solve
lemma "|-        []P <-> ~<>(~P)" by S43_solve
lemma "|-     [](~P) <-> ~<>P" by S43_solve
lemma "|-       ~[]P <-> <>(~P)" by S43_solve
lemma "|-      [][]P <-> ~<><>(~P)" by S43_solve
lemma "|- ~<>(P | Q) <-> ~<>P & ~<>Q" by S43_solve

lemma "|- []P | []Q --> [](P | Q)" by S43_solve
lemma "|- <>(P & Q) --> <>P & <>Q" by S43_solve
lemma "|- [](P | Q) --> []P | <>Q" by S43_solve
lemma "|- <>P & []Q --> <>(P & Q)" by S43_solve
lemma "|- [](P | Q) --> <>P | []Q" by S43_solve
lemma "|- <>(P-->(Q & R)) --> ([]P --> <>Q) & ([]P--><>R)" by S43_solve
lemma "|- (P--<Q) & (Q--<R) --> (P--<R)" by S43_solve
lemma "|- []P --> <>Q --> <>(P & Q)" by S43_solve

(* Theorems of system S4 from Hughes and Cresswell, p.46 *)

lemma "|- []A --> A" by S43_solve             (* refexivity *)
lemma "|- []A --> [][]A" by S43_solve         (* transitivity *)
lemma "|- []A --> <>A" by S43_solve           (* seriality *)
lemma "|- <>[](<>A --> []<>A)" by S43_solve
lemma "|- <>[](<>[]A --> []A)" by S43_solve
lemma "|- []P <-> [][]P" by S43_solve
lemma "|- <>P <-> <><>P" by S43_solve
lemma "|- <>[]<>P --> <>P" by S43_solve
lemma "|- []<>P <-> []<>[]<>P" by S43_solve
lemma "|- <>[]P <-> <>[]<>[]P" by S43_solve

(* Theorems for system S4 from Hughes and Cresswell, p.60 *)

lemma "|- []P | []Q <-> []([]P | []Q)" by S43_solve
lemma "|- ((P>-<Q) --< R) --> ((P>-<Q) --< []R)" by S43_solve

(* These are from Hailpern, LNCS 129 *)

lemma "|- [](P & Q) <-> []P & []Q" by S43_solve
lemma "|- <>(P | Q) <-> <>P | <>Q" by S43_solve
lemma "|- <>(P --> Q) <-> ([]P --> <>Q)" by S43_solve

lemma "|- [](P --> Q) --> (<>P --> <>Q)" by S43_solve
lemma "|- []P --> []<>P" by S43_solve
lemma "|- <>[]P --> <>P" by S43_solve

lemma "|- []P | []Q --> [](P | Q)" by S43_solve
lemma "|- <>(P & Q) --> <>P & <>Q" by S43_solve
lemma "|- [](P | Q) --> []P | <>Q" by S43_solve
lemma "|- <>P & []Q --> <>(P & Q)" by S43_solve
lemma "|- [](P | Q) --> <>P | []Q" by S43_solve

(* Theorems of system S43 *)

lemma "|- <>[]P --> []<>P" by S43_solve
lemma "|- <>[]P --> [][]<>P" by S43_solve
lemma "|- [](<>P | <>Q) --> []<>P | []<>Q" by S43_solve
lemma "|- <>[]P & <>[]Q --> <>([]P & []Q)" by S43_solve
lemma "|- []([]P --> []Q) | []([]Q --> []P)" by S43_solve
lemma "|- [](<>P --> <>Q) | [](<>Q --> <>P)" by S43_solve
lemma "|- []([]P --> Q) | []([]Q --> P)" by S43_solve
lemma "|- [](P --> <>Q) | [](Q --> <>P)" by S43_solve
lemma "|- [](P --> []Q-->R) | [](P | ([]R --> Q))" by S43_solve
lemma "|- [](P | (Q --> <>C)) | [](P --> C --> <>Q)" by S43_solve
lemma "|- []([]P | Q) & [](P | []Q) --> []P | []Q" by S43_solve
lemma "|- <>P & <>Q --> <>(<>P & Q) | <>(P & <>Q)" by S43_solve
lemma "|- [](P | Q) & []([]P | Q) & [](P | []Q) --> []P | []Q" by S43_solve
lemma "|- <>P & <>Q --> <>(P & Q) | <>(<>P & Q) | <>(P & <>Q)" by S43_solve
lemma "|- <>[]<>P <-> []<>P" by S43_solve
lemma "|- []<>[]P <-> <>[]P" by S43_solve

(* These are from Hailpern, LNCS 129 *)

lemma "|- [](P & Q) <-> []P & []Q" by S43_solve
lemma "|- <>(P | Q) <-> <>P | <>Q" by S43_solve
lemma "|- <>(P --> Q) <-> []P --> <>Q" by S43_solve

lemma "|- [](P --> Q) --> <>P --> <>Q" by S43_solve
lemma "|- []P --> []<>P" by S43_solve
lemma "|- <>[]P --> <>P" by S43_solve
lemma "|- []<>[]P --> []<>P" by S43_solve
lemma "|- <>[]P --> <>[]<>P" by S43_solve
lemma "|- <>[]P --> []<>P" by S43_solve
lemma "|- []<>[]P <-> <>[]P" by S43_solve
lemma "|- <>[]<>P <-> []<>P" by S43_solve

lemma "|- []P | []Q --> [](P | Q)" by S43_solve
lemma "|- <>(P & Q) --> <>P & <>Q" by S43_solve
lemma "|- [](P | Q) --> []P | <>Q" by S43_solve
lemma "|- <>P & []Q --> <>(P & Q)" by S43_solve
lemma "|- [](P | Q) --> <>P | []Q" by S43_solve
lemma "|- [](P | Q) --> []<>P | []<>Q" by S43_solve
lemma "|- <>[]P & <>[]Q --> <>(P & Q)" by S43_solve
lemma "|- <>[](P & Q) <-> <>[]P & <>[]Q" by S43_solve
lemma "|- []<>(P | Q) <-> []<>P | []<>Q" by S43_solve

end


(*  Title:      ZF/UNITY/Mutex.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra.

Variables' types are introduced globally so that type verification
reduces to the usual ZF typechecking \<in> an ill-tyed expression will
reduce to the empty set.
*)

section\<open>Mutual Exclusion\<close>

theory Mutex
imports SubstAx
begin

text\<open>Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra

Variables' types are introduced globally so that type verification reduces to
the usual ZF typechecking: an ill-tyed expressions reduce to the empty set.
\<close>

abbreviation "p == Var([0])"
abbreviation "m == Var([1])"
abbreviation "n == Var([0,0])"
abbreviation "u == Var([0,1])"
abbreviation "v == Var([1,0])"

axiomatization where \<comment> \<open>Type declarations\<close>
  p_type:  "type_of(p)=bool & default_val(p)=0" and
  m_type:  "type_of(m)=int  & default_val(m)=#0" and
  n_type:  "type_of(n)=int  & default_val(n)=#0" and
  u_type:  "type_of(u)=bool & default_val(u)=0" and
  v_type:  "type_of(v)=bool & default_val(v)=0"

definition
  (** The program for process U **)
  "U0 == {<s,t>:state*state. t = s(u:=1, m:=#1) & s`m = #0}"

definition
  "U1 == {<s,t>:state*state. t = s(p:= s`v, m:=#2) &  s`m = #1}"

definition
  "U2 == {<s,t>:state*state. t = s(m:=#3) & s`p=0 & s`m = #2}"

definition
  "U3 == {<s,t>:state*state. t=s(u:=0, m:=#4) & s`m = #3}"

definition
  "U4 == {<s,t>:state*state. t = s(p:=1, m:=#0) & s`m = #4}"

   (** The program for process V **)

definition
  "V0 == {<s,t>:state*state. t = s (v:=1, n:=#1) & s`n = #0}"

definition
  "V1 == {<s,t>:state*state. t = s(p:=not(s`u), n:=#2) & s`n = #1}"

definition
  "V2 == {<s,t>:state*state. t  = s(n:=#3) & s`p=1 & s`n = #2}"

definition
  "V3 == {<s,t>:state*state. t = s (v:=0, n:=#4) & s`n = #3}"

definition
  "V4 == {<s,t>:state*state. t  = s (p:=0, n:=#0) & s`n = #4}"

definition
  "Mutex == mk_program({s:state. s`u=0 & s`v=0 & s`m = #0 & s`n = #0},
              {U0, U1, U2, U3, U4, V0, V1, V2, V3, V4}, Pow(state*state))"

  (** The correct invariants **)

definition
  "IU == {s:state. (s`u = 1\<longleftrightarrow>(#1 $\<le> s`m & s`m $\<le> #3))
                     & (s`m = #3 \<longrightarrow> s`p=0)}"

definition
  "IV == {s:state. (s`v = 1 \<longleftrightarrow> (#1 $\<le> s`n & s`n $\<le> #3))
                      & (s`n = #3 \<longrightarrow> s`p=1)}"

  (** The faulty invariant (for U alone) **)

definition
  "bad_IU == {s:state. (s`u = 1 \<longleftrightarrow> (#1 $\<le> s`m & s`m  $\<le> #3))&
                   (#3 $\<le> s`m & s`m $\<le> #4 \<longrightarrow> s`p=0)}"

(** Variables' types **)

declare p_type [simp] u_type [simp] v_type [simp] m_type [simp] n_type [simp]

lemma u_value_type: "s \<in> state ==>s`u \<in> bool"
apply (unfold state_def)
apply (drule_tac a = u in apply_type, auto)
done

lemma v_value_type: "s \<in> state ==> s`v \<in> bool"
apply (unfold state_def)
apply (drule_tac a = v in apply_type, auto)
done

lemma p_value_type: "s \<in> state ==> s`p \<in> bool"
apply (unfold state_def)
apply (drule_tac a = p in apply_type, auto)
done

lemma m_value_type: "s \<in> state ==> s`m \<in> int"
apply (unfold state_def)
apply (drule_tac a = m in apply_type, auto)
done

lemma n_value_type: "s \<in> state ==>s`n \<in> int"
apply (unfold state_def)
apply (drule_tac a = n in apply_type, auto)
done

declare p_value_type [simp] u_value_type [simp] v_value_type [simp]
        m_value_type [simp] n_value_type [simp]

declare p_value_type [TC] u_value_type [TC] v_value_type [TC]
        m_value_type [TC] n_value_type [TC]

text\<open>Mutex is a program\<close>

lemma Mutex_in_program [simp,TC]: "Mutex \<in> program"
by (simp add: Mutex_def)

declare Mutex_def [THEN def_prg_Init, simp]
declare Mutex_def [program]

declare  U0_def [THEN def_act_simp, simp]
declare  U1_def [THEN def_act_simp, simp]
declare  U2_def [THEN def_act_simp, simp]
declare  U3_def [THEN def_act_simp, simp]
declare  U4_def [THEN def_act_simp, simp]

declare  V0_def [THEN def_act_simp, simp]
declare  V1_def [THEN def_act_simp, simp]
declare  V2_def [THEN def_act_simp, simp]
declare  V3_def [THEN def_act_simp, simp]
declare  V4_def [THEN def_act_simp, simp]

declare  U0_def [THEN def_set_simp, simp]
declare  U1_def [THEN def_set_simp, simp]
declare  U2_def [THEN def_set_simp, simp]
declare  U3_def [THEN def_set_simp, simp]
declare  U4_def [THEN def_set_simp, simp]

declare  V0_def [THEN def_set_simp, simp]
declare  V1_def [THEN def_set_simp, simp]
declare  V2_def [THEN def_set_simp, simp]
declare  V3_def [THEN def_set_simp, simp]
declare  V4_def [THEN def_set_simp, simp]

declare  IU_def [THEN def_set_simp, simp]
declare  IV_def [THEN def_set_simp, simp]
declare  bad_IU_def [THEN def_set_simp, simp]

lemma IU: "Mutex \<in> Always(IU)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
done

lemma IV: "Mutex \<in> Always(IV)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety)
done

(*The safety property: mutual exclusion*)
lemma mutual_exclusion: "Mutex \<in> Always({s \<in> state. ~(s`m = #3 & s`n = #3)})"
apply (rule Always_weaken)
apply (rule Always_Int_I [OF IU IV], auto)
done

(*The bad invariant FAILS in V1*)

lemma less_lemma: "[| x$<#1; #3 $\<le> x |] ==> P"
apply (drule_tac j = "#1" and k = "#3" in zless_zle_trans)
apply (drule_tac [2] j = x in zle_zless_trans, auto)
done

lemma "Mutex \<in> Always(bad_IU)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
apply (subgoal_tac "#1 $\<le> #3")
apply (drule_tac x = "#1" and y = "#3" in zle_trans, auto)
apply (simp (no_asm) add: not_zless_iff_zle [THEN iff_sym])
apply auto
(*Resulting state: n=1, p=false, m=4, u=false.
  Execution of V1 (the command of process v guarded by n=1) sets p:=true,
  violating the invariant!*)
oops

(*** Progress for U ***)

lemma U_F0: "Mutex \<in> {s \<in> state. s`m=#2} Unless {s \<in> state. s`m=#3}"
by (unfold op_Unless_def Mutex_def, safety)

lemma U_F1:
     "Mutex \<in> {s \<in> state. s`m=#1} \<longmapsto>w {s \<in> state. s`p = s`v & s`m = #2}"
by (unfold Mutex_def, ensures U1)

lemma U_F2: "Mutex \<in> {s \<in> state. s`p =0 & s`m = #2} \<longmapsto>w {s \<in> state. s`m = #3}"
apply (cut_tac IU)
apply (unfold Mutex_def, ensures U2)
done

lemma U_F3: "Mutex \<in> {s \<in> state. s`m = #3} \<longmapsto>w {s \<in> state. s`p=1}"
apply (rule_tac B = "{s \<in> state. s`m = #4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures U3)
apply (ensures U4)
done

lemma U_lemma2: "Mutex \<in> {s \<in> state. s`m = #2} \<longmapsto>w {s \<in> state. s`p=1}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF U_F2 U_F3], auto)
apply (auto dest!: p_value_type simp add: bool_def)
done

lemma U_lemma1: "Mutex \<in> {s \<in> state. s`m = #1} \<longmapsto>w {s \<in> state. s`p =1}"
by (rule LeadsTo_Trans [OF U_F1 [THEN LeadsTo_weaken_R] U_lemma2], blast)

lemma eq_123: "i \<in> int ==> (#1 $\<le> i & i $\<le> #3) \<longleftrightarrow> (i=#1 | i=#2 | i=#3)"
apply auto
apply (auto simp add: neq_iff_zless)
apply (drule_tac [4] j = "#3" and i = i in zle_zless_trans)
apply (drule_tac [2] j = i and i = "#1" in zle_zless_trans)
apply (drule_tac j = i and i = "#1" in zle_zless_trans, auto)
apply (rule zle_anti_sym)
apply (simp_all (no_asm_simp) add: zless_add1_iff_zle [THEN iff_sym])
done

lemma U_lemma123: "Mutex \<in> {s \<in> state. #1 $\<le> s`m & s`m $\<le> #3} \<longmapsto>w {s \<in> state. s`p=1}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib U_lemma1 U_lemma2 U_F3)

(*Misra's F4*)
lemma u_Leadsto_p: "Mutex \<in> {s \<in> state. s`u = 1} \<longmapsto>w {s \<in> state. s`p=1}"
by (rule Always_LeadsTo_weaken [OF IU U_lemma123], auto)

(*** Progress for V ***)

lemma V_F0: "Mutex \<in> {s \<in> state. s`n=#2} Unless {s \<in> state. s`n=#3}"
by (unfold op_Unless_def Mutex_def, safety)

lemma V_F1: "Mutex \<in> {s \<in> state. s`n=#1} \<longmapsto>w {s \<in> state. s`p = not(s`u) & s`n = #2}"
by (unfold Mutex_def, ensures "V1")

lemma V_F2: "Mutex \<in> {s \<in> state. s`p=1 & s`n = #2} \<longmapsto>w {s \<in> state. s`n = #3}"
apply (cut_tac IV)
apply (unfold Mutex_def, ensures "V2")
done

lemma V_F3: "Mutex \<in> {s \<in> state. s`n = #3} \<longmapsto>w {s \<in> state. s`p=0}"
apply (rule_tac B = "{s \<in> state. s`n = #4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures V3)
apply (ensures V4)
done

lemma V_lemma2: "Mutex \<in> {s \<in> state. s`n = #2} \<longmapsto>w {s \<in> state. s`p=0}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF V_F2 V_F3], auto)
apply (auto dest!: p_value_type simp add: bool_def)
done

lemma V_lemma1: "Mutex \<in> {s \<in> state. s`n = #1} \<longmapsto>w {s \<in> state. s`p = 0}"
by (rule LeadsTo_Trans [OF V_F1 [THEN LeadsTo_weaken_R] V_lemma2], blast)

lemma V_lemma123: "Mutex \<in> {s \<in> state. #1 $\<le> s`n & s`n $\<le> #3} \<longmapsto>w {s \<in> state. s`p = 0}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib V_lemma1 V_lemma2 V_F3)

(*Misra's F4*)
lemma v_Leadsto_not_p: "Mutex \<in> {s \<in> state. s`v = 1} \<longmapsto>w {s \<in> state. s`p = 0}"
by (rule Always_LeadsTo_weaken [OF IV V_lemma123], auto)

(** Absence of starvation **)

(*Misra's F6*)
lemma m1_Leadsto_3: "Mutex \<in> {s \<in> state. s`m = #1} \<longmapsto>w {s \<in> state. s`m = #3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] U_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF v_Leadsto_not_p U_F0])
apply (rule U_F1 [THEN LeadsTo_weaken_R], auto)
apply (auto dest!: v_value_type simp add: bool_def)
done

(*The same for V*)
lemma n1_Leadsto_3: "Mutex \<in> {s \<in> state. s`n = #1} \<longmapsto>w {s \<in> state. s`n = #3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] V_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF u_Leadsto_p V_F0])
apply (rule V_F1 [THEN LeadsTo_weaken_R], auto)
apply (auto dest!: u_value_type simp add: bool_def)
done

end


theory Augmenting_Path_BFS_Impl
  imports
          "../../Refine_Imperative_HOL/IICF/IICF"
          Augmenting_Path_BFS
begin

definition  "oappend x' xs' = return (x'#xs')"

lemma mop_lookup_list_as_array_rule[sepref_fr_rules]:
  "\<And>R. 1 \<le> t xs \<Longrightarrow>
    hn_refine (hn_ctxt (list_assn R) xs xs' * hn_ctxt R x x')
     (oappend x' xs')
     (hn_invalid (list_assn R) xs xs' * hn_invalid R x x') (list_assn R) ( PR_CONST (mop_append t) $  x $ xs)"
  unfolding autoref_tag_defs mop_append_def oappend_def
  unfolding hn_refine_def
  apply (auto simp: execute_return pure_def hn_ctxt_def invalid_assn_def relH_def top_assn_rule)
  apply(rule exI[where x=1] ) apply auto
  subgoal
    by (metis mod_star_trueI assn_times_comm)
  subgoal using mod_starD by auto
  subgoal using mod_starD by blast
  done

subsection \<open>Imperative Implementation\<close>

term Augmenting_Path_BFS.bfs2

context Impl_Succ begin

    abbreviation "init_state_time == 13 + N"

    definition "set_pick_time vcf = (2::nat)"

definition "map_lookup_time vcf = (2::nat) "
lemma [simp]: "map_lookup_time cf > 0" unfolding map_lookup_time_def by simp

definition init_state :: "nat \<Rightarrow> (bool \<times> (nat \<Rightarrow> nat option) \<times> nat set \<times> nat set \<times> nat) nrest" where
  "init_state  src  = do {
        m \<leftarrow> mop_map_empty (\<lambda>_. N+3);
        m \<leftarrow> mop_map_update (\<lambda>M. 6) m src src;
        C \<leftarrow> mop_set_empty (\<lambda>_. 1::nat);
        ASSERT (C={});
        C \<leftarrow> mop_set_insert (\<lambda>_. 2) src C;
        N \<leftarrow> mop_set_empty (\<lambda>_. 1::nat);
        RETURNT (False, m, C, N, 0::nat)
      }"

    term mop_set_insert
    definition "set_insert_time vcf = 2"
    definition "map_dom_member_time vcf = (2::nat)"
    definition "map_update_time vcf = (6::nat)"
    definition "set_isempty_time = (10::nat)"
    definition "set_empty_time = (10::nat)"
    definition "list_append_time = (1::nat)"

    abbreviation "bfs2 cf SS IS s t == Augmenting_Path_BFS.bfs2 cf
                       (set_insert_time (card (Graph.V cf))) (map_dom_member_time (card (Graph.V cf))) (map_update_time (card (Graph.V cf)))
                      (set_pick_time (card (Graph.V cf))) list_append_time (map_lookup_time (card (Graph.V cf))) set_empty_time set_isempty_time SS IS s t"

    definition op_bfs :: "'ga \<Rightarrow> node \<Rightarrow> node \<Rightarrow> path option nrest"
      where [simp]: "op_bfs c s t \<equiv> bfs2 (absG c) (succ c) (init_state) s t"

   (* lemma pat_op_dfs[pat_rules]:
      "bfs2$(absG$c)$(succ$c)$s$t \<equiv> UNPROTECT op_bfs$c$s$t" by simp
  *)
    sepref_register "PR_CONST op_bfs"
      :: "'ig \<Rightarrow> node \<Rightarrow> node \<Rightarrow> path option nrest"

    type_synonym ibfs_state
      = "bool \<times> (node \<rightharpoonup> node) \<times> node set \<times> node set \<times> nat"

  lemma init_state_correct: "init_state src \<le> SPECT [ (False,[src\<mapsto>src],{src},{},0::nat) \<mapsto> init_state_time  ]"
    unfolding init_state_def
    apply(rule T_specifies_I) unfolding mop_map_empty_def mop_map_update_def mop_set_empty_def
        mop_set_insert_def
    by(vcg' \<open>clarsimp\<close>  )

    schematic_goal init_state_impl:
      fixes src :: nat
      assumes src_inbounds: "src < N"
      notes [id_rules] =
        itypeI[Pure.of src "TYPE(nat)"]
      shows "hn_refine (hn_val nat_rel src srci)
        (?c::?'c Heap) ?\<Gamma>' ?R (PR_CONST (init_state) src)"
      using [[id_debug, goals_limit = 3]]
      unfolding init_state_def PR_CONST_def   using src_inbounds
      unfolding mop_map_empty_add_mn[where s="N"]  (*
  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_keep

  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 *)
      apply sepref
      done
concrete_definition (in -) init_state_impl uses Impl_Succ.init_state_impl
    print_theorems

    sepref_register "init_state " :: " node \<Rightarrow> ibfs_state nrest"

      thm init_state_impl_def

      lemmas [sepref_fr_rules] = init_state_impl.refine[OF this_loc,to_hfref]

      thm Pre_BFS_Impl.pre_bfs2_def
lemma PP: "\<And>c. Pre_BFS_Impl (set_pick_time c)" by(simp add: Pre_BFS_Impl_def)

lemma (in -) hn_refine_Some[sepref_fr_rules]: " hn_refine (hn_val Id s' s)
           (ureturn (Some s))
       (hn_val Id s' s)
       (pure Id) (RETURNT $ (Some $ s'))"
  unfolding hn_refine_def apply (auto simp:   mult.assoc  execute_ureturn pure_def hn_ctxt_def)
  by (auto simp: top_assn_rule zero_enat_def relH_def  elim: pureD )

declare rbt_search_time_logN_mono [intro]
declare rbt_insert_logN_mono [intro]
declare rbt_delete_time_logN_mono [intro]

    schematic_goal bfs_impl:
      (*notes [sepref_opt_simps del] = imp_nfoldli_def
          -- \<open>Prevent the foreach-loop to be unfolded to a fixed-point,
              to produce more readable code for presentation purposes.\<close>*)
      notes [sepref_opt_simps] = heap_WHILET_def
      fixes s t :: nat
      notes [id_rules] =
        itypeI[Pure.of s "TYPE(nat)"]
        itypeI[Pure.of t "TYPE(nat)"]
        itypeI[Pure.of c "TYPE('ig)"]
        \<comment> \<open>Declare parameters to operation identification\<close>
      assumes inbounds: "s < N" and
         inboundsAll: "\<forall>x\<in>Graph.V (absG c). x < N"
      shows

  "hn_refine (
        hn_ctxt (isG) c ci
      * hn_val nat_rel s si
      * hn_val nat_rel t ti) (?c::?'c Heap) ?\<Gamma>' ?R (PR_CONST op_bfs c s t)"
      unfolding op_bfs_def PR_CONST_def
      apply(subst Augmenting_Path_BFS.bfs2_def) apply(simp add: Augmenting_Path_BFS_def)
      unfolding Pre_BFS_Impl.pre_bfs2_def[OF PP[of "(card (Graph.V (absG c)))"]]
      unfolding Pre_BFS_Impl.inner_loop_def[OF PP[of "(card (Graph.V (absG c)))"]]  unfolding  extract_rpath_def nfoldliIE_def nfoldli_def
      using [[id_debug, goals_limit = 3]]
      unfolding monadic_WHILE_aux unfolding Pre_BFS_Impl.loopguard_def[OF PP[of "(card (Graph.V (absG c)))"]]
      unfolding set_pick_time_def set_isempty_time_def map_dom_member_time_def
          map_update_time_def set_insert_time_def set_empty_time_def map_lookup_time_def list_append_time_def
      using inbounds  inboundsAll
  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_keep

  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 -) bfs_impl uses Impl_Succ.bfs_impl
      \<comment> \<open>Extract generated implementation into constant\<close>
    prepare_code_thms (in -) bfs_impl_def

  lemmas bfs_impl_fr_rule = bfs_impl.refine[OF this_loc, to_hfref]

  end

(*  export_code bfs_impl checking SML_imp *)

end