(* Author: Alexander Maletzky *)

section \<open>Sample Computations with Signature-Based Algorithms\<close>

theory Signature_Examples
  imports Signature_Groebner Groebner_Bases.Benchmarks Groebner_Bases.Code_Target_Rat
begin

subsection \<open>Setup\<close>

lift_definition except_pp :: "('a, 'b) pp \<Rightarrow> 'a set \<Rightarrow> ('a, 'b::zero) pp" is except .

lemma hom_grading_varnum_pp: "hom_grading (varnum_pp::('a::countable, 'b::add_wellorder) pp \<Rightarrow> nat)"
proof -
  define f where "f = (\<lambda>n t. (except_pp t (- {x. elem_index x < n}))::('a, 'b) pp)"
  show ?thesis unfolding hom_grading_def hom_grading_fun_def
  proof (intro exI allI conjI impI)
    fix n s t
    show "f n (s + t) = f n s + f n t" unfolding f_def by transfer (rule except_plus)
  next
    fix n t
    show "varnum_pp (f n t) \<le> n" unfolding f_def
      by transfer (simp add: varnum_le_iff keys_except)
  next
    fix n t
    show "varnum_pp t \<le> n \<Longrightarrow> f n t = t" unfolding f_def
      by transfer (auto simp: except_id_iff varnum_le_iff)
  qed
qed

instance pp :: (countable, add_wellorder) quasi_pm_powerprod
  by (standard, intro exI conjI, fact dickson_grading_varnum_pp, fact hom_grading_varnum_pp)

subsubsection \<open>Projections of Term Orders to Orders on Power-Products\<close>

definition proj_comp :: "(('a::nat, 'b::nat) pp \<times> nat) nat_term_order \<Rightarrow> ('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> order"
  where "proj_comp cmp = (\<lambda>x y. nat_term_compare cmp (x, 0) (y, 0))"

definition proj_ord :: "(('a::nat, 'b::nat) pp \<times> nat) nat_term_order \<Rightarrow> ('a, 'b) pp nat_term_order"
  where "proj_ord cmp = Abs_nat_term_order (proj_comp cmp)"

text \<open>In principle, @{const proj_comp} and @{const proj_ord} could be defined more generally on type
  @{typ "'a \<times> nat"}, but then @{typ 'a} would have to belong to some new type-class which is the
  intersection of @{class nat_pp_term} and @{class nat_pp_compare} and additionally requires
  @{prop "rep_nat_term x = (rep_nat_pp x, 0)"}.\<close>

lemma comparator_proj_comp: "comparator (proj_comp cmp)"
proof -
  interpret cmp: comparator "nat_term_compare cmp" by (rule comparator_nat_term_compare)
  show ?thesis unfolding proj_comp_def
  proof
    fix x y :: "('a, 'b) pp"
    show "invert_order (nat_term_compare cmp (x, 0) (y, 0)) = nat_term_compare cmp (y, 0) (x, 0)"
      by (simp only: cmp.sym)
  next
    fix x y :: "('a, 'b) pp"
    assume "nat_term_compare cmp (x, 0) (y, 0) = Eq"
    hence "(x, 0) = (y, 0::nat)" by (rule cmp.weak_eq)
    thus "x = y" by simp
  next
    fix x y z :: "('a, 'b) pp"
    assume "nat_term_compare cmp (x, 0) (y, 0) = Lt" and "nat_term_compare cmp (y, 0) (z, 0) = Lt"
    thus "nat_term_compare cmp (x, 0) (z, 0) = Lt" by (rule cmp.trans)
  qed
qed

lemma nat_term_comp_proj_comp: "nat_term_comp (proj_comp cmp)"
proof -
  have 1: "fst (rep_nat_term (u, i)) = rep_nat_pp u" for u::"('a, 'b) pp" and i::nat
    by (simp add: rep_nat_term_prod_def)
  have 2: "snd (rep_nat_term (u, i)) = i" for u::"('a, 'b) pp" and i::nat
    by (simp add: rep_nat_term_prod_def rep_nat_nat_def)
  show ?thesis
  proof (rule nat_term_compI)
    fix u v :: "('a, 'b) pp"
    assume a: "fst (rep_nat_term u) = 0"
    note nat_term_comp_nat_term_compare
    moreover have "snd (rep_nat_term (u, 0::nat)) = snd (rep_nat_term (v, 0::nat))" by (simp only: 2)
    moreover from a have "fst (rep_nat_term (u, 0::nat)) = 0" by (simp add: 1 rep_nat_term_pp_def)
    ultimately have "nat_term_compare cmp (u, 0) (v, 0) \<noteq> Gt" by (rule nat_term_compD1)
    thus "proj_comp cmp u v \<noteq> Gt" by (simp add: proj_comp_def)
  next
    fix u v :: "('a, 'b) pp"
    assume "snd (rep_nat_term u) < snd (rep_nat_term v)"
    thus "proj_comp cmp u v = Lt" by (simp add: rep_nat_term_pp_def)
  next
    fix t u v :: "('a, 'b) pp"
    assume "proj_comp cmp u v = Lt"
    hence "nat_term_compare cmp (u, 0) (v, 0) = Lt" by (simp add: proj_comp_def)
    with nat_term_comp_nat_term_compare have "nat_term_compare cmp (splus (t, 0) (u, 0)) (splus (t, 0) (v, 0)) = Lt"
      by (rule nat_term_compD3)
    thus "proj_comp cmp (splus t u) (splus t v) = Lt"
      by (simp add: proj_comp_def splus_prod_def pprod.splus_def splus_pp_term)
  next
    fix u v a b :: "('a, 'b) pp"
    assume u: "fst (rep_nat_term u) = fst (rep_nat_term a)" and v: "fst (rep_nat_term v) = fst (rep_nat_term b)"
      and a: "proj_comp cmp a b = Lt"
    note nat_term_comp_nat_term_compare
    moreover from u have "fst (rep_nat_term (u, 0::nat)) = fst (rep_nat_term (a, 0::nat))"
      by (simp add: 1 rep_nat_term_pp_def)
    moreover from v have "fst (rep_nat_term (v, 0::nat)) = fst (rep_nat_term (b, 0::nat))"
      by (simp add: 1 rep_nat_term_pp_def)
    moreover have "snd (rep_nat_term (u, 0::nat)) = snd (rep_nat_term (v, 0::nat))"
      and "snd (rep_nat_term (a, 0::nat)) = snd (rep_nat_term (b, 0::nat))" by (simp_all only: 2)
    moreover from a have "nat_term_compare cmp (a, 0) (b, 0) = Lt" by (simp add: proj_comp_def)
    ultimately have "nat_term_compare cmp (u, 0) (v, 0) = Lt" by (rule nat_term_compD4)
    thus "proj_comp cmp u v = Lt" by (simp add: proj_comp_def)
  qed
qed

corollary nat_term_compare_proj_ord: "nat_term_compare (proj_ord cmp) = proj_comp cmp"
  unfolding proj_ord_def using comparator_proj_comp nat_term_comp_proj_comp
  by (rule nat_term_compare_Abs_nat_term_order_id)

lemma proj_ord_LEX [code]: "proj_ord LEX = LEX"
proof -
  have "nat_term_compare (proj_ord LEX) = nat_term_compare LEX"
    by (auto simp: nat_term_compare_proj_ord nat_term_compare_LEX proj_comp_def lex_comp
        lex_comp_aux_def rep_nat_term_prod_def rep_nat_term_pp_def intro!: ext split: order.split)
  thus ?thesis by (simp only: nat_term_compare_inject)
qed

lemma proj_ord_DRLEX [code]: "proj_ord DRLEX = DRLEX"
proof -
  have "nat_term_compare (proj_ord DRLEX) = nat_term_compare DRLEX"
    by (auto simp: nat_term_compare_proj_ord nat_term_compare_DRLEX proj_comp_def deg_comp pot_comp
        lex_comp lex_comp_aux_def rep_nat_term_prod_def rep_nat_term_pp_def intro!: ext split: order.split)
  thus ?thesis by (simp only: nat_term_compare_inject)
qed

lemma proj_ord_DEG [code]: "proj_ord (DEG to) = DEG (proj_ord to)"
proof -
  have "nat_term_compare (proj_ord (DEG to)) = nat_term_compare (DEG (proj_ord to))"
    by (simp add: nat_term_compare_proj_ord nat_term_compare_DEG proj_comp_def deg_comp
        rep_nat_term_prod_def rep_nat_term_pp_def)
  thus ?thesis by (simp only: nat_term_compare_inject)
qed

lemma proj_ord_POT [code]: "proj_ord (POT to) = proj_ord to"
proof -
  have "nat_term_compare (proj_ord (POT to)) = nat_term_compare (proj_ord to)"
    by (simp add: nat_term_compare_proj_ord nat_term_compare_POT proj_comp_def pot_comp
        rep_nat_term_prod_def rep_nat_term_pp_def)
  thus ?thesis by (simp only: nat_term_compare_inject)
qed

subsubsection \<open>Locale Interpretation\<close>

locale qpm_nat_inf_term = gd_nat_term "\<lambda>x. x" "\<lambda>x. x" to
  for to::"(('a::nat, 'b::nat) pp \<times> nat) nat_term_order"
begin

sublocale aux: qpm_inf_term "\<lambda>x. x" "\<lambda>x. x"
        "le_of_nat_term_order (proj_ord to)"
        "lt_of_nat_term_order (proj_ord to)"
        "le_of_nat_term_order to"
        "lt_of_nat_term_order to"
proof intro_locales
(*
  show "class.preorder (le_of_nat_term_order (proj_ord to)) (lt_of_nat_term_order (proj_ord to))"
    and "class.order_axioms (le_of_nat_term_order (proj_ord to))"
    and "class.linorder_axioms (le_of_nat_term_order (proj_ord to))"
    using linorder_le_of_nat_term_order[of "proj_ord to"] by (simp_all add: class.linorder_def class.order_def)
next*)
  show "ordered_powerprod_axioms (le_of_nat_term_order (proj_ord to))"
    by (unfold_locales, fact le_of_nat_term_order_zero_min, auto dest: le_of_nat_term_order_plus_monotone simp: ac_simps)
next
  show "ordered_term_axioms (\<lambda>x. x) (\<lambda>x. x) (le_of_nat_term_order (proj_ord to)) (le_of_nat_term_order to)"
  proof
    fix v w t
    assume "le_of_nat_term_order to v w"
    thus "le_of_nat_term_order to (local.splus t v) (local.splus t w)"
      by (simp add: le_of_nat_term_order nat_term_compare_splus splus_eq_splus)
  next
    fix v w
    assume "le_of_nat_term_order (proj_ord to) (pp_of_term v) (pp_of_term w)"
      and "component_of_term v \<le> component_of_term w"
    hence "nat_term_compare to (fst v, 0) (fst w, 0) \<noteq> Gt" and "snd v \<le> snd w"
      by (simp_all add: le_of_nat_term_order nat_term_compare_proj_ord proj_comp_def)
    from comparator_nat_term_compare nat_term_comp_nat_term_compare _ _ _ _ this(1)
    have "nat_term_compare to v w \<noteq> Gt"
      by (rule nat_term_compD4'') (simp_all add: rep_nat_term_prod_def ord_iff[symmetric] \<open>snd v \<le> snd w\<close>)
    thus "le_of_nat_term_order to v w" by (simp add: le_of_nat_term_order)
  qed
qed

end

text \<open>We must define the following two constants outside the global interpretation, since otherwise
  their types are too general.\<close>

definition splus_pprod :: "('a::nat, 'b::nat) pp \<Rightarrow> _"
  where "splus_pprod = pprod.splus"

definition adds_term_pprod :: "(('a::nat, 'b::nat) pp \<times> _) \<Rightarrow> _"
  where "adds_term_pprod = pprod.adds_term"

global_interpretation pprod': qpm_nat_inf_term to
  rewrites "pprod.pp_of_term = fst"
  and "pprod.component_of_term = snd"
  and "pprod.splus = splus_pprod"
  and "pprod.adds_term = adds_term_pprod"
  and "punit.monom_mult = monom_mult_punit"
  and "pprod'.aux.punit.lt = lt_punit (proj_ord to)"
  and "pprod'.aux.punit.lc = lc_punit (proj_ord to)"
  and "pprod'.aux.punit.tail = tail_punit (proj_ord to)"
  for to :: "(('a::nat, 'b::nat) pp \<times> nat) nat_term_order"
  defines max_pprod = pprod'.ord_term_lin.max
  and Koszul_syz_sigs_aux_pprod = pprod'.aux.Koszul_syz_sigs_aux
  and Koszul_syz_sigs_pprod = pprod'.aux.Koszul_syz_sigs
  and find_sig_reducer_pprod = pprod'.aux.find_sig_reducer
  and sig_trd_spp_body_pprod = pprod'.aux.sig_trd_spp_body
  and sig_trd_spp_aux_pprod = pprod'.aux.sig_trd_spp_aux
  and sig_trd_spp_pprod = pprod'.aux.sig_trd_spp
  and spair_sigs_spp_pprod = pprod'.aux.spair_sigs_spp
  and is_pred_syz_pprod = pprod'.aux.is_pred_syz
  and is_rewritable_spp_pprod = pprod'.aux.is_rewritable_spp
  and sig_crit_spp_pprod = pprod'.aux.sig_crit_spp
  and spair_spp_pprod = pprod'.aux.spair_spp
  and spp_of_pair_pprod = pprod'.aux.spp_of_pair
  and pair_ord_spp_pprod = pprod'.aux.pair_ord_spp
  and sig_of_pair_spp_pprod = pprod'.aux.sig_of_pair_spp
  and new_spairs_spp_pprod = pprod'.aux.new_spairs_spp
  and is_regular_spair_spp_pprod = pprod'.aux.is_regular_spair_spp
  and add_spairs_spp_pprod = pprod'.aux.add_spairs_spp
  and is_pot_ord_pprod = pprod'.is_pot_ord
  and new_syz_sigs_spp_pprod = pprod'.aux.new_syz_sigs_spp
  and rb_spp_body_pprod = pprod'.aux.rb_spp_body
  and rb_spp_aux_pprod = pprod'.aux.rb_spp_aux
  and gb_sig_z_pprod' = pprod'.aux.gb_sig_z
  and gb_sig_pprod' = pprod'.aux.gb_sig
  and rw_rat_strict_pprod = pprod'.aux.rw_rat_strict
  and rw_add_strict_pprod = pprod'.aux.rw_add_strict
  subgoal by (rule qpm_nat_inf_term.intro, fact gd_nat_term_id)
  subgoal by (fact pprod_pp_of_term)
  subgoal by (fact pprod_component_of_term)
  subgoal by (simp only: splus_pprod_def)
  subgoal by (simp only: adds_term_pprod_def)
  subgoal by (simp only: monom_mult_punit_def)
  subgoal by (simp only: lt_punit_def)
  subgoal by (simp only: lc_punit_def)
  subgoal by (simp only: tail_punit_def)
  done

subsubsection \<open>More Lemmas and Definitions\<close>

lemma compute_adds_term_pprod [code]:
  "adds_term_pprod u v = (snd u = snd v \<and> adds_pp_add_linorder (fst u) (fst v))"
  by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)

lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
  by (simp add: splus_pprod_def pprod.splus_def)

lemma compute_sig_trd_spp_body_pprod [code]:
  "sig_trd_spp_body_pprod to bs v (p, r) =
    (case find_sig_reducer_pprod to bs v (lt_punit (proj_ord to) p) 0 of
        None   \<Rightarrow> (tail_punit (proj_ord to) p, plus_monomial_less r (lc_punit (proj_ord to) p) (lt_punit (proj_ord to) p))
      | Some i \<Rightarrow> let b = snd (bs ! i) in
          (tail_punit (proj_ord to) p - monom_mult_punit (lc_punit (proj_ord to) p / lc_punit (proj_ord to) b)
              (lt_punit (proj_ord to) p - lt_punit (proj_ord to) b) (tail_punit (proj_ord to) b), r))"
  by (simp add: plus_monomial_less_def split: option.split)

lemma compute_sig_trd_spp_pprod [code]:
  "sig_trd_spp_pprod to bs (v, p) \<equiv> (v, sig_trd_spp_aux_pprod to bs v (p, change_ord (proj_ord to) 0))"
  by (simp add: change_ord_def)

lemmas [code] = conversep_iff

lemma compute_is_pot_ord [code]:
  "is_pot_ord_pprod (LEX::(('a::nat, 'b::nat) pp \<times> nat) nat_term_order) = False"
    (is "is_pot_ord_pprod ?lex = _")
  "is_pot_ord_pprod (DRLEX::(('a::nat, 'b::nat) pp \<times> nat) nat_term_order) = False"
    (is "is_pot_ord_pprod ?drlex = _")
  "is_pot_ord_pprod (DEG (to::(('a::nat, 'b::nat) pp \<times> nat) nat_term_order)) = False"
  "is_pot_ord_pprod (POT (to::(('a::nat, 'b::nat) pp \<times> nat) nat_term_order)) = True"
proof -
  have eq1: "snd ((Term_Order.of_exps a b i)::('a, 'b) pp \<times> nat) = i" for a b and i::nat
  proof -
    have "snd ((Term_Order.of_exps a b i)::('a, 'b) pp \<times> nat) =
          snd (rep_nat_term ((Term_Order.of_exps a b i)::('a, 'b) pp \<times> nat))"
      by (simp add: rep_nat_term_prod_def rep_nat_nat_def)
    also have "... = i"
    proof (rule snd_of_exps)
      show "snd (rep_nat_term (undefined, i)) = i" by (simp add: rep_nat_term_prod_def rep_nat_nat_def)
    qed
    finally show ?thesis .
  qed

  let ?u = "(Term_Order.of_exps 1 0 0)::('a, 'b) pp \<times> nat"
  let ?v = "(Term_Order.of_exps 0 0 1)::('a, 'b) pp \<times> nat"
  have "\<not> is_pot_ord_pprod ?lex"
  proof
    assume "is_pot_ord_pprod ?lex"
    moreover have "le_of_nat_term_order ?lex ?v ?u"
      by (simp add: le_of_nat_term_order nat_term_compare_LEX lex_comp lex_comp_aux_def
            comp_of_ord_def lex_pp_of_exps eq_of_exps)
    ultimately have "snd ?v \<le> snd ?u" by (rule pprod'.is_pot_ordD2)
    thus False by (simp add: eq1)
  qed
  thus "is_pot_ord_pprod ?lex = False" by simp

  have "\<not> is_pot_ord_pprod ?drlex"
  proof
    assume "is_pot_ord_pprod ?drlex"
    moreover have "le_of_nat_term_order ?drlex ?v ?u"
      by (simp add: le_of_nat_term_order nat_term_compare_DRLEX deg_comp comparator_of_def)
    ultimately have "snd ?v \<le> snd ?u" by (rule pprod'.is_pot_ordD2)
    thus False by (simp add: eq1)
  qed
  thus "is_pot_ord_pprod ?drlex = False" by simp

  have "\<not> is_pot_ord_pprod (DEG to)"
  proof
    assume "is_pot_ord_pprod (DEG to)"
    moreover have "le_of_nat_term_order (DEG to) ?v ?u"
      by (simp add: le_of_nat_term_order nat_term_compare_DEG deg_comp comparator_of_def)
    ultimately have "snd ?v \<le> snd ?u" by (rule pprod'.is_pot_ordD2)
    thus False by (simp add: eq1)
  qed
  thus "is_pot_ord_pprod (DEG to) = False" by simp

  have "is_pot_ord_pprod (POT to)"
    by (rule pprod'.is_pot_ordI, simp add: lt_of_nat_term_order nat_term_compare_POT pot_comp rep_nat_term_prod_def,
        simp add: comparator_of_def)
  thus "is_pot_ord_pprod (POT to) = True" by simp
qed

corollary is_pot_ord_POT: "is_pot_ord_pprod (POT to)"
  by (simp only: compute_is_pot_ord)

definition "gb_sig_z_pprod to rword_strict fs \<equiv>
                  (let res = gb_sig_z_pprod' to (rword_strict to) (map (change_ord (proj_ord to)) fs) in
                    (length (fst res), snd res))"

definition "gb_sig_pprod to rword_strict fs \<equiv> gb_sig_pprod' to (rword_strict to) (map (change_ord (proj_ord to)) fs)"

lemma snd_gb_sig_z_pprod'_eq_gb_sig_z_pprod:
  "snd (gb_sig_z_pprod' to (rword_strict to) fs) = snd (gb_sig_z_pprod to rword_strict fs)"
  by (simp add: gb_sig_z_pprod_def change_ord_def Let_def)

lemma gb_sig_pprod'_eq_gb_sig_pprod:
  "gb_sig_pprod' to (rword_strict to) fs = gb_sig_pprod to rword_strict fs"
  by (simp add: gb_sig_pprod_def change_ord_def)

thm pprod'.aux.gb_sig_isGB[OF pprod'.aux.rw_rat_strict_is_strict_rewrite_ord, simplified gb_sig_pprod'_eq_gb_sig_pprod]
thm pprod'.aux.gb_sig_no_zero_red[OF pprod'.aux.rw_rat_strict_is_strict_rewrite_ord is_pot_ord_POT, simplified snd_gb_sig_z_pprod'_eq_gb_sig_z_pprod]

subsection \<open>Computations\<close>

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "gb_sig_pprod DRLEX rw_rat_strict_pprod [X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y, X * Y * Z + 2 * Y\<^sup>2] =
    [C\<^sub>0 (3 / 4) * X ^ 3 * Y\<^sup>2 - 2 * Y ^ 4, - 4 * Y ^ 3 * Z - 3 * X\<^sup>2 * Y\<^sup>2, X * Y * Z + 2 * Y\<^sup>2, X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y]"
  by eval

end

text \<open>Recall that the first return value of @{const gb_sig_z_pprod} is the size of the computed
  Gr\"obner basis, and the second return value is the total number of useless zero-reductions:\<close>

lemma
  "gb_sig_z_pprod (POT DRLEX) rw_rat_strict_pprod ((cyclic DRLEX 6)::(_ \<Rightarrow>\<^sub>0 rat) list) = (155, 8)"
  by eval

lemma
  "gb_sig_z_pprod (POT DRLEX) rw_rat_strict_pprod ((katsura DRLEX 5)::(_ \<Rightarrow>\<^sub>0 rat) list) = (29, 0)"
  by eval

lemma
  "gb_sig_z_pprod (POT DRLEX) rw_rat_strict_pprod ((eco DRLEX 8)::(_ \<Rightarrow>\<^sub>0 rat) list) = (76, 0)"
  by eval

lemma
  "gb_sig_z_pprod (POT DRLEX) rw_rat_strict_pprod ((noon DRLEX 5)::(_ \<Rightarrow>\<^sub>0 rat) list) = (83, 0)"
  by eval

end (* theory *)


header {* Writer monad *}

theory Writer_Monad
imports Monad
begin

subsection {* Monoid class *}

class monoid = "domain" +
  fixes mempty :: "'a"
  fixes mappend :: "'a \<rightarrow> 'a \<rightarrow> 'a"
  assumes mempty_left: "\<And>ys. mappend\<cdot>mempty\<cdot>ys = ys"
  assumes mempty_right: "\<And>xs. mappend\<cdot>xs\<cdot>mempty = xs"
  assumes mappend_assoc:
    "\<And>xs ys zs. mappend\<cdot>(mappend\<cdot>xs\<cdot>ys)\<cdot>zs = mappend\<cdot>xs\<cdot>(mappend\<cdot>ys\<cdot>zs)"

subsection {* Writer monad type *}

text {* Below is the standard Haskell definition of a writer monad
type; it is an isomorphic copy of the lazy pair type \texttt{(a, w)}.
*}

text_raw {*
\begin{verbatim}
newtype Writer w a = Writer { runWriter :: (a, w) }
\end{verbatim}
*}

text {* Since HOLCF does not have a pre-defined lazy pair type, we
will base this formalization on an equivalent, more direct definition:
*}

text_raw {*
\begin{verbatim}
data Writer w a = Writer w a
\end{verbatim}
*}

text {* We can directly translate the above Haskell type definition
using @{text tycondef}. \medskip *}

tycondef 'a\<cdot>'w writer = Writer (lazy "'w") (lazy "'a")

lemma coerce_writer_abs [simp]: "coerce\<cdot>(writer_abs\<cdot>x) = writer_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: writer_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_writer)
done

lemma coerce_Writer [simp]:
  "coerce\<cdot>(Writer\<cdot>w\<cdot>x) = Writer\<cdot>(coerce\<cdot>w)\<cdot>(coerce\<cdot>x)"
unfolding Writer_def by simp

lemma fmapU_writer_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>'w writer) = \<bottom>"
  "fmapU\<cdot>f\<cdot>(Writer\<cdot>w\<cdot>x) = Writer\<cdot>w\<cdot>(f\<cdot>x)"
unfolding fmapU_writer_def writer_map_def fix_const
apply simp
apply (simp add: Writer_def)
done

subsection {* Class instance proofs *}

instance writer :: ("domain") "functor"
proof
  fix f g :: "udom \<rightarrow> udom" and xs :: "udom\<cdot>'a writer"
  show "fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>xs) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
    by (induct xs rule: writer.induct) simp_all
qed

instantiation writer :: (monoid) monad
begin

fixrec bindU_writer ::
    "udom\<cdot>'a writer \<rightarrow> (udom \<rightarrow> udom\<cdot>'a writer) \<rightarrow> udom\<cdot>'a writer"
  where "bindU_writer\<cdot>(Writer\<cdot>w\<cdot>x)\<cdot>f =
    (case f\<cdot>x of Writer\<cdot>w'\<cdot>y \<Rightarrow> Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>y)"

lemma bindU_writer_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>'a writer)"
by fixrec_simp

definition
  "returnU = Writer\<cdot>mempty"

instance proof
  fix f :: "udom \<rightarrow> udom" and m :: "udom\<cdot>'a writer"
  show "fmapU\<cdot>f\<cdot>m = bindU\<cdot>m\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct m rule: writer.induct)
       (simp_all add: returnU_writer_def mempty_right)
next
  fix f :: "udom \<rightarrow> udom\<cdot>'a writer" and x :: "udom"
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>f = f\<cdot>x"
    by (cases "f\<cdot>x" rule: writer.exhaust)
       (simp_all add: returnU_writer_def mempty_left)
next
  fix m :: "udom\<cdot>'a writer" and f g :: "udom \<rightarrow> udom\<cdot>'a writer"
  show "bindU\<cdot>(bindU\<cdot>m\<cdot>f)\<cdot>g = bindU\<cdot>m\<cdot>(\<Lambda> x. bindU\<cdot>(f\<cdot>x)\<cdot>g)"
    apply (induct m rule: writer.induct, simp)
    apply (case_tac "f\<cdot>a" rule: writer.exhaust, simp)
    apply (case_tac "g\<cdot>aa" rule: writer.exhaust, simp)
    apply (simp add: mappend_assoc)
    done
qed

end

subsection {* Transfer properties to polymorphic versions *}

lemma fmap_writer_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>'w writer) = \<bottom>"
  "fmap\<cdot>f\<cdot>(Writer\<cdot>w\<cdot>x :: 'a\<cdot>'w writer) = Writer\<cdot>w\<cdot>(f\<cdot>x)"
unfolding fmap_def [where 'f="'w writer"]
by (simp_all add: coerce_simp)

lemma return_writer_def: "return = Writer\<cdot>mempty"
unfolding return_def returnU_writer_def
by (simp add: coerce_simp eta_cfun)

lemma bind_writer_simps [simp]:
  "bind\<cdot>(\<bottom> :: 'a\<cdot>'w::monoid writer)\<cdot>f = \<bottom>"
  "bind\<cdot>(Writer\<cdot>w\<cdot>x :: 'a\<cdot>'w::monoid writer)\<cdot>k =
    (case k\<cdot>x of Writer\<cdot>w'\<cdot>y \<Rightarrow> Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>y)"
unfolding bind_def
apply (simp add: coerce_simp)
apply (cases "k\<cdot>x" rule: writer.exhaust)
apply (simp_all add: coerce_simp)
done

lemma join_writer_simps [simp]:
  "join\<cdot>\<bottom> = (\<bottom> :: 'a\<cdot>'w::monoid writer)"
  "join\<cdot>(Writer\<cdot>w\<cdot>(Writer\<cdot>w'\<cdot>x)) = Writer\<cdot>(mappend\<cdot>w\<cdot>w')\<cdot>x"
unfolding join_def by simp_all

subsection {* Extra operations *}

definition tell :: "'w \<rightarrow> unit\<cdot>('w::monoid writer)"
  where "tell = (\<Lambda> w. Writer\<cdot>w\<cdot>())"

end


theory ArityAnalysisFixProps
imports ArityAnalysisFix ArityAnalysisSpec
begin

context SubstArityAnalysis
begin

lemma Afix_restr_subst:
  assumes "x \<notin> S"
  assumes "y \<notin> S"
  assumes "domA \<Gamma> \<subseteq> S"
  shows "Afix \<Gamma>[x::h=y]\<cdot>ae f|` S = Afix \<Gamma>\<cdot>(ae f|` S) f|` S"
  by (rule Afix_restr_subst'[OF Aexp_subst_restr[OF assms(1,2)] assms])
end

end


theory basic
  imports HOL.NthRoot HHL_SL invGen
begin

definition x :: exp where
  "x == RVar ''parx''"

definition y :: exp where
  "y == RVar ''pary''"

definition z :: exp where
  "z == RVar ''parz''"

definition Assignment :: proc where
  "Assignment == x := ((Real 1) [+] x)"

lemma B01:
  "{x[\<ge>](Real 0)} x := ((Real 1) [+] x) {x[\<ge>](Real 1); elE 0}"
  unfolding x_def
  apply (rule AssignRRule, auto, fold x_def)
proof -
  fix s
  assume a: "(x[\<ge>]Real 0) s"
  obtain c where evalx: "evalE x s = c"
    using a[unfolded fGreaterEqual_def] by auto
  show "(x[\<ge>]Real 1) (\<lambda>y. if y = ''parx'' then evalE (Real 1 [+] x) s else s y)"
  proof -
    have eval0: "evalE (Real 0) s = 0"
      by auto
    from a[unfolded fGreaterEqual_def] evalx eval0
    have nonneg_c: "0 \<le> c" by auto
    have evalx': "s ''parx'' = c"
      using evalx unfolding x_def evalE.simps(2) by auto
    show ?thesis
      unfolding fGreaterEqual_def x_def evalE.simps(2) evalE.simps(1)
      by (simp add: evalx' nonneg_c)
  qed
qed

lemma B02:
  "{x[\<ge>](Real 0)}
    (x :=((Real 1) [+] x ));
    (x :=((Real 1) [+] x ))*&& x[\<ge>](Real 1)
   {x[\<ge>](Real 1);elE 0}"

apply (cut_tac p="x[\<ge>](Real 0)"
           and P="(x :=((Real 1) [+] x ))"
           and m="x[\<ge>](Real 1)"
           and Q="(x :=((Real 1) [+] x ))*&& x[\<ge>](Real 1)"
           and q="x[\<ge>](Real 1)"
           and H="elE 0"
           and G="elE 0"
            in  SequentialRule_aux,auto)
    apply (cut_tac B01,auto)
   defer
   apply (simp add:chop_def)
  apply (simp add: Valid_def)
apply (cut_tac I="x[\<ge>](Real 1)"
           and P="x :=((Real 1) [+] x )"
           and H="elE 0"
            in  RepetitionRule,auto)
apply (simp add:chop_def)
defer
apply (simp add:dOr_def )
apply (cut_tac p="x[\<ge>](Real 1)"
           and q="x[\<ge>](Real 1)"
           and H="elE 0"
           and x="''parx''"
           and f="((Real 1) [+] x )" in  AssignRRule,auto)
defer apply (simp add:x_def)

proof-
  fix s
  assume a:"(x[\<ge>]Real 1) s"
  obtain c where evalx: "evalE x s = c"
     using a[unfolded fGreaterEqual_def] by auto
   show "(x[\<ge>]Real 1)
          (\<lambda>y. if y = ''parx'' then evalE (Real 1 [+] x) s else s y)"
proof -
    have eval1: "evalE (Real 1) s = 1"
      by auto
    from a[unfolded fGreaterEqual_def] evalx eval1
    have nonneg_c1: "1 \<le> c" by auto
    have nonneg_c0: "0 \<le> c" using nonneg_c1 by linarith
    have evalx': "s ''parx'' = c"
      using evalx unfolding x_def evalE.simps(2) by auto
    show ?thesis
      unfolding fGreaterEqual_def x_def evalE.simps(2) evalE.simps(1)
      by (simp add: evalx' nonneg_c0)
  qed
qed

lemma B03:
  "{x[\<ge>](Real 0)}
    (x :=((Real 1) [+] x ));
    (x :=((Real 1) [+] x )) [[ (y :=((Real 1) [+] y ))
   {x[\<ge>](Real 1);elE 0}"
apply (cut_tac p="x[\<ge>](Real 0)"
           and P="(x :=((Real 1) [+] x ))"
           and m="x[\<ge>](Real 1)"
           and Q="(x :=((Real 1) [+] x )) [[ (y :=((Real 1) [+] y ))"
           and q="x[\<ge>](Real 1)"
           and H="elE 0"
           and G="elE 0"
            in  SequentialRule_aux,auto)
    apply (cut_tac B01,auto)
   defer
   apply (simp add:chop_def)
  apply (simp add: Valid_def)
  apply (cut_tac P="(x :=((Real 1) [+] x )) "
           and Q="(y :=((Real 1) [+] y ))"
           and p="x[\<ge>](Real 1)"
           and m="x[\<ge>](Real 1)"
           and q="x[\<ge>](Real 1)"
           and H="elE 0"
           and G="elE 0"  in JoinRule,auto)
defer
defer
apply (simp add:fOr_def )
apply (simp add:dOr_def )
apply (cut_tac p="x[\<ge>](Real 1)"
           and q="x[\<ge>](Real 1)"
           and H="elE 0"
           and x="''parx''"
           and f="((Real 1) [+] x )" in  AssignRRule,auto)
    defer
    apply (simp add:x_def)
apply (cut_tac p="x[\<ge>](Real 1)"
           and q="x[\<ge>](Real 1)"
           and H="elE 0"
           and x="''pary''"
           and f="((Real 1) [+] y )" in  AssignRRule,auto)
    defer
    apply (simp add:y_def)

proof-
  fix s
  assume a:"(x[\<ge>]Real 1) s"
  obtain c where evalx: "evalE x s = c"
     using a[unfolded fGreaterEqual_def] by auto
   show "(x[\<ge>]Real 1)
          (\<lambda>y. if y = ''parx'' then evalE (Real 1 [+] x) s else s y)"
proof -
    have eval1: "evalE (Real 1) s = 1"
      by auto
    from a[unfolded fGreaterEqual_def] evalx eval1
    have nonneg_c1: "1 \<le> c" by auto
    have nonneg_c0: "0 \<le> c" using nonneg_c1 by linarith
    have evalx': "s ''parx'' = c"
      using evalx unfolding x_def evalE.simps(2) by auto
    show ?thesis
      unfolding fGreaterEqual_def x_def evalE.simps(2) evalE.simps(1)
      by (simp add: evalx' nonneg_c0)
  qed
  assume a:"(x[\<ge>]Real 1) s"
  obtain c where evalx: "evalE x s = c"
     using a[unfolded fGreaterEqual_def] by auto
   show "(x[\<ge>]Real 1)
          (\<lambda>ya. if ya = ''pary'' then evalE (Real 1 [+] y) s else s ya) "
proof -
    have eval1: "evalE (Real 1) s = 1"
      by auto
    from a[unfolded fGreaterEqual_def] evalx eval1
    have nonneg_c1: "1 \<le> c" by auto
    have evalx': "s ''parx'' = c"
      using evalx unfolding x_def evalE.simps(2) by auto
    show ?thesis
      unfolding fGreaterEqual_def x_def y_def evalE.simps(2) evalE.simps(1)
      by (simp add: evalx' nonneg_c1)
qed
qed

consts Inv :: fform

definition cons11 :: fform where "cons11 \<equiv> (x [\<ge>] Real 1) [\<longrightarrow>] Inv"
definition cons12 :: fform where "cons12 \<equiv> Inv [\<longrightarrow>] (x [\<ge>] Real 1)"
definition cons13 :: fform where "cons13 \<equiv> exeFlow(<[''parx'']: [(Real 2)] && Inv & fTrue>) Inv [\<longrightarrow>] Inv"

lemma allcons1: "\<forall>s. (cons11 [&] cons12 [&] cons13) s"
  apply (simp only: cons11_def cons12_def cons13_def x_def)
  by (inv_check_oracle "parx-1>=0")

lemma ODE1:
  "{x [\<ge>] (Real 0)}  \<comment> \<open>x >= 0\<close>
    (x := ((Real 1) [+] x));  \<comment> \<open>x := 1 + x\<close>
    <[''parx'']: [(Real 2)] && Inv & fTrue>  \<comment> \<open>x' = 2 & True\<close>
   {x[\<ge>](Real 1); (elE 0 [[|]] (almost (x[\<ge>](Real 1))))}"  \<comment> \<open>x >= 1\<close>
  apply (rule SequentialRule[where m="x[\<ge>](Real 1)" and H="elE 0" and G="elE 0 [[|]] (almost (x[\<ge>](Real 1)))"])
  apply (rule B01)
  prefer 2 subgoal
    by (simp add:chop_def dOr_def Valid_def)
  apply (rule ContinuousRuleGT)
  using allcons1 apply (auto simp add: cons11_def cons12_def cons13_def fAnd_def fImp_def dOr_def)
  by (metis (no_types, lifting) almostmono)

definition cons21:: fform where "cons21 \<equiv>  ((x [\<ge>] Real 0)[&](y [\<ge>] Real 0)[&](z [\<ge>] Real 0)) [\<longrightarrow>] Inv "
definition cons22:: fform where "cons22 \<equiv>  Inv [\<longrightarrow>] (x [\<ge>] Real 0) "
definition cons23:: fform where "cons23 \<equiv>  exeFlow(<[''parx'', ''pary'']: [y,z] && Inv & fTrue>) (Inv)  [\<longrightarrow>]  Inv"

lemma allcons2:"\<forall> s. ( cons21 [&] cons22 [&] cons23 ) s"
  apply (simp only:cons21_def cons22_def cons23_def x_def y_def z_def)
  by (inv_check_oracle "parz >= 0 & pary >= 0 & parx >= 0 ")

lemma ODE2:"{x [\<ge>] Real 0 [&] y [\<ge>] Real 0 [&] z [\<ge>] Real 0}
           <[''parx'', ''pary'']:[y, z]&&Inv&\<lambda>s. True>
            {x [\<ge>] Real 0; (elE 0 [[|]] (almost (x[\<ge>](Real 0))))}"
  apply (rule ContinuousRuleGT)
  using allcons2 apply (auto simp add:cons21_def cons22_def cons23_def x_def y_def z_def fAnd_def fImp_def dOr_def)
  by (smt almostmono)

definition cons31:: fform where "cons31 \<equiv>  (x [\<ge>] Real 0) [\<longrightarrow>] Inv "
definition cons32:: fform where "cons32 \<equiv>  Inv [\<longrightarrow>] (x [\<ge>] Real 0) "
definition cons33:: fform where "cons33 \<equiv>  exeFlow(<[''parx'']: [(Real 5)] && Inv & fTrue>) (Inv)  [\<longrightarrow>]  Inv"
definition cons34:: fform where "cons34 \<equiv>  exeFlow(<[''parx'']: [(Real 2)] && Inv & fTrue>) (Inv)  [\<longrightarrow>]  Inv"
definition cons35:: fform where "cons35 \<equiv>  exeFlow(<[''parx'']: [x] && Inv & fTrue>) (Inv)  [\<longrightarrow>]  Inv"

lemma allcons3:"\<forall> s. ( cons31 [&] cons32 [&] cons33 [&] cons34 [&] cons35) s"
  apply (simp only:cons31_def cons32_def cons33_def cons34_def cons35_def
          x_def )
  by (inv_check_oracle "parx>=0")

lemma ODE3:"{x [\<ge>] Real 0 }
           <[''parx'']: [(Real 5)] && Inv & fTrue>;
           <[''parx'']: [(Real 2)] && Inv & fTrue>;
           <[''parx'']: [x] && Inv & fTrue>
            {x [\<ge>] Real 0; (elE 0 [[|]] (almost (x[\<ge>](Real 0))))}"
  apply (rule SequentialRule[where m="x[\<ge>](Real 0)" and H="elE 0 [[|]] (almost (x[\<ge>](Real 0)))" and G="elE 0 [[|]] (almost (x[\<ge>](Real 0)))"])
  apply (rule ContinuousRuleGT)
  using allcons3 apply (simp add:cons31_def cons32_def cons33_def cons34_def cons35_def
          x_def fAnd_def fImp_def dOr_def )
    apply (smt almostmono)
   apply (rule SequentialRule[where m="x[\<ge>](Real 0)" and H="elE 0 [[|]] (almost (x[\<ge>](Real 0)))" and G="elE 0 [[|]] (almost (x[\<ge>](Real 0)))"])
   apply (rule ContinuousRuleGT)
  using allcons3 apply (simp add:cons31_def cons32_def cons33_def cons34_def cons35_def
          x_def fAnd_def fImp_def dOr_def )
    apply (smt almostmono)
   apply (rule ContinuousRuleGT)
  using allcons3 apply (simp add:cons31_def cons32_def cons33_def cons34_def cons35_def
          x_def fAnd_def fImp_def dOr_def )
    apply (smt almostmono)
  using chopfor apply blast
  using chopfor apply blast
  done

definition exp41:: exp where
  "exp41 \<equiv> ((Real 0 [-] x [-] ((Real 1117 [*] y) [div] Real 500)) [+]
   ((Real 439 [*] y [**] 3) [div] Real 200 ))[-]((Real 333 [*] y [**] 5) [div] Real 500) "

definition exp42:: exp where
  "exp42 \<equiv> ((x [+]((Real 617 [*] y) [div] Real 500)) [-]
   ((Real 439 [*] y [**] 3) [div] Real 200 ))[+]((Real 333 [*] y [**] 5) [div] Real 500)"

definition cons41:: fform where
  "cons41 \<equiv>  (x[**]2 [\<le>] Real (1/2) [&] y[**]2 [\<le>] Real (1/3)) [\<longrightarrow>] Inv "

definition cons42:: fform where
  "cons42 \<equiv>  Inv [\<longrightarrow>] (x [-] Real 4 [*] y [<] Real 8) "

definition cons43:: fform where
  "cons43 \<equiv>  exeFlow(<[''parx'', ''pary'']: [(exp41),(exp42)] && Inv & fTrue>) (Inv)  [\<longrightarrow>]  Inv"

lemma allcons4:"\<forall> s. ( cons41 [&] cons42 [&] cons43 ) s"
  apply (simp only:cons41_def cons42_def cons43_def exp41_def exp42_def
          x_def y_def)
  (*apply (inv_oracle_SOS)
 done*)
by (inv_check_oracle "parx^2 + parx*pary + pary^2 - 111/59 <= 0")

lemma ODE4:"{x[**]2 [\<le>] Real (1/2) [&] y[**]2 [\<le>] Real (1/3)}
           <[''parx'', ''pary'']: [(exp41),(exp42)] && Inv & fTrue>
            {x [-] Real 4 [*] y [<] Real 8;elE 0 [[|]] (almost (x [-] Real 4 [*] y [<] Real 8))}"
  apply (rule ContinuousRuleGT)
  using allcons4 apply (simp add: cons41_def cons42_def cons43_def x_def y_def fAnd_def fImp_def dOr_def )
  by (smt almostmono)

definition cons51:: fform where
  "cons51 \<equiv>  (x[**]2 [\<le>] Real (1/2) [&] (y [+] Real 2)[**]2 [\<le>] Real (1/3)) [\<longrightarrow>] Inv"

definition cons52:: fform where
  "cons52 \<equiv>  Inv [\<longrightarrow>] ((x [-] Real 1) [**]2 [+] (y [-] Real (3/2)) [**]2 [>] Real (1/4)) "

definition cons53:: fform where
  "cons53 \<equiv>  exeFlow(<[''parx'', ''pary'']: [((y[-]x)[-]x[**]3),((y[**]2[-]x)[-]y)] && Inv & fTrue>) (Inv)  [\<longrightarrow>]  Inv"

lemma allcons5:"\<forall> s. ( cons51 [&] cons52 [&] cons53 ) s"
  apply (simp only: cons51_def cons52_def cons53_def x_def y_def)
  by (inv_check_oracle "2*(parx^2) + (pary+3/2)^2 - 4 <= 0")

lemma ODE5:"{x[**]2 [\<le>] Real (1/2) [&] (y [+] Real 2) [**]2 [\<le>] Real (1/3)}
           <[''parx'', ''pary'']: [((y[-]x)[-]x[**]3),((y[**]2[-]x)[-]y)] && Inv & fTrue>
            {(x [-] Real 1) [**]2 [+] (y [-] Real (3/2)) [**]2 [>] Real (1/4);elE 0 [[|]] (almost ((x [-] Real 1) [**]2 [+] (y [-] Real (3/2)) [**]2 [>] Real (1/4)))}"
apply (rule ContinuousRuleGT)
  using allcons5 apply (simp add:cons51_def cons52_def cons53_def
          x_def y_def  fAnd_def fImp_def dOr_def )
  by (smt almostmono)

end


theory Hotel_Example_Small_Generator
imports Hotel_Example "~~/src/HOL/Library/Predicate_Compile_Alternative_Defs"
begin

ML_file "~~/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML"

declare Let_def[code_pred_inline]

lemma [code_pred_inline]: "insert == (%y A x. y = x | A x)"
by (auto simp add: insert_iff[unfolded mem_def] fun_eq_iff intro!: eq_reflection)

lemma [code_pred_inline]: "(-) == (%A B x. A x \<and> \<not> B x)"
by (auto simp add: Diff_iff[unfolded mem_def] fun_eq_iff intro!: eq_reflection)

instantiation room :: small_lazy
begin

definition
  "small_lazy i = Lazy_Sequence.single Room0"

instance ..

end

instantiation key :: small_lazy
begin

definition
  "small_lazy i = Lazy_Sequence.append (Lazy_Sequence.single Key0) (Lazy_Sequence.append (Lazy_Sequence.single Key1) (Lazy_Sequence.append (Lazy_Sequence.single Key2) (Lazy_Sequence.single Key3)))"

instance ..

end

instantiation guest :: small_lazy
begin

definition
  "small_lazy i = Lazy_Sequence.append (Lazy_Sequence.single Guest0) (Lazy_Sequence.single Guest1)"

instance ..

end

ML \<open>
val small_15_active = Attrib.setup_config_bool @{binding quickcheck_small_14_active} (K false);
val small_14_active = Attrib.setup_config_bool @{binding quickcheck_small_15_active} (K false);
\<close>

setup \<open>
  Context.theory_map (Quickcheck.add_tester ("small_generators_depth_14",
    (small_14_active, Predicate_Compile_Quickcheck.test_goals
      (Predicate_Compile_Aux.Pos_Generator_DSeq, true, true, 14))))
  #> Context.theory_map (Quickcheck.add_tester ("small_generators_depth_15",
    (small_15_active, Predicate_Compile_Quickcheck.test_goals
      (Predicate_Compile_Aux.Pos_Generator_DSeq, true, true, 15))))
\<close>

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
(*quickcheck[tester = small_generators_depth_14, finite_types = false, iterations = 1, size = 1, timeout = 1200.0, expect = no_counterexample]*)
quickcheck[tester = small_generators_depth_15, finite_types = false, iterations = 1, size = 1, timeout = 2400.0, expect = counterexample]
oops

end


section {*L\_ATS\_Marking\_Configurations*}
theory
  L_ATS_Marking_Configurations

imports
  L_ATS_Language

begin

locale ATS_Marking_Configurations =
  ATS_Language
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label,'conf)derivation \<Rightarrow> 'event set"
  for
    TSstructure configurations initial_configurations step_labels step_relation effects marking_condition marked_effect unmarked_effect
    +

fixes marking_configurations :: "'TSstructure \<Rightarrow> 'conf set"
fixes marked_configuration_effect :: "'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'event set"
fixes unmarked_configuration_effect :: "'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'event set"

assumes AX_marking_condition_coincides_with_marking_configurations: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> marking_condition G d
  \<longleftrightarrow> (\<exists>i e c.
        d i = Some (pair e c)
        \<and> c \<in> marking_configurations G)"

assumes AX_marked_configuration_effect_coincides_with_marked_effect: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> marking_condition G (derivation_take d n)
  \<Longrightarrow> marked_effect G d
  = \<Union>{marked_configuration_effect G c| c. \<exists>i e.
        d i = Some (pair e c)
        \<and> c \<in> marking_configurations G}"

assumes AX_unmarked_configuration_effect_coincides_with_unmarked_effect: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> unmarked_effect G d
  = \<Union>{unmarked_configuration_effect G c| c. \<exists>i e.
        d i = Some (pair e c)}"

context ATS_Marking_Configurations
begin

lemma derivation_append_preserves_marking_condition: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> derivation_initial G (derivation_append d d' n)
  \<Longrightarrow> belongs G d
  \<Longrightarrow> belongs G d'
  \<Longrightarrow> marking_condition G d
  \<Longrightarrow> maximum_of_domain d n
  \<Longrightarrow> marking_condition G (derivation_append d d' n)"
  apply(rule_tac
      t="marking_condition G (derivation_append d d' n)"
      and s="(\<exists>i e c. ((derivation_append d d' n) i = Some (pair e c)) \<and> c \<in> (marking_configurations G))"
      in ssubst)
   apply(rule AX_marking_condition_coincides_with_marking_configurations)
    apply(force)
   apply(force)
  apply(subgoal_tac "\<exists>i e c. (d i = Some (pair e c)) \<and> c \<in> (marking_configurations G)")
   prefer 2
   apply(rule_tac
      s="marking_condition G d"
      in subst)
    apply(rule AX_marking_condition_coincides_with_marking_configurations)
     apply(force)
    apply(force)
   apply(force)
  apply(erule exE)+
  apply(rename_tac i e c)(*strict*)
  apply(rule_tac
      x="i"
      in exI)
  apply(rule_tac
      x="e"
      in exI)
  apply(rule_tac
      x="c"
      in exI)
  apply(simp add: derivation_append_def)
  apply(clarsimp)
  apply(rule_tac
      d="d"
      in no_some_beyond_maximum_of_domain)
     apply(rename_tac i e c)(*strict*)
     apply(simp add: derivation_initial_def)
     apply(force)
    apply(rename_tac i e c)(*strict*)
    apply(force)
   apply(rename_tac i e c)(*strict*)
   apply(force)
  apply(rename_tac i e c)(*strict*)
  apply(force)
  done

lemma marking_can_not_be_disabled: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> marking_condition G (derivation_take d n)
  \<Longrightarrow> marking_condition G d"
  apply(rule_tac
      t="marking_condition G d"
      in ssubst)
   apply(rule AX_marking_condition_coincides_with_marking_configurations)
    apply(force)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac
      s="marking_condition G (derivation_take d n)"
      in subst)
    apply(rule AX_marking_condition_coincides_with_marking_configurations)
     apply(force)
    apply(rule derivation_take_preserves_derivation_initial)
    apply(force)
   apply(force)
  apply(thin_tac "marking_condition G (derivation_take d n)")
  apply(clarsimp)
  apply(rename_tac i e c)(*strict*)
  apply(rule_tac
      x="i"
      in exI)
  apply(simp add: derivation_take_def)
  apply(case_tac "i\<le>n")
   apply(rename_tac i e c)(*strict*)
   apply(force)
  apply(rename_tac i e c)(*strict*)
  apply(force)
  done

lemma marked_effect_persists: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> marking_condition G (derivation_take d n)
  \<Longrightarrow> marked_effect G (derivation_take d n) \<subseteq> marked_effect G d"
  apply(rule_tac
      t="marked_effect G SSd" for SSd
      in ssubst)
   apply(rule AX_marked_configuration_effect_coincides_with_marked_effect)
     apply(force)
    apply(force)
   apply(force)
  apply(rule_tac
      t="marked_effect G SSd" for SSd
      in ssubst)
   apply(rule_tac
      n="n"
      in AX_marked_configuration_effect_coincides_with_marked_effect)
     apply(force)
    apply(rule derivation_take_preserves_derivation_initial)
    apply(force)
   apply (metis derivation_initial_is_derivation derivation_take_def derivation_take_id_prime derivation_take_preserves_derivation derivation_take_twice)
  apply(simp (no_asm))
  apply(clarsimp)
  apply(rename_tac x c i e)(*strict*)
  apply(simp add: derivation_take_def)
  apply(case_tac "i\<le>n")
   apply(rename_tac x c i e)(*strict*)
   apply(force)
  apply(rename_tac x c i e)(*strict*)
  apply(force)
  done

lemma unmarked_effect_persists: "
  TSstructure G
  \<Longrightarrow> derivation_initial G d
  \<Longrightarrow> unmarked_effect G (derivation_take d n) \<subseteq> unmarked_effect G d"
  apply(rule_tac
      t="unmarked_effect G d"
      in ssubst)
   apply(rule AX_unmarked_configuration_effect_coincides_with_unmarked_effect)
    apply(force)
   apply(force)
  apply(rule_tac
      t="unmarked_effect G (derivation_take d n)"
      in ssubst)
   apply(rule AX_unmarked_configuration_effect_coincides_with_unmarked_effect)
    apply(force)
   apply(rule derivation_take_preserves_derivation_initial)
   apply(force)
  apply(clarsimp)
  apply(rename_tac x c i e)(*strict*)
  apply(simp add: derivation_take_def)
  apply(case_tac "i\<le>n")
   apply(rename_tac x c i e)(*strict*)
   apply(force)
  apply(rename_tac x c i e)(*strict*)
  apply(force)
  done

definition marking_relevant_step_labels :: "
  'TSstructure
  \<Rightarrow> 'label set"
  where
    "marking_relevant_step_labels G \<equiv>
  {e.
    \<exists>d n c.
      derivation_initial G d
      \<and> d n = Some (pair (Some e) c)
      \<and> (\<exists>k\<ge>n. \<exists>e c. d k = Some (pair e c) \<and> c \<in> marking_configurations G)}"

end

end


theory Delete_Opt
  imports
    "Combine_Opt"
    "../Delete"
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

partial_function (M) del_opt ::
  "'ki \<Rightarrow> ('ki, 'vi) rbti \<Rightarrow> (('ki, 'vi) rbti) llM" where
  "del_opt x t_p =
  do {
    if t_p = null then return null
    else do {
      t \<leftarrow> ll_load t_p;
      case t of (RBT_NODE c a y s b) \<Rightarrow>
      do {
        if! lt_impl x y
        then! do {
          cond \<leftarrow> ll_is_black_br a;
          l_del \<leftarrow> del_opt x a;
          set_left_p l_del t_p;
          if cond = 1
          then do {balance_left_opt t_p}
          else do {set_color_p 0 t_p; return t_p}
        }
        else! if! lt_impl y x
        then! do {
          cond \<leftarrow> ll_is_black_br b;
          r_del \<leftarrow> del_opt x b;
          set_right_p r_del t_p;
          if cond = 1
          then do {balance_right_opt t_p }
          else do {set_color_p 0 t_p; return t_p}
        }
        else! do {
            key_free y;
            value_free s;
            ll_free t_p;
            combine_opt a b
        }
      }
    }
  }"

lemmas [llvm_code] = del_opt.simps

lemma del_opt_correct':
"
  llvm_htriple
  (\<upharpoonleft>key_assn k ki ** rbt_assn t ti ** \<up>(is_rbt_node t))
  (del_opt ki ti)
  (\<lambda>r. rbt_assn (rbt_del_ad k t) r ** \<upharpoonleft>key_assn k ki)
"
proof(induct k t arbitrary: ki ti rule: rbt_del_ad.induct)
  case (1 x)
  then show ?case
    apply (subst del_opt.simps)
    apply vcg
    done
next
  case (2 x c a y s b)

  have IH1:
    "x < y \<Longrightarrow> llvm_htriple
      (\<upharpoonleft>key_assn x ki \<and>* rbt_assn a ti ** \<up>(is_rbt_node a))
      (del_opt ki ti)
      (\<lambda>r. rbt_assn (rbt_del_ad x a) r \<and>* \<upharpoonleft>key_assn x ki)"
    for ki ti
    using 2(1-2) by fast

  have IH2:
    "y < x \<Longrightarrow> llvm_htriple
      (\<upharpoonleft>key_assn x ki \<and>* rbt_assn b ti ** \<up>(is_rbt_node b))
      (del_opt ki ti)
      (\<lambda>r. rbt_assn (rbt_del_ad x b) r \<and>* \<upharpoonleft>key_assn x ki)"
    for ki ti using 2(3-4) by fastforce

  note [vcg_rules] = IH1 IH2

  show ?case
    apply (subst del_opt.simps)
    apply vcg
    done
qed

lemma del_opt_correct:
"
  llvm_htriple
  (\<upharpoonleft>key_assn k ki ** rbt_assn t ti ** \<up>(is_rbt_node t))
  (del_opt ki ti)
  (\<lambda>r. rbt_assn (rbt_del k t) r ** \<upharpoonleft>key_assn k ki)
"
  using del_opt_correct' rbt_del_ad_correct by metis

definition "delete_opt x t \<equiv> do {
  del_res \<leftarrow> del_opt x t;
  (if del_res = null then return () else set_color_p 1 del_res);
  return del_res
  }"

lemmas [llvm_code] = delete_opt_def

lemma delete_opt_correct [vcg_rules]:
"
  llvm_htriple
  (\<upharpoonleft>key_assn k ki ** rbt_assn t ti ** \<up>(is_rbt_node t))
  (delete_opt ki ti)
  (\<lambda>r. rbt_assn (rbt_delete k t) r ** \<upharpoonleft>key_assn k ki)
"
  unfolding delete_opt_def rbt_delete_def paint_def
  supply del_opt_correct[vcg_rules]
  apply vcg
  done

end

end