(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
(*
A story of AutoCorres and recursion.

To do:
-- prove SIMPL total correctness
-- remove (* slow *) steps
-- remove word32 metis (or wait for word lifting...)
-- fix wp to support recursive fib'
-- Isar style proof?
*)

theory FibProof
imports
  "AutoCorres.AutoCorres"
begin

external_file "fib.c"

(*
 * The venerable Fibonacci function.
 *)
fun fibo :: "nat \<Rightarrow> nat" where
  "fibo 0 = 0" |
  "fibo (Suc 0) = Suc 0" |
  "fibo (Suc (Suc n)) = fibo n + fibo (Suc n)"
declare fibo.simps [simp del]

lemma fibo_alt_def: "fibo n = (if n = 0 then 0 else if n = 1 then 1 else fibo (n - 1) + fibo (n - 2))"
  apply (induct n rule: less_induct)
  apply (rename_tac n, case_tac n, simp add: fibo.simps)
  apply (rename_tac n1, case_tac n1, simp add: fibo.simps)
  apply (simp add: fibo.simps)
  done

lemma fibo_mono_Suc: "fibo n \<le> fibo (Suc n)"
  by (simp add: fibo_alt_def)
lemma fibo_mono: "a \<le> b \<Longrightarrow> fibo a \<le> fibo b"
  by (metis mono_iff_le_Suc mono_def fibo_mono_Suc)

lemma fibo_mono_strict: "n \<ge> 2 \<Longrightarrow> fibo n < fibo (Suc n)"
  apply (case_tac n, simp)
  apply (rename_tac n', subgoal_tac "fibo (Suc 0) \<le> fibo n'")
   apply (simp add: fibo.simps)
  apply (simp add: fibo_mono)
  done

lemma fiboI: "\<lbrakk> a + 1 = b; b + 1 = c \<rbrakk> \<Longrightarrow> fibo a + fibo b = fibo c"
  by (auto simp: fibo.simps)

(*
 * We write two versions in C, and compare correctness proofs on the
 * SIMPL and AutoCorres embeddings.
 *)

(*
 * C arithmetic is done using `unsigned', which is translated as `word32'.
 * So, it is much easier to prove that the C code implements this function,
 * which is not quite the same function as fibo.
 *)
function fibo32 :: "word32 \<Rightarrow> word32" where
  "fibo32 n = (if n = 0 then 0 else if n = 1 then 1 else fibo32 (n - 1) + fibo32 (n - 2))"
apply auto
done
termination fibo32
  by (relation "measure (\<lambda>x. unat x)", (simp|unat_arith)+)
declare fibo32.simps [simp del]

(*
 * But we really want to say that the C code does implement fibo
 * (at least up till 2971215073 < 2^32)...
 *)
lemma fibo_greater: "(6 + n) < fibo (6 + n)"
  apply (induct n)
   apply eval
  apply (subst add_Suc_right)+
  apply (subgoal_tac "Suc (6 + n) \<le> fibo (6 + n)")
   apply (subgoal_tac "fibo (6 + n) < fibo (Suc (6 + n))")
    apply simp
   apply (rule fibo_mono_strict)
   apply simp
  apply simp
  done
lemma fibo_greater': "n \<ge> 6 \<Longrightarrow> n < fibo n"
  by (metis le_iff_add fibo_greater)
lemma unat_word32_plus: "unat x + unat y < 2^32 \<Longrightarrow> unat x + unat y = unat (x + y :: word32)"
  by (metis len32 unat_of_nat_len word_arith_nat_add)

(* ... so we should say that too. *)
lemma fibo32_is_fibo: "fibo n < 2^32 \<Longrightarrow> fibo n = unat (fibo32 (of_nat n))"
  apply (induct n rule: less_induct)
  apply (subst fibo32.simps)
  apply (subst fibo_alt_def)
  apply (rename_tac n, case_tac "n = 0", simp)
  apply (case_tac "n = 1", simp)
  apply (subgoal_tac "n < 2^32"
                     "fibo (n - 1) + fibo (n - 2) < 2^32"
                     "of_nat n \<noteq> (0 :: word32)"
                     "of_nat n \<noteq> (1 :: word32)"
                     "fibo (n - 1) < 2^32"
                     "fibo (n - 2) < 2^32"
                     "fibo (n - 1) = unat (fibo32 (of_nat (n - 1)))"
                     "fibo (n - 2) = unat (fibo32 (of_nat (n - 2)))")
          apply (fastforce intro: unat_word32_plus)
         apply (metis diff_less gr0I zero_less_numeral)
        apply (metis diff_less gr0I zero_less_one)
       apply simp
      apply simp
     apply (metis len32 unat_1 unat_of_nat_len)
    apply (metis len32 unat_0 unat_of_nat_len)
   apply (metis fibo_alt_def)
  apply (case_tac "n < 6")
   apply simp
  apply (subgoal_tac "n < fibo n")
   apply simp
  apply (simp add: fibo_greater')
done

(* A helper for the SIMPL proofs later. *)
lemma fibo32_rec: "\<lbrakk> a < a + 2; b = a + 1; c = a + 2 \<rbrakk> \<Longrightarrow> fibo32 a + fibo32 b = fibo32 c"
  apply (subst(3) fibo32.simps)
  apply simp
  apply safe
     apply unat_arith
    apply (metis not_le overflow_plus_one_self word_n1_ge word_not_simps(1))
   apply (metis word_not_simps(1))
  apply (simp add: field_simps)
  done

(* First we invoke CParser to translate the C code to SIMPL. *)
install_C_file "fib.c"

context fib begin
(* fib_linear\<^bsub>C\<^esub> is the linear-time implementation. *)
thm fib_linear_body_def
(* fib\<^bsub>C\<^esub> is the pretty (inefficient) recursive implementation. *)
thm fib_body_def
(* First, let us prove that they implement fibo32. *)

(* First, the linear version. *)
lemma fib_linear_simpl_spec:
"\<Gamma> \<turnstile> {s. s = t}
     \<acute>ret__unsigned :== CALL fib_linear(\<acute>n)
     \<lbrace> (\<acute>ret__unsigned = fibo32 \<^bsup>t\<^esup>n) \<rbrace>"
  (* We have not annotated the code yet, so we cannot apply vcg usefully. *)
  (* First we expand the function call and defer the overall precondition. *)
  apply vcg_step
   defer
   (* Now we annotate the loop with the correct invariant and termination measure. *)
   apply (subst whileAnno_def)
   apply (subst whileAnno_def [symmetric,
     where I=" \<lbrace> \<acute>a = fibo32 (\<^bsup>t\<^esup>n - \<acute>n) \<and> \<acute>n \<le> \<^bsup>t\<^esup>n \<and> (\<acute>n \<noteq> 0 \<longrightarrow> (\<acute>b = fibo32 (\<^bsup>t\<^esup>n + 1 - \<acute>n))) \<rbrace>"
     and V="measure (\<lambda>s. unat (n_' s))"])
   apply vcg
  (* It is mostly word arithmetic from here on. *)
    apply (simp add: scast_def field_simps)
    apply clarsimp
    apply (case_tac "n = 0")
     apply clarsimp
    apply (case_tac "n = 1")
     apply (rename_tac n1, subgoal_tac "n1 = 1")
      apply simp
     apply unat_arith
    apply (rename_tac n1, case_tac "n1 = 1")
     apply simp
    apply clarsimp
    apply safe
       apply (metis linear word_must_wrap)
      apply (rule fibo32_rec)
        (* unat_arith is too slow for this subgoal *)
        apply (subst word_less_nowrapI'[where k = 2 and z = "-1"])
           apply (subgoal_tac "n1 \<ge> 2")
            apply (metis word_n1_ge word_sub_le_iff word_sub_mono)
           apply unat_arith
          apply simp
         apply simp
        apply simp
       apply (simp add: field_simps)+
   apply (simp add: fibo32.simps)
  apply (simp add: scast_def fibo32.simps)
done

(* And the recursive version. *)
thm fib_body_def

lemma fib_simpl_spec: "\<forall>n. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<lbrace>\<acute>n=n\<rbrace>  PROC fib(\<acute>n,\<acute>ret__unsigned) \<lbrace>\<acute>ret__unsigned = fibo32 n\<rbrace>"
  apply (hoare_rule HoareTotal.ProcRec1[where r = "measure (\<lambda>(s, d). unat \<^bsup>s\<^esup>n)"])
  apply (unfold creturn_def | vcg_step)+
  apply (subst fibo32.simps, simp)
  apply (subst fibo32.simps, simp)
  apply (subst fibo32.simps[where n = n])
  apply unat_arith
  done

(*
 * We need to temporarily leave the local context to run autocorres.
 * Normally, we would run autocorres immediately after install_C_file.
 *)
end (* context fib *)

autocorres [unsigned_word_abs = fib_linear] "fib.c"

context fib begin

thm fib_linear'_def
thm fib'.simps fib'.simps[unfolded fun_app_def, folded One_nat_def]
thm call_fib'_def call_fib'_def[simplified]

(*
 * fib_linear\<^bsub>C\<^esub> has been lifted to fib_linear', using the option monad.
 * The option monad expresses programs that read the heap
 * and may fail. fib_linear\<^bsub>C\<^esub> does not read the heap, but its loop
 * might fail to terminate, so it cannot be a simple HOL function.
 *
 * Note that arithmetic in fib_linear' has been converted to type @{typ nat}.
 * This conversion is enabled by the word_abs option.
 * fib_linear' still matches the C code as long as calculations do not wrap around;
 * AutoCorres inserts an extra guard to ensure this.
 *)

thm fib_linear'_def

(* Here we prove that fib_linear' implements fibo, assuming that
 * no calculations wrap around. *)
lemma fib_linear'_correct: "ovalid (\<lambda>_. True) (fib_linear' n) (\<lambda>r s. r = fibo n)"
  unfolding fib_linear'_def
  (* The loop invariant, as before. *)
  apply (subst owhile_add_inv
    [where I = "\<lambda>(a, b, i) s. i \<le> n \<and> a = fibo (n - i) \<and> (i \<noteq> 0 \<longrightarrow> (b = fibo (n - i + 1)))"])
  apply wp
     apply safe
        (* Again, we prove largely arithmetical facts. However, these
         * proofs are easier because we are using the @{typ nat} type. *)
        apply (fastforce intro: arg_cong[where f = fibo])
       apply (simp add: Suc_diff_le)
      apply (fastforce intro: fiboI simp: field_simps)
     apply simp
    apply (rename_tac b s, case_tac b, simp, simp)
   apply (simp_all add: fibo.simps)
  done

(* Here we prove that fib_linear' terminates, and calculations do not overflow
 * for Fibonacci numbers below UINT_MAX.
 * This involves proving something similar to fibo32_is_fibo, so we
 * do not need that theorem to interpret this one.
 *
 * NB: Because the variable b is ahead of the Fibonacci number
 *     being calculated, we need to consider integer wraparound for
 *     fibo (Suc n) instead of fibo n. *)
lemma fib_linear'_term: "no_ofail (\<lambda>_. fibo (Suc n) < UINT_MAX) (fib_linear' n)"
  (* We would like to use the wp tactic, so we will translate our goal into
     ovalidNF form. *)
  unfolding fib_linear'_def no_ofail_is_ovalidNF
  apply (subst owhile_add_inv
    [where I = "\<lambda>(a, b, i) s. i \<le> n \<and> a = fibo (n - i) \<and> b = fibo (n - i + 1) \<and> fibo (Suc n) \<le> UINT_MAX"
       and M = "\<lambda>(_, _, i) _. i"])
  apply wp
     apply safe
         apply (fastforce intro: le_trans[rotated] add_le_mono simp: fibo_alt_def[where n = "Suc n"] fibo_mono)
        apply arith
       apply (simp add: field_simps Suc_diff_le)
      apply (fastforce intro: fiboI simp: field_simps)
     apply wp
     apply simp
    apply (simp_all add: fibo.simps)
  done

(* And we are done. *)
lemma fib_linear'_proof: "ovalidNF (\<lambda>_. fibo (Suc n) < UINT_MAX) (fib_linear' n) (\<lambda>r _. r = fibo n)"
  by (metis ovalidNF_combine ovalid_pre_imp fib_linear'_correct fib_linear'_term)

(* WIP: convert and prove in nondet_monad *)

(* First, set up the conversion... *)
lemma validE_NF_validNF: "validE_NF P (liftE f) Q (K (K False)) \<Longrightarrow> validNF P f Q"
  unfolding validE_NF_def validE_def validNF_def valid_def no_fail_def liftE_def K_def
  apply monad_eq
  apply fastforce
  done

lemma [ts_rule option unlift]: "oreturn a = ogets (\<lambda>_. a)"
  by (simp add: oreturn_def ogets_def)

declare liftE_liftE[symmetric, ts_rule option unlift]

lemma gets_theE_split[ts_rule option unlift]:
  "gets_theE (case p of (x, y) \<Rightarrow> f x y) = (case p of (x, y) \<Rightarrow> gets_theE (f x y))"
  apply (simp split: prod.splits)
  done

declare gets_theE_L2_while[symmetric, where n = "[]", ts_rule option unlift]
declare K_bind_def[ts_rule option unlift]

lemma nondet_fib_linear'_proof: "\<lbrace> \<lambda>s. fibo (Suc n) \<le> UINT_MAX \<and> P s \<rbrace> gets_the (fib_linear' n) \<lbrace> \<lambda>r s. r = fibo n \<and> P s \<rbrace>!"
  unfolding fib_linear'_def
  apply (rule validE_NF_validNF)
  apply (subst fun_cong[OF gets_theE_def[symmetric, THEN meta_eq_to_obj_eq]])
  (* Then it works! *)
  apply (monad_convert nondet "gets_theE _")

  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', b', n') s. a' = fibo (n - n') \<and> n' \<le> n \<and> (n' \<noteq> 0 \<longrightarrow> (b' = fibo (n - n' + 1))) \<and> fibo (Suc n) \<le> UINT_MAX \<and> P s"
       and M="\<lambda>((_, _, n'), _). n'"])
  apply wp
    apply safe
           apply (fastforce intro: arg_cong[where f = fibo])
          apply arith
         apply (fastforce intro: fiboI simp: field_simps)
        apply simp
       apply (fastforce intro: le_trans[rotated] simp: fiboI field_simps fibo_mono)
      apply simp
     apply simp
    apply (simp_all add: UINT_MAX_def fibo.simps)
  done

(*
 * Now for the recursive function fib\<^bsub>C\<^esub>.
 * The lifted function fib' is a recursive function in HOL, but all HOL functions
 * must be well-founded (ie. terminate) and AutoCorres cannot prove this.
 * Instead, fib' gets an extra parameter called “measure”, which limits the
 * recursion depth. With this recursion limit, it is obvious that
 * fib' terminates, so fib' can be defined as a HOL function.
 *)
thm fib'.simps (* Just a reminder *)
(*
 * Like fib_linear\<^bsub>C\<^esub>, fib\<^bsub>C\<^esub> is lifted to the option monad. If the measure parameter
 * is too small, fib' will fail instead of giving the result that would be
 * returned by fib\<^bsub>C\<^esub>.
 *)

(*
 * AutoCorres also generates a \<^bitalic>measure function\<^eitalic> for fib'. This function is
 * used to generate the measure parameter anywhere fib' is called. For example,
 *
 *   void call_fib(void) { fib(42); }
 *
 * is translated to:
 *)
thm call_fib'_def
(*
 * The measure function receives all of the information needed, in principle,
 * to determine an upper bound on the call depth (if there is one).
 * Namely, the function arguments and the global program state.
 *)
term measure_of'_fib
(*
 * measure_of'_fib does not actually have a definition, yet.
 * To give it a sensible definition, we need to work out the maximum
 * recursion depth, and AutoCorres does not know how to do that.
 * We will manually define the function later.
 *)

(*
 * But first, let us prove the correctness of fib'.
 * Again, we prove partial correctness separately, assuming that fib'
 * does not return None.
 *)

lemma fib'_correct_rec_helper:
  assumes ind: "\<And>y P m. ovalid (\<lambda>_. y < x \<and> P (fibo32 y)) (fib' m y) (\<lambda>r _. P r)"
  shows "ovalid (\<lambda>_. P (fibo32 x)) (fib' m x) (\<lambda>r _. P r)"
  apply (subst fib'.simps)
  apply (clarsimp simp: unat_eq_of_nat)
  apply (wp ind)
  apply (clarsimp simp: split: if_split_asm)
  apply safe
      apply (subst (asm) fibo32.simps, simp)
     apply (subst (asm) fibo32.simps, simp)
    apply unat_arith
   apply unat_arith
  apply (subst (asm) fibo32.simps, simp)
  done

lemma fib'_correct: "ovalid P (fib' m n) (\<lambda>r s. P s \<and> r = fibo32 n)"
  apply (subgoal_tac "\<And>P. ovalid (\<lambda>_. P (fibo32 n)) (fib' m n) (\<lambda>r _. P r)")
   apply (unfold ovalid_def, fast)[1]
  apply (induct n arbitrary: P m rule: less_induct)
  apply (subgoal_tac "\<And>y P m. ovalid (\<lambda>_. y < x \<and> P (fibo32 y)) (fib' m y) (\<lambda>r _. P r)")
   apply (rule fib'_correct_rec_helper)
   apply (unfold ovalid_def, fast)[1]
  apply (unfold ovalid_def)
  apply blast
  done

lemma fib'_term_rec_helper:
  assumes ind: "\<And>y P rec_measure'. ovalidNF (\<lambda>_. y < x \<and> unat y < rec_measure' \<and> P) (fib' rec_measure' y) (\<lambda>_ _. P)"
  shows "ovalidNF (\<lambda>_. unat x < rec_measure') (fib' rec_measure' x) (\<lambda>_ _. True)"
  apply (subst fib'.simps)
  apply (wp ind)
  apply simp
  apply unat_arith (* slow *)
  done

lemma fib'_term: "no_ofail (\<lambda>_. rec_measure' > unat n) (fib' rec_measure' n)"
  apply (subst no_ofail_is_ovalidNF)
  apply (induct n arbitrary: rec_measure' rule: less_induct)
  apply (subgoal_tac "\<And>y P rec_measure'. ovalidNF (\<lambda>_. y < x \<and> unat y < rec_measure' \<and> P) (fib' rec_measure' y) (\<lambda>_ _. P)")
  apply (rule fib'_term_rec_helper, assumption)
  apply (metis (full_types) ovalidNF_assume_pre)
  done

(* The overall correctness proof. *)
lemma fib'_spec: "ovalidNF (\<lambda>s. P s \<and> m > unat n) (fib' m n) (\<lambda>r s. P s \<and> r = fibo32 n)"
  apply (rule ovalidNF_combine)
  apply (wp fib'_correct, simp)
  apply (wp fib'_term, simp)
  done

(*
If fib\<^bsub>C\<^esub> was lifted to the state monad...
Once we get hoare triples and wp reasoning on the option monad,
the proof might also look like this.

(* isar proof lets us rewrite the inductive assumption r and pass it to wp *)
lemma fib2'_correct: "\<lbrace> \<lambda>_. P (fibo32 n) \<rbrace> fib2' m n \<lbrace> \<lambda>r s. P r \<rbrace>"
proof (induct n arbitrary: P m rule: less_induct)
   fix x P m
   assume r: "\<And>y P m. y < x \<Longrightarrow> \<lbrace>  \<lambda>_. P (fibo32 y) \<rbrace> fib2' m y \<lbrace> \<lambda>r s. P r \<rbrace>"

   have r': "\<And>y P m. \<lbrace>  \<lambda>_. y < x \<and> P (fibo32 y) \<rbrace> fib2' m y \<lbrace> \<lambda>r s. P r \<rbrace>"
    apply (rule hoare_assume_pre)
    apply clarsimp
    apply (insert r)
    apply (clarsimp simp: valid_def)
    done

   show "\<lbrace> \<lambda>_. P (fibo32 x) \<rbrace> fib2' m x \<lbrace> \<lambda>r s. P r \<rbrace>"
     apply (subst fib2'.simps)
     apply (wp r')
    apply auto
    apply (simp_all add: fibo32.simps)
    apply unat_arith+
    done
qed
*)

(* Finally, we can show that anyone who calls fib' will get the correct result. *)
lemma fib'_call:
  "fib' (unat n + 1) n s = Some (fibo32 n)"
  using fib'_spec[unfolded ovalidNF_def]
  apply fastforce
  done

lemma "\<lbrace> P \<rbrace> call_fib' \<lbrace> \<lambda>_. P \<rbrace>!"
  including nf_no_pre
  apply (unfold call_fib'_def)
  apply wp
   apply (blast intro: fib'_call)
  apply (force simp: fib'_mono option_monad_mono_eq)
  done

end (* context fib *)

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Algebra\<close>
theory Nat_Algebra
imports
  Monoids
  Nat_Add
  Nat_Sub
  Nat_Mul
  Nat_Inequalities
begin

(*TODO: multiple notations are unbundled here; this is not optimal*)
unbundle no_isa_set_add_implicit_syntax no_isa_set_mul_implicit_syntax
  no_isa_set_zero_implicit_syntax no_isa_set_one_implicit_syntax

subsubsection \<open>Algebraic Structures\<close>

definition "nat_Monoid \<equiv> object {\<langle>@zero, 0\<rangle>, \<langle>@add, \<lambda>m n \<in> \<nat>. nat_add m n\<rangle>}"

bundle isa_set_nat_Monoid_syntax
begin notation nat_Monoid ("'(\<nat>, +')") end
bundle no_isa_set_nat_Monoid_syntax
begin no_notation nat_Monoid ("'(\<nat>, +')") end

unbundle isa_set_nat_Monoid_syntax

(*TODO: The following should be automatically generated*)
lemma nat_Monoid_simps [simp]:
  "(\<nat>, +) @@ zero = 0"
  "(\<nat>, +) @@ add = \<lambda>x y \<in> \<nat>. nat_add x y"
  unfolding nat_Monoid_def by simp_all

lemma nat_Monoid: "(\<nat>, +) : Monoid Nat"
proof (rule MonoidI)
  show "(\<nat>, +) : Zero Nat" by (rule ZeroI) simp
  show "(\<nat>, +) : Add Nat"
  (*TODO: object selector simplifier not working properly*)
  (* unfolding nat_Monoid_def by (rule AddI) simp *)
  proof (rule AddI)
    have select_add_eq: "(\<nat>, +)@@add = \<lambda>m n \<in> \<nat>. nat_add m n" by simp
    have "(\<nat>, +)@@add : Nat \<rightarrow>cs Nat \<rightarrow>cs Nat"
      by (subst select_add_eq) discharge_types
    then show "(\<nat>, +)@@add : Nat \<rightarrow>s Nat \<rightarrow>s Nat"
      using Dep_Function_covariant_codom by auto
  qed
next
  fix x assume "x : Nat"
  show "add (\<nat>, +) (zero (\<nat>, +)) x = x" and "add (\<nat>, +) x (zero (\<nat>, +)) = x"
    \<comment>\<open>Very low-level; lots of unfolding.\<close>
    unfolding add_def zero_def by auto

  fix y z assume "y : Nat" "z : Nat"
  show "add (\<nat>, +) (add (\<nat>, +) x y) z = add (\<nat>, +) x (add (\<nat>, +) y z)"
    unfolding add_def by (simp add: Nat_add_assoc)
qed

definition "nat_Mul_Monoid \<equiv> object {\<langle>@one, 1\<rangle>, \<langle>@mul, \<lambda>m n \<in> \<nat>. nat_mul m n\<rangle>}"

bundle isa_set_nat_Mul_Monoid_syntax
begin notation nat_Mul_Monoid ("'(\<nat>, *')") end
bundle no_isa_set_nat_Mul_Monoid_syntax
begin no_notation nat_Mul_Monoid ("'(\<nat>, *')") end

unbundle isa_set_nat_Mul_Monoid_syntax

lemma nat_Mul_Monoid: "(\<nat>, *) : Mul_Monoid Nat"
proof (rule Mul_MonoidI)
  show "(\<nat>, *) : One Nat"
    by (rule OneI) (simp add: nat_Mul_Monoid_def)
  show "(\<nat>, *) : Mul Nat"
  (*TODO: object selector simplifier not working properly*)
  (* unfolding nat_Monoid_def by (rule AddI) simp *)
  proof (rule MulI)
    have select_mul_eq: "(\<nat>, *)@@mul = \<lambda>m n \<in> \<nat>. nat_mul m n"
      unfolding nat_Mul_Monoid_def by simp
    have "(\<nat>, *)@@mul : Nat \<rightarrow>cs Nat \<rightarrow>cs Nat"
      by (subst select_mul_eq) discharge_types
    show "(\<nat>, *)@@mul : Nat \<rightarrow>s Nat \<rightarrow>s Nat"
      using Dep_Function_covariant_codom by auto
  qed
next
  fix x assume "x : Nat"
  show "mul (\<nat>, *) (one (\<nat>, *)) x = x" and "mul (\<nat>, *) x (one (\<nat>, *)) = x"
    unfolding nat_Mul_Monoid_def mul_def one_def by auto

  fix y z assume "y : Nat" "z : Nat"
  show "mul (\<nat>, *) (mul (\<nat>, *) x y) z = mul (\<nat>, *) x (mul (\<nat>, *) y z)"
    unfolding nat_Mul_Monoid_def mul_def by (simp add: Nat_mul_assoc)
qed

end


section "Skew Heap"

theory Skew_Heap
imports
  "HOL-Library.Tree_Multiset"
  "HOL-Library.Pattern_Aliases"
  "HOL-Data_Structures.Heaps"
begin

unbundle pattern_aliases

text\<open>Skew heaps~\<^cite>\<open>"SleatorT-SIAM86"\<close> are possibly the simplest functional
priority queues that have logarithmic (albeit amortized) complexity.

The implementation below could be generalized to separate the elements from
their priorities.\<close>

subsection "Merge"

function merge :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"merge Leaf t = t" |
"merge t Leaf = t" |
"merge (Node l1 a1 r1 =: t1) (Node l2 a2 r2 =: t2) =
   (if a1 \<le> a2 then Node (merge t2 r1) a1 l1
    else Node (merge t1 r2) a2 l2)"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

lemma merge_code: "merge t1 t2 =
  (case t1 of
   Leaf \<Rightarrow> t2 |
   Node l1 a1 r1 \<Rightarrow> (case t2 of
     Leaf \<Rightarrow> t1 |
     Node l2 a2 r2 \<Rightarrow>
       (if a1 \<le> a2
        then Node (merge t2 r1) a1 l1
        else Node (merge t1 r2) a2 l2)))"
by(auto split: tree.split)

text\<open>An alternative version that always walks to the Leaf of both heaps:\<close>
function merge2 :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"merge2 Leaf Leaf = Leaf" |
"merge2 Leaf (Node l2 a2 r2) = Node (merge2 r2 Leaf) a2 l2" |
"merge2 (Node l1 a1 r1) Leaf = Node (merge2 r1 Leaf) a1 l1" |
"merge2 (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2
    then Node (merge2 (Node l2 a2 r2) r1) a1 l1
    else Node (merge2 (Node l1 a1 r1) r2) a2 l2)"
by pat_completeness auto
termination
by (relation "measure (\<lambda>(x, y). size x + size y)") auto

lemma size_merge: "size(merge t1 t2) = size t1 + size t2"
by(induction t1 t2 rule: merge.induct) auto

lemma size_merge2: "size(merge2 t1 t2) = size t1 + size t2"
by(induction t1 t2 rule: merge2.induct) auto

lemma mset_merge: "mset_tree (merge t1 t2) = mset_tree t1 + mset_tree t2"
by (induction t1 t2 rule: merge.induct) (auto simp add: ac_simps)

lemma set_merge: "set_tree (merge t1 t2) = set_tree t1 \<union> set_tree t2"
by (metis mset_merge set_mset_tree set_mset_union)

lemma heap_merge:
  "\<lbrakk> heap t1;  heap t2 \<rbrakk> \<Longrightarrow> heap (merge t1 t2)"
by (induction t1 t2 rule: merge.induct)(auto simp: ball_Un set_merge)

interpretation skew_heap: Heap_Merge
where merge = merge
proof(standard, goal_cases)
  case 1 thus ?case by(simp add: mset_merge)
next
  case 2 thus ?case by(simp add: heap_merge)
qed

end


theory Chapter10_3_Evaluation
imports Chapter10_2_Typechecking
begin

primrec is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val Zero = True"
    | "is_val (Suc e) = is_val e"
    | "is_val (Rec et e0 es) = False"
    | "is_val (Lam t e) = True"
    | "is_val (Appl e1 e2) = False"
    | "is_val Triv = True"
    | "is_val (Pair e1 e2) = (is_val e1 & is_val e2)"
    | "is_val (ProjL e) = False"
    | "is_val (ProjR e) = False"

inductive eval :: "expr => expr => bool"
where eval_suc [simp]: "eval e e' ==> eval (Suc e) (Suc e')"
    | eval_rec_1 [simp]: "eval et et' ==> eval (Rec et e0 es) (Rec et' e0 es)"
    | eval_rec_2 [simp]: "eval (Rec Zero e0 es) e0"
    | eval_rec_3 [simp]: "is_val et ==>
            eval (Rec (Suc et) e0 es) (subst (Rec et e0 es) first (subst et first es))"
    | eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Appl e1 e2) (Appl e1 e2')"
    | eval_appl_3 [simp]: "is_val e2 ==> eval (Appl (Lam t2 e1) e2) (subst e2 first e1)"
    | eval_pair_1 [simp]: "eval e1 e1' ==> eval (Pair e1 e2) (Pair e1' e2)"
    | eval_pair_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Pair e1 e2) (Pair e1 e2')"
    | eval_projl_1 [simp]: "eval e e' ==> eval (ProjL e) (ProjL e')"
    | eval_projl_2 [simp]: "eval (ProjL (Pair e1 e2)) e1"
    | eval_projr_1 [simp]: "eval e e' ==> eval (ProjR e) (ProjR e')"
    | eval_projr_2 [simp]: "eval (ProjR (Pair e1 e2)) e2"

lemma canonical_nat: "is_val e ==> typecheck gam e Nat ==>
          e = Zero | (EX e'. e = Suc e' & typecheck gam e' Nat)"
by (induction e, auto)

lemma canonical_nat_no_vars: "is_val e ==> typecheck gam e Nat ==> typecheck gam' e Nat"
by (induction e, auto)

lemma canonical_arrow: "is_val e ==> typecheck gam e (Arrow t1 t2) ==>
              EX e'. e = Lam t1 e' & typecheck (extend gam t1) e' t2"
by (induction e, auto)

lemma canonical_unit: "is_val e ==> typecheck gam e Unit ==> e = Triv"
by (induction e, auto)

lemma canonical_prod: "is_val e ==> typecheck gam e (Prod t1 t2) ==>
              EX e1 e2. e = Pair e1 e2 & typecheck gam e1 t1 & typecheck gam e2 t2"
by (induction e, auto)

theorem preservation: "eval e e' ==> typecheck gam e t ==> typecheck gam e' t"
proof (induction e e' arbitrary: t rule: eval.induct)
case eval_suc
  thus ?case by fastforce
next case eval_rec_1
  thus ?case by fastforce
next case eval_rec_2
  thus ?case by fastforce
next case (eval_rec_3 et e0 es)
  from eval_rec_3 canonical_nat_no_vars have "typecheck (extend gam t) (subst et first es) t" by auto
  with eval_rec_3 show ?case by fastforce
next case eval_appl_1
  thus ?case by fastforce
next case eval_appl_2
  thus ?case by fastforce
next case eval_appl_3
  thus ?case by fastforce
next case eval_pair_1
  thus ?case by fastforce
next case eval_pair_2
  thus ?case by fastforce
next case eval_projl_1
  thus ?case by fastforce
next case eval_projl_2
  thus ?case by fastforce
next case eval_projr_1
  thus ?case by fastforce
next case eval_projr_2
  thus ?case by fastforce
qed

theorem progress: "typecheck gam e t ==> gam = empty_env ==> is_val e | (EX e'. eval e e')"
proof (induction gam e t rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by (metis eval_suc is_val.simps(3))
next case tc_rec
  thus ?case by (metis eval_rec_1 eval_rec_2 eval_rec_3 is_val.simps(3) canonical_nat)
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by (metis eval_appl_1 eval_appl_2 eval_appl_3 canonical_arrow)
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by (metis eval_pair_1 eval_pair_2 is_val.simps(8))
next case tc_projl
  thus ?case by (metis eval_projl_1 eval_projl_2 canonical_prod)
next case tc_projr
  thus ?case by (metis eval_projr_1 eval_projr_2 canonical_prod)
qed

end


(* Title:  Arc_Walk.thy
   Author: Lars Noschinski, TU München
*)

theory Arc_Walk
imports
  Digraph
begin

section {* Arc Walks *}

text {*
  We represent a walk in a graph by the list of its arcs.
*}

type_synonym 'b awalk = "'b list"

context pre_digraph begin

text {*
  The list of vertices of a walk. The additional vertex
  argument is there to deal with the case of empty walks.
*}
primrec awalk_verts :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a list" where
    "awalk_verts u [] = [u]"
  | "awalk_verts u (e # es) = tail G e # awalk_verts (head G e) es"

abbreviation awhd :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a" where
  "awhd u p \<equiv> hd (awalk_verts u p)"

abbreviation awlast:: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a" where
  "awlast u p \<equiv> last (awalk_verts u p)"

text {*
  Tests whether a list of arcs is a consistent arc sequence,
  i.e. a list of arcs, where the head G node of each arc is
  the tail G node of the following arc.
*}
fun cas :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "cas u [] v = (u = v)" |
  "cas u (e # es) v = (tail G e = u \<and> cas (head G e) es v)"

lemma cas_simp:
  assumes "es \<noteq> []"
  shows "cas u es v \<longleftrightarrow> tail G (hd es) = u \<and> cas (head G (hd es)) (tl es) v"
using assms by (cases es) auto

definition awalk :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "awalk u p v \<equiv> u \<in> verts G \<and> set p \<subseteq> arcs G \<and> cas u p v"

(* XXX: rename to atrail? *)
definition (in pre_digraph) trail :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "trail u p v \<equiv> awalk u p v \<and> distinct p"

definition apath :: "'a \<Rightarrow>'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
  "apath u p v \<equiv> awalk u p v \<and> distinct (awalk_verts u p)"

end

subsection {* Basic Lemmas *}

lemma (in pre_digraph) awalk_verts_conv:
  "awalk_verts u p = (if p = [] then [u] else map (tail G) p @ [head G (last p)])"
by (induct p arbitrary: u) auto

lemma (in pre_digraph) length_awalk_verts:
  "length (awalk_verts u p) = Suc (length p)"
by (simp add: awalk_verts_conv)

lemma (in pre_digraph) awalk_verts_ne_eq:
  assumes "p \<noteq> []"
  shows "awalk_verts u p = awalk_verts v p"
using assms by (auto simp: awalk_verts_conv)

lemma (in pre_digraph) awalk_verts_non_Nil[simp]:
  "awalk_verts u p \<noteq> []"
by (simp add: awalk_verts_conv)

context wf_digraph begin

lemma
  assumes "cas u p v"
  shows awhd_if_cas: "awhd u p = u" and awlast_if_cas: "awlast u p = v"
  using assms by (induct p arbitrary: u) auto

lemma awalk_verts_in_verts:
  assumes "u \<in> verts G" "set p \<subseteq> arcs G" "v \<in> set (awalk_verts u p)"
  shows "v \<in> verts G"
  using assms by (induct p arbitrary: u) (auto intro: wellformed)

lemma
  assumes "u \<in> verts G" "set p \<subseteq> arcs G"
  shows awhd_in_verts: "awhd u p \<in> verts G"
    and awlast_in_verts: "awlast u p \<in> verts G"
using assms by (auto elim: awalk_verts_in_verts)

lemma awalk_conv:
  "awalk u p v = (set (awalk_verts u p) \<subseteq> verts G
    \<and> set p \<subseteq> arcs G
    \<and> awhd u p = u \<and> awlast u p = v \<and> cas u p v)"
unfolding awalk_def using hd_in_set[OF awalk_verts_non_Nil, of u p]
by (auto intro: awalk_verts_in_verts awhd_if_cas awlast_if_cas simp del: hd_in_set)

lemma awalkI:
  assumes "set (awalk_verts u p) \<subseteq> verts G" "set p \<subseteq> arcs G" "cas u p v"
  shows "awalk u p v"
  using assms by (auto simp: awalk_conv awhd_if_cas awlast_if_cas)

lemma awalkE[elim]:
  assumes "awalk u p v"
  obtains "set (awalk_verts u p) \<subseteq> verts G" "set p \<subseteq> arcs G" "cas u p v"
    "awhd u p = u" "awlast u p = v"
using assms by (auto simp add: awalk_conv)

lemma awalk_Nil_iff:
  "awalk u [] v \<longleftrightarrow> u = v \<and> u \<in> verts G"
unfolding awalk_def by auto

lemma trail_Nil_iff:
  "trail u [] v \<longleftrightarrow> u = v \<and> u \<in> verts G"
  by (auto simp: trail_def awalk_Nil_iff)

lemma apath_Nil_iff: "apath u [] v \<longleftrightarrow> u = v \<and> u \<in> verts G"
  by (auto simp: apath_def awalk_Nil_iff)

lemma awalk_hd_in_verts: "awalk u p v \<Longrightarrow> u \<in> verts G"
  by (cases p) auto

lemma awalk_last_in_verts: "awalk u p v \<Longrightarrow> v \<in> verts G"
  unfolding awalk_conv by auto

lemma hd_in_awalk_verts:
  "awalk u p v \<Longrightarrow> u \<in> set (awalk_verts u p)"
  "apath u p v \<Longrightarrow> u \<in> set (awalk_verts u p)"
  by (case_tac [!]p) (auto simp: apath_def)

lemma awalk_Cons_iff:
  "awalk u (e # es) w \<longleftrightarrow> e \<in> arcs G \<and> u = tail G e \<and> awalk (head G e) es w"
  by (auto simp: awalk_def)

lemma trail_Cons_iff:
  "trail u (e # es ) w \<longleftrightarrow> e \<in> arcs G \<and> u = tail G e \<and> e \<notin> set es \<and> trail (head G e) es w"
  by (auto simp: trail_def awalk_Cons_iff)

lemma apath_Cons_iff:
  "apath u (e # es) w \<longleftrightarrow> e \<in> arcs G \<and> tail G e = u \<and> apath (head G e) es w
    \<and> tail G e \<notin> set (awalk_verts (head G e) es)" (is "?L \<longleftrightarrow> ?R")
by (auto simp: apath_def awalk_Cons_iff)

lemmas awalk_simps = awalk_Nil_iff awalk_Cons_iff
lemmas trail_simps = trail_Nil_iff trail_Cons_iff
lemmas apath_simps = apath_Nil_iff apath_Cons_iff

lemma arc_implies_awalk:
  "e \<in> arcs G \<Longrightarrow> awalk (tail G e) [e] (head G e)"
by (simp add: awalk_simps)

lemma apath_nonempty_ends:
  assumes "apath u p v"
  assumes "p \<noteq> []"
  shows "u \<noteq> v"
using assms
proof (induct p arbitrary: u)
  case (Cons e es)
  then have "apath (head G e) es v" "u \<notin> set (awalk_verts (head G e) es)"
    by (auto simp: apath_Cons_iff)
  moreover then have "v \<in> set (awalk_verts (head G e) es)" by (auto simp: apath_def)
  ultimately show "u \<noteq> v" by auto
qed simp

(* replace by awalk_Cons_iff?*)
lemma awalk_ConsI:
  assumes "awalk v es w"
  assumes "e \<in> arcs G" and "arc_to_ends G e = (u,v)"
  shows "awalk u (e # es) w"
  using assms by (cases es) (auto simp: awalk_def arc_to_ends_def)

lemma (in pre_digraph) awalkI_apath:
  assumes "apath u p v" shows "awalk u p v"
using assms by (simp add: apath_def)

lemma arcE:
  assumes "arc e (u,v)"
  assumes "\<lbrakk>e \<in> arcs G; tail G e = u; head G e = v\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp: arc_def)

lemma in_arcs_imp_in_arcs_ends:
  assumes "e \<in> arcs G"
  shows "(tail G e, head G e) \<in> arcs_ends G"
using assms by (auto simp: arcs_ends_conv)

lemma set_awalk_verts_cas:
  assumes "cas u p v"
  shows "set (awalk_verts u p) = {u} \<union> set (map (tail G) p) \<union> set (map (head G) p)"
using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by simp
next
  case (Cons e es)
  then have "set (awalk_verts (head G e) es)
      = {head G e} \<union> set (map (tail G) es) \<union> set (map (head G) es)"
    by (auto simp: awalk_Cons_iff)
  with Cons.prems show ?case by auto
qed

lemma set_awalk_verts_not_Nil_cas:
  assumes "cas u p v" "p \<noteq> []"
  shows "set (awalk_verts u p) = set (map (tail G) p) \<union> set (map (head G) p)"
proof -
  have "u \<in> set (map (tail G) p)" using assms by (cases p) auto
  with assms show ?thesis  by (auto simp: set_awalk_verts_cas)
qed

lemma
  awhd_of_awalk: "awalk u p v \<Longrightarrow> awhd u p = u" and
  awlast_of_awalk: "awalk u p v \<Longrightarrow> NOMATCH (awlast u p) v \<Longrightarrow> awlast u p = v"
  unfolding NOMATCH_def by auto
lemmas awends_of_awalk[simp] = awhd_of_awalk awlast_of_awalk

lemma awalk_verts_arc1:
  assumes "e \<in> set p"
  shows "tail G e \<in> set (awalk_verts u p)"
using assms by (auto simp: awalk_verts_conv)

lemma awalk_verts_arc2:
  assumes "awalk u p v" "e \<in> set p"
  shows "head G e \<in> set (awalk_verts u p)"
using assms by (simp add: set_awalk_verts)

lemma awalk_induct_raw[case_names Base Cons(*, induct pred: awalk*)]:
  assumes "awalk u p v"
  assumes "\<And>w1. w1 \<in> verts G \<Longrightarrow> P w1 [] w1"
  assumes "\<And>w1 w2 e es. e \<in> arcs G \<Longrightarrow> arc_to_ends G e = (w1, w2)
    \<Longrightarrow> P w2 es v \<Longrightarrow> P w1 (e # es) v"
  shows "P u p v"
using assms
proof (induct p arbitrary: u v)
  case Nil then show ?case using Nil.prems by auto
next
  case (Cons e es)
  from Cons.prems(1) show ?case
    by (intro Cons) (auto intro: Cons(2-) simp: arc_to_ends_def awalk_Cons_iff)
qed

subsection {* Appending awalks *}

lemma (in pre_digraph) cas_append_iff[simp]:
  "cas u (p @ q) v \<longleftrightarrow> cas u p (awlast u p) \<and> cas (awlast u p) q v"
by (induct u p v rule: cas.induct) auto

lemma cas_ends:
  assumes "cas u p v" "cas u' p v'"
  shows "(p \<noteq> [] \<and> u = u' \<and> v = v') \<or> (p = [] \<and> u = v \<and> u' = v')"
using assms by (induct u p v arbitrary: u u' rule: cas.induct) auto

lemma awalk_ends:
  assumes "awalk u p v" "awalk u' p v'"
  shows "(p \<noteq> [] \<and> u = u' \<and> v = v') \<or> (p = [] \<and> u = v \<and> u' = v')"
using assms by (simp add: awalk_def cas_ends)

lemma awalk_ends_eqD:
  assumes "awalk u p u" "awalk v p w"
  shows "v = w"
using awalk_ends[OF assms(1,2)] by auto

lemma awalk_empty_ends:
  assumes "awalk u [] v"
  shows "u = v"
using assms by (auto simp: awalk_def)

lemma apath_ends:
 assumes "apath u p v" and "apath u' p v'"
  shows "(p \<noteq> [] \<and> u \<noteq> v \<and> u = u' \<and> v = v') \<or> (p = [] \<and> u = v \<and> u' = v')"
using assms unfolding apath_def by (metis assms(2) apath_nonempty_ends  awalk_ends)

lemma awalk_append_iff[simp]:
  "awalk u (p @ q) v \<longleftrightarrow> awalk u p (awlast u p) \<and> awalk (awlast u p) q v" (is "?L \<longleftrightarrow> ?R")
by (auto simp: awalk_def intro: awlast_in_verts)

lemma awlast_append:
  "awlast u (p @ q) = awlast (awlast u p) q"
by (simp add: awalk_verts_conv)

lemma awhd_append:
  "awhd u (p @ q) = awhd (awhd u q) p"
by (simp add: awalk_verts_conv)

declare awalkE[rule del]

lemma awalkE'[elim]:
  assumes "awalk u p v"
  obtains "set (awalk_verts u p) \<subseteq> verts G" "set p \<subseteq> arcs G" "cas u p v"
    "awhd u p = u" "awlast u p = v" "u \<in> verts G" "v \<in> verts G"
proof -
  have "u \<in> set (awalk_verts u p)" "v \<in> set (awalk_verts u p)"
    using assms by (auto simp: hd_in_awalk_verts elim: awalkE)
  then show ?thesis using assms by (auto elim: awalkE intro: that)
qed

lemma awalk_appendI:
  assumes "awalk u p v"
  assumes "awalk v q w"
  shows "awalk u (p @ q) w"
using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by auto
next
  case (Cons e es)
  from Cons.prems have ee_e: "arc_to_ends G e = (u, head G e)"
    unfolding arc_to_ends_def by auto

  have "awalk (head G e) es v"
    using ee_e Cons(2) awalk_Cons_iff by auto
  then show ?case using Cons ee_e by (auto simp: awalk_Cons_iff)
qed

lemma awalk_verts_append_cas:
  assumes "cas u (p @ q) v"
  shows "awalk_verts u (p @ q) = awalk_verts u p @ tl (awalk_verts (awlast u p) q)"
  using assms
proof (induct p arbitrary: u)
  case Nil then show ?case by (cases q) auto
qed (auto simp: awalk_Cons_iff)

lemma awalk_verts_append:
  assumes "awalk u (p @ q) v"
  shows "awalk_verts u (p @ q) = awalk_verts u p @ tl (awalk_verts (awlast u p) q)"
  using assms by (intro awalk_verts_append_cas) blast

lemma awalk_verts_append2:
  assumes "awalk u (p @ q) v"
  shows "awalk_verts u (p @ q) = butlast (awalk_verts u p) @ awalk_verts (awlast u p) q"
 using assms by (auto simp: awalk_verts_conv)

lemma apath_append_iff:
  "apath u (p @ q) v \<longleftrightarrow> apath u p (awlast u p) \<and> apath (awlast u p) q v \<and>
    set (awalk_verts u p) \<inter> set (tl (awalk_verts (awlast u p) q)) = {}" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then have "distinct (awalk_verts (awlast u p) q)" by (auto simp: apath_def awalk_verts_append2)
  with `?L` show ?R by (auto simp: apath_def awalk_verts_append)
next
  assume ?R
  then show ?L by (auto simp: apath_def awalk_verts_append dest: distinct_tl)
qed

lemma (in wf_digraph) set_awalk_verts_append_cas:
  assumes "cas u p v" "cas v q w"
  shows "set (awalk_verts u (p @ q)) = set (awalk_verts u p) \<union> set (awalk_verts v q)"
proof -
  from assms have cas_pq: "cas u (p @ q) w"
    by (simp add: awlast_if_cas)
  moreover
  from assms have "v \<in> set (awalk_verts u p)"
    by (metis awalk_verts_non_Nil awlast_if_cas last_in_set)
  ultimately show ?thesis using assms
    by (auto simp: set_awalk_verts_cas)
qed

lemma (in wf_digraph) set_awalk_verts_append:
  assumes "awalk u p v" "awalk v q w"
  shows "set (awalk_verts u (p @ q)) = set (awalk_verts u p) \<union> set (awalk_verts v q)"
proof -
  from assms have "awalk u (p @ q) w" by auto
  moreover
  with assms have "v \<in> set (awalk_verts u (p @ q))"
    by (auto simp: awalk_verts_append)
  ultimately show ?thesis using assms
    by (auto simp: set_awalk_verts)
qed

lemma cas_takeI:
  assumes "cas u p v" "awlast u (take n p) = v'"
  shows "cas u (take n p) v'"
proof -
  from assms have "cas u (take n p @ drop n p) v" by simp
  with assms show ?thesis unfolding cas_append_iff by simp
qed

lemma cas_dropI:
  assumes "cas u p v" "awlast u (take n p) = u'"
  shows "cas u' (drop n p) v"
proof -
  from assms have "cas u (take n p @ drop n p) v" by simp
  with assms show ?thesis unfolding cas_append_iff by simp
qed

lemma awalk_verts_take_conv:
  assumes "cas u p v"
  shows "awalk_verts u (take n p) = take (Suc n) (awalk_verts u p)"
proof -
  from assms have "cas u (take n p) (awlast u (take n p))" by (auto intro: cas_takeI)
  with assms show ?thesis
    by (cases n p rule: nat.exhaust[case_product list.exhaust])
       (auto simp: awalk_verts_conv' take_map simp del: awalk_verts.simps)
qed

lemma awalk_verts_drop_conv:
  assumes "cas u p v"
  shows "awalk_verts u' (drop n p) = (if n < length p then drop n (awalk_verts u p) else [u'])"
using assms by (auto simp: awalk_verts_conv drop_map)

lemma awalk_decomp_verts:
  assumes cas: "cas u p v" and ev_decomp: "awalk_verts u p = xs @ y # ys"
  obtains q r where "cas u q y" "cas y r v" "p = q @ r" "awalk_verts u q = xs @ [y]" "awalk_verts y r = y # ys"
using assms
proof -
  def q \<equiv> "take (length xs) p" and r \<equiv> "drop (length xs) p"
  then have "p = q @ r" by simp
  moreover then have "cas u q (awlast u q)" "cas (awlast u q) r v"
    using `cas u p v` by auto
  moreover have "awlast u q = y"
    using q_def and assms by (auto simp: awalk_verts_take_conv)
  moreover have "awalk_verts u q = xs @ [awlast u q]"
    using assms q_def by (auto simp: awalk_verts_take_conv)
  moreover then have "awalk_verts y r = y # ys"
    unfolding q_def r_def using assms by (auto simp: awalk_verts_drop_conv not_less)
  ultimately show ?thesis by (intro that) auto
qed

lemma awalk_decomp:
  assumes "awalk u p v"
  assumes "w \<in> set (awalk_verts u p)"
  shows "\<exists>q r. p = q @ r \<and> awalk u q w \<and> awalk w r v"
proof -
  from assms have "cas u p v" by auto
  moreover from assms obtain xs ys where
    "awalk_verts u p = xs @ w # ys" by (auto simp: in_set_conv_decomp)
  ultimately
  obtain q r where "cas u q w" "cas w r v" "p = q @ r" "awalk_verts u q = xs @ [w]"
    by (auto intro: awalk_decomp_verts)
  with assms show ?thesis by auto
qed

lemma awalk_not_distinct_decomp:
  assumes "awalk u p v"
  assumes "\<not> distinct (awalk_verts u p)"
  shows "\<exists>q r s. p = q @ r @ s \<and> distinct (awalk_verts u q)
    \<and> 0 < length r
    \<and> (\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v)"
proof -
  from assms
  obtain xs ys zs y where
    pv_decomp: "awalk_verts u p = xs @ y # ys @ y # zs"
    and xs_y_props: "distinct xs" "y \<notin> set xs" "y \<notin> set ys"
    using not_distinct_decomp_min_prefix by blast

  obtain q p' where "cas u q y" "p = q @ p'" "awalk_verts u q = xs @ [y]"
    and p'_props: "cas y p' v"  "awalk_verts y p' = (y # ys) @ y # zs"
    using assms pv_decomp by - (rule awalk_decomp_verts, auto)
  obtain r s where "cas y r y" "cas y s v" "p' = r @ s"
    "awalk_verts y r = y # ys @ [y]" "awalk_verts y s = y # zs"
    using p'_props by (rule awalk_decomp_verts) auto

  have "p = q @ r @ s" using `p = q @ p'` `p' = r @ s` by simp
  moreover
  have "distinct (awalk_verts u q)" using `awalk_verts u q = xs @ [y]` and xs_y_props  by simp
  moreover
  have "0 < length r" using `awalk_verts y r = y # ys @ [y]` by auto
  moreover
  from pv_decomp assms have "y \<in> verts G" by auto
  then have "awalk u q y" "awalk y r y" "awalk y s v"
    using `awalk u p v` `cas u q y` `cas y r y` `cas y s v` unfolding `p = q @ r @ s`
    by (auto simp: awalk_def)
  ultimately show ?thesis by blast
qed

lemma apath_decomp_disjoint:
  assumes "apath u p v"
  assumes "p = q @ r"
  assumes "x \<in> set (awalk_verts u q)" "x \<in> set (tl (awalk_verts (awlast u q) r))"
  shows False
using assms by (auto simp: apath_def awalk_verts_append)

subsection {* Cycles *}

definition closed_w :: "'b awalk \<Rightarrow> bool" where
  "closed_w p \<equiv> \<exists>u. awalk u p u \<and> 0 < length p"

text {*
  The definitions of cycles in textbooks vary w.r.t to the minimial length
  of a cycle.

  The definition given here matches \cite{diestel2010graph}.
  \cite{bangjensen2009digraphs} excludes loops from being cycles.
  Volkmann (Lutz Volkmann: Graphen an allen Ecken und Kanten, 2006 (?))
  places no restriction on the length in the definition, but later
  usage assumes cycles to be non-empty.
*}
definition (in pre_digraph) cycle :: "'b awalk \<Rightarrow> bool" where
  "cycle p \<equiv> \<exists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> p \<noteq> []"

lemma cycle_altdef:
  "cycle p \<longleftrightarrow> closed_w p \<and> (\<exists>u. distinct (tl (awalk_verts u p)))"
by (cases p) (auto simp: closed_w_def cycle_def)

lemma (in wf_digraph) distinct_tl_verts_imp_distinct:
  assumes "awalk u p v"
  assumes "distinct (tl (awalk_verts u p))"
  shows "distinct p"
proof (rule ccontr)
  assume "\<not>distinct p"
  then obtain e xs ys zs where p_decomp: "p = xs @ e # ys @ e # zs"
    by (blast dest: not_distinct_decomp_min_prefix)
  then show False
    using assms p_decomp by (auto simp: awalk_verts_append awalk_Cons_iff set_awalk_verts)
qed

lemma (in wf_digraph) distinct_verts_imp_distinct:
  assumes "awalk u p v"
  assumes "distinct (awalk_verts u p)"
  shows "distinct p"
  using assms by (blast intro: distinct_tl_verts_imp_distinct distinct_tl)

lemma (in wf_digraph) cycle_conv:
  "cycle p \<longleftrightarrow> (\<exists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> distinct p \<and> p \<noteq> [])"
  unfolding cycle_def by (auto intro: distinct_tl_verts_imp_distinct)

lemma (in loopfree_digraph) cycle_digraph_conv:
  "cycle p \<longleftrightarrow> (\<exists>u. awalk u p u \<and> distinct (tl (awalk_verts u p)) \<and> 2 \<le> length p)" (is "?L \<longleftrightarrow> ?R")
proof
  assume "cycle p"
  then obtain u where *: "awalk u p u" "distinct (tl (awalk_verts u p))" "p \<noteq> []"
    unfolding cycle_def by auto
  have "2 \<le> length p"
  proof (rule ccontr)
    assume "\<not>?thesis" with * obtain e where "p=[e]"
      by (cases p) (auto simp: not_le)
    then show False using * by (auto simp: awalk_simps dest: no_loops)
  qed
  then show ?R using * by auto
qed (auto simp: cycle_def)

lemma (in wf_digraph) closed_w_imp_cycle:
  assumes "closed_w p" shows "\<exists>p. cycle p"
  using assms
proof (induct "length p" arbitrary: p rule: less_induct)
  case less
  then obtain u where *: "awalk u p u" "p \<noteq> []" by (auto simp: closed_w_def)
  show ?thesis
  proof cases
    assume "distinct (tl (awalk_verts u p))"
    with less show ?thesis by (auto simp: closed_w_def cycle_altdef)
  next
    assume A: "\<not>distinct (tl (awalk_verts u p))"
    then obtain e es where "p = e # es" by (cases p) auto
    with A * have **: "awalk (head G e) es u" "\<not>distinct (awalk_verts (head G e) es)"
      by (auto simp: awalk_Cons_iff)
    obtain q r s where "es = q @ r @ s" "\<exists>w. awalk w r w" "closed_w r"
      using awalk_not_distinct_decomp[OF **] by (auto simp: closed_w_def)
    then have "length r < length p" using `p = _` by auto
    then show ?thesis using `closed_w r` by (rule less)
  qed
qed

subsection {* Reachability *}

lemma reachable1_awalk:
  "u \<rightarrow>\<^sup>+ v \<longleftrightarrow> (\<exists>p. awalk u p v \<and> p \<noteq> [])"
proof
  assume "u \<rightarrow>\<^sup>+ v" then show "\<exists>p. awalk u p v \<and> p \<noteq> []"
  proof (induct rule: converse_trancl_induct)
    case (base y) then obtain e where "e \<in> arcs G" "tail G e = y" "head G e = v" by auto
    with arc_implies_awalk show ?case by auto
  next
    case (step x y)
    then obtain p where "awalk y p v" "p \<noteq> []" by auto
    moreover
    from `x \<rightarrow> y` obtain e where "tail G e = x" "head G e = y" "e \<in> arcs G"
      by auto
    ultimately
    have "awalk x (e # p) v"
      by (auto simp: awalk_Cons_iff)
    then show ?case by auto
  qed
next
  assume "\<exists>p. awalk u p v \<and> p \<noteq> []" then obtain p where "awalk u p v" "p \<noteq> []" by auto
  thus "u \<rightarrow>\<^sup>+ v"
  proof (induct p arbitrary: u)
    case (Cons a as) then show ?case
      by (cases "as = []") (auto simp: awalk_simps trancl_into_trancl2 dest: in_arcs_imp_in_arcs_ends)
  qed simp
qed

lemma reachable_awalk:
  "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (\<exists>p. awalk u p v)"
proof cases
  assume "u = v"
  have "u \<rightarrow>\<^sup>*u \<longleftrightarrow> awalk u [] u" by (auto simp: awalk_Nil_iff reachable_in_verts)
  also have "\<dots> \<longleftrightarrow> (\<exists>p. awalk u p u)"
    by (metis awalk_Nil_iff awalk_hd_in_verts)
  finally show ?thesis using `u = v` by simp
next
  assume "u \<noteq> v"
  then have "u \<rightarrow>\<^sup>* v \<longleftrightarrow> u \<rightarrow>\<^sup>+ v" by auto
  also have "\<dots> \<longleftrightarrow> (\<exists>p. awalk u p v)"
    using `u \<noteq> v` unfolding reachable1_awalk by force
  finally show ?thesis .
qed

lemma reachable_awalkI[intro?]:
  assumes "awalk u p v"
  shows "u \<rightarrow>\<^sup>* v"
  unfolding reachable_awalk using assms by auto

lemma reachable1_awalkI:
  "awalk v p w \<Longrightarrow> p \<noteq> [] \<Longrightarrow> v \<rightarrow>\<^sup>+ w"
by (auto simp add: reachable1_awalk)

lemma reachable_arc_trans:
  assumes "u \<rightarrow>\<^sup>* v" "arc e (v,w)"
  shows "u \<rightarrow>\<^sup>* w"
proof -
  from `u \<rightarrow>\<^sup>* v` obtain p where "awalk u p v"
    by (auto simp: reachable_awalk)
  moreover have "awalk v [e] w"
    using `arc e (v,w)`
    by (auto simp: arc_def awalk_def)
  ultimately have "awalk u (p @ [e]) w"
    by (rule awalk_appendI)
  then show ?thesis ..
qed

subsection {* Paths *}

lemma (in fin_digraph) length_apath:
  assumes "apath u p v"
  shows "length p \<le> card (verts G)"
proof -
  have "length p \<le> length (awalk_verts u p)"
    by (auto simp: awalk_verts_conv)
  also have "\<dots> = card (set (awalk_verts u p))"
    using `apath u p v` by (auto simp: apath_def distinct_card)
  also have "\<dots> \<le> card (verts G)"
    using `apath u p v` unfolding apath_def awalk_conv
    by (auto intro: card_mono)
  finally show ?thesis .
qed

lemma (in fin_digraph) apaths_finite_triple:
  shows "finite {(u,p,v). apath u p v}"
proof -
  have "\<And>u p v. awalk u p v \<Longrightarrow> distinct (awalk_verts u p) \<Longrightarrow>length p \<le> card (verts G)"
    by (rule length_apath) (auto simp: apath_def)
  then have "{(u,p,v). apath u p v} \<subseteq> verts G \<times> {es. set es \<subseteq> arcs G \<and> length es \<le> card (verts G)} \<times> verts G"
    by (auto simp: apath_def)
  moreover have "finite ..."
    using finite_verts finite_arcs
    by (intro finite_cartesian_product finite_lists_length_le)
  ultimately show ?thesis by (rule finite_subset)
qed

lemma (in fin_digraph) apaths_finite:
  shows "finite {p. apath u p v}"
proof -
  have "{p. apath u p v} \<subseteq> (fst o snd) ` {(u,p,v). apath u p v}"
    by (force intro: image_eqI)
  with apaths_finite_triple show ?thesis  by (rule finite_surj)
qed

fun is_awalk_cyc_decomp :: "'b awalk =>
  ('b awalk \<times> 'b awalk \<times> 'b awalk) \<Rightarrow> bool" where
  "is_awalk_cyc_decomp p (q,r,s) \<longleftrightarrow> p = q @ r @ s
    \<and> (\<exists>u v w. awalk u q v \<and> awalk v r v \<and> awalk v s w)
    \<and> 0 <length r
    \<and> (\<exists>u. distinct (awalk_verts u q))"

definition awalk_cyc_decomp :: "'b awalk
    \<Rightarrow> 'b awalk \<times> 'b awalk \<times> 'b awalk" where
  "awalk_cyc_decomp p = (SOME qrs. is_awalk_cyc_decomp p qrs)"

function awalk_to_apath :: "'b awalk \<Rightarrow> 'b awalk" where
  "awalk_to_apath p = (if \<not>(\<exists>u. distinct (awalk_verts u p)) \<and> (\<exists>u v. awalk u p v)
     then (let (q,r,s) = awalk_cyc_decomp p in awalk_to_apath (q @ s))
     else p)"
by auto

lemma awalk_cyc_decomp_has_prop:
  assumes "awalk u p v" and "\<not>distinct (awalk_verts u p)"
  shows "is_awalk_cyc_decomp p (awalk_cyc_decomp p)"
proof -
  obtain q r s where *: "p = q @ r @ s \<and> distinct (awalk_verts u q)
      \<and> 0 < length r
      \<and> (\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v)"
    by (atomize_elim) (rule awalk_not_distinct_decomp[OF assms])
  then have "\<exists>x. is_awalk_cyc_decomp p x"
    by (intro exI[where x="(q,r,s)"]) auto
  then show ?thesis unfolding awalk_cyc_decomp_def ..
qed

lemma awalk_cyc_decompE:
  assumes dec: "awalk_cyc_decomp p = (q,r,s)"
  assumes p_props: "awalk u p v" "\<not>distinct (awalk_verts u p)"
  obtains "p = q @ r @ s" "distinct (awalk_verts u q)" "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" "closed_w r"
proof
  show "p = q @ r @ s" "distinct (awalk_verts u q)" "closed_w r"
    using awalk_cyc_decomp_has_prop[OF p_props] and dec
    by (auto simp: closed_w_def awalk_verts_conv)
  then have "p \<noteq> []" by (auto simp: closed_w_def)

  (* TODO: Can we find some general rules to prove the last property?*)
  obtain u' w' v' where obt_awalk: "awalk u' q w'" "awalk w' r w'" "awalk w' s v'"
    using awalk_cyc_decomp_has_prop[OF p_props] and dec by auto
  then have "awalk u' p v'"
    using `p = q @ r @ s` by simp
  then have "u = u'" and "v = v'" using `p \<noteq> []` `awalk u p v` by (metis awalk_ends)+
  then have "awalk u q w'" "awalk w' r w'" "awalk w' s v"
    using obt_awalk by auto
  then show "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" by auto
qed

lemma awalk_cyc_decompE':
  assumes p_props: "awalk u p v" "\<not>distinct (awalk_verts u p)"
  obtains q r s where "p = q @ r @ s" "distinct (awalk_verts u q)" "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" "closed_w r"
proof -
  obtain q r s where "awalk_cyc_decomp p = (q,r,s)"
    by (cases "awalk_cyc_decomp p") auto
  then have "p = q @ r @ s" "distinct (awalk_verts u q)" "\<exists>w. awalk u q w \<and> awalk w r w \<and> awalk w s v" "closed_w r"
    using assms by (auto elim: awalk_cyc_decompE)
  then show ?thesis ..
qed

termination awalk_to_apath
proof (relation "measure length")
  fix G p qrs rs q r s

  have X: "\<And>x y. closed_w r \<Longrightarrow> awalk x r y \<Longrightarrow> x = y"
    unfolding closed_w_def by (blast dest: awalk_ends)

  assume "\<not>(\<exists>u. distinct (awalk_verts u p)) \<and>(\<exists>u v. awalk u p v)"
    and **:"qrs = awalk_cyc_decomp p" "(q, rs) = qrs" "(r, s) = rs"
  then obtain u v where *: "awalk u p v" "\<not>distinct (awalk_verts u p)"
    by (cases p) auto
  then have "awalk_cyc_decomp p = (q,r,s)" using ** by simp
  then have "is_awalk_cyc_decomp p (q,r,s)"
    apply (rule awalk_cyc_decompE[OF _ *])
    using X[of "awlast u q"  "awlast (awlast u q) r"] *(1)
    by (auto simp: closed_w_def)
  then show "(q @ s, p) \<in> measure length"
    by (auto simp: closed_w_def)
qed simp
declare awalk_to_apath.simps[simp del]

lemma awalk_to_apath_induct[consumes 1, case_names path decomp]:
  assumes awalk: "awalk u p v"
  assumes dist: "\<And>p. awalk u p v \<Longrightarrow> distinct (awalk_verts u p) \<Longrightarrow> P p"
  assumes dec: "\<And>p q r s. \<lbrakk>awalk u p v; awalk_cyc_decomp p = (q,r,s);
    \<not>distinct (awalk_verts u p); P (q @ s)\<rbrakk> \<Longrightarrow> P p"
  shows "P p"
using awalk
proof (induct "length p" arbitrary: p rule: less_induct)
  case less
  show ?case
  proof (cases "distinct (awalk_verts u p)")
    case True then show ?thesis by (auto intro: dist less.prems)
  next
    case False
    obtain q r s where p_cdecomp: "awalk_cyc_decomp p = (q,r,s)"
      by (cases "awalk_cyc_decomp p") auto
    then have "is_awalk_cyc_decomp p (q,r,s)" "p = q @ r @ s"
      using awalk_cyc_decomp_has_prop[OF less.prems(1) False] by auto
    then have "length (q @ s) < length p" "awalk u (q @ s) v"
      using less.prems by (auto dest!: awalk_ends_eqD)
    then have "P (q @ s)" by (auto intro: less)

    with p_cdecomp False show ?thesis by (auto intro: dec less.prems)
  qed
qed

lemma step_awalk_to_apath:
  assumes awalk: "awalk u p v"
    and decomp: "awalk_cyc_decomp p = (q, r, s)"
    and dist: "\<not> distinct (awalk_verts u p)"
  shows "awalk_to_apath p = awalk_to_apath (q @ s)"
proof -
  from dist have "\<not>(\<exists>u. distinct (awalk_verts u p))"
    by (auto simp: awalk_verts_conv)
  with awalk and decomp show "awalk_to_apath p = awalk_to_apath (q @ s)"
    by (auto simp: awalk_to_apath.simps)
qed

lemma apath_awalk_to_apath:
  assumes "awalk u p v"
  shows "apath u (awalk_to_apath p) v"
using assms
proof (induct rule: awalk_to_apath_induct)
  case (path p)
  then have "awalk_to_apath p = p"
    by (auto simp: awalk_to_apath.simps)
  then show ?case using path by (auto simp: apath_def)
next
  case (decomp p q r s)
  then show ?case using step_awalk_to_apath[of _ p _ q r s] by simp
qed

lemma reachable_apath:
  "u \<rightarrow>\<^sup>* v \<longleftrightarrow> (\<exists>p. apath u p v)"
  by (auto intro: awalkI_apath apath_awalk_to_apath simp: reachable_awalk)

end

end


(*
  Title: Ad-Hoc Duality for Orderings and Lattices
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Ad-Hoc Duality for Orderings and Lattices\<close>

theory Order_Duality
  imports Sup_Lattice

begin

text \<open>This component presents an "explicit" formalisation of order and lattice duality. It augments the data type based one
 used by Wenzel in his lattice components \<^cite>\<open>"Wenzel"\<close>, and complements the "implicit" formalisation given by locales. It uses a functor dual,
supplied within a type class, which is simply a bijection (isomorphism) between types, with the constraint that
the dual of a dual object is the original object. In Wenzel's formalisation, by contrast, dual is a bijection, but not
 idempotent or involutive. In the past, Preoteasa has used a similar approach with Isabelle~\<^cite>\<open>"Preoteasa11b"\<close>.\<close>

text \<open>Duality is such a fundamental concept in order and lattice theory that it probably deserves to be included in the type classes
for these objects, as in this section.\<close>

class dual =
  fixes dual :: "'a \<Rightarrow> 'a" ("\<partial>")
  assumes inj_dual: "inj \<partial>"
  and invol_dual [simp]: "\<partial> \<circ> \<partial> = id"

text \<open>This type class allows one to define a type dual. It is actually a dependent type
for which dual can be instantiated.\<close>

typedef (overloaded) 'a dual = "range (dual::'a::dual \<Rightarrow> 'a)"
  by fastforce

setup_lifting type_definition_dual

text \<open>At the moment I have no use for this type.\<close>

context dual
begin

lemma surj_dual: "surj \<partial>"
  unfolding surj_def by (metis invol_dual_var)

lemma bij_dual: "bij \<partial>"
  by (simp add: bij_def inj_dual surj_dual)

lemma inj_dual_iff: "(\<partial> x = \<partial> y) = (x = y)"
  by (meson inj_dual injD)

lemma the_inv_dual: "the_inv \<partial> = \<partial>"
  by (metis comp_apply id_def invol_dual_var inj_dual surj_dual surj_fun_eq the_inv_f_o_f_id)

end

text \<open>In boolean algebras, duality is of course De Morgan duality and can be expressed within the language.\<close>

sublocale boolean_algebra \<subseteq> ba_dual: dual "uminus"
  by (unfold_locales, simp_all add: inj_def)

definition map_dual:: "('a \<Rightarrow> 'b) \<Rightarrow> 'a::dual \<Rightarrow> 'b::dual" ("\<partial>\<^sub>F") where
  "\<partial>\<^sub>F f = \<partial> \<circ> f \<circ> \<partial>"

lemma map_dual_func1: "\<partial>\<^sub>F (f \<circ> g) = \<partial>\<^sub>F f \<circ> \<partial>\<^sub>F g"
  by (metis (no_types, lifting) comp_assoc comp_id invol_dual map_dual_def)

lemma map_dual_func2 [simp]: "\<partial>\<^sub>F id = id"
  by (simp add: map_dual_def)

lemma map_dual_nat_iso: "\<partial>\<^sub>F f \<circ> \<partial> = \<partial> \<circ> id f"
  by (simp add: comp_assoc map_dual_def)

lemma map_dual_invol [simp]: "\<partial>\<^sub>F \<circ> \<partial>\<^sub>F = id"
  unfolding map_dual_def comp_def fun_eq_iff by simp

text \<open>Thus map-dual is naturally isomorphic to the identify functor: The function dual is a natural transformation
between  map-dual and the identity functor, and, because it has a two-sided inverse --- itself, it is a natural isomorphism.\<close>

text \<open>The generic function set-dual provides another natural transformation (see below). Before introducing it, we introduce useful notation
for a widely used function.\<close>

abbreviation "\<eta> \<equiv> (\<lambda>x. {x})"

lemma eta_inj: "inj \<eta>"
  by simp

definition "set_dual = \<eta> \<circ> \<partial>"

lemma set_dual_prop: "set_dual (\<partial> x) = {x}"
  by (metis comp_apply dual_iff set_dual_def)

text \<open>The next four lemmas show that (functional) image and preimage are functors (on functions). This does not really belong here,
but it is useful for what follows. The interaction between duality and (pre)images is needed in applications.\<close>

lemma image_func1: "(`) (f \<circ> g) = (`) f \<circ> (`) g"
  unfolding fun_eq_iff by (simp add: image_comp)

lemma image_func2: "(`) id = id"
  by simp

lemma vimage_func1: "(-`) (f \<circ> g) = (-`) g \<circ> (-`) f"
  unfolding fun_eq_iff by (simp add: vimage_comp)

lemma vimage_func2: "(-`) id = id"
  by simp

lemma iso_image: "mono ((`) f)"
  by (simp add: image_mono monoI)

lemma iso_preimage: "mono ((-`) f)"
  by (simp add: monoI vimage_mono)

context dual
begin

lemma image_dual [simp]: "(`) \<partial> \<circ> (`) \<partial> = id"
  by (metis image_func1 image_func2 invol_dual)

lemma vimage_dual [simp]: "(-`) \<partial> \<circ> (-`) \<partial> = id"
  by (simp add: set.comp)

end

text \<open>The following natural transformation between the powerset functor (image) and the identity functor
is well known.\<close>

lemma power_set_func_nat_trans: "\<eta> \<circ> id f = (`) f \<circ> \<eta>"
  unfolding fun_eq_iff comp_def by simp

text \<open>As an instance, set-dual is a natural transformation with built-in type coercion.\<close>

lemma dual_singleton: "(`) \<partial> \<circ> \<eta> = \<eta> \<circ> \<partial>"
  by auto

lemma finite_dual [simp]: "finite \<circ> (`) \<partial> = finite"
  unfolding fun_eq_iff comp_def using inj_dual finite_vimageI inj_vimage_image_eq by fastforce

lemma finite_dual_var [simp]: "finite (\<partial> ` X) = finite X"
  by (metis comp_def finite_dual)

lemma subset_dual: "(X = \<partial> ` Y) = (\<partial> ` X = Y)"
  by (metis image_dual pointfree_idE)

lemma subset_dual1: "(X \<subseteq> Y) = (\<partial> ` X \<subseteq> \<partial> ` Y)"
  by (simp add: inj_dual inj_image_subset_iff)

lemma dual_empty [simp]: "\<partial> ` {} = {}"
  by simp

lemma dual_UNIV [simp]: "\<partial> ` UNIV = UNIV"
  by (simp add: surj_dual)

lemma fun_dual1: "(f = g \<circ> \<partial>) = (f \<circ> \<partial> = g)"
  by (metis comp_assoc comp_id invol_dual)

lemma fun_dual2: "(f = \<partial> \<circ> g) = (\<partial> \<circ> f = g)"
  by (metis comp_assoc fun.map_id invol_dual)

lemma fun_dual3: "(f = g \<circ> (`) \<partial>) = (f \<circ> (`) \<partial> = g)"
  by (metis comp_id image_dual o_assoc)

lemma fun_dual4: "(f = (`) \<partial> \<circ> g) = ((`) \<partial> \<circ> f = g)"
  by (metis comp_assoc id_comp image_dual)

lemma fun_dual5: "(f = \<partial> \<circ> g \<circ> \<partial>) = (\<partial> \<circ> f \<circ> \<partial> = g)"
  by (metis comp_assoc fun_dual1 fun_dual2)

lemma fun_dual6: "(f = (`) \<partial> \<circ> g \<circ> (`) \<partial>) = ((`) \<partial> \<circ> f \<circ> (`) \<partial> = g)"
  by (simp add: comp_assoc fun_dual3 fun_dual4)

lemma fun_dual7: "(f = \<partial> \<circ> g \<circ> (`) \<partial>) = (\<partial> \<circ> f \<circ> (`) \<partial> = g)"
  by (simp add: comp_assoc fun_dual2 fun_dual3)

lemma fun_dual8: "(f = (`) \<partial> \<circ> g \<circ> \<partial>) = ((`) \<partial> \<circ> f \<circ> \<partial> = g)"
  by (simp add: comp_assoc fun_dual1 fun_dual4)

lemma map_dual_dual: "(\<partial>\<^sub>F f = g) = (\<partial>\<^sub>F g = f)"
  by (metis map_dual_invol pointfree_idE)

text \<open>The next facts show incrementally that the dual of a complete lattice is a complete lattice.\<close>

class ord_with_dual = dual + ord +
  assumes ord_dual: "x \<le> y \<Longrightarrow> \<partial> y \<le> \<partial> x"

begin

lemma dual_dual_ord: "(\<partial> x \<le> \<partial> y) = (y \<le> x)"
  by (metis dual_iff ord_dual)

end

lemma ord_pres_dual:
  fixes f :: "'a::ord_with_dual \<Rightarrow> 'b::ord_with_dual"
  shows "ord_pres f \<Longrightarrow> ord_pres (\<partial>\<^sub>F f)"
  by (simp add: dual_dual_ord map_dual_def ord_pres_def)

lemma map_dual_anti: "(f::'a::ord_with_dual \<Rightarrow> 'b::ord_with_dual) \<le> g  \<Longrightarrow> \<partial>\<^sub>F g \<le> \<partial>\<^sub>F f"
  by (simp add: le_fun_def map_dual_def ord_dual)

class preorder_with_dual = ord_with_dual + preorder

begin

lemma less_dual_def_var: "(\<partial> y < \<partial> x) = (x < y)"
  by (simp add: dual_dual_ord less_le_not_le)

end

class order_with_dual = preorder_with_dual + order

lemma iso_map_dual:
  fixes f :: "'a::order_with_dual \<Rightarrow> 'b::order_with_dual"
  shows "mono f \<Longrightarrow> mono (\<partial>\<^sub>F f)"
  by (simp add: ord_pres_dual ord_pres_mono)

class lattice_with_dual = lattice + dual +
  assumes sup_dual_def: "\<partial> (x \<squnion> y) = \<partial> x \<sqinter> \<partial> y"

begin

subclass order_with_dual
  by (unfold_locales, metis inf.absorb_iff2 sup_absorb1 sup_commute sup_dual_def)

lemma inf_dual: "\<partial> (x \<sqinter> y) = \<partial> x \<squnion> \<partial> y"
  by (metis invol_dual_var sup_dual_def)

lemma inf_to_sup: "x \<sqinter> y = \<partial> (\<partial> x \<squnion> \<partial> y)"
  using inf_dual dual_iff by fastforce

lemma sup_to_inf: "x \<squnion> y = \<partial> (\<partial> x \<sqinter> \<partial> y)"
  by (simp add: inf_dual)

end

class bounded_lattice_with_dual = lattice_with_dual + bounded_lattice

begin

lemma bot_dual: "\<partial> \<bottom> = \<top>"
  by (metis dual_dual_ord dual_iff le_bot top_greatest)

lemma top_dual: "\<partial> \<top> = \<bottom>"
  using bot_dual dual_iff by force

end

class boolean_algebra_with_dual = lattice_with_dual + boolean_algebra

sublocale boolean_algebra \<subseteq> badual: boolean_algebra_with_dual _ _ _ _ _ _ _ _ uminus
  by unfold_locales simp_all

class Sup_lattice_with_dual = Sup_lattice + dual +
  assumes Sups_dual_def: "\<partial> \<circ> Sup = Infs \<circ> (`) \<partial>"

class Inf_lattice_with_dual = Inf_lattice + dual +
  assumes Sups_dual_def: "\<partial> \<circ> Supi = Inf \<circ> (`) \<partial>"

class complete_lattice_with_dual = complete_lattice + dual +
  assumes Sups_dual_def: "\<partial> \<circ> Sup = Inf \<circ> (`) \<partial>"

sublocale Sup_lattice_with_dual \<subseteq> sclatd: complete_lattice_with_dual Infs Sup infs "(\<le>)" le sups bots tops "\<partial>"
  by (unfold_locales, simp add: Sups_dual_def)

sublocale Inf_lattice_with_dual \<subseteq> iclatd: complete_lattice_with_dual Inf Supi infi "(\<le>)" le supi boti topi "\<partial>"
  by (unfold_locales, simp add: Sups_dual_def)

context complete_lattice_with_dual
begin

lemma Inf_dual: "\<partial> \<circ> Inf = Sup \<circ> (`) \<partial>"
  by (metis comp_assoc comp_id fun.map_id Sups_dual_def image_dual invol_dual)

lemma Inf_dual_var: "\<partial> (\<Sqinter>X) = \<Squnion>(\<partial> ` X)"
  using comp_eq_dest Inf_dual by fastforce

lemma Inf_to_Sup: "Inf = \<partial> \<circ> Sup \<circ> (`) \<partial>"
  by (auto simp add: Sups_dual_def image_comp)

lemma Inf_to_Sup_var: "\<Sqinter>X = \<partial> (\<Squnion>(\<partial> ` X))"
  using Inf_dual_var dual_iff by fastforce

lemma Sup_to_Inf: "Sup = \<partial> \<circ> Inf \<circ> (`) \<partial>"
  by (auto simp add: Inf_dual image_comp)

lemma Sup_to_Inf_var: "\<Squnion>X = \<partial> (\<Sqinter>(\<partial> ` X))"
  using Sup_to_Inf by force

lemma Sup_dual_def_var: "\<partial> (\<Squnion>X) = \<Sqinter> (\<partial> ` X)"
  using comp_eq_dest Sups_dual_def by fastforce

lemma bot_dual_def: "\<partial> \<top> = \<bottom>"
  by (smt Inf_UNIV Sup_UNIV Sups_dual_def surj_dual o_eq_dest)

lemma top_dual_def: "\<partial> \<bottom> = \<top>"
  using bot_dual_def dual_iff by blast

lemma inf_dual2: "\<partial> (x \<sqinter> y) = \<partial> x \<squnion> \<partial> y"
  by (smt comp_eq_elim Inf_dual Inf_empty Inf_insert SUP_insert inf_top.right_neutral)

lemma sup_dual: "\<partial> (x \<squnion> y) = \<partial> x \<sqinter> \<partial> y"
  by (metis inf_dual2 dual_iff)

subclass lattice_with_dual
  by (unfold_locales, auto simp: inf_dual sup_dual)

subclass bounded_lattice_with_dual..

end

end


(*  Title:      HOL/Library/Product_Plus.thy
    Author:     Brian Huffman
*)

section \<open>Additive group operations on product types\<close>

theory Product_Plus
imports Main
begin

subsection \<open>Operations\<close>

instantiation prod :: (zero, zero) zero
begin

definition zero_prod_def: "0 = (0, 0)"

instance ..
end

instantiation prod :: (plus, plus) plus
begin

definition plus_prod_def:
  "x + y = (fst x + fst y, snd x + snd y)"

instance ..
end

instantiation prod :: (minus, minus) minus
begin

definition minus_prod_def:
  "x - y = (fst x - fst y, snd x - snd y)"

instance ..
end

instantiation prod :: (uminus, uminus) uminus
begin

definition uminus_prod_def:
  "- x = (- fst x, - snd x)"

instance ..
end

lemma fst_zero [simp]: "fst 0 = 0"
  unfolding zero_prod_def by simp

lemma snd_zero [simp]: "snd 0 = 0"
  unfolding zero_prod_def by simp

lemma fst_add [simp]: "fst (x + y) = fst x + fst y"
  unfolding plus_prod_def by simp

lemma snd_add [simp]: "snd (x + y) = snd x + snd y"
  unfolding plus_prod_def by simp

lemma fst_diff [simp]: "fst (x - y) = fst x - fst y"
  unfolding minus_prod_def by simp

lemma snd_diff [simp]: "snd (x - y) = snd x - snd y"
  unfolding minus_prod_def by simp

lemma fst_uminus [simp]: "fst (- x) = - fst x"
  unfolding uminus_prod_def by simp

lemma snd_uminus [simp]: "snd (- x) = - snd x"
  unfolding uminus_prod_def by simp

lemma add_Pair [simp]: "(a, b) + (c, d) = (a + c, b + d)"
  unfolding plus_prod_def by simp

lemma diff_Pair [simp]: "(a, b) - (c, d) = (a - c, b - d)"
  unfolding minus_prod_def by simp

lemma uminus_Pair [simp, code]: "- (a, b) = (- a, - b)"
  unfolding uminus_prod_def by simp

subsection \<open>Class instances\<close>

instance prod :: (semigroup_add, semigroup_add) semigroup_add
  by standard (simp add: prod_eq_iff add.assoc)

instance prod :: (ab_semigroup_add, ab_semigroup_add) ab_semigroup_add
  by standard (simp add: prod_eq_iff add.commute)

instance prod :: (monoid_add, monoid_add) monoid_add
  by standard (simp_all add: prod_eq_iff)

instance prod :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
  by standard (simp add: prod_eq_iff)

instance prod :: (cancel_semigroup_add, cancel_semigroup_add) cancel_semigroup_add
    by standard (simp_all add: prod_eq_iff)

instance prod :: (cancel_ab_semigroup_add, cancel_ab_semigroup_add) cancel_ab_semigroup_add
    by standard (simp_all add: prod_eq_iff diff_diff_eq)

instance prod :: (cancel_comm_monoid_add, cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance prod :: (group_add, group_add) group_add
  by standard (simp_all add: prod_eq_iff)

instance prod :: (ab_group_add, ab_group_add) ab_group_add
  by standard (simp_all add: prod_eq_iff)

lemma fst_sum: "fst (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. fst (f x))"
proof (cases "finite A")
  case True
  then show ?thesis by induct simp_all
next
  case False
  then show ?thesis by simp
qed

lemma snd_sum: "snd (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. snd (f x))"
proof (cases "finite A")
  case True
  then show ?thesis by induct simp_all
next
  case False
  then show ?thesis by simp
qed

lemma sum_prod: "(\<Sum>x\<in>A. (f x, g x)) = (\<Sum>x\<in>A. f x, \<Sum>x\<in>A. g x)"
proof (cases "finite A")
  case True
  then show ?thesis by induct (simp_all add: zero_prod_def)
next
  case False
  then show ?thesis by (simp add: zero_prod_def)
qed

end


(*  Title:      ZF/upair.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge

Observe the order of dependence:
    Upair is defined in terms of Replace
    \<union> is defined in terms of Upair and \<Union>(similarly for Int)
    cons is defined in terms of Upair and Un
    Ordered pairs and descriptions are defined using cons ("set notation")
*)

section\<open>Unordered Pairs\<close>

theory Unordered_Pair
imports Set_Theory
keywords "print_tcset" :: diag
begin

ML_file "Tools/typechk.ML"

lemma atomize_ball [symmetric, rulify]:
     "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
by (simp add: Ball_def atomize_all atomize_imp)

subsection\<open>Unordered Pairs: constant @{term Upair}\<close>

lemma Upair_iff [simp]: "c \<in> Upair a b \<longleftrightarrow> (c=a | c=b)"
by (unfold Upair_def, blast)

lemma UpairI1: "a \<in> Upair a b"
by simp

lemma UpairI2: "b \<in> Upair a b"
by simp

lemma UpairE: "[| a \<in> Upair b c;  a=b ==> P;  a=c ==> P |] ==> P"
by (simp, blast)

subsection\<open>Rules for Binary Union, Defined via @{term Upair}\<close>

lemma Un_iff [simp]: "c \<in> A \<union> B \<longleftrightarrow> (c \<in> A | c \<in> B)"
apply (simp add: Un_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma UnI1: "c \<in> A ==> c \<in> A \<union> B"
by simp

lemma UnI2: "c \<in> B ==> c \<in> A \<union> B"
by simp

declare UnI1 [elim?]  UnI2 [elim?]

lemma UnE [elim!]: "[| c \<in> A \<union> B;  c \<in> A ==> P;  c \<in> B ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma UnE': "[| c \<in> A \<union> B;  c \<in> A ==> P;  [| c \<in> B;  c\<notin>A |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI [intro!]: "(c \<notin> B ==> c \<in> A) ==> c \<in> A \<union> B"
by (simp, blast)

subsection\<open>Rules for Binary Intersection, Defined via @{term Upair}\<close>

lemma Int_iff [simp]: "c \<in> A \<inter> B \<longleftrightarrow> (c \<in> A & c \<in> B)"
apply (unfold Int_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

lemma IntI [intro!]: "[| c \<in> A;  c \<in> B |] ==> c \<in> A \<inter> B"
by simp

lemma IntD1: "c \<in> A \<inter> B ==> c \<in> A"
by simp

lemma IntD2: "c \<in> A \<inter> B ==> c \<in> B"
by simp

lemma IntE [elim!]: "[| c \<in> A \<inter> B;  [| c \<in> A; c \<in> B |] ==> P |] ==> P"
by simp

subsection\<open>Rules for Set Difference, Defined via @{term Upair}\<close>

lemma Diff_iff [simp]: "c \<in> A-B \<longleftrightarrow> (c \<in> A & c\<notin>B)"
by (unfold Diff_def, blast)

lemma DiffI [intro!]: "[| c \<in> A;  c \<notin> B |] ==> c \<in> A - B"
by simp

lemma DiffD1: "c \<in> A - B ==> c \<in> A"
by simp

lemma DiffD2: "c \<in> A - B ==> c \<notin> B"
by simp

lemma DiffE [elim!]: "[| c \<in> A - B;  [| c \<in> A; c\<notin>B |] ==> P |] ==> P"
by simp

subsection\<open>Rules for @{term cons}\<close>

lemma cons_iff [simp]: "a \<in> cons b A \<longleftrightarrow> (a=b | a \<in> A)"
apply (unfold cons_def)
apply (blast intro: UpairI1 UpairI2 elim: UpairE)
done

(*risky as a typechecking rule, but solves otherwise unconstrained goals of
the form x \<in> ?A*)
lemma consI1 [simp,TC]: "a \<in> cons a B"
by simp

lemma consI2: "a \<in> B ==> a \<in> cons b B"
by simp

lemma consE [elim!]: "[| a \<in> cons b A;  a=b ==> P;  a \<in> A ==> P |] ==> P"
by (simp, blast)

(*Stronger version of the rule above*)
lemma consE':
    "[| a \<in> cons b A;  a=b ==> P;  [| a \<in> A;  a\<noteq>b |] ==> P |] ==> P"
by (simp, blast)

(*Classical introduction rule*)
lemma consCI [intro!]: "(a\<notin>B ==> a=b) ==> a \<in> cons b B"
by (simp, blast)

lemma cons_not_0 [simp]: "cons a B \<noteq> 0"
by (blast elim: equalityE)

lemmas cons_neq_0 = cons_not_0 [THEN notE]

declare cons_not_0 [THEN not_sym, simp]

subsection\<open>Singletons\<close>

lemma singleton_iff: "a \<in> {b} \<longleftrightarrow> a=b"
by simp

lemma singletonI [intro!]: "a \<in> {a}"
by (rule consI1)

lemmas singletonE = singleton_iff [THEN iffD1, elim_format, elim!]

subsection\<open>Descriptions\<close>

lemma the_equality [intro]:
    "[| P(a);  !!x. P(x) ==> x=a |] ==> (THE x. P(x)) = a"
apply (unfold the_def)
apply (fast dest: subst)
done

(* Only use this if you already know \<exists>!x. P(x) *)
lemma the_equality2: "[| \<exists>!x. P(x);  P(a) |] ==> (THE x. P(x)) = a"
by blast

lemma theI: "\<exists>!x. P(x) ==> P(THE x. P(x))"
apply (erule ex1E)
apply (subst the_equality)
apply (blast+)
done

(*No congruence rule is necessary: if @{term"\<forall>y.P(y)\<longleftrightarrow>Q(y)"} then
  @{term "THE x.P(x)"}  rewrites to @{term "THE x.Q(x)"} *)

(*If it's "undefined", it's zero!*)
lemma the_0: "~ (\<exists>!x. P(x)) ==> (THE x. P(x))=0"
apply (unfold the_def)
apply (blast elim!: ReplaceE)
done

(*Easier to apply than theI: conclusion has only one occurrence of P*)
lemma theI2:
    assumes p1: "~ Q(0) ==> \<exists>!x. P(x)"
        and p2: "!!x. P(x) ==> Q(x)"
    shows "Q(THE x. P(x))"
apply (rule classical)
apply (rule p2)
apply (rule theI)
apply (rule classical)
apply (rule p1)
apply (erule the_0 [THEN subst], assumption)
done

lemma the_eq_trivial [simp]: "(THE x. x = a) = a"
by blast

lemma the_eq_trivial2 [simp]: "(THE x. a = x) = a"
by blast

subsection\<open>Conditional Terms: \<open>if-then-else\<close>\<close>

lemma if_true [simp]: "(if True then a else b) = a"
by (unfold if_def, blast)

lemma if_false [simp]: "(if False then a else b) = b"
by (unfold if_def, blast)

(*Never use with case splitting, or if P is known to be true or false*)
lemma if_cong:
    "[| P\<longleftrightarrow>Q;  Q ==> a=c;  ~Q ==> b=d |]
     ==> (if P then a else b) = (if Q then c else d)"
by (simp add: if_def cong add: conj_cong)

(*Prevents simplification of x and y \<in> faster and allows the execution
  of functional programs. NOW THE DEFAULT.*)
lemma if_weak_cong: "P\<longleftrightarrow>Q ==> (if P then x else y) = (if Q then x else y)"
by simp

(*Not needed for rewriting, since P would rewrite to True anyway*)
lemma if_P: "P ==> (if P then a else b) = a"
by (unfold if_def, blast)

(*Not needed for rewriting, since P would rewrite to False anyway*)
lemma if_not_P: "~P ==> (if P then a else b) = b"
by (unfold if_def, blast)

lemma split_if [split]:
     "P(if Q then x else y) \<longleftrightarrow> ((Q \<longrightarrow> P(x)) & (~Q \<longrightarrow> P(y)))"
by (case_tac Q, simp_all)

(** Rewrite rules for boolean case-splitting: faster than split_if [split]
**)

lemmas split_if_eq1 = split_if [of "%x. x = b"] for b
lemmas split_if_eq2 = split_if [of "%x. a = x"] for a

lemmas split_if_mem1 = split_if [of "%x. x \<in> b"] for b
lemmas split_if_mem2 = split_if [of "%x. a \<in> x"] for a

lemmas split_ifs = split_if_eq1 split_if_eq2 split_if_mem1 split_if_mem2

(*Logically equivalent to split_if_mem2*)
lemma if_iff: "a: (if P then x else y) \<longleftrightarrow> P & a \<in> x | ~P & a \<in> y"
by simp

lemma if_type [TC]:
    "[| P ==> a \<in> A;  ~P ==> b \<in> A |] ==> (if P then a else b): A"
by simp

(** Splitting IFs in the assumptions **)

lemma split_if_asm: "P(if Q then x else y) \<longleftrightarrow> (~((Q & ~P(x)) | (~Q & ~P(y))))"
by simp

lemmas if_splits = split_if split_if_asm

subsection\<open>Consequences of Foundation\<close>

(*was called mem_anti_sym*)
lemma mem_asym: "[| a \<in> b;  ~P ==> b \<in> a |] ==> P"
apply (rule classical)
apply (rule_tac A1 = "{a,b}" in foundation [THEN disjE])
apply (blast elim!: equalityE)+
done

(*was called mem_anti_refl*)
lemma mem_irrefl: "a \<in> a ==> P"
by (blast intro: mem_asym)

(*mem_irrefl should NOT be added to default databases:
      it would be tried on most goals, making proofs slower!*)

lemma mem_not_refl: "a \<notin> a"
apply (rule notI)
apply (erule mem_irrefl)
done

(*Good for proving inequalities by rewriting*)
lemma mem_imp_not_eq: "a \<in> A ==> a \<noteq> A"
by (blast elim!: mem_irrefl)

lemma eq_imp_not_mem: "a=A ==> a \<notin> A"
by (blast intro: elim: mem_irrefl)

subsection\<open>Rules for Successor\<close>

lemma succ_iff: "i \<in> succ(j) \<longleftrightarrow> i=j | i \<in> j"
by (unfold succ_def, blast)

lemma succI1 [simp]: "i \<in> succ(i)"
by (simp add: succ_iff)

lemma succI2: "i \<in> j ==> i \<in> succ(j)"
by (simp add: succ_iff)

lemma succE [elim!]:
    "[| i \<in> succ(j);  i=j ==> P;  i \<in> j ==> P |] ==> P"
apply (simp add: succ_iff, blast)
done

(*Classical introduction rule*)
lemma succCI [intro!]: "(i\<notin>j ==> i=j) ==> i \<in> succ(j)"
by (simp add: succ_iff, blast)

lemma succ_not_0 [simp]: "succ(n) \<noteq> 0"
by (blast elim!: equalityE)

lemmas succ_neq_0 = succ_not_0 [THEN notE, elim!]

declare succ_not_0 [THEN not_sym, simp]
declare sym [THEN succ_neq_0, elim!]

(* @{term"succ(c) \<subseteq> B ==> c \<in> B"} *)
lemmas succ_subsetD = succI1 [THEN [2] subsetD]

(* @{term"succ(b) \<noteq> b"} *)
lemmas succ_neq_self = succI1 [THEN mem_imp_not_eq, THEN not_sym]

lemma succ_inject_iff [simp]: "succ(m) = succ(n) \<longleftrightarrow> m=n"
by (blast elim: mem_asym elim!: equalityE)

lemmas succ_inject = succ_inject_iff [THEN iffD1, dest!]

subsection\<open>Miniscoping of the Bounded Universal Quantifier\<close>

lemma ball_simps1:
     "(\<forall>x\<in>A. P(x) & Q)   \<longleftrightarrow> (\<forall>x\<in>A. P(x)) & (A=0 | Q)"
     "(\<forall>x\<in>A. P(x) | Q)   \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) | Q)"
     "(\<forall>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x\<in>A. P(x))) \<longleftrightarrow> (\<exists>x\<in>A. ~P(x))"
     "(\<forall>x\<in>0.P(x)) \<longleftrightarrow> True"
     "(\<forall>x\<in>succ i. P(x)) \<longleftrightarrow> P(i) & (\<forall>x\<in>i. P x)"
     "(\<forall>x\<in>cons a B. P(x)) \<longleftrightarrow> P(a) & (\<forall>x\<in>B. P x)"
     "(\<forall>x\<in>RepFun A f. P(x)) \<longleftrightarrow> (\<forall>y\<in>A. P (f y))"
     "(\<forall>x\<in>\<Union>(A).P x) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P x)"
by blast+

lemma ball_simps2:
     "(\<forall>x\<in>A. P & Q(x))   \<longleftrightarrow> (A=0 | P) & (\<forall>x\<in>A. Q(x))"
     "(\<forall>x\<in>A. P | Q(x))   \<longleftrightarrow> (P | (\<forall>x\<in>A. Q(x)))"
     "(\<forall>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x\<in>A. Q(x)))"
by blast+

lemma ball_simps3:
     "(\<forall>x\<in>Collect A Q. P(x)) \<longleftrightarrow> (\<forall>x\<in>A. Q(x) \<longrightarrow> P(x))"
by blast+

lemmas ball_simps [simp] = ball_simps1 ball_simps2 ball_simps3

lemma ball_conj_distrib:
    "(\<forall>x\<in>A. P(x) & Q(x)) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) & (\<forall>x\<in>A. Q(x)))"
by blast

subsection\<open>Miniscoping of the Bounded Existential Quantifier\<close>

lemma bex_simps1:
     "(\<exists>x\<in>A. P(x) & Q) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) & Q)"
     "(\<exists>x\<in>A. P(x) | Q) \<longleftrightarrow> (\<exists>x\<in>A. P(x)) | (A\<noteq>0 & Q)"
     "(\<exists>x\<in>A. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<forall>x\<in>A. P(x)) \<longrightarrow> (A\<noteq>0 & Q))"
     "(\<exists>x\<in>0.P(x)) \<longleftrightarrow> False"
     "(\<exists>x\<in>succ(i).P(x)) \<longleftrightarrow> P(i) | (\<exists>x\<in>i. P(x))"
     "(\<exists>x\<in>cons a B. P(x)) \<longleftrightarrow> P(a) | (\<exists>x\<in>B. P(x))"
     "(\<exists>x\<in>RepFun A f. P(x)) \<longleftrightarrow> (\<exists>y\<in>A. P(f(y)))"
     "(\<exists>x\<in>\<Union>(A).P(x)) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y.  P(x))"
     "(~(\<exists>x\<in>A. P(x))) \<longleftrightarrow> (\<forall>x\<in>A. ~P(x))"
by blast+

lemma bex_simps2:
     "(\<exists>x\<in>A. P & Q(x)) \<longleftrightarrow> (P & (\<exists>x\<in>A. Q(x)))"
     "(\<exists>x\<in>A. P | Q(x)) \<longleftrightarrow> (A\<noteq>0 & P) | (\<exists>x\<in>A. Q(x))"
     "(\<exists>x\<in>A. P \<longrightarrow> Q(x)) \<longleftrightarrow> ((A=0 | P) \<longrightarrow> (\<exists>x\<in>A. Q(x)))"
by blast+

lemma bex_simps3:
     "(\<exists>x\<in>Collect A Q. P(x)) \<longleftrightarrow> (\<exists>x\<in>A. Q(x) & P(x))"
by blast

lemmas bex_simps [simp] = bex_simps1 bex_simps2 bex_simps3

lemma bex_disj_distrib:
    "(\<exists>x\<in>A. P(x) | Q(x)) \<longleftrightarrow> ((\<exists>x\<in>A. P(x)) | (\<exists>x\<in>A. Q(x)))"
by blast

(** One-point rule for bounded quantifiers: see HOL/Set.ML **)

lemma bex_triv_one_point1 [simp]: "(\<exists>x\<in>A. x=a) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_triv_one_point2 [simp]: "(\<exists>x\<in>A. a=x) \<longleftrightarrow> (a \<in> A)"
by blast

lemma bex_one_point1 [simp]: "(\<exists>x\<in>A. x=a & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma bex_one_point2 [simp]: "(\<exists>x\<in>A. a=x & P(x)) \<longleftrightarrow> (a \<in> A & P(a))"
by blast

lemma ball_one_point1 [simp]: "(\<forall>x\<in>A. x=a \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

lemma ball_one_point2 [simp]: "(\<forall>x\<in>A. a=x \<longrightarrow> P(x)) \<longleftrightarrow> (a \<in> A \<longrightarrow> P(a))"
by blast

subsection\<open>Miniscoping of the Replacement Operator\<close>

text\<open>These cover both @{term Replace} and @{term Collect}\<close>
lemma Rep_simps [simp]:
     "{x. y \<in> 0, R x y} = 0"
     "{x \<in> 0. P(x)} = 0"
     "{x \<in> A. Q} = (if Q then A else 0)"
     "RepFun 0 f = 0"
     "RepFun (succ i) f = cons (f i) (RepFun i f)"
     "RepFun (cons a B) f = cons (f a) (RepFun B f)"
by (simp_all, blast+)

subsection\<open>Miniscoping of Unions\<close>

lemma UN_simps1:
     "(\<Union>x\<in>C. cons a (B x)) = (if C=0 then 0 else cons a (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<union> B')   = (if C=0 then 0 else (\<Union>x\<in>C. A(x)) \<union> B')"
     "(\<Union>x\<in>C. A' \<union> B(x))   = (if C=0 then 0 else A' \<union> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) \<inter> B')  = ((\<Union>x\<in>C. A(x)) \<inter> B')"
     "(\<Union>x\<in>C. A' \<inter> B(x))  = (A' \<inter> (\<Union>x\<in>C. B(x)))"
     "(\<Union>x\<in>C. A(x) - B')    = ((\<Union>x\<in>C. A(x)) - B')"
     "(\<Union>x\<in>C. A' - B(x))    = (if C=0 then 0 else A' - (\<Inter>x\<in>C. B(x)))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI )+
done

lemma UN_simps2:
      "(\<Union>x\<in>\<Union>(A). B(x)) = (\<Union>y\<in>A. \<Union>x\<in>y. B(x))"
      "(\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z\<in>B(x). C(z))"
      "(\<Union>x\<in>RepFun A f. B(x)) = (\<Union>a\<in>A. B(f(a)))"
by blast+

lemmas UN_simps [simp] = UN_simps1 UN_simps2

text\<open>Opposite of miniscoping: pull the operator out\<close>

lemma UN_extend_simps1:
     "(\<Union>x\<in>C. A(x)) \<union> B   = (if C=0 then B else (\<Union>x\<in>C. A(x) \<union> B))"
     "((\<Union>x\<in>C. A(x)) \<inter> B) = (\<Union>x\<in>C. A(x) \<inter> B)"
     "((\<Union>x\<in>C. A(x)) - B) = (\<Union>x\<in>C. A(x) - B)"
apply simp_all
apply blast+
done

lemma UN_extend_simps2:
     "cons a (\<Union>x\<in>C. B(x)) = (if C=0 then {a} else (\<Union>x\<in>C. cons a (B x)))"
     "A \<union> (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Union>x\<in>C. A \<union> B(x)))"
     "(A \<inter> (\<Union>x\<in>C. B(x))) = (\<Union>x\<in>C. A \<inter> B(x))"
     "A - (\<Inter>x\<in>C. B(x))    = (if C=0 then A else (\<Union>x\<in>C. A - B(x)))"
     "(\<Union>y\<in>A. \<Union>x\<in>y. B(x)) = (\<Union>x\<in>\<Union>(A). B(x))"
     "(\<Union>a\<in>A. B(f(a))) = (\<Union>x\<in>RepFun A f. B(x))"
apply (simp_all add: Inter_def)
apply (blast intro!: equalityI)+
done

lemma UN_UN_extend:
     "(\<Union>x\<in>A. \<Union>z\<in>B(x). C(z)) = (\<Union>z\<in>(\<Union>x\<in>A. B(x)). C(z))"
by blast

lemmas UN_extend_simps = UN_extend_simps1 UN_extend_simps2 UN_UN_extend

subsection\<open>Miniscoping of Intersections\<close>

lemma INT_simps1:
     "(\<Inter>x\<in>C. A(x) \<inter> B) = (\<Inter>x\<in>C. A(x)) \<inter> B"
     "(\<Inter>x\<in>C. A(x) - B)   = (\<Inter>x\<in>C. A(x)) - B"
     "(\<Inter>x\<in>C. A(x) \<union> B)  = (if C=0 then 0 else (\<Inter>x\<in>C. A(x)) \<union> B)"
by (simp_all add: Inter_def, blast+)

lemma INT_simps2:
     "(\<Inter>x\<in>C. A \<inter> B(x)) = A \<inter> (\<Inter>x\<in>C. B(x))"
     "(\<Inter>x\<in>C. A - B(x))   = (if C=0 then 0 else A - (\<Union>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. cons a (B x)) = (if C=0 then 0 else cons a (\<Inter>x\<in>C. B(x)))"
     "(\<Inter>x\<in>C. A \<union> B(x))  = (if C=0 then 0 else A \<union> (\<Inter>x\<in>C. B(x)))"
  by (auto simp add: Inter_def)

lemmas INT_simps [simp] = INT_simps1 INT_simps2

text\<open>Opposite of miniscoping: pull the operator out\<close>

lemma INT_extend_simps1:
     "(\<Inter>x\<in>C. A(x)) \<inter> B = (\<Inter>x\<in>C. A(x) \<inter> B)"
     "(\<Inter>x\<in>C. A(x)) - B = (\<Inter>x\<in>C. A(x) - B)"
     "(\<Inter>x\<in>C. A(x)) \<union> B  = (if C=0 then B else (\<Inter>x\<in>C. A(x) \<union> B))"
  by (auto simp add: Inter_def)

lemma INT_extend_simps2:
     "A \<inter> (\<Inter>x\<in>C. B(x)) = (\<Inter>x\<in>C. A \<inter> B(x))"
     "A - (\<Union>x\<in>C. B(x))   = (if C=0 then A else (\<Inter>x\<in>C. A - B(x)))"
     "cons a (\<Inter>x\<in>C. B(x)) = (if C=0 then {a} else (\<Inter>x\<in>C. cons a (B x)))"
     "A \<union> (\<Inter>x\<in>C. B(x))  = (if C=0 then A else (\<Inter>x\<in>C. A \<union> B(x)))"
  by (auto simp add: Inter_def)

lemmas INT_extend_simps = INT_extend_simps1 INT_extend_simps2

subsection\<open>Other simprules\<close>

(*** Miniscoping: pushing in big Unions, Intersections, quantifiers, etc. ***)

lemma misc_simps [simp]:
     "0 \<union> A = A"
     "A \<union> 0 = A"
     "0 \<inter> A = 0"
     "A \<inter> 0 = 0"
     "0 - A = 0"
     "A - 0 = A"
     "\<Union>(0) = 0"
     "\<Union>(cons b A) = b \<union> \<Union>(A)"
     "\<Inter>({b}) = b"
by blast+

end


(*  Title:      HOL/Datatype_Examples/TreeFI.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Finitely branching possibly infinite trees.
*)

section \<open>Finitely Branching Possibly Infinite Trees\<close>

theory TreeFI
imports MainRLT
begin

codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI list")

(* Tree reverse:*)
primcorec trev where
  "lab (trev t) = lab t"
| "sub (trev t) = map trev (rev (sub t))"

lemma treeFI_coinduct:
  assumes *: "phi x y"
  and step: "\<And>a b. phi a b \<Longrightarrow>
     lab a = lab b \<and>
     length (sub a) = length (sub b) \<and>
     (\<forall>i < length (sub a). phi (nth (sub a) i) (nth (sub b) i))"
  shows "x = y"
using * proof (coinduction arbitrary: x y)
  case (Eq_treeFI t1 t2)
  from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
  have "list_all2 phi (sub t1) (sub t2)"
  proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: list_induct2)
    case (Cons x xs y ys)
    note sub = Cons(3,4)[symmetric] and phi = mp[OF spec[OF Cons(5)], unfolded sub]
      and IH = Cons(2)[of "Tree (lab t1) (tl (sub t1))" "Tree (lab t2) (tl (sub t2))",
        unfolded sub, simplified]
    from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
  qed simp
  with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
qed

lemma trev_trev: "trev (trev tr) = tr"
  by (coinduction arbitrary: tr rule: treeFI_coinduct) (auto simp add: rev_map)

end


section {* Some preliminaries on equivalence relations and quotients *}

theory Equiv_Relation2 imports Preliminaries Pick
begin

text{* Unary predicates vs. sets: *}

definition "S2P A \<equiv> \<lambda> x. x \<in> A"

lemma S2P_app[simp]: "S2P r x \<longleftrightarrow> x \<in> r"
unfolding S2P_def by auto

lemma S2P_Collect[simp]: "S2P (Collect \<phi>) = \<phi>"
apply(rule ext)+ by simp

lemma Collect_S2P[simp]: "Collect (S2P r) = r"
by (metis Collect_mem_eq S2P_Collect)

text{* Binary predicates vs. relatipons: *}
definition "P2R \<phi> \<equiv> {(x,y). \<phi> x y}"
definition "R2P r \<equiv> \<lambda> x y. (x,y) \<in> r"

lemma in_P2R[simp]: "xy \<in> P2R \<phi> \<longleftrightarrow> \<phi> (fst xy) (snd xy)"
unfolding P2R_def by auto

lemma in_P2R_pair[simp]: "(x,y) \<in> P2R \<phi> \<longleftrightarrow> \<phi> x y"
by simp

lemma R2P_app[simp]: "R2P r x y \<longleftrightarrow> (x,y) \<in> r"
unfolding R2P_def by auto

lemma R2P_P2R[simp]: "R2P (P2R \<phi>) = \<phi>"
apply(rule ext)+ by simp

lemma P2R_R2P[simp]: "P2R (R2P r) = r"
using Collect_mem_eq P2R_def R2P_P2R  case_prod_curry by metis

definition "reflP P \<phi> \<equiv> (\<forall> x y. \<phi> x y \<or> \<phi> y x \<longrightarrow> P x) \<and> (\<forall> x. P x \<longrightarrow> \<phi> x x)"
definition "symP \<phi> \<equiv> \<forall> x y. \<phi> x y \<longrightarrow> \<phi> y x"
definition transP where "transP \<phi> \<equiv> \<forall> x y z. \<phi> x y \<and> \<phi> y z \<longrightarrow> \<phi> x z"
definition "equivP A \<phi> \<equiv> reflP A \<phi> \<and> symP \<phi> \<and> transP \<phi>"

lemma refl_on_P2R[simp]: "refl_on (Collect P) (P2R \<phi>) \<longleftrightarrow> reflP P \<phi>"
unfolding reflP_def refl_on_def by force

lemma reflP_R2P[simp]: "reflP (S2P A) (R2P r) \<longleftrightarrow> refl_on A r"
unfolding reflP_def refl_on_def by auto

lemma sym_P2R[simp]: "sym (P2R \<phi>) \<longleftrightarrow> symP \<phi>"
unfolding symP_def sym_def by auto

lemma symP_R2P[simp]: "symP (R2P r) \<longleftrightarrow> sym r"
unfolding symP_def sym_def by auto

lemma trans_P2R[simp]: "trans (P2R \<phi>) \<longleftrightarrow> transP \<phi>"
unfolding transP_def trans_def by auto

lemma transP_R2P[simp]: "transP (R2P r) \<longleftrightarrow> trans r"
unfolding transP_def trans_def by auto

lemma equiv_P2R[simp]: "equiv (Collect P) (P2R \<phi>) \<longleftrightarrow> equivP P \<phi>"
unfolding equivP_def equiv_def by auto

lemma equivP_R2P[simp]: "equivP (S2P A) (R2P r) \<longleftrightarrow> equiv A r"
unfolding equivP_def equiv_def by auto

lemma in_P2R_Im_singl[simp]: "y \<in> P2R \<phi> `` {x} \<longleftrightarrow> \<phi> x y" by simp

definition proj :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a set" where
"proj \<phi> x \<equiv> {y. \<phi> x y}"

lemma proj_P2R: "proj \<phi> x = P2R \<phi> `` {x}" unfolding proj_def by auto

lemma proj_P2R_raw: "proj \<phi> = (\<lambda> x. P2R \<phi> `` {x})"
apply(rule ext) unfolding proj_P2R ..

definition univ :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a set \<Rightarrow> 'b)"
where "univ f X == f (SOME x. x \<in> X)"

definition quotientP ::
"('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a set \<Rightarrow> bool)"  (infixl "'/'/'/" 90)
where "P /// \<phi> \<equiv> S2P ((Collect P) // (P2R \<phi>))"

lemma proj_preserves:
"P x \<Longrightarrow> (P /// \<phi>) (proj \<phi> x)"
unfolding proj_P2R quotientP_def
by (metis S2P_def mem_Collect_eq quotientI)

lemma proj_in_iff:
assumes "equivP P \<phi>"
shows "(P///\<phi>) (proj \<phi> x)  \<longleftrightarrow> P x"
using assms unfolding quotientP_def proj_def
by (metis (mono_tags) Collect_mem_eq Equiv_Relation2.proj_def
  Equiv_Relation2.proj_preserves S2P_Collect empty_Collect_eq equivP_def
  equiv_P2R in_quotient_imp_non_empty quotientP_def reflP_def)

lemma proj_iff[simp]:
"\<lbrakk>equivP P \<phi>; P x; P y\<rbrakk> \<Longrightarrow> proj \<phi> x = proj \<phi> y \<longleftrightarrow> \<phi> x y"
unfolding proj_P2R
by (metis (full_types) equiv_P2R equiv_class_eq_iff equiv_class_self
          in_P2R_pair mem_Collect_eq proj_P2R proj_def)

lemma in_proj[simp]: "\<lbrakk>equivP P \<phi>; P x\<rbrakk> \<Longrightarrow> x \<in> proj \<phi> x"
unfolding proj_P2R equiv_def refl_on_def equiv_P2R[symmetric]
by auto

lemma proj_image[simp]: "(proj \<phi>) ` (Collect P) = Collect (P///\<phi>)"
unfolding proj_P2R_raw quotientP_def quotient_def by auto

lemma in_quotientP_imp_in_rel:
"\<lbrakk>equivP P \<phi>; (P///\<phi>) X; x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> \<phi> x y"
unfolding equiv_P2R[symmetric] quotientP_def quotient_eq_iff
by (metis S2P_def in_P2R_pair quotient_eq_iff)

lemma in_quotientP_imp_closed:
"\<lbrakk>equivP P \<phi>; (P///\<phi>) X; x \<in> X; \<phi> x y\<rbrakk> \<Longrightarrow> y \<in> X"
using S2P_Collect S2P_def equivP_def proj_P2R_raw proj_def
        quotientE quotientP_def transP_def
by metis

lemma in_quotientP_imp_subset:
assumes "equivP P \<phi>" and "(P///\<phi>) X"
shows "X \<subseteq> Collect P"
by (metis (mono_tags, lifting) CollectI assms equivP_def in_quotientP_imp_in_rel reflP_def subsetI)

lemma equivP_pick_in:
assumes  "equivP P \<phi> " and "(P///\<phi>) X"
shows "pick X \<in> X"
by (metis assms in_quotientP_imp_non_empty pick_NE)

lemma equivP_pick_preserves:
assumes  "equivP P \<phi> " and "(P///\<phi>) X"
shows "P (pick X)"
by (metis assms equivP_pick_in in_quotientP_imp_subset mem_Collect_eq set_rev_mp)

lemma proj_pick:
assumes \<phi>: "equivP P \<phi>" and X: "(P///\<phi>) X"
shows "proj \<phi> (pick X) = X"
by (smt proj_def Equiv_Relation2.proj_iff Equiv_Relation2.proj_image X
   \<phi> equivP_pick_in equivP_pick_preserves image_iff mem_Collect_eq)

lemma pick_proj:
assumes "equivP P \<phi>" and "P x"
shows "\<phi> (pick (proj \<phi> x)) x"
by (metis assms equivP_def in_proj mem_Collect_eq pick proj_def symP_def)

lemma equivP_pick_iff[simp]:
assumes \<phi>: "equivP P \<phi>" and X: "(P///\<phi>) X" and Y: "(P///\<phi>) Y"
shows "\<phi> (pick X) (pick Y) \<longleftrightarrow> X = Y"
by (metis Equiv_Relation2.proj_iff X Y \<phi> equivP_pick_preserves proj_pick)

lemma equivP_pick_inj_on:
assumes "equivP P \<phi>"
shows "inj_on pick (Collect (P///\<phi>))"
using assms unfolding inj_on_def
by (metis assms equivP_pick_iff mem_Collect_eq)

definition congruentP where
"congruentP \<phi> f \<equiv> \<forall> x y. \<phi> x y \<longrightarrow> f x = f y"

abbreviation RESPECTS_P (infixr "respectsP" 80) where
"f respectsP r == congruentP r f"

lemma congruent_P2R: "congruent (P2R \<phi>) f = congruentP \<phi> f"
unfolding congruent_def congruentP_def by auto

lemma univ_commute[simp]:
assumes "equivP P \<phi>" and "f respectsP \<phi>" and "P x"
shows "(univ f) (proj \<phi> x) = f x"
unfolding congruent_P2R[symmetric]
by (metis (full_types) assms pick_def congruentP_def pick_proj univ_def)

lemma univ_unique:
assumes "equivP P \<phi>" and "f respectsP \<phi>" and "\<And> x. P x \<Longrightarrow> G (proj \<phi> x) = f x"
shows "\<forall> X. (P///\<phi>) X \<longrightarrow> G X = univ f X"
by (metis assms equivP_pick_preserves proj_pick univ_commute)

lemma univ_preserves:
assumes "equivP P \<phi> " and "f respectsP \<phi>" and "\<And> x. P x \<Longrightarrow> f x \<in> B"
shows "\<forall> X. (P///\<phi>) X \<longrightarrow> univ f X \<in> B"
by (metis Equiv_Relation2.univ_commute assms
          equivP_pick_preserves proj_pick)

end