theory ClosedPermutations
  imports IndividualMorphisms IndividualSubStructure
begin

context individual_structure_defs
begin

definition ClosedPerms ("\<Pi>\<^bsub>_\<^esub>" [1] 999) where
  "\<Pi>\<^bsub>\<phi>\<^esub> \<equiv> { p . p \<in> Perms \<and> (\<forall>x \<in> \<I>. \<phi> x (p x)) }"

lemma ClosedPermsI[intro!]:
  assumes "p \<in> Perms" "\<And>x. x \<in> \<I> \<Longrightarrow> \<phi> x (p x)"
  shows "p \<in> \<Pi>\<^bsub>\<phi>\<^esub>"
  using assms by (auto simp: ClosedPerms_def)

lemma ClosedPermsE[elim!]:
  assumes "p \<in> \<Pi>\<^bsub>\<phi>\<^esub>"
  obtains "p \<in> Perms" "\<And>x. x \<in> \<I> \<Longrightarrow> \<phi> x (p x)"
  using assms by (auto simp: ClosedPerms_def)

lemma ClosedPerms_iff:
  "p \<in> \<Pi>\<^bsub>\<phi>\<^esub> \<longleftrightarrow> p \<in> Perms \<and> (\<forall>x. x \<in> \<I> \<longrightarrow> \<phi> x (p x))"
  by blast

end

context individual_structure_defs
begin

abbreviation "closure P \<equiv> closure_rel_P P \<I>"

end

context individual_structure
begin

(* UNUSED lemma closed_perms_mono:
  assumes "closure P" "closure Q" "\<And>x y. P x y \<longrightarrow> Q x y"
  shows "\<Pi>\<^bsub>P\<^esub> \<subseteq> \<Pi>\<^bsub>Q\<^esub>"
proof -
  interpret P: closure_rel_P P \<I> using assms by simp
  interpret Q: closure_rel_P Q \<I> using assms by simp
  show ?thesis
    using assms(3) by auto
qed *)

lemma substructure_closed_perms:
  fixes IS'
  assumes "individual_substructure  IS IS'" and
    "closure_rel_P P \<I>\<^bsub>IS'\<^esub>" "closure_rel_P P \<I>"
    "closure_rel_P P \<S>"
    "\<Omega> \<in> individual_structure_defs.ClosedPerms IS' P"
  shows "\<Omega> \<in> \<Pi>\<^bsub>P\<^esub>"
proof -
  interpret IS': individual_structure IS' using assms(1) by (simp add: individual_substructure_def)
  interpret IS_IS': individual_substructure  IS IS' using assms(1) by simp
  interpret P1: closure_rel_P P "\<I>\<^bsub>IS'\<^esub>"  using assms by simp
  interpret P2: closure_rel_P P \<I>  using assms by simp
  interpret PS: closure_rel_P P \<S>  using assms by simp
  have moments_subset: "\<M> \<subseteq> \<M>\<^bsub>IS'\<^esub>" using IS_IS'.moments_subset by blast
  have S_IS'[simp]: "\<S>\<^bsub>IS'\<^esub> = \<S>" by (simp add: IS_IS'.same_substantials)
  have closure_P[intro!,simp]: "closure P" by (simp add: P2.closure_rel_P_axioms)
  have closure_P'[intro!,simp]: "IS'.closure P" by (simp add: P1.closure_rel_P_axioms)
  note set_lemmas = individuals_moments_substantials IS'.individuals_moments_substantials[simplified S_IS']
      substantials_moments_disj IS'.substantials_moments_disj[simplified S_IS']
      S_IS'
  have M'_eq1: "\<M>\<^bsub>IS'\<^esub> = \<I>\<^bsub>IS'\<^esub> - \<S>"
    using IS'.individuals_moments_substantials set_lemmas(4) by auto
  have M_eq1: "\<M> = \<I> - \<S>" using individuals_moments_substantials Un_Diff by auto
  interpret PM': closure_rel_P P "\<M>\<^bsub>IS'\<^esub>"
    by (simp add: M'_eq1 ; intro closure_rel_combs(3) ; (simp add: PS.closure_rel_P_axioms)?)
  interpret PM: closure_rel_P P "\<M>"
    by (simp add: M_eq1 ; intro closure_rel_combs(3) ; (simp add: PS.closure_rel_P_axioms)?)
  have A0: "\<M> = \<M>\<^bsub>IS'\<^esub> \<inter> \<I>"
    apply (intro equalityI)
    subgoal G1 by (simp add: moments_subset)
    using IS'.substantials_moments_disj by auto
  interpret P3: closure_rel_P P "\<I>\<^bsub>IS'\<^esub> - \<I>"  using assms closure_rel_combs(3) by blast
  obtain A: "\<Omega> \<in> IS'.Perms" "\<And>x. x \<in> \<I>\<^bsub>IS'\<^esub> \<Longrightarrow> P x (\<Omega> x)"
    using assms(5) by blast
  interpret omega_IS': individual_structure_permutation_morphism IS' \<Omega>
    using A(1) by blast
  have B: "\<I> \<subseteq> \<I>\<^bsub>IS'\<^esub>"
    using moments_subset by (simp add: IS'.individuals_moments_substantials individuals_moments_substantials ; blast)
  note omega_substantials[simp] = omega_IS'.m_substantials[simplified]
  have aux1: "A \<or> B \<longleftrightarrow> A \<or> C" if "B \<longleftrightarrow> C" for A B C using that by blast
  have aux2: "B \<and> A \<longleftrightarrow> C \<and> A" if "B \<longleftrightarrow> C" for A B C using that by blast
  have C[simp]: "\<Omega> x \<in> \<I> \<longleftrightarrow> x \<in> \<I>" for x
    apply (simp add: individuals_moments_substantials ; intro aux1 ; simp add: M_eq1 ; intro aux2)
    using B P2.closed_iff assms(5) by blast
  have C1[simp]: "omega_IS'.\<Theta> x \<in> \<S> \<longleftrightarrow> x \<in> \<S>" for x
    using omega_IS'.m_inv_simps(4) by auto
  have C2[simp]: "omega_IS'.\<Theta> x \<in> \<M> \<longleftrightarrow> x \<in> \<M>" for x
    by (metis A0 C Int_iff individual_structure_injective_morphism.m_inv_scope_moments omega_IS'.individual_structure_injective_morphism_axioms omega_IS'.m_inv_inv_moments_iff omega_IS'.m_inv_simps(5))
  have C3[simp]: "omega_IS'.\<Theta> x \<in> \<I> \<longleftrightarrow> x \<in> \<I>" for x
    by (simp only: individuals_moments_substantials Un_iff C1 C2)
  have D[simp]: "\<Omega> x \<in> \<M> \<longleftrightarrow> x \<in> \<M>" for x
    by (simp add: M_eq1)
  have E[simp]: "omega_IS'.\<Theta> ` \<I> = \<I>"
    apply (intro set_eqI iffI ; (elim imageE)? ; hypsubst_thin?)
    subgoal by simp
    subgoal for x
      apply (intro rev_image_eqI[of "\<Omega> x"] ; simp)
      using B by blast
    done
  have F[simp]: "\<Omega> ` \<I> = \<I>"
    apply (intro set_eqI iffI ; (elim imageE)? ; hypsubst_thin?)
    subgoal by simp
    subgoal for x
      apply (intro rev_image_eqI[of "omega_IS'.\<Theta> x"] ; simp?)
      using B by auto
    done
  note omega_simps = C D omega_IS'.m_individuals omega_IS'.m_substantials[simplified S_IS']
                        omega_IS'.m_moments S_IS'
  have R1: "individual_structure_morphism IS IS \<Omega>"
    apply (unfold_locales)
    subgoal G1 for x
      apply (intro disjCI ; simp ; elim conjE disjE impCE)
      using set_lemmas by blast
    subgoal G2 for x y
      apply (cases "x \<in> \<I>\<^bsub>IS'\<^esub>")
      subgoal
        apply (cases "x \<in> \<M>")
        subgoal by (simp only: IS_IS'.preserve_inherence[of x y] omega_IS'.m_preserve_inherence[of x y]  IS_IS'.preserve_inherence[of "\<Omega> x" "\<Omega> y",symmetric,simplified omega_simps])
        using inheres_in_scope_2 D by blast
      subgoal
        apply (simp add:  IS'.individuals_moments_substantials ; elim conjE)
        using moments_subset by auto
      done
    subgoal G3 for x y
      apply (cases "x \<in> \<M>\<^bsub>IS'\<^esub>")
      subgoal
        apply (cases "x \<in> \<M>")
        subgoal by (meson D IS_IS'.preserve_exact_similarity exactly_similar_scope omega_IS'.m_preserve_exact_similarity)
        using exactly_similar_scope D by meson
      subgoal
        apply (simp add:  M'_eq1 ; cases "x \<in> \<I>" ; elim impCE)
        subgoal using B subsetD by metis
        subgoal using exactly_similar_scope omega_simps(2)  substantials_moments_disj_2 by metis
        subgoal using exactly_similar_scope omega_simps(2)  moments_subset_individuals subsetD by metis
        using exactly_similar_scope omega_simps(2)  moments_subset_individuals subsetD by metis
      done
    subgoal G4 for x y
      apply (cases "x \<in> \<M>")
      subgoal by (metis D IS_IS'.m_preserve_ext_dep IS_IS'.m_preserve_refers_to omega_IS'.m_preserve_refers_to omega_substantials refers_to_scope)
      using D refers_to_scope by blast
    subgoal G5 for x y
      apply (cases "x \<in> \<I> \<and> y \<in> \<I>" ; (elim conjE)? ; simp?)
      subgoal
        apply (simp flip: IS_IS'.m_preserve_ed)
        using omega_IS'.m_preserve_ed by blast
      subgoal premises P
        using P(1) P(2)[rule_format] ed_scope omega_simps(1) by metis
      done
    apply (subgoal_tac "\<forall>w \<in> \<W>. \<Omega> ` w \<in> \<W>" "\<forall>w \<in> \<W>. omega_IS'.\<Theta> ` w \<in> \<W>" )
    subgoal G6
      apply (intro Collect_by_func_I[where ?G="(`) omega_IS'.\<Theta>" and ?F="(`) \<Omega>"]
            )
      subgoal G6_1 for w by simp
      subgoal G6_2 for w
        apply (intro set_eqI iffI IntI ; (elim imageE IntE) ; hypsubst_thin)
        subgoal G6_2_1 for _ _ y
          by (metis IS_IS'.individuals_subset IS_IS'.m_preserve_worlds_2 Int_iff omega_IS'.m_comp_m_inv_eq' subset_iff)
        subgoal G6_2_2 for _ _ y
          apply (intro imageI)
          using C G6_2_1 individuals_iff by auto
        subgoal G6_2_3 for _ y
          apply (intro imageI ; intro rev_image_eqI[of "\<Omega> y"] ; simp ; intro impI)
          using IS_IS'.individuals_subset by blast
        done
      subgoal G6_3 for w by simp
      subgoal G6_4 premises P for w
        using P(2)[rule_format,OF P(3)] P(3) worlds_are_made_of_individuals by blast
      done
    subgoal G7 premises P
      apply (intro ballI)
      subgoal premises Q for w
        supply A = P[rule_format]
        using IS_IS'.m_preserve_worlds_2[OF Q] Q apply (elim exE conjE)
        subgoal premises U for w'
          using U apply (hypsubst_thin)
          subgoal premises T
            apply (simp add: inj_on_image_Int[OF omega_IS'.m_inv_injective
              IS'.worlds_are_made_of_individuals[OF T(2)] B])
            apply (subgoal_tac "omega_IS'.\<Theta> ` \<I> = \<I>" ; simp?)
              subgoal
                apply (subgoal_tac "omega_IS'.\<Theta> ` w' \<in> \<W>\<^bsub>IS'\<^esub>")
                subgoal by (simp add: IS'.worlds_are_made_of_individuals IS_IS'.m_preserve_worlds_1 T(2))
                apply (intro omega_IS'.m_inv_w_W[THEN iffD2])
                subgoal premises _
                  using U(2) IS'.worlds_are_made_of_individuals by metis
                using U(2) by simp
              done
            done
          done
        done
  proof
    fix w
    assume as: "w \<in> \<W>"
    then obtain w' where AA: "w = w' \<inter> \<I>" "w' \<in> \<W>\<^bsub>IS'\<^esub>"
      using IS_IS'.m_preserve_worlds_2 by blast
    have "\<Omega> ` w' \<in> \<W>\<^bsub>IS'\<^esub>" using AA(2) by simp
    then have BB: "(\<Omega> ` w') \<inter> \<I> \<in> \<W>"  using IS_IS'.m_preserve_worlds_1 by simp
    have DD: "(\<Omega> ` w') \<inter> \<I> = \<Omega> ` (w' \<inter> \<I>)" by auto
    have EE: "\<Omega> ` (w' \<inter> \<I>) = \<Omega> ` w" using AA by simp
    then show "\<Omega> ` w \<in> \<W>" using DD EE BB by simp
  qed
  then interpret omega_IS: individual_structure_morphism IS IS \<Omega> by simp
  have R2: "individual_structure_permutation_morphism IS \<Omega>"
    apply (unfold_locales)
    subgoal by (rule inj_on_subset[OF omega_IS'.m_injective] ; intro B)
    subgoal by simp
    subgoal for x
      supply AA = omega_IS'.m_strong_preserve_similarity[of x]
                  IS_IS'.preserve_exact_similarity[of x "\<Omega> x",THEN iffD1]
      apply (intro AA(2)[OF _ _ AA(1)] ; simp?)
      using moments_subset by blast
    done
  show ?thesis
  proof (intro ClosedPermsI PermI R2)
    fix x
    assume "x \<in> \<I>"
    then show "P x (\<Omega> x)"
      using IS_IS'.individuals_subset assms(5) by blast
  qed
qed

end

(*
locale closed_individual_structure_permutation =
  individual_structure_permutation_morphism +
  \<phi>: closure_rel_P \<phi> \<I> for \<phi>  +
assumes
  p_closed_perm[iff]: "\<Omega> \<in> \<Pi>\<^bsub>\<phi>\<^esub>" and
  phi_closure[intro!,simp]: "closure \<phi>"
begin

lemma ClosedPerm_is_closed:  "x \<in> \<I> \<Longrightarrow> \<phi> x (\<Omega> x)"
    using p_closed_perm by blast

lemma ClosedPerm_inv_is_closed:
  assumes "x \<in> \<I>"
  shows "\<phi> x (\<Theta> x)"
  using ClosedPerm_is_closed[of "\<Theta> x",simplified,symmetric] assms by metis

end *)

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_23
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun half :: "Nat => Nat" where
  "half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S z2)) = S (half z2)"

theorem property0 :
  "((half (length (x y z))) = (half (length (x z y))))"
  oops

end


section \<open>Nested datatypes\<close>

theory Nested_Datatype
imports Main
begin

subsection \<open>Terms and substitution\<close>

datatype ('a, 'b) "term" =
  Var 'a
| App 'b "('a, 'b) term list"

primrec subst_term :: "('a \<Rightarrow> ('a, 'b) term) \<Rightarrow> ('a, 'b) term \<Rightarrow> ('a, 'b) term"
  and subst_term_list :: "('a \<Rightarrow> ('a, 'b) term) \<Rightarrow> ('a, 'b) term list \<Rightarrow> ('a, 'b) term list"
where
  "subst_term f (Var a) = f a"
| "subst_term f (App b ts) = App b (subst_term_list f ts)"
| "subst_term_list f [] = []"
| "subst_term_list f (t # ts) = subst_term f t # subst_term_list f ts"

lemmas subst_simps = subst_term.simps subst_term_list.simps

text \<open>\medskip A simple lemma about composition of substitutions.\<close>

lemma
  "subst_term (subst_term f1 \<circ> f2) t =
    subst_term f1 (subst_term f2 t)"
  and
  "subst_term_list (subst_term f1 \<circ> f2) ts =
    subst_term_list f1 (subst_term_list f2 ts)"
  by (induct t and ts rule: subst_term.induct subst_term_list.induct) simp_all

lemma "subst_term (subst_term f1 \<circ> f2) t = subst_term f1 (subst_term f2 t)"
proof -
  let "?P t" = ?thesis
  let ?Q = "\<lambda>ts. subst_term_list (subst_term f1 \<circ> f2) ts =
    subst_term_list f1 (subst_term_list f2 ts)"
  show ?thesis
  proof (induct t rule: subst_term.induct)
    fix a show "?P (Var a)" by simp
  next
    fix b ts assume "?Q ts"
    then show "?P (App b ts)"
      by (simp only: subst_simps)
  next
    show "?Q []" by simp
  next
    fix t ts
    assume "?P t" "?Q ts" then show "?Q (t # ts)"
      by (simp only: subst_simps)
  qed
qed

subsection \<open>Alternative induction\<close>

lemma "subst_term (subst_term f1 \<circ> f2) t = subst_term f1 (subst_term f2 t)"
proof (induct t rule: term.induct)
  case (Var a)
  show ?case by (simp add: o_def)
next
  case (App b ts)
  then show ?case by (induct ts) simp_all
qed

end


theory C
imports HOLCF "Mono-Nat-Fun"
begin

default_sort cpo

text {*
The initial solution to the domain equation $C = C_\bot$, i.e. the completion of the natural numbers.
*}

domain C = C (lazy "C")

lemma below_C: "x \<sqsubseteq> C\<cdot>x"
  by (induct x) auto

definition Cinf ("C\<^sup>\<infinity>") where "C\<^sup>\<infinity> = fix\<cdot>C"

lemma C_Cinf[simp]: "C\<cdot>C\<^sup>\<infinity> = C\<^sup>\<infinity>" unfolding Cinf_def by (rule fix_eq[symmetric])

abbreviation Cpow ("C\<^bsup>_\<^esup>") where "C\<^bsup>n\<^esup> \<equiv> iterate n\<cdot>C\<cdot>\<bottom>"

lemma C_below_C[simp]: "(C\<^bsup>i\<^esup> \<sqsubseteq> C\<^bsup>j\<^esup>) \<longleftrightarrow> i \<le> j"
  apply (induction i arbitrary: j)
  apply simp
  apply (case_tac j, auto)
  done

lemma below_Cinf[simp]: "r \<sqsubseteq> C\<^sup>\<infinity>"
  apply (induct r)
  apply simp_all[2]
  apply (metis (full_types) C_Cinf monofun_cfun_arg)
  done

lemma C_eq_Cinf[simp]: "C\<^bsup>i\<^esup> \<noteq> C\<^sup>\<infinity>"
  by (metis C_below_C Suc_n_not_le_n below_Cinf)

lemma Cinf_eq_C[simp]: "C\<^sup>\<infinity> = C \<cdot> r \<longleftrightarrow> C\<^sup>\<infinity> = r"
  by (metis C.injects C_Cinf)

lemma C_eq_C[simp]: "(C\<^bsup>i\<^esup> = C\<^bsup>j\<^esup>) \<longleftrightarrow> i = j"
  by (metis C_below_C le_antisym le_refl)

lemma case_of_C_below: "(case r of C\<cdot>y \<Rightarrow> x) \<sqsubseteq> x"
  by (cases r) auto

lemma C_case_below: "C_case \<cdot> f \<sqsubseteq> f"
  by (metis cfun_belowI C.case_rews(2) below_C monofun_cfun_arg)

lemma C_case_bot[simp]: "C_case \<cdot> \<bottom> = \<bottom>"
  apply (subst eq_bottom_iff)
  apply (rule C_case_below)
  done

lemma C_case_cong:
  assumes "\<And> r'. r = C\<cdot>r' \<Longrightarrow> f\<cdot>r' = g\<cdot>r'"
  shows "C_case\<cdot>f\<cdot>r = C_case\<cdot>g\<cdot>r"
using assms by (cases r) auto

lemma C_cases:
  obtains n where "r = C\<^bsup>n\<^esup>" | "r = C\<^sup>\<infinity>"
proof-
  { fix m
    have "\<exists> n. C_take m \<cdot> r = C\<^bsup>n\<^esup> "
    proof (rule C.finite_induct)
      have "\<bottom> = C\<^bsup>0\<^esup>" by simp
      thus "\<exists>n. \<bottom> = C\<^bsup>n\<^esup>"..
    next
      fix r
      show "\<exists>n. r = C\<^bsup>n\<^esup> \<Longrightarrow> \<exists>n. C\<cdot>r = C\<^bsup>n\<^esup>"
        by (auto simp del: iterate_Suc simp add: iterate_Suc[symmetric])
    qed
  }
  then obtain f where take: "\<And> m. C_take m \<cdot> r = C\<^bsup>f m\<^esup>" by metis
  have "chain (\<lambda> m. C\<^bsup>f m\<^esup>)" using ch2ch_Rep_cfunL[OF C.chain_take, where x=r, unfolded take].
  hence "mono f" by (auto simp add: mono_iff_le_Suc chain_def elim!:chainE)
  have r: "r = (\<Squnion> m. C\<^bsup>f m\<^esup>)"  by (metis (lifting) take C.reach lub_eq)
  from `mono f`
  show thesis
  proof(rule nat_mono_characterization)
    fix n
    assume n: "\<And> m. n \<le> m ==> f n = f m"
    have "max_in_chain n (\<lambda> m. C\<^bsup>f m\<^esup>)"
      apply (rule max_in_chainI)
      apply simp
      apply (erule n)
      done
    hence "(\<Squnion> m. C\<^bsup>f m\<^esup>) = C\<^bsup>f n\<^esup>" unfolding  maxinch_is_thelub[OF `chain _`].
    thus ?thesis using that unfolding r by blast
  next
    assume "\<And>m. \<exists>n. m \<le> f n"
    hence "\<And> n. C\<^bsup>n\<^esup> \<sqsubseteq> r" unfolding r by (fastforce intro: below_lub[OF `chain _`])
    hence "(\<Squnion> n. C\<^bsup>n\<^esup>) \<sqsubseteq> r"
      by (rule lub_below[OF chain_iterate])
    hence "C\<^sup>\<infinity> \<sqsubseteq> r" unfolding Cinf_def fix_def2.
    hence "C\<^sup>\<infinity> = r" using below_Cinf by (metis below_antisym)
    thus thesis using that by blast
  qed
qed

lemma C_case_Cinf[simp]: "C_case \<cdot> f \<cdot> C\<^sup>\<infinity> = f \<cdot> C\<^sup>\<infinity>"
  unfolding Cinf_def
  by (subst fix_eq) simp

fixrec Cpred :: "C \<rightarrow> C" where "Cpred\<cdot>(C\<cdot>r) = r"

lemma Cpred_strict[simp]: "Cpred\<cdot>\<bottom> = \<bottom>" by fixrec_simp

lemma Cpred_below: "Cpred\<cdot>r \<sqsubseteq> r"
  by (cases r) (simp_all add: below_C)

lemma C_Cpred_id[simp]:
  "r \<noteq> \<bottom> \<Longrightarrow> C\<cdot>(Cpred\<cdot>r) = r"
  by (cases r) auto

end