section \<open>Sets\<close>

theory Set_Extensions
imports
  "HOL-Library.Infinite_Set"
begin

  declare finite_subset[intro]

  lemma set_not_emptyI[intro 0]: "x \<in> S \<Longrightarrow> S \<noteq> {}" by auto
  lemma sets_empty_iffI[intro 0]:
    assumes "\<And> a. a \<in> A \<Longrightarrow> \<exists> b. b \<in> B"
    assumes "\<And> b. b \<in> B \<Longrightarrow> \<exists> a. a \<in> A"
    shows "A = {} \<longleftrightarrow> B = {}"
    using assms by auto
  lemma disjointI[intro 0]:
    assumes "\<And> x. x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> False"
    shows "A \<inter> B = {}"
    using assms by auto
  lemma range_subsetI[intro 0]:
    assumes "\<And> x. f x \<in> S"
    shows "range f \<subseteq> S"
    using assms by blast

  lemma finite_imageI_range:
    assumes "finite (range f)"
    shows "finite (f ` A)"
    using finite_subset image_mono subset_UNIV assms by metis

  lemma inf_img_fin_domE':
    assumes "infinite A"
    assumes "finite (f ` A)"
    obtains y
    where "y \<in> f ` A" "infinite (A \<inter> f -` {y})"
  proof (rule ccontr)
    assume 1: "\<not> thesis"
    have 2: "finite (\<Union> y \<in> f ` A. A \<inter> f -` {y})"
    proof (rule finite_UN_I)
      show "finite (f ` A)" using assms(2) by this
      show "\<And> y. y \<in> f ` A \<Longrightarrow> finite (A \<inter> f -` {y})" using that 1 by blast
    qed
    have 3: "A \<subseteq> (\<Union> y \<in> f ` A. A \<inter> f -` {y})" by blast
    show False using assms(1) 2 3 by blast
  qed

  lemma vimage_singleton[simp]: "f -` {y} = {x. f x = y}" unfolding vimage_def by simp

  lemma these_alt_def: "Option.these S = Some -` S" unfolding Option.these_def by force
  lemma the_vimage_subset: "the -` {a} \<subseteq> {None, Some a}" by auto

  lemma finite_induct_reverse[consumes 1, case_names remove]:
    assumes "finite S"
    assumes "\<And> S. finite S \<Longrightarrow> (\<And> x. x \<in> S \<Longrightarrow> P (S - {x})) \<Longrightarrow> P S"
    shows "P S"
  using assms(1)
  proof (induct rule: finite_psubset_induct)
    case (psubset S)
    show ?case
    proof (rule assms(2))
      show "finite S" using psubset(1) by this
    next
      fix x
      assume 0: "x \<in> S"
      show "P (S - {x})"
      proof (rule psubset(2))
        show "S - {x} \<subset> S" using 0 by auto
      qed
    qed
  qed

  lemma zero_not_in_Suc_image[simp]: "0 \<notin> Suc ` A" by auto

  lemma Collect_split_Suc:
    "\<not> P 0 \<Longrightarrow> {i. P i} = Suc ` {i. P (Suc i)}"
    "P 0 \<Longrightarrow> {i. P i} = {0} \<union> Suc ` {i. P (Suc i)}"
  proof -
    assume "\<not> P 0"
    thus "{i. P i} = Suc ` {i. P (Suc i)}"
      by (auto, metis image_eqI mem_Collect_eq nat.exhaust)
  next
    assume "P 0"
    thus "{i. P i} = {0} \<union> Suc ` {i. P (Suc i)}"
      by (auto, metis imageI mem_Collect_eq not0_implies_Suc)
  qed

  lemma Collect_subsume[simp]:
    assumes "\<And> x. x \<in> A \<Longrightarrow> P x"
    shows "{x \<in> A. P x} = A"
    using assms unfolding simp_implies_def by auto

  lemma Max_ge':
    assumes "finite A" "A \<noteq> {}"
    assumes "b \<in> A" "a \<le> b"
    shows "a \<le> Max A"
    using assms Max_ge_iff by auto

  abbreviation "least A \<equiv> LEAST k. k \<in> A"

  lemma least_contains[intro?, simp]:
    fixes A :: "'a :: wellorder set"
    assumes "k \<in> A"
    shows "least A \<in> A"
    using assms by (metis LeastI)
  lemma least_contains'[intro?, simp]:
    fixes A :: "'a :: wellorder set"
    assumes "A \<noteq> {}"
    shows "least A \<in> A"
    using assms by (metis LeastI equals0I)
  lemma least_least[intro?, simp]:
    fixes A :: "'a :: wellorder set"
    assumes "k \<in> A"
    shows "least A \<le> k"
    using assms by (metis Least_le)
  lemma least_unique:
    fixes A :: "'a :: wellorder set"
    assumes "k \<in> A" "k \<le> least A"
    shows "k = least A"
    using assms by (metis Least_le antisym)
  lemma least_not_less:
    fixes A :: "'a :: wellorder set"
    assumes "k < least A"
    shows "k \<notin> A"
    using assms by (metis not_less_Least)
  lemma leastI2_order[simp]:
    fixes A :: "'a :: wellorder set"
    assumes "A \<noteq> {}" "\<And> k. k \<in> A \<Longrightarrow> (\<And> l. l \<in> A \<Longrightarrow> k \<le> l) \<Longrightarrow> P k"
    shows "P (least A)"
  proof (rule LeastI2_order)
    show "least A \<in> A" using assms(1) by rule
  next
    fix k
    assume 1: "k \<in> A"
    show "least A \<le> k" using 1 by rule
  next
    fix k
    assume 1: "k \<in> A" "\<forall> l. l \<in> A \<longrightarrow> k \<le> l"
    show "P k" using assms(2) 1 by auto
  qed

  lemma least_singleton[simp]:
    fixes a :: "'a :: wellorder"
    shows "least {a} = a"
    by (metis insert_not_empty least_contains' singletonD)

  lemma least_image[simp]:
    fixes f :: "'a :: wellorder \<Rightarrow> 'b :: wellorder"
    assumes "A \<noteq> {}" "\<And> k l. k \<in> A \<Longrightarrow> l \<in> A \<Longrightarrow> k \<le> l \<Longrightarrow> f k \<le> f l"
    shows "least (f ` A) = f (least A)"
  proof (rule leastI2_order)
    show "A \<noteq> {}" using assms(1) by this
  next
    fix k
    assume 1: "k \<in> A" "\<And> i. i \<in> A \<Longrightarrow> k \<le> i"
    show "least (f ` A) = f k"
    proof (rule leastI2_order)
      show "f ` A \<noteq> {}" using assms(1) by simp
    next
      fix l
      assume 2: "l \<in> f ` A" "\<And> i. i \<in> f ` A \<Longrightarrow> l \<le> i"
      show "l = f k" using assms(2) 1 2 by force
    qed
  qed

  lemma least_le:
    fixes A B :: "'a :: wellorder set"
    assumes "B \<noteq> {}"
    assumes "\<And> i. i \<le> least A \<Longrightarrow> i \<le> least B \<Longrightarrow> i \<in> B \<Longrightarrow> i \<in> A"
    shows "least A \<le> least B"
  proof (rule ccontr)
    assume 1: "\<not> least A \<le> least B"
    have 2: "least B \<in> A" using assms(1, 2) 1 by simp
    have 3: "least A \<le> least B" using 2 by rule
    show False using 1 3 by rule
  qed
  lemma least_eq:
    fixes A B :: "'a :: wellorder set"
    assumes "A \<noteq> {}" "B \<noteq> {}"
    assumes "\<And> i. i \<le> least A \<Longrightarrow> i \<le> least B \<Longrightarrow> i \<in> A \<longleftrightarrow> i \<in> B"
    shows "least A = least B"
    using assms by (auto intro: antisym least_le)

  lemma least_Suc[simp]:
    assumes "A \<noteq> {}"
    shows "least (Suc ` A) = Suc (least A)"
  proof (rule antisym)
    obtain k where 10: "k \<in> A" using assms by blast
    have 11: "Suc k \<in> Suc ` A" using 10 by auto
    have 20: "least A \<in> A" using 10 LeastI by metis
    have 21: "least (Suc ` A) \<in> Suc ` A" using 11 LeastI by metis
    have 30: "\<And> l. l \<in> A \<Longrightarrow> least A \<le> l" using 10 Least_le by metis
    have 31: "\<And> l. l \<in> Suc ` A \<Longrightarrow> least (Suc ` A) \<le> l" using 11 Least_le by metis
    show "least (Suc ` A) \<le> Suc (least A)" using 20 31 by auto
    show "Suc (least A) \<le> least (Suc ` A)" using 21 30 by auto
  qed

  lemma least_Suc_diff[simp]: "Suc ` A - {least (Suc ` A)} = Suc ` (A - {least A})"
  proof (cases "A = {}")
    case True
    show ?thesis unfolding True by simp
  next
    case False
    have "Suc ` A - {least (Suc ` A)} = Suc ` A - {Suc (least A)}" using False by simp
    also have "\<dots> = Suc ` A - Suc ` {least A}" by simp
    also have "\<dots> = Suc ` (A - {least A})" by blast
    finally show ?thesis by this
  qed

  lemma Max_diff_least[simp]:
    fixes A :: "'a :: wellorder set"
    assumes "finite A" "A - {least A} \<noteq> {}"
    shows "Max (A - {least A}) = Max A"
  proof -
    have 1: "least A \<in> A" using assms(2) by auto
    obtain a where 2: "a \<in> A - {least A}" using assms(2) by blast
    have "Max A = Max (insert (least A) (A - {least A}))" using insert_absorb 1 by force
    also have "\<dots> = max (least A) (Max (A - {least A}))"
    proof (rule Max_insert)
      show "finite (A - {least A})" using assms(1) by auto
      show "A - {least A} \<noteq> {}" using assms(2) by this
    qed
    also have "\<dots> = Max (A - {least A})"
    proof (rule max_absorb2, rule Max_ge')
      show "finite (A - {least A})" using assms(1) by auto
      show "A - {least A} \<noteq> {}" using assms(2) by this
      show "a \<in> A - {least A}" using 2 by this
      show "least A \<le> a" using 2 by simp
    qed
    finally show ?thesis by rule
  qed

  lemma nat_set_card_equality_less:
    fixes A :: "nat set"
    assumes "x \<in> A" "y \<in> A" "card {z \<in> A. z < x} = card {z \<in> A. z < y}"
    shows "x = y"
  proof (cases x y rule: linorder_cases)
    case less
    have 0: "finite {z \<in> A. z < y}" by simp
    have 1: "{z \<in> A. z < x} \<subset> {z \<in> A. z < y}" using assms(1, 2) less by force
    have 2: "card {z \<in> A. z < x} < card {z \<in> A. z < y}" using psubset_card_mono 0 1 by this
    show ?thesis using assms(3) 2 by simp
  next
    case equal
    show ?thesis using equal by this
  next
    case greater
    have 0: "finite {z \<in> A. z < x}" by simp
    have 1: "{z \<in> A. z < y} \<subset> {z \<in> A. z < x}" using assms(1, 2) greater by force
    have 2: "card {z \<in> A. z < y} < card {z \<in> A. z < x}" using psubset_card_mono 0 1 by this
    show ?thesis using assms(3) 2 by simp
  qed

  lemma nat_set_card_equality_le:
    fixes A :: "nat set"
    assumes "x \<in> A" "y \<in> A" "card {z \<in> A. z \<le> x} = card {z \<in> A. z \<le> y}"
    shows "x = y"
  proof (cases x y rule: linorder_cases)
    case less
    have 0: "finite {z \<in> A. z \<le> y}" by simp
    have 1: "{z \<in> A. z \<le> x} \<subset> {z \<in> A. z \<le> y}" using assms(1, 2) less by force
    have 2: "card {z \<in> A. z \<le> x} < card {z \<in> A. z \<le> y}" using psubset_card_mono 0 1 by this
    show ?thesis using assms(3) 2 by simp
  next
    case equal
    show ?thesis using equal by this
  next
    case greater
    have 0: "finite {z \<in> A. z \<le> x}" by simp
    have 1: "{z \<in> A. z \<le> y} \<subset> {z \<in> A. z \<le> x}" using assms(1, 2) greater by force
    have 2: "card {z \<in> A. z \<le> y} < card {z \<in> A. z \<le> x}" using psubset_card_mono 0 1 by this
    show ?thesis using assms(3) 2 by simp
  qed

  lemma nat_set_card_mono[simp]:
    fixes A :: "nat set"
    assumes "x \<in> A"
    shows "card {z \<in> A. z < x} < card {z \<in> A. z < y} \<longleftrightarrow> x < y"
  proof
    assume 1: "card {z \<in> A. z < x} < card {z \<in> A. z < y}"
    show "x < y"
    proof (rule ccontr)
      assume 2: "\<not> x < y"
      have 3: "card {z \<in> A. z < y} \<le> card {z \<in> A. z < x}" using 2 by (auto intro: card_mono)
      show "False" using 1 3 by simp
    qed
  next
    assume 1: "x < y"
    show "card {z \<in> A. z < x} < card {z \<in> A. z < y}"
    proof (intro psubset_card_mono psubsetI)
      show "finite {z \<in> A. z < y}" by simp
      show "{z \<in> A. z < x} \<subseteq> {z \<in> A. z < y}" using 1 by auto
      show "{z \<in> A. z < x} \<noteq> {z \<in> A. z < y}" using assms 1 by blast
    qed
  qed

  lemma card_one[elim]:
    assumes "card A = 1"
    obtains a
    where "A = {a}"
    using assms by (metis One_nat_def card_Suc_eq)

  lemma image_alt_def: "f ` A = {f x |x. x \<in> A}" by auto

  lemma supset_mono_inductive[mono]:
    assumes "\<And> x. x \<in> B \<longrightarrow> x \<in> C"
    shows "A \<subseteq> B \<longrightarrow> A \<subseteq> C"
    using assms by auto
  lemma Collect_mono_inductive[mono]:
    assumes "\<And> x. P x \<longrightarrow> Q x"
    shows "x \<in> {x. P x} \<longrightarrow> x \<in> {x. Q x}"
    using assms by auto

  lemma image_union_split:
    assumes "f ` (A \<union> B) = g ` C"
    obtains D E
    where "f ` A = g ` D" "f ` B = g ` E" "D \<subseteq> C" "E \<subseteq> C"
    using assms unfolding image_Un
    by (metis (erased, lifting) inf_sup_ord(3) inf_sup_ord(4) subset_imageE)
  lemma image_insert_split:
    assumes "inj g" "f ` insert a B = g ` C"
    obtains d E
    where "f a = g d" "f ` B = g ` E" "d \<in> C" "E \<subseteq> C"
  proof -
    have 1: "f ` ({a} \<union> B) = g ` C" using assms(2) by simp
    obtain D E where 2: "f ` {a} = g ` D" "f ` B = g ` E" "D \<subseteq> C" "E \<subseteq> C"
      using image_union_split 1 by this
    obtain d where 3: "D = {d}" using assms(1) 2(1) by (auto, metis (erased, hide_lams) imageE
      image_empty image_insert inj_image_eq_iff singletonI)
    show ?thesis using that 2 unfolding 3 by simp
  qed

end


theory gcd imports newparaGste1
begin

abbreviation x::"varType" where
"x \<equiv>  (Ident ''x'')"

abbreviation y::"varType" where
"y \<equiv>  (Ident ''y'')"

definition geRule::" rule" where [simp]:
"geRule\<equiv>
let g = uip ''>'' [IVar x, IVar y]  in
let s = parallel [(x, uif ''-'' [IVar x,IVar y])]  in
guard g s"

definition leRule::" rule" where [simp]:
"leRule\<equiv>
let g = uip ''<'' [IVar x, IVar y]  in
let s = parallel [(y, uif ''-'' [IVar y,IVar x])]  in
guard g s"

definition rules::" rule set" where [simp]:
"rules \<equiv> {
leRule, geRule
}"

subsection{*Definitions of initial states*}

consts x0::nat

consts y0::nat

definition initSpec0::" formula" where [simp]:
"initSpec0  \<equiv> andForm (eqn (IVar x) (Const (index x0))) (eqn (IVar y) (Const (index y0)))"

consts J::" interpretFunType"

consts gcdSpec::"scalrValueType\<Rightarrow>scalrValueType\<Rightarrow>scalrValueType"

axiomatization where axiomOnGe [simp,intro]:
" formEval J  (implyForm (uip ''>'' [e1, e2])   (eqn (uif ''gcd'' [e1, e2]) (uif ''gcd'' [(uif ''-'' [e1,e2]), e2]))) s"

axiomatization where axiomOnLe [simp,intro]:
" formEval J  (implyForm (uip ''<'' [e1, e2])   (eqn (uif ''gcd'' [e1, e2]) (uif ''gcd'' [  e1, (uif ''-'' [e2,e1])]))) s"

definition invariants::"formula set" where [simp]:
"invariants  \<equiv> {eqn (uif ''gcd'' [IVar x, IVar y]) (uif ''gcd'' [Const (index x0), Const (index y0)])
}"

lemma lemmaOnLe:
assumes a1: "(r=leRule)" and
a2: "f =eqn (uif ''gcd'' [IVar x, IVar y]) (uif ''gcd'' [Const (index x0), Const (index y0)])"
shows "invHoldForRule   J s f  r (invariants)"  (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
  have "?P3 s"
  proof(cut_tac a1 a2,unfold invHoldForRule3_def,rule_tac x="f" in exI,
      cut_tac axiomOnLe[where s="s" and ?e1.0="IVar x" and ?e2.0="IVar y"],simp,auto)
  qed
  then show "?thesis" by blast
qed

lemma lemmaOnGe:
assumes a1: "(r=geRule)" and
a2: "f =eqn (uif ''gcd'' [IVar x, IVar y]) (uif ''gcd'' [Const (index x0), Const (index y0)])"
shows "invHoldForRule   J s f  r (invariants)"  (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
  have "?P3 s"
  proof(cut_tac a1 a2,unfold invHoldForRule3_def,rule_tac x="f" in exI,
      cut_tac axiomOnGe[where s="s" and ?e1.0="IVar x" and ?e2.0="IVar y"],simp,auto)
  qed
  then show "?thesis" by blast
qed

lemma invs_on_rules:
  assumes a1: "f \<in> invariants " and a2: "r \<in> rules "
  shows "invHoldForRule  J s f r (invariants )"
proof -

  have b1: "f =eqn (uif ''gcd'' [IVar x, IVar y]) (uif ''gcd'' [Const (index x0), Const (index y0)])"
    apply (cut_tac a1, auto) done
  have "r=geRule | r=leRule"
    using a2 by auto
    moreover {
      assume c1: "r=geRule"
      have "invHoldForRule  J s f r (invariants )"
        using b1 c1 lemmaOnGe by blast
    }

  moreover {
      assume c1: "r=leRule"
      have "invHoldForRule  J s f r (invariants )"
        using b1 c1 lemmaOnLe by blast
    }
    ultimately show ?thesis by blast
qed

lemma iniImply_inv:
assumes a1:"f \<in> invariants " and a2: "formEval J (initSpec0) s"
shows "formEval J f s "
using a1 a2 by auto

lemma consistentGcd:
  shows " consistent  J invariants {initSpec0} rules"
  using consistent_def iniImply_inv invs_on_rules by blast

lemma gcdInv:
  assumes  a2:"s \<in> reachableSet J {initSpec0}  rules"
  shows "\<forall> inv. inv \<in> invariants \<longrightarrow>formEval J inv s"  (is "?P s")
  using assms consistentGcd consistentLemma by blast

end


section \<open> Isabelle/UTP Primer \<close>

(*<*)
theory utp_tutorial
imports "UTP1-Theories.utp_theories"
begin
(*>*)

text \<open> In this section, we will introduce Hoare and He's \emph{Unifying Theories of Programming}~\cite{Hoare&98} through
  a tutorial about our mechanisation, in Isabelle, called Isabelle/UTP~\cite{Foster16a,Feliachi2010,Zeyda16}. The UTP
  is a framework for building and reasoning about heterogeneous semantics of programming and modelling languages. One of the core ideas of the UTP
  is that any program (or model) can be represented as a logical predicate over the program's state
  variables. The UTP thus begins from a higher-order logical core, and constructs a semantics for
  imperative relational programs, which can then be refined and extended with more complex language
  paradigms and theories. Isabelle/UTP mechanises this language of predicates and relations, and provides
  proof tactics for solving conjectures. For example, we can prove the following simple conjectures: \<close>

lemma "(true \<and> false) = false"
  by pred_auto

lemma "(true \<Rightarrow> P \<and> P) = P"
  by (pred_auto)

text \<open> We discharge these using our predicate calculus tactic, \emph{pred-auto}. It should be noted
  that @{term true}, @{term false}, and the conjunction operator are not simply the HOL operators;
  rather they act on on our UTP predicate type (@{typ "'\<alpha> upred"}). \<close>

subsection \<open> State-spaces and Lenses \<close>

text \<open> Predicates in the UTP are alphabetised, meaning they specify beheaviours
  in terms of a collection of variables, the alphabet, which effectively gives a state-space for
  a particular program. Thus the type of UTP predicates @{typ "'\<alpha> upred"} is parametric in the alphabet
  @{typ "'\<alpha>"}. In Isabelle/UTP we can create a particular state-space with the \textbf{alphabet} command: \<close>

alphabet myst =
  x :: "int"
  y :: "int"
  z :: "int set"

text \<open> This command creates an alphabet with three variables, $x$, $y$, and $z$, each of which
  has a defined type. A new Isabelle type is created, @{typ myst}, which can be then used
  as the parameter for our predicate model, e.g. @{typ "myst upred"}.
  In the context of our mechanisation, such variables are
  represented using \emph{lenses}~\cite{Foster16a,Foster09}. A lens, $X : V \Longrightarrow S$,
  is a pair of functions, $get :: V \to S$ and $put : S \to V \to S$, where $S$ is the source type,
  and $V$ is the view type. The source type represents a ``larger'' type that can in some sense be
  subdivided, and the view type a particular region of the source that can be observed and
  manipulated independently of the rest of the source.

  In Isabelle/UTP, the source type is the state space, and the view type is
  the variable type. For instance, we here have that @{term "x"} has type @{typ "int \<Longrightarrow> myst"}
  and @{term "z"} has type @{typ "int set \<Longrightarrow> myst"}. Thus, performing an assignment to $x$ equates
  to application of the $put$ function, and looking up the present valuation is application of the
  $get$ function.

  Since the different variable characterise different regions of the state space we can distinguish
  them using the independence predicate @{term "x \<bowtie> z"}. Two lenses are independent if they characterise
  disjoint regions of the source type. In this case we can prove that the two variables are different
  using the simplifier: \<close>

lemma "x \<bowtie> z"
  by simp

text \<open> However, we cannot prove, for example, that @{term "x \<bowtie> x"} of course since the same region
  of the state-space is characterised by both. Lenses thus provide us with a semantic characterisation
  of variables, rather than a syntactic notion. For more background on this use of lenses please see
  our recent paper~\cite{Foster16a}. \<close>

subsection \<open> Predicate Calculus \<close>

text \<open> We can now use this characterisation of variables to define predicates
  in Isabelle/UTP, for example @{term "&x >\<^sub>u &y"}, which corresponds to all valuations of the state-space
  in which $x$ is greater than $y$. Often we have to annotate our variables to help Isabelle understand
  that we are referring to UTP variables, and not, for example, HOL logical variables. In this case we
  have to decorate the names with an ampersand. Moreover, we often have to annotate operators with
  $u$ subscripts to denote that they refer to the UTP version of the operator, and not the HOL version.
  We can now write down and prove a simple proof goal: \<close>

lemma "`(&x =\<^sub>u 8 \<and> &y =\<^sub>u 5) \<Rightarrow> &x >\<^sub>u &y`"
  by (pred_auto)

text \<open> The backticks denote that we are writing an tautology. Effectively this goal tells us that
  $x = 8$ and $y = 5$ are valid valuations for the predicate. Conversely the following goal is not
  provable. \<close>

lemma "`(&x =\<^sub>u 5 \<and> &y =\<^sub>u 5) \<Rightarrow> &x >\<^sub>u &y`"
  apply (pred_simp) \<comment> \<open> Results in @{term False} \<close>
oops

text \<open> We can similarly quantify over UTP variables as the following two examples illustrate. \<close>

lemma "(\<exists> x \<bullet> &x >\<^sub>u &y) = true"
  by (pred_simp, presburger)

lemma "(\<forall> x \<bullet> &x >\<^sub>u &y) = false"
  by (pred_auto)

text \<open> The first goal states that for any given valuation of $y$ there is a valuation of $x$ which
  is greater. Predicate calculus alone is insufficient to prove this and so we can also use Isabelle's
  \emph{sledgehammer} tool~\cite{Blanchette2011} which attempts to solve the goal using an array of automated theorem provers
  and SMT solvers. In this case it finds that Isabelle's tactic for Presburger arithmetic can solve the
  goal. In this second case we have a goal which states that every valuation of $x$ is greater than
  a given valuation of $y$. Of course, this isn't the case and so we can prove the goal is equivalent
  to @{term false}. \<close>

subsection \<open> Meta-logical Operators \<close>

text \<open> In addition to predicate calculus operators, we also often need to assert meta-logical
  properties about a predicate, such as ``variable $x$ is not present in predicate $P$''. In Isabelle/UTP
  we assert this property using the \emph{unrestriction} operator, e.g. @{term "x \<sharp> true"}. Here are some
  examples of its use, including discharge using our tactic \emph{unrest-tac}. \<close>

lemma "x \<sharp> true"
  by (unrest_tac)

lemma "x \<sharp> (&y >\<^sub>u 6)"
  by (unrest_tac)

lemma "x \<sharp> (\<forall> x \<bullet> &x =\<^sub>u &y)"
  by (unrest_tac)

text \<open> The tactic attempts to prove the unrestriction using a set of built-in unrestriction laws
  that exist for every operator of the calculus. The final example is interesting, because it shows we are
  not dealing with a syntactic
  property but rather a semantic one. Typically, one would describe the (non-)presence of variables
  syntactically, by checking if the syntax tree of $P$ refers to $x$. In this case we are actually
  checking whether the valuation of $P$ depends on $x$ or not. In other words, if we can rewrite
  $P$ to a form where $x$ is not present, but $P$ is otherwise equivalent, then $x$ is unrestricted --
  it can take any value. The following example illustrates this: \<close>

lemma "x \<sharp> (&x <\<^sub>u 5 \<or> &x =\<^sub>u 5 \<or> &x >\<^sub>u 5)"
  by (pred_auto)

text \<open> Of course, if $x$ is either less than $5$, equal to $5$, or greater than $5$ then $x$ can
  take any value and the predicate will still be satisfied. Indeed this predicate is actually
  equal to @{term true} and thus @{term x} is unrestricted. We will often use unrestriction to
  encode necessary side conditions on algebraic laws of programming.

  In addition to presence of variables, we will often want to substitute a variable for an expression.
  We write this using the familiar syntax @{term "P\<lbrakk>v/x\<rbrakk>"}, and also @{term [source] "P\<lbrakk>v\<^sub>1,v\<^sub>2,v\<^sub>3/x\<^sub>1,x\<^sub>2,x\<^sub>3\<rbrakk>"} for
  an arbitrary number of expressions and variables. We can evaluate substitutions using the tactic
  \emph{subst-tac} as the following examples show:
 \<close>

lemma "(&y =\<^sub>u &x)\<lbrakk>2/x\<rbrakk> = (&y =\<^sub>u 2)"
  by (subst_tac)

lemma "(&y =\<^sub>u &x \<and> &y \<in>\<^sub>u &z)\<lbrakk>2/y\<rbrakk> = (2 =\<^sub>u &x \<and> 2 \<in>\<^sub>u &z)"
  by (subst_tac)

lemma "(\<exists> &x \<bullet> &x \<in>\<^sub>u &z)\<lbrakk>76/&x\<rbrakk> = (\<exists> &x \<bullet> &x \<in>\<^sub>u &z)"
  by (subst_tac)

lemma "true\<lbrakk>1,2/&x,&y\<rbrakk> = true"
  by (subst_tac)

text \<open> We can also, of course, combine substitution and predicate calculus to prove conjectures
  containing substitutions. Below, we prove a theorem in two steps, first applying the substitution,
  and then secondly utilising predicate calculus. Note the need to add the type coercion:
  @{term "1 :\<^sub>u int"} -- this is because both 1 and 2 are polymorphic (e.g. they can also have type
  @{typ real}), and thus explicit types must be added.  \<close>

lemma "(&x =\<^sub>u 1 \<and> &y =\<^sub>u &x)\<lbrakk>2/x\<rbrakk> = false" (is "?lhs = ?rhs")
proof -
  have "?lhs = (2 =\<^sub>u (1 :\<^sub>u int) \<and> &y =\<^sub>u 2)"
    by (subst_tac)
  also have "... = ?rhs"
    by (pred_auto)
  finally show ?thesis .
qed

text \<open> Isabelle/UTP also supports a more general notation for substitutions, where-by variable
  maplets can be considered as explicit objects that correspond to functions on the state-space.
  For example, @{term "[&x \<mapsto>\<^sub>s 1, &y \<mapsto>\<^sub>s 2]"} is a substitution that replaces $x$ with 1 and $y$
  with 2. Such substitution functions ($\sigma$) can be applied to an expression or predicate using
  the dagger operator: @{term "\<sigma> \<dagger> P"}. Thus, we can perform the following simplification: \<close>

lemma "[&x \<mapsto>\<^sub>s 1, &y \<mapsto>\<^sub>s 2] \<dagger> (&x <\<^sub>u &y) = ((1 :\<^sub>u int) <\<^sub>u 2)"
  by (subst_tac)

text \<open> This notation thus allows us to deal with state space much more flexibly. The more standard
  notation @{term "P\<lbrakk>v/x\<rbrakk>"} is in fact syntactic sugar to application of the singleton substitution
  function @{term "[x \<mapsto>\<^sub>s v]"}.

  So far, we have considered UTP predicates which contain only UTP variables. However it is
  possible to have another kind of variable -- a logical HOL variable which is sometimes known
  as a ``logical constant''~\cite{Morgan90}. Such variables are not program or model variables,
  but they simply exist to assert logical properties of a predicate. The next two examples compare UTP and HOL
  variables in a quantification. \<close>

lemma "(\<forall> x \<bullet> &x =\<^sub>u &x) = true"
  by (pred_auto)

lemma "(\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>x\<guillemotright>) = true"
  by (pred_auto)

text \<open> The first quantification is a quantification of a UTP variable, which we've already encountered.
  The second is a quantifier over a HOL variable, denoted by the quantifier being bold. In addition
  we refer to HOL variables, not using the ampersand, but the quotes @{term "\<guillemotleft>k\<guillemotright>"}. These quotes
  allow us to insert an arbitrary HOL term into a UTP expression, such as a logical variable. \<close>

subsection \<open> Relations \<close>

text \<open> Relations, @{typ "('\<alpha>, '\<beta>) urel"}, are a class of predicate in which the state space is a product
  -- i.e. @{typ "('\<alpha> \<times> '\<beta>) upred"} -- and divides the variables into input or ``before'' variables
  and output or ``after'' variables. In Isabelle/UTP we can write down a relational variable using
  the dollar notation, as illustrated below: \<close>

term "($x\<acute> =\<^sub>u 1 \<and> $y\<acute> =\<^sub>u $y \<and> $z\<acute> =\<^sub>u $z) :: myst hrel"

text \<open> Type @{typ "'\<alpha> hrel"} is the type of homogeneous relations, which have the same before and
  after state. This example relation can be intuitively thought of as the relation which sets
  $x$ to $1$ and leaves the other two variables unchanged. We would normally refer to this as
  an assignment of course, and for convenience we can write such a predicate using a more
  convenient syntax, @{term "x := 1"}, which is equivalent: \<close>

lemma "(x := 1) = (($x\<acute> =\<^sub>u 1 \<and> $y\<acute> =\<^sub>u $y \<and> $z\<acute> =\<^sub>u $z) :: myst hrel)"
  by (rel_auto)

text \<open> Since we are now in the world of relations, we have an additional tactic called \emph{rel-auto}
  that solves conjectures in relational calculus. We can use relational variables to write to
  loose specifications for programs, and then prove that a given program is a refinement. Refinement
  is an order on programs that allows us to assert that a program refines a given specification,
  for example: \<close>

lemma "($x\<acute> >\<^sub>u $y) \<sqsubseteq> (x, y) := ((&y + 3), 5)"
  by (rel_auto)

text \<open> This tells us that the specification that the after value of $x$ must be greater than the initial
  value of $y$, is refined by the program which adds $3$ to $y$ and assigns this to $x$, and
  simultaneously assigns $5$ to $y$. Of course, this is not the only refinement, but an interesting
  one. A refinement conjecture @{term "P \<sqsubseteq> Q"} in general asserts that @{term "Q"} is more deterministic
  than @{term "P"}. In addition to assignments, we can also construct relational specifications and programs
  using sequential (or relational) composition: \<close>

lemma "x := 1 ;; x := (&x + 1) = x := 2"
  by (rel_auto)

text \<open> Internally, what is happening here is quite subtle, so we can also prove this law in the Isar
  proof scripting language which allows us to further expose the details of the argument. In this
  proof we will make use of both the tactic and already proven laws of programming from Isabelle/UTP. \<close>

lemma "x := 1 ;; x := (&x + 1) = x := 2"
proof -
  \<comment> \<open> We first show that a relational composition of an assignment and some program $P$ corresponds
        to substitution of the assignment into $P$, which is proved using the law
        @{thm [source] "assigns_r_comp"}. \<close>
  have "x := 1 ;; x := (&x + 1) = (x := (&x + 1))\<lbrakk>1/$x\<rbrakk>"
    by (simp add: assigns_r_comp alpha usubst)
  \<comment> \<open> Next we execute the substitution using the relational calculus tactic. \<close>
  also have "... = x := (1 + 1)"
    by (rel_auto)
  \<comment> \<open> Finally by evaluation of the expression, we obtain the desired result of $2$. \<close>
  also have "... = x := 2"
    by (simp)
  finally show ?thesis .
qed

text \<open> UTP also gives us an if-then-else conditional construct, written @{term "P \<triangleleft> b \<triangleright> Q"}, which
  is a more concise way of writing $\textbf{if}~b~\textbf{then}~P~\textbf{else}~Q$. It also allows
  the expression of while loops, which gives us a simple imperative programming language. \<close>

lemma "(x := 1 ;; (y := 7 \<triangleleft> $x >\<^sub>u 0 \<triangleright> y := 8)) = (x,y) := (1,7)"
  by (rel_auto)

text \<open> Below is an illustration of how we can express a simple while loop in Isabelle/UTP. \<close>

term "(x,y) := (3,1);; while (&x > 0) do x := &x - 1;; y := &y * 2 od"

subsection \<open> Non-determinism and Complete Lattices \<close>

text \<open> So far we have considered only deterministic programming operators. However, one of the
  key feature of the UTP is that it allows non-deterministic specifications. Determinism is
  ordered by the refinement order @{term "P \<sqsubseteq> Q"}, which states that $P$ is more deterministic
  that $Q$, or alternatively that $Q$ makes fewer commitments than $P$. The refinement order
  @{term "P \<sqsubseteq> Q"} corresponds to a universally closed implication @{term "Q \<Rightarrow> P"}. The most
  deterministic specification is @{term "false"}, which also corresponds to a miraculous program,
  and the least is @{term "true"}, as the following theorems demonstrate. \<close>

theorem false_greatest: "P \<sqsubseteq> false"
  by (rel_auto)

theorem true_least: "true \<sqsubseteq> P"
  by (rel_auto)

text \<open> In this context @{term true} corresponds to a programmer error, such as an aborting or
  non-terminating program (the theory of relations does not distinguish these). We can similarly
  specify a non-deterministic choice between $P$ and $Q$ with
  @{term "P \<sqinter> Q"}, or alternatively @{term "\<Sqinter> A"} where $A$ is a set of possible behaviours.
  Predicate @{term "P \<sqinter> Q"} encapsulates the behaviours of both $P$ and $Q$, and is thus
  refined by both. We can also prove a variety of theorems about non-deterministic choice. \<close>

theorem Choice_equiv:
  fixes P Q :: "'\<alpha> upred"
  shows "\<Sqinter> {P, Q} = P \<sqinter> Q"
  by simp

text \<open> Theorem @{thm [source] Choice_equiv} shows the relationship between the big choice operator
  and its binary equivalent. The latter is simply a choice over a set with two elements. \<close>

theorem Choice_refine:
  fixes A B :: "'\<alpha> upred set"
  assumes "B \<subseteq> A"
  shows "\<Sqinter> A \<sqsubseteq> \<Sqinter> B"
  by (simp add: Sup_subset_mono assms)

text \<open> The intuition of theorem @{thm [source] Choice_refine} is that a specification with more
  options is refined by one with less options. We can also prove a number of theorems about
  the binary version of the operator. \<close>

theorem choice_thms:
  fixes P Q :: "'\<alpha> upred"
  shows
    "P \<sqinter> P = P"
    "P \<sqinter> Q = Q \<sqinter> P"
    "(P \<sqinter> Q) \<sqinter> R = P \<sqinter> (Q \<sqinter> R)"
    "P \<sqinter> true = true"
    "P \<sqinter> false = P"
    "P \<sqinter> Q \<sqsubseteq> P"
  by (simp_all add: lattice_class.inf_sup_aci true_upred_def false_upred_def)

text \<open> Non-deterministic choice is idempotent, meaning that a choice between $P$ and $P$ is no choice. It
  is also commutative and associative. If we make a choice between @{term "P"} and @{term "true"} then
  the erroneous behaviour signified by the latter is always chosen. Thus our operator is a so-called
  ``demonic choice'' since the worst possibility is always picked. Similarly, if a choice is made between
  @{term "P"} and a miracle (@{term "false"}) then @{term "P"} is always chosen in order to avoid miracles.
  Finally, the choice between @{term "P"} and @{term "Q"} can always be refined by removing one of the
  possibilities.

  Since predicates form a complete lattice, then by the Knaster-Tarski theorem the set of fixed points
  of a monotone function @{term "F"} is also a complete lattice. In particular, this complete lattice
  has a weakest and strongest element which can be calculated using the notations @{term "\<mu> X \<bullet> F(X)"}
  and @{term "\<nu> X \<bullet> F(X)"}, respectively. Such fixed point constructions are of particular use for
  expressing recursive and iterative constructions. Isabelle/HOL provides a number of laws for reasoning
  about fixed points, a few of which are detailed below.
\<close>

theorem mu_id: "(\<mu> X \<bullet> X) = true"
  by (simp add: mu_id)

theorem nu_id: "(\<nu> X \<bullet> X) = false"
  by (simp add: nu_id)

theorem mu_unfold: "mono F \<Longrightarrow> (\<mu> X \<bullet> F(X)) = F(\<mu> X \<bullet> F(X))"
  by (simp add: def_gfp_unfold)

theorem nu_unfold: "mono F \<Longrightarrow> (\<nu> X \<bullet> F(X)) = F(\<nu> X \<bullet> F(X))"
  by (simp add: def_lfp_unfold)

text \<open> Perhaps of most interest are the unfold laws, also known as the ``copy rule'', that allows
  the function body $F$ of the fixed point equation to be expanded once. These state that, provided
  that the body of the fixed point is a monotone function, then the body can be copied to the outside.
  These can be used to prove equivalent laws for operators like the while loop. \<close>

subsection \<open> Laws of Programming \<close>

text \<open> Although we have some primitive tactics for proving conjectures in the predicate and relational
  calculi, in order to build verification tools for programs we need a set of algebraic ``laws of
  programming''~\cite{Hoare87} that describe important theoretical properties of the operators.
  Isabelle/UTP contains several hundred examples of such laws, and we here outline a few of them. \<close>

theorem seq_assoc: "(P ;; Q) ;; R = P ;; (Q ;; R)"
  by (rel_auto)

theorem seq_unit:
  "P ;; II = P"
  "II ;; P = P"
  by (rel_auto)+

theorem seq_zero:
  "P ;; false = false"
  "false ;; P = false"
  by (rel_auto)+

text \<open> Sequential composition is associative, has the operator @{term "II"} as its left and
  right unit, and @{term "false"} as its left and right zeros. The @{term "II"} operator is a form
  of assignment which simply identifies all the variables between the before and after state,
  as the following example demonstrates. \<close>

lemma "x := &x = II"
  by (rel_auto)

text \<open> In the context of relations, @{term "false"} denotes the empty relation, and is usually
  used to represent a miraculous program. This is intuition of it being a left and right zero:
  if a miracle occurred then the whole of the program collapses. The conditional @{term "P \<triangleleft> b \<triangleright> Q"}
  also has a number of algebraic laws that we can prove. \<close>

theorem cond_true: "P \<triangleleft> true \<triangleright> Q = P"
  by (rel_auto)

theorem cond_false: "P \<triangleleft> false \<triangleright> Q = Q"
  by (rel_auto)

theorem cond_commute: "(P \<triangleleft> \<not> b \<triangleright> Q) = (Q \<triangleleft> b \<triangleright> P)"
  by (rel_auto)

theorem cond_shadow: "(P \<triangleleft> b \<triangleright> Q) \<triangleleft> b \<triangleright> R = P \<triangleleft> b \<triangleright> R"
  by (rel_auto)

text \<open> A conditional with @{term true} or @{term false} as its condition presents no choice.
  A conditional can also be commuted by negating the condition. Finally, a conditional within
  a conditional over the same condition, @{term b}, presents and unreachable branch. Thus the
  inner branch can be pruned away. We next prove some useful laws about assignment: \<close>

theorem assign_commute:
  assumes "x \<bowtie> y" "y \<sharp> e" "x \<sharp> f"
  shows "x := e;; y := f = y := f ;; x := e"
  using assms by (rel_auto)

theorem assign_twice:
  shows "x := \<guillemotleft>e\<guillemotright>;; x := \<guillemotleft>f\<guillemotright> = x := \<guillemotleft>f\<guillemotright>"
  by (rel_auto)

theorem assign_null:
  assumes "x \<bowtie> y"
  shows "(x, y) := (e, &y) = x := e"
  using assms by (rel_auto)

text \<open> Assignments can commute provided that the two variables are independent, and the expressions
  being assigned do not depend on the variable of the other assignment. A sequence of assignments
  to the same variable is equal to the second assignment, provided that the two expressions are
  both literals, i.e. @{term "\<guillemotleft>e\<guillemotright>"}. Finally, in a multiple assignment, if one of the variables
  is assigned to itself then this can be hidden, provided the two variables are independent. \<close>

text \<open>
  Since alphabetised relations form a complete lattice, we can denote iterative constructions like
  the while loop which is defined as @{term "while\<^sub>\<bottom> b do P od = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"}. We can
  then prove some common laws about iteration. \<close>

theorem while_false: "while\<^sub>\<bottom> false do P od = II"
  by (simp add: while_bot_false)

theorem while_unfold: "while\<^sub>\<bottom> b do P od = (P ;; while\<^sub>\<bottom> b do P od) \<triangleleft> b \<triangleright>\<^sub>r II"
  using while_bot_unfold by blast

text \<open> As we have seen, the predicate @{term "true"} represents the erroneous program. For loops, we
  have it that a non-terminating program equates to @{term true}, as the following example demonstrates. \<close>

lemma "while\<^sub>\<bottom> true do x := (&x + 1) od = true"
  by (simp add: assigns_r_feasible while_infinite)

text \<open> A program should not be able to recover from non-termination, of course, and therefore it
  ought to be the case that @{term true} is a left zero for sequential composition:
  @{term "true ;; P = true"}. However this is not the case as the following examples illustrate: \<close>

lemma "true ;; P = true"
  apply (rel_simp)
  nitpick \<comment> \<open> Counterexample found \<close>
oops

lemma "true ;; (x,y,z) := (\<guillemotleft>c\<^sub>1\<guillemotright>,\<guillemotleft>c\<^sub>2\<guillemotright>,\<guillemotleft>c\<^sub>3\<guillemotright>) = ((x,y,z) := (\<guillemotleft>c\<^sub>1\<guillemotright>,\<guillemotleft>c\<^sub>2\<guillemotright>,\<guillemotleft>c\<^sub>3\<guillemotright>) :: myst hrel)"
  by (rel_auto)

text \<open> The latter gives an example of a relation for which @{term true} is actually a left unit
  rather than a left zero. The assignment @{term "x,y,z := \<guillemotleft>c\<^sub>1\<guillemotright>,\<guillemotleft>c\<^sub>2\<guillemotright>,\<guillemotleft>c\<^sub>3\<guillemotright>"} does not depend
  on any before variables, and thus it is insensitive to a non-terminating program preceding it.
  Thus we can see that the theory of relations alone is insufficient to handle non-termination. \<close>

subsection \<open> Designs \<close>

text \<open> Though we now have a theory of UTP relations with which can form simple programs, as we have seen
  this theory experiences some problems. A UTP design, @{term "P \<turnstile>\<^sub>r Q"}, is a relational specification
  in terms of assumption $P$ and commitment $Q$. Such a construction states that, if $P$ holds and
  the program is allowed to execute, then the program will terminate and satisfy its commitment $Q$. If
  $P$ is not satisfied then the program will abort yielding the predicate @{term true}. For example the design
  @{term "($x \<noteq>\<^sub>u 0) \<turnstile>\<^sub>r (y := (&y div &x))"} represents a program which, assuming that $x \neq 0$ assigns
  $y$ divided by $x$ to $y$.
\<close>

lemma dex1: "(true \<turnstile>\<^sub>r (x,y) := (2,6)) ;; (($x \<noteq>\<^sub>u 0) \<turnstile>\<^sub>r (y := (&y div &x))) = true \<turnstile>\<^sub>r x,y := 2,3"
  by (rel_auto, fastforce+)

lemma dex2: "(true \<turnstile>\<^sub>r (x,y) := (0,4)) ;; (($x \<noteq>\<^sub>u 0) \<turnstile>\<^sub>r y := (&y div &x)) = true"
  by (rel_blast)

text \<open> The first example shows the result of pre-composing this design with another design that
  has a @{term true} assumption, and assigns 2 and 6 to $x$ and $y$ respectively. Since $x$ satisfies
  $x \neq 0$, then the design executes and changes $y$ to $3$. In the second example 0 is assigned to $x$,
  which leads to the design aborting. Unlike with relations, designs do have @{term true} as a left zero: \<close>

theorem design_left_zero: "true ;; (P \<turnstile>\<^sub>r Q) = true"
  by (simp add: H1_left_zero H1_rdesign Healthy_def)

text \<open> Thus designs allow us to properly handle programmer error, such as non-termination.

  The design turnstile is defined using two observational variables $ok, ok' : \mathbb{B}$,
  which are used to represent whether a program has been  ($ok$) and whether it has
  terminated ($ok'$). Specifically, a design @{term "P \<turnstile> Q"} is defined as
  $(ok \wedge P) \Rightarrow (ok' \wedge Q)$. This means that if the program was started ($ok$) and
  satisfied its assumption ($P$), then it will terminate ($ok'$) and satisfy its commitment ($Q$).
  For more on the theory of designs please see the associated tutorial~\cite{Cavalcanti&06}. \<close>

subsection \<open> Reactive Designs \<close>

text \<open> A reactive design, @{term "\<^bold>R\<^sub>s(P \<turnstile> Q)"}, is a specialised form of design which is reactive
  in nature. Whereas designs represents programs that start and terminate, reactive designs also
  have intermediate ``waiting'' states. In such a state the reactive design is waiting for something
  external to occur before it can continue, such as receiving a message or waiting for sufficient time
  to pass as measured by a clock. When waiting, a reactive design has not terminated, but neither is
  it an infinite loop or some other error state.

  Reactive designs have two additional pair of observational variables:

  \begin{itemize}
    \item $wait, wait' : \mathbb{B}$ -- denote whether the predecessor is in a waiting state, and
      whether the current program is a waiting state;
    \item $tr, tr' : \mathcal{T}$ -- denotes the interaction history using a suitable trace type
      $\mathcal{T}$.
  \end{itemize}

 For more details on reactive designs please see the associated tutorial~\cite{Cavalcanti&06}. \<close>
(*<*)
end
(*>*)


(*
  File:    Linear_Recurrence_Common.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Material common to homogenous and inhomogenous linear recurrences\<close>
theory Linear_Recurrences_Common
imports
  Complex_Main
  "HOL-Computational_Algebra.Computational_Algebra"
begin

definition lr_fps_denominator where
  "lr_fps_denominator cs = Poly (rev cs)"

lemma lr_fps_denominator_code [code abstract]:
  "coeffs (lr_fps_denominator cs) = rev (dropWhile ((=) 0) cs)"
  by (simp add: lr_fps_denominator_def)

definition lr_fps_denominator' where
  "lr_fps_denominator' cs = Poly cs"

lemma lr_fps_denominator'_code [code abstract]:
  "coeffs (lr_fps_denominator' cs) = strip_while ((=) 0) cs"
  by (simp add: lr_fps_denominator'_def)

lemma lr_fps_denominator_nz: "last cs \<noteq> 0 \<Longrightarrow> cs \<noteq> [] \<Longrightarrow> lr_fps_denominator cs \<noteq> 0"
  unfolding lr_fps_denominator_def
  by (subst coeffs_eq_iff) (auto simp: poly_eq_iff intro!: bexI[of _ "last cs"])

lemma lr_fps_denominator'_nz: "last cs \<noteq> 0 \<Longrightarrow> cs \<noteq> [] \<Longrightarrow> lr_fps_denominator' cs \<noteq> 0"
  unfolding lr_fps_denominator'_def
  by (subst coeffs_eq_iff) (auto simp: poly_eq_iff intro!: bexI[of _ "last cs"])

end


section \<open> Derivatives: extra laws and tactics \<close>

theory Derivative_extra
  imports
  "Differential_Dynamic_Logic.Lib"
  "HOL-Eisbach.Eisbach"
  "HOL-Decision_Procs.Approximation"
begin

subsection \<open> Properties of filters \<close>

lemma filtermap_within_range_minus: "filtermap (\<lambda> x. x - n::real) (at y within {x..<y}) = (at (y - n) within ({x-n..<y-n}))"
  by (simp add: filter_eq_iff eventually_filtermap eventually_at_filter filtermap_nhds_shift[symmetric])

lemma filtermap_within_range_plus: "filtermap (\<lambda> x. x + n::real) (at y within {x..<y}) = (at (y + n) within ({x+n..<y+n}))"
  using filtermap_within_range_minus[of "-n"] by simp

lemma filter_upto_contract:
  "\<lbrakk> (x::real) \<le> y; y < z \<rbrakk> \<Longrightarrow> (at z within {x..<z}) = (at z within {y..<z})"
  by (rule at_within_nhd[of _ "{y<..<z+1}"], auto)

subsection \<open> Topological Spaces \<close>

instantiation unit :: t2_space
begin
  definition open_unit :: "unit set \<Rightarrow> bool" where "open_unit = (\<lambda> _. True)"
  instance by (intro_classes, simp_all add: open_unit_def)
end

subsection \<open> Extra derivative rules \<close>

lemma has_vector_derivative_Pair [derivative_intros]:
  "\<lbrakk> (f has_vector_derivative f') (at x within s); (g has_vector_derivative g') (at x within s) \<rbrakk> \<Longrightarrow>
      ((\<lambda> x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  by (auto intro: has_derivative_Pair simp add: has_vector_derivative_def)

lemma has_vector_derivative_power[simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a :: real_normed_field"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. f x^n) has_vector_derivative (of_nat n * f' * f x^(n - 1))) (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (subst has_derivative_eq_rhs)
  apply (rule has_derivative_power)
  apply (auto)
done

lemma has_vector_derivative_divide[simp, derivative_intros]:
  fixes f :: "real \<Rightarrow> 'a :: real_normed_div_algebra"
  assumes f: "(f has_vector_derivative f') (at x within s)"
      and g: "(g has_vector_derivative g') (at x within s)"
  assumes x: "g x \<noteq> 0"
  shows "((\<lambda>x. f x / g x) has_vector_derivative
                (- f x * (inverse (g x) * g' * inverse (g x)) + f' / g x)) (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (subst has_derivative_eq_rhs)
  apply (rule has_derivative_divide)
  apply (auto simp add: divide_inverse real_vector.scale_right_diff_distrib)
done

lemma Pair_has_vector_derivative:
  assumes "(f has_vector_derivative f') (at x within s)"
    "(g has_vector_derivative g') (at x within s)"
  shows "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros)

lemma has_vector_derivative_fst:
  assumes "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  shows "(f has_vector_derivative f') (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros dest: has_derivative_fst)

lemma has_vector_derivative_fst' [derivative_intros]:
  assumes "(f has_vector_derivative (f', g')) (at x within s)"
  shows "(fst \<circ> f has_vector_derivative f') (at x within s)"
proof -
  have "(\<lambda> x. (fst (f x), snd (f x))) = f"
    by (simp)
  with assms have "((\<lambda> x. (fst (f x), snd (f x))) has_vector_derivative (f', g')) (at x within s)"
    by (simp)
  thus ?thesis
    by (drule_tac has_vector_derivative_fst, simp add: comp_def)
qed

lemma has_vector_derivative_snd:
  assumes "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s)"
  shows "(g has_vector_derivative g') (at x within s)"
  using assms
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros dest: has_derivative_snd)

lemma has_vector_derivative_snd'' [derivative_intros]:
  assumes "(f has_vector_derivative (f', g')) (at x within s)"
  shows "(snd \<circ> f has_vector_derivative g') (at x within s)"
proof -
  have "(\<lambda> x. (fst (f x), snd (f x))) = f"
    by (simp)
  with assms have "((\<lambda> x. (fst (f x), snd (f x))) has_vector_derivative (f', g')) (at x within s)"
    by (simp)
  thus ?thesis
    by (drule_tac has_vector_derivative_snd, simp add: comp_def)
qed

lemma Pair_has_vector_derivative_iff:
  "((\<lambda>x. (f x, g x)) has_vector_derivative (f', g')) (at x within s) \<longleftrightarrow>
   (f has_vector_derivative f') (at x within s) \<and> (g has_vector_derivative g') (at x within s)"
  using Pair_has_vector_derivative has_vector_derivative_fst has_vector_derivative_snd by blast

text \<open> The next four rules allow us to prove derivatives when the function is equivalent to
  another a function when approach from the left or right. \<close>

lemma has_derivative_left_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_derivative f') (at x within s)" "x \<in> s" "x < y" "\<forall>x'<y. f x' = g x'"
  shows "(g has_derivative f') (at x within s)"
  apply (rule has_derivative_transform_within[of f f' x s "y-x" g])
  apply (simp_all add: assms dist_real_def)
done

lemma has_derivative_right_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_derivative f') (at x within s)" "x \<in> s" "x > y" "\<forall>x'>y. f x' = g x'"
  shows "(g has_derivative f') (at x within s)"
  apply (rule has_derivative_transform_within[of f f' x s "x-y" g])
  apply (simp_all add: assms dist_real_def)
done

lemma has_vector_derivative_left_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_vector_derivative f') (at x within s)" "x \<in> s" "x < y" "\<forall>x'<y. f x' = g x'"
  shows "(g has_vector_derivative f') (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (rule_tac y="y" and f="f" in has_derivative_left_point)
  apply (auto simp add: assms)
done

lemma has_vector_derivative_right_point:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(f has_vector_derivative f') (at x within s)" "x \<in> s" "x > y" "\<forall>x'>y. f x' = g x'"
  shows "(g has_vector_derivative f') (at x within s)"
  using assms
  apply (simp add: has_vector_derivative_def)
  apply (rule_tac y="y" and f="f" in has_derivative_right_point)
  apply (auto simp add: assms)
done

method prove_vec_deriv = (simp add: has_vector_derivative_def, subst has_derivative_eq_rhs, force intro: derivative_intros; auto simp add: field_simps)

lemma has_vector_derivative_sqrt[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  assumes "f x > 0"
  shows "((\<lambda>x. sqrt(f x)) has_vector_derivative (f' * 1/(2 * sqrt(f x)))) (at x within s)"
  using assms unfolding divide_inverse by prove_vec_deriv

lemma has_vector_derivative_sin[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. sin(f x)) has_vector_derivative (f' * cos(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_cos[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. cos(f x)) has_vector_derivative (f' * - sin(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_exp[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)"
  shows "((\<lambda>x. exp(f x)) has_vector_derivative (f' * exp(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_ln[derivative_intros]:
  fixes f :: "real \<Rightarrow> real"
  assumes f: "(f has_vector_derivative f') (at x within s)" "0 < f x"
  shows "((\<lambda>x. ln(f x)) has_vector_derivative (f' * inverse(f x))) (at x within s)"
  using assms by prove_vec_deriv

lemma has_vector_derivative_powr[derivative_intros]:
  fixes f :: "real \<Rightarrow> real" and g :: "real \<Rightarrow> real"
  assumes
    "(g has_vector_derivative g') (at x within X)"
    "(f has_vector_derivative f') (at x within X)"
    "0 < g x" "x \<in> X"
  shows "((\<lambda>x. g x powr f x) has_vector_derivative (g x powr f x * (f' * ln (g x) + g' * f x / g x))) (at x within X)"
  using assms by prove_vec_deriv

lemma max_simps [simp]:
  "(y::real) < max x y \<longleftrightarrow> y < x"
  "x < max x y \<longleftrightarrow> x < y"
  "max x y = y \<longleftrightarrow> x \<le> y"
  by auto

lemma min_simps [simp]:
  "min (x::real) y < x \<longleftrightarrow> y < x"
  "min x y < y \<longleftrightarrow> x < y"
  by auto

text \<open> These laws seem helpful for discharging real conjectures. \<close>

lemma real_sqrt_pow2_combine [simp]: "x > 0 \<Longrightarrow> sqrt x * (sqrt x * n) = x * n"
  by simp

declare power2_eq_square [field_simps]

subsection \<open> Calculating derivatives \<close>

text \<open> We set up some nice syntax for taking derivatives by calculation, and prove associated
  theorems based on the Multivariate Analysis package. \<close>

notation frechet_derivative ("\<partial>")
notation vector_derivative ("\<partial>\<^sub>v")

lemma vector_derivative_chain_frechet:
  fixes g :: "'a::ordered_euclidean_space \<Rightarrow> 'b::ordered_euclidean_space"
  assumes "f differentiable (at x)" "g differentiable (at (f x))"
  shows "\<partial>\<^sub>v (g \<circ> f) (at x) = \<partial> g (at (f x)) (\<partial>\<^sub>v f (at x))"
proof -
  have "(g has_derivative \<partial> g (at (f x))) (at (f x))"
    using assms(2) frechet_derivative_works by blast
  hence 1:"(g has_derivative \<partial> g (at (f x))) (at (f x) within range f)"
    by (simp add: has_derivative_at_withinI)
  from 1 assms show ?thesis
    by (auto intro: vector_derivative_chain_within simp add: at_eq_bot_iff)
qed

lemma frechet_derivative_const: "\<partial> (\<lambda> x. k) (at t) = (\<lambda> x. 0)"
  by (metis frechet_derivative_at has_derivative_const)

lemma frechet_derivative_vec:
  fixes f :: "'i::finite \<Rightarrow> 'a::{real_normed_vector} \<Rightarrow> 'b::real_normed_vector"
  assumes "\<And> i. (f i) differentiable (at t)"
  shows "frechet_derivative (\<lambda> x. (\<chi> i. f i x)) (at t) = (\<lambda> x. (\<chi> i. frechet_derivative (f i) (at t) x))"
proof -
  have "((\<lambda>a. \<chi> i. f i a) has_derivative (\<lambda>a. \<chi> i. \<partial> (f i) (at t) a)) (at t)"
    by (metis (no_types) assms frechet_derivative_works has_derivative_vec)
  then show ?thesis
    by (metis (no_types) frechet_derivative_at)
qed

lemma differentiable_vec:
  fixes f :: "'i::finite \<Rightarrow> 'a::{real_normed_vector} \<Rightarrow> 'b::real_normed_vector"
  assumes "\<And> i. (f i) differentiable (at t)"
  shows "(\<lambda> x. \<chi> i. f i x) differentiable (at t)"
proof -
  have "\<forall>A i. (f i has_derivative \<partial> (f i) (at t)) (at t within A)"
    by (metis (no_types) assms differentiable_def frechet_derivative_at has_derivative_at_withinI)
  then have "\<forall>A. ((\<lambda>a. \<chi> i. f i a) has_derivative (\<lambda>a. \<chi> i. \<partial> (f i) (at t) a)) (at t within A)"
    by (simp add: has_derivative_vec)
  then show ?thesis
    using differentiable_def by blast
qed

lemma frechet_derivative_plus:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x + g x) (at t) = (\<lambda> x. \<partial> f (at t) x + \<partial> g (at t) x)"
proof -
  have "((\<lambda>x. f x + g x) has_derivative (\<lambda>x. \<partial> f (at t) x + \<partial> g (at t) x)) (at t)"
    using assms(1) assms(2) frechet_derivative_works has_derivative_add by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_uminus:
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. - f x) (at t) = (\<lambda>x. - \<partial> f (at t) x)"
proof -
  have "((\<lambda>x. - f x) has_derivative (\<lambda>x. - \<partial> f (at t) x)) (at t)"
    using assms frechet_derivative_works has_derivative_minus by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_minus:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x - g x) (at t) = (\<lambda> x. \<partial> f (at t) x - \<partial> g (at t) x)"
proof -
  have "((\<lambda>x. f x - g x) has_derivative (\<lambda>x. \<partial> f (at t) x - \<partial> g (at t) x)) (at t)"
    using assms(1) assms(2) frechet_derivative_works has_derivative_diff by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_mult:
  fixes f g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_algebra"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x * g x) (at t) =
         (\<lambda> x. f t * \<partial> g (at t) x + \<partial> f (at t) x * g t)"
proof -
  have "((\<lambda>x. f x * g x) has_derivative (\<lambda> x. f t * \<partial> g (at t) x + \<partial> f (at t) x * g t)) (at t)"
    using assms(1) assms(2) frechet_derivative_works has_derivative_mult by blast
  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_scaleR:
  fixes g :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x *\<^sub>R g x) (at t) =
         (\<lambda> x. f t *\<^sub>R \<partial> g (at t) x + \<partial> f (at t) x *\<^sub>R g t)"
proof -
  have "((\<lambda>x. f x *\<^sub>R g x) has_derivative (\<lambda> x. f t *\<^sub>R \<partial> g (at t) x + \<partial> f (at t) x *\<^sub>R g t)) (at t)"
  proof -
    have "(f has_derivative \<partial> f (at t)) (at t)"
      by (meson assms(1) frechet_derivative_works)
    then show ?thesis
      using assms(2) frechet_derivative_works has_derivative_scaleR by blast
  qed

  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_inner:
  fixes g :: "'a::{real_inner,real_normed_vector} \<Rightarrow> 'b::{real_inner,real_normed_vector}"
  assumes "f differentiable (at t)" "g differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x \<bullet> g x) (at t) =
         (\<lambda> x. f t \<bullet> \<partial> g (at t) x + \<partial> f (at t) x \<bullet> g t)"
proof -
  have "((\<lambda>x. f x \<bullet> g x) has_derivative (\<lambda> x. f t \<bullet> \<partial> g (at t) x + \<partial> f (at t) x \<bullet> g t)) (at t)"
  proof -
    have "(f has_derivative \<partial> f (at t)) (at t)"
      by (meson assms(1) frechet_derivative_works)
    then show ?thesis
      using assms(2) frechet_derivative_works has_derivative_inner by blast
  qed

  thus ?thesis
    using frechet_derivative_at by force
qed

lemma frechet_derivative_norm:
  fixes f :: "'a::{real_inner} \<Rightarrow> 'b::{real_inner}"
  assumes "f differentiable (at t)" "f t \<noteq> 0"
  shows "\<partial> (\<lambda> x. norm (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x \<bullet> sgn (f t))"
proof -
  have "(norm \<circ> f has_derivative ((\<lambda> x. x \<bullet> sgn (f t)) \<circ> \<partial> f (at t))) (at t)"
    using assms(1) assms(2) diff_chain_at frechet_derivative_works has_derivative_norm by blast
  thus ?thesis
    by (metis assms differentiable_def frechet_derivative_at has_derivative_compose has_derivative_norm)
qed

lemma frechet_derivative_power:
  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_field"
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. f x ^ n) (at t) = (\<lambda>y. of_nat n * \<partial> f (at t) y * f t ^ (n - 1))"
  using assms has_derivative_power[of f "\<partial> f (at t)" t UNIV n] frechet_derivative_at
  by (fastforce simp add: frechet_derivative_works)

lemma frechet_derivative_powr:
  fixes f :: "'a::{banach, real_normed_algebra_1} \<Rightarrow> real"
  assumes "f differentiable (at t)" "g differentiable (at t)" "0 < f t"
  shows "\<partial> (\<lambda> x. f x powr g x) (at t) = (\<lambda>h. f t powr g t * (\<partial> g (at t) h * ln (f t) + \<partial> f (at t) h * g t / f t))"
  using assms has_derivative_powr[of f "\<partial> f (at t)" t UNIV g "\<partial> g (at t)"] frechet_derivative_at
  by (fastforce simp add: frechet_derivative_works)

lemma frechet_derivative_ln:
  fixes f :: "'a::{banach, real_normed_algebra_1} \<Rightarrow> real"
  assumes "f differentiable (at t)" "0 < f t"
  shows "\<partial> (\<lambda> x. ln (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x * inverse (f t))"
  by (metis assms(1) assms(2) frechet_derivative_at frechet_derivative_works has_derivative_ln)

lemma frechet_derivative_sin:
  fixes f :: "'a::{real_normed_vector} \<Rightarrow> real"
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. sin (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x * cos (f t))"
  by (metis assms frechet_derivative_at frechet_derivative_works has_derivative_sin)

lemma frechet_derivative_cos:
  fixes f :: "'a::{real_normed_vector} \<Rightarrow> real"
  assumes "f differentiable (at t)"
  shows "\<partial> (\<lambda> x. cos (f x)) (at t) = (\<lambda> x. \<partial> f (at t) x * - sin (f t))"
  by (metis assms frechet_derivative_at frechet_derivative_works has_derivative_cos)

end


theory T57
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Utils
  imports Regular_Tree_Relations.Term_Context
    Regular_Tree_Relations.FSet_Utils
begin

subsection \<open>Misc\<close>

definition "funas_trs \<R> = \<Union> ((\<lambda> (s, t). funas_term s \<union> funas_term t) ` \<R>)"

fun linear_term :: "('f, 'v) term \<Rightarrow> bool" where
  "linear_term (Var _) = True" |
  "linear_term (Fun _ ts) = (is_partition (map vars_term ts) \<and> (\<forall>t\<in>set ts. linear_term t))"

fun vars_term_list :: "('f, 'v) term \<Rightarrow> 'v list" where
  "vars_term_list (Var x) = [x]" |
  "vars_term_list (Fun _ ts) = concat (map vars_term_list ts)"

fun varposs :: "('f, 'v) term \<Rightarrow> pos set" where
  "varposs (Var x) = {[]}" |
  "varposs (Fun f ts) = (\<Union>i<length ts. {i # p | p. p \<in> varposs (ts ! i)})"

abbreviation "poss_args f ts \<equiv> map2 (\<lambda> i t. map ((#) i) (f t)) ([0 ..< length ts]) ts"

fun varposs_list :: "('f, 'v) term \<Rightarrow> pos list" where
  "varposs_list (Var x) = [[]]" |
  "varposs_list (Fun f ts) = concat (poss_args varposs_list ts)"

fun concat_index_split where
  "concat_index_split (o_idx, i_idx) (x # xs) =
     (if i_idx < length x
      then (o_idx, i_idx)
      else concat_index_split (Suc o_idx, i_idx - length x) xs)"

inductive_set trancl_list for \<R> where
  base[intro, Pure.intro] : "length xs = length ys \<Longrightarrow>
      (\<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>) \<Longrightarrow> (xs, ys) \<in> trancl_list \<R>"
| list_trancl [Pure.intro]: "(xs, ys) \<in> trancl_list \<R> \<Longrightarrow> i < length ys \<Longrightarrow> (ys ! i, z) \<in> \<R> \<Longrightarrow>
    (xs, ys[i := z]) \<in> trancl_list \<R>"

lemma sorted_append_bigger:
  "sorted xs \<Longrightarrow>  \<forall>x \<in> set xs. x \<le> y \<Longrightarrow> sorted (xs @ [y])"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then have s: "sorted xs" by (cases xs) simp_all
  from Cons have a: "\<forall>x\<in>set xs. x \<le> y" by simp
  from Cons(1)[OF s a] Cons(2-) show ?case by (cases xs) simp_all
qed

lemma find_SomeD:
  "List.find P xs = Some x \<Longrightarrow> P x"
  "List.find P xs = Some x \<Longrightarrow> x\<in>set xs"
  by (auto simp add: find_Some_iff)

lemma sum_list_replicate_length' [simp]:
  "sum_list (replicate n (Suc 0)) = n"
  by (induct n) simp_all

lemma arg_subteq [simp]:
  assumes "t \<in> set ts" shows "Fun f ts \<unrhd> t"
  using assms by auto

lemma finite_funas_term: "finite (funas_term s)"
  by (induct s) auto

lemma finite_funas_trs:
  "finite \<R> \<Longrightarrow> finite (funas_trs \<R>)"
  by (induct rule: finite.induct) (auto simp: finite_funas_term funas_trs_def)

fun subterms where
  "subterms (Var x) = {Var x}"|
  "subterms (Fun f ts) = {Fun f ts} \<union> (\<Union> (subterms ` set ts))"

lemma finite_subterms_fun: "finite (subterms s)"
  by (induct s) auto

lemma subterms_supteq_conv: "t \<in> subterms s \<longleftrightarrow> s \<unrhd> t"
  by (induct s) (auto elim: supteq.cases)

lemma set_all_subteq_subterms:
  "subterms s = {t. s \<unrhd> t}"
  using subterms_supteq_conv by auto

lemma finite_subterms: "finite {t. s \<unrhd> t}"
  unfolding set_all_subteq_subterms[symmetric]
  by (simp add: finite_subterms_fun)

lemma finite_strict_subterms: "finite {t. s \<rhd> t}"
  by (intro finite_subset[OF _ finite_subterms]) auto

lemma finite_UN_I2:
  "finite A \<Longrightarrow> (\<forall> B \<in> A. finite B) \<Longrightarrow> finite (\<Union> A)"
  by blast

lemma root_substerms_funas_term:
  "the ` (root ` (subterms s) - {None}) = funas_term s" (is "?Ls = ?Rs")
proof -
  thm subterms.induct
  {fix x assume "x \<in> ?Ls" then have "x \<in> ?Rs"
    proof (induct s arbitrary: x)
      case (Fun f ts)
      then show ?case
        by auto (metis DiffI Fun.hyps imageI option.distinct(1) singletonD)
    qed auto}
  moreover
  {fix g assume "g \<in> ?Rs" then have "g \<in> ?Ls"
    proof (induct s arbitrary: g)
      case (Fun f ts)
      from Fun(2) consider "g = (f, length ts)" | "\<exists> t \<in> set ts. g \<in> funas_term t"
        by (force simp: in_set_conv_nth)
      then show ?case
      proof cases
        case 1 then show ?thesis
          by (auto simp: image_iff intro: bexI[of _ "Some (f, length ts)"])
      next
        case 2
        then obtain t where wit: "t \<in> set ts" "g \<in> funas_term t" by blast
        have "g \<in> the ` (root ` subterms t - {None})" using Fun(1)[OF wit] .
        then show ?thesis using wit(1)
          by (auto simp: image_iff)
      qed
    qed auto}
  ultimately show ?thesis by auto
qed

lemma root_substerms_funas_term_set:
  "the ` (root ` \<Union> (subterms ` R) - {None}) = \<Union> (funas_term ` R)"
  using root_substerms_funas_term
  by auto (smt DiffE DiffI UN_I image_iff)

lemma subst_merge:
  assumes part: "is_partition (map vars_term ts)"
  shows "\<exists>\<sigma>. \<forall>i<length ts. \<forall>x\<in>vars_term (ts ! i). \<sigma> x = \<tau> i x"
proof -
  let ?\<tau> = "map \<tau> [0 ..< length ts]"
  let ?\<sigma> = "fun_merge ?\<tau> (map vars_term ts)"
  show ?thesis
    by (rule exI[of _ ?\<sigma>], intro allI impI ballI,
      insert fun_merge_part[OF part, of _ _ ?\<tau>], auto)
qed

lemma rel_comp_empty_trancl_simp: "R O R = {} \<Longrightarrow> R\<^sup>+ = R"
  by (metis O_assoc relcomp_empty2 sup_bot_right trancl_unfold trancl_unfold_right)

lemma choice_nat:
  assumes "\<forall>i<n. \<exists>x. P x i"
  shows "\<exists>f. \<forall>x<n. P (f x) x" using assms
proof -
  from assms have "\<forall> i. \<exists> x. i < n \<longrightarrow> P x i" by simp
  from choice[OF this] show ?thesis by auto
qed

lemma subseteq_set_conv_nth:
  "(\<forall> i < length ss. ss ! i \<in> T) \<longleftrightarrow> set ss \<subseteq> T"
  by (metis in_set_conv_nth subset_code(1))

lemma singelton_trancl [simp]: "{a}\<^sup>+ = {a}"
  using tranclD tranclD2 by fastforce

context
includes fset.lifting
begin
lemmas frelcomp_empty_ftrancl_simp = rel_comp_empty_trancl_simp [Transfer.transferred]
lemmas in_fset_idx = in_set_idx [Transfer.transferred]
lemmas fsubseteq_fset_conv_nth = subseteq_set_conv_nth [Transfer.transferred]
lemmas singelton_ftrancl [simp] = singelton_trancl [Transfer.transferred]
end

lemma set_take_nth:
  assumes "x \<in> set (take i xs)"
  shows "\<exists> j < length xs. j < i \<and> xs ! j = x" using assms
  by (metis in_set_conv_nth length_take min_less_iff_conj nth_take)

lemma nth_sum_listI:
  assumes "length xs = length ys"
    and "\<forall> i < length xs. xs ! i = ys ! i"
  shows "sum_list xs = sum_list ys"
  using assms nth_equalityI by blast

lemma concat_nth_length:
  "i < length uss \<Longrightarrow> j < length (uss ! i) \<Longrightarrow>
    sum_list (map length (take i uss)) + j < length (concat uss)"
by (induct uss arbitrary: i j) (simp, case_tac i, auto)

lemma sum_list_1_E [elim]:
  assumes "sum_list xs = Suc 0"
  obtains i where "i < length xs" "xs ! i = Suc 0" "\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j = 0"
proof -
  have "\<exists> i < length xs. xs ! i = Suc 0 \<and> (\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j = 0)" using assms
  proof (induct xs)
    case (Cons a xs) show ?case
    proof (cases a)
      case [simp]: 0
      obtain i where "i < length xs" "xs ! i = Suc 0" "(\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j = 0)"
        using Cons by auto
      then show ?thesis using less_Suc_eq_0_disj
        by (intro exI[of _ "Suc i"]) auto
    next
      case (Suc nat) then show ?thesis using Cons by auto
    qed
  qed auto
  then show " (\<And>i. i < length xs \<Longrightarrow> xs ! i = Suc 0 \<Longrightarrow> \<forall>j<length xs. j \<noteq> i \<longrightarrow> xs ! j = 0 \<Longrightarrow> thesis) \<Longrightarrow> thesis"
    by blast
qed

lemma nth_equalityE:
  "xs = ys \<Longrightarrow> (length xs = length ys \<Longrightarrow> (\<And>i. i < length xs \<Longrightarrow> xs ! i = ys ! i) \<Longrightarrow> P) \<Longrightarrow> P"
  by simp

lemma map_cons_presv_distinct:
  "distinct t \<Longrightarrow> distinct (map ((#) i) t)"
  by (simp add: distinct_conv_nth)

lemma concat_nth_nthI:
  assumes "length ss = length ts" "\<forall> i < length ts. length (ss ! i) = length (ts ! i)"
    and "\<forall> i < length ts. \<forall> j < length (ts ! i). P (ss ! i ! j) (ts ! i ! j)"
  shows "\<forall> i < length (concat ts). P (concat ss ! i) (concat ts ! i)"
  using assms by (metis nth_concat_two_lists)

lemma last_nthI:
  assumes "i < length ts" "\<not> i < length ts - Suc 0"
  shows "ts ! i = last ts" using assms
  by (induct ts arbitrary: i)
    (auto, metis last_conv_nth length_0_conv less_antisym nth_Cons')

(* induction scheme for transitive closures of lists *)
lemma trancl_list_appendI [simp, intro]:
  "(xs, ys) \<in> trancl_list \<R> \<Longrightarrow> (x, y) \<in> \<R> \<Longrightarrow> (x # xs, y # ys) \<in> trancl_list \<R>"
proof (induct rule: trancl_list.induct)
  case (base xs ys)
  then show ?case using less_Suc_eq_0_disj
    by (intro trancl_list.base) auto
next
  case (list_trancl xs ys i z)
  from list_trancl(3) have *: "y # ys[i := z] = (y # ys)[Suc i := z]" by auto
  show ?case using list_trancl unfolding *
    by (intro trancl_list.list_trancl) auto
qed

lemma trancl_list_append_tranclI [intro]:
  "(x, y) \<in> \<R>\<^sup>+ \<Longrightarrow> (xs, ys) \<in> trancl_list \<R> \<Longrightarrow> (x # xs, y # ys) \<in> trancl_list \<R>"
proof (induct rule: trancl.induct)
  case (trancl_into_trancl a b c)
  then have "(a # xs, b # ys) \<in> trancl_list \<R>" by auto
  from trancl_list.list_trancl[OF this, of 0 c]
  show ?case using trancl_into_trancl(3)
    by auto
qed auto

lemma trancl_list_conv:
  "(xs, ys) \<in> trancl_list \<R> \<longleftrightarrow> length xs = length ys \<and> (\<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>\<^sup>+)" (is "?Ls \<longleftrightarrow> ?Rs")
proof
  assume "?Ls" then show ?Rs
  proof (induct)
    case (list_trancl xs ys i z)
    then show ?case
      by auto (metis nth_list_update trancl.trancl_into_trancl)
  qed auto
next
  assume ?Rs then show ?Ls
  proof (induct ys arbitrary: xs)
    case Nil
    then show ?case by (cases xs) auto
  next
    case (Cons y ys)
    from Cons(2) obtain x xs' where *: "xs = x # xs'" and
      inv: "(x, y) \<in> \<R>\<^sup>+"
      by (cases xs) auto
    show ?case using Cons(1)[of "tl xs"] Cons(2) unfolding *
      by (intro trancl_list_append_tranclI[OF inv]) force
  qed
qed

lemma trancl_list_induct [consumes 2, case_names base step]:
  assumes "length ss = length ts" "\<forall> i < length ts. (ss ! i, ts ! i) \<in> \<R>\<^sup>+"
   and "\<And>xs ys. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R> \<Longrightarrow> P xs ys"
   and "\<And>xs ys i z. length xs = length ys \<Longrightarrow> \<forall> i < length ys. (xs ! i, ys ! i) \<in> \<R>\<^sup>+ \<Longrightarrow> P xs ys
      \<Longrightarrow> i < length ys \<Longrightarrow> (ys ! i, z) \<in> \<R> \<Longrightarrow> P xs (ys[i := z])"
 shows "P ss ts" using assms
  by (intro trancl_list.induct[of ss ts \<R> P]) (auto simp: trancl_list_conv)

lemma swap_trancl:
  "(prod.swap ` R)\<^sup>+ = prod.swap ` (R\<^sup>+)"
proof -
  have [simp]: "prod.swap ` X = X\<inverse>" for X by auto
  show ?thesis by (simp add: trancl_converse)
qed

lemma swap_rtrancl:
  "(prod.swap ` R)\<^sup>* = prod.swap ` (R\<^sup>*)"
proof -
  have [simp]: "prod.swap ` X = X\<inverse>" for X by auto
  show ?thesis by (simp add: rtrancl_converse)
qed

lemma Restr_simps:
  "R \<subseteq> X \<times> X \<Longrightarrow> Restr (R\<^sup>+) X = R\<^sup>+"
  "R \<subseteq> X \<times> X \<Longrightarrow> Restr Id X O R = R"
  "R \<subseteq> X \<times> X \<Longrightarrow> R O Restr Id X = R"
  "R \<subseteq> X \<times> X \<Longrightarrow> S \<subseteq> X \<times> X \<Longrightarrow> Restr (R O S) X = R O S"
  "R \<subseteq> X \<times> X \<Longrightarrow> R\<^sup>+ \<subseteq> X \<times> X"
  subgoal using trancl_mono_set[of R "X \<times> X"] by (auto simp: trancl_full_on)
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal using trancl_subset_Sigma .
  done

lemma Restr_tracl_comp_simps:
  "\<R> \<subseteq> X \<times> X \<Longrightarrow> \<L> \<subseteq> X \<times> X \<Longrightarrow> \<L>\<^sup>+ O \<R> \<subseteq> X \<times> X"
  "\<R> \<subseteq> X \<times> X \<Longrightarrow> \<L> \<subseteq> X \<times> X \<Longrightarrow> \<L> O \<R>\<^sup>+ \<subseteq> X \<times> X"
  "\<R> \<subseteq> X \<times> X \<Longrightarrow> \<L> \<subseteq> X \<times> X \<Longrightarrow> \<L>\<^sup>+ O \<R> O \<L>\<^sup>+ \<subseteq> X \<times> X"
  by (auto dest: subsetD[OF Restr_simps(5)[of \<L>]] subsetD[OF Restr_simps(5)[of \<R>]])

text \<open>Conversions of the Nth function between lists and a spliting of the list into lists of lists\<close>

lemma concat_index_split_mono_first_arg:
  "i < length (concat xs) \<Longrightarrow> o_idx \<le> fst (concat_index_split (o_idx, i) xs)"
  by (induct xs arbitrary: o_idx i) (auto, metis Suc_leD add_diff_inverse_nat nat_add_left_cancel_less)

lemma concat_index_split_sound_fst_arg_aux:
  "i < length (concat xs) \<Longrightarrow> fst (concat_index_split (o_idx, i) xs) < length xs + o_idx"
  by (induct xs arbitrary: o_idx i) (auto, metis add_Suc_right add_diff_inverse_nat nat_add_left_cancel_less)

lemma concat_index_split_sound_fst_arg:
  "i < length (concat xs) \<Longrightarrow> fst (concat_index_split (0, i) xs) < length xs"
  using concat_index_split_sound_fst_arg_aux[of i xs 0] by auto

lemma concat_index_split_sound_snd_arg_aux:
  assumes "i < length (concat xs)"
  shows "snd (concat_index_split (n, i) xs) < length (xs ! (fst (concat_index_split (n, i) xs) - n))" using assms
proof (induct xs arbitrary: i n)
  case (Cons x xs)
  show ?case proof (cases "i < length x")
    case False then have size: "i - length x < length (concat xs)"
      using Cons(2) False by auto
    obtain k j where [simp]: "concat_index_split (Suc n, i - length x) xs = (k, j)"
      using old.prod.exhaust by blast
    show ?thesis using False Cons(1)[OF size, of "Suc n"] concat_index_split_mono_first_arg[OF size, of "Suc n"]
      by (auto simp: nth_append)
  qed (auto simp add: nth_append)
qed auto

lemma concat_index_split_sound_snd_arg:
  assumes "i < length (concat xs)"
  shows "snd (concat_index_split (0, i) xs) < length (xs ! fst (concat_index_split (0, i) xs))"
  using concat_index_split_sound_snd_arg_aux[OF assms, of 0] by auto

lemma reconstr_1d_concat_index_split:
  assumes "i < length (concat xs)"
  shows "i = (\<lambda> (m, j). sum_list (map length (take (m - n) xs)) + j) (concat_index_split (n, i) xs)" using assms
proof (induct xs arbitrary: i n)
  case (Cons x xs) show ?case
  proof (cases "i < length x")
    case False
    obtain m k where res: "concat_index_split (Suc n, i - length x) xs = (m, k)"
      using prod_decode_aux.cases by blast
    then have unf_ind: "concat_index_split (n, i) (x # xs) = concat_index_split (Suc n, i - length x) xs" and
      size: "i - length x < length (concat xs)" using Cons(2) False by auto
    have "Suc n \<le> m" using concat_index_split_mono_first_arg[OF size, of "Suc n"] by (auto simp: res)
    then have [simp]: "sum_list (map length (take (m - n) (x # xs))) = sum_list (map length (take (m - Suc n) xs)) + length x"
      by (simp add: take_Cons')
    show ?thesis using Cons(1)[OF size, of "Suc n"] False unfolding unf_ind res by auto
  qed auto
qed auto

lemma concat_index_split_larger_lists [simp]:
  assumes "i < length (concat xs)"
  shows "concat_index_split (n, i) (xs @ ys) = concat_index_split (n, i) xs" using assms
  by (induct xs arbitrary: ys n i) auto

lemma concat_index_split_split_sound_aux:
  assumes "i < length (concat xs)"
  shows "concat xs ! i = (\<lambda> (k, j). xs ! (k - n) ! j) (concat_index_split (n, i) xs)" using assms
proof (induct xs arbitrary: i n)
  case (Cons x xs)
  show ?case proof (cases "i < length x")
    case False then have size: "i - length x < length (concat xs)"
      using Cons(2) False by auto
    obtain k j where [simp]: "concat_index_split (Suc n, i - length x) xs = (k, j)"
      using prod_decode_aux.cases by blast
    show ?thesis using False Cons(1)[OF size, of "Suc n"]
      using concat_index_split_mono_first_arg[OF size, of "Suc n"]
      by (auto simp: nth_append)
  qed (auto simp add: nth_append)
qed auto

lemma concat_index_split_sound:
  assumes "i < length (concat xs)"
  shows "concat xs ! i = (\<lambda> (k, j). xs ! k ! j) (concat_index_split (0, i) xs)"
  using concat_index_split_split_sound_aux[OF assms, of 0] by auto

lemma concat_index_split_sound_bounds:
  assumes "i < length (concat xs)" and "concat_index_split (0, i) xs = (m, n)"
  shows "m < length xs" "n < length (xs ! m)"
  using concat_index_split_sound_fst_arg[OF assms(1)] concat_index_split_sound_snd_arg[OF assms(1)]
  by (auto simp: assms(2))

lemma concat_index_split_less_length_concat:
  assumes "i < length (concat xs)" and "concat_index_split (0, i) xs = (m, n)"
  shows "i = sum_list (map length (take m xs)) + n" "m < length xs" "n < length (xs ! m)"
    "concat xs ! i = xs ! m ! n"
  using concat_index_split_sound[OF assms(1)] reconstr_1d_concat_index_split[OF assms(1), of 0]
  using concat_index_split_sound_fst_arg[OF assms(1)] concat_index_split_sound_snd_arg[OF assms(1)] assms(2)
  by auto

lemma nth_concat_split':
  assumes "i < length (concat xs)"
  obtains j k where "j < length xs" "k < length (xs ! j)" "concat xs ! i = xs ! j ! k" "i = sum_list (map length (take j xs)) + k"
  using concat_index_split_less_length_concat[OF assms]
  by (meson old.prod.exhaust)

lemma sum_list_split [dest!, consumes 1]:
  assumes "sum_list (map length (take i xs)) + j = sum_list (map length (take k xs)) + l"
   and "i < length xs" "k < length xs"
   and "j < length (xs ! i)" "l < length (xs ! k)"
 shows "i = k \<and> j = l" using assms
proof (induct xs rule: rev_induct)
  case (snoc x xs)
  then show ?case
    by (auto simp: nth_append split: if_splits)
       (metis concat_nth_length length_concat not_add_less1)+
qed auto

lemma concat_index_split_unique:
  assumes "i < length (concat xs)" and "length xs = length ys"
    and "\<forall> i < length xs. length (xs ! i) = length (ys ! i)"
  shows "concat_index_split (n, i) xs = concat_index_split (n, i) ys" using assms
proof (induct xs arbitrary: ys n i)
  case (Cons x xs) note IH = this show ?case
  proof (cases ys)
    case Nil then show ?thesis using Cons(3) by auto
  next
    case [simp]: (Cons y ys')
    have [simp]: "length y = length x" using IH(4) by force
    have [simp]: "\<not> i < length x \<Longrightarrow> i - length x < length (concat xs)" using IH(2) by auto
    have [simp]: "i < length ys' \<Longrightarrow> length (xs ! i) = length (ys' ! i)" for i using IH(3, 4)
      by (auto simp: All_less_Suc) (metis IH(4) Suc_less_eq length_Cons Cons nth_Cons_Suc)
    show ?thesis using IH(2-) IH(1)[of "i - length x" ys' "Suc n"] by auto
  qed
qed auto

lemma set_vars_term_list [simp]:
  "set (vars_term_list t) = vars_term t"
  by (induct t) simp_all

lemma vars_term_list_empty_ground [simp]:
  "vars_term_list t = [] \<longleftrightarrow> ground t"
  by (induct t) auto

lemma varposs_imp_poss:
  assumes "p \<in> varposs t"
  shows "p \<in> poss t"
  using assms by (induct t arbitrary: p) auto

lemma vaposs_list_fun:
  assumes "p \<in> set (varposs_list (Fun f ts))"
  obtains i ps where "i < length ts" "p = i # ps"
  using assms set_zip_leftD by fastforce

lemma varposs_list_distinct:
  "distinct (varposs_list t)"
proof (induct t)
  case (Fun f ts)
  then show ?case proof (induct ts rule: rev_induct)
    case (snoc x xs)
    then have "distinct (varposs_list (Fun f xs))" "distinct (varposs_list x)" by auto
    then show ?case using snoc by (auto simp add: map_cons_presv_distinct dest: set_zip_leftD)
  qed auto
qed auto

lemma varposs_append:
  "varposs (Fun f (ts @ [t])) = varposs (Fun f ts) \<union> ((#) (length ts)) ` varposs t"
  by (auto simp: nth_append split: if_splits)

lemma varposs_eq_varposs_list:
  "set (varposs_list t) = varposs t"
proof (induct t)
  case (Fun f ts)
  then show ?case proof (induct ts rule: rev_induct)
    case (snoc x xs)
    then have "varposs (Fun f xs) = set (varposs_list (Fun f xs))"
      "varposs x = set (varposs_list x)" by auto
    then show ?case using snoc unfolding varposs_append
      by auto
  qed auto
qed auto

lemma varposs_list_var_terms_length:
  "length (varposs_list t) = length (vars_term_list t)"
  by (induct t) (auto simp: vars_term_list.simps intro: eq_length_concat_nth)

lemma vars_term_list_nth:
  assumes "i < length (vars_term_list (Fun f ts))"
    and "concat_index_split (0, i) (map vars_term_list ts) = (k, j)"
  shows "k < length ts \<and> j < length (vars_term_list (ts ! k)) \<and>
    vars_term_list (Fun f ts) ! i = map vars_term_list ts ! k ! j \<and>
    i = sum_list (map length (map vars_term_list (take k ts))) + j"
  using assms concat_index_split_less_length_concat[of i "map vars_term_list ts" k j]
  by (auto simp: vars_term_list.simps comp_def take_map)

lemma varposs_list_nth:
  assumes "i < length (varposs_list (Fun f ts))"
     and "concat_index_split (0, i) (poss_args varposs_list ts) = (k, j)"
  shows "k < length ts \<and> j < length (varposs_list (ts ! k)) \<and>
    varposs_list (Fun f ts) ! i = k # (map varposs_list ts) ! k ! j \<and>
    i = sum_list (map length (map varposs_list (take k ts))) + j"
  using assms concat_index_split_less_length_concat[of i "poss_args varposs_list ts" k j]
  by (auto simp: comp_def take_map intro: nth_sum_listI)

lemma varposs_list_to_var_term_list:
  assumes "i < length (varposs_list t)"
  shows "the_Var (t |_ (varposs_list t ! i)) = (vars_term_list t) ! i" using assms
proof (induct t arbitrary: i)
  case (Fun f ts)
  have "concat_index_split (0, i) (poss_args varposs_list ts) = concat_index_split (0, i) (map vars_term_list ts)"
    using Fun(2) concat_index_split_unique[of i "poss_args varposs_list ts" "map vars_term_list ts" 0]
    using varposs_list_var_terms_length[of "ts ! i" for i]
    by (auto simp: vars_term_list.simps)
  then obtain k j where "concat_index_split (0, i) (poss_args varposs_list ts) = (k, j)"
    "concat_index_split (0, i) (map vars_term_list ts) = (k, j)" by fastforce
  from varposs_list_nth[OF Fun(2) this(1)] vars_term_list_nth[OF _ this(2)]
  show ?case using Fun(2) Fun(1)[OF nth_mem] varposs_list_var_terms_length[of "Fun f ts"] by auto
qed (auto simp: vars_term_list.simps)

end