theory Smap_siterate_comp
  imports Main "$HIPSTER_HOME/IsaHipster"
    Smap_laws
begin
setup Tactic_Data.set_coinduct_sledgehammer
primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "siterate f a = SCons a (siterate f (f a))"
(*cohipster smap siterate*)
lemma lemma_ac [thy_expl]: "smap y (siterate y z) = siterate y (y z)"
  by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_ad [thy_expl]: "smap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
 by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_ac)
(*cohipster smap siterate Fun.comp \<comment> "Explore smap, siterate, and function composition"
*)
text_raw \<open>\DefineSnippet{siteratefusion}{\<close>
lemma lemma_ae [thy_expl]: "smap z (siterate (y \<circ> z) x2) = siterate (z \<circ> y) (z x2)"
 by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    auto
text_raw \<open>}%EndSnippet\<close>

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3_same
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 x y z) = (add3acc x y z))"
  oops

end


section \<open>Topological Manifolds\<close>
theory Topological_Manifold
  imports Chart
begin

text \<open>Definition of topological manifolds. Existence of locally finite cover.\<close>

subsection \<open>Defintition\<close>

text \<open>We define topological manifolds as a second-countable Hausdorff space, where
  every point in the carrier set has a neighborhood that is homeomorphic to an open
  subset of the Euclidean space. Here topological manifolds are specified by a set
  of charts, and the carrier set is simply defined to be the union of the domain of
  the charts.\<close>
locale manifold =
  fixes charts::"('a::{second_countable_topology, t2_space}, 'e::euclidean_space) chart set"
begin

definition "carrier = (\<Union>(domain ` charts))"

lemma open_carrier[intro, simp]: "open carrier"
  by (auto simp: carrier_def)

lemma domain_subset_carrier[simp]: "domain c \<subseteq> carrier" if "c \<in> charts"
  using that
  by (auto simp: carrier_def)

lemma in_domain_in_carrier[intro, simp]: "c \<in> charts \<Longrightarrow> x \<in> domain c \<Longrightarrow> x \<in> carrier"
  by (auto simp: carrier_def)

subsection \<open>Existence of locally finite cover\<close>

text \<open>Every point has a precompact neighborhood.\<close>
lemma precompact_neighborhoodE:
  assumes "x \<in> carrier"
  obtains C where "x \<in> C" "open C" "compact (closure C)" "closure C \<subseteq> carrier"
proof -
  from carrierE[OF assms] obtain c where c: "c \<in> charts" "x \<in> domain c" by auto
  then have "c x \<in> codomain c" by auto
  with open_contains_cball[of "codomain c"]
  obtain e where e: "0 < e" "cball (apply_chart c x) e \<subseteq> codomain c"
    by auto
  then have e': "ball (apply_chart c x) e \<subseteq> codomain c"
    by (auto simp: mem_ball)
  define C where "C = inv_chart c ` ball (c x) e"
  have "x \<in> C"
    using c \<open>e > 0\<close>
    unfolding C_def
    by (auto intro!: image_eqI[where x="apply_chart c x"])
  moreover have "open C"
    using e'
    by (auto simp: C_def)
  moreover
  have compact: "compact (inv_chart c ` cball (apply_chart c x) e)"
    using e
    by (intro compact_continuous_image continuous_on_chart) auto
  have closure_subset: "closure C \<subseteq> inv_chart c ` cball (apply_chart c x) e"
    apply (rule closure_minimal)
    subgoal by (auto simp: C_def mem_ball)
    subgoal by (rule compact_imp_closed) (rule compact)
    done
  have "compact (closure C)"
    apply (rule compact_if_closed_subset_of_compact[where T="inv_chart c ` cball (c x) e"])
    subgoal by simp
    subgoal by (rule compact)
    subgoal by (rule closure_subset)
    done
  moreover have "closure C \<subseteq> carrier"
    using closure_subset c e
    by force
  ultimately show ?thesis ..
qed

text \<open>There exists a covering of the carrier by precompact sets.\<close>
lemma precompact_open_coverE:
  obtains U::"nat\<Rightarrow>'a set"
  where "(\<Union>i. U i) = carrier" "\<And>i. open (U i)" "\<And>i. compact (closure (U i))"
    "\<And>i. closure (U i) \<subseteq> carrier"
proof cases
  assume "carrier = {}"
  then have "(\<Union>i. {}) = carrier" "open {}" "compact (closure {})" "closure {} \<subseteq> carrier"
    by auto
  then show ?thesis ..
next
  assume "carrier \<noteq> {}"
  have "\<exists>b. x \<in> b \<and> open b \<and> compact (closure b) \<and> closure b \<subseteq> carrier" if "x \<in> carrier" for x
    using that
    by (rule precompact_neighborhoodE) auto
  then obtain balls where balls:
    "\<And>x. x \<in> carrier \<Longrightarrow> x \<in> balls x"
    "\<And>x. x \<in> carrier \<Longrightarrow> open (balls x)"
    "\<And>x. x \<in> carrier \<Longrightarrow> compact (closure (balls x))"
    "\<And>x. x \<in> carrier \<Longrightarrow> closure (balls x) \<subseteq> carrier"
    by metis
  let ?balls = "balls ` carrier"
  have *: "\<And>x::'a set. x \<in> ?balls \<Longrightarrow> open x" by (auto simp: balls)
  from Lindelof[of "?balls", OF this]
  obtain \<F>' where \<F>': "\<F>' \<subseteq> ?balls" "countable \<F>'" "\<Union>\<F>' = \<Union>?balls"
    by auto
  have "\<F>' \<noteq> {}" using \<F>' balls \<open>carrier \<noteq> {}\<close>
    by auto
  define U where "U = from_nat_into \<F>'"
  have into_range_balls: "U i \<in> ?balls" for i
  proof -
    have "from_nat_into \<F>' i \<in> \<F>'" for i
      by (rule from_nat_into) fact
    also have "\<F>' \<subseteq> ?balls" by fact
    finally show ?thesis by (simp add: U_def)
  qed
  have U: "open (U i)" "compact (closure (U i))" "closure (U i) \<subseteq> carrier" for i
    using balls into_range_balls[of i]
    by force+
  then have "U i \<subseteq> carrier" for i using closure_subset by force
  have "(\<Union>i. U i) = carrier"
  proof (rule antisym)
    show "(\<Union>i. U i) \<subseteq> carrier" using \<open>U _ \<subseteq> carrier\<close> by force
  next
    show "carrier \<subseteq> (\<Union>i. U i)"
    proof safe
      fix x::'a
      assume "x \<in> carrier"
      then have "x \<in> balls x" by fact
      with \<open>x \<in> carrier\<close> \<F>' obtain F where "x \<in> F" "F \<in> \<F>'" by blast
      with from_nat_into_surj[OF \<open>countable \<F>'\<close> \<open>F \<in> \<F>'\<close>]
      obtain i where "x \<in> U i" by (auto simp: U_def)
      then show "x \<in> (\<Union>i. U i)" by auto
    qed
  qed
  then show ?thesis using U ..
qed

text \<open>There exists a locally finite covering of the carrier by precompact sets.\<close>
lemma precompact_locally_finite_open_coverE:
  obtains W::"nat\<Rightarrow>'a set"
  where "carrier = (\<Union>i. W i)" "\<And>i. open (W i)" "\<And>i. compact (closure (W i))"
    "\<And>i. closure (W i) \<subseteq> carrier"
    "locally_finite_on carrier UNIV W"
proof -
  from precompact_open_coverE obtain U
    where U: "(\<Union>i::nat. U i) = carrier" "\<And>i. open (U i)" "\<And>i. compact (closure (U i))"
      "\<And>i. closure (U i) \<subseteq> carrier"
    by auto
  have "\<exists>V. \<forall>j.
    (open (V j) \<and>
    compact (closure (V j)) \<and>
    U j \<subseteq> V j \<and>
    closure (V j) \<subseteq> carrier) \<and>
    closure (V j) \<subseteq> V (Suc j)"
    (is "\<exists>V. \<forall>j. ?P j (V j) \<and> ?Q j (V j) (V (Suc j))")
  proof (rule dependent_nat_choice)
    show "\<exists>x. ?P 0 x" using U by (force intro!: exI[where x="U 0"])
  next
    fix X n
    assume P: "?P n X"
    have "closure X \<subseteq> (\<Union>c. U c)"
      unfolding U using P by auto
    have "compact (closure X)" using P by auto
    from compactE_image[OF this, of UNIV U, OF \<open>open (U _)\<close> \<open>closure X \<subseteq> _\<close>]
    obtain M where M: "M \<subseteq> UNIV" "finite M" "closure X \<subseteq> (\<Union>c\<in>M. U c)"
      by auto
    show "\<exists>y. ?P (Suc n) y \<and> ?Q n X y"
    proof (intro exI[where x="U (Suc n) \<union> (\<Union>c\<in>M. U c)"] impI conjI)
      show "open (U (Suc n) \<union> \<Union>(U ` M))"
        by (auto intro!: U)
      show "compact (closure (U (Suc n) \<union> \<Union>(U ` M)))"
        using \<open>finite M\<close>
        by (auto simp add: closure_Union intro!: U)
      show "U (Suc n) \<subseteq> U (Suc n) \<union> \<Union>(U ` M)" by auto
      show "closure (U (Suc n) \<union> \<Union>(U ` M)) \<subseteq> carrier"
        using U \<open>finite M\<close>
        by (force simp: closure_Union)
      show "closure X \<subseteq> U (Suc n) \<union> (\<Union>c\<in>M. U c)"
        using M by auto
    qed
  qed
  then obtain V where V:
    "\<And>j. closure (V j) \<subseteq> V (Suc j)"
    "\<And>j. open (V j)"
    "\<And>j. compact (closure (V j))"
    "\<And>j. U j \<subseteq> V j"
    "\<And>j. closure (V j) \<subseteq> carrier"
    by metis
  have V_mono_Suc: "\<And>j. V j \<subseteq> V (Suc j)"
    using V by auto
  have V_mono: "V l \<subseteq> V m" if "l \<le> m" for l m
    using V_mono_Suc that
    by (rule lift_Suc_mono_le[of V])
  have V_cover: "carrier = \<Union>(V ` UNIV)"
  proof (rule antisym)
    show "carrier \<subseteq> \<Union>(V ` UNIV)"
      unfolding U(1)[symmetric]
      using V(4)
      by auto
    show "\<Union>(V ` UNIV) \<subseteq> carrier"
      using V(5) by force
  qed
  define W where "W j = (if j < 2 then V j else V j - closure (V (j - 2)))" for j
  have "compact (closure (W j))" for j
    apply (rule compact_if_closed_subset_of_compact[where T="closure (V j)"])
    subgoal by simp
    subgoal by (simp add: V)
    subgoal
      apply (rule closure_mono)
      using V(1)[of j] V(1)[of "Suc j"]
      by (auto simp: W_def)
    done
  have open_W: "open (W j)" for j
    by (auto simp: W_def V)
  have W_cover: "p \<in> \<Union>(W ` UNIV)" if "p \<in> carrier" for p
  proof -
    have "p \<in> \<Union>(V ` UNIV)" using that V_cover
      by auto
    then have ex: "\<exists>i. p \<in> V i" by auto
    define k where "k = (LEAST i. p \<in> V i)"
    from LeastI_ex[OF ex]
    have k: "p \<in> V k" by (auto simp: k_def)
    have "p \<in> W k"
    proof cases
      assume "k < 2"
      then show ?thesis using k
        by (auto simp: W_def)
    next
      assume k2: "\<not>k < 2"
      have False if "p \<in> closure (V (k - 2))"
      proof -
        have "Suc (k - 2) = k - 1" using k2 by arith
        then have "p \<in> V (k - 1)"
          using k2 that V(1)[of "k - 2"]
          by auto
        moreover
        have "k - 1 < k" using k2 by arith
        from not_less_Least[OF this[unfolded k_def], folded k_def]
        have "p \<notin> V (k - 1)" .
        ultimately show ?thesis by simp
      qed
      then show ?thesis
        using k
        by (auto simp: W_def)
    qed
    then show ?thesis by auto
  qed
  have W_eq_carrier: "carrier = (\<Union>i. W i)"
  proof (rule antisym)
    show "carrier \<subseteq> (\<Union>i. W i)"
      using W_cover by auto
    have "(\<Union>i. W i) \<subseteq> (\<Union>i. V i)"
      by (auto simp: W_def split: if_splits)
    also have "\<dots> = carrier" by (simp add: V_cover)
    finally show "(\<Union>i. W i) \<subseteq> carrier" .
  qed
  have W_disjoint: "W k \<inter> W l = {}" if less: "l < k - 1" for l k
  proof -
    from less have "k \<ge> 2" by arith
    then have "W k = V k - closure (V (k - 2))"
      by (auto simp: W_def)
    moreover have "W l \<subseteq> V (k - 2)"
    proof -
      have "W l \<subseteq> V l"
        by (auto simp: W_def)
      also have "\<dots> \<subseteq> V (k - 2)"
        by (rule V_mono) (use less in arith)
      finally show ?thesis .
    qed
    ultimately show ?thesis
      by auto
  qed
  have "locally_finite_on carrier UNIV W"
  proof (rule locally_finite_on_open_coverI)
    show "carrier \<subseteq> \<Union>(W ` UNIV)" unfolding W_eq_carrier by simp
    show "open (W i)" for i by (auto simp: open_W)
    fix k
    have "{i. W i \<inter> W k \<noteq> {}} \<subseteq> {(k - 1) .. (k + 1)}"
    proof (rule subsetI)
      fix l
      assume "l \<in> {i. W i \<inter> W k \<noteq> {}} "
      then have l: "W l \<inter> W k \<noteq> {}"
        by auto
      consider "l < k - 1" | "l > k + 1" | "k-1 \<le> l" "l \<le> k+1" by arith
      then show "l \<in> {(k - 1) .. (k + 1)}"
      proof cases
        case 1
        from W_disjoint[OF this] l
        show ?thesis by auto
      next
        case 2
        then have "k < l - 1" by arith
        from W_disjoint[OF this] l
        show ?thesis by auto
      next
        case 3
        then show ?thesis
          by (auto simp: l)
      qed
    qed
    also have "finite \<dots>" by simp
    finally (finite_subset)
    show "finite {i\<in>UNIV . W i \<inter> W k \<noteq> {}}" by simp
  qed
  have "closure (W i) \<subseteq> carrier" for i
    using V closure_mono
    apply (auto simp: W_def)
    using Diff_subset subsetD by blast
  have "carrier = (\<Union>i. W i)" "\<And>i. open (W i)" "\<And>i. compact (closure (W i))"
    "\<And>i. closure (W i) \<subseteq> carrier"
    "locally_finite_on carrier UNIV W"
    by fact+
  then show ?thesis ..
qed

end

end


subsection \<open>Reduction relation\<close>

theory Reduction
  imports Substitution
begin

inductive red_term :: "[trm, trm] \<Rightarrow> bool"  (infixl "\<longlonglongrightarrow>" 50)
      and red_cmd :: "[cmd, cmd] \<Rightarrow> bool"  (infixl "\<^sub>C\<longlonglongrightarrow>" 50)
where
  beta   [intro]: "(\<lambda> T : t)\<degree>r \<longlonglongrightarrow> t[r/0]\<^sup>T" |
  struct [intro]: "(\<mu> (T1\<rightarrow>T2) : c)\<degree>s \<longlonglongrightarrow> \<mu> T2 : (c[0 = 0 (\<diamond> \<^sup>\<bullet> (liftM_trm s 0))]\<^sup>C)" |
  rename [intro]: "\<lbrakk> 0 \<notin> (fmv_trm t 0) \<rbrakk> \<Longrightarrow> (\<mu> T : (<0> t)) \<longlonglongrightarrow> dropM_trm t 0" |
  mueta  [intro]: "<i> (\<mu> T : c) \<^sub>C\<longlonglongrightarrow> (dropM_cmd (c[0 = i \<diamond>]\<^sup>C) i)" |

  lambda [intro]: "\<lbrakk> s \<longlonglongrightarrow> t \<rbrakk> \<Longrightarrow> (\<lambda> T : s) \<longlonglongrightarrow> (\<lambda> T : t)" |
  appL   [intro]: "\<lbrakk> s \<longlonglongrightarrow> u \<rbrakk> \<Longrightarrow> (s\<degree>t) \<longlonglongrightarrow> (u\<degree>t)" |
  appR   [intro]: "\<lbrakk> t \<longlonglongrightarrow> u \<rbrakk> \<Longrightarrow> (s\<degree>t) \<longlonglongrightarrow> (s\<degree>u)" |
  mu     [intro]: "\<lbrakk> c \<^sub>C\<longlonglongrightarrow> d \<rbrakk> \<Longrightarrow> (\<mu> T : c) \<longlonglongrightarrow> (\<mu> T : d)" |
  cmd    [intro]: "\<lbrakk> t \<longlonglongrightarrow> s \<rbrakk> \<Longrightarrow> (<i> t) \<^sub>C\<longlonglongrightarrow> (<i> s)"

inductive_cases redE [elim]:
  "`i \<longlonglongrightarrow> s"
  "(\<lambda> T : t) \<longlonglongrightarrow> s"
  "s\<degree>t \<longlonglongrightarrow> u"
  "(\<mu> T : c) \<longlonglongrightarrow> t"
  "<i> t \<^sub>C\<longlonglongrightarrow> c"

text\<open>Reflexive transitive closure\<close>

inductive beta_rtc_term :: "[trm, trm] \<Rightarrow> bool"  (infixl "\<longlonglongrightarrow>\<^sup>*" 50) where
  refl_term [iff]: "s \<longlonglongrightarrow>\<^sup>* s" |
  step_term: "\<lbrakk>s \<longlonglongrightarrow> t; t \<longlonglongrightarrow>\<^sup>* u\<rbrakk> \<Longrightarrow> s \<longlonglongrightarrow>\<^sup>* u"

lemma step_term2: "\<lbrakk>s \<longlonglongrightarrow>\<^sup>* t; t \<longlonglongrightarrow> u\<rbrakk> \<Longrightarrow> s \<longlonglongrightarrow>\<^sup>* u"
  by (induct rule: beta_rtc_term.induct) (auto intro: step_term)

inductive beta_rtc_command :: "[cmd, cmd] \<Rightarrow> bool"  (infixl "\<^sub>C\<longlonglongrightarrow>\<^sup>*" 50) where
  refl_command [iff]: "c \<^sub>C\<longlonglongrightarrow>\<^sup>* c" |
  step_command: "c \<^sub>C\<longlonglongrightarrow> d \<Longrightarrow> d \<^sub>C\<longlonglongrightarrow>\<^sup>* e \<Longrightarrow> c \<^sub>C\<longlonglongrightarrow>\<^sup>* e"

text\<open>The beta reduction relation is included in the reflexive transitive closure.\<close>
lemma rtc_term_incl [intro]: "s \<longlonglongrightarrow> t \<Longrightarrow> s \<longlonglongrightarrow>\<^sup>* t"
  by (meson beta_rtc_term.simps)

lemma [intro]: "c \<^sub>C\<longlonglongrightarrow> d \<Longrightarrow> c \<^sub>C\<longlonglongrightarrow>\<^sup>* d"
  by(auto intro: step_command)

text\<open>Proof that the reflexive transitive closure as defined above is transitive.\<close>

lemma rtc_term_trans [intro]: "s \<longlonglongrightarrow>\<^sup>* t \<Longrightarrow> t \<longlonglongrightarrow>\<^sup>* u \<Longrightarrow> s \<longlonglongrightarrow>\<^sup>* u"
  by(induction rule: beta_rtc_term.induct) (auto simp add: step_term)

lemma rtc_command_trans[intro]: "c \<^sub>C\<longlonglongrightarrow>\<^sup>* d \<Longrightarrow> d \<^sub>C\<longlonglongrightarrow>\<^sup>* e \<Longrightarrow> c \<^sub>C\<longlonglongrightarrow>\<^sup>* e"
  by(induction rule: beta_rtc_command.induct) (auto simp add: step_command)

text\<open>Congruence rules for the reflexive transitive closure.\<close>

lemma rtc_lambda: "s \<longlonglongrightarrow>\<^sup>* t \<Longrightarrow> (\<lambda> T : s) \<longlonglongrightarrow>\<^sup>* (\<lambda> T : t)"
  apply(induction rule: beta_rtc_term.induct)
  by force (meson red_term_red_cmd.lambda step_term)

lemma rtc_appL: "s \<longlonglongrightarrow>\<^sup>* u \<Longrightarrow> (s\<degree>t) \<longlonglongrightarrow>\<^sup>* (u\<degree>t)"
  apply(induction rule: beta_rtc_term.induct)
  by force (meson appL step_term)

end


(*  Title:       The Cayley-Hamilton Theorem
    Author:      Stephan Adelsberger <sadelsbe /at/ wu /dot/ ac /dot/ at>,
                 Stefan Hetzl <stefan.hetzl /at/ tuwien /dot/ ac /dot/ at>,
                 Florian Pollak <florian.pollak /at/ gmail /dot/ com>, 2014
    Maintainer:  Stephan Adelsberger <sadelsbe /at/ wu /dot/ ac /dot/ at>
*)

header {* The Cayley-Hamilton theorem\label{sec.ch} *}

theory Cayley_Hamilton
imports
  Main
  "~~/src/HOL/Library/Polynomial"
  "~~/src/HOL/Multivariate_Analysis/Determinants"
  Polynomial_extension
  Determinants_extension
  Matrices
  Polynomial_matrix
begin

text{* As preparation for the proof of the Cayley-Hamilton theorem we first show
   that the maximal degree of $\mathrm{adj}(X I_n - A)$ is $n-1$. *}

lemma maxdeg_cofactorM:
fixes A :: "'a::comm_ring_1^'n\<Colon>finite^'n"
shows "maxdegM (transpose (cofactorM (mat (monom 1 (Suc 0)) - mat2matofpoly A))) = CARD('n) - 1"
proof-
  txt{* charpoly *}
  let ?B = "mat (monom 1 (Suc 0)) - mat2matofpoly A"
  let ?U = "UNIV :: 'n::finite set"

  let ?f = "\<lambda>p. \<Sum>i\<in>?U. degree (?B $ i $ p i)"
  let ?m = "Max {\<Sum>i\<in>?U. degree (?B $ i $ p i) | p. p permutes ?U}"
  let ?mon_A = "\<lambda>i. monom 1 (Suc 0) - [:A $ i $ i:]"

  { fix i j :: "'n::finite"
    let ?B' = "minorM ?B i j"
    let ?aB' = "\<lambda> r c. (if r = i \<and> c = j then 1 else if r = i \<or> c = j then 0
               else (if r = c then monom 1 (Suc 0) - [:A $ r $ c:]  else [: - A $ r $ c:]))"

    have deg_aB': "\<And> r c. degree (?aB' r c) = (if r = i \<or> c = j \<or> r \<noteq> c then 0 else 1)"
      by(simp add: monom_poly_degree_one)

    have B'_eq: "?B' = (\<chi> i j. ?aB' i j)"
      by (simp add: vec_eq_iff minorM_def mat_def mat2matofpoly_def)

    let ?f = "\<lambda>p. \<Sum>l\<in>?U. degree (?aB' l (p l))"

    have max_card_minus: "Max {?f p |p. p permutes ?U} \<le> card(?U) - 1"
      by(intro Max.boundedI)
        (auto simp add: card_insert Collect_disj_eq
                        deg_aB' setsum.If_cases card_Compl exI[of _ id] permutes_id[of ?U])

    { assume ij: "i = j"

      { fix p assume a: "p \<noteq> id" "?aB' i (p i) = 1"
        have "\<exists>k. (k \<noteq> i) \<and> degree (?aB' k (p k)) = 0"
          by(simp add: a) (metis a eq_id_iff[of p] one_neq_zero)

        then obtain k where P: "k \<noteq> i" "degree (?aB' k (p k)) = 0"
          by auto

        have "(\<Sum>l\<in>?U. degree (?aB' l (p l))) = (\<Sum>l\<in>?U - {k} - {i}. degree (?aB' l (p l)))"
          using P
          by(intro setsum.mono_neutral_right) (auto)
        also have "\<dots> \<le> (\<Sum>l\<in>?U - {k} - {i}. 1)"
          by (intro setsum_mono)
             (simp add: minorM_def mat_def mat2matofpoly_def monom_poly_degree_one)
        finally have "degree (\<Prod>l\<in>?U. (?aB' l (p l))) \<le> card(?U) - 2"
          using P degree_setprod_le[of "\<lambda>l. (?aB' l (p l))" "?U"]
          by (auto simp: card_Diff_subset)

      } note case_p_not_id1 = this

      txt {* one diagonal element is 1, while everything else is equal to B *}

      have 1: "(\<Sum>l\<in>?U. degree (?aB' l (id l))) = card(?U) - 1"
        unfolding deg_aB' using ij by (simp add: setsum.If_cases card_Compl)

      have 2: "degree (\<Prod>l\<in>?U. ?aB' l (id l)) = card (?U) - 1"
        using ij degree_setprod_le[of "\<lambda>l. ?mon_A l" "?U - {j}"]
        coeff_mult_setprod_setsum[of "\<lambda>l. ?aB' l (id l)" "?U-{i}"]
        le_degree[of "\<Prod>i\<in>UNIV - {j}. ?mon_A i" "CARD('n) - Suc 0"]
        by(simp add: setprod.If_cases monom_poly_degree_one Compl_eq_Diff_UNIV)

      have case_B_i_p_i_is_zero: "\<And>p. ?aB' i (p i) = 0 \<Longrightarrow> (\<Prod>i\<in>?U. ?aB' i (p i)) = 0"
        by(force intro!: setprod_zero)

      { fix p:: "'n::finite \<Rightarrow> 'n"
        assume "p \<noteq> id"
        then have "degree (\<Prod>l\<in>UNIV. ?aB' l (p l)) \<le> CARD('n) - 2"
          using case_B_i_p_i_is_zero[of p] case_p_not_id1(1)[of p]
          by (metis (no_types, lifting) degree_0 le0)
      } note case_p_not_id2 = this

      { assume a1: "1 < CARD('n)"

        let ?f = "\<lambda>p. \<Sum>l\<in>UNIV. degree (?aB' l (p l))"
        let ?S = "{?f p | p. p permutes ?U}"

        have "Max ?S = CARD('n) - 1"
          using ij 1[symmetric] permutes_id max_card_minus
          by(intro Max_eqI)
            (simp_all add: permutes_id[of ?U] exI[of _ id])

          also have "\<forall>(p::'n::finite \<Rightarrow> 'n). p\<noteq>id \<longrightarrow> degree (\<Prod>l\<in>?U. ?aB' l (p l)) \<le> CARD('n) - 2"
          using ij case_p_not_id2
          by simp

        ultimately have "degree (det ?B') = CARD('n) - 1"
          unfolding B'_eq
          using ij a1 2 permutes_id[of ?U]
          by(subst det_coeff_poly_mat(1)[of id "(\<chi> i j. ?aB' i j)"])
            (auto simp only: vec_lambda_beta)
      }
    }
    hence "1 < CARD('n) \<Longrightarrow> i = j \<Longrightarrow> degree (det ?B') = CARD('n) - 1"
     and  "i \<noteq> j \<Longrightarrow> degree (det ?B') \<le> CARD('n) - 1"
      using max_card_minus det_coeff_poly_mat(3)[of ?B'] B'_eq
      by auto
  } note deg_det_B' = this

  let ?f_cofactor = "\<lambda> i j. degree (transpose (\<chi> i. vec_lambda (cofactor ?B i)) $ i $ j)"

  { fix i j :: "'n::finite"
    assume a0: "CARD('n::finite) = 1"
    moreover then have *: "{undefined::'n::finite} = UNIV"
      by (simp add: a0 card_eq_UNIV_imp_eq_UNIV)
    moreover have eq: "\<And>P. (\<forall>i::'n. P i) \<longleftrightarrow> P undefined"
      using ball_UNIV[where 'a='n] unfolding *[symmetric] by simp
    ultimately have **: "i = j \<and> j = (undefined::'n::finite)" by auto

    have "degree(det (minorM ?B i j)) = 0"
      using det_coeff_poly_mat(3)[of "minorM ?B i j"]
      by(simp add: det_def minorM_def mat_def mat2matofpoly_def *[symmetric] ** cong del: if_cong)
  } note trivial_case = this

  then have "maxdegM (transpose (cofactorM ?B)) \<ge> card ?U - 1"
    using deg_det_B'(1) zero_less_card_finite[where 'a='n]
    by(cases "CARD('n) = Suc 0")
      (fastforce simp add: cofactorM_def maxdegM_eq_range Max_ge_iff
       transpose_def cofactor_def[of ?B] gr0_conv_Suc simp del: zero_less_card_finite)+

  also have "maxdegM (transpose (cofactorM ?B)) \<le> card ?U - 1"
    using deg_det_B'(1) deg_det_B'(2) trivial_case
    using full_SetCompr_eq[of "\<lambda> (i, j) \<Rightarrow> ?f_cofactor i j"]
    by(simp_all add: transpose_def cofactor_def[of ?B] maxdegM_def cofactorM_def)
      (metis le0 le_refl less_le one_le_card_finite )

  finally show "maxdegM (transpose (cofactorM (mat (monom 1 (Suc 0)) - mat2matofpoly A)))
  = CARD('n) - 1"
    using dual_order.antisym by simp
qed

text{* Evaluation of polynomials as formalised in HOL/Library/Polynomial.thy assumes that
   the point at which evaluation happens is of the same type as the coefficients. In the
   present setting something more general is needed.

   Also, the following cannot be used as its reordering assumes working in a commutative setting
   definition poly\_mat where @{term "poly_mat = poly_rec (\<lambda>x. 0) (\<lambda>a p f x. mat a + x * f x)"}

   Therefore, the following definition is made:

   evaluate a polynomial with coefficients in 'a on a matrix over 'a
*}
definition evalmat :: "'a\<Colon>comm_ring_1 poly \<Rightarrow> 'a^'n^'n \<Rightarrow> 'a^'n^'n" where
  "evalmat P A = (\<Sum> i \<in> { n\<Colon>nat . n \<le> ( degree P ) } . (coeff P i) *ss (matpow A i) )"

theorem Cayley_Hamilton:
  fixes A :: "'a::comm_ring_1^'n\<Colon>finite^'n"
  shows "evalmat (charpoly A) A = 0"
proof-

  let ?A = "mat2matofpoly A"
  let ?I = "mat (monom 1 1)"

  def n == "Suc (maxdegM (adjugate (?I - ?A)))"
  then have n_gt_0: "0 < n"
    by auto
  then have [simp]: "\<not> n \<le> n - Suc 0"
    by auto

  from poly_basis obtain B where Pred:
  "adjugate (?I - ?A) = (\<Sum> i \<le> n - 1 . monom 1 i *ss mat2matofpoly (B i))"
    using n_def by auto

  let ?B = "\<lambda>i. mat2matofpoly (B i)"

  txt{* B\_mat is a matrix, while B is a function that returns a matrix ) *}
  def B_mat == "\<Sum> i \<le> n - 1 . monom 1 i *ss ?B i"

  have charpoly_aux: "degree (charpoly A) = n" "coeff (charpoly A) n = 1"
    using coeff_charpoly_xn_is_one[of A] maxdeg_cofactorM[of A]  n_def
    by (simp_all add: adjugate_def)

  have 1: "{Suc 0..n - Suc 0} \<inter> {i. i \<le> n} \<inter> Collect (op \<le> n) = {}"
    by auto

  let ?M = "\<lambda>i B. monom 1 i *ss B"
  have "mat (charpoly A) = det (?I - ?A) *ss mat 1"
    by (simp add: charpoly_def mat2matofpoly_def scalar_matrix_mult_def mat_def vec_eq_iff)
  also have "\<dots> = (?I - ?A) ** B_mat"
    by (metis adjugate_det_symmetric Pred B_mat_def)
  also have "\<dots> = ?I ** B_mat - ?A ** B_mat"
    unfolding matrix_mult_right_distributes_minus ..
  also have "\<dots> = (\<Sum>i\<le>n - 1. ?M (i + 1) (?B i)) - (\<Sum>i\<le>n - 1 . ?M i (?A ** ?B i))"
    by (simp add: B_mat_def matrix_sum_mult scalar_mat_matrix_mult_left scalar_scalar_mult_assoc
       mult_monom matrix_scalar_assoc)
  also have "(\<Sum>i\<le>n - 1. ?M (i + 1) (?B i)) = (\<Sum> i\<in>insert (n - 1) {..< n - 1} . ?M (i + 1) (?B i))"
    by (intro setsum.cong) auto
  also have "\<dots> = (\<Sum>i<n - 1. ?M (i + 1) (?B i)) + ?M n (?B (n - 1))"
    by (simp add: n_def)
  also have "(\<Sum>i\<le>n - 1. ?M i (?A ** ?B i)) = (\<Sum>i\<in>insert 0 {1 .. n - 1} . ?M i (?A ** ?B i))"
    by (intro setsum.cong) auto
  also have "\<dots> = (\<Sum>i=1..n - 1. ?M i (?A ** ?B i)) + ?A ** ?B 0"
    by (simp add: scalar_matrix_mult_monom)
  also have "(\<Sum>i\<in>{1..n - 1}. ?M i (?A ** ?B i)) = (\<Sum>i<n - 1. ?M (i + 1) (?A ** ?B (i + 1)))"
    by (rule setsum.reindex_bij_witness[where i="\<lambda>x. x + 1" and j="\<lambda>x. x - 1"]) auto
  also have "((\<Sum>i<n - 1. ?M (i + 1) (?B i)) + ?M n (?B (n - 1))) -
    ((\<Sum>i<n - 1. ?M (i + 1) (?A ** ?B (i + 1))) + ?A ** ?B 0) =
    - (?A ** ?B 0) + (\<Sum>i<n - 1. ?M (i + 1) (?B i - ?A ** ?B (i + 1))) + ?M n (?B (n - 1))"
    by (simp add: scalar_minus_ldistrib setsum_subtractf scalar_minus_left)
  also have "(\<Sum>i<n - 1. ?M (i + 1) (?B i - ?A ** ?B (i + 1))) =
      (\<Sum>i=1..n - 1. ?M i (mat2matofpoly (B (i - 1) - A ** (B i))))"
    by (rule setsum.reindex_bij_witness[where i="\<lambda>x. x - 1" and j="\<lambda>x. x + 1"])
       (auto simp: mat2matofpoly_mult mat2matofpoly_simps)
  finally have *: "mat (charpoly A) =
    - (?A ** ?B 0) +
    (\<Sum>i = 1..n - 1. ?M i (mat2matofpoly (B (i - 1) - A ** B i))) +
    ?M n (mat2matofpoly (B (n - 1)))" .

  have coeff_top: "B (n - 1) = coeffM (mat (charpoly A)) n"
    using n_gt_0 *
    by(simp_all add: coeffM_simps coeffM_monom_mult coeffM_mat2matofpoly mat2matofpoly_mult
    coeffM_setsum if_distrib[where f="\<lambda>x. x * y" for y] setsum.If_cases 1)

  { fix i
    have "coeffM (mat (charpoly A)) i = (if \<not> (1 \<le> i) then - (A ** B 0) else
    if i \<le> n - 1 then B (i - 1) - A ** B i else if i = n then mat 1 else 0)"
    proof-

      { fix i
        { fix i assume a1: "1 \<le> i" "i \<le> n - 1"
          then have "(\<Sum>j=1..n - 1. coeffM (monom 1 j *ss mat2matofpoly (B (j - 1) - A ** B j)) i) =
            B (i - 1) - A ** B i"
            using if_distrib[where f="\<lambda>x. y * x" for y]
            by (simp add: vec_eq_iff mat2matofpoly_def coeffM_def coeff_setsum
            scalar_matrix_mult_def if_distrib[where f="\<lambda>x. y * x" for y] setsum.If_cases) }
        moreover
        { fix i assume  "i \<notin> {1..n - 1}"
          then have "(\<Sum>j=1..n - 1. coeffM (monom 1 j *ss mat2matofpoly (B (j - 1) - A ** B j)) i) =
            (\<Sum>j=1..n - 1. 0)"
            by (intro setsum.cong) (auto simp add: coeffM_monom_mult coeffM_mat2matofpoly) }
        ultimately have x: "(\<Sum>j=1..n - 1.
        coeffM (monom 1 j *ss mat2matofpoly (B (j - 1) - A ** B j)) i) =
        (if i \<in> {1..n - 1} then B (i - 1) - A ** B i else 0)"
          by simp

       have "coeffM (mat (charpoly A)) i = - coeffM (mat2matofpoly A ** mat2matofpoly (B 0)) i +
       (if i \<in> {1..n - 1} then B (i - 1) - A ** B i else 0) +
       coeffM (monom 1 n *ss mat2matofpoly (B (n - 1))) i"
         using n_gt_0
         by(simp only: mat2matofpoly_mult x[symmetric] * coeffM_setsum coeffM_simps)
       }

    thus ?thesis
    using charpoly_aux(2) coeff_top
    by(auto simp add: coeffM_monom_mult mat2matofpoly_mult coeffM_mat2matofpoly coeffM_mat 1
                         one_scalar_mult_mat)
    qed
  } note coeffM_charpoly = this

  have zero: "1 < n \<Longrightarrow> - (A ** B 0) + (\<Sum>i=1.. n - 1. (matpow A i ** B (i - 1)) -
  (matpow A (i + 1) ** B i)) + matpow A n ** B (n - 1) = 0"
  proof-
    assume a0: "1 < n"
    let ?AB = "\<lambda>i j. matpow A i ** B j"

    have "{1..n- 1} = {1} \<union> {2..n- 1}"
      using a0 by auto

    then have sum_one: "(\<Sum>i=1..n- 1. ?AB i (i - 1)) = ?AB 1 0 + (\<Sum>i=1..n- 2. ?AB (i + 1) i)"
      using setsum_shift_bounds_cl_nat_ivl[of "\<lambda>i. ?AB i (i- 1)" 1 1 "n- 2"]
      Suc_diff_Suc[of 1 n] a0
      by(simp only: Suc_1 one_add_one) simp

    have "{1..n- 1} =  {n- 1} \<union> {1..n- 2}"
      using a0 by auto

    then have sum_two: "(\<Sum>i=1..n- 1. ?AB (i + 1) i) = ?AB n (n- 1) + (\<Sum>i=1..n- 2. ?AB (i + 1) i)"
      using a0 by(simp add: n_def)

    show ?thesis
      using a0 sum_one sum_two
      by (simp only: diff_conv_add_uminus comm_monoid_add_class.setsum.distrib setsum_negf)
         (simp add: matrix_mul_rid)
  qed

  have final: "1 < n \<Longrightarrow> (\<Sum>i\<le> n. coeff (charpoly A) i *ss matpow A i) = 0"
  proof-
    assume a0: "1 < n"

    { fix i assume a1: "1 \<le> i" "i \<le> n - 1"
      then have "coeff (charpoly A) i *ss matpow A i
      = matpow A i ** B (i - 1) - matpow A (Suc i) ** B i"
        using coeffM_charpoly[of i]
        by(simp only: matrix_scalar_mat_one[of "matpow A i" "coeff (charpoly A) i", symmetric]
           coeffM_mat[of "charpoly A", symmetric] matrix_mul_assoc[symmetric]
           matpow_suc[symmetric] matrix_mult_left_distributes_minus[symmetric])
          (simp) }

    moreover have "{i. i \<le> n} = {1.. n - 1}\<union>{n}\<union>{0}"
    by auto

    ultimately show ?thesis
      using a0 coeff_top coeffM_charpoly[of 0]
      by(simp add: zero[symmetric] atMost_def matrix_mul_rid coeffM_mat
      matrix_mul_lid setsum_subtractf charpoly_aux(2) one_scalar_mult_mat)
  qed

  txt{* case n > 1 *}
  { assume "degree (charpoly A) = n" "n>1"
    then have ?thesis
      using final by(simp add: evalmat_def atMost_def[of n])
  }
  txt{* case n = 1 *}
  moreover
  { assume a0: "CARD('n::finite) = 1"
    moreover then have *: "{undefined::'n::finite} = UNIV"
      by (simp add: a0 card_eq_UNIV_imp_eq_UNIV)
    moreover have eq: "\<And>P. (\<forall>i::'n. P i) \<longleftrightarrow> P undefined"
      using ball_UNIV[where 'a='n] unfolding *[symmetric] by simp
    moreover have "{n. n \<le> Suc 0} = {0, 1}"
      by auto
    ultimately have ?thesis
      using coeff_charpoly_xn_is_one[of A]
      apply (simp_all add: mat_def mat2matofpoly_def scalar_matrix_mult_def matrix_matrix_mult_def
             evalmat_def vec_eq_iff charpoly_def det_one_element_matrix[of _ undefined])
      unfolding *[symmetric]
      apply simp
      done
  }
  ultimately show ?thesis
    using charpoly_aux(1) n_gt_0 coeff_charpoly_xn_is_one
    by(simp, metis less_nat_zero_code less_one linorder_neqE_nat)
qed

text{*
   {\bf Acknowledgements.}

   The authors would like to thank the Isabelle community, and in particular Johannes H{\"o}lzl,
   Makarius Wenzel, Andreas Lochbihler and Lukas Bulwahn for their helpful support.
*}

end


theory Specialisation_Examples
imports Main "HOL-Library.Predicate_Compile_Alternative_Defs"
begin

declare [[values_timeout = 960.0]]

section \<open>Specialisation Examples\<close>

primrec nth_el'
where
  "nth_el' [] i = None"
| "nth_el' (x # xs) i = (case i of 0 => Some x | Suc j => nth_el' xs j)"

definition
  "greater_than_index xs = (\<forall>i x. nth_el' xs i = Some x --> x > i)"

code_pred (expected_modes: i => bool) [inductify, skip_proof, specialise] greater_than_index .
ML_val \<open>Core_Data.intros_of \<^context> \<^const_name>\<open>specialised_nth_el'P\<close>\<close>

thm greater_than_index.equation

values [expected "{()}"] "{x. greater_than_index [1,2,4,6]}"
values [expected "{}"] "{x. greater_than_index [0,2,3,2]}"

subsection \<open>Common subterms\<close>

text \<open>If a predicate is called with common subterms as arguments,
  this predicate should be specialised.
\<close>

definition max_nat :: "nat => nat => nat"
  where "max_nat a b = (if a <= b then b else a)"

lemma [code_pred_inline]:
  "max = max_nat"
by (simp add: fun_eq_iff max_def max_nat_def)

definition
  "max_of_my_Suc x = max x (Suc x)"

text \<open>In this example, max is specialised, hence the mode o => i => bool is possible\<close>

code_pred (modes: o => i => bool) [inductify, specialise, skip_proof] max_of_my_Suc .

thm max_of_my_SucP.equation

ML_val \<open>Core_Data.intros_of \<^context> \<^const_name>\<open>specialised_max_natP\<close>\<close>

values "{x. max_of_my_SucP x 6}"

subsection \<open>Sorts\<close>

inductive sorted :: "'a::linorder list \<Rightarrow> bool" where
  Nil [simp]: "sorted []"
| Cons: "\<forall>y\<in>set xs. x \<le> y \<Longrightarrow> sorted xs \<Longrightarrow> sorted (x # xs)"

lemma sorted_single [simp]: "sorted [x]"
by (rule sorted.Cons) auto

lemma sorted_many: "x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> sorted (x # y # zs)"
by (rule sorted.Cons) (cases "y # zs" rule: sorted.cases, auto)

lemma sorted_many_eq [simp]:
  "sorted (x # y # zs) \<longleftrightarrow> x \<le> y \<and> sorted (y # zs)"
by (auto intro: sorted_many elim: sorted.cases)

declare sorted.Nil [code_pred_intro]
  sorted_single [code_pred_intro]
  sorted_many [code_pred_intro]

code_pred sorted
proof -
  assume "sorted xa"
  assume 1: "xa = [] \<Longrightarrow> thesis"
  assume 2: "\<And>x. xa = [x] \<Longrightarrow> thesis"
  assume 3: "\<And>x y zs. xa = x # y # zs \<Longrightarrow> x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> thesis"
  show thesis proof (cases xa)
    case Nil with 1 show ?thesis .
  next
    case (Cons x xs) show ?thesis proof (cases xs)
      case Nil with Cons 2 show ?thesis by simp
    next
      case (Cons y zs)
      show ?thesis
      proof (rule 3)
        from Cons \<open>xa = x # xs\<close> show "xa = x # y # zs" by simp
        with \<open>sorted xa\<close> show "x \<le> y" and "sorted (y # zs)" by simp_all
      qed
    qed
  qed
qed
thm sorted.equation

section \<open>Specialisation in POPLmark theory\<close>

notation
  Some ("\<lfloor>_\<rfloor>")

notation
  None ("\<bottom>")

notation
  length ("\<parallel>_\<parallel>")

notation
  Cons ("_ \<Colon>/ _" [66, 65] 65)

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = \<bottom>"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> \<lfloor>x\<rfloor> | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

primrec assoc :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" ("_\<langle>_\<rangle>\<^sub>?" [90, 0] 91)
where
  "[]\<langle>a\<rangle>\<^sub>? = \<bottom>"
| "(x # xs)\<langle>a\<rangle>\<^sub>? = (if fst x = a then \<lfloor>snd x\<rfloor> else xs\<langle>a\<rangle>\<^sub>?)"

primrec unique :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "unique [] = True"
| "unique (x # xs) = (xs\<langle>fst x\<rangle>\<^sub>? = \<bottom> \<and> unique xs)"

datatype type =
    TVar nat
  | Top
  | Fun type type    (infixr "\<rightarrow>" 200)
  | TyAll type type  ("(3\<forall><:_./ _)" [0, 10] 10)

datatype binding = VarB type | TVarB type
type_synonym env = "binding list"

primrec is_TVarB :: "binding \<Rightarrow> bool"
where
  "is_TVarB (VarB T) = False"
| "is_TVarB (TVarB T) = True"

primrec type_ofB :: "binding \<Rightarrow> type"
where
  "type_ofB (VarB T) = T"
| "type_ofB (TVarB T) = T"

primrec mapB :: "(type \<Rightarrow> type) \<Rightarrow> binding \<Rightarrow> binding"
where
  "mapB f (VarB T) = VarB (f T)"
| "mapB f (TVarB T) = TVarB (f T)"

datatype trm =
    Var nat
  | Abs type trm   ("(3\<lambda>:_./ _)" [0, 10] 10)
  | TAbs type trm  ("(3\<lambda><:_./ _)" [0, 10] 10)
  | App trm trm    (infixl "\<bullet>" 200)
  | TApp trm type  (infixl "\<bullet>\<^sub>\<tau>" 200)

primrec liftT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type" ("\<up>\<^sub>\<tau>")
where
  "\<up>\<^sub>\<tau> n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
| "\<up>\<^sub>\<tau> n k Top = Top"
| "\<up>\<^sub>\<tau> n k (T \<rightarrow> U) = \<up>\<^sub>\<tau> n k T \<rightarrow> \<up>\<^sub>\<tau> n k U"
| "\<up>\<^sub>\<tau> n k (\<forall><:T. U) = (\<forall><:\<up>\<^sub>\<tau> n k T. \<up>\<^sub>\<tau> n (k + 1) U)"

primrec lift :: "nat \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm" ("\<up>")
where
  "\<up> n k (Var i) = (if i < k then Var i else Var (i + n))"
| "\<up> n k (\<lambda>:T. t) = (\<lambda>:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (\<lambda><:T. t) = (\<lambda><:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (s \<bullet> t) = \<up> n k s \<bullet> \<up> n k t"
| "\<up> n k (t \<bullet>\<^sub>\<tau> T) = \<up> n k t \<bullet>\<^sub>\<tau> \<up>\<^sub>\<tau> n k T"

primrec substTT :: "type \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>\<tau>" [300, 0, 0] 300)
where
  "(TVar i)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> =
     (if k < i then TVar (i - 1) else if i = k then \<up>\<^sub>\<tau> k 0 S else TVar i)"
| "Top[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = Top"
| "(T \<rightarrow> U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> \<rightarrow> U[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<forall><:T. U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = (\<forall><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. U[k+1 \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>)"

primrec decT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("\<down>\<^sub>\<tau>")
where
  "\<down>\<^sub>\<tau> 0 k T = T"
| "\<down>\<^sub>\<tau> (Suc n) k T = \<down>\<^sub>\<tau> n k (T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>)"

primrec subst :: "trm \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm"  ("_[_ \<mapsto> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto> s] = (if k < i then Var (i - 1) else if i = k then \<up> k 0 s else Var i)"
| "(t \<bullet> u)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet> u[k \<mapsto> s]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet>\<^sub>\<tau> \<down>\<^sub>\<tau> 1 k T"
| "(\<lambda>:T. t)[k \<mapsto> s] = (\<lambda>:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"
| "(\<lambda><:T. t)[k \<mapsto> s] = (\<lambda><:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"

primrec substT :: "trm \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> trm"    ("_[_ \<mapsto>\<^sub>\<tau> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto>\<^sub>\<tau> S] = (if k < i then Var (i - 1) else Var i)"
| "(t \<bullet> u)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet> u[k \<mapsto>\<^sub>\<tau> S]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet>\<^sub>\<tau> T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<lambda>:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda>:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"
| "(\<lambda><:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"

primrec liftE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env" ("\<up>\<^sub>e")
where
  "\<up>\<^sub>e n k [] = []"
| "\<up>\<^sub>e n k (B \<Colon> \<Gamma>) = mapB (\<up>\<^sub>\<tau> n (k + \<parallel>\<Gamma>\<parallel>)) B \<Colon> \<up>\<^sub>e n k \<Gamma>"

primrec substE :: "env \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> env"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>e" [300, 0, 0] 300)
where
  "[][k \<mapsto>\<^sub>\<tau> T]\<^sub>e = []"
| "(B \<Colon> \<Gamma>)[k \<mapsto>\<^sub>\<tau> T]\<^sub>e = mapB (\<lambda>U. U[k + \<parallel>\<Gamma>\<parallel> \<mapsto>\<^sub>\<tau> T]\<^sub>\<tau>) B \<Colon> \<Gamma>[k \<mapsto>\<^sub>\<tau> T]\<^sub>e"

primrec decE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env"  ("\<down>\<^sub>e")
where
  "\<down>\<^sub>e 0 k \<Gamma> = \<Gamma>"
| "\<down>\<^sub>e (Suc n) k \<Gamma> = \<down>\<^sub>e n k (\<Gamma>[k \<mapsto>\<^sub>\<tau> Top]\<^sub>e)"

inductive
  well_formed :: "env \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f _" [50, 50] 50)
where
  wf_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
| wf_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
| wf_arrow: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
| wf_all: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> TVarB T \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive
  well_formedE :: "env \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f" [50] 50)
  and well_formedB :: "env \<Rightarrow> binding \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f\<^sub>B _" [50, 50] 50)
where
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<equiv> \<Gamma> \<turnstile>\<^sub>w\<^sub>f type_ofB B"
| wf_Nil: "[] \<turnstile>\<^sub>w\<^sub>f"
| wf_Cons: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

inductive_cases well_formed_cases:
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive_cases well_formedE_cases:
  "B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

inductive
  subtyping :: "env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ <: _" [50, 50, 50] 50)
where
  SA_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f S \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
| SA_refl_TVar: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: TVar i"
| SA_trans_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB U\<rfloor> \<Longrightarrow>
    \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (Suc i) 0 U <: T \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: T"
| SA_arrow: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>1 \<rightarrow> S\<^sub>2 <: T\<^sub>1 \<rightarrow> T\<^sub>2"
| SA_all: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> (\<forall><:S\<^sub>1. S\<^sub>2) <: (\<forall><:T\<^sub>1. T\<^sub>2)"

inductive
  typing :: "env \<Rightarrow> trm \<Rightarrow> type \<Rightarrow> bool"    ("_ \<turnstile> _ : _" [50, 50, 50] 50)
where
  T_Var: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma>\<langle>i\<rangle> = \<lfloor>VarB U\<rfloor> \<Longrightarrow> T = \<up>\<^sub>\<tau> (Suc i) 0 U \<Longrightarrow> \<Gamma> \<turnstile> Var i : T"
| T_Abs: "VarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>:T\<^sub>1. t\<^sub>2) : T\<^sub>1 \<rightarrow> \<down>\<^sub>\<tau> 1 0 T\<^sub>2"
| T_App: "\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>11 \<rightarrow> T\<^sub>12 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>11 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 \<bullet> t\<^sub>2 : T\<^sub>12"
| T_TAbs: "TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda><:T\<^sub>1. t\<^sub>2) : (\<forall><:T\<^sub>1. T\<^sub>2)"
| T_TApp: "\<Gamma> \<turnstile> t\<^sub>1 : (\<forall><:T\<^sub>11. T\<^sub>12) \<Longrightarrow> \<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>11 \<Longrightarrow>
    \<Gamma> \<turnstile> t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 : T\<^sub>12[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]\<^sub>\<tau>"
| T_Sub: "\<Gamma> \<turnstile> t : S \<Longrightarrow> \<Gamma> \<turnstile> S <: T \<Longrightarrow> \<Gamma> \<turnstile> t : T"

code_pred [inductify, skip_proof, specialise] typing .

thm typing.equation

values 6 "{(E, t, T). typing E t T}"

subsection \<open>Higher-order predicate\<close>

code_pred [inductify] mapB .

subsection \<open>Multiple instances\<close>

inductive subtype_refl' where
  "\<Gamma> \<turnstile> t : T ==> \<not> (\<Gamma> \<turnstile> T <: T) ==> subtype_refl' t T"

code_pred (modes: i => i => bool, o => i => bool, i => o => bool, o => o => bool) [inductify] subtype_refl' .

thm subtype_refl'.equation

end