\<^marker>\<open>creator "Peter Lammich"\<close>
\<^marker>\<open>contributor "Maximilian P. L. Haslbeck"\<close>
section \<open>Introsort (roughly libstdc++ version)\<close>
theory Sorting_Introsort
imports
  Sorting_Final_insertion_Sort Sorting_Heapsort Sorting_Log2
  Sorting_Quicksort_Partition
  "../../lib/More_Asymptotics"
begin

context weak_ordering begin
paragraph \<open>Summary\<close>
text \<open>This theory refines @{term introsort_aux3} and @{term introsort3} down to LLVM code.
  It uses @{term heapsort2} and @{term partition_pivot} to implement the first phase of
    introsort in introsort_aux.
  Furthermore it uses @{term final_insertion_sort2} to implement the second phase.
  Finally LLVM code is synthesize with the Sepref tool.\<close>

paragraph \<open>Main Theorems/Definitions\<close>
text \<open>
\<^item> introsort_aux4 introsort4: refinements of abstract algorithms already using heapsort2 and
    partition_pivot
\<^item> upperbound_heapsort_cost: theorem upperbounding heapsort's cost, and exchanging between
    algorithm specific ''slice_sort'' coin and operation specific ''sort_c'' coin
\<^item> heapsort_correct'': the correctness theorem for heapsort to be used during refinement of
    introsort_aux4
\<^item> introsort5_correct: the final correctness theorem for introsort5, collapsing the cost into a
    new constant introsort5_acost, which is then simplified to introsort_cost3
\<^item> introsort_impl: the LLVM program synthesized from introsort5
\<^item> final_hoare_triple: is the Hoare triple extracted for introsort_impl
\<^item> introsort3_allcost_simplified, introsort3_allcost_nlogn : the final cost bound of introsort_impl
    is displayed simplified to inspect the constants, and proved to be in \<Theta>(n log n); Note that,
    while we prove the bound to be in \<Theta>, it still is only an upper bound, as the Hoare triple
    only allows for upper bounds [excess time credits are garbage collected (@{term GC})].
\<close>

subsection \<open>introsort_aux4 -- using heapsort and partitioner\<close>

  (* Assemble an introsort loop, using the partitioner and heap-sort *)

  definition introsort_aux4 :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a list, ecost) nrest"
    where "introsort_aux4 xs l h d \<equiv> RECT' (\<lambda>introsort_aux (xs,l,h,d). doN {
    ASSERT (l\<le>h);
    lxs \<leftarrow> SPECc2 ''sub'' (-) h l;
    if\<^sub>N SPECc2 ''icmp_slt'' (<) is_threshold lxs then doN {
      if\<^sub>N SPECc2 ''icmp_eq'' (=) d 0 then
        mop_call (heapsort2 xs l h)
      else doN {
        (xs,m)\<leftarrow>partition_pivot xs l h;
        d' \<leftarrow> SPECc2 ''sub'' (-) d 1;
        xs \<leftarrow> introsort_aux (xs,l,m,d');
        xs \<leftarrow> introsort_aux (xs,m,h,d');
        RETURN xs
      }
    }
    else
      RETURN xs
  }) (xs,l,h,d)"

definition "introsort_aux4d xs hml l h \<equiv>
  doN {
    loghml \<leftarrow> mop_call (SPECT [Discrete.log hml \<mapsto> log2_iter_cost hml]);
    d \<leftarrow> SPECc2 ''mul'' (*) loghml 2;
    introsort_aux4 xs l h d
  }"

thm heapsort_correct' partition_pivot_correct

subsubsection \<open>Assemble Exchange rate\<close>

text \<open>Here we assemble a Timerefinement from @{term heapsort_TR} and @{term TR_pp}.\<close>

definition "Tia43 \<equiv> TId(''eq'':=cost ''icmp_eq'' 1,
          ''lt'':=cost ''icmp_slt'' 1,
        ''partition_c'':=TR_pp ''partition_c'',
        ''sort_c'':=
        cost ''call'' (enat 10)
         + cost ''if'' (enat 24)
         + cost ''sub'' (enat 34)
         + cost ''ofs_ptr'' (enat 20)
         + cost ''mul'' (enat 14)
         + cost ''cmpo_v_idx'' (enat 6)
         + cost ''add'' (enat 42)
         + cost ''cmpo_idxs'' (enat 4)
         + cost ''udiv'' (enat 16)
         + cost ''and'' (enat 6)
         + cost ''icmp_slt'' (enat 21)
         + cost ''list_swap'' (enat 1)
         + cost ''load'' (enat 10)
         + cost ''store'' (enat 10))"

lemma cost_n_eq_TId_n: "cost n (1::enat) = TId n"
  by(auto simp:  TId_def cost_def zero_acost_def less_eq_acost_def)

lemma wfR''Tia43[simp]: "wfR'' (Tia43)"
  by(auto simp: Tia43_def intro!: wfR''_upd)
lemma spTia43[simp]: "struct_preserving (Tia43)"
  by(auto simp: Tia43_def intro!: struct_preserving_upd_I)
lemma pcTia43[simp]:
  "preserves_curr (Tia43) ''sub''"
  "preserves_curr (Tia43) ''icmp_slt''"
  "preserves_curr (Tia43) ''icmp_eq''"
  by(auto simp: Tia43_def preserves_curr_def cost_n_eq_TId_n)

subsubsection \<open>Prepare Heapsort\<close>

paragraph \<open>Upper bound cost for heap sort\<close>

text \<open>rules to upperbound hs\<close>
lemma
  assumes "1 \<le> Discrete.log (h - l)" "1 \<le> h - l"
  shows
    hsub_aux1: "x \<le> y \<Longrightarrow> (h - l) + x \<le> (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux3: "x \<le> y \<Longrightarrow> (h - (1+l)) + x \<le> (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux4: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow> p * (h - (1+l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux2: "x \<le> y \<Longrightarrow> p * (h - l) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux5: "x \<le> y \<Longrightarrow> (Discrete.log (h - l) * (h - (1+l))) + x \<le> (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux6: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow> p * (Discrete.log (h - l) * (h - (1+l))) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux13: "x \<le> y \<Longrightarrow> ((h - l) * Discrete.log (h - l)) + x \<le> (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux14: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow> p * ((h - l) * Discrete.log (h - l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux15: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow> (h - l) * (p *  Discrete.log (h - l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux7: "x \<le> y \<Longrightarrow> ((h - (1+l)) * Discrete.log (h - l)) + x \<le> (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux8: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow> p * ((h - (1+l)) * Discrete.log (h - l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux9: "x \<le> y \<Longrightarrow> (Discrete.log (h - l)) + x \<le> (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux10: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow> p * ( Discrete.log (h - l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux11: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow>(h - (1+l)) * ( p * Discrete.log (h - l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux12: "x \<le> y \<Longrightarrow> p>0 \<Longrightarrow>(h - l) * ( p * Discrete.log (h - l)) + x \<le> p * (h - l) * Discrete.log (h - l) + y"
  and  hsub_aux_end: "x \<le> y \<Longrightarrow> q>0 \<Longrightarrow> q + x \<le> q * (h - l) * Discrete.log (h - l) + y"
  subgoal
    apply(rule add_mono)
    subgoal using assms by simp
    by simp
  subgoal
    apply(rule add_mono)
    subgoal apply(rule order.trans[where b="h-l"]) apply simp using assms by simp
    by simp
  subgoal
    apply(rule add_mono)
    subgoal apply simp apply(rule order.trans[where b="h-l"]) apply simp using assms by simp
    by simp
  using assms
  by(auto intro!: add_mono)

definition "hsub_STOP = (0::nat)"
lemma hsub_aux0: "a+(hsub_STOP::nat)\<le> b\<Longrightarrow> a \<le> b"
  by simp

lemma hsub_stop: "hsub_STOP \<le> 0"
  unfolding hsub_STOP_def by simp

lemmas hsub_aux = hsub_aux1 hsub_aux2 hsub_aux3 hsub_aux4 hsub_aux5 hsub_aux6
      hsub_aux13 hsub_aux14 hsub_aux15
      hsub_aux7 hsub_aux8
       hsub_aux9 hsub_aux10 hsub_aux11 hsub_aux12
      hsub_aux_end

method hsub_solver uses assms  = (simp only: Suc_eq_plus1_left,
                    rule hsub_aux0,
                    simp only: add.assoc,
                    rule order.trans,
                    (rule hsub_aux[OF assms])+,
                    rule hsub_stop,
                    (simp_all, linarith?))

lemma upperbound_heapsort_cost':
  assumes "Discrete.log (h - l) \<ge> 1" "h-l \<ge> 1"
  shows
  "timerefineA (heapsort_TR l h)  (cost ''slice_sort'' 1)
      \<le> timerefineA (Tia43)
       (cost ''sort_c'' (enat ((h-l) * Discrete.log (h-l))))"
  unfolding Tia43_def
    unfolding heapsort_TR_def  singleton_heap_context.sift_down3_cost_def heapsort_time_def
  unfolding pp_fun_upd pp_TId_absorbs_right
  apply(auto simp add: timerefineA_propagate)
  unfolding Rsd_a_def heapsort_lbc_def
  apply(auto simp:   timerefineA_update_apply_same_cost' lift_acost_cost costmult_cost
                lift_acost_propagate timerefineA_update_cost wfR''_TId intro!: wfR''_upd)
  apply(subst timerefineA_propagate, auto)+
  unfolding singleton_heap_context.sift_down3_cost_def  singleton_heap_context.E_sd3_l_def
  apply(auto simp: costmult_cost costmult_add_distrib lift_acost_propagate lift_acost_cost)
  apply(simp only: add.left_commute add.assoc cost_same_curr_left_add plus_enat_simps)
  apply(simp add: timerefineA_update_apply_same_cost' costmult_cost costmult_add_distrib)
  apply(simp only: add.left_commute)
  apply sc_solve_debug
  apply safe
  subgoal (*if*)  apply(simp add: add_mult_distrib2 add_mult_distrib
              sc_solve_debug_def numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (*call*) apply(simp add: add_mult_distrib2 add_mult_distrib
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* sub *) apply(simp add: add_mult_distrib2 add_mult_distrib
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''ofs_ptr'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''mul'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''cmpo_v_idx'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''add'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''cmpo_idxs'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''udiv'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''icmp_slt'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''and'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''store'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''load'' *) apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
    by(hsub_solver assms: assms)
  subgoal (* ''list_swap'' *)
      using assms apply(simp add: add_mult_distrib2 add_mult_distrib  add.assoc
              sc_solve_debug_def  numeral_eq_enat plus_enat_simps one_enat_def times_enat_simps)
      done
  done

lemma upperbound_heapsort_cost: (* i guess h-l must be \<ge> 2 *)
  shows
  "(h-l)>1 \<Longrightarrow> timerefineA (heapsort_TR l h)  (cost ''slice_sort'' 1)
      \<le> timerefineA (Tia43)
       (cost ''sort_c'' (enat ((h-l) * Discrete.log (h-l))))"
  apply(rule upperbound_heapsort_cost')
  apply auto
  using Discrete.log.simps by auto

paragraph \<open>Prepare correctness theorem\<close>

lemma heapsort_correct'':
  "\<lbrakk>(xs,xs')\<in>Id; (l,l')\<in>Id; (h,h')\<in>Id; lxs=(h'-l'); h'-l'>1\<rbrakk> \<Longrightarrow> heapsort2 xs l h \<le>
      \<Down>Id (timerefine (Tia43) (slice_sort_specT (cost ''sort_c'' (enat ((\<lambda>n. n * Discrete.log n) lxs))) (\<^bold><) xs' l' h'))"
 apply(rule order.trans)
   apply(rule heapsort_correct') apply auto [3]
  unfolding slice_sort_spec_def slice_sort_specT_def
  apply(rule ASSERT_D3_leI)
  apply(simp add: SPEC_timerefine_conv)
  apply(rule SPEC_leq_SPEC_I)
   apply simp
  apply(rule upperbound_heapsort_cost) apply simp
  done

subsubsection \<open>Prepare Partition Algorithm\<close>

lemma partition_pivot_correct':
  "\<lbrakk>(xs,xs')\<in>Id; (l,l')\<in>Id; (h,h')\<in>Id\<rbrakk>
  \<Longrightarrow> partition_pivot xs l h \<le> \<Down>Id (timerefine (Tia43) (partition3_spec xs' l' h'))"
  apply(rule partition_pivot_correct_flexible)
  unfolding Tia43_def
  apply (auto )
  done

subsubsection \<open>Refinement Lemma for introsort_aux4\<close>

lemma introsort_aux4_refine:
    "introsort_aux4 xs l h d
         \<le> \<Down>Id (timerefine (Tia43) ((introsort_aux3 (\<lambda>n. n * Discrete.log n) xs l h d)))"
  unfolding introsort_aux4_def introsort_aux3_def
  supply conc_Id[simp del]
  supply [refine] = mop_call_refine
  apply (refine_rcg RECT'_refine_t bindT_refine_conc_time_my_inres SPECc2_refine' SPECc2_refine MIf_refine
          heapsort_correct'' partition_pivot_correct')
  apply refine_mono
  apply refine_dref_type
  apply (simp_all add: inres_SPECc2)
  apply(auto simp: Tia43_def )
  done

lemma nlogn_mono:
  "\<And>x y. x \<le> y \<Longrightarrow> x * Discrete.log x \<le> y * Discrete.log y"
  apply(rule mult_mono)
     apply simp
    apply (rule log_mono[THEN monoD])
  by simp_all

lemma nlogn_sums:
  "a + b \<le> c \<Longrightarrow> a * Discrete.log a + b * Discrete.log b \<le> c * Discrete.log c"
  apply(rule order.trans)
   apply(rule add_mono[where b="a * Discrete.log c" and d="b * Discrete.log c"])
  subgoal using log_mono[THEN monoD] by simp
  subgoal using log_mono[THEN monoD] by simp
  apply(subst add_mult_distrib[symmetric])
  by simp

lemma nlogn_superlinear:
  "a * Discrete.log a + b * Discrete.log b \<le> (a+b) * Discrete.log (a+b)"
  apply(rule nlogn_sums) by simp

thm introsort_aux3_correct

definition "E_isa4 d lxs = (pp (pp Tia43 (TId(''list_append'' := 0, ''list_length'' := cost ''sub'' 1)))
             (TId(''slice_part_sorted'' := introsort_aux_cost (\<lambda>n. n * Discrete.log n) (lxs, d))))"

lemma sp_E_isa4[simp]:
  "struct_preserving (E_isa4 d hl)"
  unfolding E_isa4_def
  by (auto simp: pp_fun_upd pp_TId_absorbs_right intro!: struct_preserving_upd_I)

lemma pc_E_isa4[simp]:
  "preserves_curr (E_isa4 d hl) ''sub''"
  "preserves_curr (E_isa4 d hl) ''icmp_slt''"
  unfolding E_isa4_def
  by(auto simp: pcTia43[unfolded preserves_curr_def] pp_fun_upd pp_TId_absorbs_right
                preserves_curr_def cost_n_eq_TId_n)

subsubsection \<open>Correctness Lemma for introsort_aux4\<close>

lemma introsort_aux4_correct:
  "introsort_aux4 xs l h d \<le> \<Down> Id (timerefine (E_isa4 d (h-l)) (slice_part_sorted_spec xs l h))"
  apply(rule order.trans)
   apply(rule introsort_aux4_refine)
  apply(rule order.trans)
   apply simp apply(rule timerefine_mono2)
  apply simp
   apply(rule introsort_aux3_correct)
  subgoal apply(intro nlogn_sums) by simp
  apply (simp add: timerefine_iter2)
  apply(subst timerefine_iter2)
  subgoal
    apply(simp add: pp_fun_upd pp_TId_absorbs_right)
    apply(intro wfR''_upd)
    by simp
  subgoal by auto
  unfolding E_isa4_def apply simp
  done

schematic_goal introsort_aux4_cost_for_slice_part_sorted: "E_isa4 d lxs ''slice_part_sorted'' = ?G"
  unfolding norm_cost_tag_def[symmetric]
  unfolding E_isa4_def
  apply(simp add: norm_cost norm_pp)
  apply(rule norm_cost_tagI)
  done

subsubsection \<open>Correctness Lemma for introsort_aux4d\<close>

definition "E_isa4d lxs = (TId(''slice_part_sorted'' := log2_iter_cost lxs + cost ''call'' 1
                       + cost ''mul'' 1 + E_isa4 (Discrete.log lxs * 2) lxs ''slice_part_sorted''))"

lemma introsort_aux4d_correct:
  assumes "hml = h-l"
  shows "introsort_aux4d xs hml l h
           \<le> \<Down> Id (timerefine (E_isa4d hml) (slice_part_sorted_spec xs l h))"
  using assms
  unfolding introsort_aux4d_def
  unfolding spss_eq1 spss_eq2
  apply simp
  unfolding slice_part_sorted_specT_def
  apply(cases "l < h \<and> h \<le> length xs", auto)
  unfolding SPEC_REST_emb'_conv
  apply(rule gwp_specifies_I)
  supply insort4 = introsort_aux4_correct[unfolded spss_eq1 spss_eq2,
          unfolded slice_part_sorted_specT_def SPEC_REST_emb'_conv, simplified,
          THEN le_acost_ASSERTI_otherdir, THEN gwp_specifies_rev_I, THEN gwp_conseq_0]
  apply(refine_vcg \<open>-\<close> rules: gwp_SPECc2 insort4)
   apply(auto simp: Some_eq_emb'_conv emb_le_Some_conv )
  by(simp add: E_isa4d_def norm_cost add.left_commute add.commute add.assoc)

lemma TR_sps_important2:
  assumes "TR ''slice_part_sorted'' = E_isa4d (h - l) ''slice_part_sorted''"
  shows "timerefine TR (slice_part_sorted_spec xs l h)
             = (timerefine (E_isa4d (h-l)) (slice_part_sorted_spec xs l h))"
  unfolding slice_part_sorted_spec_def
  apply(cases "l < h \<and> h \<le> length xs"; auto)
  apply(simp only: SPEC_timerefine_conv)
  apply(rule SPEC_cong, simp)
  apply(rule ext)
  apply(simp add: norm_cost)
  apply(subst assms(1))
  apply(simp add: norm_cost)
  done

lemma introsort_aux4d_correct_flexible:
  assumes "TR ''slice_part_sorted'' = E_isa4d (h - l) ''slice_part_sorted''"
    and "hml = h-l"
  shows "introsort_aux4d xs hml l h \<le> \<Down> Id (timerefine TR (slice_part_sorted_spec xs l h))"
  apply(subst TR_sps_important2[where TR=TR, OF assms(1)])
  supply [[unify_trace_failure]]
  unfolding assms(2)
  apply(rule introsort_aux4d_correct[where hml="h-l"])
  by simp

subsection \<open>introsort4\<close>

  definition "introsort4 xs l h \<equiv> doN {
    ASSERT(l\<le>h);
    hml \<leftarrow> SPECc2 ''sub'' (-) h l;
    if\<^sub>N SPECc2 ''icmp_slt'' (<) 1 hml then doN {
      xs \<leftarrow> introsort_aux4d xs hml l h;
      xs \<leftarrow> final_insertion_sort2 xs l h;
      RETURN xs
    } else RETURN xs
  }"

lemmas final_insertion_sort2_correct_flexible = final_insertion_sort2_correct

abbreviation "TR_is d s == TId(''lt'':=cost ''icmp_slt'' 1,''slice_sort'' := fi2_cost s,
            ''slice_part_sorted'':= log2_iter_cost s + cost ''call'' 1 + cost ''mul'' 1 + E_isa4 d s ''slice_part_sorted'')"

lemma pc_TR_is[simp]:
  "preserves_curr (TR_is d hl) ''sub''"
  "preserves_curr (TR_is d hl) ''icmp_slt''"
  by(auto simp: preserves_curr_def cost_n_eq_TId_n)

lemma wfR''_TR_is[simp]: "wfR'' (TR_is d hl)"
  by (auto intro!: wfR''_upd)

lemma sp_TR_is[simp]:
  "struct_preserving (TR_is d hl)"
  by (auto intro!: struct_preserving_upd_I)

lemma introsort4_refine:
  "introsort4 xs l h \<le> \<Down>Id (timerefine (TR_is (Discrete.log (h-l)*2) (h-l)) (introsort3 xs l h))"
  unfolding introsort4_def introsort3_def
  supply conc_Id[simp del]
  apply (refine_rcg SPECc2_refine' SPECc2_refine bindT_refine_conc_time_my_inres MIf_refine
              introsort_aux4d_correct_flexible final_insertion_sort2_correct_flexible
             consumea_refine   )
  apply refine_dref_type
 by (auto simp: E_isa4d_def norm_cost inres_SPECc2)

end

lemma introsort_depth_limit_in_bounds_aux: (* TODO: Move depth-computation into own (inline) function *)
  assumes "n < max_snat N" "1<N" shows "Discrete.log (n) * 2 < max_snat N"
proof (cases "n=0")
  case True thus ?thesis using assms by auto
next
  case [simp]: False
  have ?thesis if "Discrete.log (n) < max_snat (N-1)"
    using that \<open>1<N\<close> unfolding max_snat_def
    by (metis nat_mult_power_less_eq pos2 semiring_normalization_rules(33))
  moreover have "Discrete.log (n) < max_snat (N-1)"
    apply (rule discrete_log_ltI)
    using assms apply (auto simp: max_snat_def)
    by (smt Suc_diff_Suc leI le_less_trans n_less_equal_power_2 nat_power_less_imp_less
            not_less_eq numeral_2_eq_2 numeral_2_eq_2 zero_order(3))
  ultimately show ?thesis .
qed

context sort_impl_context begin

subsection \<open>introsort_aux5 -- using cmp and swap\<close>

  definition introsort_aux5 :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a list, ecost) nrest"
    where "introsort_aux5 xs l h d \<equiv> RECT' (\<lambda>introsort_aux (xs,l,h,d). doN {
    ASSERT (l\<le>h);
    lxs \<leftarrow> SPECc2 ''sub'' (-) h l;
    if\<^sub>N SPECc2 ''icmp_slt'' (<) is_threshold lxs then doN {
      if\<^sub>N SPECc2 ''icmp_eq'' (=) d 0 then
        mop_call (heapsort3 xs l h)
      else doN {
        (xs,m)\<leftarrow>partition_pivot2 xs l h;
        d' \<leftarrow> SPECc2 ''sub'' (-) d 1;
        xs \<leftarrow> introsort_aux (xs,l,m,d');
        xs \<leftarrow> introsort_aux (xs,m,h,d');
        RETURN xs
      }
    }
    else
      RETURN xs
  }) (xs,l,h,d)"

lemma pc_TR_cmp_swap: "x\<noteq>''cmp_idxs'' \<Longrightarrow> x\<noteq>''cmpo_idxs'' \<Longrightarrow> x\<noteq>''cmpo_v_idx'' \<Longrightarrow> x\<noteq>''list_swap''
  \<Longrightarrow> preserves_curr TR_cmp_swap x"
  apply(intro preserves_curr_other_updI)
  by auto

subsubsection \<open>refine compare and swap\<close>

lemma introsort_aux5_refine: "(xs,xs')\<in>Id \<Longrightarrow> (l,l')\<in>Id \<Longrightarrow> (h,h')\<in>Id \<Longrightarrow> (d,d')\<in>Id
    \<Longrightarrow> introsort_aux5 xs l h d \<le> \<Down>Id (timerefine (TR_cmp_swap) ((introsort_aux4 xs' l' h' d')))"
    unfolding introsort_aux4_def introsort_aux5_def
    supply conc_Id[simp del]
    apply (refine_rcg RECT'_refine_t bindT_refine_conc_time_my_inres SPECc2_refine' MIf_refine
            heapsort3_refine partition_pivot2_refines  mop_call_refine)
    apply refine_mono
    apply refine_dref_type
    apply (auto simp add: inres_SPECc2 intro!: pc_TR_cmp_swap)
    done

subsubsection \<open>synthesize program\<close>

sepref_register introsort_aux5
sepref_def introsort_aux_impl is
  "uncurry3 (PR_CONST introsort_aux5)"
    :: "(arr_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  unfolding introsort_aux5_def PR_CONST_def
  apply (annot_snat_const "TYPE('size_t)")
  supply [[goals_limit = 1]]
  by sepref

subsection \<open>introsort5\<close>

  definition "introsort5 xs l h \<equiv> doN {
    ASSERT(l\<le>h);
    hml \<leftarrow> SPECc2 ''sub'' (-) h l;
    if\<^sub>N SPECc2 ''icmp_slt'' (<) 1 hml then doN {
      loghml \<leftarrow> mop_call (log2_iter hml);
      d \<leftarrow> SPECc2 ''mul'' (*) loghml 2;
      xs \<leftarrow> introsort_aux5 xs l h d;
      xs \<leftarrow> final_insertion_sort3 xs l h;
      RETURN xs
    } else RETURN xs
  }"

subsubsection \<open>refine compare and swap\<close>

  lemma introsort5_refine: "introsort5 xs l h \<le> \<Down>Id (timerefine (TR_cmp_swap) ((introsort4 xs l h )))"
    unfolding introsort4_def introsort_aux4d_def introsort5_def
    supply conc_Id[simp del]
    apply simp
    apply (refine_rcg bindT_refine_conc_time_my_inres SPECc2_refine' MIf_refine
            introsort_aux5_refine final_insertion_sort3_refines
              log2_iter_refine_TR_cmp_swap mop_call_refine )
    apply refine_dref_type
    apply (auto simp add: inres_SPECc2 intro!: pc_TR_cmp_swap)
    done

lemma mop_call_same_result:
  fixes m :: "(_,(_,enat) acost)nrest"
  shows "RETURN x \<le> mop_call m \<Longrightarrow> RETURN x \<le> m"
  unfolding mop_call_def consume_def RETURNT_def
  apply(auto split: if_splits nrest.splits simp: le_fun_def)
  subgoal for x2 apply(cases "x2 x") apply auto
    by (simp add: ecost_nneg)
  done

lemma introsort5_synth_side_condition: (* TODO: Move depth-computation into own (inline) function *)
  assumes "hml < max_snat N" "RETURNTecost xb \<le> mop_call (log2_iter hml)" "1<N"
  shows "xb * 2 < max_snat N"
proof -
  from order_trans[OF mop_call_same_result[OF assms(2)] log2_iter_refine]
  have xb: "xb = Discrete.log hml"
    unfolding  RETURNT_def
    by (auto split: if_splits simp: le_fun_def)

  show ?thesis
    unfolding xb
    apply(rule introsort_depth_limit_in_bounds_aux)
    using assms by auto
qed

subsubsection \<open>synthesize program\<close>

sepref_register introsort5
sepref_def introsort_impl is
  "uncurry2 (PR_CONST introsort5)"
    :: "(arr_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn"
  unfolding introsort5_def PR_CONST_def
  apply (annot_snat_const "TYPE('size_t)")
  supply [intro!] = introsort5_synth_side_condition
  by sepref

subsection \<open>Compose the correctness theorems\<close>

text \<open>When composing the correctness theorems of @{term introsort5},
    @{term introsort4} and @{term introsort3},
     we synthesize a compound exchange rate ?E:\<close>

schematic_goal introsort5_correct:
  "introsort5 xs l h \<le> \<Down> Id (timerefine ?E (slice_sort_spec (\<^bold><) xs l h))"
  apply(rule order.trans)
  apply(rule introsort5_refine)
  apply (rule nrest_Rel_mono)

  apply(rule order.trans)
  apply(rule timerefine_mono2) apply(rule wfR''E)
   apply(rule introsort4_refine)

  apply(rule order.trans)
  apply(rule timerefine_mono2) apply(rule wfR''E)
  apply (rule nrest_Rel_mono)
  apply(rule timerefine_mono2) apply(rule wfR''_TR_is)
   apply(rule introsort3_correct)

  apply(simp add: conc_Id)
  apply (subst timerefine_iter2)
    apply(rule wfR''E)
   apply(rule wfR''_TR_is)

  apply (subst timerefine_iter2)
  apply(rule wfR''_ppI)
    apply(rule wfR''E)
    apply(rule wfR''_TR_is)
  subgoal apply auto done
  apply(rule order.refl)
  done

text \<open>And give this exchange rate a Name:\<close>

concrete_definition introsort5_TR is introsort5_correct uses "_ \<le> \<Down> Id (timerefine \<hole> _) "

lemma pull_introsort5_TR_into_spec: "(timerefine (introsort5_TR l h) (slice_sort_spec (\<^bold><) xs l h))
    = slice_sort_specT (introsort5_TR l h ''slice_sort'') (\<^bold><) xs l h"
  unfolding slice_sort_spec_def slice_sort_specT_def
  apply(cases "l \<le> h \<and> h \<le> length xs")
   apply(auto simp: SPEC_timerefine_conv)
  apply(rule SPEC_cong) apply simp
  by (auto simp: timerefineA_cost)

text \<open>We simplify @{term introsort5_TR}\<close>

schematic_goal ub_introsort5: "timerefineA (introsort5_TR l h) (cost ''slice_sort'' 1) \<le> ?x"
  unfolding introsort5_TR_def introsort3_cost_def
  apply(simp add: norm_pp norm_cost )
  apply(subst timerefineA_propagate, (auto intro!: wfR''_upd)[1])+
  apply(simp add: norm_pp norm_cost )
  unfolding log2_iter_cost_def TR_is_insert3_def E_isa4_def Tia43_def introsort_aux_cost_def
      cost_insert_guarded_def cost_is_insert_guarded_step_def
      cost_insert_def cost_is_insert_step_def move_median_to_first_cost_def
  apply(simp add: norm_pp norm_cost )
  apply(subst timerefineA_propagate, (auto intro!: wfR''_upd)[1])+
  apply(simp add: norm_pp norm_cost )
  unfolding cmpo_v_idx2'_cost_def cmp_idxs2'_cost_def myswap_cost_def cmpo_idxs2'_cost_def
  apply(simp add: norm_pp norm_cost )
  apply(simp add: add.commute add.left_commute)
  apply(simp add: cost_same_curr_left_add cost_same_curr_add)
  apply(simp add: add.assoc add.commute add.left_commute)
  apply(simp add: cost_same_curr_left_add cost_same_curr_add)
  apply(simp add: add.assoc add.commute add.left_commute)

  apply sc_solve_upperbound
  by simp

text \<open>and give it a name\<close>
concrete_definition introsort5_acost is ub_introsort5 uses "_ \<le> \<hole>"

text \<open>we pull the lifting to the outer most:\<close>
schematic_goal lift_introsort5_acost: "introsort5_acost x y = lift_acost ?y"
  unfolding introsort5_acost_def
  apply(simp add: numeral_eq_enat one_enat_def)
  unfolding lift_acost_cost[symmetric]  lift_acost_propagate[symmetric]
  apply(rule refl)
  done

text \<open>We define the finite part of the cost expression:\<close>
concrete_definition introsort5_cost is lift_introsort5_acost uses "_ = lift_acost \<hole>"

text \<open>We display the final fine-grained cost expression:\<close>
definition "introsort_cost3 s \<equiv>
cost ''mul'' (Suc (s * Discrete.log s * 14)) +
(cost ''ofs_ptr'' (1241 + (108 * (s * Discrete.log s) + 68 * s)) +
 (cost ''add'' (48 * (s * Discrete.log s) + (21 + (s + Discrete.log s))) +
  (cost ''store'' (612 + (34 * s + 54 * (s * Discrete.log s))) +
   (cost ''sub'' (35 * s + (596 + 44 * (s * Discrete.log s))) +
    (cost ''load'' (629 + (34 * s + 54 * (s * Discrete.log s))) +
     (cost ''if'' (40 * (s * Discrete.log s) + (633 + (Discrete.log s + 20 * s))) +
      (cost lt_curr_name (306 + (17 * s + 20 * (s * Discrete.log s))) +
       (cost ''and'' (s * Discrete.log s * 6) +
        (cost ''icmp_slt'' (20 + (2 * s + (25 * (s * Discrete.log s) + Discrete.log s))) +
         (cost ''udiv'' (Suc (18 * (s * Discrete.log s) + Discrete.log s)) +
          (cost ''call'' (343 + (22 * (s * Discrete.log s) + (19 * s + Discrete.log s))) +
           (cost ''icmp_eq'' (289 + (s + Discrete.log s * 2 * s)) +
             cost ''icmp_sle'' 1))))))))))))"

lemma introsort_cost3_eq_introsort_cost5: "introsort_cost3 (h-l) = introsort5_cost l h"
  unfolding introsort_cost3_def introsort5_cost_def by (auto simp: algebra_simps)

definition "introsort_impl_cost n = lift_acost (introsort_cost3 n)"

lemma "introsort_impl_cost (h-l) = introsort5_acost l h"
  unfolding introsort_impl_cost_def introsort5_cost.refine introsort_cost3_eq_introsort_cost5
  by simp

text \<open>Combine Refinement lemma for @{term introsort_impl} with correctness theorem\<close>

lemmas introsort_correct' = hn_refine_result[OF introsort_impl.refine[to_hnr],
                                              unfolded PR_CONST_def APP_def,
                                              OF introsort5_TR.refine ]

lemma introsort_correct:
 "hn_refine (hn_ctxt arr_assn a ai \<and>* hn_val snat_rel ba bia \<and>* hn_val snat_rel b bi)
       (introsort_impl ai bia bi)
 (hn_invalid arr_assn a ai \<and>* hn_val snat_rel ba bia \<and>* hn_val snat_rel b bi) (hr_comp arr_assn Id)
  (timerefine (introsort5_TR ba b) (slice_sort_spec (\<^bold><) a ba b))"
  apply(rule introsort_correct')
  apply(rule attains_sup_sv) by simp

text \<open>extract Hoare Triple\<close>

lemmas introsort_ht = introsort_correct[unfolded slice_sort_spec_def SPEC_REST_emb'_conv,
                                          THEN ht_from_hnr]

lemma Sum_any_cost2: "Sum_any (the_acost (cost n x)) = x"
  unfolding cost_def by (simp add: zero_acost_def)

subsection \<open>The final Hoare Triple\<close>

lemma introsort_final_hoare_triple:
  assumes "l \<le> h \<and> h \<le> length xs\<^sub>0"
  shows "llvm_htriple ($introsort_impl_cost (h-l) \<and>* hn_ctxt arr_assn xs\<^sub>0 p
           \<and>* hn_val snat_rel l l' \<and>* hn_val snat_rel h h')
        (introsort_impl p l' h')
      (\<lambda>r. (\<lambda>s. \<exists>xs. (\<up>(slice_sort_aux xs\<^sub>0 xs l h) \<and>* arr_assn xs r) s)
           \<and>* hn_invalid arr_assn xs\<^sub>0 p \<and>* hn_val snat_rel l l' \<and>* hn_val snat_rel h h')"
  unfolding introsort_impl_cost_def
  using assms
  by (rule llvm_htriple_more_time[OF introsort5_acost.refine introsort_ht,
                unfolded introsort5_cost.refine introsort_cost3_eq_introsort_cost5[symmetric]
                          hr_comp_Id2])

text \<open>Calculate the cost for all currencies:\<close>

schematic_goal Sum_any_calc: "project_all (introsort_impl_cost s) = ?x"
  unfolding norm_cost_tag_def[symmetric]
  apply(subst project_all_is_Sumany_if_lifted[OF introsort_impl_cost_def])
  unfolding introsort_cost3_def
  apply(simp add: the_acost_propagate add.assoc)
  apply(subst Sum_any.distrib;  ( auto simp only: Sum_any_cost
          intro!: finite_sum_nonzero_cost finite_sum_nonzero_if_summands_finite_nonzero))+
  apply(rule norm_cost_tagI)
  done

text \<open>Give the result a name:\<close>
concrete_definition (in -) introsort3_allcost is sort_impl_context.Sum_any_calc uses "_ = \<hole>"

lemma introsort3_allcost_is_projected_introsort_impl_cost:
  "introsort3_allcost n = project_all (introsort_impl_cost n)"
  apply(subst introsort3_allcost.refine[OF sort_impl_context_axioms, symmetric])
  by simp

end

text \<open>The cost of introsort expanded:\<close>

lemma introsort3_allcost_simplified:
  "introsort3_allcost n = 4693 + 5 *  Discrete.log n + 231 * n + 455 * (n * Discrete.log n)"
  unfolding introsort3_allcost_def
  apply (simp add: algebra_simps)
  done

text \<open>The asymptotic behaviour of introsort's cost:\<close>

lemma introsort3_allcost_nlogn:
  "(\<lambda>x. real (introsort3_allcost x)) \<in> \<Theta>(\<lambda>n. (real n)*(ln (real n)))"
  unfolding introsort3_allcost_simplified
  by auto2

end


theory Namespace
imports BasicTypes
begin
subsection \<open> Namespaces \<close>
text \<open>
  Namespaces in the stdpp library for Coq are quite sophisticated and require some features
  that Isabelle doesn't have. Thus, we use a less flexible but similar, easier version.
\<close>
type_synonym namespace = "nat list"
type_synonym name = "nat list"
definition names :: "namespace \<Rightarrow> name set" where
  "names N = {n. \<exists>p. n=p@N}" \<comment> \<open> A namespace is used as the prefix for other names. \<close>
definition dnames :: "namespace \<Rightarrow> name dset" where "dnames N = DSet (names N)"

definition nroot :: namespace where "nroot = []"
definition add_name :: "namespace \<Rightarrow> name \<Rightarrow> namespace" where "add_name N n = n@N"

lemma add_name_names: "add_name N n \<in> names N"
  unfolding names_def add_name_def
  apply (induction N arbitrary: n)
  by auto

lemma add_name_subseq_names: "names (add_name N n) \<subseteq> names N"
  unfolding names_def add_name_def
  apply (induction N arbitrary: n)
  by auto

lemma cons_subseq_names: "names (a#N) \<subseteq> names N"
  using add_name_subseq_names[of _ "[a]"] unfolding add_name_def by simp

lemma add_name_minus: "names (add_name N n) = names N - {n'. (\<exists>p. n'=p@N) \<and> (\<nexists>q. n'=q@n@N)}"
  unfolding names_def add_name_def
  by auto

lemma add_name_subs_names: "n\<noteq>[] \<Longrightarrow> names (add_name N n) \<subset> names N"
  using add_name_minus names_def by fastforce

lemma union_add_names: "\<Union> {names (add_name N n) | n. True} = names N"
unfolding names_def add_name_def by auto

lemma infinite_names: "infinite (names N)"
proof
  assume assm: "finite (names N)"
  have "{x#N | x. True} \<subseteq> names N"
    unfolding names_def by auto
  from rev_finite_subset[OF assm this] have "finite {x#N | x. True}" .
  then have "finite ((\<lambda>x. x#N) ` UNIV)" by (simp add: full_SetCompr_eq)
  have "inj_on (\<lambda>x. x#N) UNIV" by (meson injI list.inject)
  from  finite_imageD[OF \<open>finite ((\<lambda>x. x#N) ` UNIV)\<close> this] have "finite (UNIV::nat set)" .
  with infinite_UNIV_nat show False ..
qed

lemma not_no_names: "names N \<noteq> {}" by (simp add: infinite_imp_nonempty infinite_names)

definition string_to_name :: "string \<Rightarrow> name" where
  "string_to_name = (map nat_of_integer) \<circ> String.asciis_of_literal \<circ> String.implode"

definition subnamespace :: "namespace \<Rightarrow> namespace \<Rightarrow> bool" where
  "subnamespace N1 N2 \<equiv> \<exists>p. N1=p@N2"
lemma sub_names: "subnamespace N1 N2 \<longleftrightarrow> N1 \<in> names N2"
  by (auto simp: names_def subnamespace_def)
lemma distinct_names: "\<lbrakk>\<not>subnamespace N1 N2; \<not>subnamespace N2 N1\<rbrakk> \<Longrightarrow> names N1 \<inter> names N2 = {}"
  by (auto simp: names_def subnamespace_def) (metis append_eq_append_conv2)
end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section \<open>Accessing Values via Keys\<close>

theory RBT_Map_Set_Extension
imports
  Collections.RBTMapImpl
  Collections.RBTSetImpl
  Matrix.Utility
begin

text \<open>
  We provide two extensions of the red black tree implementation.

  The first extension provides two convenience methods on sets which are represented by red black
  trees: a check on subsets and the big union operator.

  The second extension is to provide two operations @{term elem_list_to_rm} and @{term
  rm_set_lookup} which can be used to index a set of values via keys. More precisely, given a list
  of values of type @{typ "'v"} and a key function of type @{typ "'v => 'k"}, @{term
  elem_list_to_rm} will generate a map of type @{typ "'k => 'v set"}. Then with @{term
  rs_set_lookup} we can efficiently access all values which match a given key.
\<close>

subsection \<open>Subset and Union\<close>

text \<open>
  For the subset operation @{term "r \<subseteq> s"} we provide two implementations. The first one (@{term
  rs_subset}) traverses over @{term r} and then performs membership tests \<open>\<in> s\<close>. Its
  complexity is ${\cal O}(|r| \cdot log (|s|))$. The second one (@{term rs_subset_list}) generates
  sorted lists for both @{term r} and @{term s} and then linearly checks the subset condition. Its
  complexity is ${\cal O}(|r| + |s|)$.
\<close>

text \<open>
  As union operator we use the standard fold function. Note that the order of the union is important
  so that new sets are added to the big union.
\<close>

(* perhaps there is a smarter way to use two iterates at the same time, however,
  when writing this theory this feature was not detected in the RBTSetImpl theory *)
definition rs_subset :: "('a :: linorder) rs \<Rightarrow> 'a rs \<Rightarrow> 'a option"
where
  "rs_subset as bs = rs.iteratei
    as
    (\<lambda> maybe. case maybe of None \<Rightarrow> True | Some _ \<Rightarrow> False)
    (\<lambda> a _. if rs.memb a bs then None else Some a)
    None"

lemma rs_subset [simp]:
  "rs_subset as bs = None \<longleftrightarrow> rs.\<alpha> as \<subseteq> rs.\<alpha> bs"
proof -
  let ?abort = "\<lambda> maybe. case maybe of None \<Rightarrow> True | Some _ \<Rightarrow> False"
  let ?I = "\<lambda> aas maybe. maybe = None \<longleftrightarrow> (\<forall> a. a \<in> rs.\<alpha> as - aas \<longrightarrow> a \<in> rs.\<alpha> bs)"
  let ?it = "rs_subset as bs"
  have "?I {} ?it \<or> (\<exists> it \<subseteq> rs.\<alpha> as. it \<noteq> {} \<and> \<not> ?abort ?it \<and> ?I it ?it)"
    unfolding rs_subset_def
    by (rule rs.iteratei_rule_P [where I="?I"]) (auto simp: rs.correct)
  then show ?thesis by auto
qed

definition rs_subset_list :: "('a :: linorder) rs \<Rightarrow> 'a rs \<Rightarrow> 'a option"
where
  "rs_subset_list as bs = sorted_list_subset (rs.to_sorted_list as) (rs.to_sorted_list bs)"

definition rs_Union :: "('q :: linorder) rs list \<Rightarrow> 'q rs"
where
  "rs_Union = foldl rs.union (rs.empty ())"

lemma rs_Union [simp]:
  "rs.\<alpha> (rs_Union qs) = \<Union> (rs.\<alpha> ` set qs)"
proof -
  {
    fix start
    have "rs.\<alpha> (foldl rs.union start qs) = rs.\<alpha> start \<union> \<Union> (rs.\<alpha> ` set qs)"
      by (induct qs arbitrary: start, auto simp: rs.correct)
  } from this[of "rs.empty ()"]
  show ?thesis unfolding rs_Union_def
    by (auto simp: rs.correct)
qed

subsection \<open>Grouping Values via Keys\<close>

text \<open>
  The functions to produce the index (@{term elem_list_to_rm}) and the lookup function (@{term
  rm_set_lookup}) are straight-forward, however it requires some tedious reasoning that they perform
  as they should.
\<close>
fun elem_list_to_rm :: "('d \<Rightarrow> 'k :: linorder) \<Rightarrow> 'd list \<Rightarrow> ('k, 'd list) rm"
where
  "elem_list_to_rm key [] = rm.empty ()" |
  "elem_list_to_rm key (d # ds) =
    (let
      rm = elem_list_to_rm key ds;
      k = key d
    in
      (case rm.\<alpha> rm k of
        None \<Rightarrow> rm.update_dj k [d] rm
      | Some data \<Rightarrow> rm.update k (d # data) rm))"

definition "rm_set_lookup rm = (\<lambda> a. (case rm.\<alpha> rm a of None \<Rightarrow> [] | Some rules \<Rightarrow> rules))"

lemma rm_to_list_empty [simp]:
  "rm.to_list (rm.empty ()) = []"
proof -
  have "map_of (rm.to_list (rm.empty ())) = Map.empty"
    by (simp add: rm.correct)
  moreover have map_of_empty_iff: "\<And>l. map_of l = Map.empty \<longleftrightarrow> l = []"
    by (case_tac l) auto
  ultimately show ?thesis by metis
qed

locale rm_set =
  fixes rm :: "('k :: linorder, 'd list) rm"
    and key :: "'d \<Rightarrow> 'k"
    and data :: "'d set"
  assumes rm_set_lookup: "\<And> k. set (rm_set_lookup rm k) = {d \<in> data. key d = k}"
begin

lemma data_lookup:
  "data = \<Union> {set (rm_set_lookup rm k) | k. True}" (is "_ = ?R")
proof -
  {
    fix d
    assume d: "d \<in> data"
    then have d: "d \<in> {d' \<in> data. key d' = key d}" by auto
    have "d \<in> ?R"
      by (rule UnionI[OF _ d], rule CollectI, rule exI[of _ "key d"], unfold rm_set_lookup[of "key d"], simp)
  }
  moreover
  {
    fix d
    assume "d \<in> ?R"
    from this[unfolded rm_set_lookup]
    have "d \<in> data" by auto
  }
  ultimately show ?thesis by blast
qed

lemma finite_data:
  "finite data"
  unfolding data_lookup
proof
  show "finite {set (rm_set_lookup rm k) | k. True}" (is "finite ?L")
  proof -
    let ?rmset = "rm.\<alpha> rm"
    let ?M = "?rmset ` Map.dom ?rmset"
    let ?N = "((\<lambda> e. set (case e of None \<Rightarrow> [] | Some ds \<Rightarrow> ds)) ` ?M)"
    let ?K = "?N \<union> {{}}"
    from rm.finite[of rm] have fin: "finite ?K" by auto
    show ?thesis
    proof (rule finite_subset[OF _ fin], rule)
      fix ds
      assume "ds \<in> ?L"
      from this[unfolded rm_set_lookup_def]
      obtain fn where ds: "ds = set (case rm.\<alpha> rm fn of None \<Rightarrow> []
          | Some ds \<Rightarrow> ds)" by auto
      show "ds \<in> ?K"
      proof (cases "rm.\<alpha> rm fn")
        case None
        then show ?thesis unfolding ds by auto
      next
        case (Some rules)
        from Some have fn: "fn \<in> Map.dom ?rmset" by auto
        have "ds \<in> ?N"
          unfolding ds
          by (rule, rule refl, rule, rule refl, rule fn)
        then show ?thesis by auto
      qed
    qed
  qed
qed (force simp: rm_set_lookup_def)

end

interpretation elem_list_to_rm: rm_set "elem_list_to_rm key ds" key "set ds"
proof
  fix k
  show "set (rm_set_lookup (elem_list_to_rm key ds) k) = {d \<in> set ds. key d = k}"
  proof (induct ds arbitrary: k)
    case Nil
    then show ?case unfolding rm_set_lookup_def
      by (simp add: rm.correct)
  next
    case (Cons d ds k)
    let ?el = "elem_list_to_rm key"
    let ?l = "\<lambda>k ds. set (rm_set_lookup (?el ds) k)"
    let ?r = "\<lambda>k ds. {d \<in> set ds. key d = k}"
    from Cons have ind:
      "\<And> k. ?l k ds = ?r k ds" by auto
    show "?l k (d # ds) = ?r k (d # ds)"
    proof (cases "rm.\<alpha> (?el ds) (key d)")
      case None
      from None ind[of "key d"] have r: "{da \<in> set ds. key da = key d} = {}"
        unfolding rm_set_lookup_def by auto
      from None have el: "?el (d # ds) = rm.update_dj (key d) [d] (?el ds)"
        by simp
      from None have ndom: "key d \<notin> Map.dom (rm.\<alpha> (?el ds))" by auto
      have r: "?r k (d # ds) = ?r k ds \<inter> {da. key da \<noteq> key d} \<union> {da . key da = k \<and> da = d}" (is "_ = ?r1 \<union> ?r2") using r by auto
      from ndom have l: "?l k (d # ds) =
        set (case (rm.\<alpha> (elem_list_to_rm key ds)(key d \<mapsto> [d])) k of None \<Rightarrow> []
        | Some rules \<Rightarrow> rules)" (is "_ = ?l") unfolding el rm_set_lookup_def
        by (simp add: rm.correct)
      {
        fix da
        assume "da \<in> ?r1 \<union> ?r2"
        then have "da \<in> ?l"
        proof
          assume "da \<in> ?r2"
          then have da: "da = d" and k: "key d = k" by auto
          show ?thesis unfolding da k by auto
        next
          assume "da \<in> ?r1"
          from this[unfolded ind[symmetric] rm_set_lookup_def]
          obtain das where rm: "rm.\<alpha> (?el ds) k = Some das" and da: "da \<in> set das" and k: "key da \<noteq> key d" by (cases "rm.\<alpha> (?el ds) k", auto)
          from ind[of k, unfolded rm_set_lookup_def] rm da k have k: "key d \<noteq> k" by auto
          have rm: "(rm.\<alpha> (elem_list_to_rm key ds)(key d \<mapsto> [d])) k = Some das"
            unfolding rm[symmetric] using k by auto
          show ?thesis unfolding rm using da by auto
        qed
      }
      moreover
      {
        fix da
        assume l: "da \<in> ?l"
        let ?rm = "((rm.\<alpha> (elem_list_to_rm key ds))(key d \<mapsto> [d])) k"
        from l obtain das where rm: "?rm = Some das" and da: "da \<in> set das"
          by (cases ?rm, auto)
        have "da \<in> ?r1 \<union> ?r2"
        proof (cases "k = key d")
          case True
          with rm da have da: "da = d" by auto
          then show ?thesis using True by auto
        next
          case False
          with rm have "rm.\<alpha> (?el ds) k = Some das" by auto
          from ind[of k, unfolded rm_set_lookup_def this] da False
          show ?thesis by auto
        qed
      }
      ultimately have "?l = ?r1 \<union> ?r2" by blast
      then show ?thesis unfolding l r .
    next
      case (Some das)
      from Some ind[of "key d"] have das: "{da \<in> set ds. key da = key d} = set das"
        unfolding rm_set_lookup_def by auto
      from Some have el: "?el (d # ds) = rm.update (key d) (d # das) (?el ds)"
        by simp
      from Some have dom: "key d \<in> Map.dom (rm.\<alpha> (?el ds))" by auto
      from dom have l: "?l k (d # ds) =
        set (case (rm.\<alpha> (elem_list_to_rm key ds)(key d \<mapsto> (d # das))) k of None \<Rightarrow> []
        | Some rules \<Rightarrow> rules)" (is "_ = ?l") unfolding el rm_set_lookup_def
        by (simp add: rm.correct)
      have r: "?r k (d # ds) = ?r k ds \<union> {da. key da = k \<and> da = d}" (is "_ = ?r1 \<union> ?r2")  by auto
      {
        fix da
        assume "da \<in> ?r1 \<union> ?r2"
        then have "da \<in> ?l"
        proof
          assume "da \<in> ?r2"
          then have da: "da = d" and k: "key d = k" by auto
          show ?thesis unfolding da k by auto
        next
          assume "da \<in> ?r1"
          from this[unfolded ind[symmetric] rm_set_lookup_def]
          obtain das' where rm: "rm.\<alpha> (?el ds) k = Some das'" and da: "da \<in> set das'" by (cases "rm.\<alpha> (?el ds) k", auto)
          from ind[of k, unfolded rm_set_lookup_def rm] have das': "set das' = {d \<in> set ds. key d = k}" by auto
          show ?thesis
          proof (cases "k = key d")
            case True
            show ?thesis using das' das da unfolding True by simp
          next
            case False
            then show ?thesis using das' da rm by auto
          qed
        qed
      }
      moreover
      {
        fix da
        assume l: "da \<in> ?l"
        let ?rm = "((rm.\<alpha> (elem_list_to_rm key ds))(key d \<mapsto> d # das)) k"
        from l obtain das' where rm: "?rm = Some das'" and da: "da \<in> set das'"
          by (cases ?rm, auto)
        have "da \<in> ?r1 \<union> ?r2"
        proof (cases "k = key d")
          case True
          with rm da das have da: "da \<in> set (d # das)" by auto
          then have "da = d \<or> da \<in> set das" by auto
          then have k: "key da = k"
          proof
            assume "da = d"
            then show ?thesis using True by simp
          next
            assume "da \<in> set das"
            with das True show ?thesis by auto
          qed
          from da k show ?thesis using das by auto
        next
          case False
          with rm have "rm.\<alpha> (?el ds) k = Some das'" by auto
          from ind[of k, unfolded rm_set_lookup_def this] da False
          show ?thesis by auto
        qed
      }
      ultimately have "?l = ?r1 \<union> ?r2" by blast
      then show ?thesis unfolding l r .
    qed
  qed
qed

end


section \<open> Scenes \<close>

theory Scenes
  imports Lens_Instances
begin

text \<open> Like lenses, scenes characterise a region of a source type. However, unlike lenses, scenes
  do not explicitly assign a view type to this region, and consequently they have just one type
  parameter. This means they can be more flexibly composed, and in particular it is possible to
  show they form nice algebraic structures in Isabelle/HOL. They are mainly of use in characterising
  sets of variables, where, of course, we do not care about the types of those variables and
  therefore representing them as lenses is inconvenient. \<close>

subsection \<open> Overriding Functions \<close>

text \<open> Overriding functions provide an abstract way of replacing a region of an existing source
  with the corresponding region of another source. \<close>

locale overrider =
  fixes F :: "'s \<Rightarrow> 's \<Rightarrow> 's" (infixl "\<triangleright>" 65)
  assumes
    ovr_overshadow_left: "x \<triangleright> y \<triangleright> z = x \<triangleright> z" and
    ovr_overshadow_right: "x \<triangleright> (y \<triangleright> z) = x \<triangleright> z"
begin
  lemma ovr_assoc: "x \<triangleright> (y \<triangleright> z) = x \<triangleright> y \<triangleright> z"
    by (simp add: ovr_overshadow_left ovr_overshadow_right)
end

locale idem_overrider = overrider +
  assumes ovr_idem: "x \<triangleright> x = x"

declare overrider.ovr_overshadow_left [simp]
declare overrider.ovr_overshadow_right [simp]
declare idem_overrider.ovr_idem [simp]

subsection \<open> Scene Type \<close>

typedef 's scene = "{F :: 's \<Rightarrow> 's \<Rightarrow> 's. overrider F}"
  by (rule_tac x="\<lambda> x y. x" in exI, simp, unfold_locales, simp_all)

setup_lifting type_definition_scene

lift_definition idem_scene :: "'s scene \<Rightarrow> bool" is idem_overrider .

lift_definition region :: "'s scene \<Rightarrow> 's rel"
is "\<lambda> F. {(s\<^sub>1, s\<^sub>2). (\<forall> s. F s s\<^sub>1 = F s s\<^sub>2)}" .

lift_definition coregion :: "'s scene \<Rightarrow> 's rel"
is "\<lambda> F. {(s\<^sub>1, s\<^sub>2). (\<forall> s. F s\<^sub>1 s = F s\<^sub>2 s)}" .

lemma equiv_region: "equiv UNIV (region X)"
  apply (transfer)
  apply (rule equivI)
    apply (rule refl_onI)
     apply (auto)
   apply (rule symI)
   apply (auto)
  apply (rule transI)
  apply (auto)
  done

lemma equiv_coregion: "equiv UNIV (coregion X)"
  apply (transfer)
  apply (rule equivI)
    apply (rule refl_onI)
     apply (auto)
   apply (rule symI)
   apply (auto)
  apply (rule transI)
  apply (auto)
  done

lemma region_coregion_Id:
  "idem_scene X \<Longrightarrow> region X \<inter> coregion X = Id"
  by (transfer, auto, metis idem_overrider.ovr_idem)

lift_definition scene_override :: "'a \<Rightarrow> 'a \<Rightarrow> ('a scene) \<Rightarrow> 'a" ("_ \<oplus>\<^sub>S _ on _" [95,0,96] 95)
is "\<lambda> s\<^sub>1 s\<^sub>2 F. F s\<^sub>1 s\<^sub>2" .

lemma scene_override_idem [simp]: "idem_scene X \<Longrightarrow> s \<oplus>\<^sub>S s on X = s"
  by (transfer, simp)

lemma scene_override_overshadow_left [simp]:
  "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X \<oplus>\<^sub>S S\<^sub>3 on X = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>3 on X"
  by (transfer, simp)

lemma scene_override_overshadow_right [simp]:
  "S\<^sub>1 \<oplus>\<^sub>S (S\<^sub>2 \<oplus>\<^sub>S S\<^sub>3 on X) on X = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>3 on X"
  by (transfer, simp)

definition scene_equiv :: "'a \<Rightarrow> 'a \<Rightarrow> ('a scene) \<Rightarrow> bool" ("_ \<approx>\<^sub>S _ on _" [65,0,66] 65) where
[lens_defs]: "S\<^sub>1 \<approx>\<^sub>S S\<^sub>2 on X = (S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X = S\<^sub>1)"

lemma scene_equiv_region: "idem_scene X \<Longrightarrow> region X = {(S\<^sub>1, S\<^sub>2). S\<^sub>1 \<approx>\<^sub>S S\<^sub>2 on X}"
  by (simp add: lens_defs, transfer, auto)
     (metis idem_overrider.ovr_idem, metis overrider.ovr_overshadow_right)

lift_definition scene_indep :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" (infix "\<bowtie>\<^sub>S" 50)
is "\<lambda> F G. (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. G (F s\<^sub>1 s\<^sub>2) s\<^sub>3 = F (G s\<^sub>1 s\<^sub>3) s\<^sub>2)" .

lemma scene_indep_override:
  "X \<bowtie>\<^sub>S Y = (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on X \<oplus>\<^sub>S s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>S s\<^sub>3 on Y \<oplus>\<^sub>S s\<^sub>2 on X)"
  by (transfer, auto)

lemma scene_indep_sym:
  "X \<bowtie>\<^sub>S Y \<Longrightarrow> Y \<bowtie>\<^sub>S X"
  by (transfer, auto)

text \<open> Compatibility is a weaker notion than independence; the scenes can overlap but they must
  agree when they do. \<close>

lift_definition scene_compat :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" (infix "##\<^sub>S" 50)
is "\<lambda> F G. (\<forall> s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2 = F (G s\<^sub>1 s\<^sub>2) s\<^sub>2)" .

lemma scene_indep_compat [simp]: "X \<bowtie>\<^sub>S Y \<Longrightarrow> X ##\<^sub>S Y"
  by (transfer, auto)

lemma scene_compat_refl: "X ##\<^sub>S X"
  by (transfer, simp)

lemma scene_compat_sym: "X ##\<^sub>S Y \<Longrightarrow> Y ##\<^sub>S X"
  by (transfer, simp)

lemma scene_override_commute_indep:
  assumes "X \<bowtie>\<^sub>S Y"
  shows "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X \<oplus>\<^sub>S S\<^sub>3 on Y = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>3 on Y \<oplus>\<^sub>S S\<^sub>2 on X"
  using assms
  by (transfer, auto)

instantiation scene :: (type) "{bot, top, uminus, sup, inf}"
begin
  lift_definition bot_scene    :: "'s scene" is "\<lambda> x y. x" by (unfold_locales, simp_all)
  lift_definition top_scene    :: "'s scene" is "\<lambda> x y. y" by (unfold_locales, simp_all)
  lift_definition uminus_scene :: "'s scene \<Rightarrow> 's scene" is "\<lambda> F x y. F y x"
    by (unfold_locales, simp_all)
  text \<open> Scene union requires that the two scenes are at least compatible. If they are not, the
        result is the bottom scene. \<close>
  lift_definition sup_scene :: "'s scene \<Rightarrow> 's scene \<Rightarrow> 's scene"
    is "\<lambda> F G. if (\<forall> s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2 = F (G s\<^sub>1 s\<^sub>2) s\<^sub>2) then (\<lambda> s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2) else (\<lambda> s\<^sub>1 s\<^sub>2. s\<^sub>1)"
    by (unfold_locales, auto, metis overrider.ovr_overshadow_right)
  definition inf_scene :: "'s scene \<Rightarrow> 's scene \<Rightarrow> 's scene" where
    [lens_defs]: "inf_scene X Y = - (sup (- X) (- Y))"
  instance ..
end

abbreviation union_scene :: "'s scene \<Rightarrow> 's scene \<Rightarrow> 's scene" (infixl "\<squnion>\<^sub>S" 65)
where "union_scene \<equiv> sup"

abbreviation inter_scene :: "'s scene \<Rightarrow> 's scene \<Rightarrow> 's scene" (infixl "\<sqinter>\<^sub>S" 70)
where "inter_scene \<equiv> inf"

abbreviation top_scene :: "'s scene" ("\<top>\<^sub>S")
where "top_scene \<equiv> top"

abbreviation bot_scene :: "'s scene" ("\<bottom>\<^sub>S")
where "bot_scene \<equiv> bot"

lemma uminus_scene_twice: "- (- (X :: 's scene)) = X"
  by (transfer, simp)

lemma scene_override_id [simp]: "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on \<top>\<^sub>S = S\<^sub>2"
  by (transfer, simp)

lemma scene_override_unit [simp]: "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on \<bottom>\<^sub>S = S\<^sub>1"
  by (transfer, simp)

lemma scene_override_commute: "S\<^sub>2 \<oplus>\<^sub>S S\<^sub>1 on (- X) = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X"
  by (transfer, simp)

lemma scene_union_incompat: "\<not> X ##\<^sub>S Y \<Longrightarrow> X \<squnion>\<^sub>S Y = \<bottom>\<^sub>S"
  by (transfer, auto)

lemma scene_override_union: "X ##\<^sub>S Y \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on (X \<squnion>\<^sub>S Y) = (S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X) \<oplus>\<^sub>S S\<^sub>2 on Y"
  by (transfer, auto)

lemma scene_union_unit: "X \<squnion>\<^sub>S \<bottom>\<^sub>S = X"
  by (transfer, simp)

lemma scene_union_annhil: "idem_scene X \<Longrightarrow> X \<squnion>\<^sub>S \<top>\<^sub>S = \<top>\<^sub>S"
  by (transfer, simp)

lemma scene_union_pres_compat: "\<lbrakk> A ##\<^sub>S B; A ##\<^sub>S C \<rbrakk> \<Longrightarrow> A ##\<^sub>S (B \<squnion>\<^sub>S C)"
  by (transfer, auto)

lemma scene_indep_self_compl: "A \<bowtie>\<^sub>S -A"
  by (transfer, simp)

lemma scene_union_assoc:
  assumes "X ##\<^sub>S Y" "X ##\<^sub>S Z" "Y ##\<^sub>S Z"
  shows "X \<squnion>\<^sub>S (Y \<squnion>\<^sub>S Z) = (X \<squnion>\<^sub>S Y) \<squnion>\<^sub>S Z"
  using assms by (transfer, auto)

lemma scene_inter_indep:
  assumes "idem_scene X" "idem_scene Y" "X \<bowtie>\<^sub>S Y"
  shows "X \<sqinter>\<^sub>S Y = \<bottom>\<^sub>S"
  using assms
  unfolding lens_defs
  apply (transfer, auto)
  apply (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_assoc overrider.ovr_overshadow_right)
  apply (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_overshadow_right)
  done

lemma scene_union_idem: "X \<squnion>\<^sub>S X = X"
  by (transfer, simp)

lemma scene_union_compl: "idem_scene X \<Longrightarrow> X \<squnion>\<^sub>S - X = \<top>\<^sub>S"
  by (transfer, auto)

lemma scene_inter_idem: "X \<sqinter>\<^sub>S X = X"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_union_commute: "X \<squnion>\<^sub>S Y = Y \<squnion>\<^sub>S X"
  by (transfer, auto)

lemma scene_inter_compl: "idem_scene X \<Longrightarrow> X \<sqinter>\<^sub>S - X = \<bottom>\<^sub>S"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_demorgan1: "-(X \<squnion>\<^sub>S Y) = -X \<sqinter>\<^sub>S -Y"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_demorgan2: "-(X \<sqinter>\<^sub>S Y) = -X \<squnion>\<^sub>S -Y"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_compat_top: "idem_scene X \<Longrightarrow> X ##\<^sub>S \<top>\<^sub>S"
  by (transfer, simp)

instantiation scene :: (type) ord
begin
  text \<open> $X$ is a subscene of $Y$ provided that overriding with first $Y$ and then $X$ can
         be rewritten using the complement of $X$. \<close>
  definition less_eq_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" where
  [lens_defs]: "less_eq_scene X Y = (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on Y \<oplus>\<^sub>S s\<^sub>3 on X = s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>2 \<oplus>\<^sub>S s\<^sub>3 on X) on Y)"
  definition less_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" where
  [lens_defs]: "less_scene x y = (x \<le> y \<and> \<not> y \<le> x)"
instance ..
end

abbreviation subscene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" (infix "\<subseteq>\<^sub>S" 55)
where "subscene X Y \<equiv> X \<le> Y"

lemma subscene_refl: "X \<subseteq>\<^sub>S X"
  by (simp add: less_eq_scene_def)

lemma subscene_trans: "\<lbrakk> idem_scene Y; X \<subseteq>\<^sub>S Y; Y \<subseteq>\<^sub>S Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>S Z"
  by (simp add: less_eq_scene_def, transfer, auto, metis (no_types, hide_lams) idem_overrider.ovr_idem)

lemma subscene_antisym: "\<lbrakk> idem_scene Y; X \<subseteq>\<^sub>S Y; Y \<subseteq>\<^sub>S X \<rbrakk> \<Longrightarrow> X = Y"
  apply (simp add: less_eq_scene_def, transfer, auto)
  apply (rule ext)
  apply (rule ext)
  apply (metis (full_types) idem_overrider.ovr_idem overrider.ovr_overshadow_left)
  done

lemma subscene_eliminate:
  "\<lbrakk> idem_scene Y; X \<le> Y \<rbrakk> \<Longrightarrow> s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on X \<oplus>\<^sub>S s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>S s\<^sub>3 on Y"
  by (metis less_eq_scene_def scene_override_overshadow_left scene_override_idem)

lemma scene_bot_least: "\<bottom>\<^sub>S \<le> X"
  unfolding less_eq_scene_def by (transfer, auto)

lemma scene_top_greatest: "X \<le> \<top>\<^sub>S"
  unfolding less_eq_scene_def by (transfer, auto)

lemma scene_union_ub: "\<lbrakk> idem_scene Y; X \<bowtie>\<^sub>S Y \<rbrakk> \<Longrightarrow> X \<le> (X \<squnion>\<^sub>S Y)"
  by (simp add: less_eq_scene_def, transfer, auto)
     (metis (no_types, hide_lams) idem_overrider.ovr_idem overrider.ovr_overshadow_right)

lemma scene_le_then_compat: "\<lbrakk> idem_scene X; idem_scene Y; X \<le> Y \<rbrakk> \<Longrightarrow> X ##\<^sub>S Y"
  unfolding less_eq_scene_def
  by (transfer, auto, metis (no_types, lifting) idem_overrider.ovr_idem overrider_def)

lemma indep_then_compl_in: "A \<bowtie>\<^sub>S B \<Longrightarrow> A \<le> -B"
  unfolding less_eq_scene_def by (transfer, simp)

subsection \<open> Linking Scenes and Lenses \<close>

text \<open> The following function extracts a scene from a very well behaved lens \<close>

lift_definition lens_scene :: "('v \<Longrightarrow> 's) \<Rightarrow> 's scene" ("\<lbrakk>_\<rbrakk>\<^sub>\<sim>") is
"\<lambda> X s\<^sub>1 s\<^sub>2. if (mwb_lens X) then s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X else s\<^sub>1"
  by (unfold_locales, auto simp add: lens_override_def)

lemma vwb_impl_idem_scene [simp]:
  "vwb_lens X \<Longrightarrow> idem_scene \<lbrakk>X\<rbrakk>\<^sub>\<sim>"
  by (transfer, unfold_locales, auto simp add: lens_override_overshadow_left lens_override_overshadow_right)

lemma idem_scene_impl_vwb:
  "\<lbrakk> mwb_lens X; idem_scene \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<rbrakk> \<Longrightarrow> vwb_lens X"
  apply (cases "mwb_lens X")
   apply (transfer, unfold idem_overrider_def overrider_def, auto)
  apply (simp add: idem_overrider_axioms_def override_idem_implies_vwb)
  done

lemma lens_compat_scene: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> X ##\<^sub>L Y \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> ##\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (auto simp add: lens_scene.rep_eq scene_compat.rep_eq lens_defs)

text \<open> Next we show some important congruence properties \<close>

lemma zero_lens_scene: "\<lbrakk>0\<^sub>L\<rbrakk>\<^sub>\<sim> = \<bottom>\<^sub>S"
  by (transfer, simp)

lemma one_lens_scene: "\<lbrakk>1\<^sub>L\<rbrakk>\<^sub>\<sim> = \<top>\<^sub>S"
  by (transfer, simp)

lemma lens_scene_override:
  "mwb_lens X \<Longrightarrow> s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on \<lbrakk>X\<rbrakk>\<^sub>\<sim> = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X"
  by (transfer, simp)

lemma lens_indep_scene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "(X \<bowtie> Y) \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  using assms
  by (auto, (simp add: scene_indep_override, transfer, simp add: lens_indep_override_def)+)

lemma lens_indep_impl_scene_indep [simp]:
  "(X \<bowtie> Y) \<Longrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (transfer, auto simp add: lens_indep_comm lens_override_def)

lemma lens_plus_scene:
  "\<lbrakk> vwb_lens X; vwb_lens Y; X \<bowtie> Y \<rbrakk> \<Longrightarrow> \<lbrakk>X +\<^sub>L Y\<rbrakk>\<^sub>\<sim> = \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<squnion>\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (transfer, auto simp add: lens_override_plus lens_indep_override_def lens_indep_overrideI plus_vwb_lens)

lemma subscene_implies_sublens': "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<le> \<lbrakk>Y\<rbrakk>\<^sub>\<sim> \<longleftrightarrow> X \<subseteq>\<^sub>L' Y"
  by (simp add: lens_defs less_eq_scene_def, transfer, simp add: lens_override_def)

lemma sublens'_implies_subscene: "\<lbrakk> vwb_lens X; vwb_lens Y; X \<subseteq>\<^sub>L' Y \<rbrakk> \<Longrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<le> \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (simp add: lens_defs less_eq_scene_def, auto simp add: lens_override_def lens_scene_override)

lemma sublens_iff_subscene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<subseteq>\<^sub>L Y \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<le> \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (simp add: assms sublens_iff_sublens' subscene_implies_sublens')

text \<open> Equality on scenes is sound and complete with respect to lens equivalence. \<close>

lemma lens_equiv_scene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> = \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
proof
  assume a: "X \<approx>\<^sub>L Y"
  show "\<lbrakk>X\<rbrakk>\<^sub>\<sim> = \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
    by (meson a assms lens_equiv_def sublens_iff_subscene subscene_antisym vwb_impl_idem_scene)
next
  assume b: "\<lbrakk>X\<rbrakk>\<^sub>\<sim> = \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  show "X \<approx>\<^sub>L Y"
    by (simp add: assms b lens_equiv_def sublens_iff_subscene subscene_refl)
qed

text \<open> Membership operations. These have slightly hacky definitions at the moment in order to
  cater for @{term mwb_lens}. See if they can be generalised? \<close>

definition lens_member :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b scene \<Rightarrow> bool" (infix "\<in>\<^sub>S" 50) where
[lens_defs]:
"lens_member x A = ((\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on A \<oplus>\<^sub>L s\<^sub>3 on x = s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>2 \<oplus>\<^sub>L s\<^sub>3 on x) on A) \<and>
                      (\<forall> b b'. get\<^bsub>x\<^esub> (b \<oplus>\<^sub>S b' on A) = get\<^bsub>x\<^esub> b'))"

lemma lens_member_top: "x \<in>\<^sub>S \<top>\<^sub>S"
  by (auto simp add: lens_member_def)

abbreviation lens_not_member :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b scene \<Rightarrow> bool" (infix "\<notin>\<^sub>S" 50) where
"x \<notin>\<^sub>S A \<equiv> (x \<in>\<^sub>S - A)"

lemma lens_member_get_override [simp]: "x \<in>\<^sub>S a \<Longrightarrow> get\<^bsub>x\<^esub> (b \<oplus>\<^sub>S b' on a) = get\<^bsub>x\<^esub> b'"
  by (simp add: lens_member_def)

lemma lens_not_member_get_override [simp]: "x \<notin>\<^sub>S a \<Longrightarrow> get\<^bsub>x\<^esub> (b \<oplus>\<^sub>S b' on a) = get\<^bsub>x\<^esub> b"
  by (simp add: lens_member_def scene_override_commute)

subsection \<open> Function Domain Scene \<close>

lift_definition fun_dom_scene :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) scene" ("fds") is
"\<lambda> A f g. override_on f g A" by (unfold_locales, simp_all add: override_on_def fun_eq_iff)

lemma fun_dom_scene_empty: "fds({}) = \<bottom>\<^sub>S"
  by (transfer, simp)

lemma fun_dom_scene_union: "fds(A \<union> B) = fds(A) \<squnion>\<^sub>S fds(B)"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_compl: "fds(- A) = - fds(A)"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_inter: "fds(A \<inter> B) = fds(A) \<sqinter>\<^sub>S fds(B)"
  by (simp add: inf_scene_def fun_dom_scene_union[THEN sym] fun_dom_scene_compl[THEN sym])

lemma fun_dom_scene_UNIV: "fds(UNIV) = \<top>\<^sub>S"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_always_compat [simp]: "fds(A) ##\<^sub>S fds(B)"
  by (transfer, simp add: override_on_def fun_eq_iff)

text \<open> Hide implementation details for scenes \<close>

lifting_update scene.lifting
lifting_forget scene.lifting

end