\<^marker>\<open>creator Florian Keßler\<close>

section "IMP- to SAS+"

theory IMP_Minus_To_SAS_Plus
  imports "IMP-_To_IMP--/IMP_Minus_To_IMP_Minus_Minus"
    "IMP--_To_SAS++/IMP_Minus_Minus_To_SAS_Plus_Plus_Correctness"
    "SAS++_To_SAS+/SAS_Plus_Plus_To_SAS_Plus"
begin

text \<open> We combine our reduction steps from IMP- to IMP--, then from IMP-- to SAS++ and finally
  from SAS++ to SAS+ to give a reduction IMP- to SAS+. We then proceed to show the correctness of
  this reduction, by combining the correctness results we have derived for the individual parts
  of the reduction. \<close>

type_synonym SAS_problem = "(IMP_Minus_Minus_To_SAS_Plus_Plus_State_Translations.variable,
  IMP_Minus_Minus_To_SAS_Plus_Plus_State_Translations.domain_element) problem"

lemma le_two_to_the_bit_length_intro: "x \<le> y \<Longrightarrow> x \<le> 2 ^ (bit_length y)"
  using log_exp2_gt[of y]
  by (auto simp: bit_length_def)

text \<open> We give a definition to compute the upper bound on the number of bits needed to represent
       all of the fixed input of some IMP- program, the biggest constant therein and all guessed
       values up to some r. \<close>

definition max_input_bits:: "IMP_Minus_com \<Rightarrow> (vname \<rightharpoonup> nat) \<Rightarrow> nat \<Rightarrow> nat" where
"max_input_bits c I r =
  bit_length (max (max (Max (ran I)) r) (Max_Constant.max_constant c))"

lemma bit_at_index_geq_max_input_bits_is_zero:
  assumes "x < r" "max_input_bits c I r \<le> b"
  shows "nth_bit x b = Zero"
  using \<open>x < r\<close>
  by (fastforce intro: bit_geq_bit_length_is_Zero bit_length_monotonic
                       le_trans[OF _ \<open>max_input_bits c I r \<le> b\<close>]
                simp: max_input_bits_def)

lemma bit_at_index_geq_max_input_bits_is_zero_in_initial_state:
  assumes "finite (ran I)" "max_input_bits c I r \<le> b" "I x = Some y"
  shows "nth_bit y b = Zero"
  using assms(1,3)
  by(fastforce intro: bit_geq_bit_length_is_Zero le_trans[OF _ \<open>max_input_bits c I r \<le> b\<close>]
                      Max_ge ranI max.coboundedI1 bit_length_monotonic
               simp: max_input_bits_def)

lemma max_constant_less_two_to_the_max_input_bits:
  "max_constant c < 2 ^ (max_input_bits c I r)"
  using log_exp2_gt max_less_iff_conj
  by(fastforce simp: max_input_bits_def bit_length_def)

lemma initial_state_element_less_two_to_the_max_input_bits:
  "\<lbrakk>finite (ran I); I x = Some y\<rbrakk> \<Longrightarrow> y < (2 :: nat) ^ (max_input_bits c I r)"
  by(force intro: log_exp2_gt Max_ge ranI order.strict_trans1[of y "Max (ran I)"]
                  order.strict_trans1[of _ "(max (max (Max (ran I)) r) (max_constant c))"]
           simp: algebra_simps max_input_bits_def bit_length_def)

text \<open> Translation of a (partial) initial state from IMP- to IMP--. Observe that in order to avoid
       overflows when executing IMP--, we require all bits beyond a certain guess_range in the bit
       blasted IMP-- registers that are unspecified in the IMP- initial state to be zero. \<close>

text \<open> We give our reduction, by composing the steps IMP- \<Rightarrow> IMP-- \<Rightarrow> SAS++ \<Rightarrow> SAS+. For the IMP-
       \<Rightarrow> IMP-- step, we compute a number of bits n that is guaranteed to suffice for all
      executions of the program for at most t steps, starting in initial states where the maximal
      value of any register is bounded by the maximum of the maximal value of any register in the
      partial initial state I and r. \<close>

definition IMP_Minus_to_SAS_Plus:: "IMP_Minus_com \<Rightarrow> (vname \<rightharpoonup> nat) \<Rightarrow> nat \<Rightarrow> (vname \<rightharpoonup> nat)
  \<Rightarrow>  nat \<Rightarrow> SAS_problem" where
"IMP_Minus_to_SAS_Plus c I r G t =
 (let
    guess_range = max_input_bits c I r;
    n = t + guess_range + 1;
    c' = IMP_Minus_To_IMP_Minus_Minus c n;
    I' = IMP_Minus_State_To_IMP_Minus_Minus_partial I n guess_range |` (set (enumerate_variables c'));
    G' = (IMP_Minus_State_To_IMP_Minus_Minus_partial G n n) |` (set (enumerate_variables c'));
    sas_pp = imp_minus_minus_to_sas_plus c' I' G';
    sas_p = SAS_Plus_Plus_To_SAS_Plus sas_pp
  in
    sas_p)"

lemma le_mul_intro: "0 < b \<Longrightarrow> a \<le> b \<Longrightarrow> (1 :: nat) < c \<Longrightarrow> a < c * b"
  by (metis One_nat_def dual_order.strict_trans le_neq_implies_less n_less_m_mult_n)

text \<open> First direction of the correctness proof for the IMP- to SAS+ reduction, showing that when
       the IMP- program terminates in some state, then in SAS+ there is a plan that will reach any
      goal state that matches the end state of the IMP- program, such that the plan is polynomially
      longer than the execution in IMP-. The constants used to bound the length of the plan have
      no significance, rather they are just derived by adding up the various constants that we
      used in the correctness proofs for the different parts of the reduction. \<close>

lemma map_le_proj: "m1 \<subseteq>\<^sub>m m2 \<Longrightarrow> m1 |` s \<subseteq>\<^sub>m m2 |` s"
  by (auto simp: map_le_def)

lemma map_le_IMP_Minus_State_To_IMP_Minus_Minus:
  "\<lbrakk>s1 \<subseteq>\<^sub>m Some \<circ> s2\<rbrakk> \<Longrightarrow>
   IMP_Minus_State_To_IMP_Minus_Minus_partial s1 n n \<subseteq>\<^sub>m IMP_Minus_State_To_IMP_Minus_Minus s2 n"
    apply (auto simp: IMP_Minus_State_To_IMP_Minus_Minus_partial_def
                   IMP_Minus_State_To_IMP_Minus_Minus_def
                   IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def
                   map_le_def
             split!: option.splits if_splits char.splits bool.splits)
    by (smt domI map_comp_Some_iff option.inject)+

lemma map_le_IMP_Minus_State_To_IMP_Minus_Minus_2:
  "\<lbrakk>s1 \<subseteq>\<^sub>m Some \<circ> s2; range s2 \<noteq> {}; finite (range s2); Max (range s2) < r; (bit_length r) \<le> rbl\<rbrakk> \<Longrightarrow>
   IMP_Minus_State_To_IMP_Minus_Minus_partial s1 n rbl \<subseteq>\<^sub>m IMP_Minus_State_To_IMP_Minus_Minus s2 n"
    apply (auto simp: IMP_Minus_State_To_IMP_Minus_Minus_partial_def
                   IMP_Minus_State_To_IMP_Minus_Minus_def
                   IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def
                   map_le_def image_def
             split!: option.splits if_splits char.splits bool.splits)
   apply (smt domI map_comp_Some_iff option.inject)
  apply(intro bit_geq_bit_length_is_Zero[symmetric])
  by (metis bit_length_monotonic leI le_less less_le_trans)

lemma IMP_Minus_to_SAS_Plus_correctness:
  assumes
    "I \<subseteq>\<^sub>m Some \<circ> s1"
    "finite (range s1)"
    "Max (range s1) < r"
    "G \<subseteq>\<^sub>m Some \<circ> s2"
    "(c, s1) \<Rightarrow>\<^bsup>t\<^esup> s2"
    "t \<le> t'"
  shows
    "\<exists>plan. length plan \<le> 100 * (max_input_bits c I r + t' + 1) * (t' - 1)
                            + (max_input_bits c I r + t' + 1 + 1) * (num_variables c + 2) + 52
            \<and> is_serial_solution_for_problem (IMP_Minus_to_SAS_Plus c I r G t') plan"
proof -
  let ?guess_range = " max_input_bits c I r"
  let ?n = "?guess_range + t' + 1"
  let ?c' = "IMP_Minus_To_IMP_Minus_Minus c ?n"
  let ?s1' = "IMP_Minus_State_To_IMP_Minus_Minus s1 ?n |` (set (enumerate_variables ?c'))"
  let ?s2' = "IMP_Minus_State_To_IMP_Minus_Minus s2 ?n |` (set (enumerate_variables ?c'))"
  let ?I = "(IMP_Minus_State_To_IMP_Minus_Minus_partial I ?n ?guess_range)
    |` (set (enumerate_variables ?c'))"
  let ?G = "(IMP_Minus_State_To_IMP_Minus_Minus_partial G ?n ?n)
    |` (set (enumerate_variables ?c'))"
  let ?t = "100 * ?n * (t' - 1) + 51"
  let ?sas_plus_plus_problem
    = "imp_minus_minus_to_sas_plus ?c' ?I ?G"

  have "?n > 0" by simp

  have "Suc 0 < 2 ^ t'"
    using \<open>(c, s1) \<Rightarrow>\<^bsup> t \<^esup> s2\<close> \<open>t \<le> t'\<close> log_Suc_zero
    by (fastforce intro: Suc_lessI dest: bigstep_progress)
  moreover have "2 ^ t * max (Max (range s1)) (max_constant c) \<le> 2 ^ t' * 2 ^ max_input_bits c I r"
           (is "?max_bits_t \<le> _")
    using \<open>Max (range s1) < r\<close> \<open>t \<le> t'\<close> le_two_to_the_bit_length_intro mult_le_mono
    by (auto simp: max_input_bits_def)
  ultimately have "?max_bits_t < 2 ^ (t' + max_input_bits c I r + 1)"
    by(auto simp: power_add intro!: le_mul_intro)
  moreover have "t < t' + max_input_bits c I r + 1"
    using assms
    by auto

  ultimately have "t_small_step_fun (100 * ?n * (t - 1) + 50)
      (IMP_Minus_To_IMP_Minus_Minus c ?n, IMP_Minus_State_To_IMP_Minus_Minus s1 ?n)
     = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus s2 ?n)"
    using assms(2,5)
    by (fastforce intro!: IMP_Minus_To_IMP_Minus_Minus simp: add.commute)+
  moreover have "(100 * ?n * (t - 1) + 50) \<le> (100 * ?n * (t' - 1) + 50)"
    using \<open>t \<le> t'\<close>
    by auto
  ultimately have
    "t_small_step_fun (100 * ?n * (t' - 1) + 50) (?c', IMP_Minus_State_To_IMP_Minus_Minus s1 ?n)
       = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus s2 ?n)"
    using t_small_step_fun_increase_time by blast
  hence "\<exists>t'' \<le> 100 * ?n * (t' - 1) + 50. (?c', ?s1') \<rightarrow>\<^bsup>t''\<^esup> (SKIP, ?s2')"
    by(auto simp: t_small_step_fun_restrict_variables
            intro: iffD1[OF t_small_step_fun_t_small_step_equivalence])
  then obtain t'' where t''_def: "t'' \<le> 100 * ?n * (t' - 1) + 50" "(?c', ?s1') \<rightarrow>\<^bsup>t''\<^esup> (SKIP, ?s2')"
    by blast

  have "?G \<subseteq>\<^sub>m ?s2'"
    by (intro map_le_proj map_le_IMP_Minus_State_To_IMP_Minus_Minus[OF \<open>G \<subseteq>\<^sub>m Some \<circ> s2\<close>])

  have "?I  \<subseteq>\<^sub>m ?s1'"
    by (auto simp: range max_input_bits_def
             intro!: map_le_proj bit_length_monotonic
                     map_le_IMP_Minus_State_To_IMP_Minus_Minus_2
                      [OF \<open>I \<subseteq>\<^sub>m Some \<circ> s1\<close> _ \<open>finite (range s1)\<close> \<open>Max (range s1) < r\<close>])

  let ?ss1'' = "imp_minus_state_to_sas_plus (?c', ?s1')"
  let ?ss2'' = "imp_minus_state_to_sas_plus (SKIP, ?s2')"

  thm set_mp[OF IMP_Minus_To_IMP_Minus_Minus_variables[OF \<open>?n > 0\<close>, simplified]]

  obtain plan where plan_def:
     "is_serial_solution_for_problem_sas_plus_plus ?sas_plus_plus_problem plan"
     "length plan \<le> t''"
    apply(rule exE[OF imp_minus_minus_to_sas_plus_plus[OF \<open>(?c', ?s1') \<rightarrow>\<^bsup>t''\<^esup> (SKIP, ?s2')\<close>,
                      where ?I="?I" and ?G="?G" and t' = t'']])
    using \<open>?I  \<subseteq>\<^sub>m ?s1'\<close> \<open>?G \<subseteq>\<^sub>m ?s2'\<close>
    by (auto simp add: dom_of_IMP_Minus_State_To_IMP_Minus_Minus
        dest: set_mp[OF IMP_Minus_To_IMP_Minus_Minus_variables[OF \<open>?n > 0\<close>, simplified]])

   hence "\<exists>prefix. length prefix \<le> length ((?sas_plus_plus_problem)\<^sub>\<V>\<^sub>+) + 1
                   \<and> is_serial_solution_for_problem
                        (SAS_Plus_Plus_To_SAS_Plus ?sas_plus_plus_problem)
                        (prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))"
     by(fastforce simp: IMP_Minus_State_To_IMP_Minus_Minus_partial_def map_comp_def
                  intro!: SAS_Plus_Plus_To_SAS_Plus imp_minus_minus_to_sas_plus_valid
                  split: option.splits)

   then obtain prefix where
     prefix_def: "length prefix \<le> length ((?sas_plus_plus_problem)\<^sub>\<V>\<^sub>+) + 1
                  \<and> is_serial_solution_for_problem
                       (SAS_Plus_Plus_To_SAS_Plus ?sas_plus_plus_problem)
                       (prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))"
     by rule

   let ?plan' = "prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan)"
   have "length ((?sas_plus_plus_problem)\<^sub>\<V>\<^sub>+) \<le> (?n + 1) * (num_variables c + 2) + 1"
     using IMP_Minus_To_IMP_Minus_Minus_variables_length
             [where ?c=c and ?n="(Suc (t' + max_input_bits c I r))"]
     by(auto simp: imp_minus_minus_to_sas_plus_def Let_def add.commute)
   hence "length prefix \<le> (?n + 1) * (num_variables c + 2) + 2"
     using prefix_def
     by simp
   hence "length ?plan' \<le> 100 * ?n * (t' - 1) + (?n + 1) * (num_variables c + 2) + 52
           \<and> is_serial_solution_for_problem (IMP_Minus_to_SAS_Plus c I r G t') ?plan'"
     using plan_def prefix_def t''_def
     by(auto simp: IMP_Minus_to_SAS_Plus_def Let_def add.commute)
   thus ?thesis
     by rule
qed

lemma not_in_superset_of_dom_then_None:
 "dom s \<subseteq> S \<Longrightarrow> x \<notin> S \<Longrightarrow> s x = None" by auto

text \<open> Second direction of the correctness proof. We show that for an IMP- program that will
      terminate after at most t steps on any input, if there is a solution in the reduced
      SAS+ problem, then there is an IMP- state which matches the initial state of the SAS+ problem,
      such that when the IMP- program is run starting from that state, it reaches a terminating
      state matching the goal state of the SAS+ problem. \<close>

lemma SAS_Plus_to_IMP_Minus_correctness:
  assumes
    "dom I \<subseteq> set (Max_Constant.all_variables c)"
    "dom G \<subseteq> set (Max_Constant.all_variables c)"
    "Max (ran G) < 2 ^ (t + max_input_bits c I r)"
    "is_serial_solution_for_problem (IMP_Minus_to_SAS_Plus c I r G t) plan"
    "\<forall>s1. I \<subseteq>\<^sub>m Some o s1 \<longrightarrow> (\<exists>s2. \<exists>t' \<le> t. (c, s1) \<Rightarrow>\<^bsup>t'\<^esup> s2)"
  shows "\<exists>s1 s2 t'. t' \<le> t \<and> I \<subseteq>\<^sub>m Some \<circ> s1 \<and> G \<subseteq>\<^sub>m Some \<circ> s2 \<and> (c, s1)  \<Rightarrow>\<^bsup>t'\<^esup> s2"
proof -
  let ?guess_range = "max_input_bits c I r"
  let ?n = "t + ?guess_range + 1"
  let ?c' = "IMP_Minus_To_IMP_Minus_Minus c ?n"
  let ?I = "(IMP_Minus_State_To_IMP_Minus_Minus_partial I ?n ?guess_range)
    |` (set (enumerate_variables ?c'))"
  let ?G = "(IMP_Minus_State_To_IMP_Minus_Minus_partial G ?n ?n) |` (set (enumerate_variables ?c'))"

  have "finite (ran I)" "finite (ran G)"
    using \<open>dom I \<subseteq> set (Max_Constant.all_variables c)\<close>
      \<open>dom G \<subseteq> set (Max_Constant.all_variables c)\<close>
    finite_set by(auto simp: finite_subset intro!: finite_ran)

  have "?n > 0" by simp

  obtain plan' where "length plan' \<le> length plan
    \<and> is_serial_solution_for_problem_sas_plus_plus (imp_minus_minus_to_sas_plus ?c' ?I ?G) plan'"
    using SAS_Plus_To_SAS_Plus_Plus
      \<open>is_serial_solution_for_problem (IMP_Minus_to_SAS_Plus c I r G t) plan\<close>
    by (metis IMP_Minus_to_SAS_Plus_def imp_minus_minus_to_sas_plus_valid)

  then obtain s1 s2 t' where "(?I|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s1"
    "dom s1 = set (enumerate_variables ?c')"
    "(?G|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s2" "t' \<le> length plan'"
    "(?c', s1) \<rightarrow>\<^bsup>t'\<^esup> (SKIP, s2)"
    using sas_plus_plus_to_imp_minus_minus by fastforce

  let ?s1' = "IMP_Minus_Minus_State_To_IMP_Minus s1 ?n"
  let ?s2' = "IMP_Minus_Minus_State_To_IMP_Minus s2 ?n"

  have "s1 v = (IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n |` (set (enumerate_variables ?c'))) v"
    for v
  proof(cases "v \<in> set (enumerate_variables ?c')")
    case True
    thus ?thesis
    proof (cases "v \<in> dom ?I")
      case True
      hence "s1 v = ?I v" using \<open>(?I|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s1\<close>
        by(auto simp: map_le_def)
      thus ?thesis using \<open>v \<in> set (enumerate_variables ?c')\<close>
          apply(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_partial_def
              IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def var_to_var_bit_eq_Some_iff
              var_to_operand_bit_eq_Some_iff
              IMP_Minus_State_To_IMP_Minus_Minus_partial_of_operand_bit_to_var
              IMP_Minus_State_To_IMP_Minus_Minus_def
              nth_bit_of_IMP_Minus_Minus_State_To_IMP_Minus
              split: option.splits)
        using \<open>v \<in> dom ?I\<close> by(auto simp: map_comp_def
            IMP_Minus_State_To_IMP_Minus_Minus_partial_def
            IMP_Minus_State_To_IMP_Minus_Minus_partial_of_operand_bit_to_var
            var_bit_to_var_neq_operand_bit_to_var[symmetric]
            dest!: set_mp[OF IMP_Minus_To_IMP_Minus_Minus_variables[OF \<open>?n > 0\<close>, simplified]]
            split: option.splits char.splits bool.splits)
    next
      case False
      then obtain v' i where "v = var_bit_to_var (v', i) \<and> i < ?guess_range" using \<open>\<not>(v \<in> dom ?I)\<close>
         \<open>v \<in> set (enumerate_variables ?c')\<close>
        set_mp[OF IMP_Minus_To_IMP_Minus_Minus_variables \<open>v \<in> set (enumerate_variables ?c')\<close>]
        by(auto simp: map_comp_def
            IMP_Minus_State_To_IMP_Minus_Minus_partial_def split: option.splits)
      thus ?thesis using \<open>v \<in> set (enumerate_variables ?c')\<close>
          \<open>dom s1 = set (enumerate_variables ?c')\<close>
        by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_def
            nth_bit_of_IMP_Minus_Minus_State_To_IMP_Minus
            IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def split: option.splits)
    qed
  next
    case False
    thus ?thesis using \<open>dom s1 = set (enumerate_variables ?c')\<close> by auto
  qed
  hence "s1 = IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n |` (set (enumerate_variables ?c'))" by auto

  have "?s1' v = y" if "I v = Some y" for v y
  proof -
    from that have "v \<in> set (Max_Constant.all_variables c)"
      using \<open>dom I \<subseteq> set (Max_Constant.all_variables c)\<close>
      by auto
    hence "\<forall>i < ?n. var_bit_to_var (v, i) \<in> set (enumerate_variables ?c')"
      by(auto simp: var_bit_in_IMP_Minus_Minus_variables)
    moreover hence "i < ?n \<Longrightarrow> s1 (var_bit_to_var (v, i)) = ?I (var_bit_to_var (v, i))" for i
      using \<open>(?I|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s1\<close> \<open>I v = Some y\<close>
      by(auto simp: map_le_def
                    IMP_Minus_State_To_IMP_Minus_Minus_def dom_def
                    IMP_Minus_State_To_IMP_Minus_Minus_partial_def map_comp_def
                    split: option.splits)
    ultimately show "?s1' v = y"
      using
        \<open>(?I|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s1\<close>
        less_le_trans[OF initial_state_element_less_two_to_the_max_input_bits[where ?c=c and ?r=r]]
        \<open>I v = Some y\<close> \<open>finite (ran I)\<close>
      by(auto simp add: map_comp_def
          power_add
          algebra_simps nth_append bit_list_to_nat_eq_nat_iff
          IMP_Minus_Minus_State_To_IMP_Minus_def
          IMP_Minus_State_To_IMP_Minus_Minus_partial_def
          intro!: bit_at_index_geq_max_input_bits_is_zero_in_initial_state
          [symmetric, where ?c=c and ?I = I and ?r=r])
  qed
  hence "I \<subseteq>\<^sub>m Some \<circ> ?s1'" by(auto simp: map_le_def)

  hence "t_small_step_fun t'
  (?c', IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n |` set (enumerate_variables ?c')) = (SKIP, s2)"
    using \<open>(?c', s1) \<rightarrow>\<^bsup>t'\<^esup> (SKIP, s2)\<close>
      \<open>s1 = IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n |` (set (enumerate_variables ?c'))\<close>
    by(auto simp: t_small_step_fun_t_small_step_equivalence)
  moreover have "t_small_step_fun t'
    (?c', IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n |` set (enumerate_variables ?c'))
    = (fst (t_small_step_fun t' (?c', IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n)),
       snd  (t_small_step_fun t' (?c', IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n))
      |` set (enumerate_variables ?c'))"
    by (auto simp: t_small_step_fun_restrict_variables)
  ultimately obtain s2' where "t_small_step_fun t' (?c', IMP_Minus_State_To_IMP_Minus_Minus ?s1' ?n)
    = (SKIP, s2')" "s2' |` set (enumerate_variables ?c') = s2" by auto (metis prod.collapse)

  moreover obtain t'' s2'' where "t'' \<le> t" "(c, ?s1') \<Rightarrow>\<^bsup>t''\<^esup> s2''"
    using \<open>\<forall>s1. I \<subseteq>\<^sub>m Some o s1 \<longrightarrow> (\<exists>s2. \<exists>t' \<le> t. (c, s1) \<Rightarrow>\<^bsup>t'\<^esup> s2)\<close>
    using \<open>I \<subseteq>\<^sub>m Some \<circ> IMP_Minus_Minus_State_To_IMP_Minus s1 (t + max_input_bits c I r + 1)\<close>
    by blast
  moreover have "?guess_range \<le> i \<Longrightarrow> s1 (var_bit_to_var (v, i)) \<noteq> Some One" for i v
  proof(cases "(var_bit_to_var (v, i)) \<in> set (enumerate_variables ?c')")
    case True
    assume "?guess_range \<le> i"
    hence "?I (var_bit_to_var (v, i)) = Some Zero"
      using set_mp[OF IMP_Minus_To_IMP_Minus_Minus_variables
          \<open>(var_bit_to_var (v, i)) \<in> set (enumerate_variables ?c')\<close>]
      by (auto simp: IMP_Minus_State_To_IMP_Minus_Minus_partial_def
              intro!: var_bit_in_IMP_Minus_Minus_variables
              split: option.splits)
    thus ?thesis using \<open>(?I|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s1\<close>
      by(auto simp: map_le_def dom_def)
  next
    case False
    then show ?thesis using \<open>dom s1 = set (enumerate_variables ?c')\<close> by auto
  qed

  moreover hence "finite (range (IMP_Minus_Minus_State_To_IMP_Minus s1 ?n))"
    "Max (range (IMP_Minus_Minus_State_To_IMP_Minus s1 ?n)) < 2 ^ ?guess_range"
    using all_bits_geq_k_Zero_then_IMP_Minus_Minus_State_To_IMP_Minus_range_limited by blast+
  ultimately have "s2' = IMP_Minus_State_To_IMP_Minus_Minus s2'' ?n"
    using IMP_Minus_Minus_To_IMP_Minus_aux max_constant_less_two_to_the_max_input_bits
    by(auto simp: power_add algebra_simps mult_2 trans_less_add2)

  have "G v = Some y \<Longrightarrow> s2'' v = y" for v y
  proof -
    assume "G v = Some y"
    hence "v \<in> set (Max_Constant.all_variables c)"
      using \<open>dom G \<subseteq> set (Max_Constant.all_variables c)\<close> by auto
    hence "\<forall>i < ?n. var_bit_to_var (v, i) \<in> set (enumerate_variables ?c')"
      by(auto simp: var_bit_in_IMP_Minus_Minus_variables)
    moreover hence "i < ?n \<longrightarrow> s2 (var_bit_to_var (v, i)) = ?G (var_bit_to_var (v, i))" for i
      using \<open>(?G|` set (enumerate_variables ?c')) \<subseteq>\<^sub>m s2\<close> \<open>G v = Some y\<close>
      by(auto simp:  map_le_def
          IMP_Minus_State_To_IMP_Minus_Minus_def dom_def
          IMP_Minus_State_To_IMP_Minus_Minus_partial_def map_comp_def split: option.splits)
    moreover hence "i < ?n \<longrightarrow> s2' (var_bit_to_var (v, i)) = ?G (var_bit_to_var (v, i))" for i
      using \<open>s2' |` set (enumerate_variables ?c') = s2\<close>
        \<open>\<forall>i < ?n. var_bit_to_var (v, i) \<in> set (enumerate_variables ?c')\<close> by auto
    ultimately have "i < ?n \<longrightarrow> map_option (\<lambda>x. nth_bit x i) (G v) = Some (nth_bit (s2'' v) i)" for i
      using  \<open>s2' = IMP_Minus_State_To_IMP_Minus_Minus s2'' ?n\<close> \<open>G v = Some y\<close>
      by(auto simp: IMP_Minus_State_To_IMP_Minus_Minus_def
          IMP_Minus_State_To_IMP_Minus_Minus_partial_def
          IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def)
    thus "s2'' v = y"
      apply - apply(rule all_bits_equal_then_equal[where ?n = "?n"])
      apply(insert IMP_Minus_space_growth[OF \<open>(c, ?s1') \<Rightarrow>\<^bsup>t''\<^esup> s2''\<close>
          \<open>finite (range (IMP_Minus_Minus_State_To_IMP_Minus s1 ?n))\<close>, where ?k="?guess_range"])
      using \<open>Max (range (IMP_Minus_Minus_State_To_IMP_Minus s1 ?n)) < 2 ^ ?guess_range\<close>
        max_constant_less_two_to_the_max_input_bits \<open>t'' \<le> t\<close>
        apply simp
        apply(rule less_le_trans[where ?y="2 ^ (t + max_input_bits c I r)"])
         apply(auto simp: algebra_simps)
        apply(rule less_le_trans[where ?y="2 ^ (t'' + max_input_bits c I r)"])
      using \<open>G v = Some y\<close>  apply(auto)
      apply(rule less_le_trans[where ?y="2 ^ (t + max_input_bits c I r)"])
       apply (meson ran_def Max_ge \<open>finite (ran G)\<close> \<open>Max (ran G) < 2 ^ (t + max_input_bits c I r)\<close>
          le_less_trans ranI)
      by simp
  qed
  hence "G \<subseteq>\<^sub>m Some \<circ> s2''" by(auto simp: map_le_def)

  show ?thesis using \<open>t'' \<le> t\<close> \<open>(c, ?s1') \<Rightarrow>\<^bsup>t''\<^esup> s2''\<close> \<open>I \<subseteq>\<^sub>m Some \<circ> ?s1'\<close> \<open>G \<subseteq>\<^sub>m Some \<circ> s2''\<close>
    by auto
qed

end


theory AteDefs
imports "../HOModel"
begin

section \<open>Verification of the \ate{} Consensus algorithm\<close>

text \<open>
  Algorithm \ate{} is presented in~\<^cite>\<open>"biely:tolerating"\<close>. Like \ute{},
  it is an uncoordinated algorithm that tolerates value faults, and it
  is parameterized by values $T$, $E$, and $\alpha$ that serve a similar
  function as in \ute{}, allowing the algorithm to be adapted to the
  characteristics of different systems. \ate{} can be understood as a
  variant of \emph{OneThirdRule} tolerating Byzantine faults.

  We formalize in Isabelle the correctness proof of the algorithm that
  appears in~\<^cite>\<open>"biely:tolerating"\<close>, using the framework of theory
  \<open>HOModel\<close>.
\<close>

subsection \<open>Model of the Algorithm\<close>

text \<open>
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic HO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>The following record models the local state of a process.\<close>

record 'val pstate =
  x :: "'val"              \<comment> \<open>current value held by process\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, but no
  decision has yet been taken.
\<close>

definition Ate_initState where
  "Ate_initState p st \<equiv> (decide st = None)"

text \<open>
  The following locale introduces the parameters used for the \ate{}
  algorithm and their constraints~\<^cite>\<open>"biely:tolerating"\<close>.
\<close>

locale ate_parameters =
  fixes \<alpha>::nat and T::nat and E::nat
  assumes TNaE:"T \<ge> 2*(N + 2*\<alpha> - E)"
      and TltN:"T < N"
      and EltN:"E < N"

begin

text \<open>The following are consequences of the assumptions on the parameters.\<close>

lemma majE: "2 * (E - \<alpha>) \<ge> N"
using TNaE TltN by auto

lemma Egta: "E > \<alpha>"
using majE EltN by auto

lemma Tge2a: "T \<ge> 2 * \<alpha>"
using TNaE EltN by auto

text \<open>
  At every round, each process sends its current \<open>x\<close>.
  If it received more than \<open>T\<close> messages, it selects the smallest value
  and store it in \<open>x\<close>. As in algorithm \emph{OneThirdRule}, we
  therefore require values to be linearly ordered.

  If more than \<open>E\<close> messages holding the same value are received,
  the process decides that value.
\<close>

definition mostOftenRcvd where
  "mostOftenRcvd (msgs::Proc \<Rightarrow> 'val option) \<equiv>
   {v. \<forall>w. card {qq. msgs qq = Some w} \<le> card {qq. msgs qq = Some v}}"

definition
  Ate_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val"
where
  "Ate_sendMsg r p q st \<equiv> x st"

definition
  Ate_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> ('val::linorder) pstate \<Rightarrow> (Proc \<Rightarrow> 'val option)
                        \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "Ate_nextState r p st msgs st' \<equiv>
     (if card {q. msgs q \<noteq> None} > T
      then x st' = Min (mostOftenRcvd msgs)
      else x st' = x st)
   \<and> (   (\<exists>v. card {q. msgs q = Some v} > E  \<and> decide st' = Some v)
       \<or> \<not> (\<exists>v. card {q. msgs q = Some v} > E)
         \<and> decide st' = decide st)"

subsection \<open>Communication Predicate for \ate{}\<close>

text \<open>
  Following~\<^cite>\<open>"biely:tolerating"\<close>, we now define the communication
  predicate for the \ate{} algorithm. The round-by-round predicate
  requires that no process may receive more than \<open>\<alpha>\<close> corrupted
  messages at any round.
\<close>
definition Ate_commPerRd where
  "Ate_commPerRd HOrs SHOrs \<equiv>
   \<forall>p. card (HOrs p - SHOrs p) \<le> \<alpha>"

text \<open>
  The global communication predicate stipulates the three following
  conditions:
  \begin{itemize}
  \item for every process \<open>p\<close> there are infinitely many rounds
    where \<open>p\<close> receives more than \<open>T\<close> messages,
  \item for every process \<open>p\<close> there are infinitely many rounds
    where \<open>p\<close> receives more than \<open>E\<close> uncorrupted messages,
  \item and there are infinitely many rounds in which more than
    \<open>E - \<alpha>\<close> processes receive uncorrupted messages from the
    same set of processes, which contains more than \<open>T\<close> processes.
  \end{itemize}
\<close>
definition
  Ate_commGlobal where
  "Ate_commGlobal HOs SHOs \<equiv>
     (\<forall>r p. \<exists>r' > r. card (HOs r' p) > T)
   \<and> (\<forall>r p.  \<exists>r' > r. card (SHOs r' p \<inter> HOs r' p) > E)
   \<and> (\<forall>r. \<exists>r' > r. \<exists>\<pi>1 \<pi>2.
        card \<pi>1 > E - \<alpha>
      \<and> card \<pi>2 > T
      \<and> (\<forall>p \<in> \<pi>1. HOs r' p = \<pi>2 \<and> SHOs r' p \<inter> HOs r' p = \<pi>2))"

subsection \<open>The \ate{} Heard-Of Machine\<close>

text \<open>
  We now define the non-coordinated SHO machine for the \ate{} algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition Ate_SHOMachine where
  "Ate_SHOMachine = \<lparr>
    CinitState =  (\<lambda> p st crd. Ate_initState p (st::('val::linorder) pstate)),
    sendMsg =  Ate_sendMsg,
    CnextState = (\<lambda> r p st msgs crd st'. Ate_nextState r p st msgs st'),
    SHOcommPerRd = (Ate_commPerRd:: Proc HO \<Rightarrow> Proc HO \<Rightarrow> bool),
    SHOcommGlobal = Ate_commGlobal
   \<rparr>"

abbreviation
  "Ate_M \<equiv> (Ate_SHOMachine::(Proc, 'val::linorder pstate, 'val) SHOMachine)"

end   \<comment> \<open>locale @{text "ate_parameters"}\<close>

end   (* theory AteDefs *)


section \<open>Concrete setting\<close>

theory Concrete
imports Syntactic_Criteria After_Execution
begin

lemma (in PL_Indis) WbisT_If_cross:
  assumes "c1 \<approx>wT c2" "c1 \<approx>wT c1" "c2 \<approx>wT c2"
  shows "(If tst c1 c2) \<approx>wT (If tst c1 c2)"
proof -
  define \<phi>
    where "\<phi> c d \<longleftrightarrow> (\<exists>c1' c2'. c = If tst c1' c2' \<and> d = If tst c1' c2' \<and> c1' \<approx>wT c2' \<and> c1' \<approx>wT c1' \<and> c2' \<approx>wT c2')"
    for c d
  with assms have "\<phi> (If tst c1 c2) (If tst c1 c2)" by auto
  then show ?thesis
  proof (induct rule: WbisT_coinduct[where \<phi>=\<phi>])
    case (cont c s d t c' s')
    note cont(2,3)
    moreover from cont obtain c1 c2
      where \<phi>: "c = If tst c1 c2" "d = If tst c1 c2" "c1 \<approx>wT c2" "c1 \<approx>wT c1" "c2 \<approx>wT c2"
      by (auto simp: \<phi>_def)
    moreover then have "c2 \<approx>wT c1"
      using WbisT_sym unfolding sym_def by blast
    ultimately have "(d, t) \<rightarrow>*c (if tval tst t then c1 else c2, t) \<and> s' \<approx> t \<and>
      (\<phi> c' (if tval tst t then c1 else c2) \<or> c' \<approx>wT (if tval tst t then c1 else c2))"
      by (auto simp: \<phi>_def)
    then show ?case by auto
  qed (auto simp: \<phi>_def)
qed

text\<open>

We instatiate the following notions, kept generic so far:

\begin{itemize}
  \item On the language syntax:
  \begin{itemize}
    \item atoms, tests and states just like at the possibilistic case;
    \item choices, to either if-choices (based on tests) or binary fixed-probability choices;
    \item the schedulers, to the uniform one
  \end{itemize}
  \item On the security semantics, the lattice of levels and the indis relation, again, just like at the possibilistic case.
\end{itemize}
\<close>

datatype level = Lo | Hi

lemma [dest]: "\<And> l A. \<lbrakk>l \<in> A; Lo \<notin> A\<rbrakk> \<Longrightarrow> l = Hi" and
      [dest]: "\<And> l A. \<lbrakk>l \<in> A; Hi \<notin> A\<rbrakk> \<Longrightarrow> l = Lo"
by (metis level.exhaust)+

declare level.split[split]

instantiation level :: complete_lattice
begin
  definition top_level: "top \<equiv> Hi"
  definition bot_level: "bot \<equiv> Lo"
  definition inf_level: "inf l1 l2 \<equiv> if Lo \<in> {l1,l2} then Lo else Hi"
  definition sup_level: "sup l1 l2 \<equiv> if Hi \<in> {l1,l2} then Hi else Lo"
  definition less_eq_level: "less_eq l1 l2 \<equiv> (l1 = Lo \<or> l2 = Hi)"
  definition less_level: "less l1 l2 \<equiv> l1 = Lo \<and> l2 = Hi"
  definition Inf_level: "Inf L \<equiv> if Lo \<in> L then Lo else Hi"
  definition Sup_level: "Sup L \<equiv> if Hi \<in> L then Hi else Lo"
instance
  proof qed (auto simp: top_level bot_level inf_level sup_level
                        less_eq_level less_level Inf_level Sup_level)
end

lemma sup_eq_Lo[simp]: "sup a b = Lo \<longleftrightarrow> a = Lo \<and> b = Lo"
  by (auto simp: sup_level)

datatype var = h | h' | l | l'
datatype exp = Ct nat | Var var | Plus exp exp | Minus exp exp
datatype test = Tr | Eq exp exp | Gt exp exp | Non test
datatype atom = Assign var exp
type_synonym state = "var \<Rightarrow> nat"

syntax
 "_assign" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("_ ::= _" [1000, 61] 61)

translations
  "x ::= expr" == "CONST Atm (CONST Assign x expr)"

primrec sec where
  "sec h  = Hi"
| "sec h' = Hi"
| "sec l  = Lo"
| "sec l' = Lo"

fun eval where
 "eval (Ct n) s = n"
|"eval (Var x) s = s x"
|"eval (Plus e1 e2) s = eval e1 s + eval e2 s"
|"eval (Minus e1 e2) s = eval e1 s - eval e2 s"

fun tval where
 "tval Tr s = True"
|"tval (Eq e1 e2) s = (eval e1 s = eval e2 s)"
|"tval (Gt e1 e2) s = (eval e1 s > eval e2 s)"
|"tval (Non e) s = (\<not> tval e s)"

fun aval where
"aval (Assign x e) s = (s (x := eval e s))"

definition indis :: "(state * state) set"where
"indis \<equiv> {(s,t). ALL x. sec x = Lo \<longrightarrow> s x = t x}"

interpretation Example_PL: PL_Indis tval aval indis
proof
  show "equiv UNIV indis"
    unfolding refl_on_def sym_def trans_def equiv_def indis_def by auto
qed

fun exprSec where
 "exprSec (Ct n) = bot"
|"exprSec (Var x) = sec x"
|"exprSec (Plus e1 e2) = sup (exprSec e1) (exprSec e2)"
|"exprSec (Minus e1 e2) = sup (exprSec e1) (exprSec e2)"

fun tstSec where
 "tstSec Tr = bot"
|"tstSec (Eq e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Gt e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Non e) = tstSec e"

lemma exprSec_Lo_eval_eq: "exprSec expr = Lo \<Longrightarrow> (s, t) \<in> indis \<Longrightarrow> eval expr s = eval expr t"
  by (induct expr) (auto simp: indis_def)

lemma compatAtmSyntactic[simp]: "exprSec expr = Lo \<or> sec v = Hi \<Longrightarrow> Example_PL.compatAtm (Assign v expr)"
  unfolding Example_PL.compatAtm_def
  by (induct expr)
     (auto simp: indis_def intro!: arg_cong2[where f="(+)"] arg_cong2[where f="(-)"] exprSec_Lo_eval_eq)

lemma presAtmSyntactic[simp]: "sec v = Hi \<Longrightarrow> Example_PL.presAtm (Assign v expr)"
  unfolding Example_PL.presAtm_def by (simp add: indis_def)

lemma compatTstSyntactic[simp]: "tstSec tst = Lo \<Longrightarrow> Example_PL.compatTst tst"
  unfolding Example_PL.compatTst_def
  by (induct tst)
     (simp_all, safe del: iffI
              intro!: arg_cong2[where f="(=)"] arg_cong2[where f="(<) :: nat \<Rightarrow> nat \<Rightarrow> bool"] exprSec_Lo_eval_eq)

lemma "Example_PL.SC_discr (h ::= Ct 0)"
  by (simp add: Example_PL.SC_discr.simps)

abbreviation "siso c \<equiv> Example_PL.siso c"
abbreviation "siso0 c \<equiv> Example_PL.siso0 c"
abbreviation "discr c \<equiv> Example_PL.discr c"
abbreviation "discr0 c \<equiv> Example_PL.discr0 c"
abbreviation Sbis_abbrev (infix "\<approx>s" 55) where "c1 \<approx>s c2 \<equiv> (c1,c2) \<in> Example_PL.Sbis"
abbreviation ZObis_abbrev (infix "\<approx>01" 55) where "c1 \<approx>01 c2 \<equiv> (c1,c2) \<in> Example_PL.ZObis"
abbreviation ZObisT_abbrev (infix "\<approx>01T" 55) where "c1 \<approx>01T c2 \<equiv> (c1,c2) \<in> Example_PL.ZObisT"
abbreviation Wbis_abbrev (infix "\<approx>w" 55) where "c1 \<approx>w c2 \<equiv> (c1,c2) \<in> Example_PL.Wbis"
abbreviation WbisT_abbrev (infix "\<approx>wT" 55) where "c1 \<approx>wT c2 \<equiv> (c1,c2) \<in> Example_PL.WbisT"
abbreviation BisT_abbrev (infix "\<approx>T" 55) where "c1 \<approx>T c2 \<equiv> (c1,c2) \<in> Example_PL.BisT"

subsection \<open>Programs from EXAMPLE 1\<close>

definition [simp]: "c0 = (h ::= Ct 0)"

definition [simp]: "c1 = (if Eq (Var l) (Ct 0) then h ::= Ct 1 else l ::= Ct 2)"

definition [simp]: "c2 = (if Eq (Var h) (Ct 0) then h ::= Ct 1 else h ::= Ct 2)"

definition [simp]: "c3 = (if Eq (Var h) (Ct 0) then h ::= Ct 1 ;; h ::= Ct 2
                                         else h ::= Ct 3)"

definition [simp]: "c4 = l ::= Ct 4 ;; c3"

definition [simp]: "c5 = c3 ;; l ::= Ct 4"

definition [simp]: "c6 = l ::= Var h"

definition [simp]: "c7 = l ::= Var h ;; l ::= Ct 0"

definition [simp]: "c8 = h' ::= Var h ;;
  while Gt (Var h) (Ct 0) do (h ::= Minus (Var h) (Ct 1) ;; h' ::= Plus (Var h') (Ct 1)) ;;
  l ::= Ct 4"

definition [simp]: "c9 = c7 | l' ::= Var l"

definition [simp]: "c10 = c5 | l ::= Ct 5"

definition [simp]: "c11 = c8 | l ::= Ct 5"

declare bot_level[iff]

theorem c0: "siso c0" "discr c0"
  by auto

theorem c1: "siso c1" "c1 \<approx>s c1"
  by auto

theorem c2: "discr c2"
  by auto

theorem Sbis_c2: "c2 \<approx>s c2"
  oops

theorem c3: "discr c3"
  by auto

theorem c4: "c4 \<approx>01 c4"
  by auto

theorem c5: "c5 \<approx>w c5"
  by auto

text\<open>Example 4 from the paper\<close>

theorem "c3 \<approx>wT c3" by auto

theorem "c5 \<approx>wT c5" by auto

corollary "discr (while Eq (Var h) (Ct 0)  do h ::= Ct 0)"
  by auto

text\<open>Example 5 from the paper\<close>

definition [simp]: "c12 \<equiv> h ::= Ct 4 ;;
  while Gt (Var h) (Ct 0)
    do (h ::= Minus (Var h) (Ct 1) ;; h' ::= Plus (Var h') (Ct 1)) ;;
  l ::= Ct 1"

corollary "(c12 | l ::= Ct 2) \<approx>T (c12 | l ::= Ct 2)"
  by auto

definition [simp]: "c13 =
  (if Eq (Var h) (Ct 0) then h ::= Ct 1 ;; l ::= Ct 2 else l ::= Ct 2) ;; l' ::= Ct 4"

lemma c13_inner:
  "(h ::= Ct 1 ;; l ::= Ct 2) \<approx>wT (l ::= Ct 2)"
proof -
  define \<phi> where "\<phi> =
    (\<lambda>(c :: (test, atom) com) (d :: (test, atom) com).
      c = h ::= Ct 1 ;; l ::= Ct 2 \<and> d = l ::= Ct 2 \<or>
      d = h ::= Ct 1 ;; l ::= Ct 2 \<and> c = l ::= Ct 2)"
  then have "\<phi> (h ::= Ct 1 ;; l ::= Ct 2) (l ::= Ct 2)"
    by auto
  then show ?thesis
  proof (induct rule: Example_PL.WbisT_coinduct[where \<phi>=\<phi>])
    case sym then show ?case by (auto simp add: \<phi>_def)
  next
    case (cont c s d t c' s') then show ?case
      by (auto simp add: \<phi>_def intro!: exI[of _ "l ::= Ct 2"] exI[of _ t])
         (auto simp: indis_def)
  next
    have exec:
        "\<And>t. Example_PL.MtransT (h ::= Ct 1 ;; l ::= Ct 2, t) (aval (Assign l (Ct 2)) (aval (Assign h (Ct 1)) t))"
        by (simp del: aval.simps)
           (blast intro: Example_PL.transC_MtransT Example_PL.transC_MtransC.SeqT Example_PL.transT.Atm Example_PL.transT_MtransT)
    case (termi c s d t s') with exec show ?case
      by (auto simp add: \<phi>_def intro!: exI[of _ "t (h := 1, l := 2)"])
         (auto simp: indis_def)
  qed
qed

theorem "c13 \<approx>wT c13"
   using c13_inner
   by (auto intro!: Example_PL.Seq_WbisT Example_PL.WbisT_If_cross)

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section "Combining automata and regular expressions"

theory AutoRegExp
imports Automata RegExp2NA RegExp2NAe
begin

theorem "DA.accepts (na2da(rexp2na r)) w = (w : lang r)"
by (simp add: NA_DA_equiv[THEN sym] accepts_rexp2na)

theorem  "DA.accepts (nae2da(rexp2nae r)) w = (w : lang r)"
by (simp add: NAe_DA_equiv accepts_rexp2nae)

end


(*  Title:      HOL/Cardinals/Wellorder_Constructions.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Constructions on wellorders.
*)

section \<open>Constructions on Wellorders\<close>

theory Wellorder_Constructions
imports
  BNF_Wellorder_Constructions Wellorder_Embedding Order_Union
  "../Library/Cardinal_Notations"
begin

declare
  ordLeq_Well_order_simp[simp]
  not_ordLeq_iff_ordLess[simp]
  not_ordLess_iff_ordLeq[simp]
  Func_empty[simp]
  Func_is_emp[simp]

lemma Func_emp2[simp]: "A \<noteq> {} \<Longrightarrow> Func A {} = {}" by auto

subsection \<open>Restriction to a set\<close>

lemma Restr_incr2:
"r <= r' \<Longrightarrow> Restr r A <= Restr r' A"
by blast

lemma Restr_incr:
"\<lbrakk>r \<le> r'; A \<le> A'\<rbrakk> \<Longrightarrow> Restr r A \<le> Restr r' A'"
by blast

lemma Restr_Int:
"Restr (Restr r A) B = Restr r (A Int B)"
by blast

lemma Restr_iff: "(a,b) : Restr r A = (a : A \<and> b : A \<and> (a,b) : r)"
by (auto simp add: Field_def)

lemma Restr_subset1: "Restr r A \<le> r"
by auto

lemma Restr_subset2: "Restr r A \<le> A \<times> A"
by auto

lemma wf_Restr:
"wf r \<Longrightarrow> wf(Restr r A)"
using Restr_subset by (elim wf_subset) simp

lemma Restr_incr1:
"A \<le> B \<Longrightarrow> Restr r A \<le> Restr r B"
by blast

subsection \<open>Order filters versus restrictions and embeddings\<close>

lemma ofilter_Restr:
assumes WELL: "Well_order r" and
        OFA: "ofilter r A" and OFB: "ofilter r B" and SUB: "A \<le> B"
shows "ofilter (Restr r B) A"
proof-
  let ?rB = "Restr r B"
  have Well: "wo_rel r" unfolding wo_rel_def using WELL .
  hence Refl: "Refl r" by (auto simp add: wo_rel.REFL)
  hence Field: "Field ?rB = Field r Int B"
  using Refl_Field_Restr by blast
  have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
  by (auto simp add: Well_order_Restr wo_rel_def)
  (* Main proof *)
  show ?thesis
  proof(auto simp add: WellB wo_rel.ofilter_def)
    fix a assume "a \<in> A"
    hence "a \<in> Field r \<and> a \<in> B" using assms Well
    by (auto simp add: wo_rel.ofilter_def)
    with Field show "a \<in> Field(Restr r B)" by auto
  next
    fix a b assume *: "a \<in> A"  and "b \<in> under (Restr r B) a"
    hence "b \<in> under r a"
    using WELL OFB SUB ofilter_Restr_under[of r B a] by auto
    thus "b \<in> A" using * Well OFA by(auto simp add: wo_rel.ofilter_def)
  qed
qed

lemma ofilter_subset_iso:
assumes WELL: "Well_order r" and
        OFA: "ofilter r A" and OFB: "ofilter r B"
shows "(A = B) = iso (Restr r A) (Restr r B) id"
using assms
by (auto simp add: ofilter_subset_embedS_iso)

subsection \<open>Ordering the well-orders by existence of embeddings\<close>

corollary ordLeq_refl_on: "refl_on {r. Well_order r} ordLeq"
using ordLeq_reflexive unfolding ordLeq_def refl_on_def
by blast

corollary ordLeq_trans: "trans ordLeq"
using trans_def[of ordLeq] ordLeq_transitive by blast

corollary ordLeq_preorder_on: "preorder_on {r. Well_order r} ordLeq"
by(auto simp add: preorder_on_def ordLeq_refl_on ordLeq_trans)

corollary ordIso_refl_on: "refl_on {r. Well_order r} ordIso"
using ordIso_reflexive unfolding refl_on_def ordIso_def
by blast

corollary ordIso_trans: "trans ordIso"
using trans_def[of ordIso] ordIso_transitive by blast

corollary ordIso_sym: "sym ordIso"
by (auto simp add: sym_def ordIso_symmetric)

corollary ordIso_equiv: "equiv {r. Well_order r} ordIso"
by (auto simp add:  equiv_def ordIso_sym ordIso_refl_on ordIso_trans)

lemma ordLess_Well_order_simp[simp]:
assumes "r <o r'"
shows "Well_order r \<and> Well_order r'"
using assms unfolding ordLess_def by simp

lemma ordIso_Well_order_simp[simp]:
assumes "r =o r'"
shows "Well_order r \<and> Well_order r'"
using assms unfolding ordIso_def by simp

lemma ordLess_irrefl: "irrefl ordLess"
by(unfold irrefl_def, auto simp add: ordLess_irreflexive)

lemma ordLess_or_ordIso:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "r <o r' \<or> r' <o r \<or> r =o r'"
unfolding ordLess_def ordIso_def
using assms embedS_or_iso[of r r'] by auto

corollary ordLeq_ordLess_Un_ordIso:
"ordLeq = ordLess \<union> ordIso"
by (auto simp add: ordLeq_iff_ordLess_or_ordIso)

lemma not_ordLeq_ordLess:
"r \<le>o r' \<Longrightarrow> \<not> r' <o r"
using not_ordLess_ordLeq by blast

lemma ordIso_or_ordLess:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "r =o r' \<or> r <o r' \<or> r' <o r"
using assms ordLess_or_ordLeq ordLeq_iff_ordLess_or_ordIso by blast

lemmas ord_trans = ordIso_transitive ordLeq_transitive ordLess_transitive
                   ordIso_ordLeq_trans ordLeq_ordIso_trans
                   ordIso_ordLess_trans ordLess_ordIso_trans
                   ordLess_ordLeq_trans ordLeq_ordLess_trans

lemma ofilter_ordLeq:
assumes "Well_order r" and "ofilter r A"
shows "Restr r A \<le>o r"
proof-
  have "A \<le> Field r" using assms by (auto simp add: wo_rel_def wo_rel.ofilter_def)
  thus ?thesis using assms
  by (simp add: ofilter_subset_ordLeq wo_rel.Field_ofilter
      wo_rel_def Restr_Field)
qed

corollary under_Restr_ordLeq:
"Well_order r \<Longrightarrow> Restr r (under r a) \<le>o r"
by (auto simp add: ofilter_ordLeq wo_rel.under_ofilter wo_rel_def)

subsection \<open>Copy via direct images\<close>

lemma Id_dir_image: "dir_image Id f \<le> Id"
unfolding dir_image_def by auto

lemma Un_dir_image:
"dir_image (r1 \<union> r2) f = (dir_image r1 f) \<union> (dir_image r2 f)"
unfolding dir_image_def by auto

lemma Int_dir_image:
assumes "inj_on f (Field r1 \<union> Field r2)"
shows "dir_image (r1 Int r2) f = (dir_image r1 f) Int (dir_image r2 f)"
proof
  show "dir_image (r1 Int r2) f \<le> (dir_image r1 f) Int (dir_image r2 f)"
  using assms unfolding dir_image_def inj_on_def by auto
next
  show "(dir_image r1 f) Int (dir_image r2 f) \<le> dir_image (r1 Int r2) f"
  proof(clarify)
    fix a' b'
    assume "(a',b') \<in> dir_image r1 f" "(a',b') \<in> dir_image r2 f"
    then obtain a1 b1 a2 b2
    where 1: "a' = f a1 \<and> b' = f b1 \<and> a' = f a2 \<and> b' = f b2" and
          2: "(a1,b1) \<in> r1 \<and> (a2,b2) \<in> r2" and
          3: "{a1,b1} \<le> Field r1 \<and> {a2,b2} \<le> Field r2"
    unfolding dir_image_def Field_def by blast
    hence "a1 = a2 \<and> b1 = b2" using assms unfolding inj_on_def by auto
    hence "a' = f a1 \<and> b' = f b1 \<and> (a1,b1) \<in> r1 Int r2 \<and> (a2,b2) \<in> r1 Int r2"
    using 1 2 by auto
    thus "(a',b') \<in> dir_image (r1 \<inter> r2) f"
    unfolding dir_image_def by blast
  qed
qed

(* More facts on ordinal sum: *)

lemma Osum_embed:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "embed r (r Osum r') id"
proof-
  have 1: "Well_order (r Osum r')"
  using assms by (auto simp add: Osum_Well_order)
  moreover
  have "compat r (r Osum r') id"
  unfolding compat_def Osum_def by auto
  moreover
  have "inj_on id (Field r)" by simp
  moreover
  have "ofilter (r Osum r') (Field r)"
  using 1 proof(auto simp add: wo_rel_def wo_rel.ofilter_def
                               Field_Osum under_def)
    fix a b assume 2: "a \<in> Field r" and 3: "(b,a) \<in> r Osum r'"
    moreover
    {assume "(b,a) \<in> r'"
     hence "a \<in> Field r'" using Field_def[of r'] by blast
     hence False using 2 FLD by blast
    }
    moreover
    {assume "a \<in> Field r'"
     hence False using 2 FLD by blast
    }
    ultimately
    show "b \<in> Field r" by (auto simp add: Osum_def Field_def)
  qed
  ultimately show ?thesis
  using assms by (auto simp add: embed_iff_compat_inj_on_ofilter)
qed

corollary Osum_ordLeq:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "r \<le>o r Osum r'"
using assms Osum_embed Osum_Well_order
unfolding ordLeq_def by blast

lemma Well_order_embed_copy:
assumes WELL: "well_order_on A r" and
        INJ: "inj_on f A" and SUB: "f ` A \<le> B"
shows "\<exists>r'. well_order_on B r' \<and> r \<le>o r'"
proof-
  have "bij_betw f A (f ` A)"
  using INJ inj_on_imp_bij_betw by blast
  then obtain r'' where "well_order_on (f ` A) r''" and 1: "r =o r''"
  using WELL  Well_order_iso_copy by blast
  hence 2: "Well_order r'' \<and> Field r'' = (f ` A)"
  using well_order_on_Well_order by blast
  (*  *)
  let ?C = "B - (f ` A)"
  obtain r''' where "well_order_on ?C r'''"
  using well_order_on by blast
  hence 3: "Well_order r''' \<and> Field r''' = ?C"
  using well_order_on_Well_order by blast
  (*  *)
  let ?r' = "r'' Osum r'''"
  have "Field r'' Int Field r''' = {}"
  using 2 3 by auto
  hence "r'' \<le>o ?r'" using Osum_ordLeq[of r'' r'''] 2 3 by blast
  hence 4: "r \<le>o ?r'" using 1 ordIso_ordLeq_trans by blast
  (*  *)
  hence "Well_order ?r'" unfolding ordLeq_def by auto
  moreover
  have "Field ?r' = B" using 2 3 SUB by (auto simp add: Field_Osum)
  ultimately show ?thesis using 4 by blast
qed

subsection \<open>The maxim among a finite set of ordinals\<close>

text \<open>The correct phrasing would be ``a maxim of ...", as \<open>\<le>o\<close> is only a preorder.\<close>

definition isOmax :: "'a rel set \<Rightarrow> 'a rel \<Rightarrow> bool"
where
"isOmax  R r == r \<in> R \<and> (ALL r' : R. r' \<le>o r)"

definition omax :: "'a rel set \<Rightarrow> 'a rel"
where
"omax R == SOME r. isOmax R r"

lemma exists_isOmax:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "\<exists> r. isOmax R r"
proof-
  have "finite R \<Longrightarrow> R \<noteq> {} \<longrightarrow> (\<forall> r \<in> R. Well_order r) \<longrightarrow> (\<exists> r. isOmax R r)"
  apply(erule finite_induct) apply(simp add: isOmax_def)
  proof(clarsimp)
    fix r :: "('a \<times> 'a) set" and R assume *: "finite R" and **: "r \<notin> R"
    and ***: "Well_order r" and ****: "\<forall>r\<in>R. Well_order r"
    and IH: "R \<noteq> {} \<longrightarrow> (\<exists>p. isOmax R p)"
    let ?R' = "insert r R"
    show "\<exists>p'. (isOmax ?R' p')"
    proof(cases "R = {}")
      assume Case1: "R = {}"
      thus ?thesis unfolding isOmax_def using ***
      by (simp add: ordLeq_reflexive)
    next
      assume Case2: "R \<noteq> {}"
      then obtain p where p: "isOmax R p" using IH by auto
      hence 1: "Well_order p" using **** unfolding isOmax_def by simp
      {assume Case21: "r \<le>o p"
       hence "isOmax ?R' p" using p unfolding isOmax_def by simp
       hence ?thesis by auto
      }
      moreover
      {assume Case22: "p \<le>o r"
       {fix r' assume "r' \<in> ?R'"
        moreover
        {assume "r' \<in> R"
         hence "r' \<le>o p" using p unfolding isOmax_def by simp
         hence "r' \<le>o r" using Case22 by(rule ordLeq_transitive)
        }
        moreover have "r \<le>o r" using *** by(rule ordLeq_reflexive)
        ultimately have "r' \<le>o r" by auto
       }
       hence "isOmax ?R' r" unfolding isOmax_def by simp
       hence ?thesis by auto
      }
      moreover have "r \<le>o p \<or> p \<le>o r"
      using 1 *** ordLeq_total by auto
      ultimately show ?thesis by blast
    qed
  qed
  thus ?thesis using assms by auto
qed

lemma omax_isOmax:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "isOmax R (omax R)"
unfolding omax_def using assms
by(simp add: exists_isOmax someI_ex)

lemma omax_in:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "omax R \<in> R"
using assms omax_isOmax unfolding isOmax_def by blast

lemma Well_order_omax:
assumes "finite R" and "R \<noteq> {}" and "\<forall>r\<in>R. Well_order r"
shows "Well_order (omax R)"
using assms apply - apply(drule omax_in) by auto

lemma omax_maxim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r" and "r \<in> R"
shows "r \<le>o omax R"
using assms omax_isOmax unfolding isOmax_def by blast

lemma omax_ordLeq:
assumes "finite R" and "R \<noteq> {}" and *: "\<forall> r \<in> R. r \<le>o p"
shows "omax R \<le>o p"
proof-
  have "\<forall> r \<in> R. Well_order r" using * unfolding ordLeq_def by simp
  thus ?thesis using assms omax_in by auto
qed

lemma omax_ordLess:
assumes "finite R" and "R \<noteq> {}" and *: "\<forall> r \<in> R. r <o p"
shows "omax R <o p"
proof-
  have "\<forall> r \<in> R. Well_order r" using * unfolding ordLess_def by simp
  thus ?thesis using assms omax_in by auto
qed

lemma omax_ordLeq_elim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "omax R \<le>o p" and "r \<in> R"
shows "r \<le>o p"
using assms omax_maxim[of R r] apply simp
using ordLeq_transitive by blast

lemma omax_ordLess_elim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "omax R <o p" and "r \<in> R"
shows "r <o p"
using assms omax_maxim[of R r] apply simp
using ordLeq_ordLess_trans by blast

lemma ordLeq_omax:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "r \<in> R" and "p \<le>o r"
shows "p \<le>o omax R"
using assms omax_maxim[of R r] apply simp
using ordLeq_transitive by blast

lemma ordLess_omax:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "r \<in> R" and "p <o r"
shows "p <o omax R"
using assms omax_maxim[of R r] apply simp
using ordLess_ordLeq_trans by blast

lemma omax_ordLeq_mono:
assumes P: "finite P" and R: "finite R"
and NE_P: "P \<noteq> {}" and Well_R: "\<forall> r \<in> R. Well_order r"
and LEQ: "\<forall> p \<in> P. \<exists> r \<in> R. p \<le>o r"
shows "omax P \<le>o omax R"
proof-
  let ?mp = "omax P"  let ?mr = "omax R"
  {fix p assume "p : P"
   then obtain r where r: "r : R" and "p \<le>o r"
   using LEQ by blast
   moreover have "r <=o ?mr"
   using r R Well_R omax_maxim by blast
   ultimately have "p <=o ?mr"
   using ordLeq_transitive by blast
  }
  thus "?mp <=o ?mr"
  using NE_P P using omax_ordLeq by blast
qed

lemma omax_ordLess_mono:
assumes P: "finite P" and R: "finite R"
and NE_P: "P \<noteq> {}" and Well_R: "\<forall> r \<in> R. Well_order r"
and LEQ: "\<forall> p \<in> P. \<exists> r \<in> R. p <o r"
shows "omax P <o omax R"
proof-
  let ?mp = "omax P"  let ?mr = "omax R"
  {fix p assume "p : P"
   then obtain r where r: "r : R" and "p <o r"
   using LEQ by blast
   moreover have "r <=o ?mr"
   using r R Well_R omax_maxim by blast
   ultimately have "p <o ?mr"
   using ordLess_ordLeq_trans by blast
  }
  thus "?mp <o ?mr"
  using NE_P P omax_ordLess by blast
qed

subsection \<open>Limit and succesor ordinals\<close>

lemma embed_underS2:
assumes r: "Well_order r" and s: "Well_order s"  and g: "embed r s g" and a: "a \<in> Field r"
shows "g ` underS r a = underS s (g a)"
using embed_underS[OF assms] unfolding bij_betw_def by auto

lemma bij_betw_insert:
assumes "b \<notin> A" and "f b \<notin> A'" and "bij_betw f A A'"
shows "bij_betw f (insert b A) (insert (f b) A')"
using notIn_Un_bij_betw[OF assms] by auto

context wo_rel
begin

lemma underS_induct:
  assumes "\<And>a. (\<And> a1. a1 \<in> underS a \<Longrightarrow> P a1) \<Longrightarrow> P a"
  shows "P a"
  by (induct rule: well_order_induct) (rule assms, simp add: underS_def)

lemma suc_underS:
assumes B: "B \<subseteq> Field r" and A: "AboveS B \<noteq> {}" and b: "b \<in> B"
shows "b \<in> underS (suc B)"
using suc_AboveS[OF B A] b unfolding underS_def AboveS_def by auto

lemma underS_supr:
assumes bA: "b \<in> underS (supr A)" and A: "A \<subseteq> Field r"
shows "\<exists> a \<in> A. b \<in> underS a"
proof(rule ccontr, auto)
  have bb: "b \<in> Field r" using bA unfolding underS_def Field_def by auto
  assume "\<forall>a\<in>A.  b \<notin> underS a"
  hence 0: "\<forall>a \<in> A. (a,b) \<in> r" using A bA unfolding underS_def
  by simp (metis REFL in_mono max2_def max2_greater refl_on_domain)
  have "(supr A, b) \<in> r" apply(rule supr_least[OF A bb]) using 0 by auto
  thus False using bA unfolding underS_def by simp (metis ANTISYM antisymD)
qed

lemma underS_suc:
assumes bA: "b \<in> underS (suc A)" and A: "A \<subseteq> Field r"
shows "\<exists> a \<in> A. b \<in> under a"
proof(rule ccontr, auto)
  have bb: "b \<in> Field r" using bA unfolding underS_def Field_def by auto
  assume "\<forall>a\<in>A.  b \<notin> under a"
  hence 0: "\<forall>a \<in> A. a \<in> underS b" using A bA unfolding underS_def
  by simp (metis (lifting) bb max2_def max2_greater mem_Collect_eq under_def set_rev_mp)
  have "(suc A, b) \<in> r" apply(rule suc_least[OF A bb]) using 0 unfolding underS_def by auto
  thus False using bA unfolding underS_def by simp (metis ANTISYM antisymD)
qed

lemma (in wo_rel) in_underS_supr:
assumes j: "j \<in> underS i" and i: "i \<in> A" and A: "A \<subseteq> Field r" and AA: "Above A \<noteq> {}"
shows "j \<in> underS (supr A)"
proof-
  have "(i,supr A) \<in> r" using supr_greater[OF A AA i] .
  thus ?thesis using j unfolding underS_def
  by simp (metis REFL TRANS max2_def max2_equals1 refl_on_domain transD)
qed

lemma inj_on_Field:
assumes A: "A \<subseteq> Field r" and f: "\<And> a b. \<lbrakk>a \<in> A; b \<in> A; a \<in> underS b\<rbrakk> \<Longrightarrow> f a \<noteq> f b"
shows "inj_on f A"
unfolding inj_on_def proof safe
  fix a b assume a: "a \<in> A" and b: "b \<in> A" and fab: "f a = f b"
  {assume "a \<in> underS b"
   hence False using f[OF a b] fab by auto
  }
  moreover
  {assume "b \<in> underS a"
   hence False using f[OF b a] fab by auto
  }
  ultimately show "a = b" using TOTALS A a b unfolding underS_def by auto
qed

lemma in_notinI:
assumes "(j,i) \<notin> r \<or> j = i" and "i \<in> Field r" and "j \<in> Field r"
shows "(i,j) \<in> r" by (metis assms max2_def max2_greater_among)

lemma ofilter_init_seg_of:
assumes "ofilter F"
shows "Restr r F initial_segment_of r"
using assms unfolding ofilter_def init_seg_of_def under_def by auto

lemma underS_init_seg_of_Collect:
assumes "\<And>j1 j2. \<lbrakk>j2 \<in> underS i; (j1, j2) \<in> r\<rbrakk> \<Longrightarrow> R j1 initial_segment_of R j2"
shows "{R j |j. j \<in> underS i} \<in> Chains init_seg_of"
unfolding Chains_def proof safe
  fix j ja assume jS: "j \<in> underS i" and jaS: "ja \<in> underS i"
  and init: "(R ja, R j) \<notin> init_seg_of"
  hence jja: "{j,ja} \<subseteq> Field r" and j: "j \<in> Field r" and ja: "ja \<in> Field r"
  and jjai: "(j,i) \<in> r" "(ja,i) \<in> r"
  and i: "i \<notin> {j,ja}" unfolding Field_def underS_def by auto
  have jj: "(j,j) \<in> r" and jaja: "(ja,ja) \<in> r" using j ja by (metis in_notinI)+
  show "R j initial_segment_of R ja"
  using jja init jjai i
  by (elim cases_Total3 disjE) (auto elim: cases_Total3 intro!: assms simp: underS_def)
qed

lemma (in wo_rel) Field_init_seg_of_Collect:
assumes "\<And>j1 j2. \<lbrakk>j2 \<in> Field r; (j1, j2) \<in> r\<rbrakk> \<Longrightarrow> R j1 initial_segment_of R j2"
shows "{R j |j. j \<in> Field r} \<in> Chains init_seg_of"
unfolding Chains_def proof safe
  fix j ja assume jS: "j \<in> Field r" and jaS: "ja \<in> Field r"
  and init: "(R ja, R j) \<notin> init_seg_of"
  hence jja: "{j,ja} \<subseteq> Field r" and j: "j \<in> Field r" and ja: "ja \<in> Field r"
  unfolding Field_def underS_def by auto
  have jj: "(j,j) \<in> r" and jaja: "(ja,ja) \<in> r" using j ja by (metis in_notinI)+
  show "R j initial_segment_of R ja"
  using jja init
  by (elim cases_Total3 disjE) (auto elim: cases_Total3 intro!: assms simp: Field_def)
qed

subsubsection \<open>Successor and limit elements of an ordinal\<close>

definition "succ i \<equiv> suc {i}"

definition "isSucc i \<equiv> \<exists> j. aboveS j \<noteq> {} \<and> i = succ j"

definition "zero = minim (Field r)"

definition "isLim i \<equiv> \<not> isSucc i"

lemma zero_smallest[simp]:
assumes "j \<in> Field r" shows "(zero, j) \<in> r"
unfolding zero_def
by (metis AboveS_Field assms subset_AboveS_UnderS subset_antisym subset_refl suc_def suc_least_AboveS)

lemma zero_in_Field: assumes "Field r \<noteq> {}"  shows "zero \<in> Field r"
using assms unfolding zero_def by (metis Field_ofilter minim_in ofilter_def)

lemma leq_zero_imp[simp]:
"(x, zero) \<in> r \<Longrightarrow> x = zero"
by (metis ANTISYM WELL antisymD well_order_on_domain zero_smallest)

lemma leq_zero[simp]:
assumes "Field r \<noteq> {}"  shows "(x, zero) \<in> r \<longleftrightarrow> x = zero"
using zero_in_Field[OF assms] in_notinI[of x zero] by auto

lemma under_zero[simp]:
assumes "Field r \<noteq> {}" shows "under zero = {zero}"
using assms unfolding under_def by auto

lemma underS_zero[simp,intro]: "underS zero = {}"
unfolding underS_def by auto

lemma isSucc_succ: "aboveS i \<noteq> {} \<Longrightarrow> isSucc (succ i)"
unfolding isSucc_def succ_def by auto

lemma succ_in_diff:
assumes "aboveS i \<noteq> {}"  shows "(i,succ i) \<in> r \<and> succ i \<noteq> i"
using assms suc_greater[of "{i}"] unfolding succ_def AboveS_def aboveS_def Field_def by auto

lemmas succ_in[simp] = succ_in_diff[THEN conjunct1]
lemmas succ_diff[simp] = succ_in_diff[THEN conjunct2]

lemma succ_in_Field[simp]:
assumes "aboveS i \<noteq> {}"  shows "succ i \<in> Field r"
using succ_in[OF assms] unfolding Field_def by auto

lemma succ_not_in:
assumes "aboveS i \<noteq> {}" shows "(succ i, i) \<notin> r"
proof
  assume 1: "(succ i, i) \<in> r"
  hence "succ i \<in> Field r \<and> i \<in> Field r" unfolding Field_def by auto
  hence "(i, succ i) \<in> r \<and> succ i \<noteq> i" using assms by auto
  thus False using 1 by (metis ANTISYM antisymD)
qed

lemma not_isSucc_zero: "\<not> isSucc zero"
proof
  assume *: "isSucc zero"
  then obtain i where "aboveS i \<noteq> {}" and 1: "minim (Field r) = succ i"
  unfolding isSucc_def zero_def by auto
  hence "succ i \<in> Field r" by auto
  with * show False
    by (metis REFL isSucc_def minim_least refl_on_domain
        subset_refl succ_in succ_not_in zero_def)
qed

lemma isLim_zero[simp]: "isLim zero"
  by (metis isLim_def not_isSucc_zero)

lemma succ_smallest:
assumes "(i,j) \<in> r" and "i \<noteq> j"
shows "(succ i, j) \<in> r"
unfolding succ_def apply(rule suc_least)
using assms unfolding Field_def by auto

lemma isLim_supr:
assumes f: "i \<in> Field r" and l: "isLim i"
shows "i = supr (underS i)"
proof(rule equals_supr)
  fix j assume j: "j \<in> Field r" and 1: "\<And> j'. j' \<in> underS i \<Longrightarrow> (j',j) \<in> r"
  show "(i,j) \<in> r" proof(intro in_notinI[OF _ f j], safe)
    assume ji: "(j,i) \<in> r" "j \<noteq> i"
    hence a: "aboveS j \<noteq> {}" unfolding aboveS_def by auto
    hence "i \<noteq> succ j" using l unfolding isLim_def isSucc_def by auto
    moreover have "(succ j, i) \<in> r" using succ_smallest[OF ji] by auto
    ultimately have "succ j \<in> underS i" unfolding underS_def by auto
    hence "(succ j, j) \<in> r" using 1 by auto
    thus False using succ_not_in[OF a] by simp
  qed
qed(insert f, unfold underS_def Field_def, auto)

definition "pred i \<equiv> SOME j. j \<in> Field r \<and> aboveS j \<noteq> {} \<and> succ j = i"

lemma pred_Field_succ:
assumes "isSucc i" shows "pred i \<in> Field r \<and> aboveS (pred i) \<noteq> {} \<and> succ (pred i) = i"
proof-
  obtain j where a: "aboveS j \<noteq> {}" and i: "i = succ j" using assms unfolding isSucc_def by auto
  have 1: "j \<in> Field r" "j \<noteq> i" unfolding Field_def i
  using succ_diff[OF a] a unfolding aboveS_def by auto
  show ?thesis unfolding pred_def apply(rule someI_ex) using 1 i a by auto
qed

lemmas pred_Field[simp] = pred_Field_succ[THEN conjunct1]
lemmas aboveS_pred[simp] = pred_Field_succ[THEN conjunct2, THEN conjunct1]
lemmas succ_pred[simp] = pred_Field_succ[THEN conjunct2, THEN conjunct2]

lemma isSucc_pred_in:
assumes "isSucc i"  shows "(pred i, i) \<in> r"
proof-
  define j where "j = pred i"
  have i: "i = succ j" using assms unfolding j_def by simp
  have a: "aboveS j \<noteq> {}" unfolding j_def using assms by auto
  show ?thesis unfolding j_def[symmetric] unfolding i using succ_in[OF a] .
qed

lemma isSucc_pred_diff:
assumes "isSucc i"  shows "pred i \<noteq> i"
by (metis aboveS_pred assms succ_diff succ_pred)

(* todo: pred maximal, pred injective? *)

lemma succ_inj[simp]:
assumes "aboveS i \<noteq> {}" and "aboveS j \<noteq> {}"
shows "succ i = succ j \<longleftrightarrow> i = j"
proof safe
  assume s: "succ i = succ j"
  {assume "i \<noteq> j" and "(i,j) \<in> r"
   hence "(succ i, j) \<in> r" using assms by (metis succ_smallest)
   hence False using s assms by (metis succ_not_in)
  }
  moreover
  {assume "i \<noteq> j" and "(j,i) \<in> r"
   hence "(succ j, i) \<in> r" using assms by (metis succ_smallest)
   hence False using s assms by (metis succ_not_in)
  }
  ultimately show "i = j" by (metis TOTALS WELL assms(1) assms(2) succ_in_diff well_order_on_domain)
qed

lemma pred_succ[simp]:
assumes "aboveS j \<noteq> {}"  shows "pred (succ j) = j"
unfolding pred_def apply(rule some_equality)
using assms apply(force simp: Field_def aboveS_def)
by (metis assms succ_inj)

lemma less_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "(j, succ i) \<in> r \<longleftrightarrow> (j,i) \<in> r \<or> j = succ i"
apply safe
  apply (metis WELL assms in_notinI well_order_on_domain suc_singl_pred succ_def succ_in_diff)
  apply (metis (hide_lams, full_types) REFL TRANS assms max2_def max2_equals1 refl_on_domain succ_in_Field succ_not_in transD)
  apply (metis assms in_notinI succ_in_Field)
done

lemma underS_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "underS (succ i) = under i"
unfolding underS_def under_def by (auto simp: assms succ_not_in)

lemma succ_mono:
assumes "aboveS j \<noteq> {}" and "(i,j) \<in> r"
shows "(succ i, succ j) \<in> r"
by (metis (full_types) assms less_succ succ_smallest)

lemma under_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "under (succ i) = insert (succ i) (under i)"
using less_succ[OF assms] unfolding under_def by auto

definition mergeSL :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
"mergeSL S L f i \<equiv>
 if isSucc i then S (pred i) (f (pred i))
 else L f i"

subsubsection \<open>Well-order recursion with (zero), succesor, and limit\<close>

definition worecSL :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where "worecSL S L \<equiv> worec (mergeSL S L)"

definition "adm_woL L \<equiv> \<forall>f g i. isLim i \<and> (\<forall>j\<in>underS i. f j = g j) \<longrightarrow> L f i = L g i"

lemma mergeSL:
assumes "adm_woL L"  shows "adm_wo (mergeSL S L)"
unfolding adm_wo_def proof safe
  fix f g :: "'a => 'b" and i :: 'a
  assume 1: "\<forall>j\<in>underS i. f j = g j"
  show "mergeSL S L f i = mergeSL S L g i"
  proof(cases "isSucc i")
    case True
    hence "pred i \<in> underS i" unfolding underS_def using isSucc_pred_in isSucc_pred_diff by auto
    thus ?thesis using True 1 unfolding mergeSL_def by auto
  next
    case False hence "isLim i" unfolding isLim_def by auto
    thus ?thesis using assms False 1 unfolding mergeSL_def adm_woL_def by auto
  qed
qed

lemma worec_fixpoint1: "adm_wo H \<Longrightarrow> worec H i = H (worec H) i"
by (metis worec_fixpoint)

lemma worecSL_isSucc:
assumes a: "adm_woL L" and i: "isSucc i"
shows "worecSL S L i = S (pred i) (worecSL S L (pred i))"
proof-
  let ?H = "mergeSL S L"
  have "worecSL S L i = ?H (worec ?H) i"
  unfolding worecSL_def using worec_fixpoint1[OF mergeSL[OF a]] .
  also have "... = S (pred i) (worecSL S L (pred i))"
  unfolding worecSL_def mergeSL_def using i by simp
  finally show ?thesis .
qed

lemma worecSL_succ:
assumes a: "adm_woL L" and i: "aboveS j \<noteq> {}"
shows "worecSL S L (succ j) = S j (worecSL S L j)"
proof-
  define i where "i = succ j"
  have i: "isSucc i" by (metis i i_def isSucc_succ)
  have ij: "j = pred i" unfolding i_def using assms by simp
  have 0: "succ (pred i) = i" using i by simp
  show ?thesis unfolding ij using worecSL_isSucc[OF a i] unfolding 0 .
qed

lemma worecSL_isLim:
assumes a: "adm_woL L" and i: "isLim i"
shows "worecSL S L i = L (worecSL S L) i"
proof-
  let ?H = "mergeSL S L"
  have "worecSL S L i = ?H (worec ?H) i"
  unfolding worecSL_def using worec_fixpoint1[OF mergeSL[OF a]] .
  also have "... = L (worecSL S L) i"
  using i unfolding worecSL_def mergeSL_def isLim_def by simp
  finally show ?thesis .
qed

definition worecZSL :: "'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where "worecZSL Z S L \<equiv> worecSL S (\<lambda> f a. if a = zero then Z else L f a)"

lemma worecZSL_zero:
assumes a: "adm_woL L"
shows "worecZSL Z S L zero = Z"
proof-
  let ?L = "\<lambda> f a. if a = zero then Z else L f a"
  have "worecZSL Z S L zero = ?L (worecZSL Z S L) zero"
  unfolding worecZSL_def apply(rule worecSL_isLim)
  using assms unfolding adm_woL_def by auto
  also have "... = Z" by simp
  finally show ?thesis .
qed

lemma worecZSL_succ:
assumes a: "adm_woL L" and i: "aboveS j \<noteq> {}"
shows "worecZSL Z S L (succ j) = S j (worecZSL Z S L j)"
unfolding worecZSL_def apply(rule  worecSL_succ)
using assms unfolding adm_woL_def by auto

lemma worecZSL_isLim:
assumes a: "adm_woL L" and "isLim i" and "i \<noteq> zero"
shows "worecZSL Z S L i = L (worecZSL Z S L) i"
proof-
  let ?L = "\<lambda> f a. if a = zero then Z else L f a"
  have "worecZSL Z S L i = ?L (worecZSL Z S L) i"
  unfolding worecZSL_def apply(rule worecSL_isLim)
  using assms unfolding adm_woL_def by auto
  also have "... = L (worecZSL Z S L) i" using assms by simp
  finally show ?thesis .
qed

subsubsection \<open>Well-order succ-lim induction\<close>

lemma ord_cases:
obtains j where "i = succ j" and "aboveS j \<noteq> {}"  | "isLim i"
by (metis isLim_def isSucc_def)

lemma well_order_inductSL[case_names Suc Lim]:
assumes SUCC: "\<And>i. \<lbrakk>aboveS i \<noteq> {}; P i\<rbrakk> \<Longrightarrow> P (succ i)" and
LIM: "\<And>i. \<lbrakk>isLim i; \<And>j. j \<in> underS i \<Longrightarrow> P j\<rbrakk> \<Longrightarrow> P i"
shows "P i"
proof(induction rule: well_order_induct)
  fix i assume 0:  "\<forall>j. j \<noteq> i \<and> (j, i) \<in> r \<longrightarrow> P j"
  show "P i" proof(cases i rule: ord_cases)
    fix j assume i: "i = succ j" and j: "aboveS j \<noteq> {}"
    hence "j \<noteq> i \<and> (j, i) \<in> r" by (metis  succ_diff succ_in)
    hence 1: "P j" using 0 by simp
    show "P i" unfolding i apply(rule SUCC) using 1 j by auto
  qed(insert 0 LIM, unfold underS_def, auto)
qed

lemma well_order_inductZSL[case_names Zero Suc Lim]:
assumes ZERO: "P zero"
and SUCC: "\<And>i. \<lbrakk>aboveS i \<noteq> {}; P i\<rbrakk> \<Longrightarrow> P (succ i)" and
LIM: "\<And>i. \<lbrakk>isLim i; i \<noteq> zero; \<And>j. j \<in> underS i \<Longrightarrow> P j\<rbrakk> \<Longrightarrow> P i"
shows "P i"
apply(induction rule: well_order_inductSL) using assms by auto

(* Succesor and limit ordinals *)
definition "isSuccOrd \<equiv> \<exists> j \<in> Field r. \<forall> i \<in> Field r. (i,j) \<in> r"
definition "isLimOrd \<equiv> \<not> isSuccOrd"

lemma isLimOrd_succ:
assumes isLimOrd and "i \<in> Field r"
shows "succ i \<in> Field r"
using assms unfolding isLimOrd_def isSuccOrd_def
by (metis REFL in_notinI refl_on_domain succ_smallest)

lemma isLimOrd_aboveS:
assumes l: isLimOrd and i: "i \<in> Field r"
shows "aboveS i \<noteq> {}"
proof-
  obtain j where "j \<in> Field r" and "(j,i) \<notin> r"
  using assms unfolding isLimOrd_def isSuccOrd_def by auto
  hence "(i,j) \<in> r \<and> j \<noteq> i" by (metis i max2_def max2_greater)
  thus ?thesis unfolding aboveS_def by auto
qed

lemma succ_aboveS_isLimOrd:
assumes "\<forall> i \<in> Field r. aboveS i \<noteq> {} \<and> succ i \<in> Field r"
shows isLimOrd
unfolding isLimOrd_def isSuccOrd_def proof safe
  fix j assume j: "j \<in> Field r" "\<forall>i\<in>Field r. (i, j) \<in> r"
  hence "(succ j, j) \<in> r" using assms by auto
  moreover have "aboveS j \<noteq> {}" using assms j unfolding aboveS_def by auto
  ultimately show False by (metis succ_not_in)
qed

lemma isLim_iff:
assumes l: "isLim i" and j: "j \<in> underS i"
shows "\<exists> k. k \<in> underS i \<and> j \<in> underS k"
proof-
  have a: "aboveS j \<noteq> {}" using j unfolding underS_def aboveS_def by auto
  show ?thesis apply(rule exI[of _ "succ j"]) apply safe
  using assms a unfolding underS_def isLim_def
  apply (metis (lifting, full_types) isSucc_def mem_Collect_eq succ_smallest)
  by (metis (lifting, full_types) a mem_Collect_eq succ_diff succ_in)
qed

end (* context wo_rel *)

abbreviation "zero \<equiv> wo_rel.zero"
abbreviation "succ \<equiv> wo_rel.succ"
abbreviation "pred \<equiv> wo_rel.pred"
abbreviation "isSucc \<equiv> wo_rel.isSucc"
abbreviation "isLim \<equiv> wo_rel.isLim"
abbreviation "isLimOrd \<equiv> wo_rel.isLimOrd"
abbreviation "isSuccOrd \<equiv> wo_rel.isSuccOrd"
abbreviation "adm_woL \<equiv> wo_rel.adm_woL"
abbreviation "worecSL \<equiv> wo_rel.worecSL"
abbreviation "worecZSL \<equiv> wo_rel.worecZSL"

subsection \<open>Projections of wellorders\<close>

definition "oproj r s f \<equiv> Field s \<subseteq> f ` (Field r) \<and> compat r s f"

lemma oproj_in:
assumes "oproj r s f" and "(a,a') \<in> r"
shows "(f a, f a') \<in> s"
using assms unfolding oproj_def compat_def by auto

lemma oproj_Field:
assumes f: "oproj r s f" and a: "a \<in> Field r"
shows "f a \<in> Field s"
using oproj_in[OF f] a unfolding Field_def by auto

lemma oproj_Field2:
assumes f: "oproj r s f" and a: "b \<in> Field s"
shows "\<exists> a \<in> Field r. f a = b"
using assms unfolding oproj_def by auto

lemma oproj_under:
assumes f:  "oproj r s f" and a: "a \<in> under r a'"
shows "f a \<in> under s (f a')"
using oproj_in[OF f] a unfolding under_def by auto

(* An ordinal is embedded in another whenever it is embedded as an order
(not necessarily as initial segment):*)
theorem embedI:
assumes r: "Well_order r" and s: "Well_order s"
and f: "\<And> a. a \<in> Field r \<Longrightarrow> f a \<in> Field s \<and> f ` underS r a \<subseteq> underS s (f a)"
shows "\<exists> g. embed r s g"
proof-
  interpret r: wo_rel r by unfold_locales (rule r)
  interpret s: wo_rel s by unfold_locales (rule s)
  let ?G = "\<lambda> g a. suc s (g ` underS r a)"
  define g where "g = worec r ?G"
  have adm: "adm_wo r ?G" unfolding r.adm_wo_def image_def by auto
  (*  *)
  {fix a assume "a \<in> Field r"
   hence "bij_betw g (under r a) (under s (g a)) \<and>
          g a \<in> under s (f a)"
   proof(induction a rule: r.underS_induct)
     case (1 a)
     hence a: "a \<in> Field r"
     and IH1a: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> inj_on g (under r a1)"
     and IH1b: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g ` under r a1 = under s (g a1)"
     and IH2: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> under s (f a1)"
     unfolding underS_def Field_def bij_betw_def by auto
     have fa: "f a \<in> Field s" using f[OF a] by auto
     have g: "g a = suc s (g ` underS r a)"
     using r.worec_fixpoint[OF adm] unfolding g_def fun_eq_iff by simp
     have A0: "g ` underS r a \<subseteq> Field s"
     using IH1b by (metis IH2 image_subsetI in_mono under_Field)
     {fix a1 assume a1: "a1 \<in> underS r a"
      from IH2[OF this] have "g a1 \<in> under s (f a1)" .
      moreover have "f a1 \<in> underS s (f a)" using f[OF a] a1 by auto
      ultimately have "g a1 \<in> underS s (f a)" by (metis s.ANTISYM s.TRANS under_underS_trans)
     }
     hence "f a \<in> AboveS s (g ` underS r a)" unfolding AboveS_def
     using fa by simp (metis (lifting, full_types) mem_Collect_eq underS_def)
     hence A: "AboveS s (g ` underS r a) \<noteq> {}" by auto
     have B: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> underS s (g a)"
     unfolding g apply(rule s.suc_underS[OF A0 A]) by auto
     {fix a1 a2 assume a2: "a2 \<in> underS r a" and 1: "a1 \<in> underS r a2"
      hence a12: "{a1,a2} \<subseteq> under r a2" and "a1 \<noteq> a2" using r.REFL a
      unfolding underS_def under_def refl_on_def Field_def by auto
      hence "g a1 \<noteq> g a2" using IH1a[OF a2] unfolding inj_on_def by auto
      hence "g a1 \<in> underS s (g a2)" using IH1b[OF a2] a12
      unfolding underS_def under_def by auto
     } note C = this
     have ga: "g a \<in> Field s" unfolding g using s.suc_inField[OF A0 A] .
     have aa: "a \<in> under r a"
     using a r.REFL unfolding under_def underS_def refl_on_def by auto
     show ?case proof safe
       show "bij_betw g (under r a) (under s (g a))" unfolding bij_betw_def proof safe
         show "inj_on g (under r a)" proof(rule r.inj_on_Field)
           fix a1 a2 assume "a1 \<in> under r a" and a2: "a2 \<in> under r a" and a1: "a1 \<in> underS r a2"
           hence a22: "a2 \<in> under r a2" and a12: "a1 \<in> under r a2" "a1 \<noteq> a2"
           using a r.REFL unfolding under_def underS_def refl_on_def by auto
           show "g a1 \<noteq> g a2"
           proof(cases "a2 = a")
             case False hence "a2 \<in> underS r a"
             using a2 unfolding underS_def under_def by auto
             from IH1a[OF this] show ?thesis using a12 a22 unfolding inj_on_def by auto
           qed(insert B a1, unfold underS_def, auto)
         qed(unfold under_def Field_def, auto)
       next
         fix a1 assume a1: "a1 \<in> under r a"
         show "g a1 \<in> under s (g a)"
         proof(cases "a1 = a")
           case True thus ?thesis
           using ga s.REFL unfolding refl_on_def under_def by auto
         next
           case False
           hence a1: "a1 \<in> underS r a" using a1 unfolding underS_def under_def by auto
           thus ?thesis using B unfolding underS_def under_def by auto
         qed
       next
         fix b1 assume b1: "b1 \<in> under s (g a)"
         show "b1 \<in> g ` under r a"
         proof(cases "b1 = g a")
           case True thus ?thesis using aa by auto
         next
           case False
           hence "b1 \<in> underS s (g a)" using b1 unfolding underS_def under_def by auto
           from s.underS_suc[OF this[unfolded g] A0]
           obtain a1 where a1: "a1 \<in> underS r a" and b1: "b1 \<in> under s (g a1)" by auto
           obtain a2 where "a2 \<in> under r a1" and b1: "b1 = g a2" using IH1b[OF a1] b1 by auto
           hence "a2 \<in> under r a" using a1
           by (metis r.ANTISYM r.TRANS in_mono underS_subset_under under_underS_trans)
           thus ?thesis using b1 by auto
         qed
       qed
     next
       have "(g a, f a) \<in> s" unfolding g proof(rule s.suc_least[OF A0])
         fix b1 assume "b1 \<in> g ` underS r a"
         then obtain a1 where a1: "b1 = g a1" and a1: "a1 \<in> underS r a" by auto
         hence "b1 \<in> underS s (f a)"
         using a by (metis \<open>\<And>a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> underS s (f a)\<close>)
         thus "f a \<noteq> b1 \<and> (b1, f a) \<in> s" unfolding underS_def by auto
       qed(insert fa, auto)
       thus "g a \<in> under s (f a)" unfolding under_def by auto
     qed
   qed
  }
  thus ?thesis unfolding embed_def by auto
qed

corollary ordLeq_def2:
  "r \<le>o s \<longleftrightarrow> Well_order r \<and> Well_order s \<and>
               (\<exists> f. \<forall> a \<in> Field r. f a \<in> Field s \<and> f ` underS r a \<subseteq> underS s (f a))"
using embed_in_Field[of r s] embed_underS2[of r s] embedI[of r s]
unfolding ordLeq_def by fast

lemma iso_oproj:
  assumes r: "Well_order r" and s: "Well_order s" and f: "iso r s f"
  shows "oproj r s f"
using assms unfolding oproj_def
by (subst (asm) iso_iff3) (auto simp: bij_betw_def)

theorem oproj_embed:
assumes r: "Well_order r" and s: "Well_order s" and f: "oproj r s f"
shows "\<exists> g. embed s r g"
proof (rule embedI[OF s r, of "inv_into (Field r) f"], unfold underS_def, safe)
  fix b assume "b \<in> Field s"
  thus "inv_into (Field r) f b \<in> Field r" using oproj_Field2[OF f] by (metis imageI inv_into_into)
next
  fix a b assume "b \<in> Field s" "a \<noteq> b" "(a, b) \<in> s"
    "inv_into (Field r) f a = inv_into (Field r) f b"
  with f show False by (auto dest!: inv_into_injective simp: Field_def oproj_def)
next
  fix a b assume *: "b \<in> Field s" "a \<noteq> b" "(a, b) \<in> s"
  { assume "(inv_into (Field r) f a, inv_into (Field r) f b) \<notin> r"
    moreover
    from *(3) have "a \<in> Field s" unfolding Field_def by auto
    with *(1,2) have
      "inv_into (Field r) f a \<in> Field r" "inv_into (Field r) f b \<in> Field r"
      "inv_into (Field r) f a \<noteq> inv_into (Field r) f b"
      by (auto dest!: oproj_Field2[OF f] inv_into_injective intro!: inv_into_into)
    ultimately have "(inv_into (Field r) f b, inv_into (Field r) f a) \<in> r"
      using r by (auto simp: well_order_on_def linear_order_on_def total_on_def)
    with f[unfolded oproj_def compat_def] *(1) \<open>a \<in> Field s\<close>
      f_inv_into_f[of b f "Field r"] f_inv_into_f[of a f "Field r"]
      have "(b, a) \<in> s" by (metis in_mono)
    with *(2,3) s have False
      by (auto simp: well_order_on_def linear_order_on_def partial_order_on_def antisym_def)
  } thus "(inv_into (Field r) f a, inv_into (Field r) f b) \<in> r" by blast
qed

corollary oproj_ordLeq:
assumes r: "Well_order r" and s: "Well_order s" and f: "oproj r s f"
shows "s \<le>o r"
using oproj_embed[OF assms] r s unfolding ordLeq_def by auto

end


(* Title: Verification Component Based on KAT: Examples with Automated VCG
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsubsection \<open>Verification Examples with Automated VCG\<close>

theory VC_KAT_Examples2
  imports VC_KAT "HOL-Eisbach.Eisbach"
begin

text \<open>The following simple tactic for verification condition generation has been
implemented with the Eisbach proof methods language.\<close>

named_theorems hl_intro

declare sH_while_inv [hl_intro]
  rel_kat.H_seq [hl_intro]
  H_assign_var [hl_intro]
  rel_kat.H_cond [hl_intro]

method hoare = (rule hl_intro; hoare?)

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
   apply hoare
   using gcd_red_nat by auto

lemma integer_division:
  "PRE (\<lambda>s::nat store. s ''x'' \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. s ''x''));
    (WHILE (\<lambda>s. s ''y'' \<le> s ''r'') INV (\<lambda>s. s ''x'' = s ''q'' * s ''y'' + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - s ''y''))
      OD)
   POST (\<lambda>s. s ''x'' = s ''q'' * s ''y'' + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < s ''y'')"
   by hoare auto

lemma imp_reverse:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
   apply hoare
   apply auto[3]
   apply (clarsimp, metis (no_types, lifting) Cons_eq_appendI append_eq_append_conv2 hd_Cons_tl rev.simps(2) self_append_conv)
   by simp

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Normalising Word Numerals"

theory Norm_Words
imports "Signed_Words"
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval @{text "[0..2^len_of 'a)"}. Only for concrete word lengths.
\<close>

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (len_of TYPE('a)) (-numeral x))"
  by (simp only: word_ubin.Abs_norm word_neg_numeral_alt)

ML \<open>
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT (Type (@{type_name word}, [Type (@{type_name signed}, [T])])) = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

declare word_pow_0 [simp]

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ len_of TYPE('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

lemma "f (7 :: 2 word) = f 3" by simp

lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

lemma "(-1 :: 2 word) = 3" by simp

lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

lemma "f (-1) = f (15 :: 4 word)" by simp

lemma "f (-1) = f (7 :: 3 word)" by simp

lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end