\<^marker>\<open>creator "Peter Lammich"\<close>
\<^marker>\<open>contributor "Maximilian P. L. Haslbeck"\<close>
section \<open>Final Insertion Sort\<close>
theory Sorting_Final_insertion_Sort
imports Sorting_Quicksort_Scheme Sorting_Unguarded_Insertion_Sort
begin

paragraph \<open>Summary\<close>
text \<open>This theory implements an algorithm final insertion sort, that
  assumes a list that is almost-sorted @{term part_sorted_wrt} and returns
  a sorted list in linear time.\<close>

paragraph \<open>Main Theorems/Definitions\<close>
text \<open>
\<^item> final_insertion_sort: the abstract algorithm that models final insertion sort
\<^item> final_insertion_sort_correct: final insertion sort, sorts an almost-sorted list
      in time fi_cost, which is linear in the length of the list
\<^item> final_insertion_sort_impl: the synthesized algorithm
\<close>

context weak_ordering begin

subsection \<open>final_insertion_sort\<close>

  definition "final_insertion_sort xs \<equiv> doN {
    ASSERT (1 < length xs);
    lxs \<leftarrow> SPECT [length xs \<mapsto> cost ''sub'' 1];
    if\<^sub>N SPECc2 ''icmp_sle'' (\<le>) lxs is_threshold then doN {
      SPECT [() \<mapsto> cost ''add'' 1];
      insertion_sort_guarded 1 lxs xs
    }
    else doN {
      SPECT [() \<mapsto> cost ''add'' 2];
      xs \<leftarrow> insertion_sort_guarded 1 is_threshold xs;
      insertion_sort_unguarded is_threshold is_threshold lxs xs
    }
  }"

subsubsection \<open>reasoning about stopper elements\<close>

  lemma has_stopperI:
    assumes "i<length xs" "j'<i" "i-j'\<le>N" "\<forall>j\<le>j'. \<not>xs!i\<^bold><xs!j"
    shows "has_stopper N xs i"
    using assms unfolding has_stopper_def by blast

  lemma part_sorted_guardedI:
    assumes S: "part_sorted_wrt (le_by_lt (\<^bold><)) N xs" and B: "N\<le>i" "i<length xs"
    shows "has_stopper N xs i"
  proof -
    from S have "N\<noteq>0" \<open>i\<noteq>0\<close> using B by (cases N; auto)+

    from S obtain ss where SL: "is_slicing N xs ss" and SORTED: "sorted_wrt (slice_LT (le_by_lt (\<^bold><))) ss" unfolding part_sorted_wrt_def by auto

    have XS_EQ: "xs = concat ss" using SL unfolding is_slicing_def by auto

    define xi where "xi = xs!i"

    obtain xs1 xs2 where XSEQ2: "xs=xs1@xi#xs2" and LEN_XS1: "length xs1 = i"
      unfolding xi_def using id_take_nth_drop[OF \<open>i<length xs\<close>] B by simp

    have [simp]: "ss\<noteq>[]"
      using XS_EQ assms(3) by auto
    have "concat ss = xs1@xi#xs2" by (simp add: XS_EQ[symmetric] XSEQ2)
    then obtain ss1 ssi1 ssi2 ss2 where 1: "ss = ss1 @ (ssi1 @ ssi2) # ss2" "xs1 = concat ss1 @ ssi1" "xi # xs2 = ssi2 @ concat ss2"
      by (auto dest: concat_eq_appendD)

    have SS1_NGT: "\<forall>x\<in>set (concat ss1). \<forall>y\<in>set (ssi1@ssi2). \<not>x \<^bold>> y"
      using SORTED by (auto simp add: "1"(1) sorted_wrt_append slice_LT_def le_by_lt_def)

    have XS1_NGT: "\<forall>x\<in>set xs1. \<forall>y\<in>set (concat ss2). \<not>x \<^bold>> y"
      using SORTED by (auto simp add: "1" sorted_wrt_append slice_LT_def le_by_lt_def)

    from SL 1 have SLI_BND: "length (ssi1@ssi2) \<le> N" unfolding is_slicing_def by auto

    show ?thesis proof (cases ssi2)
      case [simp]: Nil

      obtain ssi2' ss2' where [simp]: "ss2 = (xi#ssi2') # ss2'" using 1
        apply simp
        apply (cases ss2; simp)
        subgoal for ss2_1 ss2_r
          using SL unfolding is_slicing_def
          apply (cases ss2_1; simp)
          done
        done

      show ?thesis
        apply (rule has_stopperI[where j'="length xs1 - 1"])
        subgoal by fact
        subgoal using \<open>i \<noteq> 0\<close> \<open>length xs1 = i\<close> by auto
        subgoal
          using LEN_XS1 \<open>N \<noteq> 0\<close> by linarith
        subgoal
          apply (auto simp add: XS_EQ 1 simp flip: LEN_XS1)
          apply (simp add: nth_append split: if_splits)
          subgoal for j using XS1_NGT nth_mem unfolding 1(2) by fastforce
          subgoal for j using XS1_NGT nth_mem unfolding 1(2) by fastforce
          done
        done

    next
      case (Cons _ ssi2') hence [simp]: "ssi2 = xi#ssi2'" using 1 by auto

      have "ss1\<noteq>[]" proof
        assume [simp]: "ss1=[]"
        from 1 have "xs1 = ssi1" by simp
        hence "length ssi1 = i" using \<open>length xs1 = i\<close> by simp
        hence "length (ssi1@ssi2) > i" by simp
        moreover note SLI_BND
        ultimately show False using \<open>N\<le>i\<close> by auto
      qed

      have 11: "length (concat ss1) \<le> i" using \<open>length xs1 = i\<close> by (simp add: 1)

      have 12: "i < N + length (concat ss1)"
        by (metis "1"(2) "11" SLI_BND \<open>length xs1 = i\<close> add_diff_cancel_left' add_lessD1 le_eq_less_or_eq length_append length_greater_0_conv less_add_same_cancel1 less_diff_conv2 list.simps(3) local.Cons)

      show ?thesis
        apply (rule has_stopperI[where j'="length (concat ss1) - 1"])
        subgoal using assms(3) by auto
        subgoal using "1"(2) \<open>i \<noteq> 0\<close> \<open>length xs1 = i\<close> by auto
        subgoal using 12 by linarith
        subgoal
          apply (auto simp add: XS_EQ 1 simp flip: LEN_XS1)
          apply (simp add: nth_append split: if_splits)
          subgoal for j using SS1_NGT using nth_mem by fastforce
          subgoal using "12" assms(2) by linarith
          done
        done
    qed
  qed

  lemma mset_slice_eq_xform_aux:
    assumes "mset (slice 0 N xs') = mset (slice 0 N xs)"
    assumes "j < N" "N < length xs" "length xs' = length xs"
    obtains jj where "jj<N" "xs'!j = xs!jj"
    using assms by (auto simp: list_eq_iff_nth_eq set_slice_conv dest!: mset_eq_setD; auto)

  lemma filter_mset_eq_empty_conv: "filter_mset P m = {#} \<longleftrightarrow> (\<forall>x\<in>#m. \<not>P x)"
    by (auto simp: filter_mset_eq_conv)

  lemma filter_mset_eq_same_conv: "filter_mset P m = m \<longleftrightarrow> (\<forall>x\<in>#m. P x)"
    by (auto simp: filter_mset_eq_conv)

  lemma sorted_pos_aux:
    assumes "size (filter_mset (\<lambda>x. x \<^bold>\<le> a) (mset xs)) \<ge> n" "sorted_wrt (\<^bold>\<le>) xs"
    shows "\<forall>i<n. xs!i \<^bold>\<le> a"
  proof -

    from assms(1) have NL: "n\<le>length xs"
      by (metis le_trans size_filter_mset_lesseq size_mset)

    show ?thesis proof (rule ccontr, simp add: unfold_le_to_lt, clarify)
      fix i
      assume "i<n" "a \<^bold>< xs!i"
      hence 1: "\<forall>j\<in>{i..<length xs}. a \<^bold>< xs!j"
        by (metis antisym_conv2 assms(2) atLeastLessThan_iff itrans sorted_wrt_nth_less wo_leD)

      define xs\<^sub>1 where "xs\<^sub>1 = take i xs"
      define xs\<^sub>2 where "xs\<^sub>2 = drop i xs"

      have "xs = xs\<^sub>1@xs\<^sub>2" "\<forall>x\<in>set xs\<^sub>2. \<not>x\<^bold>\<le>a"
        unfolding xs\<^sub>1_def xs\<^sub>2_def using 1
        by (auto simp: in_set_conv_nth unfold_le_to_lt)

      hence "filter_mset (\<lambda>x. x \<^bold>\<le> a) (mset xs) = filter_mset (\<lambda>x. x \<^bold>\<le> a) (mset xs\<^sub>1)"
        by (auto simp: filter_mset_eq_empty_conv)

      hence "size (filter_mset (\<lambda>x. x \<^bold>\<le> a) (mset xs)) \<le> length xs\<^sub>1"
        apply auto
        by (metis size_filter_mset_lesseq size_mset)
      also have "length xs\<^sub>1 < n" unfolding xs\<^sub>1_def using \<open>i<n\<close> NL by auto
      finally show False using assms(1) by simp
    qed
  qed

  lemma filter_mset_eq_sameI:
    "(\<forall>x\<in>#m. P x) \<Longrightarrow> filter_mset P m = m" by (simp add: filter_mset_eq_same_conv)

  lemma xfer_stopper_leN_aux:
    assumes "length xs' = length xs"
    assumes I: "N \<le> i" "i < length xs"
    assumes DEQ: "drop N xs' = drop N xs"
    assumes S: "mset (slice 0 N xs') = mset (slice 0 N xs)" "sorted_wrt_lt (\<^bold><) (slice 0 N xs')"
    assumes LE: "\<forall>j\<le>j'. \<not> xs ! i \<^bold>< xs ! j" "j' < N" "j \<le> j'"
    shows "\<not> (xs' ! i \<^bold>< xs' ! j)"
  proof -

    define xs\<^sub>1 where "xs\<^sub>1 = take (Suc j') (slice 0 N xs)"
    define xs\<^sub>2 where "xs\<^sub>2 = drop (Suc j') (slice 0 N xs)"

    have S0NXS_EQ: "(slice 0 N xs) = xs\<^sub>1@xs\<^sub>2"
      unfolding xs\<^sub>1_def xs\<^sub>2_def by (auto)

    have "\<forall>x\<in>set (take (Suc j') xs). x \<^bold>\<le> xs!i"
      unfolding unfold_le_to_lt using LE
      by (auto simp: in_set_conv_nth)
    also have "take (Suc j') xs = xs\<^sub>1"
      using LE
      apply (auto simp: take_slice xs\<^sub>1_def)
      by (simp add: Misc.slice_def)
    finally have 1: "\<forall>x\<in>set xs\<^sub>1. x \<^bold>\<le> xs ! i" .

    have [simp]: "xs!i = xs'!i"
      by (metis DEQ assms(1) assms(2) assms(3) drop_eq_mono hd_drop_conv_nth)

    have "Suc j' = length xs\<^sub>1" unfolding xs\<^sub>1_def using LE I by auto
    also from 1 have "length xs\<^sub>1 \<le> size (filter_mset (\<lambda>x. x \<^bold>\<le> xs!i) (mset (slice 0 N xs)))"
      by (simp add: S0NXS_EQ filter_mset_eq_sameI)
    also have "mset (slice 0 N xs) = mset (slice 0 N xs')" using S by simp
    finally have "\<forall>ia<Suc j'. slice 0 N xs' ! ia \<^bold>\<le> xs ! i"
      using S(2)
      apply -
      apply (erule sorted_pos_aux)
      using le_by_lt by blast
    hence "\<forall>ia<Suc j'. xs' ! ia \<^bold>\<le> xs ! i"
      using LE by (simp add: Misc.slice_def)
    thus ?thesis using LE by (auto simp: unfold_le_to_lt)
  qed

  lemma transfer_stopper_over_initial_sorting:
    assumes "has_stopper N xs i"
    assumes B: "length xs' = length xs" "0<N" "N \<le> i" "i < length xs"
    assumes DEQ: "drop N xs' = drop N xs"
    assumes SORTED: "sort_spec (\<^bold><) (slice 0 N xs) (slice 0 N xs')"
    shows "has_stopper N xs' i"
    using assms[unfolded sort_spec_def has_stopper_def]
    apply clarify
    subgoal for j'
      apply (cases "j'<N")
      subgoal
        apply (rule has_stopperI[where j'=j'])
        using xfer_stopper_leN_aux
        apply auto
        done
      subgoal
        apply (rule has_stopperI[where j'=j'])
        apply auto
        subgoal for j
          apply (subgoal_tac "xs'!i = xs!i")
          subgoal
            apply (cases "j<N")
            subgoal by (erule (1) mset_slice_eq_xform_aux[where j=j]; simp)
            subgoal by (smt assms(6) drop_eq_mono hd_drop_conv_nth leI le_eq_less_or_eq le_less_trans)
            done
          subgoal by (metis assms(4) drop_eq_mono hd_drop_conv_nth)
          done
        done
      done
    done

  lemma transfer_guard_over_initial_sorting:
    assumes PS: "part_sorted_wrt (le_by_lt (\<^bold><)) N xs"
    assumes B: "length xs' = length xs" "0<N" "N \<le> i" "i < length xs"
    assumes DEQ: "drop N xs' = drop N xs"
    assumes SORTED: "sort_spec (\<^bold><) (slice 0 N xs) (slice 0 N xs')"
    shows "has_stopper N xs' i"
    using assms transfer_stopper_over_initial_sorting part_sorted_guardedI by blast

  lemma pull_refinement_into_slice_sort_specT:
    "slice_sort_specT (enat (h-i\<^sub>0+1) *m insort_guarded_step_cost) (\<^bold><) xs 0 h
      = \<Down>Id (timerefine (TId(''slice_sort'' := enat (h-i\<^sub>0+1) *m insort_guarded_step_cost)) (
            slice_sort_spec (\<^bold><) xs 0 h))"
    unfolding slice_sort_spec_def slice_sort_specT_def
    apply(cases "h \<le> length xs"; auto)
    apply(simp add: SPEC_timerefine_conv)
    apply(rule SPEC_cong, simp)
    by(simp add: timerefineA_cost)

  abbreviation "guarded_insort_cost lxs \<equiv> enat (lxs+1) *m insort_guarded_step_cost"

  lemma insertion_sort_guarded_correct_fl:
    "\<lbrakk>sorted_wrt_lt (\<^bold><) (take i\<^sub>0 xs); h\<le>length xs ; i\<^sub>0<h; h\<le>length xs \<rbrakk>
      \<Longrightarrow> insertion_sort_guarded i\<^sub>0 h xs
        \<le> slice_sort_specT (guarded_insort_cost (h-i\<^sub>0)) (\<^bold><) xs 0 h"
    apply(subst pull_refinement_into_slice_sort_specT)
    apply(rule insertion_sort_guarded_correct)
       apply auto
    done

  lemma insertion_sort_guarded_correct_threshold:
    "\<lbrakk>sorted_wrt_lt (\<^bold><) (take i\<^sub>0 xs); h\<le>length xs ; i\<^sub>0<h; h\<le>length xs; (h-i\<^sub>0)\<le>is_threshold \<rbrakk>
      \<Longrightarrow> insertion_sort_guarded i\<^sub>0 h xs
        \<le> slice_sort_specT (guarded_insort_cost is_threshold) (\<^bold><) xs 0 h"
    apply(rule order_trans)
     apply(rule insertion_sort_guarded_correct_fl)
        apply auto [4]
    unfolding slice_sort_specT_def
    apply(rule nrest_le_formatI)
    apply(intro refine0 SPEC_both_refine)
    apply clarsimp
    apply(rule costmult_right_mono)
    by auto

  lemma final_insertion_sort_correct_aux:
    "\<lbrakk>sorted_wrt_lt (\<^bold><) (take i\<^sub>0 xs\<^sub>0); h \<le> length xs\<^sub>0; i\<^sub>0 < h; h \<le> length xs\<^sub>0; h - i\<^sub>0 \<le> is_threshold;
          0 \<le> h \<and> h \<le> length xs\<^sub>0\<rbrakk>
    \<Longrightarrow> insertion_sort_guarded i\<^sub>0 h xs\<^sub>0 \<le>
        SPECT
         (emb (\<lambda>xs. length xs = length xs\<^sub>0 \<and> take 0 xs = take 0 xs\<^sub>0 \<and> drop h xs = drop h xs\<^sub>0 \<and> sort_spec (\<^bold><) (slice 0 h xs\<^sub>0) (slice 0 h xs))
           (guarded_insort_cost is_threshold))
      "
  using insertion_sort_guarded_correct_threshold[of i\<^sub>0 xs\<^sub>0 h]
  unfolding slice_sort_specT_def SPEC_REST_emb'_conv
  by(cases "0 \<le> h \<and> h \<le> length xs\<^sub>0", auto)

  abbreviation "unguarded_insort_cost lxs \<equiv> enat (lxs+1) *m insort_step_cost"

  thm insertion_sort_unguarded_correct

  lemma pull_refinement_into_slice_sort_specT_guarded:
    "slice_sort_specT (enat (h-i\<^sub>0+1) *m insort_step_cost) (\<^bold><) xs 0 h
    = \<Down>Id (timerefine (TId(''slice_sort'' := enat (h-i\<^sub>0+1) *m insort_step_cost)) (
            slice_sort_spec (\<^bold><) xs 0 h))"
    unfolding slice_sort_spec_def slice_sort_specT_def
    apply(cases "h \<le> length xs"; auto)
    apply(simp add: SPEC_timerefine_conv)
    apply(rule SPEC_cong, simp)
    by(simp add: timerefineA_cost)

  lemma insertion_sort_unguarded_correct_prepared:
    "\<lbrakk>sorted_wrt_lt (\<^bold><) (take i\<^sub>0 xs\<^sub>0); (\<forall>i\<in>{i\<^sub>0..<h}. has_stopper N xs\<^sub>0 i) \<and> h\<le>length xs\<^sub>0 ; i\<^sub>0<h; h\<le>length xs\<^sub>0 \<rbrakk>
      \<Longrightarrow> insertion_sort_unguarded N i\<^sub>0 h xs\<^sub>0
        \<le> SPECT
         (emb (\<lambda>xs. length xs = length xs\<^sub>0 \<and> take 0 xs = take 0 xs\<^sub>0 \<and> drop h xs = drop h xs\<^sub>0 \<and> sort_spec (\<^bold><) (slice 0 h xs\<^sub>0) (slice 0 h xs))
 (unguarded_insort_cost (h)))"
    apply(rule order.trans)
     apply(rule insertion_sort_unguarded_correct)
        apply auto [4]
    unfolding slice_sort_spec_def slice_sort_specT_def
    apply auto
    unfolding SPEC_timerefine_conv SPEC_REST_emb'_conv[symmetric]
    apply(rule SPEC_leq_SPEC_I, simp)
    apply(simp add: timerefineA_cost)
    apply(rule costmult_right_mono)
    apply simp
    done

  abbreviation "fi_cost lxs == guarded_insort_cost (is_threshold)
         + cost ''add'' 1 + cost ''add'' 1
        + cost ''if'' 1 +  cost ''sub'' 1 + cost ''icmp_sle'' 1
        + unguarded_insort_cost lxs
      "

subsubsection \<open>Correctness Theorem\<close>

  lemma final_insertion_sort_correct:
    "\<lbrakk>part_sorted_wrt (le_by_lt (\<^bold><)) is_threshold xs; 1 < length xs; lxs=length xs\<rbrakk>
      \<Longrightarrow> final_insertion_sort xs
       \<le> \<Down>Id (timerefine (TId(''sort_spec'':=fi_cost lxs))
               (SPEC (sort_spec (\<^bold><) xs) (\<lambda>_. cost ''sort_spec'' 1)))"
    unfolding final_insertion_sort_def SPEC_timerefine_conv
    apply simp
    unfolding SPEC_def
    unfolding SPECc2_def
    apply(rule gwp_specifies_I)
    apply (refine_vcg \<open>-\<close>)

    subgoal (* if branch *)
      apply(rule final_insertion_sort_correct_aux[THEN gwp_specifies_rev_I, THEN gwp_conseq_0 ])

    apply simp_all
      subgoal apply (rule sorted_wrt01) by auto
      apply safe
      apply(simp_all add: emb_eq_Some_conv)
      subgoal apply auto  using slice_complete by metis
      apply(simp add: norm_cost add.assoc )
      apply sc_solve by (auto simp: one_enat_def)

    subgoal (* else branch *)
      apply(rule final_insertion_sort_correct_aux[THEN gwp_specifies_rev_I, THEN gwp_conseq_0 ])
      apply simp_all
      subgoal apply (rule sorted_wrt01) by auto
      apply(rule insertion_sort_unguarded_correct_prepared[THEN gwp_specifies_rev_I, THEN gwp_conseq_0 ])
      apply(simp_all add: emb_eq_Some_conv)
      subgoal by (simp add: Misc.slice_def sort_spec_def)
      subgoal for xs' t M (* transfer guard over initial sorting *)
        apply safe
        apply(rule transfer_guard_over_initial_sorting[where xs=xs])
        by auto
      subgoal
        apply rule
        subgoal
          apply (auto simp: sort_spec_def)
           apply (metis Misc.slice_def append_take_drop_id drop0 drop_take slice_complete union_code)
          by (metis slice_complete)
        subgoal
          apply(simp add: norm_cost add.assoc)
          apply sc_solve
          by (auto simp: one_enat_def numeral_eq_enat)
      done
    done
  done

subsection \<open>final_insertion_sort2\<close>

  definition "final_insertion_sort2 xs l h \<equiv> doN {
    ASSERT (l<h);
    lxs \<leftarrow> SPECc2 ''sub'' (-) h l;
    if\<^sub>N SPECc2 ''icmp_sle'' (\<le>) lxs is_threshold then do {
      l' \<leftarrow> SPECc2 ''add'' (+) l 1;
      insertion_sort_guarded2 l l' h xs
    }
    else doN {
      l' \<leftarrow> SPECc2 ''add'' (+) l 1;
      l'' \<leftarrow> SPECc2 ''add'' (+) l is_threshold;
      xs \<leftarrow> insertion_sort_guarded2 l l' l'' xs;
      insertion_sort_unguarded2 is_threshold l'' h xs
    }
  }"

abbreviation "TR_fi2 N == (TR_is_insert3 N)"

lemma wfR''_TR_fi2[simp]: "wfR'' (TR_fi2 N)"
  by (auto simp: pp_TId_absorbs_right pp_fun_upd intro!: wfR''_upd)

lemma sp_TR_fi2[simp]: "struct_preserving (TR_fi2 N)"
  unfolding TR_is_insert3_def
  by (auto simp: pp_TId_absorbs_right pp_fun_upd intro!: struct_preserving_upd_I)

  (* TODO: make these refinement steps use the correct TimeRefine *)

  thm insertion_sort_guarded2_refine
  lemma insertion_sort_guarded2_refine_prepared:
    "\<lbrakk> (xsi,xs) \<in> slicep_rel l h; (ii,i)\<in>idx_shift_rel l; (ji,j)\<in>idx_shift_rel l; j\<le>N \<rbrakk>
      \<Longrightarrow> insertion_sort_guarded2 l ii ji xsi \<le>\<Down>(slice_rel xsi l h) (timerefine (TR_fi2 N) (insertion_sort_guarded i j xs))"
    apply(rule insertion_sort_guarded2_refine)
    apply auto done

  lemma insertion_sort_unguarded2_refine_prepared:
    "\<lbrakk> (xsi,xs) \<in> slicep_rel l h; (ii,i)\<in>idx_shift_rel l; (ji,j)\<in>idx_shift_rel l \<rbrakk>
      \<Longrightarrow> insertion_sort_unguarded2 N ii ji xsi \<le>\<Down>(slice_rel xsi l h) (timerefine (TR_fi2 N) (insertion_sort_unguarded N i j xs))"
    apply(rule insertion_sort_unguarded2_refine)
    apply auto done

  lemma final_insertion_sort2_refine: "\<lbrakk>(xsi,xs) \<in> slicep_rel l h\<rbrakk>
    \<Longrightarrow> final_insertion_sort2 xsi l h \<le> \<Down>(slice_rel xsi l h) (timerefine (TR_fi2 is_threshold) (final_insertion_sort xs))"
    unfolding final_insertion_sort2_def final_insertion_sort_def
    unfolding SPECc2_alt consume_RETURNT[symmetric]
    apply normalize_blocks

    supply [refine] = insertion_sort_guarded2_refine_prepared
                        insertion_sort_unguarded2_refine_prepared

    apply (refine_rcg bindT_refine_conc_time_my_inres MIf_refine consumea_refine)
    apply refine_dref_type
   apply clarsimp_all

      apply(all \<open>(simp add: timerefineA_propagate timerefineA_update_cost timerefineA_update_apply_same_cost;fail)?\<close>)

             apply (auto simp: slicep_rel_def idx_shift_rel_def ) [10]
    subgoal
      apply(simp add: norm_cost norm_pp TR_is_insert3_def)
      apply(subst timerefineA_propagate)
      by(auto simp: norm_cost  intro!: wfR''_upd)
    subgoal
      by (simp add: norm_cost norm_pp TR_is_insert3_def)
    subgoal
      apply(simp add: norm_cost norm_pp TR_is_insert3_def)
      apply sc_solve by simp
    subgoal
        apply (subst slice_rel_rebase, assumption)
      apply(refine_rcg insertion_sort_unguarded2_refine_prepared)
      by (auto simp: slice_rel_alt idx_shift_rel_def slicep_rel_def)
    done

  abbreviation "fi2_cost s \<equiv> enat 17 *m TR_is_insert3 is_threshold ''icmp_slt''
         + enat 17 *m TR_is_insert3 is_threshold ''add''
           + enat 17 *m TR_is_insert3 is_threshold ''is_insert_g''
           + enat 17 *m TR_is_insert3 is_threshold ''call'' +
          enat 17 *m TR_is_insert3 is_threshold ''if'' +
          TR_is_insert3 is_threshold ''add'' +
          TR_is_insert3 is_threshold ''add'' +
          TR_is_insert3 is_threshold ''if'' +
          TR_is_insert3 is_threshold ''sub'' +
          TR_is_insert3 is_threshold ''icmp_sle'' +
          (enat (Suc (s)) *m TR_is_insert3 is_threshold ''icmp_slt''
             + enat (Suc (s)) *m TR_is_insert3 is_threshold ''add''
           + enat (Suc (s)) *m TR_is_insert3 is_threshold ''is_insert'' +
           enat (Suc (s)) *m TR_is_insert3 is_threshold ''call'' +
           enat (Suc (s)) *m TR_is_insert3 is_threshold ''if'')"

subsubsection \<open>Correctness Theorem\<close>

  lemma final_insertion_sort2_correct:
    assumes [simplified, simp]: "(xs',xs)\<in>Id" "(l',l)\<in>Id" "(h',h)\<in>Id"
      and "T ''slice_sort'' = fi2_cost (h-l)"
    shows "final_insertion_sort2 xs' l' h' \<le> \<Down>Id (timerefine T (final_sort_spec xs l h))"
    unfolding final_sort_spec_def slice_sort_spec_def
    apply(intro refine0)
    apply(rule order_trans)
    apply(rule final_insertion_sort2_refine[where xs="slice l h xs"])
    subgoal by(auto simp: slicep_rel_def)
    apply(rule order_trans[OF nrest_Rel_mono])
    apply(rule timerefine_mono2)
    subgoal  by simp
    apply(rule final_insertion_sort_correct)
       apply simp
      apply simp
     apply simp
    apply(simp add: SPEC_timerefine_conv)
    unfolding slice_rel_def
    apply(simp add: build_rel_SPEC_conv)
    apply(rule SPEC_leq_SPEC_I_strong)
    subgoal by auto
    subgoal apply (auto simp: timerefineA_cost_apply_costmult   norm_cost)
      apply(subst assms(4)) apply simp
      done
    done

end

subsection \<open>final_insertion_sort3\<close>

context sort_impl_context begin

  definition "final_insertion_sort3 xs l h \<equiv> doN {
    ASSERT (l<h);
    lxs \<leftarrow> SPECc2 ''sub'' (-) h l;
    if\<^sub>N SPECc2 ''icmp_sle'' (\<le>) lxs is_threshold then do {
      l' \<leftarrow> SPECc2 ''add'' (+) l 1;
      insertion_sort_guarded3 l l' h xs
    }
    else doN {
      l' \<leftarrow> SPECc2 ''add'' (+) l 1;
      l'' \<leftarrow> SPECc2 ''add'' (+) l is_threshold;
      xs \<leftarrow> insertion_sort_guarded3 l l' l'' xs;
      insertion_sort_unguarded3 is_threshold l'' h xs
    }
  }"

subsubsection \<open>Refinement Lemma\<close>

  lemma final_insertion_sort3_refines:
    "(xs,xs')\<in>Id \<Longrightarrow> (l,l')\<in>Id \<Longrightarrow> (h,h')\<in>Id
      \<Longrightarrow> final_insertion_sort3 xs l h \<le> \<Down>Id (timerefine TR_cmp_swap (final_insertion_sort2 xs' l' h'))"
    supply conc_Id[simp del]
    unfolding final_insertion_sort3_def final_insertion_sort2_def
    supply [refine] = insertion_sort_unguarded3_refines insertion_sort_guarded3_refines
    apply(refine_rcg MIf_refine SPECc2_refine' bindT_refine_conc_time_my_inres monadic_WHILEIT_refine' )
    apply refine_dref_type
    apply(all \<open>(intro  preserves_curr_other_updI wfR''_upd wfR''_TId preserves_curr_TId)?\<close>)
    apply (simp_all (no_asm))
    by auto

subsubsection \<open>Synthesize final_insertion_sort_impl\<close>

  sepref_register final_insertion_sort3
  sepref_def final_insertion_sort_impl is "uncurry2 (PR_CONST final_insertion_sort3)"
    :: "(array_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a array_assn elem_assn"
    unfolding final_insertion_sort3_def PR_CONST_def
    apply (annot_snat_const "TYPE('size_t)")
    by sepref

end

end


theory DP_Lifting
  imports Main "./Monad"
begin

  (* Types *)
type_synonym ('a,'M,'b) fun_lifted = "'a \<Rightarrow> ('M,'b) state" ("_ ==_\<Longrightarrow> _" [3,1000,2] 2)
type_synonym ('a,'b) dpfun = "'a ==('a\<rightharpoonup>'b)\<Longrightarrow> 'b" (infixr "\<Rightarrow>\<^sub>T" 2)
term 0 (**)

  (* Basics *)
notation Monad.return ("\<langle>_\<rangle>")

syntax
  "_lambda\<^sub>T" :: "[pttrns, 'a] \<Rightarrow> logic" ("(3\<lambda>\<^sub>T_./ _)" [0, 3] 3)
translations
  "\<lambda>\<^sub>T v vs. e" \<rightharpoonup> "\<lambda>\<^sub>T v. \<lambda>\<^sub>T vs. e"
  "\<lambda>\<^sub>T v. e" \<rightharpoonup> "\<langle>\<lambda> v. e\<rangle>"

definition fun_app_lifted :: "('M,'a =='M\<Longrightarrow> 'b) state \<Rightarrow> ('M,'a) state \<Rightarrow> ('M,'b) state" (infixl "." 999) where
  "f\<^sub>T . x\<^sub>T \<equiv> do { f \<leftarrow> f\<^sub>T; x \<leftarrow> x\<^sub>T; f x }"
term 0 (**)

lemma fun_app_lifted_elim1:
  assumes "runState (f\<^sub>T . x\<^sub>T) M = (v, Mv)"
  obtains f Mf x Mx where "runState f\<^sub>T M = (f, Mf)" "runState x\<^sub>T Mf = (x, Mx)" and "runState (f x) Mx = (v, Mv)"
  using assms unfolding fun_app_lifted_def bind_def by (auto split: prod.splits)

lemma fun_app_lifted_elim:
  assumes "runState (f\<^sub>T . x\<^sub>T) M = (v, Mv)" "runState f\<^sub>T M = (f, Mf)"
  obtains x Mx where "runState x\<^sub>T Mf = (x, Mx)" and "runState (f x) Mx = (v, Mv)"
  using assms by (auto intro: fun_app_lifted_elim1)

lemma fun_app_lifted_dest:
  assumes "runState f\<^sub>T M = (f, Mf)" "runState x\<^sub>T Mf = (x, Mx)" "runState (f x) Mx = (v, Mv)"
  shows "runState (f\<^sub>T . x\<^sub>T) M = (v, Mv)"
    using assms unfolding fun_app_lifted_def bind_def by auto
term 0 (**)

lemma return_app_return:
  "\<langle>f\<rangle> . \<langle>x\<rangle> = f x"
  unfolding fun_app_lifted_def left_identity ..
term 0 (**)

definition checkmem :: "'param \<Rightarrow> ('param \<rightharpoonup> 'result, 'result) state \<Rightarrow> ('param \<rightharpoonup> 'result, 'result) state" where
  "checkmem param calc \<equiv> do {
    M \<leftarrow> get;
    case M param of
      Some x \<Rightarrow> return x
    | None \<Rightarrow> do {
        x \<leftarrow> calc;
        M' \<leftarrow> get;
        put (M'(param\<mapsto>x));
        return x
      }
  }"

abbreviation checkmem_eq :: "('param \<Rightarrow>\<^sub>T 'result) \<Rightarrow> 'param \<Rightarrow> ('param \<rightharpoonup> 'result, 'result) state \<Rightarrow> bool" ("_$ _ =CHECKMEM= _" [1000,51] 51) where
  "(dp\<^sub>T$ param =CHECKMEM= calc) \<equiv> (dp\<^sub>T param = checkmem param calc)"
term 0 (**)

context
  includes lifting_syntax
begin

  (* Auxiliary *)
definition unlift_' :: "'a \<Rightarrow> ('M, 'a) state" where
  "unlift_' x \<equiv> \<langle>x\<rangle>"
definition unlift_3 :: "('a =='M\<Longrightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> ('M, 'b) state)" where
  "unlift_3 f \<equiv> \<lambda>v0. \<langle>f\<rangle> . \<langle>v0\<rangle>"
definition unlift_33 :: "('a =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> ('M, 'c) state)" where
  "unlift_33 f \<equiv> \<lambda>v0 v1. \<langle>f\<rangle> . \<langle>v0\<rangle> . \<langle>v1\<rangle>"

definition lift_' :: "'a \<Rightarrow> ('M, 'a) state" where
  "lift_' x \<equiv> \<langle>x\<rangle>"
definition lift_3 :: "('a \<Rightarrow> 'b) \<Rightarrow> ('M, 'a =='M\<Longrightarrow> 'b) state" where
  "lift_3 f \<equiv> \<lambda>\<^sub>T x. \<langle>f x\<rangle>"
definition lift_33 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('M, 'a =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'c) state" where
  "lift_33 f \<equiv> \<lambda>\<^sub>T x0 x1. \<langle>f x0 x1\<rangle>"
definition lift_333 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> ('M, 'a =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'c =='M\<Longrightarrow> 'd) state" where
  "lift_333 f \<equiv> \<lambda>\<^sub>T x0 x1 x2. \<langle>f x0 x1 x2\<rangle>"
term 0 (**)

  (* HOL *)
definition If\<^sub>T :: "('M, bool =='M\<Longrightarrow> 'a =='M\<Longrightarrow> 'a =='M\<Longrightarrow> 'a) state" where
  "If\<^sub>T \<equiv> lift_333 If"

thm comp_def
definition comp\<^sub>T :: "('M, ('b =='M\<Longrightarrow> 'c) =='M\<Longrightarrow> ('a =='M\<Longrightarrow> 'b) =='M\<Longrightarrow> ('a =='M\<Longrightarrow> 'c)) state" where
  "comp\<^sub>T \<equiv> \<lambda>\<^sub>T f g x. \<langle>f\<rangle> . (\<langle>g\<rangle> . \<langle>x\<rangle>)"

thm id_def
definition id\<^sub>T :: "('M, 'a =='M\<Longrightarrow> 'a) state" where
  "id\<^sub>T \<equiv> lift_3 id"
term 0 (**)

  (* List *)
definition Nil\<^sub>T :: "('M, 'a list) state" where
  "Nil\<^sub>T \<equiv> lift_' Nil"

definition Cons\<^sub>T :: "('M, 'a =='M\<Longrightarrow> 'a list =='M\<Longrightarrow> 'a list) state" where
  "Cons\<^sub>T \<equiv> lift_33 Cons"

definition case_list\<^sub>T :: "('M, 'b =='M\<Longrightarrow> ('a =='M\<Longrightarrow> 'a list =='M\<Longrightarrow> 'b) =='M\<Longrightarrow> 'a list =='M\<Longrightarrow> 'b) state" where
  "case_list\<^sub>T \<equiv> \<lambda>\<^sub>T ifNil ifCons val. case_list (unlift_' ifNil) (unlift_33 ifCons) val"

fun map\<^sub>T' :: "('a =='M\<Longrightarrow>'b) \<Rightarrow> 'a list =='M\<Longrightarrow> 'b list" where
  "(map\<^sub>T' f) [] = \<langle>[]\<rangle>"
| "(map\<^sub>T' f) (x#xs) = Cons\<^sub>T . (f x) . ((map\<^sub>T' f) xs)"
lemma
  "(map\<^sub>T' f) (x#xs) = Cons\<^sub>T . (f x) . (\<langle>map\<^sub>T' f\<rangle> . \<langle>xs\<rangle>)" unfolding map\<^sub>T'.simps(2) fun_app_lifted_def left_identity ..

definition map\<^sub>T :: "('M, ('a =='M\<Longrightarrow> 'b) =='M\<Longrightarrow> 'a list =='M\<Longrightarrow> 'b list) state" where
  "map\<^sub>T \<equiv> lift_3 map\<^sub>T'"

lemma map\<^sub>T_map\<^sub>T': "map\<^sub>T . f\<^sub>T . xs\<^sub>T = do {f \<leftarrow> f\<^sub>T; xs \<leftarrow> xs\<^sub>T; map\<^sub>T' f xs}"
  unfolding map\<^sub>T_def lift_3_def fun_app_lifted_def left_identity bind_assoc ..
term 0 (**)

primrec fold\<^sub>T' :: "('a =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'b) \<Rightarrow> 'a list =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'b" where
  "(fold\<^sub>T' f) [] = id\<^sub>T"
| "(fold\<^sub>T' f) (x#xs) = comp\<^sub>T . ((fold\<^sub>T' f) xs) . (\<langle>f\<rangle> . \<langle>x\<rangle>)"
lemma
  "(fold\<^sub>T' f) (x#xs) = comp\<^sub>T . (\<langle>fold\<^sub>T' f\<rangle> . \<langle>xs\<rangle>) . (\<langle>f\<rangle> . \<langle>x\<rangle>)" unfolding fold\<^sub>T'.simps(2) fun_app_lifted_def left_identity ..

definition fold\<^sub>T :: "('M, ('a =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'b) =='M\<Longrightarrow> 'a list =='M\<Longrightarrow> 'b =='M\<Longrightarrow> 'b) state" where
  "fold\<^sub>T \<equiv> \<lambda>\<^sub>T f\<^sub>T. \<langle>fold\<^sub>T' f\<^sub>T\<rangle>"

definition upt\<^sub>T :: "('M, nat =='M\<Longrightarrow> nat =='M\<Longrightarrow> nat list) state" where
  "upt\<^sub>T \<equiv> lift_33 upt"
term 0 (**)

  (* Option *)
definition None\<^sub>T :: "('M, 'a option) state" where
  "None\<^sub>T \<equiv> lift_' None"

definition Some\<^sub>T :: "('M, 'a =='M\<Longrightarrow> 'a option) state" where
  "Some\<^sub>T \<equiv> lift_3 Some"

definition case_option\<^sub>T :: "('M, 'b =='M\<Longrightarrow> ('a =='M\<Longrightarrow> 'b) =='M\<Longrightarrow> 'a option =='M\<Longrightarrow> 'b) state" where
  "case_option\<^sub>T \<equiv> \<lambda>\<^sub>T ifNone ifSome val. case_option (unlift_' ifNone) (unlift_3 ifSome) val"
term 0 (**)

  (* Prod *)
definition Pair\<^sub>T :: "('M, 'a0 =='M\<Longrightarrow> 'a1 =='M\<Longrightarrow> 'a0\<times>'a1) state" where
  "Pair\<^sub>T \<equiv> lift_33 Pair"

definition case_prod\<^sub>T :: "('M, ('a0 =='M\<Longrightarrow> 'a1 =='M\<Longrightarrow> 'b) =='M\<Longrightarrow> ('a0\<times>'a1) =='M\<Longrightarrow> 'b) state" where
  "case_prod\<^sub>T \<equiv> \<lambda>\<^sub>T ifProd val. case_prod (unlift_33 ifProd) val"

term "case_prod\<^sub>T . (\<lambda>\<^sub>T v0 v1. \<langle>v0+v1\<rangle>) . (Pair\<^sub>T . \<langle>0\<rangle> . \<langle>0::int\<rangle>)"
term 0 (**)

  (* Arithmetic *)
definition min\<^sub>T :: "('M, 'a::ord =='M\<Longrightarrow> 'a =='M\<Longrightarrow> 'a) state" where
  "min\<^sub>T \<equiv> lift_33 min"

definition max\<^sub>T :: "('M, 'a::ord =='M\<Longrightarrow> 'a =='M\<Longrightarrow> 'a) state" where
  "max\<^sub>T \<equiv> lift_33 max"

definition plus\<^sub>T :: "('M, 'a::plus =='M\<Longrightarrow> 'a =='M\<Longrightarrow> 'a) state" where
  "plus\<^sub>T \<equiv> lift_33 plus"
term 0 (**)
end
end


theory Prelude_Composition
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize [\"Comp\", \"Comp1\"]"

consts
X__o__X :: "('b => 'c) * ('a => 'b) => 'a => 'c"

axioms
Comp [rule_format] :
"ALL f.
 ALL g. makePartial o X__o__X (f, g) = makePartial o (% x. f (g x))"

theorem Comp1 : "ALL f. ALL g. ALL y. X__o__X (f, g) y = f (g y)"
apply(auto)
thm Comp
apply(rule Comp)
by auto

ML "Header.record \"Comp1\""

end


(*<*)
theory Abstract_Monitor
  imports MFOTL
begin
(*>*)

section \<open>Abstract Specification of a Monitor\<close>

locale monitorable =
  fixes monitorable :: "'a MFOTL.formula \<Rightarrow> bool"

text \<open>The following locale specifies the desired behavior ouf a monitor abstractly.\<close>

locale monitor = monitorable +
  fixes
    M :: "'a MFOTL.formula \<Rightarrow> 'a MFOTL.prefix \<Rightarrow> (nat \<times> 'a option list) set"
  assumes
    mono_monitor: "monitorable \<phi> \<Longrightarrow> \<pi> \<le> \<pi>' \<Longrightarrow> M \<phi> \<pi> \<subseteq> M \<phi> \<pi>'"
    and sound_monitor: "monitorable \<phi> \<Longrightarrow> (i, v) \<in> M \<phi> \<pi> \<Longrightarrow>
      i < plen \<pi> \<and> wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v \<and> (\<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> MFOTL.sat \<sigma> (map the v) i \<phi>)"
    and complete_monitor: "monitorable \<phi> \<Longrightarrow> prefix_of \<pi> \<sigma> \<Longrightarrow>
      i < plen \<pi> \<Longrightarrow> wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v \<Longrightarrow>
      (\<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> MFOTL.sat \<sigma> (map the v) i \<phi>) \<Longrightarrow> \<exists>\<pi>'. prefix_of \<pi>' \<sigma> \<and> (i, v) \<in> M \<phi> \<pi>'"

locale slicable_monitor = monitor +
  assumes monitor_slice: "mem_restr S v \<Longrightarrow> (i, v) \<in> M \<phi> (MFOTL.pslice \<phi> S \<pi>) \<longleftrightarrow> (i, v) \<in> M \<phi> \<pi>"

locale monitor_pre_progress = monitorable +
  fixes progress :: "'a MFOTL.trace \<Rightarrow> 'a MFOTL.formula \<Rightarrow> nat \<Rightarrow> nat"
  assumes
    progress_mono: "j \<le> j' \<Longrightarrow> progress \<sigma> \<phi> j \<le> progress \<sigma> \<phi> j'"
    and progress_le: "progress \<sigma> \<phi> j \<le> j"
    and progress_ge: "monitorable \<phi> \<Longrightarrow> \<exists>j. i \<le> progress \<sigma> \<phi> j"

locale monitor_progress = monitor_pre_progress +
  assumes progress_prefix_conv: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of \<pi> \<sigma>' \<Longrightarrow>
    progress \<sigma> \<phi> (plen \<pi>) = progress \<sigma>' \<phi> (plen \<pi>)"
begin

definition verdicts :: "'a MFOTL.formula \<Rightarrow> 'a MFOTL.prefix \<Rightarrow> (nat \<times> 'a tuple) set" where
  "verdicts \<phi> \<pi> = {(i, v). wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v \<and>
    (\<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> i < progress \<sigma> \<phi> (plen \<pi>) \<and> MFOTL.sat \<sigma> (map the v) i \<phi>)}"

lemma verdicts_mono: "\<pi> \<le> \<pi>' \<Longrightarrow> verdicts \<phi> \<pi> \<subseteq> verdicts \<phi> \<pi>'"
  unfolding verdicts_def
  by (auto dest: prefix_of_antimono elim!: order.strict_trans2 intro!: progress_mono plen_mono)

end

lemma stake_eq_mono: "stake b x = stake b y \<Longrightarrow> a \<le> b \<Longrightarrow> stake a x = stake a y"
proof (induction a arbitrary: b x y)
  case 0
  then show ?case by simp
next
  case Suca: (Suc a)
  show ?case proof (cases b)
    case 0
    with Suca show ?thesis by (simp del: stake.simps)
  next
    case (Suc b')
    with Suca show ?thesis by (auto simp only: stake.simps list.inject)
  qed
qed

sublocale monitor_progress \<subseteq> monitor monitorable verdicts
proof (standard, goal_cases)
  case (1 \<phi> \<pi> \<pi>')
  from 1(2) show ?case by (rule verdicts_mono)
next
  case (2 \<phi> i v \<pi>)
  from \<open>(i, v) \<in> verdicts \<phi> \<pi>\<close> show ?case
    unfolding verdicts_def
    using ex_prefix_of[of \<pi>]
    by (auto elim!: order.strict_trans2 intro!: progress_le)
next
  case complete: (3 \<phi> \<pi> \<sigma> i v)
  from \<open>monitorable \<phi>\<close> obtain j where eval: "i < progress \<sigma> \<phi> j"
    unfolding less_eq_Suc_le
    using progress_ge by blast
  define j' where "j' = max (plen \<pi>) j"
  then have "plen \<pi> \<le> j'" by simp
  from eval have eval': "i < progress \<sigma> \<phi> j'"
    unfolding j'_def
    by (auto elim: order.strict_trans2 intro!: progress_mono)
  from complete(2) \<open>plen \<pi> \<le> j'\<close> have "\<pi> \<le> take_prefix j' \<sigma>"
  proof (transfer fixing: j', goal_cases prefix)
    case (prefix \<pi> \<sigma>)
    then have "stake j' \<sigma> = stake (length \<pi>) \<sigma> @ stake (j' - length \<pi>) (sdrop (length \<pi>) \<sigma>)"
      by (unfold stake_add) auto
    with \<open>stake (length \<pi>) \<sigma> = \<pi>\<close> show ?case
      by auto
  qed
  with complete(4) eval' show ?case using progress_prefix_conv[of "take_prefix j' \<sigma>" \<sigma> \<sigma>' \<phi> for \<sigma>']
    unfolding verdicts_def
    by (auto intro!: exI[where x="take_prefix j' \<sigma>"] complete(5)[rule_format] elim: prefix_of_antimono)
qed

locale monitor_timed_progress = monitor_pre_progress +
  assumes progress_time_conv: "\<forall>i<j. \<tau> \<sigma> i = \<tau> \<sigma>' i \<Longrightarrow> progress \<sigma> \<phi> j = progress \<sigma>' \<phi> j"
    and progress_sat_cong: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of \<pi> \<sigma>' \<Longrightarrow> i < progress \<sigma> \<phi> (plen \<pi>) \<Longrightarrow>
      MFOTL.sat \<sigma> v i \<phi> \<longleftrightarrow> MFOTL.sat \<sigma>' v i \<phi>"
begin

lemma progress_map_conv: "progress (map_\<Gamma> f \<sigma>) \<phi> j = progress (map_\<Gamma> g \<sigma>) \<phi> j"
  by (auto intro: progress_time_conv)

lemma progress_slice_conv: "progress (MFOTL.slice \<phi>' R \<sigma>) \<phi> j = progress (MFOTL.slice \<phi>' R' \<sigma>) \<phi> j"
  unfolding MFOTL.slice_def using progress_map_conv .

lemma progress_slice: "progress (MFOTL.slice \<phi> R \<sigma>) \<phi> j = progress \<sigma> \<phi> j"
  using progress_map_conv[where g=id] by (simp add: MFOTL.slice_def)

end

sublocale monitor_timed_progress \<subseteq> monitor_progress
  by (unfold_locales, auto intro: progress_time_conv \<tau>_prefix_conv)

lemma (in monitor_timed_progress) verdicts_alt:
  "verdicts \<phi> \<pi> = {(i, v). wf_tuple (MFOTL.nfv \<phi>) (MFOTL.fv \<phi>) v \<and>
    (\<exists>\<sigma>. prefix_of \<pi> \<sigma> \<and> i < progress \<sigma> \<phi> (plen \<pi>) \<and> MFOTL.sat \<sigma> (map the v) i \<phi>)}"
  unfolding verdicts_def
  using ex_prefix_of[of \<pi>]
  by (auto dest: progress_prefix_conv[of \<pi> _ _ \<phi>] elim!: progress_sat_cong[THEN iffD1, rotated -1])

sublocale monitor_timed_progress \<subseteq> slicable_monitor monitorable verdicts
proof
  fix S :: "'a list set" and v i \<phi> \<pi>
  assume *: "mem_restr S v"
  show "((i, v) \<in> verdicts \<phi> (MFOTL.pslice \<phi> S \<pi>)) = ((i, v) \<in> verdicts \<phi> \<pi>)" (is "?L = ?R")
  proof
    assume ?L
    with * show ?R unfolding verdicts_def
      by (auto simp: progress_slice fvi_less_nfv wf_tuple_def elim!: mem_restrE
        box_equals[OF sat_slice_iff sat_fvi_cong sat_fvi_cong, symmetric, THEN iffD1, rotated -1]
        dest: spec[of _ "MFOTL.slice \<phi> S _"] prefix_of_pslice_slice)
  next
    assume ?R
    with * show ?L unfolding verdicts_alt
      by (auto simp: progress_slice fvi_less_nfv wf_tuple_def elim!: mem_restrE
        box_equals[OF sat_slice_iff sat_fvi_cong sat_fvi_cong, symmetric, THEN iffD2, rotated -1]
        intro: exI[of _ "MFOTL.slice \<phi> S _"] prefix_of_pslice_slice)
  qed
qed

text \<open>Past-only Formulas.\<close>

fun past_only :: "'a MFOTL.formula \<Rightarrow> bool" where
  "past_only (MFOTL.Pred _ _) = True"
| "past_only (MFOTL.Eq _ _) = True"
| "past_only (MFOTL.Neg \<psi>) = past_only \<psi>"
| "past_only (MFOTL.Or \<alpha> \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (MFOTL.Exists \<psi>) = past_only \<psi>"
| "past_only (MFOTL.Prev _ \<psi>) = past_only \<psi>"
| "past_only (MFOTL.Next _ _) = False"
| "past_only (MFOTL.Since \<alpha> _ \<beta>) = (past_only \<alpha> \<and> past_only \<beta>)"
| "past_only (MFOTL.Until \<alpha> _ \<beta>) = False"

interpretation past_only_monitor: monitor_timed_progress past_only "\<lambda>\<sigma> \<phi> j. if past_only \<phi> then j else 0"
proof (unfold_locales, goal_cases)
  case (5 \<pi> \<sigma> \<sigma>' i \<phi> v)
  then have "past_only \<phi>" and "i < plen \<pi>" by (simp_all split: if_splits)
  then show ?case proof (induction \<phi> arbitrary: v i)
    case (Pred e ts)
    with \<Gamma>_prefix_conv[OF 5(1,2)] show ?case by simp
  next
    case (Prev I \<phi>)
    with \<tau>_prefix_conv[OF 5(1,2)] show ?case by (simp split: nat.split)
  next
    case (Since \<phi>1 I \<phi>2)
    with Since \<tau>_prefix_conv[OF 5(1,2)] show ?case by auto
  qed simp_all
qed auto

(*<*)
end
(*>*)


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: utp_circus_tutorial.thy                                              *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 18 Sep 2017 *)

section {* {\Circus} Tutorial *}

theory utp_circus_tutorial
imports "../theories/utp_circus" Transitive_Closure
begin recall_syntax

subsection {* Preliminaries *}

no_translations
  "a \<^bold>\<rightarrow> P" == "CONST PrefixCSP \<guillemotleft>a\<guillemotright> P"

translations
  "a \<^bold>\<rightarrow> P" == "CONST PrefixCSP \<guillemotleft>a()\<guillemotright> P"

paragraph \<open>Additional proof support\<close>

declare list_concat_minus_list_concat [simp]

lemma list_Cons_minus [simp]:
"(x # y) - (x # z) = y - z"
  by (simp add: minus_list_def)

subsection {* Time Types *}

text \<open>Below we define synonyms for the types \<open>TIME\<close> and \<open>PERIOD\<close>.\<close>

type_synonym TIME   = "nat"
type_synonym PERIOD = "nat"

subsection {* Channel Declarations *}

datatype timer_evt =
  setT "TIME" |
  updateSS "PERIOD" |
  step "TIME \<times> PERIOD" |
  endc "unit"

abbreviation timer_prefix ::
  "('a, timer_evt) chan \<Rightarrow>
   ('a, timer_evt + 'ext) chan" where
"timer_prefix c \<equiv> Inl o c"

notation timer_prefix ("tm:_" [1000] 1000)

abbreviation "tm_events \<equiv>
  \<epsilon>(tm:setT) \<union> \<epsilon>(tm:updateSS) \<union> \<epsilon>(tm:step) \<union> \<epsilon>(tm:endc)"

subsection {* Process Definition *}

alphabet timer_state =
  currentTime :: "TIME"
  stepSize :: "PERIOD"

type_synonym timer_action =
  "(timer_state, timer_evt) action"

definition [rdes]:
"process Timer(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(timer_state)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> currentTime :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> stepSize :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    (tm:step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
      currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) \<box>
    (&currentTime =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u tm:endc \<^bold>\<rightarrow> Stop) ;; Step
  \<bullet> (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

text \<open>The same process definition using deep variables.\<close>

definition [rdes]:
"process DvarTimer(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(vstore)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> <currentTime> :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> <stepSize> :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    (tm:step!(&<currentTime>)!(&<stepSize>) \<^bold>\<rightarrow>
      <currentTime> :=\<^sub>C min\<^sub>u(&<currentTime> + &<stepSize>, \<guillemotleft>tN\<guillemotright>)) \<box>
    (&<currentTime> =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u tm:endc \<^bold>\<rightarrow> Stop) ;; Step
  \<bullet> (<currentTime>, <stepSize>) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

text \<open>Proof that the @{const Timer} process does not diverge.\<close>

lemma "pre\<^sub>R(Timer(ct, hc, tN)) = true\<^sub>r"
apply (rdes_calc)
apply (rel_simp)
done

text \<open>Proof about the initial refusal set of the @{const Timer} process.\<close>

text \<open>
  Simplified encoding of the @{const Timer} process action. The simplification
  does not consider hiding of the state in the process semantics and neither
  uses the extensible event type. The @{const setT} communication is slightly
  more restrictive, requiring \<open>t < tN\<close> rather than \<open>t \<le> tN\<close>.
\<close>

definition StepBody :: "TIME \<Rightarrow> timer_action" where
"StepBody tN =
  (setT?(t : \<guillemotleft>t\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright>) \<^bold>\<rightarrow> currentTime :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
  (updateSS?(ss) \<^bold>\<rightarrow> stepSize :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
  (step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
    currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) \<box>
  (&currentTime =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u endc \<^bold>\<rightarrow> Stop"

fun MainAction :: "(TIME \<times> PERIOD \<times> TIME) \<Rightarrow> timer_action" where
"MainAction (ct, hc, tN) =
  (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; (\<mu>\<^sub>C Step \<bullet> StepBody(tN) ;; Step)"

text \<open>Additional lemma needed for the proof below.\<close>

lemma wpR_assign [wp]:
  assumes "P is NCSP"
  shows "($tr\<acute> =\<^sub>u $tr \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>S) wp\<^sub>R pre\<^sub>R P = \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> pre\<^sub>R(P)"
apply (simp add: wpR_def unrest rdes assms rea_not_not closure usubst)
done

text \<open>Communications on @{const setT} are initially not refused.\<close>

lemma StepBody_muI:
"[true \<turnstile> \<^bold>\<forall> t \<bullet> \<guillemotleft>t\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright> \<and> \<guillemotleft>trace\<guillemotright> =\<^sub>u \<langle>\<rangle> \<Rightarrow> (setT\<cdot>\<guillemotleft>t\<guillemotright>)\<^sub>u \<notin>\<^sub>u \<guillemotleft>refs\<guillemotright> | false]\<^sub>C
  \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> StepBody tN ;; X)"
apply (unfold StepBody_def)
apply (rule CRD_mu_basic_refine)
-- {* Subgoal 1 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 2 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 3 *}
apply (rdes_calc)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 5 *}
apply (rdes_calc)
apply (rel_auto)
done

text \<open>@{const setT} is only enabled when \<open>t < tN\<close>.\<close>

lemma StepBody_muI2:
"[true \<turnstile> \<^bold>\<forall> t \<bullet> \<guillemotleft>trace\<guillemotright> =\<^sub>u \<langle>(setT\<cdot>\<guillemotleft>t\<guillemotright>)\<^sub>u\<rangle> \<Rightarrow> \<guillemotleft>t\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright> | false]\<^sub>C
  \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> StepBody tN ;; X)"
apply (unfold StepBody_def)
apply (rule CRD_mu_basic_refine)
-- {* Subgoal 1 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 2 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 3 *}
apply (rdes_calc)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 5 *}
apply (rdes_calc)
apply (rel_auto)
done

thm CRD_mu_basic_refine -- \<open>TODO: Ask Simon to explain the 5th proviso!\<close>

lemma StepBody_muI3:
"[true \<turnstile> \<^bold>\<forall> (ct, ss) \<bullet> \<guillemotleft>ct\<guillemotright> <\<^sub>u \<guillemotleft>tN\<guillemotright> \<and>
    \<guillemotleft>trace\<guillemotright> =\<^sub>u \<langle>(setT\<cdot>\<guillemotleft>ct\<guillemotright>)\<^sub>u, (updateSS\<cdot>\<guillemotleft>ss\<guillemotright>)\<^sub>u\<rangle> \<Rightarrow> (step\<cdot>\<guillemotleft>(ct, ss)\<guillemotright>)\<^sub>u \<notin>\<^sub>u \<guillemotleft>refs\<guillemotright>
 | false]\<^sub>C
 \<sqsubseteq> (\<mu>\<^sub>C X \<bullet> StepBody tN ;; X)"
apply (unfold StepBody_def)
apply (rule CRD_mu_basic_refine)
-- {* Subgoal 1 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 2 *}
apply (simp add: closure unrest alpha)
-- {* Subgoal 3 *}
apply (rdes_calc)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 5 *}
apply (rdes_calc)
apply (rel_simp)
apply (erule prefixE)
apply (auto)
oops

text \<open>A simpler version of \<open>Timer\<close> with fewer communications and no recursion.\<close>

definition [rdes]:
"process SimpleTimer(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(timer_state)
  Step = (
    (step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
      currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) \<box>
    (&currentTime =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u endc \<^bold>\<rightarrow> Stop)
  \<bullet> (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

lemma
"SimpleTimer(ct, hc, tN) \<sqsubseteq> step!(\<guillemotleft>ct\<guillemotright>)!(\<guillemotleft>hc\<guillemotright>) \<^bold>\<rightarrow> Skip"
apply (unfold SimpleTimer_def)
apply (unfold circus_syntax)
apply (simp add: Let_def)
apply (rule_tac SRD_refine_intro)
-- {* Subgoal 1 *}
apply (simp add: closure)
-- {* Subgoal 2 *}
apply (simp add: closure)
-- {* Subgoal 3 *}
apply (rdes_calc)
apply (rel_simp)
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
apply (erule_tac Q = "endc () \<in> ref\<^sub>v" in contrapos_pp)
apply (simp) defer
-- {* Subgoal 4 *}
apply (rdes_calc)
apply (rel_simp)
oops

method rdes_refine_auto =
  (rule_tac SRD_refine_intro;
    (simp add: closure rdes unrest usubst; (rdes_calc, rel_auto?)))

lemma
"ct < tN \<Longrightarrow> SimpleTimer(ct, hc, tN) \<sqsubseteq> step!(\<guillemotleft>ct\<guillemotright>)!(\<guillemotleft>hc\<guillemotright>) \<^bold>\<rightarrow> Skip"
apply (unfold SimpleTimer_def)
apply (unfold circus_syntax)
apply (simp add: Let_def)
apply (rdes_refine_auto)
done

text \<open>Simpler version of the Timer communicating only on channel @{const step}.\<close>

definition [rdes]: -- \<open>@{const Timer} with only @{const step} recursion\<close>
"process SimpleTimer2(ct::TIME, hc::PERIOD, tN::TIME) \<triangleq> begin
  state(timer_state)
  Step = (step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
    currentTime :=\<^sub>C min\<^sub>u(&currentTime + &stepSize, \<guillemotleft>tN\<guillemotright>)) ;; Step
  \<bullet> (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

text \<open>Let us try proving something about @{const step} events.\<close>

lemma "`peri\<^sub>R(SimpleTimer2(ct, hc, tN)) \<and> $tr =\<^sub>u $tr\<acute> \<Rightarrow> \<guillemotleft>step(ct, hc)\<guillemotright> \<notin>\<^sub>u $ref\<acute>`"
apply (rdes_calc)
apply (rel_simp)
apply (erule_tac Q = "step (ct, hc) \<in> ref\<^sub>v" in contrapos_pp; simp)
apply (subgoal_tac "currentTime\<^sub>v' = ct \<and> stepSize\<^sub>v' = hc")
-- {* Subgoal 1 *}
apply (clarsimp)
-- {* Subgoal 2 *}
apply (thin_tac "\<not> step (currentTime\<^sub>v', stepSize\<^sub>v') \<in> ref\<^sub>v")
apply (rename_tac n)
apply (case_tac "n = 0")
-- {* Subgoal 2.1 *}
apply (clarsimp)
-- {* Subgoal 2.2 *}
apply (clarify)
apply (erule contrapos_pp; simp)
-- \<open>@{command sledgehammer}\<close>
-- \<open>We need additional lemmas here to make progress..!\<close>
oops

lemma nat_one_induct:
"0 < n \<Longrightarrow> (P 1 \<Longrightarrow> (\<And>n. P n \<Longrightarrow> P (Suc n)) \<Longrightarrow> P n)"
apply (induction n)
apply (simp_all)
apply (blast)
done

lemma tr_in_relpow_grows:
"0 < n \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 (tr1::'\<epsilon> list) (tr2::'\<epsilon> list) (st1::'\<sigma>) (st2::'\<sigma>)
    (ref1::'\<epsilon> set) (ref2::'\<epsilon> set).
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr1, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr2, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<in> r \<longrightarrow>
    tr1 < tr2) \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 (tr1::'\<epsilon> list) (tr2::'\<epsilon> list) (st1::'\<sigma>) (st2::'\<sigma>)
    (ref1::'\<epsilon> set) (ref2::'\<epsilon> set).
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr1, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr2, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<in> (r ^^ n)
  \<longrightarrow> tr1 < tr2)"
apply (erule nat_one_induct)
apply (simp_all)
apply (clarsimp)
apply (case_tac y)
apply (case_tac more)
apply (case_tac morea)
apply (case_tac moreb)
apply (clarsimp)
using dual_order.strict_trans by (blast)

lemma empty_trace_neq_relpowI [rule_format]:
"0 < n \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 (tr1::'\<epsilon> list) (tr2::'\<epsilon> list) (st1::'\<sigma>) (st2::'\<sigma>)
    (ref1::'\<epsilon> set) (ref2::'\<epsilon> set).
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr1, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr2, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<in> r \<longrightarrow>
    tr1 < tr2) \<Longrightarrow>
  (\<forall>ok1 ok2 wait1 wait2 tr st1 st2 ref1 ref2.
    (\<lparr>ok\<^sub>v = ok1, wait\<^sub>v = wait1, tr\<^sub>v = tr, st\<^sub>v = st1, ref\<^sub>v = ref1\<rparr>,
     \<lparr>ok\<^sub>v = ok2, wait\<^sub>v = wait2, tr\<^sub>v = tr, st\<^sub>v = st2, ref\<^sub>v = ref2\<rparr>) \<notin> (r ^^ n))"
apply (drule_tac tr_in_relpow_grows)
apply (assumption)
apply (clarsimp)
apply (subgoal_tac "tr < tr")
apply (clarsimp)
apply (blast)
done

text \<open>Let us try again with those two lemmas above.\<close>

lemma "`peri\<^sub>R(SimpleTimer2(ct, hc, tN)) \<and> $tr =\<^sub>u $tr\<acute> \<Rightarrow> \<guillemotleft>step(ct, hc)\<guillemotright> \<notin>\<^sub>u $ref\<acute>`"
apply (rdes_calc)
apply (rel_simp)
apply (erule_tac Q = "step (ct, hc) \<in> ref\<^sub>v" in contrapos_pp; simp)
apply (subgoal_tac "currentTime\<^sub>v' = ct \<and> stepSize\<^sub>v' = hc")
-- {* Subgoal 1 *}
apply (clarsimp)
-- {* Subgoal 2 *}
apply (thin_tac "\<not> step (currentTime\<^sub>v', stepSize\<^sub>v') \<in> ref\<^sub>v")
apply (rename_tac n)
apply (case_tac "n = 0")
-- {* Subgoal 2.1 *}
apply (clarsimp)
-- {* Subgoal 2.2 *}
apply (clarify)
apply (erule contrapos_pp; simp)
apply (erule empty_trace_neq_relpowI)
apply (clarsimp)
apply (simp add: Prefix_Order.strict_prefixI')
done
end


section\<open>Abstract ITE Implementation\<close>
theory Abstract_Impl
imports BDT
        Automatic_Refinement.Refine_Lib
        Option_Helpers
begin

datatype ('a, 'ni) IFEXD = TD | FD | IFD 'a 'ni 'ni

locale bdd_impl_pre =
  fixes R :: "'s \<Rightarrow> ('ni \<times> ('a :: linorder) ifex) set"
  fixes I :: "'s \<Rightarrow> bool"
begin
  definition les:: "'s \<Rightarrow> 's \<Rightarrow> bool" where
  "les s s' == \<forall>ni n. (ni, n) \<in> R s \<longrightarrow> (ni, n) \<in> R s'"
end

locale bdd_impl = bdd_impl_pre R for R :: "'s \<Rightarrow> ('ni \<times> ('a :: linorder) ifex) set" +
  fixes Timpl :: "'s \<rightharpoonup> ('ni \<times> 's)"
  fixes Fimpl :: "'s \<rightharpoonup> ('ni \<times> 's)"
  fixes IFimpl :: "'a \<Rightarrow> 'ni \<Rightarrow> 'ni \<Rightarrow> 's \<rightharpoonup> ('ni \<times> 's)"
  fixes DESTRimpl :: "'ni  \<Rightarrow> 's \<rightharpoonup> ('a, 'ni) IFEXD"

  assumes Timpl_rule: "I s \<Longrightarrow> ospec (Timpl s) (\<lambda>(ni, s'). (ni, Trueif) \<in> R s' \<and> I s' \<and> les s s')"
  assumes Fimpl_rule: "I s \<Longrightarrow> ospec (Fimpl s) (\<lambda>(ni, s'). (ni, Falseif) \<in> R s' \<and> I s' \<and> les s s')"
  assumes IFimpl_rule: "\<lbrakk>I s; (ni1,n1) \<in> R s;(ni2,n2) \<in> R s\<rbrakk>
                        \<Longrightarrow> ospec (IFimpl v ni1 ni2 s) (\<lambda>(ni, s'). (ni, IFC v n1 n2) \<in> R s' \<and> I s' \<and> les s s')"

  assumes DESTRimpl_rule1: "I s \<Longrightarrow> (ni, Trueif) \<in> R s \<Longrightarrow> ospec (DESTRimpl ni s) (\<lambda>r. r = TD)"
  assumes DESTRimpl_rule2: "I s \<Longrightarrow> (ni, Falseif) \<in> R s \<Longrightarrow> ospec (DESTRimpl ni s) (\<lambda>r. r = FD)"
  assumes DESTRimpl_rule3: "I s \<Longrightarrow> (ni, IF v n1 n2) \<in> R s \<Longrightarrow>
                            ospec (DESTRimpl ni s)
                                  (\<lambda>r. \<exists>ni1 ni2. r = (IFD v ni1 ni2) \<and> (ni1, n1) \<in> R s \<and> (ni2, n2) \<in> R s)"
begin

lemma les_refl[simp,intro!]:"les s s" by (auto simp add: les_def)
lemma les_trans[trans]:"les s1 s2 \<Longrightarrow> les s2 s3 \<Longrightarrow> les s1 s3" by (auto simp add: les_def)
lemmas DESTRimpl_rules = DESTRimpl_rule1 DESTRimpl_rule2 DESTRimpl_rule3

lemma DESTRimpl_rule_useless:
  "I s \<Longrightarrow> (ni, n) \<in> R s \<Longrightarrow> ospec (DESTRimpl ni s) (\<lambda>r. (case r of
    TD \<Rightarrow> (ni, Trueif) \<in> R s |
    FD \<Rightarrow> (ni, Falseif) \<in> R s |
    IFD v nt ne \<Rightarrow> (\<exists>t e. n = IF v t e \<and> (ni, IF v t e) \<in> R s)))"
by(cases n; clarify; drule (1) DESTRimpl_rules; drule ospecD2; clarsimp)
lemma DESTRimpl_rule:
  "I s \<Longrightarrow> (ni, n) \<in> R s \<Longrightarrow> ospec (DESTRimpl ni s) (\<lambda>r. (case n of
    Trueif \<Rightarrow> r = TD |
    Falseif \<Rightarrow> r = FD |
    IF v t e \<Rightarrow> (\<exists>tn en. r = IFD v tn en \<and> (tn,t) \<in> R s \<and> (en,e) \<in> R s)))"
by(cases n; clarify; drule (1) DESTRimpl_rules; drule ospecD2; clarsimp)

definition "case_ifexi fti ffi fii ni s \<equiv> do {
  dest \<leftarrow> DESTRimpl ni s;
  case dest of
    TD \<Rightarrow> fti s
  | FD \<Rightarrow> ffi s
  | IFD v ti ei \<Rightarrow> fii v ti ei s}"

lemma case_ifexi_rule:
  assumes INV: "I s"
  assumes NI: "(ni,n)\<in>R s"
  assumes FTI: "\<lbrakk> n = Trueif \<rbrakk> \<Longrightarrow> ospec (fti s) (\<lambda>(r,s'). (r,ft) \<in> Q s \<and> I' s')"
  assumes FFI: "\<lbrakk> n = Falseif \<rbrakk> \<Longrightarrow> ospec (ffi s) (\<lambda>(r,s'). (r,ff) \<in> Q s \<and> I' s')"
  assumes FII: "\<And>ti ei v t e. \<lbrakk> n = IF v t e; (ti,t)\<in>R s; (ei,e)\<in>R s \<rbrakk> \<Longrightarrow> ospec (fii v ti ei s) (\<lambda>(r,s'). (r,fi v t e) \<in> Q s \<and> I' s')"
  shows "ospec (case_ifexi fti ffi fii ni s) (\<lambda>(r,s'). (r,case_ifex ft ff fi n) \<in> Q s \<and> I' s')"
  unfolding case_ifexi_def
  apply (cases n)
    subgoal
      apply (rule obind_rule)
       apply (rule DESTRimpl_rule1[OF INV])
       using NI FTI by (auto)
    subgoal
      apply (rule obind_rule)
       apply (rule DESTRimpl_rule2[OF INV])
       using NI FFI by (auto)
    subgoal
      apply (rule obind_rule)
       apply (rule DESTRimpl_rule3[OF INV])
       using NI FII by (auto)
done

abbreviation "return x \<equiv> \<lambda>s. Some (x,s)"

primrec lowest_tops_impl where
"lowest_tops_impl [] s = Some (None,s)" |
"lowest_tops_impl (e#es) s =
    case_ifexi
      (\<lambda>s. lowest_tops_impl es s)
      (\<lambda>s. lowest_tops_impl es s)
      (\<lambda>v t e s. do {
      (rec,s) \<leftarrow> lowest_tops_impl es s;
        (case rec of
          Some u \<Rightarrow> Some ((Some (min u v)), s) |
          None \<Rightarrow> Some ((Some v), s))
       }) e s"

declare lowest_tops_impl.simps[simp del]

fun lowest_tops_alt where
"lowest_tops_alt [] = None" |
"lowest_tops_alt (e#es) = (
    let rec = lowest_tops_alt es in
    case_ifex
      rec
      rec
      (\<lambda>v t e. (case rec of
          Some u \<Rightarrow> (Some (min u v)) |
          None \<Rightarrow> (Some v))
       ) e
  )"

lemma lowest_tops_alt: "lowest_tops l = lowest_tops_alt l"
  by (induction l rule: lowest_tops.induct) (auto split: option.splits simp: lowest_tops.simps)

lemma lowest_tops_impl_R:
  assumes "list_all2 (in_rel (R s)) li l" "I s"
  shows "ospec (lowest_tops_impl li s) (\<lambda>(r,s'). r = lowest_tops l \<and> s'=s)"
  unfolding lowest_tops_alt
  using assms apply (induction rule: list_all2_induct)
   subgoal by (simp add: lowest_tops_impl.simps)
   subgoal
     apply (simp add: lowest_tops_impl.simps)
     apply (rule case_ifexi_rule[where Q="\<lambda>s. Id", unfolded pair_in_Id_conv])
      apply assumption+
     apply (rule obind_rule)
      apply assumption
     apply (clarsimp split: option.splits)
    done
  done

definition restrict_top_impl where
"restrict_top_impl e vr vl s =
  case_ifexi
    (return e)
    (return e)
    (\<lambda>v te ee. return (if v = vr then (if vl then te else ee) else e))
    e s
  "

lemma restrict_top_alt: "restrict_top n var val = (case n of
  (IF v t e) \<Rightarrow> (if v = var then (if val then t else e) else (IF v t e))
| _ \<Rightarrow> n)"
  apply (induction n var val rule: restrict_top.induct)
  apply (simp_all)
  done

lemma restrict_top_impl_spec: "I s \<Longrightarrow> (ni,n) \<in> R s \<Longrightarrow> ospec (restrict_top_impl ni vr vl s) (\<lambda>(res,s'). (res, restrict_top n vr vl) \<in> R s \<and> s'=s)"
  unfolding restrict_top_impl_def restrict_top_alt
  by (rule case_ifexi_rule[where I'="\<lambda>s'. s'=s" and Q="R", simplified]) auto

partial_function(option) ite_impl where
"ite_impl i t e s = do {
  (lt,_) \<leftarrow> lowest_tops_impl [i, t, e] s;
  (case lt of
    Some a \<Rightarrow> do {
      (ti,_) \<leftarrow> restrict_top_impl i a True s;
      (tt,_) \<leftarrow> restrict_top_impl t a True s;
      (te,_) \<leftarrow> restrict_top_impl e a True s;
      (fi,_) \<leftarrow> restrict_top_impl i a False s;
      (ft,_) \<leftarrow> restrict_top_impl t a False s;
      (fe,_) \<leftarrow> restrict_top_impl e a False s;
      (tb,s) \<leftarrow> ite_impl ti tt te s;
      (fb,s) \<leftarrow> ite_impl fi ft fe s;
      IFimpl a tb fb s}
  | None \<Rightarrow> case_ifexi (\<lambda>_.(Some (t,s))) (\<lambda>_.(Some (e,s))) (\<lambda>_ _ _ _. None) i s
)}"

lemma ite_impl_R: "I s
       \<Longrightarrow> in_rel (R s) ii i \<Longrightarrow> in_rel (R s) ti t \<Longrightarrow> in_rel (R s) ei e
       \<Longrightarrow> ospec (ite_impl ii ti ei s) (\<lambda>(r, s'). (r, ifex_ite i t e) \<in> R s' \<and> I s' \<and> les s s')"
proof(induction i t e arbitrary: s ii ti ei rule: ifex_ite.induct, goal_cases)
  case (1 i t e s ii ti ei) note goal1 = 1
  have la2: "list_all2 (in_rel (R s)) [ii,ti,ei] [i,t,e]" using goal1(4-6) by simp
  show ?case proof(cases "lowest_tops [i,t,e]")
    case None from goal1(3-6) show ?thesis
        apply(subst ite_impl.simps)
        apply(rule obind_rule[where Q="\<lambda>(r, s'). r = lowest_tops [i,t,e] \<and> s'=s"])
         apply(rule ospec_cons)
          apply(rule lowest_tops_impl_R[OF la2])
          apply(assumption)
         apply(clarsimp split: prod.splits)
        apply(simp add: None split: prod.splits)
        apply(clarsimp)
        apply(rule ospec_cons)
         apply(rule case_ifexi_rule[where I'="\<lambda>s'. s'=s"])
        using None by (auto split: prod.splits ifex.splits simp: lowest_tops.simps)
    next
    case (Some lv)
      note mIH = goal1(1,2)[OF Some]
      from goal1(3-6) show ?thesis
        apply(subst ite_impl.simps)
        apply(rule obind_rule[where Q="\<lambda>(r, s'). r = lowest_tops [i,t,e]"])
         apply(rule ospec_cons)
          apply(rule lowest_tops_impl_R[OF la2])
          apply(assumption)
         apply(clarsimp split: prod.splits)
        apply(simp add: Some split: prod.splits)
        apply(clarsimp)
        (* take care of all those restrict_tops *)
        apply(rule obind_rule, rule restrict_top_impl_spec, assumption+, clarsimp split: prod.splits)+
        apply(rule obind_rule)
         apply(rule mIH(1))
            apply(simp;fail)+
        apply(clarsimp)
        apply(rule obind_rule)
         apply(rule mIH(2))
            apply(simp add: les_def;fail)+
        apply(simp split: prod.splits)
        apply(rule ospec_cons)
         apply(rule IFimpl_rule)
           apply(simp add: les_def;fail)+
           using les_def les_trans by blast+
    qed
qed

lemma case_ifexi_mono[partial_function_mono]:
  assumes [partial_function_mono]:
    "mono_option (\<lambda>F. fti F s)"
    "mono_option (\<lambda>F. ffi F s)"
    "\<And>x31 x32 x33. mono_option (\<lambda>F. fii F x31 x32 x33 s)"
  shows "mono_option (\<lambda>F. case_ifexi (fti F) (ffi F) (fii F) ni s)"
  unfolding case_ifexi_def by (tactic \<open>Partial_Function.mono_tac @{context} 1\<close>)

partial_function(option) val_impl :: "'ni \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> (bool\<times>'s) option"
where
"val_impl e ass s = case_ifexi
  (\<lambda>s. Some (True,s))
  (\<lambda>s. Some (False,s))
  (\<lambda>v t e s. val_impl (if ass v then t else e) ass s)
  e  s"

lemma "I s \<Longrightarrow> (ni,n) \<in> R s \<Longrightarrow> ospec (val_impl ni ass s) (\<lambda>(r,s'). r = (val_ifex n ass) \<and> s'=s)"
  apply (induction n arbitrary: ni)
  subgoal
   apply (subst val_impl.simps)
   apply (rule ospec_cons)
    apply (rule case_ifexi_rule[where I'="\<lambda>s'. s'=s" and Q="\<lambda>s. Id"]; assumption?)
      by auto
  subgoal
   apply (subst val_impl.simps)
   apply (rule ospec_cons)
    apply (rule case_ifexi_rule[where I'="\<lambda>s'. s'=s" and Q="\<lambda>s. Id"]; assumption?)
      by auto
  subgoal
   apply (subst val_impl.simps)
   apply (subst val_ifex.simps)
   apply (clarsimp; intro impI conjI)
    apply (rule ospec_cons)
     apply (rule case_ifexi_rule[where I'="\<lambda>s'. s'=s" and Q="\<lambda>s. Id"]; assumption?)
       apply (simp; fail)
      apply (simp; fail)
     apply (rule ospec_cons)
      apply (rprems; simp; fail)
     apply (simp; fail)
    apply (simp; fail)
   apply (rule ospec_cons)
    apply (rule case_ifexi_rule[where I'="\<lambda>s'. s'=s" and Q="\<lambda>s. Id"]; assumption?)
      apply (simp; fail)
     apply (simp; fail)
    apply(simp)
    apply (rule ospec_cons)
     apply (rprems; simp; fail)
    apply (simp; fail)
   apply (simp; fail)
   done
  done

end

locale bdd_impl_cmp_pre = bdd_impl_pre
begin

definition "map_invar_impl m s =
  (\<forall>ii ti ei ri. m (ii,ti,ei) = Some ri \<longrightarrow>
  (\<exists>i t e. ((ri,ifex_ite_opt i t e) \<in> R s) \<and> (ii,i) \<in> R s \<and> (ti,t) \<in> R s \<and> (ei,e) \<in> R s))"

lemma map_invar_impl_les: "map_invar_impl m s \<Longrightarrow> les s s' \<Longrightarrow> map_invar_impl m s'"
  unfolding map_invar_impl_def bdd_impl_pre.les_def by blast

lemma map_invar_impl_update: "map_invar_impl m s \<Longrightarrow>
       (ii,i) \<in> R s \<Longrightarrow> (ti,t) \<in> R s \<Longrightarrow> (ei,e) \<in> R s \<Longrightarrow>
       (ri, ifex_ite_opt i t e) \<in> R s \<Longrightarrow> map_invar_impl (m((ii,ti,ei) \<mapsto> ri)) s"
unfolding map_invar_impl_def by auto

end

locale bdd_impl_cmp = bdd_impl + bdd_impl_cmp_pre +
  fixes M :: "'a \<Rightarrow> ('b \<times> 'b \<times> 'b) \<Rightarrow> 'b option"
  fixes U :: "'a \<Rightarrow> ('b \<times> 'b \<times> 'b) \<Rightarrow> 'b \<Rightarrow> 'a"
  fixes cmp :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  assumes cmp_rule1: "I s \<Longrightarrow> (ni, i) \<in> R s \<Longrightarrow> (ni', i) \<in> R s \<Longrightarrow> cmp ni ni'"
  assumes cmp_rule2: "I s \<Longrightarrow> cmp ni ni' \<Longrightarrow> (ni, i) \<in> R s \<Longrightarrow> (ni', i') \<in> R s \<Longrightarrow> i = i'"
  assumes map_invar_rule1: "I s \<Longrightarrow> map_invar_impl (M s) s"
  assumes map_invar_rule2: "I s \<Longrightarrow> (ii,it) \<in> R s \<Longrightarrow> (ti,tt) \<in> R s \<Longrightarrow> (ei,et) \<in> R s \<Longrightarrow>
                            (ri, ifex_ite_opt it tt et) \<in> R s \<Longrightarrow> U s (ii,ti,ei) ri = s' \<Longrightarrow>
                            I s'"
  assumes map_invar_rule3: "I s \<Longrightarrow> R (U s (ii, ti, ei) ri) = R s"
begin

lemma cmp_rule_eq: "I s \<Longrightarrow>  (ni, i) \<in> R s \<Longrightarrow> (ni', i') \<in> R s \<Longrightarrow> cmp ni ni' \<longleftrightarrow> i = i'"
  using cmp_rule1 cmp_rule2 by force

lemma DESTRimpl_Some: "I s \<Longrightarrow> (ni, i) \<in> R s \<Longrightarrow> ospec (DESTRimpl ni s) (\<lambda>r. True)"
  apply(cases i)
    apply(auto intro: ospec_cons dest: DESTRimpl_rules)
done

fun param_opt_impl where
  "param_opt_impl i t e s =  do {
    ii \<leftarrow> DESTRimpl i s;
    ti \<leftarrow> DESTRimpl t s;
    ei \<leftarrow> DESTRimpl e s;
    (tn,s) \<leftarrow> Timpl s;
    (fn,s) \<leftarrow> Fimpl s;
    Some ((if ii = TD then Some t else
    if ii = FD then Some e else
    if ti = TD \<and> ei = FD then Some i else
    if cmp t e then Some t else
    if ei = TD \<and> cmp i t then Some tn else
    if ti = FD \<and> cmp i e then Some fn else
    None), s)}"

declare param_opt_impl.simps[simp del]

lemma param_opt_impl_lesI:
  assumes "I s" "(ii,i) \<in> R s" "(ti,t) \<in> R s" "(ei,e) \<in> R s"
  shows "ospec (param_opt_impl ii ti ei s)
               (\<lambda>(r,s'). I s' \<and> les s s')"
  using assms apply(subst param_opt_impl.simps)
  by (auto simp add: param_opt_def les_def intro!: obind_rule
                dest: DESTRimpl_Some Timpl_rule Fimpl_rule)

lemma param_opt_impl_R:
  assumes "I s" "(ii,i) \<in> R s" "(ti,t) \<in> R s" "(ei,e) \<in> R s"
  shows "ospec (param_opt_impl ii ti ei s)
               (\<lambda>(r,s'). case r of None \<Rightarrow> param_opt i t e = None
                                 | Some r \<Rightarrow> (\<exists>r'. param_opt i t e  = Some r' \<and> (r, r') \<in> R s'))"
  using assms apply(subst param_opt_impl.simps)
  apply(rule obind_rule)
   apply(rule DESTRimpl_rule; assumption)
  apply(rule obind_rule)
   apply(rule DESTRimpl_rule; assumption)
  apply(rule obind_rule)
   apply(rule DESTRimpl_rule; assumption)
  apply(rule obind_rule)
   apply(rule Timpl_rule; assumption)
  apply(safe)
  apply(rule obind_rule)
   apply(rule Fimpl_rule; assumption)
  by (auto simp add: param_opt_def les_def cmp_rule_eq split: ifex.splits)

partial_function(option) ite_impl_opt where
"ite_impl_opt i t e s = do {
  (ld, s) \<leftarrow>  param_opt_impl i t e s;
  (case ld of Some b \<Rightarrow> Some (b, s) |
  None \<Rightarrow>
  do {
  (lt,_) \<leftarrow> lowest_tops_impl [i, t, e] s;
  (case lt of
    Some a \<Rightarrow> do {
      (ti,_) \<leftarrow> restrict_top_impl i a True s;
      (tt,_) \<leftarrow> restrict_top_impl t a True s;
      (te,_) \<leftarrow> restrict_top_impl e a True s;
      (fi,_) \<leftarrow> restrict_top_impl i a False s;
      (ft,_) \<leftarrow> restrict_top_impl t a False s;
      (fe,_) \<leftarrow> restrict_top_impl e a False s;
      (tb,s) \<leftarrow> ite_impl_opt ti tt te s;
      (fb,s) \<leftarrow> ite_impl_opt fi ft fe s;
      IFimpl a tb fb s}
  | None \<Rightarrow> case_ifexi (\<lambda>_.(Some (t,s))) (\<lambda>_.(Some (e,s))) (\<lambda>_ _ _ _. None) i s
)})}"

lemma ospec_and: "ospec f P \<Longrightarrow> ospec f Q \<Longrightarrow> ospec f (\<lambda>x. P x \<and> Q x)"
  using ospecD2 by force

lemma ite_impl_opt_R: "
  I s
  \<Longrightarrow> in_rel (R s) ii i \<Longrightarrow> in_rel (R s) ti t \<Longrightarrow> in_rel (R s) ei e
  \<Longrightarrow> ospec (ite_impl_opt ii ti ei s) (\<lambda>(r, s'). (r, ifex_ite_opt i t e) \<in> R s' \<and> I s' \<and> les s s')"
proof(induction i t e arbitrary: s ii ti ei rule: ifex_ite_opt.induct, goal_cases)
  note ifex_ite_opt.simps[simp del] restrict_top.simps[simp del]
  case (1 i t e s ii ti ei) note goal1 = 1
  have la2: "list_all2 (in_rel (R s)) [ii,ti,ei] [i,t,e]" using goal1(4-6) by simp
  note mIH = goal1(1,2)
  from goal1(3-6) show ?case
    apply(cases "param_opt i t e")
     defer
     apply(subst ite_impl_opt.simps)
      apply(rule obind_rule)
       apply(rule ospec_and[OF param_opt_impl_R param_opt_impl_lesI])
             apply(auto simp add: les_def ifex_ite_opt.simps split: option.splits)[9]
    (* param_opt i t e = None *)
    apply(frule param_opt_lowest_tops_lem)
    apply(clarsimp)
    apply(subst ite_impl_opt.simps)
     apply(rule obind_rule)
     apply(rule ospec_and[OF param_opt_impl_R param_opt_impl_lesI])
            apply(auto split: option.splits)[8]
    apply(clarsimp split: option.splits)
    apply(rule obind_rule[where Q="\<lambda>(r, s'). r = lowest_tops [i,t,e]"])
     apply(rule ospec_cons)
      apply(rule lowest_tops_impl_R)
       using les_def apply(fastforce)
      apply(assumption)
     apply(fastforce)
    using BDT.param_opt_lowest_tops_lem apply(clarsimp split: prod.splits)
    (* take care of all those restrict_tops *)
    apply(rule obind_rule, rule restrict_top_impl_spec, assumption, auto simp add: les_def split: prod.splits)+
    apply(rule obind_rule)
     apply(rule mIH(1))
          apply(simp add: les_def;fail)+
    apply(clarsimp)
     apply(rule obind_rule)
     apply(rule mIH(2))
          apply(simp add: les_def;fail)+
    apply(simp add: ifex_ite_opt.simps split: prod.splits)
    apply(rule ospec_cons)
     apply(rule IFimpl_rule)
       apply(auto simp add: les_def;fail)+
    done
qed

partial_function(option) ite_impl_lu where
"ite_impl_lu i t e s = do {
  (case M s (i,t,e) of Some b \<Rightarrow> Some (b,s) | None \<Rightarrow> do {
  (ld, s) \<leftarrow>  param_opt_impl i t e s;
  (case ld of Some b \<Rightarrow> Some (b, s) |
  None \<Rightarrow>
  do {
  (lt,_) \<leftarrow> lowest_tops_impl [i, t, e] s;
  (case lt of
    Some a \<Rightarrow> do {
      (ti,_) \<leftarrow> restrict_top_impl i a True s;
      (tt,_) \<leftarrow> restrict_top_impl t a True s;
      (te,_) \<leftarrow> restrict_top_impl e a True s;
      (fi,_) \<leftarrow> restrict_top_impl i a False s;
      (ft,_) \<leftarrow> restrict_top_impl t a False s;
      (fe,_) \<leftarrow> restrict_top_impl e a False s;
      (tb,s) \<leftarrow> ite_impl_lu ti tt te s;
      (fb,s) \<leftarrow> ite_impl_lu fi ft fe s;
      (r,s) \<leftarrow> IFimpl a tb fb s;
      let s = U s (i,t,e) r;
      Some (r,s)
      } |
    None \<Rightarrow> None
)})})}"

declare ifex_ite_opt.simps[simp del]

lemma ite_impl_lu_R: "I s
       \<Longrightarrow> (ii,i) \<in> R s \<Longrightarrow> (ti,t) \<in> R s \<Longrightarrow> (ei,e) \<in> R s
       \<Longrightarrow> ospec (ite_impl_lu ii ti ei s)
                 (\<lambda>(r, s'). (r, ifex_ite_opt i t e) \<in> R s' \<and> I s' \<and> les s s')"
proof(induction i t e arbitrary: s ii ti ei rule: ifex_ite_opt.induct, goal_cases)
  note restrict_top.simps[simp del]
  case (1 i t e s ii ti ei) note goal1 = 1
  have la2: "list_all2 (in_rel (R s)) [ii,ti,ei] [i,t,e]" using goal1(4-6) by simp
  note mIH = goal1(1,2)
  from goal1(3-6) show ?case
    apply(subst ite_impl_lu.simps)
    apply(cases "M s (ii, ti, ei)")
     defer
     (* M s (ii, ti, ei) = Some a *)
     apply(frule map_invar_rule1)
     apply(simp only: option.simps ospec.simps prod.simps simp_thms les_refl)
     apply(subst (asm) map_invar_impl_def)
     apply(erule allE[where x = ii])
     apply(erule allE[where x = ti])
     apply(erule allE[where x = ei])
     apply(rename_tac a)
     apply(erule_tac x = a in allE)
     apply(metis cmp_rule_eq)
    (* M s (ii, ti, ei) = Some a *)
    apply(clarsimp)
    apply(cases "param_opt i t e")
     defer
     (* param_opt i t e = Some a *)
     apply(rule obind_rule)
      apply(rule ospec_and[OF param_opt_impl_R param_opt_impl_lesI])
             apply(auto simp add: map_invar_impl_les ifex_ite_opt.simps  split: option.splits)[9]
    (* param_opt i t e = None *)
    apply(frule param_opt_lowest_tops_lem)
    apply(clarsimp)
    apply(rule obind_rule)
     apply(rule ospec_and[OF param_opt_impl_R param_opt_impl_lesI])
             apply(auto split: option.splits)[8]
    apply(clarsimp split: option.splits)
    apply(rule_tac obind_rule[where Q="\<lambda>(r, s'). r = lowest_tops [i,t,e]"])
     apply(rule ospec_cons)
      apply(rule lowest_tops_impl_R)
       using les_def apply(fastforce)
      apply(assumption)
     apply(fastforce)
    using BDT.param_opt_lowest_tops_lem apply(clarsimp split: prod.splits)
    apply(rule obind_rule, rule restrict_top_impl_spec, assumption+, auto simp add: les_def split: prod.splits)+
    apply(rule obind_rule)
     apply(rule mIH(1))
          apply(simp add: map_invar_impl_les les_def;fail)+
    apply(clarsimp)
    apply(rule obind_rule)
     apply(rule mIH(2))
          apply(simp add: map_invar_impl_les les_def;fail)+
    apply(simp add: ifex_ite_opt.simps split: prod.splits)
    apply(rule obind_rule)
     apply(rule IFimpl_rule)
       apply(simp)
      apply(auto simp add: les_def)[2]
    apply(clarsimp simp add: les_def)
    apply(safe)
    using map_invar_rule3 apply(presburger)
     apply(rule map_invar_rule2)
          prefer 6 apply(blast)
         apply(blast)
        apply(blast)
       apply(blast)
      apply(blast)
     apply(clarsimp simp add: ifex_ite_opt.simps)
    using map_invar_rule3 by presburger
qed

end
end


theory Example
imports Hoare_Typed RHL_Typed Hoare_Tactics
begin

locale M begin
  abbreviation "(x::int variable) == Variable ''x''"
  definition "invoke == proc (x) { x:=1; return () }"
end

term M.invoke

abbreviation "(x::int variable) == Variable ''x''"
abbreviation "(y::int variable) == Variable ''y''"
abbreviation "(b::bool variable) == Variable ''b''"

consts p1::program p2::program p3::program p4::program p5::program p6::program p7::program
definition "test = PROGRAM[ \<guillemotleft>p1\<guillemotright>; \<guillemotleft>p2\<guillemotright>; \<guillemotleft>p3\<guillemotright>; \<guillemotleft>p4\<guillemotright>; \<guillemotleft>p5\<guillemotright>; \<guillemotleft>p6\<guillemotright>; \<guillemotleft>p7\<guillemotright>; ]"

ML {* Scan.lift; Parse.int *}

(* TODO: parse invariant as assertion (with &m, variables, etc) *)
lemma test: "hoare {P &m} x:=1; x:=2; x:=3; x:=4; x:=5; x:=6 {x<10}"
  apply (seq 3 invariant: "x=3")
  apply (wp, skip, simp)
  apply (wp, skip, simp)
done

definition "example =
  PROGRAM[
    x := 0;
    b := True;
    while (b) {
      b <- uniform UNIV;
      x := x+1;
    };
    skip;
    if (\<not>b) { skip; x := 15; skip }
  ]"

(* TODO: Variables should contain a typeref *)

(*
simproc_setup memory_lookup_update ("memory_lookup (memory_update m v a) w") = {*
let
fun simproc_memory_lookup_update' ctx
    (Const(@{const_name memory_lookup},_)$
       (Const(@{const_name memory_update},_)$m$v$a) $ w) =
    let val thy = Proof_Context.theory_of ctx
        val vareq = decide_var_eq ctx (cterm_of thy v) (cterm_of thy w) in
    case vareq of NONE => NONE
     | SOME(true,thm) => SOME (@{thm memory_lookup_update_same'} OF [thm])
     | SOME(false,thm) => SOME (@{thm memory_lookup_update_notsame} OF [thm])
    end
  | simproc_memory_lookup_update' _ _ = NONE

fun simproc_memory_lookup_update _ ctx fact =
   simproc_memory_lookup_update' ctx (term_of fact)
in
simproc_memory_lookup_update
end
*}
*)

(*declare [[simproc del: memory_lookup_update]]*)

lemma test2: assumes "Q == \<lambda>m. memory_lookup m x = 13"
 (* fixes x::"int variable" and y::"int variable"
  assumes "\<not> var_eq x y"
 *) shows "hoare {\<lambda>m. memory_lookup m x = 13} x := x+1; x := x+1; y := 5; if (False) x:=4 {x \<ge> 15}"
  apply wp
  apply skip
  by simp

lemma hoare_example: "hoare {True} \<guillemotleft>example\<guillemotright> {x = 15}"
  unfolding example_def program_def
  apply wp apply simp
  apply (rule while_rule'[where I="\<lambda>m. True"], auto)
done

end