theory Renegar_Algorithm
  imports  BKR_Algorithm
begin

(* There is significant overlap between Renegar's algorithm and BKR's.
  However, the RHS vector is constructed differently in Renegar. The base case is also different.
  In general, the _R's on definition and lemma names in this file are to emphasize that we are
  working with Renegar style.
*)

definition construct_NofI_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> real poly list \<Rightarrow> rat"
  where "construct_NofI_R p I1 I2 = (
    let new_p = sum_list (map (\<lambda>x. x^2) (p # I1)) in
    rat_of_int (changes_R_smods new_p ((pderiv new_p)*(prod_list I2))))"

(* Renegar's RHS vector will have type (nat list * nat list) list.
   Note the change from BKR, where the RHS vector had type nat list list*)
definition construct_rhs_vector_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list * nat list) list \<Rightarrow> rat vec"
  where "construct_rhs_vector_R p qs Is =
  vec_of_list (map (\<lambda>(I1,I2).
    (construct_NofI_R p (retrieve_polys qs I1) (retrieve_polys qs I2))) Is)"

section "Base Case"

(* Renegar's matrix is 3x3 instead of 2x2 *)
definition base_case_info_R:: "(rat mat \<times> ((nat list * nat list) list \<times> rat list list))"
  where "base_case_info_R =
    ((mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]]),([([], []),([0], []),([], [0])], [[1],[0],[-1]]))"

(* When p, q are coprime, this will actually be an int vec, which is why taking the floor is okay *)
definition base_case_solve_for_lhs:: "real poly \<Rightarrow> real poly \<Rightarrow> rat vec"
  where "base_case_solve_for_lhs p q = (mult_mat_vec (mat_of_rows_list 3 [[1/2, -1/2, 1/2], [0, 1, 0], [1/2, -1/2, -1/2]])  (construct_rhs_vector_R p [q] [([], []),([0], []),([], [0])]))"

(* Solve for LHS in general: mat_inverse returns an option type, and we pattern match on this.
  Notice that when we call this function in the algorithm, the matrix we pass will always be invertible,
  given how the construction works. *)
definition solve_for_lhs_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> (nat list * nat list) list \<Rightarrow> rat mat \<Rightarrow> rat vec"
  where "solve_for_lhs_R p qs subsets matr =
     mult_mat_vec (matr_option (dim_row matr) (mat_inverse_var matr))  (construct_rhs_vector_R p qs subsets)"

section "Smashing"

definition subsets_smash_R::"nat \<Rightarrow> (nat list*nat list) list \<Rightarrow> (nat list*nat list) list \<Rightarrow> (nat list*nat list) list"
  where "subsets_smash_R n s1 s2 = concat (map (\<lambda>l1. map (\<lambda> l2. (((fst l1) @ (map ((+) n) (fst l2))), (snd l1) @ (map ((+) n) (snd l2)))) s2) s1)"

definition smash_systems_R:: "('a::zero) poly \<Rightarrow> ('a::zero) poly list \<Rightarrow> ('a::zero) poly list \<Rightarrow> (nat list * nat list) list \<Rightarrow> (nat list * nat list) list \<Rightarrow>
  rat list list \<Rightarrow> rat list list \<Rightarrow> rat mat \<Rightarrow> rat mat \<Rightarrow>
  ('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list))"
  where "smash_systems_R p qs1 qs2 subsets1 subsets2 signs1 signs2 mat1 mat2 =
    (qs1@qs2, (kronecker_product mat1 mat2, (subsets_smash_R (length qs1) subsets1 subsets2, signs_smash signs1 signs2)))"

fun combine_systems_R:: "('a::zero) poly \<Rightarrow> (('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list))) \<Rightarrow> (('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list)))
  \<Rightarrow> (('a::zero) poly list \<times> (rat mat \<times> ((nat list * nat list) list \<times> rat list list)))"
  where "combine_systems_R p (qs1, m1, sub1, sgn1) (qs2, m2, sub2, sgn2) =
    (smash_systems_R p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2)"

(* Overall:
  Start with a matrix equation.
  Input a matrix, subsets, and signs.
  Drop columns of the matrix based on the 0's on the LHS---so extract a list of 0's. Reduce signs accordingly.
  Then find a list of rows to delete based on using rank (use the transpose result, pivot positions!),
   and delete those rows.  Reduce subsets accordingly.
  End with a reduced system! *)
section "Reduction"

fun reduction_step_R:: "rat mat \<Rightarrow> rat list list \<Rightarrow> (nat list*nat list) list \<Rightarrow> rat vec \<Rightarrow> rat mat \<times> ((nat list*nat list) list \<times> rat list list)"
  where "reduction_step_R A signs subsets lhs_vec =
    (let reduce_cols_A = (reduce_mat_cols A lhs_vec);
         rows_keep = rows_to_keep reduce_cols_A in
    (take_rows_from_matrix  reduce_cols_A rows_keep,
      (take_indices subsets rows_keep,
      take_indices signs (find_nonzeros_from_input_vec lhs_vec))))"

fun reduce_system_R:: "real poly \<Rightarrow> (real poly list \<times> (rat mat \<times> ((nat list*nat list) list \<times> rat list list))) \<Rightarrow> (rat mat \<times> ((nat list*nat list) list \<times> rat list list))"
  where "reduce_system_R p (qs,m,subs,signs) =
    reduction_step_R m signs subs (solve_for_lhs_R p qs subs m)"

section "Overall algorithm "
(* Find matrix, subsets, signs.
   The "rat mat" in the output is the matrix. The "(nat list*nat list) list" is the list of subsets.
   The "rat list list" is the list of signs.
*)
fun calculate_data_R:: "real poly \<Rightarrow> real poly list \<Rightarrow>  (rat mat \<times> ((nat list*nat list) list \<times> rat list list))"
  where
  "calculate_data_R p qs =
  ( let len = length qs in
    if len = 0 then
      (\<lambda>(a,b,c).(a,b,map (drop 1) c)) (reduce_system_R p ([1],base_case_info_R))
    else if len \<le> 1 then reduce_system_R p (qs,base_case_info_R)
    else
    (let q1 = take (len div 2) qs; left = calculate_data_R p q1;
         q2 = drop (len div 2) qs; right = calculate_data_R p q2;
         comb = combine_systems_R p (q1,left) (q2,right) in
         reduce_system_R p comb
    )
  )"

(* Extract the list of consistent sign assignments *)
definition find_consistent_signs_at_roots_R:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
  where [code]:
  "find_consistent_signs_at_roots_R p qs =
  ( let (M,S,\<Sigma>) = calculate_data_R p qs in \<Sigma> )"

lemma find_consistent_signs_at_roots_thm_R:
  shows "find_consistent_signs_at_roots_R p qs = snd (snd (calculate_data_R p qs))"
  by (simp add: case_prod_beta find_consistent_signs_at_roots_R_def)

end


(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)

theory Myhill
  imports Myhill_2 "Regular-Sets.Derivatives"
begin

section \<open>The theorem\<close>

theorem Myhill_Nerode:
  fixes A::"('a::finite) lang"
  shows "(\<exists>r. A = lang r) \<longleftrightarrow> finite (UNIV // \<approx>A)"
using Myhill_Nerode1 Myhill_Nerode2 by auto

subsection \<open>Second direction proved using partial derivatives\<close>

text \<open>
  An alternaive proof using the notion of partial derivatives for regular
  expressions due to Antimirov \cite{Antimirov95}.
\<close>

lemma MN_Rel_Derivs:
  shows "x \<approx>A y \<longleftrightarrow> Derivs x A = Derivs y A"
unfolding Derivs_def str_eq_def
by auto

lemma Myhill_Nerode3:
  fixes r::"'a rexp"
  shows "finite (UNIV // \<approx>(lang r))"
proof -
  have "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
  proof -
    have "range (\<lambda>x. pderivs x r) \<subseteq> Pow (pderivs_lang UNIV r)"
      unfolding pderivs_lang_def by auto
    moreover
    have "finite (Pow (pderivs_lang UNIV r))" by (simp add: finite_pderivs_lang)
    ultimately
    have "finite (range (\<lambda>x. pderivs x r))"
      by (simp add: finite_subset)
    then show "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
      by (rule finite_eq_tag_rel)
  qed
  moreover
  have "=(\<lambda>x. pderivs x r)= \<subseteq> \<approx>(lang r)"
    unfolding tag_eq_def
    by (auto simp add: MN_Rel_Derivs Derivs_pderivs)
  moreover
  have "equiv UNIV =(\<lambda>x. pderivs x r)="
  and  "equiv UNIV (\<approx>(lang r))"
    unfolding equiv_def refl_on_def sym_def trans_def
    unfolding tag_eq_def str_eq_def
    by auto
  ultimately show "finite (UNIV // \<approx>(lang r))"
    by (rule refined_partition_finite)
qed

end


\<^marker>\<open>creator "Peter Lammich"\<close>
\<^marker>\<open>contributor "Maximilian P. L. Haslbeck"\<close>
section \<open>Algorithms to calculate the logarithm of base 2\<close>
theory Sorting_Log2
imports Sorting_Setup
begin

paragraph \<open>Summary\<close>
text \<open>This theory two algorithms for calculating the logarithm for base 2.
    The first algorithm repeatedly divides by 2 until 0 is reached. This algorithm
    is linear in the log n.
    The second algorithm calculates the number of leading zeros. That algorithm thus has running
    time depending on the word size.
    We use the first algorithm for our further developments\<close>

subsection \<open>Log2 by iterated division by 2\<close>

definition log2_iter :: "nat \<Rightarrow> (nat,_) nrest"
  where "log2_iter n\<^sub>0 \<equiv> RECT' (\<lambda>log_iter n. do {
     if\<^sub>N SPECc2 ''icmp_slt'' (<) n 2 then
       RETURNT 0
     else doN {
       n' \<leftarrow> SPECc2 ''udiv'' (div) n 2;
       r \<leftarrow> log_iter n';
       ASSERT (r+1 \<le> n);
       SPECc2 ''add'' (+) r 1
     }
   }) n\<^sub>0"

abbreviation "log2_iter_body_cost n \<equiv> n *m (cost ''icmp_slt'' 1 + cost ''call'' 1 + cost ''if'' 1 + cost ''udiv'' 1 + cost ''add'' 1)"
definition "log2_iter_cost n \<equiv> log2_iter_body_cost (enat (Discrete.log n + 1))"

lemma minus_0_absorb_acost: "x - (0::(_,enat)acost) = x"
  apply(cases x)
  by(auto simp: minus_acost_alt zero_acost_def)

lemma log2_iter_refine_aux: "n\<ge>2 \<Longrightarrow> Suc (Discrete.log n - Suc 0) = Discrete.log n"
  using log_rec by auto

definition "mop_log x = SPECT [Discrete.log x \<mapsto> cost ''log'' 1]"

lemma log2_iter_refine:
  shows "log2_iter x \<le> SPECT [Discrete.log x \<mapsto> log2_iter_cost x]"
  unfolding log2_iter_def
        unfolding log2_iter_cost_def
  apply(cases "x>0")
  subgoal
    apply -
    apply(induct rule: log_induct)
    subgoal
      apply(subst RECT'_unfold)
       apply refine_mono
      apply(rule gwp_specifies_I)
      unfolding SPECc2_def

      apply (refine_vcg \<open>-\<close> rules: gwp_monadic_WHILEIET)
      subgoal apply (auto simp: norm_cost) apply sc_solve by(auto simp:  one_enat_def)
      subgoal by auto
      done
    subgoal
      apply(subst RECT'_unfold)
       apply refine_mono
      apply(rule gwp_specifies_I)
      unfolding SPECc2_def

      apply (refine_vcg \<open>-\<close>)
      subgoal by simp
      subgoal premises prems
        apply(rule prems(2)[THEN gwp_specifies_rev_I, THEN gwp_conseq4])
        apply (refine_vcg \<open>-\<close>)
        apply(auto split: if_splits)
         apply(auto simp: norm_cost minus_0_absorb_acost)
        subgoal apply(subst log2_iter_refine_aux) using prems(1) by auto
        subgoal apply sc_solve apply (auto simp: one_enat_def)
          apply(subst log2_iter_refine_aux) using prems(1) by auto
        subgoal apply(subst log2_iter_refine_aux) using prems(1)
          apply auto
          by (metis leD less_2_cases_iff log_exp2_le nat_le_linear neq0_conv pow_mono_leq_imp_lt)
        done
      done
    done
  subgoal
    apply(subst RECT'_unfold)
     apply refine_mono
    apply(rule gwp_specifies_I)
    unfolding SPECc2_def

    apply (refine_vcg \<open>-\<close> rules: gwp_monadic_WHILEIET)
    subgoal apply (auto simp: norm_cost) apply sc_solve by(auto simp: one_enat_def)
    subgoal by auto
    done
  done

lemma (in sort_impl_context) log2_iter_refine_TR_cmp_swap:
 "(x,x')\<in>Id \<Longrightarrow> log2_iter x \<le> \<Down> nat_rel (timerefine TR_cmp_swap (SPECT [Discrete.log x' \<mapsto> log2_iter_cost x']))"
  apply(rule order.trans)
   apply(rule log2_iter_refine)
  unfolding log2_iter_cost_def
  by (auto simp: timerefine_SPECT_map le_fun_def norm_cost)

lemma log2_iter_correct: "log2_iter x \<le> \<Down>Id (timerefine (TId(''log'':=log2_iter_cost x)) (mop_log x))"
  apply(rule order_trans)
  apply(rule log2_iter_refine)
  by(auto simp: mop_log_def timerefine_SPECT_map le_fun_def norm_cost)

(* TODO: @Peter integrate this type parameter into sort_impl_context and adapt
            all other functions *)
(*experiment
begin

sepref_register log2_iter
context
  fixes wordlen :: "'l::len2 itself"
  assumes [simp]: "LENGTH('l) \<ge> 4"
begin

find_in_thms "''icmp_slt''" in sepref_fr_rules

abbreviation "arb_size_assn \<equiv> snat_assn' TYPE('l)"

sepref_def log2_iter_impl is "log2_iter"
    :: "arb_size_assn\<^sup>k \<rightarrow>\<^sub>a arb_size_assn"
  unfolding log2_iter_def PR_CONST_def
  apply (annot_snat_const "TYPE('l::len2)")
  by sepref
end
end *)

context size_t_context
begin

  sepref_def log2_iter_impl is "log2_iter"
      :: "size_assn\<^sup>k \<rightarrow>\<^sub>a size_assn"
    unfolding log2_iter_def PR_CONST_def
    apply (annot_snat_const "TYPE('size_t)")
    by sepref
end

subsection \<open>Count Leading Zeroes and Log2\<close>
(* TODO: Define semantics of llvm.ctlz intrinsic! *)

subsubsection \<open>Explicit Implementation by Loop\<close>

definition word_clz' :: "'a::len word \<Rightarrow> nat" where
  "word_clz' x \<equiv> if x=0 then 0 else word_clz x"

lemma word_clz'_eq: "x\<noteq>0 \<Longrightarrow> word_clz' x = word_clz x"
  by (simp add: word_clz'_def)

lemma of_bl_eqZ:
  "\<lbrakk> length xs = LENGTH ('a::len0) \<rbrakk> \<Longrightarrow> (of_bl xs :: 'a word) = 0 \<longleftrightarrow> (xs = replicate LENGTH('a) False)"
  apply auto
  by (metis to_bl_0 to_bl_use_of_bl word_bl_Rep')

lemma word_clz'_rec: "word_clz' x = (if x <=s 0 then 0 else 1 + word_clz' (x << 1))"
  (* TODO: Clean up this mess! *)
  apply (clarsimp simp: word_clz'_def word_clz_def)
  apply (cases "to_bl x")
  apply auto
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: word_msb_alt word_sle_msb_le shiftl_bl)
  apply (subst (asm) of_bl_eqZ)
  apply (auto) []
  apply (metis length_Cons word_bl_Rep')
  apply (metis length_append_singleton length_replicate replicate_Suc replicate_append_same rotate1_rl' to_bl_0 word_bl.Rep_eqD)
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: bl_shiftl shiftl_bl)
  apply (subst (asm) of_bl_eqZ)
  apply auto
  apply (metis length_Cons word_bl_Rep')
  apply (subst word_bl.Abs_inverse)
  apply auto
  apply (metis length_Cons word_bl_Rep')
  apply (subgoal_tac "True\<in>set list")
  apply simp
  by (simp add: eq_zero_set_bl)

lemma word_clz'_rec2: "word_clz' x = (if 0 <s x then 1 + word_clz' (x << 1) else 0)"
  by (meson signed.not_le word_clz'_rec)

lemma word_clz'_simps2:
  "0 <s x \<Longrightarrow> word_clz' x = 1 + word_clz' (x << 1)"
  "\<not>(0 <s x) \<Longrightarrow> word_clz' x = 0"
  using word_clz'_rec2 by metis+

definition word_clz2 :: "'a::len2 word \<Rightarrow> (nat,_) nrest"
  where "word_clz2 x\<^sub>0 \<equiv> do {
    (c,_) \<leftarrow> monadic_WHILEIT (\<lambda>(c,x). word_clz' x\<^sub>0 = c + word_clz' x)
     (\<lambda>(c,x). SPECc2 ''icmp_slt'' (<s) 0 x) (\<lambda>(c,x). do {
      ASSERT (c + 1 < max_snat LENGTH('a));
      c' \<leftarrow> SPECc2 ''add'' (+) c 1;
      x' \<leftarrow> SPECc2 ''shl'' (<<) x 1;
      RETURN (c',x')
    }) (0,x\<^sub>0);
    RETURN c
  }"

lemma word_clz'_fits_snat: "word_clz' (x::'a::len2 word) < max_snat LENGTH('a)"
  unfolding word_clz'_def using word_clz_nonzero_max[of x]
  apply (auto simp: word_size max_snat_def)
  by (meson le_def n_less_equal_power_2 nat_le_Suc_less_imp order_trans)

abbreviation "word_clz2_body_cost \<equiv> cost ''icmp_slt'' 1 + cost ''add'' 1
                  + cost ''call'' 1 + cost ''if'' 1 + cost ''shl'' 1"

abbreviation "word_clz2_cost sw \<equiv>  (enat (1+sw)) *m word_clz2_body_cost"

(* TODO: move, DUP *)
lemma finite_sum_gtzero_nat_cost:
  "finite {a. the_acost (cost n m) a > (0::nat)}"
  unfolding cost_def by (auto simp: zero_acost_def)

lemma if_rule: "(c \<Longrightarrow> x \<le> a) \<Longrightarrow> (~c \<Longrightarrow> x \<le> b) \<Longrightarrow> x \<le> (if c then a else b)"
  by auto

lemma costmult_0_nat:
  shows "(0::nat) *m x = 0"
  by(auto simp: costmult_def zero_acost_def)

lemma word_clz2_refine: "word_clz2 x\<^sub>0 \<le> SPECT [word_clz' x\<^sub>0\<mapsto> word_clz2_cost (size x\<^sub>0)]"
  apply(rule order_trans[where y="SPECT [word_clz' x\<^sub>0\<mapsto> (enat (1+word_clz' x\<^sub>0)) *m word_clz2_body_cost]"])
  subgoal
    unfolding word_clz2_def
    apply(subst monadic_WHILEIET_def[symmetric, where E="\<lambda>(c,x). ((word_clz' x)) *m word_clz2_body_cost"])

    apply(rule gwp_specifies_I)
    unfolding SPECc2_def

    apply (refine_vcg \<open>-\<close> rules: gwp_monadic_WHILEIET)
    apply(rule gwp_monadic_WHILEIET)
    subgoal
      by(auto simp: wfR2_def the_acost_zero_app norm_cost intro!: finite_sum_gtzero_nat_cost)
    subgoal for s
      apply clarsimp
      apply (refine_vcg \<open>-\<close> rules: if_rule)
      subgoal
        apply(rule loop_body_conditionI)
        subgoal
          apply (auto simp: norm_cost)
          apply sc_solve
          by (auto simp add: word_clz'_rec2)
        subgoal
          apply (auto simp: norm_cost)
          apply sc_solve
          by (auto simp: one_enat_def word_clz'_rec2)
        subgoal
          by (simp add: word_clz'_rec2)
        done
      subgoal using word_clz'_fits_snat[of x\<^sub>0]
        by (auto simp: word_clz'_simps2)
      subgoal
        apply(rule loop_exit_conditionI)
        apply(refine_vcg \<open>-\<close>)
        apply (auto)
        subgoal
          using word_clz'_simps2(2) by blast
        subgoal
          apply(simp add: costmult_0_nat)
          apply(auto simp: norm_cost )
          apply sc_solve
          by (auto simp: one_enat_def)
        done
      done
    subgoal by simp
    done
  subgoal apply(simp add: le_fun_def)
    apply(rule costmult_right_mono)
    using word_clz_max by (auto simp add: word_clz'_def )
  done

(*
lemma word_clz2_refine': "(word_clz2, RETURN o word_clz') \<in> Id \<rightarrow> \<langle>Id\<rangle>nrest_rel"
  by (auto intro!: nrest_relI simp: word_clz2_refine)
*)

sepref_def word_clz'_impl is word_clz2 :: "(word_assn' TYPE('b::len2))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE('b)"
  unfolding word_clz2_def
  apply (rewrite at "(SPECc2 ''shl'' (<<) _ \<hole>)" snat_const_fold[where 'a='b])
  apply (rewrite at "(SPECc2 ''add'' (+) _ \<hole>)" snat_const_fold[where 'a='b])
  apply (rewrite at "(\<hole>,_)" snat_const_fold[where 'a='b])
  by sepref

export_llvm "word_clz'_impl :: 64 word \<Rightarrow> 64 word llM"

sepref_register word_clz'

lemma word_clz_nonzero_max': "x\<noteq>0 \<Longrightarrow> word_clz (x::'a::len2 word) \<le> LENGTH('a) - Suc 0"
  using word_clz_nonzero_max[of x] unfolding word_size
  by simp

lemma "x - 0 = (x::(_,enat) acost)"
  apply(cases x)
  by(auto simp: zero_acost_def minus_acost_alt)

definition word_log22 where
  "word_log22 (w::'a::len2 word) = doN {
    w' \<leftarrow> SPECc2 ''sub'' (-) (snat_const TYPE('a::len2) (size w)) 1;
    wclz \<leftarrow> word_clz2 w;
    w'' \<leftarrow> SPECc2 ''sub'' (-) w' wclz;
    RETURN w''
    }"
abbreviation "word_log22_cost sw \<equiv> word_clz2_cost sw + cost ''sub'' 2"

lemma word_log22_correct:
  assumes "w>0" "LENGTH('a::len2)>2"
  shows "word_log22 w \<le> SPECT [word_log2 w \<mapsto> word_log22_cost (size w)]"
  unfolding word_log22_def
  unfolding SPECc2_def
  apply(rule gwp_specifies_I)

  using assms
  apply (refine_vcg \<open>-\<close> rules: word_clz2_refine[THEN gwp_specifies_rev_I, THEN gwp_conseq4])
  apply(auto simp: word_log2_def  word_clz'_def split: if_splits)
  apply(simp add: norm_cost needname_minus_absorb)
  apply sc_solve by auto

(*

sepref_def word_log2_impl is
  "word_log22" :: "[\<lambda>x. x>0 \<and> LENGTH('a)>2]\<^sub>a (word_assn' TYPE('a::len2))\<^sup>k \<rightarrow> snat_assn' TYPE('a)"
  unfolding word_log22_def word_size PR_CONST_def
  apply (annot_snat_const "TYPE('a)")
  supply [simp] = word_clz_nonzero_max'
  apply sepref_dbg_preproc
  apply sepref_dbg_cons_init
  apply sepref_dbg_id
  apply sepref_dbg_monadify
  apply sepref_dbg_opt_init
  apply sepref_dbg_trans_keep
  apply sepref_dbg_opt
  apply sepref_dbg_cons_solve
  apply sepref_dbg_cons_solve
  apply sepref_dbg_constraints
  by sepref  (* TODO: sepref *)

export_llvm "word_log2_impl :: 64 word \<Rightarrow> _"
*)
subsubsection \<open>Connection with \<^const>\<open>Discrete.log\<close>\<close>

lemma discrete_log_ltI: (* TODO: Check how precise this bound is! *)
  assumes "n\<noteq>0" "N\<noteq>0" "n<2^N"
  shows "Discrete.log n < N"
  using assms
  by (metis Discrete.log_le_iff leD linorder_neqE_nat log_exp log_exp2_le order_less_le zero_order(3))

lemma unat_x_div_2_conv:
  fixes x y :: "'a::len2 word"
  shows "unat x div 2 = unat y \<longleftrightarrow> y = x div 2"
proof -
  have A: "2 = unat (2::'a word)"
    by (metis le_less_trans len2_simps(2) n_less_equal_power_2 of_nat_numeral unat_of_nat_len)

  have B: "unat x div 2 = unat (x div 2)"
    unfolding A
    by (simp add: unat_div)

  show ?thesis
    by (auto simp: B dest: word_unat.Rep_eqD)

qed

lemma take_size_m1_to_bl:
  fixes x :: "'a::len word"
  shows "take (size x - Suc 0) (to_bl x) = butlast (to_bl x)"
  by (simp add: butlast_conv_take word_size_bl)

lemma takeWhile_butlast_eqI: "\<lbrakk>x\<in>set xs; \<not>P x\<rbrakk> \<Longrightarrow> takeWhile P (butlast xs) = takeWhile P xs"
  by (metis append_Nil2 butlast.simps(2) butlast_append list.simps(3) split_list_last takeWhile_tail)

lemma takeWhile_butlast_eqI': "\<lbrakk>\<exists>x\<in>set xs. \<not>P x\<rbrakk> \<Longrightarrow> takeWhile P (butlast xs) = takeWhile P xs"
  by (metis append_Nil2 butlast.simps(2) butlast_append list.simps(3) split_list_last takeWhile_tail)

lemma ex_True_in_set_conv: "(\<exists>x\<in>S. x) \<longleftrightarrow> True\<in>S" by auto

lemma word_clz_rec:
  fixes x :: "'a::len2 word"
  shows "2\<le>x \<Longrightarrow> word_clz (x div 2) = word_clz x + 1"
  unfolding word_clz_def shiftr1_is_div_2[symmetric]
  apply (auto simp: bl_shiftr word_size)
  apply (subst bl_shiftr)
  apply (simp add: word_size Suc_leI)
  apply (auto simp: take_size_m1_to_bl)
  apply (subst takeWhile_butlast_eqI')
  apply (simp_all add: ex_True_in_set_conv)
  apply (rule ccontr)
  apply (simp only: eq_zero_set_bl[symmetric])
  by (metis le_unat_uoi len2_simps(2) n_less_equal_power_2 of_nat_numeral unat_0 unat_of_nat_len word_le_0_iff zero_neq_numeral)

lemma overflow_safe_hbound_check: "2*k\<le>n \<longleftrightarrow> k\<le>n div 2" for k n :: nat by auto

lemma word_clz_ge2_max: "2\<le>(x::'a::len2 word) \<Longrightarrow> word_clz x + 1 < size x"
  apply (simp only: word_clz_rec[symmetric] word_size)
  apply (rule word_clz_nonzero_max[of "x div 2", unfolded word_size])
  by (smt One_nat_def Suc_pred add.left_neutral add.right_neutral add_diff_cancel_left' add_diff_cancel_right'
        add_left_cancel diff_Suc_Suc div_less div_of_0_id div_self lessI less_eq_Suc_le less_one linorder_neqE_nat
        linorder_not_le mult.right_neutral not_numeral_le_zero numeral_2_eq_2 numeral_One numeral_le_one_iff order_less_le
        overflow_safe_hbound_check pos2 power.simps(1) power.simps(2) semiring_norm(69) unat_0 unat_div unat_eq_zero unat_gt_0
        unat_x_div_2_conv word_clz_rec word_gt_0_no word_le_nat_alt zero_less_one zero_neq_one)

lemma word_log2_rec:
  fixes x :: "'a::len2 word" shows "2\<le>x \<Longrightarrow> word_log2 x = Suc (word_log2 (x div 2))"
  apply (auto simp: word_log2_def word_size word_clz_rec)
  using word_clz_ge2_max[unfolded word_size, of x]
  by auto

lemma word_log2_is_discrete_log:
  fixes x :: "'a::len2 word"
  shows "word_log2 x = Discrete.log (unat x)"
  apply (cases "x=0")
  apply simp
  subgoal proof -
    assume "x \<noteq> 0"
    hence "unat x > 0" by (simp add: unat_gt_0)
    then show ?thesis
    proof (induction "unat x" arbitrary: x rule: log_induct)
      case one
      hence "x=1" using word_unat_Rep_inject1 by auto
      then show ?case
        unfolding word_log2_def
        by (auto simp: word_size)

    next
      case double

      from double.hyps(2) have "Discrete.log (unat x div 2) = word_log2 (x div 2)"
        by (metis unat_x_div_2_conv)

      then show ?case
        apply (subst log_rec, simp add: \<open>2 \<le> unat x\<close>)
        apply simp
        apply (subst word_log2_rec)
        apply auto
        using double.hyps(1) le_unat_uoi word_le_nat_alt by fastforce

    qed
  qed
  done

lemma word_log2_refine_unat: "(word_log2, Discrete.log) \<in> unat_rel' TYPE('a::len2) \<rightarrow> nat_rel"
  using word_log2_is_discrete_log
  by (fastforce simp: unat_rel_def unat.rel_def in_br_conv)

lemma word_log2_refine_snat: "(word_log2, Discrete.log) \<in> snat_rel' TYPE('a::len2) \<rightarrow> nat_rel"
  using word_log2_is_discrete_log
  by (fastforce simp: snat_rel_def snat.rel_def in_br_conv snat_eq_unat)

end


theory tutorial_3
imports
Main

begin

locale group =
  fixes on :: "'p ⇒ 'l ⇒ bool"
  assumes line_on_two_pts: "a ≠ b ⟹ ∃l. on a l ∧ on b l"
   and line_on_two_pts_unique: "⟦ a ≠ b; on a l; on b l; on a m; on b m ⟧ ⟹ l = m"
  and two_points_on_line: "∃a b. a ≠ b ∧ on a l ∧ on b l"
  and three_points_not_on_line: "∃a b c. a ≠ b ∧ a ≠ c ∧ b ≠ c ∧
                                    ¬ (∃l. on a l ∧ on b l ∧ on c l)"

(* PROOFS START *)

begin

(* not all points lie on the same line. *)
lemma exists_a_point_not_on_line: "∃x. ¬ on x l"
proof -
  obtain a b c where lines: "¬ (on a l ∧ on b l ∧ on c l)"
    using three_points_not_on_line by blast
  then show ?thesis by blast
qed

(* there exist at least two lines through each point. *)
lemma two_lines_through_each_point: "∃l k. on x l ∧ on x k ∧ l ≠ k"
proof -
  have "∃z. z ≠ x"
  proof (rule ccontr)
    from two_points_on_line obtain a b where ab: "(a::'p) ≠ b" by blast
    assume "∄z. z ≠ x"
    then have univ: "∀z. z = x" by blast
    then have "a = x" and "b = x" by auto
    then show False
      using ab by simp
  qed
  then obtain z where "z ≠ x" by blast
  then obtain l where xl: "on x l" and zl: "on z l" using line_on_two_pts by blast
  obtain w where n_wl: "¬ on w l" using exists_a_point_not_on_line by blast
  obtain m where wm: "on x m" and zm: "on w m" using line_on_two_pts xl by force
  then have "l ≠ m" using n_wl by blast
  thus ?thesis using wm xl by blast
qed

(* two lines cannot intersect in more than one point.
   proof method: prove that they are the same line if they do. *)
lemma two_lines_unique_intersect_pt:
  assumes lm: "l ≠ m" and "on x l" and "on x m" and "on y l" and "on y m"
  shows "x = y"
  proof (rule ccontr)
    assume "x ≠ y"
    then have "l = m"
      using assms(2) assms(3) assms(4) assms(5) line_on_two_pts_unique by simp
    thus False
      using lm by simp
  qed

end

(* PROOFS END *)

end


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

Well-order relations as needed by bounded natural functors.
*)

section \<open>Well-Order Relations as Needed by Bounded Natural Functors\<close>

theory BNF_Wellorder_Relation
imports Order_Relation
begin

text\<open>In this section, we develop basic concepts and results pertaining
to well-order relations.  Note that we consider well-order relations
as {\em non-strict relations},
i.e., as containing the diagonals of their fields.\<close>

locale wo_rel =
  fixes r :: "'a rel"
  assumes WELL: "Well_order r"
begin

text\<open>The following context encompasses all this section. In other words,
for the whole section, we consider a fixed well-order relation @{term "r"}.\<close>

(* context wo_rel  *)

abbreviation under where "under \<equiv> Order_Relation.under r"
abbreviation underS where "underS \<equiv> Order_Relation.underS r"
abbreviation Under where "Under \<equiv> Order_Relation.Under r"
abbreviation UnderS where "UnderS \<equiv> Order_Relation.UnderS r"
abbreviation above where "above \<equiv> Order_Relation.above r"
abbreviation aboveS where "aboveS \<equiv> Order_Relation.aboveS r"
abbreviation Above where "Above \<equiv> Order_Relation.Above r"
abbreviation AboveS where "AboveS \<equiv> Order_Relation.AboveS r"
abbreviation ofilter where "ofilter \<equiv> Order_Relation.ofilter r"
lemmas ofilter_def = Order_Relation.ofilter_def[of r]

subsection \<open>Auxiliaries\<close>

lemma REFL: "Refl r"
using WELL order_on_defs[of _ r] by auto

lemma TRANS: "trans r"
using WELL order_on_defs[of _ r] by auto

lemma ANTISYM: "antisym r"
using WELL order_on_defs[of _ r] by auto

lemma TOTAL: "Total r"
using WELL order_on_defs[of _ r] by auto

lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force

lemma LIN: "Linear_order r"
using WELL well_order_on_def[of _ r] by auto

lemma WF: "wf (r - Id)"
using WELL well_order_on_def[of _ r] by auto

lemma cases_Total:
"\<And> phi a b. \<lbrakk>{a,b} <= Field r; ((a,b) \<in> r \<Longrightarrow> phi a b); ((b,a) \<in> r \<Longrightarrow> phi a b)\<rbrakk>
             \<Longrightarrow> phi a b"
using TOTALS by auto

lemma cases_Total3:
"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (b,a) \<in> r - Id \<Longrightarrow> phi a b);
              (a = b \<Longrightarrow> phi a b)\<rbrakk>  \<Longrightarrow> phi a b"
using TOTALS by auto

subsection \<open>Well-founded induction and recursion adapted to non-strict well-order relations\<close>

text\<open>Here we provide induction and recursion principles specific to {\em non-strict}
well-order relations.
Although minor variations of those for well-founded relations, they will be useful
for doing away with the tediousness of
having to take out the diagonal each time in order to switch to a well-founded relation.\<close>

lemma well_order_induct:
assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
shows "P a"
proof-
  have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
  using IND by blast
  thus "P a" using WF wf_induct[of "r - Id" P a] by blast
qed

definition
worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
"worec F \<equiv> wfrec (r - Id) F"

definition
adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
where
"adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"

lemma worec_fixpoint:
assumes ADM: "adm_wo H"
shows "worec H = H (worec H)"
proof-
  let ?rS = "r - Id"
  have "adm_wf (r - Id) H"
  unfolding adm_wf_def
  using ADM adm_wo_def[of H] underS_def[of r] by auto
  hence "wfrec ?rS H = H (wfrec ?rS H)"
  using WF wfrec_fixpoint[of ?rS H] by simp
  thus ?thesis unfolding worec_def .
qed

subsection \<open>The notions of maximum, minimum, supremum, successor and order filter\<close>

text\<open>
We define the successor {\em of a set}, and not of an element (the latter is of course
a particular case).  Also, we define the maximum {\em of two elements}, \<open>max2\<close>,
and the minimum {\em of a set}, \<open>minim\<close> -- we chose these variants since we
consider them the most useful for well-orders.  The minimum is defined in terms of the
auxiliary relational operator \<open>isMinim\<close>.  Then, supremum and successor are
defined in terms of minimum as expected.
The minimum is only meaningful for non-empty sets, and the successor is only
meaningful for sets for which strict upper bounds exist.
Order filters for well-orders are also known as ``initial segments".\<close>

definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where "max2 a b \<equiv> if (a,b) \<in> r then b else a"

definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"

definition minim :: "'a set \<Rightarrow> 'a"
where "minim A \<equiv> THE b. isMinim A b"

definition supr :: "'a set \<Rightarrow> 'a"
where "supr A \<equiv> minim (Above A)"

definition suc :: "'a set \<Rightarrow> 'a"
where "suc A \<equiv> minim (AboveS A)"

subsubsection \<open>Properties of max2\<close>

lemma max2_greater_among:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
proof-
  {assume "(a,b) \<in> r"
   hence ?thesis using max2_def assms REFL refl_on_def
   by (auto simp add: refl_on_def)
  }
  moreover
  {assume "a = b"
   hence "(a,b) \<in> r" using REFL  assms
   by (auto simp add: refl_on_def)
  }
  moreover
  {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
   hence "(a,b) \<notin> r" using ANTISYM
   by (auto simp add: antisym_def)
   hence ?thesis using * max2_def assms REFL refl_on_def
   by (auto simp add: refl_on_def)
  }
  ultimately show ?thesis using assms TOTAL
  total_on_def[of "Field r" r] by blast
qed

lemma max2_greater:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
using assms by (auto simp add: max2_greater_among)

lemma max2_among:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "max2 a b \<in> {a, b}"
using assms max2_greater_among[of a b] by simp

lemma max2_equals1:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(max2 a b = a) = ((b,a) \<in> r)"
using assms ANTISYM unfolding antisym_def using TOTALS
by(auto simp add: max2_def max2_among)

lemma max2_equals2:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "(max2 a b = b) = ((a,b) \<in> r)"
using assms ANTISYM unfolding antisym_def using TOTALS
unfolding max2_def by auto

subsubsection \<open>Existence and uniqueness for isMinim and well-definedness of minim\<close>

lemma isMinim_unique:
assumes MINIM: "isMinim B a" and MINIM': "isMinim B a'"
shows "a = a'"
proof-
  {have "a \<in> B"
   using MINIM isMinim_def by simp
   hence "(a',a) \<in> r"
   using MINIM' isMinim_def by simp
  }
  moreover
  {have "a' \<in> B"
   using MINIM' isMinim_def by simp
   hence "(a,a') \<in> r"
   using MINIM isMinim_def by simp
  }
  ultimately
  show ?thesis using ANTISYM antisym_def[of r] by blast
qed

lemma Well_order_isMinim_exists:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "\<exists>b. isMinim B b"
proof-
  from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
  *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
  show ?thesis
  proof(simp add: isMinim_def, rule exI[of _ b], auto)
    show "b \<in> B" using * by simp
  next
    fix b' assume As: "b' \<in> B"
    hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
    (*  *)
    from As  * have "b' = b \<or> (b',b) \<notin> r" by auto
    moreover
    {assume "b' = b"
     hence "(b,b') \<in> r"
     using ** REFL by (auto simp add: refl_on_def)
    }
    moreover
    {assume "b' \<noteq> b \<and> (b',b) \<notin> r"
     hence "(b,b') \<in> r"
     using ** TOTAL by (auto simp add: total_on_def)
    }
    ultimately show "(b,b') \<in> r" by blast
  qed
qed

lemma minim_isMinim:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "isMinim B (minim B)"
proof-
  let ?phi = "(\<lambda> b. isMinim B b)"
  from assms Well_order_isMinim_exists
  obtain b where *: "?phi b" by blast
  moreover
  have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
  using isMinim_unique * by auto
  ultimately show ?thesis
  unfolding minim_def using theI[of ?phi b] by blast
qed

subsubsection\<open>Properties of minim\<close>

lemma minim_in:
assumes "B \<le> Field r" and "B \<noteq> {}"
shows "minim B \<in> B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by simp
  thus ?thesis by (simp add: isMinim_def)
qed

lemma minim_inField:
assumes "B \<le> Field r" and "B \<noteq> {}"
shows "minim B \<in> Field r"
proof-
  have "minim B \<in> B" using assms by (simp add: minim_in)
  thus ?thesis using assms by blast
qed

lemma minim_least:
assumes  SUB: "B \<le> Field r" and IN: "b \<in> B"
shows "(minim B, b) \<in> r"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  thus ?thesis by (auto simp add: isMinim_def IN)
qed

lemma equals_minim:
assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
        LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
shows "a = minim B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  moreover have "isMinim B a" using IN LEAST isMinim_def by auto
  ultimately show ?thesis
  using isMinim_unique by auto
qed

subsubsection\<open>Properties of successor\<close>

lemma suc_AboveS:
assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
shows "suc B \<in> AboveS B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r] by auto
  thus "minim (AboveS B) \<in> AboveS B"
  using assms by (simp add: minim_in)
qed

lemma suc_greater:
assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and
        IN: "b \<in> B"
shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
proof-
  from assms suc_AboveS
  have "suc B \<in> AboveS B" by simp
  with IN AboveS_def[of r] show ?thesis by simp
qed

lemma suc_least_AboveS:
assumes ABOVES: "a \<in> AboveS B"
shows "(suc B,a) \<in> r"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r] by auto
  thus "(minim (AboveS B),a) \<in> r"
  using assms minim_least by simp
qed

lemma suc_inField:
assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
shows "suc B \<in> Field r"
proof-
  have "suc B \<in> AboveS B" using suc_AboveS assms by simp
  thus ?thesis
  using assms AboveS_Field[of r] by auto
qed

lemma equals_suc_AboveS:
assumes SUB: "B \<le> Field r" and ABV: "a \<in> AboveS B" and
        MINIM: "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
shows "a = suc B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
  using AboveS_Field[of r B] by auto
  thus "a = minim (AboveS B)"
  using assms equals_minim
  by simp
qed

lemma suc_underS:
assumes IN: "a \<in> Field r"
shows "a = suc (underS a)"
proof-
  have "underS a \<le> Field r"
  using underS_Field[of r] by auto
  moreover
  have "a \<in> AboveS (underS a)"
  using in_AboveS_underS IN by fast
  moreover
  have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
  proof(clarify)
    fix a'
    assume *: "a' \<in> AboveS (underS a)"
    hence **: "a' \<in> Field r"
    using AboveS_Field by fast
    {assume "(a,a') \<notin> r"
     hence "a' = a \<or> (a',a) \<in> r"
     using TOTAL IN ** by (auto simp add: total_on_def)
     moreover
     {assume "a' = a"
      hence "(a,a') \<in> r"
      using REFL IN ** by (auto simp add: refl_on_def)
     }
     moreover
     {assume "a' \<noteq> a \<and> (a',a) \<in> r"
      hence "a' \<in> underS a"
      unfolding underS_def by simp
      hence "a' \<notin> AboveS (underS a)"
      using AboveS_disjoint by fast
      with * have False by simp
     }
     ultimately have "(a,a') \<in> r" by blast
    }
    thus  "(a, a') \<in> r" by blast
  qed
  ultimately show ?thesis
  using equals_suc_AboveS by auto
qed

subsubsection \<open>Properties of order filters\<close>

lemma under_ofilter:
"ofilter (under a)"
proof(unfold ofilter_def under_def, auto simp add: Field_def)
  fix aa x
  assume "(aa,a) \<in> r" "(x,aa) \<in> r"
  thus "(x,a) \<in> r"
  using TRANS trans_def[of r] by blast
qed

lemma underS_ofilter:
"ofilter (underS a)"
proof(unfold ofilter_def underS_def under_def, auto simp add: Field_def)
  fix aa assume "(a, aa) \<in> r" "(aa, a) \<in> r" and DIFF: "aa \<noteq> a"
  thus False
  using ANTISYM antisym_def[of r] by blast
next
  fix aa x
  assume "(aa,a) \<in> r" "aa \<noteq> a" "(x,aa) \<in> r"
  thus "(x,a) \<in> r"
  using TRANS trans_def[of r] by blast
qed

lemma Field_ofilter:
"ofilter (Field r)"
by(unfold ofilter_def under_def, auto simp add: Field_def)

lemma ofilter_underS_Field:
"ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
proof
  assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
  thus "ofilter A"
  by (auto simp: underS_ofilter Field_ofilter)
next
  assume *: "ofilter A"
  let ?One = "(\<exists>a\<in>Field r. A = underS a)"
  let ?Two = "(A = Field r)"
  show "?One \<or> ?Two"
  proof(cases ?Two, simp)
    let ?B = "(Field r) - A"
    let ?a = "minim ?B"
    assume "A \<noteq> Field r"
    moreover have "A \<le> Field r" using * ofilter_def by simp
    ultimately have 1: "?B \<noteq> {}" by blast
    hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
    have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
    hence 4: "?a \<notin> A" by blast
    have 5: "A \<le> Field r" using * ofilter_def by auto
    (*  *)
    moreover
    have "A = underS ?a"
    proof
      show "A \<le> underS ?a"
      proof(unfold underS_def, auto simp add: 4)
        fix x assume **: "x \<in> A"
        hence 11: "x \<in> Field r" using 5 by auto
        have 12: "x \<noteq> ?a" using 4 ** by auto
        have 13: "under x \<le> A" using * ofilter_def ** by auto
        {assume "(x,?a) \<notin> r"
         hence "(?a,x) \<in> r"
         using TOTAL total_on_def[of "Field r" r]
               2 4 11 12 by auto
         hence "?a \<in> under x" using under_def[of r] by auto
         hence "?a \<in> A" using ** 13 by blast
         with 4 have False by simp
        }
        thus "(x,?a) \<in> r" by blast
      qed
    next
      show "underS ?a \<le> A"
      proof(unfold underS_def, auto)
        fix x
        assume **: "x \<noteq> ?a" and ***: "(x,?a) \<in> r"
        hence 11: "x \<in> Field r" using Field_def by fastforce
         {assume "x \<notin> A"
          hence "x \<in> ?B" using 11 by auto
          hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
          hence False
          using ANTISYM antisym_def[of r] ** *** by auto
         }
        thus "x \<in> A" by blast
      qed
    qed
    ultimately have ?One using 2 by blast
    thus ?thesis by simp
  qed
qed

lemma ofilter_UNION:
"(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union>i \<in> I. A i)"
unfolding ofilter_def by blast

lemma ofilter_under_UNION:
assumes "ofilter A"
shows "A = (\<Union>a \<in> A. under a)"
proof
  have "\<forall>a \<in> A. under a \<le> A"
  using assms ofilter_def by auto
  thus "(\<Union>a \<in> A. under a) \<le> A" by blast
next
  have "\<forall>a \<in> A. a \<in> under a"
  using REFL Refl_under_in[of r] assms ofilter_def[of A] by blast
  thus "A \<le> (\<Union>a \<in> A. under a)" by blast
qed

subsubsection\<open>Other properties\<close>

lemma ofilter_linord:
assumes OF1: "ofilter A" and OF2: "ofilter B"
shows "A \<le> B \<or> B \<le> A"
proof(cases "A = Field r")
  assume Case1: "A = Field r"
  hence "B \<le> A" using OF2 ofilter_def by auto
  thus ?thesis by simp
next
  assume Case2: "A \<noteq> Field r"
  with ofilter_underS_Field OF1 obtain a where
  1: "a \<in> Field r \<and> A = underS a" by auto
  show ?thesis
  proof(cases "B = Field r")
    assume Case21: "B = Field r"
    hence "A \<le> B" using OF1 ofilter_def by auto
    thus ?thesis by simp
  next
    assume Case22: "B \<noteq> Field r"
    with ofilter_underS_Field OF2 obtain b where
    2: "b \<in> Field r \<and> B = underS b" by auto
    have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
    using 1 2 TOTAL total_on_def[of _ r] by auto
    moreover
    {assume "a = b" with 1 2 have ?thesis by auto
    }
    moreover
    {assume "(a,b) \<in> r"
     with underS_incr[of r] TRANS ANTISYM 1 2
     have "A \<le> B" by auto
     hence ?thesis by auto
    }
    moreover
     {assume "(b,a) \<in> r"
     with underS_incr[of r] TRANS ANTISYM 1 2
     have "B \<le> A" by auto
     hence ?thesis by auto
    }
    ultimately show ?thesis by blast
  qed
qed

lemma ofilter_AboveS_Field:
assumes "ofilter A"
shows "A \<union> (AboveS A) = Field r"
proof
  show "A \<union> (AboveS A) \<le> Field r"
  using assms ofilter_def AboveS_Field[of r] by auto
next
  {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
   {fix y assume ***: "y \<in> A"
    with ** have 1: "y \<noteq> x" by auto
    {assume "(y,x) \<notin> r"
     moreover
     have "y \<in> Field r" using assms ofilter_def *** by auto
     ultimately have "(x,y) \<in> r"
     using 1 * TOTAL total_on_def[of _ r] by auto
     with *** assms ofilter_def under_def[of r] have "x \<in> A" by auto
     with ** have False by contradiction
    }
    hence "(y,x) \<in> r" by blast
    with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
   }
   with * have "x \<in> AboveS A" unfolding AboveS_def by auto
  }
  thus "Field r \<le> A \<union> (AboveS A)" by blast
qed

lemma suc_ofilter_in:
assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
        REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
shows "b \<in> A"
proof-
  have *: "suc A \<in> Field r \<and> b \<in> Field r"
  using WELL REL well_order_on_domain[of "Field r"] by auto
  {assume **: "b \<notin> A"
   hence "b \<in> AboveS A"
   using OF * ofilter_AboveS_Field by auto
   hence "(suc A, b) \<in> r"
   using suc_least_AboveS by auto
   hence False using REL DIFF ANTISYM *
   by (auto simp add: antisym_def)
  }
  thus ?thesis by blast
qed

end (* context wo_rel *)

end


theory Generics
  imports Graph Morphism "HOL-Library.Countable"
begin

type_synonym ('l,'m) ngraph = "(nat,nat,'l,'m) pre_graph"

definition to_ngraph :: "('v::countable,'e :: countable,'l,'m) pre_graph \<Rightarrow> ('l,'m) ngraph" where
\<open>to_ngraph G \<equiv> \<lparr>nodes = to_nat ` V\<^bsub>G\<^esub>, edges = to_nat ` E\<^bsub>G\<^esub>
  , source= \<lambda>e. to_nat (s\<^bsub>G\<^esub> (from_nat e)), target = \<lambda>e. to_nat (t\<^bsub>G\<^esub> (from_nat e))
  , node_label = \<lambda>v. l\<^bsub>G\<^esub> (from_nat v), edge_label = \<lambda>e. m\<^bsub>G\<^esub> (from_nat e)\<rparr>\<close>

definition from_ngraph :: " ('l,'m) ngraph \<Rightarrow> ('v::countable,'e :: countable,'l,'m) pre_graph" where
\<open>from_ngraph G \<equiv> \<lparr>nodes = from_nat ` V\<^bsub>G\<^esub>, edges = from_nat ` E\<^bsub>G\<^esub>
  , source = \<lambda>e. from_nat (s\<^bsub>G\<^esub> (to_nat e)), target = \<lambda>e. from_nat (t\<^bsub>G\<^esub> (to_nat e))
  , node_label = \<lambda>e. l\<^bsub>G\<^esub> (to_nat e), edge_label = \<lambda>e. m\<^bsub>G\<^esub> (to_nat e)\<rparr>\<close>

lemma ngraph_to_from[simp]:
  \<open>from_ngraph (to_ngraph G) = G\<close>
  by (simp add: from_ngraph_def to_ngraph_def from_nat_def)

lemma graph_ngraph_corres_iff:
  \<open>graph (to_ngraph G) \<longleftrightarrow> graph G \<close>
proof
  show \<open>graph (to_ngraph G)\<close> if \<open>graph G\<close>
  proof
    show \<open>finite V\<^bsub>to_ngraph G\<^esub>\<close>
      using graph.finite_nodes[OF \<open>graph G\<close>]
      by (simp add: to_ngraph_def)
  next
    show \<open>finite E\<^bsub>to_ngraph G\<^esub>\<close>
      using graph.finite_edges[OF \<open>graph G\<close>]
      by (simp add: to_ngraph_def)
  next
    show \<open>s\<^bsub>to_ngraph G\<^esub> e \<in> V\<^bsub>to_ngraph G\<^esub>\<close> if \<open>e \<in> E\<^bsub>to_ngraph G\<^esub>\<close> for e
      using graph.source_integrity[OF \<open>graph G\<close>] that
      by (auto simp add: to_ngraph_def)
  next
    show \<open>t\<^bsub>to_ngraph G\<^esub> e \<in> V\<^bsub>to_ngraph G\<^esub>\<close> if \<open>e \<in> E\<^bsub>to_ngraph G\<^esub>\<close> for e
      using graph.target_integrity[OF \<open>graph G\<close>] that
      by (auto simp add: to_ngraph_def)
  qed
next
  show \<open>graph G\<close> if \<open>graph (to_ngraph G)\<close>
  proof
    show \<open>finite V\<^bsub>G\<^esub>\<close>
      using graph.finite_nodes[OF \<open>graph (to_ngraph G)\<close>] that
      by (auto simp add: to_ngraph_def dest: finite_imageD)
  next
    show \<open>finite E\<^bsub>G\<^esub>\<close>
      using graph.finite_edges[OF \<open>graph (to_ngraph G)\<close>] that
      by (auto simp add: to_ngraph_def dest: finite_imageD)
  next
    show \<open>s\<^bsub>G\<^esub> e \<in> V\<^bsub>G\<^esub>\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
      using graph.source_integrity[OF \<open>graph (to_ngraph G)\<close>] that
      by (fastforce simp add: to_ngraph_def)
  next
    show \<open>t\<^bsub>G\<^esub> e \<in> V\<^bsub>G\<^esub>\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
      using graph.target_integrity[OF \<open>graph (to_ngraph G)\<close>] that
      by (fastforce simp add: to_ngraph_def)
  qed
qed
(*
lemma ngraph_subset_graph_iff:
  shows \<open>V\<^bsub>G\<^esub> \<subseteq> V\<^bsub>H\<^esub> \<longleftrightarrow> V\<^bsub>to_ngraph G\<^esub> \<subseteq> V\<^bsub>to_ngraph H\<^esub>\<close>
  sorry *)

type_synonym nmorph = "(nat,nat,nat,nat) pre_morph"

definition to_nmorph :: "('v\<^sub>1::countable,'v\<^sub>2::countable,'e\<^sub>1::countable,'e\<^sub>2::countable) pre_morph \<Rightarrow> nmorph" where
"to_nmorph m \<equiv> \<lparr>node_map = \<lambda>v. to_nat (\<^bsub>m\<^esub>\<^sub>V (from_nat v)), edge_map = \<lambda>e. to_nat (\<^bsub>m\<^esub>\<^sub>E (from_nat e))\<rparr>"

definition from_nmorph :: "nmorph \<Rightarrow> ('v\<^sub>1::countable,'v\<^sub>2::countable,'e\<^sub>1::countable,'e\<^sub>2::countable) pre_morph" where
"from_nmorph m \<equiv> \<lparr>node_map = \<lambda>v. from_nat (\<^bsub>m\<^esub>\<^sub>V (to_nat v)), edge_map = \<lambda>e. from_nat (\<^bsub>m\<^esub>\<^sub>E (to_nat e))\<rparr>"

lemma nmorph_to_from[simp]:
  \<open>from_nmorph (to_nmorph m) = m\<close>
  by (simp add: from_nmorph_def to_nmorph_def from_nat_def)

lemma to_nmorph_dist:
  \<open>to_nmorph (g \<circ>\<^sub>\<rightarrow> f) = to_nmorph g \<circ>\<^sub>\<rightarrow> to_nmorph f\<close>
  by (auto simp add: morph_comp_def to_nmorph_def)

definition to_nmorph2 :: "(nat,'v::countable,nat, 'e::countable) pre_morph \<Rightarrow> nmorph" where
"to_nmorph2 m \<equiv> \<lparr>node_map = \<lambda>v. to_nat (\<^bsub>m\<^esub>\<^sub>V v), edge_map = \<lambda>e. to_nat (\<^bsub>m\<^esub>\<^sub>E e)\<rparr>"

lemma morph_eq_nmorph2_iff: \<open>morphism G H u \<longleftrightarrow> morphism G (to_ngraph H) (to_nmorph2 u)\<close>
proof
  show \<open>morphism G (to_ngraph H) (to_nmorph2 u)\<close> if \<open>morphism G H u\<close>
  proof -
    interpret u: morphism G H u
      using that by assumption

    show ?thesis
    proof intro_locales
      show \<open>graph (to_ngraph H)\<close>
        by (simp add: graph_ngraph_corres_iff u.H.graph_axioms)
    next
      show \<open>morphism_axioms G (to_ngraph H) (to_nmorph2 u)\<close>
      proof
        show \<open>\<^bsub>to_nmorph2 u\<^esub>\<^sub>E e \<in> E\<^bsub>to_ngraph H\<^esub>\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          by (simp add: to_ngraph_def to_nmorph2_def that u.morph_edge_range)
      next
        show \<open>\<^bsub>to_nmorph2 u\<^esub>\<^sub>V v \<in> V\<^bsub>to_ngraph H\<^esub>\<close> if \<open>v \<in> V\<^bsub>G\<^esub>\<close> for v
          by (simp add: to_ngraph_def to_nmorph2_def that u.morph_node_range)
      next
        show \<open>\<^bsub>to_nmorph2 u\<^esub>\<^sub>V (s\<^bsub>G\<^esub> e) = s\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph2 u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          by (simp add: to_ngraph_def to_nmorph2_def that u.source_preserve)
      next
        show \<open>\<^bsub>to_nmorph2 u\<^esub>\<^sub>V (t\<^bsub>G\<^esub> e) = t\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph2 u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          by (simp add: to_ngraph_def to_nmorph2_def that u.target_preserve)
      next
        show \<open>l\<^bsub>G\<^esub> v = l\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph2 u\<^esub>\<^sub>V v)\<close> if \<open> v \<in> V\<^bsub>G\<^esub>\<close> for v
          by (simp add: to_ngraph_def to_nmorph2_def that u.label_preserve)
      next
        show \<open>m\<^bsub>G\<^esub> e = m\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph2 u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          by (simp add: to_ngraph_def to_nmorph2_def that u.mark_preserve)
      qed
    qed
  qed
next
  show \<open>morphism G H u\<close> if \<open>morphism G (to_ngraph H) (to_nmorph2 u)\<close>
  proof -
    interpret u: morphism G \<open>to_ngraph H\<close> \<open>to_nmorph2 u\<close>
      using that by assumption

    show ?thesis
    proof intro_locales
      show \<open>graph H\<close>
        using graph_ngraph_corres_iff u.H.graph_axioms
        by blast
    next
      show \<open>morphism_axioms G H u\<close>
      proof
        show \<open>\<^bsub>u\<^esub>\<^sub>E e \<in> E\<^bsub>H\<^esub>\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          using u.morph_edge_range
          by (simp add: to_ngraph_def to_nmorph2_def that image_iff)
      next
        show \<open>\<^bsub>u\<^esub>\<^sub>V v \<in> V\<^bsub>H\<^esub>\<close> if \<open>v \<in> V\<^bsub>G\<^esub>\<close> for v
          using u.morph_node_range
          by (simp add: to_ngraph_def to_nmorph2_def that image_iff)
      next
        show \<open>\<^bsub>u\<^esub>\<^sub>V (s\<^bsub>G\<^esub> e) = s\<^bsub>H\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          using u.source_preserve
          by (simp add: to_ngraph_def to_nmorph2_def that)
      next
        show \<open>\<^bsub>u\<^esub>\<^sub>V (t\<^bsub>G\<^esub> e) = t\<^bsub>H\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          using u.target_preserve
          by (simp add: to_ngraph_def to_nmorph2_def that)
      next
        show \<open>l\<^bsub>G\<^esub> v = l\<^bsub>H\<^esub> (\<^bsub>u\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>G\<^esub>\<close> for v
          by (simp add: to_ngraph_def to_nmorph2_def that u.label_preserve)
      next
        show \<open>m\<^bsub>G\<^esub> e = m\<^bsub>H\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
          by (simp add: to_ngraph_def to_nmorph2_def that u.mark_preserve)
      qed
    qed
  qed
qed

lemma
  morph_eq_nmorph_iff: \<open>morphism G H m \<longleftrightarrow> morphism (to_ngraph G) (to_ngraph H) (to_nmorph m)\<close>
proof
  show \<open>morphism (to_ngraph G) (to_ngraph H) (to_nmorph m)\<close> if asm: \<open>morphism G H m\<close>
  proof intro_locales
    show \<open>graph (to_ngraph G)\<close>
      using morphism.axioms(1)[OF that]
      by (auto iff: graph_ngraph_corres_iff[of G])
  next
    show \<open>graph (to_ngraph H)\<close>
      using morphism.axioms(2)[OF that]
      by (auto iff: graph_ngraph_corres_iff[of H])
  next
    show \<open>morphism_axioms (to_ngraph G) (to_ngraph H) (to_nmorph m)\<close>
    proof
      show \<open>\<^bsub>to_nmorph m\<^esub>\<^sub>E e \<in> E\<^bsub>to_ngraph H\<^esub>\<close> if \<open>e \<in> E\<^bsub>to_ngraph G\<^esub>\<close> for e
        using morphism.morph_edge_range[OF asm] that
        by (auto simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>\<^bsub>to_nmorph m\<^esub>\<^sub>V v \<in> V\<^bsub>to_ngraph H\<^esub>\<close> if \<open>v \<in> V\<^bsub>to_ngraph G\<^esub>\<close> for v
        using morphism.morph_node_range[OF asm] that
        by (auto simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>\<^bsub>to_nmorph m\<^esub>\<^sub>V (s\<^bsub>to_ngraph G\<^esub> e) = s\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph m\<^esub>\<^sub>E e)\<close>
        if \<open>e \<in> E\<^bsub>to_ngraph G\<^esub>\<close> for e
        using morphism.source_preserve[OF asm] that
        by (auto simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>\<^bsub>to_nmorph m\<^esub>\<^sub>V (t\<^bsub>to_ngraph G\<^esub> e) = t\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph m\<^esub>\<^sub>E e)\<close>
        if \<open>e \<in> E\<^bsub>to_ngraph G\<^esub>\<close> for e
        using morphism.target_preserve[OF asm] that
        by (auto simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>l\<^bsub>to_ngraph G\<^esub> v = l\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph m\<^esub>\<^sub>V v)\<close>
        if \<open>v \<in> V\<^bsub>to_ngraph G\<^esub>\<close> for v
        using morphism.label_preserve[OF asm] that
        by (auto simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>m\<^bsub>to_ngraph G\<^esub> e = m\<^bsub>to_ngraph H\<^esub> (\<^bsub>to_nmorph m\<^esub>\<^sub>E e)\<close>
        if \<open>e \<in> E\<^bsub>to_ngraph G\<^esub>\<close> for e
        using morphism.mark_preserve[OF asm] that
        by (auto simp add: to_ngraph_def to_nmorph_def)
    qed
  qed
next
  show \<open>morphism G H m\<close> if asm: \<open>morphism (to_ngraph G) (to_ngraph H) (to_nmorph m)\<close>
  proof intro_locales
    show \<open>graph G\<close>
      using morphism.axioms(1)[OF that]
      by (auto iff: graph_ngraph_corres_iff[of G])
  next
    show \<open>graph H\<close>
      using morphism.axioms(2)[OF that]
      by (auto iff: graph_ngraph_corres_iff[of H])
  next
    show \<open>morphism_axioms G H m\<close>
    proof
      show \<open>\<^bsub>m\<^esub>\<^sub>E e \<in> E\<^bsub>H\<^esub>\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
        using morphism.morph_edge_range[OF asm] that
        by (fastforce simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>\<^bsub>m\<^esub>\<^sub>V v \<in> V\<^bsub>H\<^esub>\<close> if \<open>v \<in> V\<^bsub>G\<^esub>\<close> for v
        using morphism.morph_node_range[OF asm] that
        by (fastforce simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>\<^bsub>m\<^esub>\<^sub>V (s\<^bsub>G\<^esub> e) = s\<^bsub>H\<^esub> (\<^bsub>m\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
        using morphism.source_preserve[OF asm] that
        by (fastforce simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>\<^bsub>m\<^esub>\<^sub>V (t\<^bsub>G\<^esub> e) = t\<^bsub>H\<^esub> (\<^bsub>m\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
        using morphism.target_preserve[OF asm] that
        by (fastforce simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>l\<^bsub>G\<^esub> v = l\<^bsub>H\<^esub> (\<^bsub>m\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>G\<^esub>\<close> for v
        using morphism.label_preserve[OF asm] that
        by (fastforce simp add: to_ngraph_def to_nmorph_def)
    next
      show \<open>m\<^bsub>G\<^esub> e = m\<^bsub>H\<^esub> (\<^bsub>m\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>G\<^esub>\<close> for e
        using morphism.mark_preserve[OF asm] that
        by (fastforce simp add: to_ngraph_def to_nmorph_def)
    qed
  qed
qed
(*
lemma blaa:
  \<open>\<^bsub>to_nmorph f\<^esub>\<^sub>V (to_nat x) \<in> V\<^bsub>to_ngraph G\<^esub> \<longleftrightarrow> \<^bsub>f\<^esub>\<^sub>V x \<in> V\<^bsub>G\<^esub>\<close>
  sorry

lemma blaa1:
  \<open>\<^bsub>to_nmorph f\<^esub>\<^sub>E (to_nat x) \<in> E\<^bsub>to_ngraph G\<^esub> \<longleftrightarrow> \<^bsub>f\<^esub>\<^sub>E x \<in> E\<^bsub>G\<^esub>\<close>
  sorry
 *)
lemma  morph_tong_tong_u_is_morph_tonm:
  assumes \<open>morphism (to_ngraph D) (to_ngraph D') u\<close>
  shows \<open>morphism D D' (from_nmorph u)\<close>
proof intro_locales
  show \<open>graph D\<close>
    using graph_ngraph_corres_iff morphism.axioms(1)[OF assms]
    by blast
next
  show \<open>graph D'\<close>
    using graph_ngraph_corres_iff morphism.axioms(2)[OF assms]
    by blast
next
  show \<open>morphism_axioms D D' (from_nmorph u)\<close>
    using assms
    by (auto simp add: morphism_axioms_def from_nmorph_def to_nmorph_def morphism_def to_ngraph_def from_ngraph_def)
qed

lemma comp_lift_node:
  \<open>(\<forall>v \<in> V\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>V v = \<^bsub>k \<circ>\<^sub>\<rightarrow> m\<^esub>\<^sub>V v) \<longleftrightarrow> (\<forall>v \<in> V\<^bsub>to_ngraph G\<^esub>. \<^bsub>(to_nmorph f) \<circ>\<^sub>\<rightarrow> (to_nmorph g)\<^esub>\<^sub>V v = \<^bsub>(to_nmorph k) \<circ>\<^sub>\<rightarrow> (to_nmorph m)\<^esub>\<^sub>V v)\<close>
proof
  show \<open>\<forall>v\<in>V\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>V v = \<^bsub>to_nmorph k \<circ>\<^sub>\<rightarrow> to_nmorph m\<^esub>\<^sub>V v\<close>
    if \<open>\<forall>v\<in>V\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>V v = \<^bsub>k \<circ>\<^sub>\<rightarrow> m\<^esub>\<^sub>V v\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
next
  show \<open>\<forall>v\<in>V\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>V v = \<^bsub>k \<circ>\<^sub>\<rightarrow> m\<^esub>\<^sub>V v\<close>
    if \<open>\<forall>v\<in>V\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>V v = \<^bsub>to_nmorph k \<circ>\<^sub>\<rightarrow> to_nmorph m\<^esub>\<^sub>V v\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
qed

lemma comp_lift_node1:
  \<open>(\<forall>v \<in> V\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>V v = \<^bsub>k\<^esub>\<^sub>V v) \<longleftrightarrow> (\<forall>v \<in> V\<^bsub>to_ngraph G\<^esub>. \<^bsub>(to_nmorph f) \<circ>\<^sub>\<rightarrow> (to_nmorph g)\<^esub>\<^sub>V v = \<^bsub>(to_nmorph k)\<^esub>\<^sub>V v)\<close>
proof
  show \<open>\<forall>v\<in>V\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>V v = \<^bsub>to_nmorph k\<^esub>\<^sub>V v\<close> if \<open>\<forall>v\<in>V\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>V v = \<^bsub>k\<^esub>\<^sub>V v\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
next
  show \<open>\<forall>v\<in>V\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>V v = \<^bsub>k\<^esub>\<^sub>V v \<close> if \<open>\<forall>v\<in>V\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>V v = \<^bsub>to_nmorph k\<^esub>\<^sub>V v\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
qed

lemma comp_lift_edge:
\<open>(\<forall>e \<in> E\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>E e = \<^bsub>k \<circ>\<^sub>\<rightarrow> m\<^esub>\<^sub>E e) \<longleftrightarrow> (\<forall>e \<in> E\<^bsub>to_ngraph G\<^esub>. \<^bsub>(to_nmorph f) \<circ>\<^sub>\<rightarrow> (to_nmorph g)\<^esub>\<^sub>E e = \<^bsub>(to_nmorph k) \<circ>\<^sub>\<rightarrow> (to_nmorph m)\<^esub>\<^sub>E e)\<close>
proof
  show \<open>\<forall>e\<in>E\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>E e = \<^bsub>to_nmorph k \<circ>\<^sub>\<rightarrow> to_nmorph m\<^esub>\<^sub>E e\<close>
    if \<open>\<forall>e\<in>E\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>E e = \<^bsub>k \<circ>\<^sub>\<rightarrow> m\<^esub>\<^sub>E e\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
next
  show \<open>\<forall>e\<in>E\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>E e = \<^bsub>k \<circ>\<^sub>\<rightarrow> m\<^esub>\<^sub>E e\<close>
    if \<open>\<forall>e\<in>E\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>E e = \<^bsub>to_nmorph k \<circ>\<^sub>\<rightarrow> to_nmorph m\<^esub>\<^sub>E e\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
qed

lemma comp_lift_edge1:
  \<open>(\<forall>e \<in> E\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>E e = \<^bsub>k\<^esub>\<^sub>E e) \<longleftrightarrow> (\<forall>e \<in> E\<^bsub>to_ngraph G\<^esub>. \<^bsub>(to_nmorph f) \<circ>\<^sub>\<rightarrow> (to_nmorph g)\<^esub>\<^sub>E e = \<^bsub>(to_nmorph k)\<^esub>\<^sub>E e)\<close>
proof
  show \<open> \<forall>e\<in>E\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>E e = \<^bsub>to_nmorph k\<^esub>\<^sub>E e\<close> if \<open>\<forall>e\<in>E\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>E e = \<^bsub>k\<^esub>\<^sub>E e\<close>
    using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
next
  show \<open>\<forall>e\<in>E\<^bsub>G\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> g\<^esub>\<^sub>E e = \<^bsub>k\<^esub>\<^sub>E e\<close> if \<open>\<forall>e\<in>E\<^bsub>to_ngraph G\<^esub>. \<^bsub>to_nmorph f \<circ>\<^sub>\<rightarrow> to_nmorph g\<^esub>\<^sub>E e = \<^bsub>to_nmorph k\<^esub>\<^sub>E e\<close>
using that
    unfolding morph_comp_def
    by (auto simp add: to_nmorph_def to_ngraph_def)
qed

definition lift_morph :: "nmorph \<Rightarrow> ('a::countable,nat,'b::countable,nat) pre_morph" where
"lift_morph f \<equiv> \<lparr>node_map = \<lambda>v. \<^bsub>f\<^esub>\<^sub>V (to_nat v), edge_map = \<lambda>e. \<^bsub>f\<^esub>\<^sub>E (to_nat e)\<rparr>"

end