(*  Title:      ZF/Order.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Results from the book "Set Theory: an Introduction to Independence Proofs"
        by Kenneth Kunen.  Chapter 1, section 6.
Additional definitions and lemmas for reflexive orders.
*)

section\<open>Partial and Total Orderings: Basic Definitions and Properties\<close>

theory Order imports WF Perm begin

text \<open>We adopt the following convention: \<open>ord\<close> is used for
  strict orders and \<open>order\<close> is used for their reflexive
  counterparts.\<close>

definition
  part_ord :: "[i,i]\<Rightarrow>o"                (*Strict partial ordering*)  where
   "part_ord(A,r) \<equiv> irrefl(A,r) \<and> trans[A](r)"

definition
  linear   :: "[i,i]\<Rightarrow>o"                (*Strict total ordering*)  where
   "linear(A,r) \<equiv> (\<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle>:r | x=y | \<langle>y,x\<rangle>:r)"

definition
  tot_ord  :: "[i,i]\<Rightarrow>o"                (*Strict total ordering*)  where
   "tot_ord(A,r) \<equiv> part_ord(A,r) \<and> linear(A,r)"

definition
  "preorder_on(A, r) \<equiv> refl(A, r) \<and> trans[A](r)"

definition                              (*Partial ordering*)
  "partial_order_on(A, r) \<equiv> preorder_on(A, r) \<and> antisym(r)"

abbreviation
  "Preorder(r) \<equiv> preorder_on(field(r), r)"

abbreviation
  "Partial_order(r) \<equiv> partial_order_on(field(r), r)"

definition
  well_ord :: "[i,i]\<Rightarrow>o"                (*Well-ordering*)  where
   "well_ord(A,r) \<equiv> tot_ord(A,r) \<and> wf[A](r)"

definition
  mono_map :: "[i,i,i,i]\<Rightarrow>i"            (*Order-preserving maps*)  where
   "mono_map(A,r,B,s) \<equiv>
              {f \<in> A->B. \<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle>:r \<longrightarrow> <f`x,f`y>:s}"

definition
  ord_iso  :: "[i,i,i,i]\<Rightarrow>i"  (\<open>(\<langle>_, _\<rangle> \<cong>/ \<langle>_, _\<rangle>)\<close> 51)  (*Order isomorphisms*)  where
   "\<langle>A,r\<rangle> \<cong> \<langle>B,s\<rangle> \<equiv>
              {f \<in> bij(A,B). \<forall>x\<in>A. \<forall>y\<in>A. \<langle>x,y\<rangle>:r \<longleftrightarrow> <f`x,f`y>:s}"

definition
  pred     :: "[i,i,i]\<Rightarrow>i"              (*Set of predecessors*)  where
   "pred(A,x,r) \<equiv> {y \<in> A. \<langle>y,x\<rangle>:r}"

definition
  ord_iso_map :: "[i,i,i,i]\<Rightarrow>i"         (*Construction for linearity theorem*)  where
   "ord_iso_map(A,r,B,s) \<equiv>
     \<Union>x\<in>A. \<Union>y\<in>B. \<Union>f \<in> ord_iso(pred(A,x,r), r, pred(B,y,s), s). {\<langle>x,y\<rangle>}"

definition
  first :: "[i, i, i] \<Rightarrow> o"  where
    "first(u, X, R) \<equiv> u \<in> X \<and> (\<forall>v\<in>X. v\<noteq>u \<longrightarrow> \<langle>u,v\<rangle> \<in> R)"

subsection\<open>Immediate Consequences of the Definitions\<close>

lemma part_ord_Imp_asym:
    "part_ord(A,r) \<Longrightarrow> asym(r \<inter> A*A)"
by (unfold part_ord_def irrefl_def trans_on_def asym_def, blast)

lemma linearE:
    "\<lbrakk>linear(A,r);  x \<in> A;  y \<in> A;
        \<langle>x,y\<rangle>:r \<Longrightarrow> P;  x=y \<Longrightarrow> P;  \<langle>y,x\<rangle>:r \<Longrightarrow> P\<rbrakk>
     \<Longrightarrow> P"
by (simp add: linear_def, blast)

(** General properties of well_ord **)

lemma well_ordI:
    "\<lbrakk>wf[A](r); linear(A,r)\<rbrakk> \<Longrightarrow> well_ord(A,r)"
apply (simp add: irrefl_def part_ord_def tot_ord_def
                 trans_on_def well_ord_def wf_on_not_refl)
apply (fast elim: linearE wf_on_asym wf_on_chain3)
done

lemma well_ord_is_wf:
    "well_ord(A,r) \<Longrightarrow> wf[A](r)"
by (unfold well_ord_def, safe)

lemma well_ord_is_trans_on:
    "well_ord(A,r) \<Longrightarrow> trans[A](r)"
by (unfold well_ord_def tot_ord_def part_ord_def, safe)

lemma well_ord_is_linear: "well_ord(A,r) \<Longrightarrow> linear(A,r)"
by (unfold well_ord_def tot_ord_def, blast)

(** Derived rules for pred(A,x,r) **)

lemma pred_iff: "y \<in> pred(A,x,r) \<longleftrightarrow> \<langle>y,x\<rangle>:r \<and> y \<in> A"
by (unfold pred_def, blast)

lemmas predI = conjI [THEN pred_iff [THEN iffD2]]

lemma predE: "\<lbrakk>y \<in> pred(A,x,r);  \<lbrakk>y \<in> A; \<langle>y,x\<rangle>:r\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (simp add: pred_def)

lemma pred_subset_under: "pred(A,x,r) \<subseteq> r -`` {x}"
by (simp add: pred_def, blast)

lemma pred_subset: "pred(A,x,r) \<subseteq> A"
by (simp add: pred_def, blast)

lemma pred_pred_eq:
    "pred(pred(A,x,r), y, r) = pred(A,x,r) \<inter> pred(A,y,r)"
by (simp add: pred_def, blast)

lemma trans_pred_pred_eq:
    "\<lbrakk>trans[A](r);  \<langle>y,x\<rangle>:r;  x \<in> A;  y \<in> A\<rbrakk>
     \<Longrightarrow> pred(pred(A,x,r), y, r) = pred(A,y,r)"
by (unfold trans_on_def pred_def, blast)

subsection\<open>Restricting an Ordering's Domain\<close>

(** The ordering's properties hold over all subsets of its domain
    [including initial segments of the form pred(A,x,r) **)

(*Note: a relation s such that s<=r need not be a partial ordering*)
lemma part_ord_subset:
    "\<lbrakk>part_ord(A,r);  B<=A\<rbrakk> \<Longrightarrow> part_ord(B,r)"
by (unfold part_ord_def irrefl_def trans_on_def, blast)

lemma linear_subset:
    "\<lbrakk>linear(A,r);  B<=A\<rbrakk> \<Longrightarrow> linear(B,r)"
by (unfold linear_def, blast)

lemma tot_ord_subset:
    "\<lbrakk>tot_ord(A,r);  B<=A\<rbrakk> \<Longrightarrow> tot_ord(B,r)"
  unfolding tot_ord_def
apply (fast elim!: part_ord_subset linear_subset)
done

lemma well_ord_subset:
    "\<lbrakk>well_ord(A,r);  B<=A\<rbrakk> \<Longrightarrow> well_ord(B,r)"
  unfolding well_ord_def
apply (fast elim!: tot_ord_subset wf_on_subset_A)
done

(** Relations restricted to a smaller domain, by Krzysztof Grabczewski **)

lemma irrefl_Int_iff: "irrefl(A,r \<inter> A*A) \<longleftrightarrow> irrefl(A,r)"
by (unfold irrefl_def, blast)

lemma trans_on_Int_iff: "trans[A](r \<inter> A*A) \<longleftrightarrow> trans[A](r)"
by (unfold trans_on_def, blast)

lemma part_ord_Int_iff: "part_ord(A,r \<inter> A*A) \<longleftrightarrow> part_ord(A,r)"
  unfolding part_ord_def
apply (simp add: irrefl_Int_iff trans_on_Int_iff)
done

lemma linear_Int_iff: "linear(A,r \<inter> A*A) \<longleftrightarrow> linear(A,r)"
by (unfold linear_def, blast)

lemma tot_ord_Int_iff: "tot_ord(A,r \<inter> A*A) \<longleftrightarrow> tot_ord(A,r)"
  unfolding tot_ord_def
apply (simp add: part_ord_Int_iff linear_Int_iff)
done

lemma wf_on_Int_iff: "wf[A](r \<inter> A*A) \<longleftrightarrow> wf[A](r)"
apply (unfold wf_on_def wf_def, fast) (*10 times faster than blast!*)
done

lemma well_ord_Int_iff: "well_ord(A,r \<inter> A*A) \<longleftrightarrow> well_ord(A,r)"
  unfolding well_ord_def
apply (simp add: tot_ord_Int_iff wf_on_Int_iff)
done

subsection\<open>Empty and Unit Domains\<close>

(*The empty relation is well-founded*)
lemma wf_on_any_0: "wf[A](0)"
by (simp add: wf_on_def wf_def, fast)

subsubsection\<open>Relations over the Empty Set\<close>

lemma irrefl_0: "irrefl(0,r)"
by (unfold irrefl_def, blast)

lemma trans_on_0: "trans[0](r)"
by (unfold trans_on_def, blast)

lemma part_ord_0: "part_ord(0,r)"
  unfolding part_ord_def
apply (simp add: irrefl_0 trans_on_0)
done

lemma linear_0: "linear(0,r)"
by (unfold linear_def, blast)

lemma tot_ord_0: "tot_ord(0,r)"
  unfolding tot_ord_def
apply (simp add: part_ord_0 linear_0)
done

lemma wf_on_0: "wf[0](r)"
by (unfold wf_on_def wf_def, blast)

lemma well_ord_0: "well_ord(0,r)"
  unfolding well_ord_def
apply (simp add: tot_ord_0 wf_on_0)
done

subsubsection\<open>The Empty Relation Well-Orders the Unit Set\<close>

text\<open>by Grabczewski\<close>

lemma tot_ord_unit: "tot_ord({a},0)"
by (simp add: irrefl_def trans_on_def part_ord_def linear_def tot_ord_def)

lemma well_ord_unit: "well_ord({a},0)"
  unfolding well_ord_def
apply (simp add: tot_ord_unit wf_on_any_0)
done

subsection\<open>Order-Isomorphisms\<close>

text\<open>Suppes calls them "similarities"\<close>

(** Order-preserving (monotone) maps **)

lemma mono_map_is_fun: "f \<in> mono_map(A,r,B,s) \<Longrightarrow> f \<in> A->B"
by (simp add: mono_map_def)

lemma mono_map_is_inj:
    "\<lbrakk>linear(A,r);  wf[B](s);  f \<in> mono_map(A,r,B,s)\<rbrakk> \<Longrightarrow> f \<in> inj(A,B)"
apply (unfold mono_map_def inj_def, clarify)
apply (erule_tac x=w and y=x in linearE, assumption+)
apply (force intro: apply_type dest: wf_on_not_refl)+
done

lemma ord_isoI:
    "\<lbrakk>f \<in> bij(A, B);
        \<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<langle>x, y\<rangle> \<in> r \<longleftrightarrow> <f`x, f`y> \<in> s\<rbrakk>
     \<Longrightarrow> f \<in> ord_iso(A,r,B,s)"
by (simp add: ord_iso_def)

lemma ord_iso_is_mono_map:
    "f \<in> ord_iso(A,r,B,s) \<Longrightarrow> f \<in> mono_map(A,r,B,s)"
apply (simp add: ord_iso_def mono_map_def)
apply (blast dest!: bij_is_fun)
done

lemma ord_iso_is_bij:
    "f \<in> ord_iso(A,r,B,s) \<Longrightarrow> f \<in> bij(A,B)"
by (simp add: ord_iso_def)

(*Needed?  But ord_iso_converse is!*)
lemma ord_iso_apply:
    "\<lbrakk>f \<in> ord_iso(A,r,B,s);  \<langle>x,y\<rangle>: r;  x \<in> A;  y \<in> A\<rbrakk> \<Longrightarrow> <f`x, f`y> \<in> s"
by (simp add: ord_iso_def)

lemma ord_iso_converse:
    "\<lbrakk>f \<in> ord_iso(A,r,B,s);  \<langle>x,y\<rangle>: s;  x \<in> B;  y \<in> B\<rbrakk>
     \<Longrightarrow> <converse(f) ` x, converse(f) ` y> \<in> r"
apply (simp add: ord_iso_def, clarify)
apply (erule bspec [THEN bspec, THEN iffD2])
apply (erule asm_rl bij_converse_bij [THEN bij_is_fun, THEN apply_type])+
apply (auto simp add: right_inverse_bij)
done

(** Symmetry and Transitivity Rules **)

(*Reflexivity of similarity*)
lemma ord_iso_refl: "id(A): ord_iso(A,r,A,r)"
by (rule id_bij [THEN ord_isoI], simp)

(*Symmetry of similarity*)
lemma ord_iso_sym: "f \<in> ord_iso(A,r,B,s) \<Longrightarrow> converse(f): ord_iso(B,s,A,r)"
apply (simp add: ord_iso_def)
apply (auto simp add: right_inverse_bij bij_converse_bij
                      bij_is_fun [THEN apply_funtype])
done

(*Transitivity of similarity*)
lemma mono_map_trans:
    "\<lbrakk>g \<in> mono_map(A,r,B,s);  f \<in> mono_map(B,s,C,t)\<rbrakk>
     \<Longrightarrow> (f O g): mono_map(A,r,C,t)"
  unfolding mono_map_def
apply (auto simp add: comp_fun)
done

(*Transitivity of similarity: the order-isomorphism relation*)
lemma ord_iso_trans:
    "\<lbrakk>g \<in> ord_iso(A,r,B,s);  f \<in> ord_iso(B,s,C,t)\<rbrakk>
     \<Longrightarrow> (f O g): ord_iso(A,r,C,t)"
apply (unfold ord_iso_def, clarify)
apply (frule bij_is_fun [of f])
apply (frule bij_is_fun [of g])
apply (auto simp add: comp_bij)
done

(** Two monotone maps can make an order-isomorphism **)

lemma mono_ord_isoI:
    "\<lbrakk>f \<in> mono_map(A,r,B,s);  g \<in> mono_map(B,s,A,r);
        f O g = id(B);  g O f = id(A)\<rbrakk> \<Longrightarrow> f \<in> ord_iso(A,r,B,s)"
apply (simp add: ord_iso_def mono_map_def, safe)
apply (intro fg_imp_bijective, auto)
apply (subgoal_tac "<g` (f`x), g` (f`y) > \<in> r")
apply (simp add: comp_eq_id_iff [THEN iffD1])
apply (blast intro: apply_funtype)
done

lemma well_ord_mono_ord_isoI:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s);
         f \<in> mono_map(A,r,B,s);  converse(f): mono_map(B,s,A,r)\<rbrakk>
      \<Longrightarrow> f \<in> ord_iso(A,r,B,s)"
apply (intro mono_ord_isoI, auto)
apply (frule mono_map_is_fun [THEN fun_is_rel])
apply (erule converse_converse [THEN subst], rule left_comp_inverse)
apply (blast intro: left_comp_inverse mono_map_is_inj well_ord_is_linear
                    well_ord_is_wf)+
done

(** Order-isomorphisms preserve the ordering's properties **)

lemma part_ord_ord_iso:
    "\<lbrakk>part_ord(B,s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> part_ord(A,r)"
apply (simp add: part_ord_def irrefl_def trans_on_def ord_iso_def)
apply (fast intro: bij_is_fun [THEN apply_type])
done

lemma linear_ord_iso:
    "\<lbrakk>linear(B,s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> linear(A,r)"
apply (simp add: linear_def ord_iso_def, safe)
apply (drule_tac x1 = "f`x" and x = "f`y" in bspec [THEN bspec])
apply (safe elim!: bij_is_fun [THEN apply_type])
apply (drule_tac t = "(`) (converse (f))" in subst_context)
apply (simp add: left_inverse_bij)
done

lemma wf_on_ord_iso:
    "\<lbrakk>wf[B](s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> wf[A](r)"
apply (simp add: wf_on_def wf_def ord_iso_def, safe)
apply (drule_tac x = "{f`z. z \<in> Z \<inter> A}" in spec)
apply (safe intro!: equalityI)
apply (blast dest!: equalityD1 intro: bij_is_fun [THEN apply_type])+
done

lemma well_ord_ord_iso:
    "\<lbrakk>well_ord(B,s);  f \<in> ord_iso(A,r,B,s)\<rbrakk> \<Longrightarrow> well_ord(A,r)"
  unfolding well_ord_def tot_ord_def
apply (fast elim!: part_ord_ord_iso linear_ord_iso wf_on_ord_iso)
done

subsection\<open>Main results of Kunen, Chapter 1 section 6\<close>

(*Inductive argument for Kunen's Lemma 6.1, etc.
  Simple proof from Halmos, page 72*)
lemma well_ord_iso_subset_lemma:
     "\<lbrakk>well_ord(A,r);  f \<in> ord_iso(A,r, A',r);  A'<= A;  y \<in> A\<rbrakk>
      \<Longrightarrow> \<not> <f`y, y>: r"
apply (simp add: well_ord_def ord_iso_def)
apply (elim conjE CollectE)
apply (rule_tac a=y in wf_on_induct, assumption+)
apply (blast dest: bij_is_fun [THEN apply_type])
done

(*Kunen's Lemma 6.1 \<in> there's no order-isomorphism to an initial segment
                     of a well-ordering*)
lemma well_ord_iso_predE:
     "\<lbrakk>well_ord(A,r);  f \<in> ord_iso(A, r, pred(A,x,r), r);  x \<in> A\<rbrakk> \<Longrightarrow> P"
apply (insert well_ord_iso_subset_lemma [of A r f "pred(A,x,r)" x])
apply (simp add: pred_subset)
(*Now we know  f`x < x *)
apply (drule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
(*Now we also know @{term"f`x \<in> pred(A,x,r)"}: contradiction! *)
apply (simp add: well_ord_def pred_def)
done

(*Simple consequence of Lemma 6.1*)
lemma well_ord_iso_pred_eq:
     "\<lbrakk>well_ord(A,r);  f \<in> ord_iso(pred(A,a,r), r, pred(A,c,r), r);
         a \<in> A;  c \<in> A\<rbrakk> \<Longrightarrow> a=c"
apply (frule well_ord_is_trans_on)
apply (frule well_ord_is_linear)
apply (erule_tac x=a and y=c in linearE, assumption+)
apply (drule ord_iso_sym)
(*two symmetric cases*)
apply (auto elim!: well_ord_subset [OF _ pred_subset, THEN well_ord_iso_predE]
            intro!: predI
            simp add: trans_pred_pred_eq)
done

(*Does not assume r is a wellordering!*)
lemma ord_iso_image_pred:
     "\<lbrakk>f \<in> ord_iso(A,r,B,s);  a \<in> A\<rbrakk> \<Longrightarrow> f `` pred(A,a,r) = pred(B, f`a, s)"
  unfolding ord_iso_def pred_def
apply (erule CollectE)
apply (simp (no_asm_simp) add: image_fun [OF bij_is_fun Collect_subset])
apply (rule equalityI)
apply (safe elim!: bij_is_fun [THEN apply_type])
apply (rule RepFun_eqI)
apply (blast intro!: right_inverse_bij [symmetric])
apply (auto simp add: right_inverse_bij  bij_is_fun [THEN apply_funtype])
done

lemma ord_iso_restrict_image:
     "\<lbrakk>f \<in> ord_iso(A,r,B,s);  C<=A\<rbrakk>
      \<Longrightarrow> restrict(f,C) \<in> ord_iso(C, r, f``C, s)"
apply (simp add: ord_iso_def)
apply (blast intro: bij_is_inj restrict_bij)
done

(*But in use, A and B may themselves be initial segments.  Then use
  trans_pred_pred_eq to simplify the pred(pred...) terms.  See just below.*)
lemma ord_iso_restrict_pred:
   "\<lbrakk>f \<in> ord_iso(A,r,B,s);   a \<in> A\<rbrakk>
    \<Longrightarrow> restrict(f, pred(A,a,r)) \<in> ord_iso(pred(A,a,r), r, pred(B, f`a, s), s)"
apply (simp add: ord_iso_image_pred [symmetric])
apply (blast intro: ord_iso_restrict_image elim: predE)
done

(*Tricky; a lot of forward proof!*)
lemma well_ord_iso_preserving:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s);  \<langle>a,c\<rangle>: r;
         f \<in> ord_iso(pred(A,a,r), r, pred(B,b,s), s);
         g \<in> ord_iso(pred(A,c,r), r, pred(B,d,s), s);
         a \<in> A;  c \<in> A;  b \<in> B;  d \<in> B\<rbrakk> \<Longrightarrow> \<langle>b,d\<rangle>: s"
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], (erule asm_rl predI predE)+)
apply (subgoal_tac "b = g`a")
apply (simp (no_asm_simp))
apply (rule well_ord_iso_pred_eq, auto)
apply (frule ord_iso_restrict_pred, (erule asm_rl predI)+)
apply (simp add: well_ord_is_trans_on trans_pred_pred_eq)
apply (erule ord_iso_sym [THEN ord_iso_trans], assumption)
done

(*See Halmos, page 72*)
lemma well_ord_iso_unique_lemma:
     "\<lbrakk>well_ord(A,r);
         f \<in> ord_iso(A,r, B,s);  g \<in> ord_iso(A,r, B,s);  y \<in> A\<rbrakk>
      \<Longrightarrow> \<not> <g`y, f`y> \<in> s"
apply (frule well_ord_iso_subset_lemma)
apply (rule_tac f = "converse (f) " and g = g in ord_iso_trans)
apply auto
apply (blast intro: ord_iso_sym)
apply (frule ord_iso_is_bij [of f])
apply (frule ord_iso_is_bij [of g])
apply (frule ord_iso_converse)
apply (blast intro!: bij_converse_bij
             intro: bij_is_fun apply_funtype)+
apply (erule notE)
apply (simp add: left_inverse_bij bij_is_fun comp_fun_apply [of _ A B])
done

(*Kunen's Lemma 6.2: Order-isomorphisms between well-orderings are unique*)
lemma well_ord_iso_unique: "\<lbrakk>well_ord(A,r);
         f \<in> ord_iso(A,r, B,s);  g \<in> ord_iso(A,r, B,s)\<rbrakk> \<Longrightarrow> f = g"
apply (rule fun_extension)
apply (erule ord_iso_is_bij [THEN bij_is_fun])+
apply (subgoal_tac "f`x \<in> B \<and> g`x \<in> B \<and> linear(B,s)")
 apply (simp add: linear_def)
 apply (blast dest: well_ord_iso_unique_lemma)
apply (blast intro: ord_iso_is_bij bij_is_fun apply_funtype
                    well_ord_is_linear well_ord_ord_iso ord_iso_sym)
done

subsection\<open>Towards Kunen's Theorem 6.3: Linearity of the Similarity Relation\<close>

lemma ord_iso_map_subset: "ord_iso_map(A,r,B,s) \<subseteq> A*B"
by (unfold ord_iso_map_def, blast)

lemma domain_ord_iso_map: "domain(ord_iso_map(A,r,B,s)) \<subseteq> A"
by (unfold ord_iso_map_def, blast)

lemma range_ord_iso_map: "range(ord_iso_map(A,r,B,s)) \<subseteq> B"
by (unfold ord_iso_map_def, blast)

lemma converse_ord_iso_map:
    "converse(ord_iso_map(A,r,B,s)) = ord_iso_map(B,s,A,r)"
  unfolding ord_iso_map_def
apply (blast intro: ord_iso_sym)
done

lemma function_ord_iso_map:
    "well_ord(B,s) \<Longrightarrow> function(ord_iso_map(A,r,B,s))"
  unfolding ord_iso_map_def function_def
apply (blast intro: well_ord_iso_pred_eq ord_iso_sym ord_iso_trans)
done

lemma ord_iso_map_fun: "well_ord(B,s) \<Longrightarrow> ord_iso_map(A,r,B,s)
           \<in> domain(ord_iso_map(A,r,B,s)) -> range(ord_iso_map(A,r,B,s))"
by (simp add: Pi_iff function_ord_iso_map
                 ord_iso_map_subset [THEN domain_times_range])

lemma ord_iso_map_mono_map:
    "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
     \<Longrightarrow> ord_iso_map(A,r,B,s)
           \<in> mono_map(domain(ord_iso_map(A,r,B,s)), r,
                      range(ord_iso_map(A,r,B,s)), s)"
  unfolding mono_map_def
apply (simp (no_asm_simp) add: ord_iso_map_fun)
apply safe
apply (subgoal_tac "x \<in> A \<and> ya:A \<and> y \<in> B \<and> yb:B")
 apply (simp add: apply_equality [OF _  ord_iso_map_fun])
   unfolding ord_iso_map_def
 apply (blast intro: well_ord_iso_preserving, blast)
done

lemma ord_iso_map_ord_iso:
    "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk> \<Longrightarrow> ord_iso_map(A,r,B,s)
           \<in> ord_iso(domain(ord_iso_map(A,r,B,s)), r,
                      range(ord_iso_map(A,r,B,s)), s)"
apply (rule well_ord_mono_ord_isoI)
   prefer 4
   apply (rule converse_ord_iso_map [THEN subst])
   apply (simp add: ord_iso_map_mono_map
                    ord_iso_map_subset [THEN converse_converse])
apply (blast intro!: domain_ord_iso_map range_ord_iso_map
             intro: well_ord_subset ord_iso_map_mono_map)+
done

(*One way of saying that domain(ord_iso_map(A,r,B,s)) is downwards-closed*)
lemma domain_ord_iso_map_subset:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s);
         a \<in> A;  a \<notin> domain(ord_iso_map(A,r,B,s))\<rbrakk>
      \<Longrightarrow>  domain(ord_iso_map(A,r,B,s)) \<subseteq> pred(A, a, r)"
  unfolding ord_iso_map_def
apply (safe intro!: predI)
(*Case analysis on  xa vs a in r *)
apply (simp (no_asm_simp))
apply (frule_tac A = A in well_ord_is_linear)
apply (rename_tac b y f)
apply (erule_tac x=b and y=a in linearE, assumption+)
(*Trivial case: b=a*)
apply clarify
apply blast
(*Harder case: \<langle>a, xa\<rangle>: r*)
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type],
       (erule asm_rl predI predE)+)
apply (frule ord_iso_restrict_pred)
 apply (simp add: pred_iff)
apply (simp split: split_if_asm
          add: well_ord_is_trans_on trans_pred_pred_eq domain_UN domain_Union, blast)
done

(*For the 4-way case analysis in the main result*)
lemma domain_ord_iso_map_cases:
     "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
      \<Longrightarrow> domain(ord_iso_map(A,r,B,s)) = A |
          (\<exists>x\<in>A. domain(ord_iso_map(A,r,B,s)) = pred(A,x,r))"
apply (frule well_ord_is_wf)
  unfolding wf_on_def wf_def
apply (drule_tac x = "A-domain (ord_iso_map (A,r,B,s))" in spec)
apply safe
(*The first case: the domain equals A*)
apply (rule domain_ord_iso_map [THEN equalityI])
apply (erule Diff_eq_0_iff [THEN iffD1])
(*The other case: the domain equals an initial segment*)
apply (blast del: domainI subsetI
             elim!: predE
             intro!: domain_ord_iso_map_subset
             intro: subsetI)+
done

(*As above, by duality*)
lemma range_ord_iso_map_cases:
    "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
     \<Longrightarrow> range(ord_iso_map(A,r,B,s)) = B |
         (\<exists>y\<in>B. range(ord_iso_map(A,r,B,s)) = pred(B,y,s))"
apply (rule converse_ord_iso_map [THEN subst])
apply (simp add: domain_ord_iso_map_cases)
done

text\<open>Kunen's Theorem 6.3: Fundamental Theorem for Well-Ordered Sets\<close>
theorem well_ord_trichotomy:
   "\<lbrakk>well_ord(A,r);  well_ord(B,s)\<rbrakk>
    \<Longrightarrow> ord_iso_map(A,r,B,s) \<in> ord_iso(A, r, B, s) |
        (\<exists>x\<in>A. ord_iso_map(A,r,B,s) \<in> ord_iso(pred(A,x,r), r, B, s)) |
        (\<exists>y\<in>B. ord_iso_map(A,r,B,s) \<in> ord_iso(A, r, pred(B,y,s), s))"
apply (frule_tac B = B in domain_ord_iso_map_cases, assumption)
apply (frule_tac B = B in range_ord_iso_map_cases, assumption)
apply (drule ord_iso_map_ord_iso, assumption)
apply (elim disjE bexE)
   apply (simp_all add: bexI)
apply (rule wf_on_not_refl [THEN notE])
  apply (erule well_ord_is_wf)
 apply assumption
apply (subgoal_tac "\<langle>x,y\<rangle>: ord_iso_map (A,r,B,s) ")
 apply (drule rangeI)
 apply (simp add: pred_def)
apply (unfold ord_iso_map_def, blast)
done

subsection\<open>Miscellaneous Results by Krzysztof Grabczewski\<close>

(** Properties of converse(r) **)

lemma irrefl_converse: "irrefl(A,r) \<Longrightarrow> irrefl(A,converse(r))"
by (unfold irrefl_def, blast)

lemma trans_on_converse: "trans[A](r) \<Longrightarrow> trans[A](converse(r))"
by (unfold trans_on_def, blast)

lemma part_ord_converse: "part_ord(A,r) \<Longrightarrow> part_ord(A,converse(r))"
  unfolding part_ord_def
apply (blast intro!: irrefl_converse trans_on_converse)
done

lemma linear_converse: "linear(A,r) \<Longrightarrow> linear(A,converse(r))"
by (unfold linear_def, blast)

lemma tot_ord_converse: "tot_ord(A,r) \<Longrightarrow> tot_ord(A,converse(r))"
  unfolding tot_ord_def
apply (blast intro!: part_ord_converse linear_converse)
done

(** By Krzysztof Grabczewski.
    Lemmas involving the first element of a well ordered set **)

lemma first_is_elem: "first(b,B,r) \<Longrightarrow> b \<in> B"
by (unfold first_def, blast)

lemma well_ord_imp_ex1_first:
        "\<lbrakk>well_ord(A,r); B<=A; B\<noteq>0\<rbrakk> \<Longrightarrow> (\<exists>!b. first(b,B,r))"
  unfolding well_ord_def wf_on_def wf_def first_def
apply (elim conjE allE disjE, blast)
apply (erule bexE)
apply (rule_tac a = x in ex1I, auto)
apply (unfold tot_ord_def linear_def, blast)
done

lemma the_first_in:
     "\<lbrakk>well_ord(A,r); B<=A; B\<noteq>0\<rbrakk> \<Longrightarrow> (THE b. first(b,B,r)) \<in> B"
apply (drule well_ord_imp_ex1_first, assumption+)
apply (rule first_is_elem)
apply (erule theI)
done

subsection \<open>Lemmas for the Reflexive Orders\<close>

lemma subset_vimage_vimage_iff:
  "\<lbrakk>Preorder(r); A \<subseteq> field(r); B \<subseteq> field(r)\<rbrakk> \<Longrightarrow>
  r -`` A \<subseteq> r -`` B \<longleftrightarrow> (\<forall>a\<in>A. \<exists>b\<in>B. \<langle>a, b\<rangle> \<in> r)"
  apply (auto simp: subset_def preorder_on_def refl_def vimage_def image_def)
   apply blast
  unfolding trans_on_def
  apply (erule_tac P = "(\<lambda>x. \<forall>y\<in>field(r).
          \<forall>z\<in>field(r). \<langle>x, y\<rangle> \<in> r \<longrightarrow> \<langle>y, z\<rangle> \<in> r \<longrightarrow> \<langle>x, z\<rangle> \<in> r)" for r in rev_ballE)
    (* instance obtained from proof term generated by best *)
   apply best
  apply blast
  done

lemma subset_vimage1_vimage1_iff:
  "\<lbrakk>Preorder(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
  r -`` {a} \<subseteq> r -`` {b} \<longleftrightarrow> \<langle>a, b\<rangle> \<in> r"
  by (simp add: subset_vimage_vimage_iff)

lemma Refl_antisym_eq_Image1_Image1_iff:
  "\<lbrakk>refl(field(r), r); antisym(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
  r `` {a} = r `` {b} \<longleftrightarrow> a = b"
  apply rule
   apply (frule equality_iffD)
   apply (drule equality_iffD)
   apply (simp add: antisym_def refl_def)
   apply best
  apply (simp add: antisym_def refl_def)
  done

lemma Partial_order_eq_Image1_Image1_iff:
  "\<lbrakk>Partial_order(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
  r `` {a} = r `` {b} \<longleftrightarrow> a = b"
  by (simp add: partial_order_on_def preorder_on_def
    Refl_antisym_eq_Image1_Image1_iff)

lemma Refl_antisym_eq_vimage1_vimage1_iff:
  "\<lbrakk>refl(field(r), r); antisym(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
  r -`` {a} = r -`` {b} \<longleftrightarrow> a = b"
  apply rule
   apply (frule equality_iffD)
   apply (drule equality_iffD)
   apply (simp add: antisym_def refl_def)
   apply best
  apply (simp add: antisym_def refl_def)
  done

lemma Partial_order_eq_vimage1_vimage1_iff:
  "\<lbrakk>Partial_order(r); a \<in> field(r); b \<in> field(r)\<rbrakk> \<Longrightarrow>
  r -`` {a} = r -`` {b} \<longleftrightarrow> a = b"
  by (simp add: partial_order_on_def preorder_on_def
    Refl_antisym_eq_vimage1_vimage1_iff)

end


section\<open>Arities of internalized formulas\<close>
theory Arities
  imports FrecR
begin

lemma arity_upair_fm : "\<lbrakk>  t1\<in>nat ; t2\<in>nat ; up\<in>nat  \<rbrakk> \<Longrightarrow>
  arity(upair_fm(t1,t2,up)) = \<Union> {succ(t1),succ(t2),succ(up)}"
  unfolding  upair_fm_def
  using nat_union_abs1 nat_union_abs2 pred_Un
  by auto

lemma arity_pair_fm : "\<lbrakk>  t1\<in>nat ; t2\<in>nat ; p\<in>nat  \<rbrakk> \<Longrightarrow>
  arity(pair_fm(t1,t2,p)) = \<Union> {succ(t1),succ(t2),succ(p)}"
  unfolding pair_fm_def
  using arity_upair_fm nat_union_abs1 nat_union_abs2 pred_Un
  by auto

lemma arity_composition_fm :
  "\<lbrakk> r\<in>nat ; s\<in>nat ; t\<in>nat \<rbrakk> \<Longrightarrow> arity(composition_fm(r,s,t)) = \<Union> {succ(r), succ(s), succ(t)}"
  unfolding composition_fm_def
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_domain_fm :
    "\<lbrakk> r\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(domain_fm(r,z)) = succ(r) \<union> succ(z)"
  unfolding domain_fm_def
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_range_fm :
    "\<lbrakk> r\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(range_fm(r,z)) = succ(r) \<union> succ(z)"
  unfolding range_fm_def
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_union_fm :
  "\<lbrakk> x\<in>nat ; y\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(union_fm(x,y,z)) = \<Union> {succ(x), succ(y), succ(z)}"
  unfolding union_fm_def
  using  nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_image_fm :
  "\<lbrakk> x\<in>nat ; y\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(image_fm(x,y,z)) = \<Union> {succ(x), succ(y), succ(z)}"
  unfolding image_fm_def
  using arity_pair_fm  nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_pre_image_fm :
  "\<lbrakk> x\<in>nat ; y\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(pre_image_fm(x,y,z)) = \<Union> {succ(x), succ(y), succ(z)}"
  unfolding pre_image_fm_def
  using arity_pair_fm  nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_big_union_fm :
  "\<lbrakk> x\<in>nat ; y\<in>nat \<rbrakk> \<Longrightarrow> arity(big_union_fm(x,y)) = succ(x) \<union> succ(y)"
  unfolding big_union_fm_def
  using nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_fun_apply_fm :
  "\<lbrakk> x\<in>nat ; y\<in>nat ; f\<in>nat \<rbrakk> \<Longrightarrow>
    arity(fun_apply_fm(f,x,y)) =  succ(f) \<union> succ(x) \<union> succ(y)"
  unfolding fun_apply_fm_def
  using arity_upair_fm arity_image_fm arity_big_union_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_field_fm :
    "\<lbrakk> r\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(field_fm(r,z)) = succ(r) \<union> succ(z)"
  unfolding field_fm_def
  using arity_pair_fm arity_domain_fm arity_range_fm arity_union_fm
    nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_empty_fm :
    "\<lbrakk> r\<in>nat \<rbrakk> \<Longrightarrow> arity(empty_fm(r)) = succ(r)"
  unfolding empty_fm_def
  using nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_succ_fm :
  "\<lbrakk>x\<in>nat;y\<in>nat\<rbrakk> \<Longrightarrow> arity(succ_fm(x,y)) = succ(x) \<union> succ(y)"
  unfolding succ_fm_def cons_fm_def
  using arity_upair_fm arity_union_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma number1arity__fm :
    "\<lbrakk> r\<in>nat \<rbrakk> \<Longrightarrow> arity(number1_fm(r)) = succ(r)"
  unfolding number1_fm_def
  using arity_empty_fm arity_succ_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_function_fm :
    "\<lbrakk> r\<in>nat \<rbrakk> \<Longrightarrow> arity(function_fm(r)) = succ(r)"
  unfolding function_fm_def
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_relation_fm :
    "\<lbrakk> r\<in>nat \<rbrakk> \<Longrightarrow> arity(relation_fm(r)) = succ(r)"
  unfolding relation_fm_def
  using arity_pair_fm nat_union_abs1 nat_union_abs2 pred_Un_distrib
  by simp

lemma arity_restriction_fm :
    "\<lbrakk> r\<in>nat ; z\<in>nat ; A\<in>nat \<rbrakk> \<Longrightarrow> arity(restriction_fm(A,z,r)) = succ(A) \<union> succ(r) \<union> succ(z)"
  unfolding restriction_fm_def
  using arity_pair_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_typed_function_fm :
  "\<lbrakk> x\<in>nat ; y\<in>nat ; f\<in>nat \<rbrakk> \<Longrightarrow>
    arity(typed_function_fm(f,x,y)) = \<Union> {succ(f), succ(x), succ(y)}"
  unfolding typed_function_fm_def
  using arity_pair_fm arity_relation_fm arity_function_fm arity_domain_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_subset_fm :
  "\<lbrakk>x\<in>nat ; y\<in>nat\<rbrakk> \<Longrightarrow> arity(subset_fm(x,y)) = succ(x) \<union> succ(y)"
  unfolding subset_fm_def
  using nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_transset_fm :
  "\<lbrakk>x\<in>nat\<rbrakk> \<Longrightarrow> arity(transset_fm(x)) = succ(x)"
  unfolding transset_fm_def
  using arity_subset_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_ordinal_fm :
  "\<lbrakk>x\<in>nat\<rbrakk> \<Longrightarrow> arity(ordinal_fm(x)) = succ(x)"
  unfolding ordinal_fm_def
  using arity_transset_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_limit_ordinal_fm :
  "\<lbrakk>x\<in>nat\<rbrakk> \<Longrightarrow> arity(limit_ordinal_fm(x)) = succ(x)"
  unfolding limit_ordinal_fm_def
  using arity_ordinal_fm arity_succ_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_finite_ordinal_fm :
  "\<lbrakk>x\<in>nat\<rbrakk> \<Longrightarrow> arity(finite_ordinal_fm(x)) = succ(x)"
  unfolding finite_ordinal_fm_def
  using arity_ordinal_fm arity_limit_ordinal_fm arity_succ_fm arity_empty_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_omega_fm :
  "\<lbrakk>x\<in>nat\<rbrakk> \<Longrightarrow> arity(omega_fm(x)) = succ(x)"
  unfolding omega_fm_def
  using arity_limit_ordinal_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_cartprod_fm :
  "\<lbrakk> A\<in>nat ; B\<in>nat ; z\<in>nat \<rbrakk> \<Longrightarrow> arity(cartprod_fm(A,B,z)) = succ(A) \<union> succ(B) \<union> succ(z)"
  unfolding cartprod_fm_def
  using arity_pair_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_fst_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(fst_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding fst_fm_def
  using arity_pair_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_snd_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(snd_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding snd_fm_def
  using arity_pair_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_snd_snd_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(snd_snd_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding snd_snd_fm_def hcomp_fm_def
  using arity_snd_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_ftype_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(ftype_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding ftype_fm_def
  using arity_fst_fm
  by auto

lemma name1arity__fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(name1_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding name1_fm_def hcomp_fm_def
  using arity_fst_fm arity_snd_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma name2arity__fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(name2_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding name2_fm_def hcomp_fm_def
  using arity_fst_fm arity_snd_snd_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_cond_of_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(cond_of_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding cond_of_fm_def hcomp_fm_def
  using arity_snd_fm arity_snd_snd_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_singleton_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(singleton_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding singleton_fm_def cons_fm_def
  using arity_union_fm arity_upair_fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_Memrel_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(Memrel_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding Memrel_fm_def
  using  arity_pair_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_quasinat_fm :
  "\<lbrakk>x\<in>nat\<rbrakk> \<Longrightarrow> arity(quasinat_fm(x)) = succ(x)"
  unfolding quasinat_fm_def cons_fm_def
  using arity_succ_fm arity_empty_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_is_recfun_fm :
  "\<lbrakk>p\<in>formula ; v\<in>nat ; n\<in>nat; Z\<in>nat;i\<in>nat\<rbrakk> \<Longrightarrow>  arity(p) = i \<Longrightarrow>
  arity(is_recfun_fm(p,v,n,Z)) = succ(v) \<union> succ(n) \<union> succ(Z) \<union> pred(pred(pred(pred(i))))"
  unfolding is_recfun_fm_def
  using arity_upair_fm arity_pair_fm arity_pre_image_fm arity_restriction_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_is_wfrec_fm :
  "\<lbrakk>p\<in>formula ; v\<in>nat ; n\<in>nat; Z\<in>nat ; i\<in>nat\<rbrakk> \<Longrightarrow> arity(p) = i \<Longrightarrow>
    arity(is_wfrec_fm(p,v,n,Z)) = succ(v) \<union> succ(n) \<union> succ(Z) \<union> pred(pred(pred(pred(pred(i)))))"
  unfolding is_wfrec_fm_def
  using arity_succ_fm  arity_is_recfun_fm
     nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_is_nat_case_fm :
  "\<lbrakk>p\<in>formula ; v\<in>nat ; n\<in>nat; Z\<in>nat; i\<in>nat\<rbrakk> \<Longrightarrow> arity(p) = i \<Longrightarrow>
    arity(is_nat_case_fm(v,p,n,Z)) = succ(v) \<union> succ(n) \<union> succ(Z) \<union> pred(pred(i))"
  unfolding is_nat_case_fm_def
  using arity_succ_fm arity_empty_fm arity_quasinat_fm
    nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_iterates_MH_fm :
  assumes "isF\<in>formula" "v\<in>nat" "n\<in>nat" "g\<in>nat" "z\<in>nat" "i\<in>nat"
      "arity(isF) = i"
    shows "arity(iterates_MH_fm(isF,v,n,g,z)) =
           succ(v) \<union> succ(n) \<union> succ(g) \<union> succ(z) \<union> pred(pred(pred(pred(i))))"
proof -
  let ?\<phi> = "Exists(And(fun_apply_fm(succ(succ(succ(g))), 2, 0), Forall(Implies(Equal(0, 2), isF))))"
  let ?ar = "succ(succ(succ(g))) \<union> pred(pred(i))"
  from assms
  have "arity(?\<phi>) =?ar" "?\<phi>\<in>formula"
    using arity_fun_apply_fm
    nat_union_abs1 nat_union_abs2 pred_Un_distrib succ_Un_distrib Un_assoc[symmetric]
    by simp_all
  then
  show ?thesis
    unfolding iterates_MH_fm_def
    using arity_is_nat_case_fm[OF \<open>?\<phi>\<in>_\<close> _ _ _ _ \<open>arity(?\<phi>) = _\<close>] assms pred_succ_eq pred_Un_distrib
    by auto
qed

lemma arity_is_iterates_fm :
  assumes "p\<in>formula" "v\<in>nat" "n\<in>nat" "Z\<in>nat" "i\<in>nat"
    "arity(p) = i"
  shows "arity(is_iterates_fm(p,v,n,Z)) = succ(v) \<union> succ(n) \<union> succ(Z) \<union>
          pred(pred(pred(pred(pred(pred(pred(pred(pred(pred(pred(i)))))))))))"
proof -
  let ?\<phi> = "iterates_MH_fm(p, 7#+v, 2, 1, 0)"
  let ?\<psi> = "is_wfrec_fm(?\<phi>, 0, succ(succ(n)),succ(succ(Z)))"
  from \<open>v\<in>_\<close>
  have "arity(?\<phi>) = (8#+v) \<union> pred(pred(pred(pred(i))))" "?\<phi>\<in>formula"
    using assms arity_iterates_MH_fm nat_union_abs2
    by simp_all
  then
  have "arity(?\<psi>) = succ(succ(succ(n))) \<union> succ(succ(succ(Z))) \<union> (3#+v) \<union>
      pred(pred(pred(pred(pred(pred(pred(pred(pred(i)))))))))"
    using assms arity_is_wfrec_fm[OF \<open>?\<phi>\<in>_\<close> _ _ _ _ \<open>arity(?\<phi>) = _\<close>] nat_union_abs1 pred_Un_distrib
    by auto
  then
  show ?thesis
    unfolding is_iterates_fm_def
    using arity_Memrel_fm arity_succ_fm assms nat_union_abs1 pred_Un_distrib
    by auto
qed

lemma arity_eclose_n_fm :
  assumes "A\<in>nat" "x\<in>nat" "t\<in>nat"
  shows "arity(eclose_n_fm(A,x,t)) = succ(A) \<union> succ(x) \<union> succ(t)"
proof -
  let ?\<phi> = "big_union_fm(1,0)"
  have "arity(?\<phi>) = 2" "?\<phi>\<in>formula"
    using arity_big_union_fm nat_union_abs2
    by simp_all
  with assms
  show ?thesis
    unfolding eclose_n_fm_def
    using arity_is_iterates_fm[OF \<open>?\<phi>\<in>_\<close> _ _ _,of _ _ _ 2]
    by auto
qed

lemma arity_mem_eclose_fm :
  assumes "x\<in>nat" "t\<in>nat"
  shows "arity(mem_eclose_fm(x,t)) = succ(x) \<union> succ(t)"
proof -
  let ?\<phi>="eclose_n_fm(x #+ 2, 1, 0)"
  from \<open>x\<in>nat\<close>
  have "arity(?\<phi>) = x#+3"
    using arity_eclose_n_fm nat_union_abs2
    by simp
  with assms
  show ?thesis
    unfolding mem_eclose_fm_def
    using arity_finite_ordinal_fm nat_union_abs2 pred_Un_distrib
    by simp
qed

lemma arity_is_eclose_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(is_eclose_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding is_eclose_fm_def
  using arity_mem_eclose_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma eclose_n1arity__fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(eclose_n1_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding eclose_n1_fm_def
  using arity_is_eclose_fm arity_singleton_fm name1arity__fm nat_union_abs2 pred_Un_distrib
  by auto

lemma eclose_n2arity__fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(eclose_n2_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding eclose_n2_fm_def
  using arity_is_eclose_fm arity_singleton_fm name2arity__fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_ecloseN_fm :
  "\<lbrakk>x\<in>nat ; t\<in>nat\<rbrakk> \<Longrightarrow> arity(ecloseN_fm(x,t)) = succ(x) \<union> succ(t)"
  unfolding ecloseN_fm_def
  using eclose_n1arity__fm eclose_n2arity__fm arity_union_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_frecR_fm :
  "\<lbrakk>a\<in>nat;b\<in>nat\<rbrakk> \<Longrightarrow> arity(frecR_fm(a,b)) = succ(a) \<union> succ(b)"
  unfolding frecR_fm_def
  using arity_ftype_fm name1arity__fm name2arity__fm arity_domain_fm
      number1arity__fm arity_empty_fm nat_union_abs2 pred_Un_distrib
  by auto

lemma arity_Collect_fm :
  assumes "x \<in> nat" "y \<in> nat" "p\<in>formula"
  shows "arity(Collect_fm(x,p,y)) = succ(x) \<union> succ(y) \<union> pred(arity(p))"
  unfolding Collect_fm_def
  using assms pred_Un_distrib
  by auto

end


(* author: wzh*)

theory MyList
  imports Main

begin

datatype 'a list = Nil | Cons 'a "'a list"

(*app means add two lists*)
fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil xs = xs" |
"app (Cons x xs) ys = Cons x (app xs ys)"

(*rev means reverse a list*)
fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"
value "rev(Cons a (Cons b Nil))"

lemma app_Nil2 [simp]: "app xs Nil = xs"
  apply(induction xs)
   apply(auto)
  done

lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
  apply(induction xs)
   apply(auto)
  done

lemma rev_app [simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
  apply(induction xs)
   apply(auto)
  done

theorem rev_rev [simp]: "rev (rev xs) = xs"
  apply(induction xs)
   apply(auto)
  done

end


section \<open>Permutations as Products of Disjoint Cycles\<close>

theory Executable_Permutations
imports
  Graph_Theory.Funpow
  List_Aux
  "HOL-Library.Permutations"
  "HOL-Library.Rewrite"
begin

subsection \<open>Cyclic Permutations\<close>

definition list_succ :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "list_succ xs x = (if x \<in> set xs then xs ! ((index xs x + 1) mod length xs) else x)"

text \<open>
  We demonstrate the functions on the following simple lemmas

  @{lemma "list_succ [1 :: int, 2, 3] 1 = 2" by code_simp}
  @{lemma "list_succ [1 :: int, 2, 3] 2 = 3" by code_simp}
  @{lemma "list_succ [1 :: int, 2, 3] 3 = 1" by code_simp}
\<close>

lemma list_succ_altdef:
  "list_succ xs x = (let n = index xs x in if n + 1 = length xs then xs ! 0 else if n + 1 < length xs then xs ! (n + 1) else x)"
  using index_le_size[of xs x] unfolding list_succ_def index_less_size_conv[symmetric] by (auto simp: Let_def)

lemma list_succ_Nil:
  "list_succ [] = id"
  by (simp add: list_succ_def fun_eq_iff)

lemma list_succ_singleton:
  "list_succ [x] = list_succ []"
  by (simp add: fun_eq_iff list_succ_def)

lemma list_succ_short:
  assumes "length xs < 2" shows "list_succ xs = id"
  using assms
  by (cases xs) (rename_tac [2] y ys, case_tac [2] ys, auto simp: list_succ_Nil list_succ_singleton)

lemma list_succ_simps:
  "index xs x + 1 = length xs \<Longrightarrow> list_succ xs x = xs ! 0"
  "index xs x + 1 < length xs \<Longrightarrow> list_succ xs x = xs ! (index xs x + 1)"
  "length xs \<le> index xs x \<Longrightarrow> list_succ xs x = x"
  by (auto simp: list_succ_altdef)

lemma list_succ_not_in:
  assumes "x \<notin> set xs" shows "list_succ xs x = x"
  using assms by (auto simp: list_succ_def)

lemma list_succ_list_succ_rev:
  assumes "distinct xs" shows "list_succ (rev xs) (list_succ xs x) = x"
proof -
  { assume "index xs x + 1 < length xs"
    moreover then have "length xs - Suc (Suc (length xs - Suc (Suc (index xs x)))) = index xs x"
      by linarith
    ultimately have ?thesis using assms
      by (simp add: list_succ_def index_rev index_nth_id rev_nth)
  }
  moreover
  { assume A: "index xs x + 1 = length xs"
    moreover
    from A have "xs \<noteq> []" by auto
    moreover
    with A have "last xs = xs ! index xs x" by (cases "length xs") (auto simp: last_conv_nth)
    ultimately
    have ?thesis
      using assms
      by (auto simp add: list_succ_def rev_nth index_rev index_nth_id last_conv_nth)
  }
  moreover
  { assume A: "index xs x \<ge> length xs"
    then have "x \<notin> set xs" by (metis index_less less_irrefl)
    then have ?thesis by (auto simp: list_succ_def) }
  ultimately show ?thesis by (metis discrete le_less not_less)
qed

lemma inj_list_succ: "distinct xs \<Longrightarrow> inj (list_succ xs)"
  by (metis injI list_succ_list_succ_rev)

lemma inv_list_succ_eq: "distinct xs \<Longrightarrow> inv (list_succ xs) = list_succ (rev xs)"
  by (metis distinct_rev inj_imp_inv_eq inj_list_succ list_succ_list_succ_rev)

lemma bij_list_succ: "distinct xs \<Longrightarrow> bij (list_succ xs)"
  by (metis bij_def inj_list_succ distinct_rev list_succ_list_succ_rev surj_def)

lemma list_succ_permutes:
  assumes "distinct xs" shows "list_succ xs permutes set xs"
  using assms by (auto simp: permutes_conv_has_dom bij_list_succ has_dom_def list_succ_def)

lemma permutation_list_succ:
  assumes "distinct xs" shows "permutation (list_succ xs)"
  using list_succ_permutes[OF assms] by (auto simp: permutation_permutes)

lemma list_succ_nth:
  assumes "distinct xs" "n < length xs" shows "list_succ xs (xs ! n) = xs ! (Suc n mod length xs)"
  using assms by (auto simp: list_succ_def index_nth_id)

lemma list_succ_last[simp]:
  assumes "distinct xs" "xs \<noteq> []" shows "list_succ xs (last xs) = hd xs"
  using assms by (auto simp: list_succ_def hd_conv_nth)

lemma list_succ_rotate1[simp]:
  assumes "distinct xs" shows "list_succ (rotate1 xs) = list_succ xs"
proof (rule ext)
  fix y show "list_succ (rotate1 xs) y = list_succ xs y"
    using assms
  proof (induct xs)
    case Nil then show ?case by simp
  next
    case (Cons x xs)
    show ?case
    proof (cases "x = y")
      case True
      then have "index (xs @ [y]) y = length xs"
        using \<open>distinct (x # xs)\<close> by (simp add: index_append)
      with True show ?thesis by (cases "xs=[]") (auto simp: list_succ_def nth_append)
    next
      case False
      then show ?thesis
        apply (cases "index xs y + 1 < length xs")
        apply (auto simp:list_succ_def index_append nth_append)
        by (metis Suc_lessI index_less_size_conv mod_self nth_Cons_0 nth_append nth_append_length)
    qed
  qed
qed

lemma list_succ_rotate[simp]:
  assumes "distinct xs" shows "list_succ (rotate n xs) = list_succ xs"
  using assms by (induct n) auto

lemma list_succ_in_conv:
  "list_succ xs x \<in> set xs \<longleftrightarrow> x \<in> set xs"
  by (auto simp: list_succ_def not_nil_if_in_set )

lemma list_succ_in_conv1:
  assumes "A \<inter> set xs = {}"
  shows "list_succ xs x \<in> A \<longleftrightarrow> x \<in> A"
  by (metis assms disjoint_iff_not_equal list_succ_in_conv list_succ_not_in)

lemma list_succ_commute:
  assumes "set xs \<inter> set ys = {}"
  shows "list_succ xs (list_succ ys x) = list_succ ys (list_succ xs x)"
proof -
  have "\<And>x. x \<in> set xs \<Longrightarrow> list_succ ys x = x"
     "\<And>x. x \<in> set ys \<Longrightarrow> list_succ xs x = x"
    using assms by (blast intro: list_succ_not_in)+
  then show ?thesis
    by (cases "x \<in> set xs \<union> set ys") (auto simp: list_succ_in_conv list_succ_not_in)
qed

subsection \<open>Arbitrary Permutations\<close>

fun lists_succ :: "'a list list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "lists_succ [] x = x"
| "lists_succ (xs # xss) x = list_succ xs (lists_succ xss x)"

definition distincts ::  "'a list list \<Rightarrow> bool" where
  "distincts xss \<equiv> distinct xss \<and> (\<forall>xs \<in> set xss. distinct xs \<and> xs \<noteq> []) \<and> (\<forall>xs \<in> set xss. \<forall>ys \<in> set xss. xs \<noteq> ys \<longrightarrow> set xs \<inter> set ys = {})"

lemma distincts_distinct: "distincts xss \<Longrightarrow> distinct xss"
  by (auto simp: distincts_def)

lemma distincts_Nil[simp]: "distincts []"
  by (simp add: distincts_def)

lemma distincts_single: "distincts [xs] \<longleftrightarrow> distinct xs \<and> xs \<noteq> []"
  by (auto simp add: distincts_def)

lemma distincts_Cons: "distincts (xs # xss)
   \<longleftrightarrow> xs \<noteq> [] \<and> distinct xs \<and> distincts xss \<and> (set xs \<inter> (\<Union>ys \<in> set xss. set ys)) = {}" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L then show ?R by (auto simp: distincts_def)
next
  assume ?R
  then have "distinct (xs # xss)"
    apply (auto simp: disjoint_iff_not_equal distincts_distinct)
    apply (metis length_greater_0_conv nth_mem)
    done
  moreover
  from \<open>?R\<close> have "\<forall>xs \<in> set (xs # xss). distinct xs \<and> xs \<noteq> []"
    by (auto simp: distincts_def)
  moreover
  from \<open>?R\<close> have "\<forall>xs' \<in> set (xs # xss). \<forall>ys \<in> set (xs # xss). xs' \<noteq> ys \<longrightarrow> set xs' \<inter> set ys = {}"
    by (simp add: distincts_def) blast
  ultimately show ?L unfolding distincts_def by (intro conjI)
qed

lemma distincts_Cons': "distincts (xs # xss)
   \<longleftrightarrow> xs \<noteq> [] \<and> distinct xs \<and> distincts xss \<and> (\<forall>ys \<in> set xss. set xs \<inter> set ys = {})" (is "?L \<longleftrightarrow> ?R")
 unfolding distincts_Cons by blast

lemma distincts_rev:
  "distincts (map rev xss) \<longleftrightarrow> distincts xss"
  by (simp add: distincts_def distinct_map)

lemma length_distincts:
  assumes "distincts xss"
  shows "length xss = card (set ` set xss)"
  using assms
proof (induct xss)
  case Nil then show ?case by simp
next
  case (Cons xs xss)
  then have "set xs \<notin> set ` set xss"
    using equals0I[of "set xs"] by (auto simp: distincts_Cons disjoint_iff_not_equal )
  with Cons show ?case by (auto simp add: distincts_Cons)
qed

lemma distincts_remove1: "distincts xss \<Longrightarrow> distincts (remove1 xs xss)"
  by (auto simp: distincts_def)

lemma distinct_Cons_remove1:
  "x \<in> set xs \<Longrightarrow> distinct (x # remove1 x xs) = distinct xs"
  by (induct xs) auto

lemma set_Cons_remove1:
  "x \<in> set xs \<Longrightarrow> set (x # remove1 x xs) = set xs"
  by (induct xs) auto

lemma distincts_Cons_remove1:
  "xs \<in> set xss \<Longrightarrow> distincts (xs # remove1 xs xss) = distincts xss"
  by (simp only: distinct_Cons_remove1 set_Cons_remove1 distincts_def)

lemma distincts_inj_on_set:
  assumes "distincts xss" shows "inj_on set (set xss)"
  by (rule inj_onI) (metis assms distincts_def inf.idem set_empty)

lemma distincts_distinct_set:
  assumes "distincts xss" shows "distinct (map set xss)"
  using assms by (auto simp: distinct_map distincts_distinct distincts_inj_on_set)

lemma distincts_distinct_nth:
  assumes "distincts xss" "n < length xss" shows "distinct (xss ! n)"
  using assms by (auto simp: distincts_def)

lemma lists_succ_not_in:
  assumes "x \<notin> (\<Union>xs\<in>set xss. set xs)" shows "lists_succ xss x = x"
  using assms by (induct xss) (auto simp: list_succ_not_in)

lemma lists_succ_in_conv:
  "lists_succ xss x \<in> (\<Union>xs\<in>set xss. set xs) \<longleftrightarrow> x \<in> (\<Union>xs\<in>set xss. set xs)"
  by (induct xss) (auto simp: list_succ_in_conv lists_succ_not_in list_succ_not_in)

lemma lists_succ_in_conv1:
  assumes "A \<inter> (\<Union>xs\<in>set xss. set xs) = {}"
  shows "lists_succ xss x \<in> A \<longleftrightarrow> x \<in> A"
  by (metis Int_iff assms emptyE lists_succ_in_conv lists_succ_not_in)

lemma lists_succ_Cons_pf: "lists_succ (xs # xss) = list_succ xs o lists_succ xss"
  by auto

lemma lists_succ_Nil_pf: "lists_succ [] = id"
  by (simp add: fun_eq_iff)

lemmas lists_succ_simps_pf = lists_succ_Cons_pf lists_succ_Nil_pf

lemma lists_succ_permutes:
  assumes "distincts xss"
  shows "lists_succ xss permutes (\<Union>xs \<in> set xss. set xs)"
  using assms
proof (induction xss)
  case Nil then show ?case by auto
next
  case (Cons xs xss)
  have "list_succ xs permutes (set xs)"
    using Cons by (intro list_succ_permutes) (simp add: distincts_def in_set_member)
  moreover
  have "lists_succ xss permutes (\<Union>ys \<in> set xss. set ys)"
    using Cons by (auto simp: Cons distincts_def)
  ultimately show "lists_succ (xs # xss) permutes (\<Union>ys \<in> set (xs # xss). set ys)"
    using Cons by (auto simp: lists_succ_Cons_pf intro: permutes_compose permutes_subset)
qed

lemma bij_lists_succ: "distincts xss \<Longrightarrow> bij (lists_succ xss)"
  by (induct xss) (auto simp: lists_succ_simps_pf bij_comp bij_list_succ distincts_Cons)

lemma lists_succ_snoc: "lists_succ (xss @ [xs]) = lists_succ xss o list_succ xs"
  by (induct xss) auto

lemma inv_lists_succ_eq:
  assumes "distincts xss"
  shows "inv (lists_succ xss) = lists_succ (rev (map rev xss))"
proof -
  have *: "\<And>f g. inv (\<lambda>b. f (g b)) = inv (f o g)" by (simp add: o_def)
  have **: "lists_succ [] = id" by auto
  show ?thesis
    using assms by (induct xss) (auto simp: * ** lists_succ_snoc lists_succ_Cons_pf o_inv_distrib
      inv_list_succ_eq distincts_Cons bij_list_succ bij_lists_succ)
qed

lemma lists_succ_remove1:
  assumes "distincts xss" "xs \<in> set xss"
  shows "lists_succ (xs # remove1 xs xss) = lists_succ xss"
  using assms
proof (induct xss)
  case Nil then show ?case by simp
next
  case (Cons ys xss)
  show ?case
  proof cases
    assume "xs = ys" then show ?case by simp
  next
    assume "xs \<noteq> ys"
    with Cons.prems have inter: "set xs \<inter> set ys = {}" and "xs \<in> set xss"
      by (auto simp: distincts_Cons)
    have dists:
        "distincts (xs # remove1 xs xss)"
        "distincts (xs # ys # remove1 xs xss)"
      using \<open>distincts (ys # xss)\<close> \<open>xs \<in> set xss\<close> by (auto simp: distincts_def)

    have "list_succ xs \<circ> (list_succ ys \<circ> lists_succ (remove1 xs xss))
        = list_succ ys \<circ> (list_succ xs \<circ> lists_succ (remove1 xs xss))"
      using inter unfolding fun_eq_iff comp_def
      by (subst list_succ_commute) auto
    also have "\<dots> = list_succ ys o (lists_succ (xs # remove1 xs xss))"
      using dists by (simp add: lists_succ_Cons_pf distincts_Cons)
    also have "\<dots> = list_succ ys o lists_succ xss"
      using \<open>xs \<in> set xss\<close> \<open>distincts (ys # xss)\<close>
      by (simp add: distincts_Cons Cons.hyps)
    finally
    show "lists_succ (xs # remove1 xs (ys # xss)) = lists_succ (ys # xss)"
      using Cons dists by (auto simp: lists_succ_Cons_pf distincts_Cons)
  qed
qed

lemma lists_succ_no_order:
  assumes "distincts xss" "distincts yss" "set xss = set yss"
  shows "lists_succ xss = lists_succ yss"
  using assms
proof (induct xss arbitrary: yss)
  case Nil then show ?case by simp
next
  case (Cons xs xss)
  have "xs \<notin> set xss" "xs \<in> set yss" using Cons.prems
    by (auto dest: distincts_distinct)
  have "lists_succ xss = lists_succ (remove1 xs yss)"
    using Cons.prems \<open>xs \<notin> _\<close>
    by (intro Cons.hyps) (auto simp add: distincts_Cons distincts_remove1 distincts_distinct)
  then have "lists_succ (xs # xss) = lists_succ (xs # remove1 xs yss)"
    using Cons.prems \<open>xs \<in> _\<close>
    by (simp add: lists_succ_Cons_pf distincts_Cons_remove1)
  then show ?case
    using Cons.prems \<open>xs \<in> _\<close> by (simp add: lists_succ_remove1)
qed

section \<open>List Orbits\<close>

text \<open>Computes the orbit of @{term x} under @{term f}\<close>
definition orbit_list :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "orbit_list f x \<equiv> iterate 0 (funpow_dist1 f x x) f x"

partial_function (tailrec)
  orbit_list_impl :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
where
  "orbit_list_impl f s acc x = (let x' = f x in if x' = s then rev (x # acc) else orbit_list_impl f s (x # acc) x')"

context notes [simp] = length_fold_remove1_le begin
text \<open>Computes the list of orbits\<close>
fun orbits_list :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "orbits_list f [] = []"
| "orbits_list f (x # xs) =
     orbit_list f x # orbits_list f (fold remove1 (orbit_list f x) xs)"

fun orbits_list_impl :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "orbits_list_impl f [] = []"
| "orbits_list_impl f (x # xs) =
     (let fc = orbit_list_impl f x [] x in fc # orbits_list_impl f (fold remove1 fc xs))"

declare orbit_list_impl.simps[code]
end

abbreviation sset :: "'a list list \<Rightarrow> 'a set set" where
  "sset xss \<equiv> set ` set xss"

lemma iterate_funpow_step:
  assumes "f x \<noteq> y" "y \<in> orbit f x"
  shows "iterate 0 (funpow_dist1 f x y) f x = x # iterate 0 (funpow_dist1 f (f x) y) f (f x)"
proof -
  from assms have A: "y \<in> orbit f (f x)" by (simp add: orbit_step)
  have "iterate 0 (funpow_dist1 f x y) f x = x # iterate 1 (funpow_dist1 f x y) f x" (is "_ = _ # ?it")
    unfolding iterate_def by (rewrite in "\<hole> = _" upt_conv_Cons) auto
  also have "?it = map (\<lambda>n. (f ^^ n) x) (map Suc [0..<funpow_dist f (f x) y])"
    unfolding iterate_def map_Suc_upt by simp
  also have "\<dots> = map (\<lambda>n. (f ^^ n) (f x)) [0..<funpow_dist f (f x) y]"
    by (simp add: funpow_swap1)
  also have "\<dots> = iterate 0 (funpow_dist1 f (f x) y) f (f x)"
    unfolding iterate_def
    unfolding iterate_def by (simp add: funpow_dist_step[OF assms(1) A])
  finally show ?thesis .
qed

lemma orbit_list_impl_conv:
  assumes "y \<in> orbit f x"
  shows "orbit_list_impl f y acc x = rev acc @ iterate 0 (funpow_dist1 f x y) f x"
  using assms
proof (induct n\<equiv>"funpow_dist1 f x y" arbitrary: x acc)
  case (Suc x)

  show ?case
  proof cases
    assume "f x = y"
    then show ?thesis by (subst orbit_list_impl.simps) (simp add: Let_def iterate_def funpow_dist_0)
  next
    assume not_y :"f x \<noteq> y"

    have y_in_succ: "y \<in> orbit f (f x)"
      by (intro orbit_step Suc.prems not_y)

    have "orbit_list_impl f y acc x = orbit_list_impl f y (x # acc) (f x)"
      using not_y by (subst orbit_list_impl.simps) simp
    also have "\<dots> = rev (x # acc) @ iterate 0 (funpow_dist1 f (f x) y) f (f x)" (is "_ = ?rev @ ?it")
      by (intro Suc funpow_dist_step not_y y_in_succ)
    also have "\<dots> = rev acc @ iterate 0 (funpow_dist1 f x y) f x"
      using not_y Suc.prems by (simp add: iterate_funpow_step)
    finally show ?thesis .
  qed
qed

lemma orbit_list_conv_impl:
  assumes "x \<in> orbit f x"
  shows "orbit_list f x = orbit_list_impl f x [] x"
  unfolding orbit_list_impl_conv[OF assms] orbit_list_def by simp

lemma set_orbit_list:
  assumes "x \<in> orbit f x"
  shows "set (orbit_list f x) = orbit f x"
  by (simp add: orbit_list_def orbit_conv_funpow_dist1[OF assms] set_iterate)

lemma set_orbit_list':
  assumes "permutation f" shows "set (orbit_list f x) = orbit f x"
  using assms by (simp add: permutation_self_in_orbit set_orbit_list)

lemma distinct_orbit_list:
  assumes "x \<in> orbit f x"
  shows "distinct (orbit_list f x)"
  by (simp del: upt_Suc add: orbit_list_def iterate_def distinct_map inj_on_funpow_dist1[OF assms])

lemma distinct_orbit_list':
  assumes "permutation f" shows "distinct (orbit_list f x)"
  using assms by (simp add: permutation_self_in_orbit distinct_orbit_list)

lemma orbits_list_conv_impl:
  assumes "permutation f"
  shows "orbits_list f xs = orbits_list_impl f xs"
proof (induct "length xs" arbitrary: xs rule: less_induct)
  case less show ?case
    using assms by (cases xs) (auto simp: assms less less_Suc_eq_le length_fold_remove1_le
      orbit_list_conv_impl permutation_self_in_orbit Let_def)
qed

lemma orbit_list_not_nil[simp]: "orbit_list f x \<noteq> []"
  by (simp add: orbit_list_def)

lemma sset_orbits_list:
  assumes "permutation f" shows "sset (orbits_list f xs) = (orbit f) ` set xs"
proof (induct "length xs" arbitrary: xs rule: less_induct)
  case less
  show ?case
  proof (cases xs)
    case Nil then show ?thesis by simp
  next
    case (Cons x' xs')
    let ?xs'' = "fold remove1 (orbit_list f x') xs'"
    have A: "sset (orbits_list f ?xs'') = orbit f ` set ?xs''"
      using Cons by (simp add: less_Suc_eq_le length_fold_remove1_le less.hyps)
    have B: "set (orbit_list f x') = orbit f x'"
      by (rule set_orbit_list) (simp add: permutation_self_in_orbit assms)

    have "orbit f ` set (fold remove1 (orbit_list f x') xs') \<subseteq> orbit f ` set xs'"
      using set_fold_remove1[of _ xs'] by auto
    moreover
    have "orbit f ` set xs' - {orbit f x'} \<subseteq> (orbit f ` set (fold remove1 (orbit_list f x') xs'))" (is "?L \<subseteq> ?R")
    proof
      fix A assume "A \<in> ?L"
      then obtain y where "A = orbit f y" "y \<in> set xs'" by auto
      have "A \<noteq> orbit f x'" using \<open>A \<in> ?L\<close> by auto
      from \<open>A = _\<close> \<open>A \<noteq> _\<close> have "y \<notin> orbit f x'"
        by (meson assms cyclic_on_orbit orbit_cyclic_eq3 permutation_permutes)
      with \<open>y \<in> _\<close> have "y \<in> set (fold remove1 (orbit_list f x') xs')"
        by (auto simp: set_fold_remove1' set_orbit_list permutation_self_in_orbit assms)
      then show "A \<in> ?R" using \<open>A = _\<close> by auto
    qed
    ultimately
    show ?thesis by (auto simp: A B Cons)
  qed
qed

subsection \<open>Relation to @{term cyclic_on}\<close>

lemma list_succ_orbit_list:
  assumes "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"
  shows "list_succ (orbit_list f s) = f"
proof -
  have "distinct (orbit_list f s)" "\<And>x. x \<notin> set (orbit_list f s) \<Longrightarrow> x = f x"
    using assms by (simp_all add: distinct_orbit_list set_orbit_list)
  moreover
  have "\<And>i. i < length (orbit_list f s) \<Longrightarrow> orbit_list f s ! (Suc i mod length (orbit_list f s)) = f (orbit_list f s ! i)"
    using funpow_dist1_prop[OF \<open>s \<in> orbit f s\<close>] by (auto simp: orbit_list_def funpow_mod_eq)
  ultimately show ?thesis
    by (auto simp: list_succ_def fun_eq_iff)
qed

lemma list_succ_funpow_conv:
  assumes A: "distinct xs" "x \<in> set xs"
  shows "(list_succ xs ^^ n) x = xs ! ((index xs x + n) mod length xs)"
proof -
  have "xs \<noteq> []" using assms by auto
  then show ?thesis
    by (induct n) (auto simp: hd_conv_nth A index_nth_id list_succ_def mod_simps)
qed

lemma orbit_list_succ:
  assumes "distinct xs" "x \<in> set xs"
  shows "orbit (list_succ xs) x = set xs"
proof (intro set_eqI iffI)
  fix y assume "y \<in> orbit (list_succ xs) x"
  then show "y \<in> set xs"
    by induct (auto simp: list_succ_in_conv \<open>x \<in> set xs\<close>)
next
  fix y assume "y \<in> set xs"
  moreover
  { fix i j have "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> \<exists>n. xs ! j = xs ! ((i + n) mod length xs)"
      using assms by (auto simp: exI[where x="j + (length xs - i)"])
  }
  ultimately
  show "y \<in> orbit (list_succ xs) x"
    using assms by (auto simp: orbit_altdef_permutation permutation_list_succ list_succ_funpow_conv index_nth_id in_set_conv_nth)
qed

lemma cyclic_on_list_succ:
  assumes "distinct xs" "xs \<noteq> []" shows "cyclic_on (list_succ xs) (set xs)"
  using assms last_in_set by (auto simp: cyclic_on_def orbit_list_succ)

lemma obtain_orbit_list_func:
  assumes "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"
  obtains xs where "f = list_succ xs" "set xs = orbit f s" "distinct xs" "hd xs = s"
proof -
  { from assms have "f = list_succ (orbit_list f s)" by (simp add: list_succ_orbit_list)
    moreover
    have "set (orbit_list f s) = orbit f s" "distinct (orbit_list f s)"
      by (auto simp: set_orbit_list distinct_orbit_list assms)
    moreover have "hd (orbit_list f s) = s"
      by (simp add: orbit_list_def iterate_def hd_map del: upt_Suc)
    ultimately have "\<exists>xs. f = list_succ xs \<and> set xs = orbit f s \<and> distinct xs \<and> hd xs = s" by blast
  } then show ?thesis by (metis that)
qed

lemma cyclic_on_obtain_list_succ:
  assumes "cyclic_on f S" "\<And>x. x \<notin> S \<Longrightarrow> f x = x"
  obtains xs where "f = list_succ xs" "set xs = S" "distinct xs"
proof -
  from assms obtain s where s: "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"  "S = orbit f s"
    by (auto simp: cyclic_on_def)
  then show ?thesis by (metis that obtain_orbit_list_func)
qed

lemma cyclic_on_obtain_list_succ':
  assumes "cyclic_on f S" "f permutes S"
  obtains xs where "f = list_succ xs" "set xs = S" "distinct xs"
  using assms unfolding permutes_def by (metis cyclic_on_obtain_list_succ)

lemma list_succ_unique:
  assumes "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"
  shows "\<exists>!xs. f = list_succ xs \<and> distinct xs \<and> hd xs = s \<and> set xs = orbit f s"
proof -
  from assms obtain xs where xs: "f = list_succ xs" "distinct xs" "hd xs = s" "set xs = orbit f s"
    by (rule obtain_orbit_list_func)
  moreover
  { fix zs
    assume A: "f = list_succ zs" "distinct zs" "hd zs = s" "set zs = orbit f s"
    then have "zs \<noteq> []" using \<open>s \<in> orbit f s\<close> by auto
    from \<open>distinct xs\<close> \<open>distinct zs\<close> \<open>set xs = orbit f s\<close> \<open>set zs = orbit f s\<close>
    have len: "length xs = length zs" by (metis distinct_card)

    { fix n assume "n < length xs"
      then have "zs ! n = xs ! n"
      proof (induct n)
        case 0 with A xs \<open>zs \<noteq> []\<close> show ?case by (simp add: hd_conv_nth nth_rotate_conv_nth)
      next
        case (Suc n)
        then have "list_succ zs (zs ! n) = list_succ xs (xs! n)"
          using \<open>f = list_succ xs\<close> \<open>f = list_succ zs\<close> by simp
        with \<open>Suc n < _\<close> show ?case
          by (simp add:list_succ_nth len \<open>distinct xs\<close> \<open>distinct zs\<close>)
      qed }
    then have "zs = xs" by (metis len nth_equalityI) }
  ultimately show ?thesis by metis
qed

lemma distincts_orbits_list:
  assumes "distinct as" "permutation f"
  shows "distincts (orbits_list f as)"
  using assms(1)
proof (induct "length as" arbitrary: as rule: less_induct)
  case less
  show ?case
  proof (cases as)
    case Nil then show ?thesis by simp
  next
    case (Cons a as')
    let ?as' = "fold remove1 (orbit_list f a) as'"
    from Cons less.prems have A: "distincts (orbits_list f (fold remove1 (orbit_list f a) as'))"
      by (intro less) (auto simp: distinct_fold_remove1 length_fold_remove1_le less_Suc_eq_le)

    have B: "set (orbit_list f a) \<inter> \<Union>(sset (orbits_list f (fold remove1 (orbit_list f a) as'))) = {}"
    proof -
      have "orbit f a \<inter> set (fold remove1 (orbit_list f a) as') = {}"
        using assms less.prems Cons by (simp add: set_fold_remove1_distinct set_orbit_list')
      then have "orbit f a \<inter> \<Union> (orbit f ` set (fold remove1 (orbit_list f a) as')) = {}"
        by auto (metis assms(2) cyclic_on_orbit disjoint_iff_not_equal permutation_self_in_orbit[OF assms(2)] orbit_cyclic_eq3 permutation_permutes)
      then show ?thesis using assms
      by (auto simp: set_orbit_list' sset_orbits_list disjoint_iff_not_equal)
    qed
    show ?thesis
      using A B assms by (auto simp: distincts_Cons Cons distinct_orbit_list')
  qed
qed

lemma cyclic_on_lists_succ':
  assumes "distincts xss"
  shows "A \<in> sset xss \<Longrightarrow> cyclic_on (lists_succ xss) A"
  using assms
proof (induction xss arbitrary: A)
  case Nil then show ?case by auto
next
  case (Cons xs xss A)
  then have inter: "set xs \<inter> (\<Union>ys\<in>set xss. set ys) = {}" by (auto simp: distincts_Cons)

  note pcp[OF _ _ inter] = permutes_comp_preserves_cyclic1 permutes_comp_preserves_cyclic2
  from Cons show "cyclic_on (lists_succ (xs # xss)) A"
    by (cases "A = set xs")
      (auto intro: pcp simp: cyclic_on_list_succ list_succ_permutes
        lists_succ_permutes lists_succ_Cons_pf distincts_Cons)
qed

lemma cyclic_on_lists_succ:
  assumes "distincts xss"
  shows "\<And>xs. xs \<in> set xss \<Longrightarrow> cyclic_on (lists_succ xss) (set xs)"
  using assms by (auto intro: cyclic_on_lists_succ')

lemma permutes_as_lists_succ:
  assumes "distincts xss"
  assumes ls_eq: "\<And>xs. xs \<in> set xss \<Longrightarrow> list_succ xs = perm_restrict f (set xs)"
  assumes "f permutes (\<Union>(sset xss))"
  shows "f = lists_succ xss"
  using assms
proof (induct xss arbitrary: f)
  case Nil then show ?case by simp
next
  case (Cons xs xss)
  let ?sets = "\<lambda>xss. \<Union>ys \<in> set xss. set ys"

  have xs: "distinct xs" "xs \<noteq> []" using Cons by (auto simp: distincts_Cons)

  have f_xs: "perm_restrict f (set xs) = list_succ xs"
    using Cons by simp

  have co_xs: "cyclic_on (perm_restrict f (set xs)) (set xs)"
    unfolding f_xs using xs by (rule cyclic_on_list_succ)

  have perm_xs: "perm_restrict f (set xs) permutes set xs"
    unfolding f_xs using \<open>distinct xs\<close> by (rule list_succ_permutes)

  have perm_xss: "perm_restrict f (?sets xss) permutes (?sets xss)"
  proof -
    have "perm_restrict f (?sets (xs # xss) - set xs) permutes (?sets (xs # xss) - set xs)"
      using Cons co_xs by (intro perm_restrict_diff_cyclic) (auto simp: cyclic_on_perm_restrict)
    also have "?sets (xs # xss) - set xs = ?sets xss"
      using Cons by (auto simp: distincts_Cons)
    finally show ?thesis .
  qed

  have f_xss: "perm_restrict f (?sets xss) = lists_succ xss"
  proof -
    have *: "\<And>xs. xs \<in> set xss \<Longrightarrow> ((\<Union>x\<in>set xss. set x) \<inter> set xs) = set xs"
      by blast
    with perm_xss Cons.prems show ?thesis
      by (intro Cons.hyps) (auto simp: distincts_Cons perm_restrict_perm_restrict *)
  qed

  from Cons.prems show "f = lists_succ (xs # xss)"
    by (simp add: lists_succ_Cons_pf distincts_Cons f_xss[symmetric]
      perm_restrict_union perm_xs perm_xss)
qed

lemma cyclic_on_obtain_lists_succ:
  assumes
    permutes: "f permutes S" and
    S: "S = \<Union>(sset css)" and
    dists: "distincts css" and
    cyclic: "\<And>cs. cs \<in> set css \<Longrightarrow> cyclic_on f (set cs)"
  obtains xss where "f = lists_succ xss" "distincts xss" "map set xss = map set css" "map hd xss = map hd css"
proof -
  let ?fc = "\<lambda>cs. perm_restrict f (set cs)"
  define some_list where "some_list cs = (SOME xs. ?fc cs = list_succ xs \<and> set xs = set cs \<and> distinct xs \<and> hd xs = hd cs)" for cs
  { fix cs assume "cs \<in> set css"
    then have "cyclic_on (?fc cs) (set cs)" "\<And>x. x \<notin> set cs \<Longrightarrow> ?fc cs x = x" "hd cs \<in> set cs"
      using cyclic dists by (auto simp add: cyclic_on_perm_restrict perm_restrict_def distincts_def)
    then have "hd cs \<in> orbit (?fc cs) (hd cs)"  "\<And>x. x \<notin> orbit (?fc cs) (hd cs) \<Longrightarrow> ?fc cs x = x" "hd cs \<in> set cs" "set cs = orbit (?fc cs) (hd cs)"
      by (auto simp: cyclic_on_alldef)
    then have "\<exists>xs. ?fc cs = list_succ xs \<and> set xs = set cs \<and> distinct xs \<and> hd xs = hd cs"
      by (metis obtain_orbit_list_func)
    then have "?fc cs = list_succ (some_list cs) \<and> set (some_list cs) = set cs \<and> distinct (some_list cs) \<and> hd (some_list cs) = hd cs"
      unfolding some_list_def by (rule someI_ex)
    then have "?fc cs = list_succ (some_list cs)" "set (some_list cs) = set cs" "distinct (some_list cs)" "hd (some_list cs) = hd cs"
      by auto
  } note sl_cs  = this

  have "\<And>cs. cs \<in> set css \<Longrightarrow> cs \<noteq> []" using dists by (auto simp: distincts_def)
  then have some_list_ne: "\<And>cs. cs \<in> set css \<Longrightarrow> some_list cs \<noteq> []"
    by (metis set_empty sl_cs(2))

  have set: "map set (map some_list css) = map set css" "map hd (map some_list css) = map hd css"
    using sl_cs(2,4) by (auto simp add: map_idI)

  have distincts: "distincts (map some_list css)"
  proof -
    have c_dist: "\<And>xs ys. \<lbrakk>xs\<in>set css; ys\<in>set css; xs \<noteq> ys\<rbrakk> \<Longrightarrow> set xs \<inter> set ys = {}"
      using dists by (auto simp: distincts_def)

    have "distinct (map some_list css)"
    proof -
      have "inj_on some_list (set css)"
        using sl_cs(2) c_dist by (intro inj_onI) (metis inf.idem set_empty)
      with \<open>distincts css\<close> show ?thesis
        by (auto simp: distincts_distinct distinct_map)
    qed
    moreover
    have "\<forall>xs\<in>set (map some_list css). distinct xs \<and> xs \<noteq> []"
      using sl_cs(3) some_list_ne by auto
    moreover
    from c_dist have "(\<forall>xs\<in>set (map some_list css). \<forall>ys\<in>set (map some_list css). xs \<noteq> ys \<longrightarrow> set xs \<inter> set ys = {})"
      using sl_cs(2) by auto
    ultimately
    show ?thesis by (simp add: distincts_def)
  qed

  have f: "f = lists_succ (map some_list css)"
    using distincts
  proof (rule permutes_as_lists_succ)
    fix xs assume "xs \<in> set (map some_list css)"
    then show "list_succ xs = perm_restrict f (set xs)"
      using sl_cs(1) sl_cs(2) by auto
  next
    have "S = (\<Union>xs\<in>set (map some_list css). set xs)"
      using S sl_cs(2) by auto
    with permutes show "f permutes \<Union>(sset (map some_list css))"
      by simp
  qed

  from f distincts set  show ?thesis ..
qed

subsection \<open>Permutations of a List\<close>

lemma length_remove1_less:
  assumes "x \<in> set xs" shows "length (remove1 x xs) < length xs"
proof -
  from assms have "0 < length xs" by auto
  with assms show ?thesis by (auto simp: length_remove1)
qed
context notes [simp] = length_remove1_less begin
fun permutations :: "'a list \<Rightarrow> 'a list list" where
  permutations_Nil: "permutations [] = [[]]"
| permutations_Cons:
    "permutations xs = [y # ys. y <- xs, ys <- permutations (remove1 y xs)]"
end

declare permutations_Cons[simp del]

text \<open>
  The function above returns all permutations of a list. The function below computes
  only those which yield distinct cyclic permutation functions (cf. @{term list_succ}).
\<close>

fun cyc_permutations :: "'a list \<Rightarrow> 'a list list" where
  "cyc_permutations [] = [[]]"
| "cyc_permutations (x # xs) = map (Cons x) (permutations xs)"

lemma nil_in_permutations[simp]: "[] \<in> set (permutations xs) \<longleftrightarrow> xs = []"
  by (induct xs) (auto simp: permutations_Cons)

lemma permutations_not_nil:
  assumes "xs \<noteq> []"
  shows "permutations xs = concat (map (\<lambda>x. map ((#) x) (permutations (remove1 x xs))) xs)"
  using assms by (cases xs) (auto simp: permutations_Cons)

lemma set_permutations_step:
  assumes "xs \<noteq> []"
  shows "set (permutations xs) = (\<Union>x \<in> set xs. Cons x ` set (permutations (remove1 x xs)))"
  using assms by (cases xs) (auto simp: permutations_Cons)

lemma in_set_permutations:
  assumes "distinct xs"
  shows "ys \<in> set (permutations xs) \<longleftrightarrow> distinct ys \<and> set xs = set ys" (is "?L xs ys \<longleftrightarrow> ?R xs ys")
  using assms
proof (induct "length xs" arbitrary: xs ys)
  case 0 then show ?case by auto
next
  case (Suc n)
  then have "xs \<noteq> []" by auto

  show ?case
  proof
    assume "?L xs ys"
    then obtain y ys' where "ys = y # ys'" "y \<in> set xs" "ys' \<in> set (permutations (remove1 (hd ys) xs))"
      using \<open>xs \<noteq> []\<close> by (auto simp: permutations_not_nil)
    moreover
    then have "?R (remove1 y xs) ys'"
      using Suc.prems Suc.hyps(2) by (intro Suc.hyps(1)[THEN iffD1]) (auto simp: length_remove1)
    ultimately show "?R xs ys"
      using Suc by auto
  next
    assume "?R xs ys"
    with \<open>xs \<noteq> []\<close> obtain y ys' where "ys = y # ys'" "y \<in> set xs" by (cases ys) auto
    moreover
    then have "ys' \<in> set (permutations (remove1 y xs))"
      using Suc \<open>?R xs ys\<close> by (intro Suc.hyps(1)[THEN iffD2]) (auto simp: length_remove1)
    ultimately
    show "?L xs ys"
      using \<open>xs \<noteq> []\<close> by (auto simp: permutations_not_nil)
  qed
qed

lemma in_set_cyc_permutations:
  assumes "distinct xs"
  shows "ys \<in> set (cyc_permutations xs) \<longleftrightarrow> distinct ys \<and> set xs = set ys \<and> hd ys = hd xs" (is "?L xs ys \<longleftrightarrow> ?R xs ys")
proof (cases xs)
  case (Cons x xs) with assms show ?thesis
    by (cases ys) (auto simp: in_set_permutations intro!: imageI)
qed auto

lemma in_set_cyc_permutations_obtain:
  assumes "distinct xs" "distinct ys" "set xs = set ys"
  obtains n where "rotate n ys \<in> set (cyc_permutations xs)"
proof (cases xs)
  case Nil with assms have "rotate 0 ys \<in> set (cyc_permutations xs)" by auto
  then show ?thesis ..
next
  case (Cons x xs')
  let ?ys' = "rotate (index ys x) ys"
  have "ys \<noteq> []" "x \<in> set ys"
    using Cons assms by auto
  then have "distinct ?ys' \<and> set xs = set ?ys' \<and> hd ?ys' = hd xs"
    using assms Cons by (auto simp add: hd_rotate_conv_nth)
  with \<open>distinct xs\<close> have "?ys' \<in> set (cyc_permutations xs)"
    by (rule in_set_cyc_permutations[THEN iffD2])
  then show ?thesis ..
qed

lemma list_succ_set_cyc_permutations:
  assumes "distinct xs" "xs \<noteq> []"
  shows "list_succ ` set (cyc_permutations xs) = {f. f permutes set xs \<and> cyclic_on f (set xs)}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix f assume "f \<in> ?L"
  moreover have "\<And>ys. set xs = set ys \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> ys \<noteq> []" by auto
  ultimately show "f \<in> ?R"
    using assms by (auto simp: in_set_cyc_permutations list_succ_permutes cyclic_on_list_succ)
next
  fix f assume "f \<in> ?R"
  then obtain ys where ys: "list_succ ys = f" "distinct ys" "set ys = set xs"
    by (auto elim: cyclic_on_obtain_list_succ')
  moreover
  with \<open>distinct xs\<close> obtain n where "rotate n ys \<in> set (cyc_permutations xs)"
    by (auto elim: in_set_cyc_permutations_obtain)
  then have "list_succ (rotate n ys) \<in> ?L" by simp
  ultimately
  show "f \<in> ?L" by simp
qed

subsection \<open>Enumerating Permutations from List Orbits\<close>

definition cyc_permutationss :: "'a list list \<Rightarrow> 'a list list list" where
  "cyc_permutationss = product_lists o map cyc_permutations"

lemma cyc_permutationss_Nil[simp]: "cyc_permutationss [] = [[]]"
  by (auto simp: cyc_permutationss_def)

lemma in_set_cyc_permutationss:
  assumes "distincts xss"
  shows "yss \<in> set (cyc_permutationss xss) \<longleftrightarrow> distincts yss \<and> map set xss = map set yss \<and> map hd xss = map hd yss"
proof -
  { assume A: "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map cyc_permutations xss)"
    then have "length yss = length xss" by (auto simp: list_all2_lengthD)
    then have "\<Union>(sset xss) = \<Union>(sset yss)" "distincts yss" "map set xss = map set yss" "map hd xss = map hd yss"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: distincts_Cons in_set_cyc_permutations)
  } note X = this
  { assume A: "distincts yss" "map set xss = map set yss" "map hd xss = map hd yss"
    then have "length yss = length xss" by (auto dest: map_eq_imp_length_eq)
    then have "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map cyc_permutations xss)"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: distincts_Cons in_set_cyc_permutations)
  } note Y = this
  show "?thesis"
    unfolding cyc_permutationss_def
    by (auto simp: product_lists_set intro: X Y)
qed

lemma lists_succ_set_cyc_permutationss:
  assumes "distincts xss"
  shows "lists_succ ` set (cyc_permutationss xss) = {f. f permutes \<Union>(sset xss) \<and> (\<forall>c \<in> sset xss. cyclic_on f c)}" (is "?L = ?R")
  using assms
proof (intro set_eqI iffI)
  fix f assume "f \<in> ?L"
  then obtain yss where "yss \<in> set (cyc_permutationss xss)" "f = lists_succ yss" by (rule imageE)
  moreover
  from \<open>yss \<in> _\<close> assms have "set (map set xss) = set (map set yss)"
    by (auto simp: in_set_cyc_permutationss)
  then have "sset xss = sset yss" by simp
  ultimately
  show "f \<in> ?R"
    using assms
  by (auto simp: in_set_cyc_permutationss cyclic_on_lists_succ') (metis lists_succ_permutes)
next
  fix f assume "f \<in> ?R"
  then have "f permutes \<Union>(sset xss)" "\<And>cs. cs \<in> set xss \<Longrightarrow> cyclic_on f (set cs)"
    by auto
  from this(1) refl assms this(2)
  obtain yss where "f = lists_succ yss" "distincts yss" "map set yss = map set xss" "map hd yss = map hd xss"
    by (rule cyclic_on_obtain_lists_succ)
  with assms show "f \<in> ?L" by (auto intro!: imageI simp: in_set_cyc_permutationss)
qed

subsection \<open>Lists of Permutations\<close>

definition permutationss :: "'a list list \<Rightarrow> 'a list list list" where
  "permutationss = product_lists o map permutations"

lemma permutationss_Nil[simp]: "permutationss [] = [[]]"
  by (auto simp: permutationss_def)

lemma permutationss_Cons:
  "permutationss (xs # xss) = concat (map (\<lambda>ys. map (Cons ys) (permutationss xss)) (permutations xs))"
  by (auto simp: permutationss_def)

lemma in_set_permutationss:
  assumes "distincts xss"
  shows "yss \<in> set (permutationss xss) \<longleftrightarrow> distincts yss \<and> map set xss = map set yss"
proof -
  { assume A: "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map permutations xss)"
    then have "length yss = length xss" by (auto simp: list_all2_lengthD)
    then have "\<Union>(sset xss) = \<Union>(sset yss)" "distincts yss" "map set xss = map set yss"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: distincts_Cons in_set_permutations)
  } note X = this
  { assume A: "distincts yss" "map set xss = map set yss"
    then have "length yss = length xss" by (auto dest: map_eq_imp_length_eq)
    then have "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map permutations xss)"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: in_set_permutations distincts_Cons)
  } note Y = this
  show "?thesis"
    unfolding permutationss_def
    by (auto simp: product_lists_set intro: X Y)
qed

lemma set_permutationss:
  assumes "distincts xss"
  shows "set (permutationss xss) = {yss. distincts yss \<and> map set xss = map set yss}"
  using in_set_permutationss[OF assms] by blast

lemma permutations_complete: (* could generalize with multi-sets *)
  assumes "distinct xs" "distinct ys" "set xs = set ys"
  shows "ys \<in> set (permutations xs)"
  using assms
proof (induct "length xs" arbitrary: xs ys)
  case 0 then show ?case by simp
next
  case (Suc n)
  from Suc.hyps have "xs \<noteq> []" by auto
  then obtain y ys' where [simp]: "ys = y # ys'" "y \<in> set xs" using Suc.prems by (cases ys) auto
  have "ys' \<in> set (permutations (remove1 y xs))"
    using Suc.prems \<open>Suc n = _\<close> by (intro Suc.hyps) (simp_all add: length_remove1 )
  then show ?case using \<open>xs \<noteq> []\<close> by (auto simp: set_permutations_step)
qed

end