section \<open>More on Terms\<close>

theory Terms imports Transition_QuasiTerms_Terms
begin

text\<open>In this section, we continue the study of terms, with stating and proving
properties specific to terms (while in the previous section we dealt with
lifting properties from quasi-terms).
Consequently, in this theory, not only the theorems, but neither the proofs
should mention quasi-items at all.
Among the properties specific to terms will
be the compositionality properties of substitution (while, by contrast, similar properties
of swapping also held for quasi-tems).
\<close>

context FixVars (* scope all throughout the file *)
begin

declare qItem_simps[simp del]
declare qItem_versus_item_simps[simp del]

subsection \<open>Identity environment versus other operators\<close>

(* Recall theorem getEnv_idEnv. *)

theorem getEnv_updEnv_idEnv[simp]:
"(idEnv [x \<leftarrow> X]_xs) ys y = (if (ys = xs \<and> y = x) then Some X else None)"
unfolding idEnv_def updEnv_def by simp

theorem subst_psubst_idEnv:
"(X #[Y / y]_ys) = (X #[idEnv [y \<leftarrow> Y]_ys])"
unfolding subst_def idEnv_def updEnv_def psubst_def by simp

theorem vsubst_psubst_idEnv:
"(X #[z // y]_ys) = (X #[idEnv [y \<leftarrow> Var ys z]_ys])"
unfolding vsubst_def by(simp add: subst_psubst_idEnv)

theorem substEnv_psubstEnv_idEnv:
"(rho &[Y / y]_ys) = (rho &[idEnv [y \<leftarrow> Y]_ys])"
unfolding substEnv_def idEnv_def updEnv_def psubstEnv_def by simp

theorem vsubstEnv_psubstEnv_idEnv:
"(rho &[z // y]_ys) = (rho &[idEnv [y \<leftarrow> Var ys z]_ys])"
unfolding vsubstEnv_def by (simp add: substEnv_psubstEnv_idEnv)

theorem freshEnv_idEnv: "freshEnv xs x idEnv"
unfolding idEnv_def freshEnv_def liftAll_def by simp

theorem swapEnv_idEnv[simp]: "(idEnv &[x \<and> y]_xs) = idEnv"
unfolding idEnv_def swapEnv_def comp_def swapEnvDom_def swapEnvIm_def lift_def by simp

theorem psubstEnv_idEnv[simp]: "(idEnv &[rho]) = rho"
unfolding idEnv_def psubstEnv_def lift_def by simp

theorem substEnv_idEnv: "(idEnv &[X / x]_xs) = (idEnv [x \<leftarrow> X]_xs)"
unfolding substEnv_def using psubstEnv_idEnv by auto

theorem vsubstEnv_idEnv: "(idEnv &[y // x]_xs) = (idEnv [x \<leftarrow> (Var xs y)]_xs)"
unfolding vsubstEnv_def using substEnv_idEnv .

lemma psubstAll_idEnv:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs"
shows
"(good X  \<longrightarrow> (X #[idEnv]) = X) \<and>
 (goodAbs A  \<longrightarrow> (A $[idEnv]) = A)"
apply(induct rule: term_rawInduct)
unfolding psubstInp_def psubstBinp_def
using idEnv_preserves_good psubst_Var_simp1
by (simp_all del: getEnv_idEnv add:
liftAll_lift_ext lift_ident freshEnv_idEnv psubstBinp_def psubstInp_def)
  fastforce+

lemma psubst_idEnv[simp]:
"good X \<Longrightarrow> (X #[idEnv]) = X"
by(simp add: psubstAll_idEnv)

lemma psubstEnv_idEnv_id[simp]:
assumes "goodEnv rho"
shows "(rho &[idEnv]) = rho"
using assms unfolding psubstEnv_def lift_def goodEnv_def liftAll_def
apply(intro ext) subgoal for xs x by(cases "rho xs x") auto .

subsection \<open>Environment update versus other operators\<close>

(* Recall theorem getEnv_updEnv. *)

theorem updEnv_overwrite[simp]: "((rho [x \<leftarrow> X]_xs) [x \<leftarrow> X']_xs) = (rho [x \<leftarrow> X']_xs)"
unfolding updEnv_def by fastforce

theorem updEnv_commute:
assumes "xs \<noteq> ys \<or> x \<noteq> y"
shows "((rho [x \<leftarrow> X]_xs) [y \<leftarrow> Y]_ys) = ((rho [y \<leftarrow> Y]_ys) [x \<leftarrow> X]_xs)"
using assms unfolding updEnv_def by fastforce

theorem freshEnv_updEnv_E1:
assumes "freshEnv xs y (rho [x \<leftarrow> X]_xs)"
shows "y \<noteq> x"
using assms unfolding freshEnv_def liftAll_def updEnv_def by auto

theorem freshEnv_updEnv_E2:
assumes "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
shows "fresh ys y X"
using assms unfolding freshEnv_def liftAll_def updEnv_def
by (auto split: if_splits)

theorem freshEnv_updEnv_E3:
assumes "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
shows "rho ys y = None"
using assms freshEnv_updEnv_E1[of ys y] unfolding freshEnv_def
by (metis getEnv_updEnv option.simps(3))

theorem freshEnv_updEnv_E4:
assumes "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
and "zs \<noteq> xs \<or> z \<noteq> x" and "rho zs z = Some Z"
shows "fresh ys y Z"
using assms unfolding freshEnv_def liftAll_def
by (metis getEnv_updEnv1)

theorem freshEnv_updEnv_I:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "fresh ys y X" and "rho ys y = None"
and "\<And> zs z Z. \<lbrakk>zs \<noteq> xs \<or> z \<noteq> x; rho zs z = Some Z\<rbrakk> \<Longrightarrow> fresh ys y Z"
shows "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
unfolding freshEnv_def liftAll_def
using assms by auto

theorem swapEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[y1 \<and> y2]_ys) =
 ((rho &[y1 \<and> y2]_ys) [(x @xs[y1 \<and> y2]_ys) \<leftarrow> (X #[y1 \<and> y2]_ys)]_xs)"
unfolding swapEnv_defs sw_def lift_def
by(cases "xs = ys") fastforce+

lemma swapEnv_updEnv_fresh:
assumes "ys \<noteq> xs \<or> x \<notin> {y1,y2}" and "good X"
and "fresh ys y1 X" and "fresh ys y2 X"
shows "((rho [x \<leftarrow> X]_xs) &[y1 \<and> y2]_ys) =
       ((rho &[y1 \<and> y2]_ys) [x \<leftarrow> X]_xs)"
using assms by(simp add: swapEnv_updEnv)

theorem psubstEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[rho']) = ((rho &[rho']) [x \<leftarrow> (X #[rho'])]_xs)"
unfolding psubstEnv_def by fastforce

theorem psubstEnv_updEnv_idEnv:
"((idEnv [x \<leftarrow> X]_xs) &[rho]) = (rho [x \<leftarrow> (X #[rho])]_xs)"
by(simp add: psubstEnv_updEnv)

theorem substEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x \<leftarrow> (X #[Y / y]_ys)]_xs)"
unfolding substEnv_def subst_def by(rule psubstEnv_updEnv)

theorem vsubstEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x \<leftarrow> (X #[y1 // y]_ys)]_xs)"
unfolding vsubstEnv_def vsubst_def using substEnv_updEnv .

subsection \<open>Environment ``get" versus other operators\<close>

text\<open>Currently, ``get" is just function application.  While the next
properties are immediate consequences of the definitions, it is worth stating
them because of their abstract character (since later, concrete terms
inferred from abstract terms by a presumptive package, ``get" will no longer
be function application).\<close>

theorem getEnv_ext:
assumes "\<And> xs x. rho xs x = rho' xs x"
shows "rho = rho'"
using assms by(simp add: ext)

theorem freshEnv_getEnv1[simp]:
"\<lbrakk>freshEnv ys y rho; rho xs x = Some X\<rbrakk> \<Longrightarrow> ys \<noteq> xs \<or> y \<noteq> x"
unfolding freshEnv_def by auto

theorem freshEnv_getEnv2[simp]:
"\<lbrakk>freshEnv ys y rho; rho xs x = Some X\<rbrakk> \<Longrightarrow> fresh ys y X"
unfolding freshEnv_def liftAll_def by simp

theorem freshEnv_getEnv[simp]:
"freshEnv ys y rho \<Longrightarrow> rho ys y = None"
unfolding freshEnv_def by simp

theorem getEnv_swapEnv1[simp]:
assumes "rho xs (x @xs [z1 \<and> z2]_zs) = None"
shows "(rho &[z1 \<and> z2]_zs) xs x = None"
using assms unfolding swapEnv_defs lift_def by simp

theorem getEnv_swapEnv2[simp]:
assumes "rho xs (x @xs [z1 \<and> z2]_zs) = Some X"
shows "(rho &[z1 \<and> z2]_zs) xs x = Some (X #[z1 \<and> z2]_zs)"
using assms unfolding swapEnv_defs lift_def by simp

theorem getEnv_psubstEnv_None[simp]:
assumes "rho xs x = None"
shows "(rho &[rho']) xs x = rho' xs x"
using assms unfolding psubstEnv_def by simp

theorem getEnv_psubstEnv_Some[simp]:
assumes "rho xs x = Some X"
shows "(rho &[rho']) xs x = Some (X #[rho'])"
using assms unfolding psubstEnv_def by simp

theorem getEnv_substEnv1[simp]:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "rho xs x = None"
shows "(rho &[Y / y]_ys) xs x = None"
using assms unfolding substEnv_def2 by auto

theorem getEnv_substEnv2[simp]:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "rho xs x = Some X"
shows "(rho &[Y / y]_ys) xs x = Some (X #[Y / y]_ys)"
using assms unfolding substEnv_def2 by auto

theorem getEnv_substEnv3[simp]:
"\<lbrakk>ys \<noteq> xs \<or> y \<noteq> x; freshEnv xs x rho\<rbrakk>
 \<Longrightarrow> (rho &[Y / y]_ys) xs x = None"
using getEnv_substEnv1 by auto

theorem getEnv_substEnv4[simp]:
"freshEnv ys y rho \<Longrightarrow> (rho &[Y / y]_ys) ys y = Some Y"
unfolding substEnv_psubstEnv_idEnv by simp

theorem getEnv_vsubstEnv2[simp]:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "rho xs x = Some X"
shows "(rho &[y1 // y]_ys) xs x = Some (X #[y1 // y]_ys)"
using assms unfolding vsubstEnv_def vsubst_def by auto

theorem getEnv_vsubstEnv3[simp]:
"\<lbrakk>ys \<noteq> xs \<or> y \<noteq> x; freshEnv xs x rho\<rbrakk>
 \<Longrightarrow> (rho &[z // y]_ys) xs x = None"
using getEnv_vsubstEnv1 by auto

theorem getEnv_vsubstEnv4[simp]:
"freshEnv ys y rho \<Longrightarrow> (rho &[z // y]_ys) ys y = Some (Var ys z)"
unfolding vsubstEnv_psubstEnv_idEnv by simp

subsection \<open>Substitution versus other operators\<close>

definition freshImEnvAt ::
"'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)env \<Rightarrow> 'varSort \<Rightarrow> 'var \<Rightarrow> bool"
where
"freshImEnvAt xs x rho ys y ==
 rho ys y = None \<and> (ys \<noteq> xs \<or> y \<noteq> x) \<or>
 (\<exists> Y. rho ys y = Some Y \<and> fresh xs x Y)"

lemma freshAll_psubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and x
assumes goodP: "goodPar P"
shows
"(good X \<longrightarrow> z \<in> varsOf P \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
     fresh zs z (X #[rho]) =
     (\<forall> ys. \<forall> y. fresh ys y X \<or> freshImEnvAt zs z rho ys y)))
 \<and>
 (goodAbs A \<longrightarrow> z \<in> varsOf P \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
     freshAbs zs z (A $[rho]) =
     (\<forall> ys. \<forall> y. freshAbs ys y A \<or> freshImEnvAt zs z rho ys y)))"
proof(induction rule: term_induct_fresh[of P])
  case Par
  then show ?case using goodP by simp
next
  case (Var ys y)
  thus ?case proof clarify
    fix rho
    assume r: "rho \<in> envsOf P"
    hence g: "goodEnv rho" using goodP by simp
    thus "fresh zs z (psubst rho (Var ys y)) =
     (\<forall>ysa ya. fresh ysa ya (Var ys y) \<or> freshImEnvAt zs z rho ysa ya)"
    unfolding freshImEnvAt_def
    by(cases "ys = zs \<and> y = z", (cases "rho ys y", auto)+)
  qed
next
  case (Op delta inp binp)
  show ?case proof clarify
    fix rho
    assume P: "z \<in> varsOf P" "rho \<in> envsOf P"
    let ?L1 = "liftAll (fresh zs z \<circ> psubst rho) inp"
    let ?L2 = "liftAll (freshAbs zs z \<circ> psubstAbs rho) binp"
    let ?R1 = "%ys y. liftAll (fresh ys y) inp"
    let ?R2 = "%ys y. liftAll (freshAbs ys y) binp"
    let ?R3 = "%ys y. freshImEnvAt zs z rho ys y"
    have "(?L1 \<and> ?L2) = (\<forall>ys y. ?R1 ys y \<and> ?R2 ys y \<or> ?R3 ys y)"
    using Op.IH P unfolding liftAll_def by simp blast
    thus "fresh zs z ((Op delta inp binp) #[rho]) =
           (\<forall>ys y. fresh ys y (Op delta inp binp) \<or> freshImEnvAt zs z rho ys y)"
    by (metis (no_types, lifting) Op.hyps(1) Op.hyps(2) P(2) envsOf_preserves_good freshBinp_def freshInp_def fresh_Op_simp goodP liftAll_lift_comp psubstBinp_def psubstBinp_preserves_good
     psubstInp_def psubstInp_preserves_good psubst_Op_simp)
  qed
next
  case (Abs xs x X)
  thus ?case
  using goodP by simp (metis (full_types) freshEnv_def freshImEnvAt_def)
qed

corollary fresh_psubst:
assumes "good X" and "goodEnv rho"
shows
"fresh zs z (X #[rho]) =
 (\<forall> ys y. fresh ys y X \<or> freshImEnvAt zs z rho ys y)"
using assms freshAll_psubstAll[of "Par [z] [] [] [rho]"]
unfolding goodPar_def by simp

corollary fresh_psubst_E1:
assumes "good X" and "goodEnv rho"
and "rho ys y = None" and "fresh zs z (X #[rho])"
shows "fresh ys y X \<or> (ys \<noteq> zs \<or> y \<noteq> z)"
using assms fresh_psubst unfolding freshImEnvAt_def by fastforce

corollary fresh_psubst_E2:
assumes "good X" and "goodEnv rho"
and "rho ys y = Some Y" and "fresh zs z (X #[rho])"
shows "fresh ys y X \<or> fresh zs z Y"
using assms fresh_psubst[of X rho] unfolding freshImEnvAt_def by fastforce

corollary fresh_psubst_I1:
assumes "good X" and "goodEnv rho"
and "fresh zs z X" and "freshEnv zs z rho"
shows "fresh zs z (X #[rho])"
using assms apply(simp add: fresh_psubst)
unfolding freshEnv_def liftAll_def freshImEnvAt_def by auto

corollary psubstEnv_preserves_freshEnv:
assumes good: "goodEnv rho"  "goodEnv rho'"
and fresh: "freshEnv zs z rho"  "freshEnv zs z rho'"
shows "freshEnv zs z (rho &[rho'])"
using assms unfolding freshEnv_def liftAll_def
by simp (smt Var_preserves_good fresh(2) fresh_psubst_I1 option.case_eq_if
option.exhaust_sel option.sel psubstEnv_def psubst_Var_simp2 psubst_preserves_good)

corollary fresh_psubst_I:
assumes "good X" and "goodEnv rho"
and "rho zs z = None \<Longrightarrow> fresh zs z X" and
    "\<And> ys y Y. rho ys y = Some Y \<Longrightarrow> fresh ys y X \<or> fresh zs z Y"
shows "fresh zs z (X #[rho])"
using assms unfolding freshImEnvAt_def
by (simp add: fresh_psubst) (metis freshImEnvAt_def not_None_eq)

lemma fresh_subst:
assumes "good X" and "good Y"
shows "fresh zs z (X #[Y / y]_ys) =
       (((zs = ys \<and> z = y) \<or> fresh zs z X) \<and> (fresh ys y X \<or> fresh zs z Y))"
using assms unfolding subst_def freshImEnvAt_def
by (simp add: fresh_psubst)
(metis (no_types, lifting) freshImEnvAt_def fresh_psubst fresh_psubst_E2
getEnv_updEnv_idEnv idEnv_preserves_good option.simps(3) updEnv_preserves_good)

lemma fresh_vsubst:
assumes "good X"
shows "fresh zs z (X #[y1 // y]_ys) =
       (((zs = ys \<and> z = y) \<or> fresh zs z X) \<and> (fresh ys y X \<or> (zs \<noteq> ys \<or> z \<noteq> y1)))"
unfolding vsubst_def using assms by(auto simp: fresh_subst)

lemma subst_preserves_fresh:
assumes "good X" and "good Y"
and "fresh zs z X" and "fresh zs z Y"
shows "fresh zs z (X #[Y / y]_ys)"
using assms by(simp add: fresh_subst)

lemma substEnv_preserves_freshEnv_aux:
assumes rho: "goodEnv rho" and Y: "good Y"
and fresh_rho: "freshEnv zs z rho" and fresh_Y: "fresh zs z Y" and diff: "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms unfolding freshEnv_def liftAll_def
by (simp add: option.case_eq_if substEnv_def2 subst_preserves_fresh)

lemma substEnv_preserves_freshEnv:
assumes rho: "goodEnv rho" and Y: "good Y"
and fresh_rho: "freshEnv zs z rho" and fresh_Y: "fresh zs z Y" and diff: "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms by(simp add: substEnv_preserves_freshEnv_aux)

lemma vsubst_preserves_fresh:
assumes "good X"
and "fresh zs z X" and "zs \<noteq> ys \<or> z \<noteq> y1"
shows "fresh zs z (X #[y1 // y]_ys)"
using assms by(simp add: fresh_vsubst)

lemma vsubstEnv_preserves_freshEnv:
assumes rho: "goodEnv rho"
and fresh_rho: "freshEnv zs z rho" and diff: "zs \<noteq> ys \<or> z \<notin> {y,y1}"
shows "freshEnv zs z (rho &[y1 // y]_ys)"
using assms unfolding vsubstEnv_def
by(simp add: substEnv_preserves_freshEnv)

lemma fresh_fresh_subst[simp]:
assumes "good Y" and "good X"
and "fresh ys y Y"
shows "fresh ys y (X #[Y / y]_ys)"
using assms by(simp add: fresh_subst)

lemma diff_fresh_vsubst[simp]:
assumes "good X"
and "y \<noteq> y1"
shows "fresh ys y (X #[y1 // y]_ys)"
using assms by(simp add: fresh_vsubst)

lemma fresh_subst_E1:
assumes "good X" and "good Y"
and "fresh zs z (X #[Y / y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "fresh zs z X"
using assms by(auto simp add: fresh_subst)

lemma fresh_vsubst_E1:
assumes "good X"
and "fresh zs z (X #[y1 // y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "fresh zs z X"
using assms by(auto simp add: fresh_vsubst)

lemma fresh_subst_E2:
assumes "good X" and "good Y"
and "fresh zs z (X #[Y / y]_ys)"
shows "fresh ys y X \<or> fresh zs z Y"
using assms by(simp add: fresh_subst)

lemma fresh_vsubst_E2:
assumes "good X"
and "fresh zs z (X #[y1 // y]_ys)"
shows "fresh ys y X \<or> zs \<noteq> ys \<or> z \<noteq> y1"
using assms by(simp add: fresh_vsubst)

lemma psubstAll_cong:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes goodP: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho rho'. {rho, rho'} \<subseteq> envsOf P \<longrightarrow>
   (\<forall> ys. \<forall> y. fresh ys y X \<or> rho ys y = rho' ys y) \<longrightarrow>
               (X #[rho]) = (X #[rho'])))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho rho'. {rho, rho'} \<subseteq> envsOf P \<longrightarrow>
   (\<forall> ys. \<forall> y. freshAbs ys y A \<or> rho ys y = rho' ys y) \<longrightarrow>
               (A $[rho]) = (A $[rho'])))"
proof(induction rule: term_induct_fresh[of P])
  case Par
  then show ?case using assms .
next
  case (Var xs x)
  then show ?case using goodP by (auto simp: psubst_Var)
next
  case (Op delta inp binp)
  show ?case proof clarify
    fix rho rho'
    assume envs: "{rho, rho'} \<subseteq> envsOf P"
    hence goodEnv: "goodEnv rho \<and> goodEnv rho'" using goodP by simp
    assume "\<forall>ys y. fresh ys y (Op delta inp binp) \<or> rho ys y = rho' ys y"
    hence 1: "liftAll (\<lambda> X. \<forall>ys y. fresh ys y X \<or> rho ys y = rho' ys y) inp \<and>
            liftAll (\<lambda> A. \<forall>ys y. freshAbs ys y A \<or> rho ys y = rho' ys y) binp"
    using Op by simp (smt freshBinp_def freshInp_def liftAll_def)
    have "liftAll (\<lambda> X. (X #[rho]) = (X #[rho'])) inp \<and>
          liftAll (\<lambda> A. (A $[rho]) = (A $[rho'])) binp"
    using Op.IH 1 envs by (auto simp: liftAll_def)
    thus "(Op delta inp binp) #[rho] = (Op delta inp binp) #[rho']"
    using Op.IH 1
    by (simp add: Op.hyps goodEnv psubstBinp_def psubstInp_def liftAll_lift_ext)
  qed
next
  case (Abs xs x X)
  thus ?case
  using Abs goodP unfolding freshEnv_def liftAll_def
  by simp (metis Abs.hyps(5) envsOf_preserves_good psubstAbs_simp)
qed

corollary psubst_cong[fundef_cong]:
assumes "good X" and "goodEnv rho" and "goodEnv rho'"
and "\<And> ys y. fresh ys y X \<or> rho ys y = rho' ys y"
shows "(X #[rho]) = (X #[rho'])"
using assms psubstAll_cong[of "Par [] [] [] [rho,rho']"]
unfolding goodPar_def by simp

(* Note: A congruence principle for ``psubstEnv" would not hold w.r.t. ``freshEnv",
and the one that would hold w.r.t. ``fresh" would be a mere rephrasing of the
definition of ``psubstEnv", not worth stating. *)

lemma fresh_psubst_updEnv:
assumes "good X" and "good Y" and "goodEnv rho"
and "fresh xs x Y"
shows "(Y #[rho [x \<leftarrow> X]_xs]) = (Y #[rho])"
using assms by (auto cong: psubst_cong)

lemma psubstAll_ident:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term" and
      A :: "('index,'bindex,'varSort,'var,'opSym)abs" and
      P :: "('index,'bindex,'varSort,'var,'opSym) Transition_QuasiTerms_Terms.param"
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
   (\<forall> zs z. freshEnv zs z rho \<or> fresh zs z X)
   \<longrightarrow> (X #[rho]) = X))
 \<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
   (\<forall> zs z. freshEnv zs z rho \<or> freshAbs zs z A)
   \<longrightarrow> (A $[rho]) = A))"
proof(induction rule: term_induct_fresh)
  case (Var xs x)
  then show ?case
  by (meson assms freshEnv_def fresh_Var_simp goodPar_def psubst_Var_simp1)
next
  case (Op delta inp binp)
  then show ?case
  by (metis (no_types,lifting) Op_preserves_good assms envsOf_preserves_good
   freshEnv_getEnv idEnv_def idEnv_preserves_good psubst_cong psubst_idEnv)
qed(insert P, fastforce+)

corollary freshEnv_psubst_ident[simp]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term"
assumes "good X" and "goodEnv rho"
and "\<And> zs z. freshEnv zs z rho \<or> fresh zs z X"
shows "(X #[rho]) = X"
using assms psubstAll_ident[of "Par [] [] [] [rho]"]
unfolding goodPar_def by simp

lemma fresh_subst_ident[simp]:
assumes "good X" and "good Y" and "fresh xs x Y"
shows "(Y #[X / x]_xs) = Y"
by (simp add: assms fresh_psubst_updEnv subst_def)

corollary substEnv_updEnv_fresh:
assumes "good X" and "good Y" and "fresh ys y X"
shows "((rho [x \<leftarrow> X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x \<leftarrow> X]_xs)"
using assms by(simp add: substEnv_updEnv)

lemma fresh_substEnv_updEnv[simp]:
assumes rho: "goodEnv rho" and Y: "good Y"
and *: "freshEnv ys y rho"
shows "(rho &[Y / y]_ys) = (rho [y \<leftarrow> Y]_ys)"
apply (rule getEnv_ext)
subgoal for xs x using assms by (cases "rho xs x") auto .

lemma fresh_vsubst_ident[simp]:
assumes "good Y" and "fresh xs x Y"
shows "(Y #[x1 // x]_xs) = Y"
using assms unfolding vsubst_def by simp

corollary vsubstEnv_updEnv_fresh:
assumes "good X" and "fresh ys y X"
shows "((rho [x \<leftarrow> X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x \<leftarrow> X]_xs)"
using assms by(simp add: vsubstEnv_updEnv)

lemma fresh_vsubstEnv_updEnv[simp]:
assumes rho: "goodEnv rho"
and *: "freshEnv ys y rho"
shows "(rho &[y1 // y]_ys) = (rho [y \<leftarrow> Var ys y1]_ys)"
using assms unfolding vsubstEnv_def by simp

lemma swapAll_psubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho z1 z2. rho \<in> envsOf P \<and> {z1,z2} \<subseteq> varsOf P \<longrightarrow>
                ((X #[rho]) #[z1 \<and> z2]_zs) = ((X #[z1 \<and> z2]_zs) #[rho &[z1 \<and> z2]_zs])))
 \<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho z1 z2. rho \<in> envsOf P \<and> {z1,z2} \<subseteq> varsOf P \<longrightarrow>
                ((A $[rho]) $[z1 \<and> z2]_zs) = ((A $[z1 \<and> z2]_zs) $[rho &[z1 \<and> z2]_zs])))"
proof(induction rule: term_induct_fresh[of P])
  case (Var xs x)
  then show ?case using assms
  by simp (smt Var_preserves_good envsOf_preserves_good getEnv_swapEnv1 getEnv_swapEnv2 option.case_eq_if option.exhaust_sel psubst_Var psubst_Var_simp2 swapEnv_preserves_good
 swap_Var_simp swap_involutive2 swap_sym)
next
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding psubstInp_def swapInp_def psubstBinp_def swapBinp_def lift_comp
  unfolding liftAll_def lift_def
  by simp (auto simp: lift_def psubstInp_def swapInp_def
  psubstBinp_def swapBinp_def split: option.splits)
qed(insert assms, auto)

lemma swap_psubst:
assumes "good X" and "goodEnv rho"
shows "((X #[rho]) #[z1 \<and> z2]_zs) = ((X #[z1 \<and> z2]_zs) #[rho &[z1 \<and> z2]_zs])"
using assms swapAll_psubstAll[of "Par [z1,z2] [] [] [rho]"]
unfolding goodPar_def by auto

lemma swap_subst:
assumes "good X" and "good Y"
shows "((X #[Y / y]_ys) #[z1 \<and> z2]_zs) =
       ((X #[z1 \<and> z2]_zs) #[(Y #[z1 \<and> z2]_zs) / (y @ys[z1 \<and> z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1 \<and> z2]_zs) \<leftarrow> (Y #[z1 \<and> z2]_zs)]_ys) =
           ((idEnv [y \<leftarrow> Y]_ys) &[z1 \<and> z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  using assms unfolding subst_def 1 by (intro swap_psubst) auto
qed

lemma swap_vsubst:
assumes "good X"
shows "((X #[y1 // y]_ys) #[z1 \<and> z2]_zs) =
       ((X #[z1 \<and> z2]_zs) #[(y1 @ys[z1 \<and> z2]_zs) // (y @ys[z1 \<and> z2]_zs)]_ys)"
using assms unfolding vsubst_def
by(simp add: swap_subst)

lemma swapEnv_psubstEnv:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[rho']) &[z1 \<and> z2]_zs) = ((rho &[z1 \<and> z2]_zs) &[rho' &[z1 \<and> z2]_zs])"
using assms apply(intro ext)
subgoal for xs x
by (cases "rho xs (x @xs[z1 \<and> z2]_zs)")
   (auto simp: lift_def swapEnv_defs swap_psubst) .

lemma swapEnv_substEnv:
assumes "good Y" and "goodEnv rho"
shows "((rho &[Y / y]_ys) &[z1 \<and> z2]_zs) =
       ((rho &[z1 \<and> z2]_zs) &[(Y #[z1 \<and> z2]_zs) / (y @ys[z1 \<and> z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1 \<and> z2]_zs) \<leftarrow> (Y #[z1 \<and> z2]_zs)]_ys) =
           ((idEnv [y \<leftarrow> Y]_ys) &[z1 \<and> z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  unfolding substEnv_def 1
  using assms by (intro swapEnv_psubstEnv) auto
qed

lemma swapEnv_vsubstEnv:
assumes "goodEnv rho"
shows "((rho &[y1 // y]_ys) &[z1 \<and> z2]_zs) =
       ((rho &[z1 \<and> z2]_zs) &[(y1 @ys[z1 \<and> z2]_zs) // (y @ys[z1 \<and> z2]_zs)]_ys)"
using assms unfolding vsubstEnv_def by(simp add: swapEnv_substEnv)

lemma psubstAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho rho'. {rho,rho'} \<subseteq> envsOf P \<longrightarrow> ((X #[rho]) #[rho']) = (X #[(rho &[rho'])])))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho rho'. {rho,rho'} \<subseteq> envsOf P \<longrightarrow> ((A $[rho]) $[rho']) = (A $[(rho &[rho'])])))"
proof(induction rule: term_induct_fresh[of P])
  case (Var xs x)
  then show ?case using assms
  by simp (smt envsOf_preserves_good option.case_eq_if option.sel psubstEnv_def
  psubstEnv_idEnv_id psubstEnv_preserves_good psubst_Var_simp1 psubst_Var_simp2)
next
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding psubstInp_def swapInp_def psubstBinp_def swapBinp_def lift_comp
  unfolding liftAll_def lift_def
  by simp (auto simp: lift_def psubstInp_def swapInp_def
  psubstBinp_def swapBinp_def split: option.splits)
qed(insert assms, simp_all add: psubstEnv_preserves_freshEnv)

corollary psubst_compose:
assumes "good X" and "goodEnv rho" and "goodEnv rho'"
shows "((X #[rho]) #[rho']) = (X #[(rho &[rho'])])"
using assms psubstAll_compose[of "Par [] [] [] [rho, rho']"]
unfolding goodPar_def by auto

lemma psubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'" and "goodEnv rho''"
shows "((rho &[rho']) &[rho'']) = (rho &[(rho' &[rho''])])"
using assms apply(intro ext)
subgoal for xs x
by (cases "rho xs x") (auto simp: lift_def psubstEnv_def  psubst_compose) .

lemma psubst_subst_compose:
assumes "good X" and "good Y" and "goodEnv rho"
shows "((X #[Y / y]_ys) #[rho]) = (X #[(rho [y \<leftarrow> (Y #[rho])]_ys)])"
by (simp add: assms psubstEnv_updEnv_idEnv psubst_compose subst_psubst_idEnv)

lemma psubstEnv_substEnv_compose:
assumes "goodEnv rho" and "good Y" and "goodEnv rho'"
shows "((rho &[Y / y]_ys) &[rho']) = (rho &[(rho' [y \<leftarrow> (Y #[rho'])]_ys)])"
by (simp add: assms psubstEnv_compose psubstEnv_updEnv_idEnv substEnv_def)

lemma psubst_vsubst_compose:
assumes "good X" and "goodEnv rho"
shows "((X #[y1 // y]_ys) #[rho]) = (X #[(rho [y \<leftarrow> ((Var ys y1) #[rho])]_ys)])"
using assms unfolding vsubst_def by(simp add: psubst_subst_compose)

lemma psubstEnv_vsubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[y1 // y]_ys) &[rho']) = (rho &[(rho' [y \<leftarrow> ((Var ys y1) #[rho'])]_ys)])"
using assms unfolding vsubstEnv_def by(simp add: psubstEnv_substEnv_compose)

lemma subst_psubst_compose:
assumes "good X" and "good Y" and "goodEnv rho"
shows "((X #[rho]) #[Y / y]_ys) = (X #[(rho &[Y / y]_ys)])"
unfolding subst_def substEnv_def using assms by(simp add: psubst_compose)

lemma substEnv_psubstEnv_compose:
assumes "goodEnv rho" and "good Y" and "goodEnv rho'"
shows "((rho &[rho']) &[Y / y]_ys) = (rho &[(rho' &[Y / y]_ys)])"
unfolding substEnv_def using assms by(simp add: psubstEnv_compose)

lemma psubst_subst_compose_freshEnv:
assumes "goodEnv rho" and "good X" and "good Y"
assumes "freshEnv ys y rho"
shows "((X #[Y / y]_ys) #[rho]) = ((X #[rho]) #[(Y #[rho]) / y]_ys)"
using assms by (simp add: subst_psubst_compose psubst_subst_compose)

lemma psubstEnv_substEnv_compose_freshEnv:
assumes "goodEnv rho" and "goodEnv rho'" and "good Y"
assumes "freshEnv ys y rho'"
shows "((rho &[Y / y]_ys) &[rho']) = ((rho &[rho']) &[(Y #[rho']) / y]_ys)"
using assms by (simp add: substEnv_psubstEnv_compose psubstEnv_substEnv_compose)

lemma vsubst_psubst_compose:
assumes "good X" and "goodEnv rho"
shows "((X #[rho]) #[y1 // y]_ys) = (X #[(rho &[y1 // y]_ys)])"
unfolding vsubst_def vsubstEnv_def using assms by(simp add: subst_psubst_compose)

lemma vsubstEnv_psubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[rho']) &[y1 // y]_ys) = (rho &[(rho' &[y1 // y]_ys)])"
unfolding vsubstEnv_def using assms by(simp add: substEnv_psubstEnv_compose)

lemma subst_compose1:
assumes "good X" and "good Y1" and "good Y2"
shows "((X #[Y1 / y]_ys) #[Y2 / y]_ys) = (X #[(Y1 #[Y2 / y]_ys) / y]_ys)"
proof-
  have "goodEnv (idEnv [y \<leftarrow> Y1]_ys) \<and> goodEnv (idEnv [y \<leftarrow> Y2]_ys)" using assms by simp
  thus ?thesis using \<open>good X\<close> unfolding subst_def substEnv_def
  by(simp add: psubst_compose psubstEnv_updEnv)
qed

lemma substEnv_compose1:
assumes "goodEnv rho" and "good Y1" and "good Y2"
shows "((rho &[Y1 / y]_ys) &[Y2 / y]_ys) = (rho &[(Y1 #[Y2 / y]_ys) / y]_ys)"
by (simp add: assms psubstEnv_compose psubstEnv_updEnv_idEnv substEnv_def subst_psubst_idEnv)

lemma subst_vsubst_compose1:
assumes "good X" and "good Y" and "y \<noteq> y1"
shows "((X #[y1 // y]_ys) #[Y / y]_ys) = (X #[y1 // y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose1)

lemma substEnv_vsubstEnv_compose1:
assumes "goodEnv rho" and "good Y" and "y \<noteq> y1"
shows "((rho &[y1 // y]_ys) &[Y / y]_ys) = (rho &[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose1)

lemma vsubst_subst_compose1:
assumes "good X" and "good Y"
shows "((X #[Y / y]_ys) #[y1 // y]_ys) = (X #[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose1)

lemma vsubstEnv_substEnv_compose1:
assumes "goodEnv rho" and "good Y"
shows "((rho &[Y / y]_ys) &[y1 // y]_ys) = (rho &[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose1)

lemma vsubst_compose1:
assumes "good X"
shows "((X #[y1 // y]_ys) #[y2 // y]_ys) = (X #[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubst_def
by(cases "y = y1") (auto simp: subst_compose1)

lemma vsubstEnv_compose1:
assumes "goodEnv rho"
shows "((rho &[y1 // y]_ys) &[y2 // y]_ys) = (rho &[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubstEnv_def
by(cases "y = y1") (auto simp: substEnv_compose1)

lemma subst_compose2:
assumes  "good X" and "good Y" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((X #[Y / y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[(Y #[Z / z]_zs) / y]_ys)"
by (metis assms fresh freshEnv_getEnv freshEnv_getEnv2 freshEnv_idEnv freshEnv_updEnv_I idEnv_preserves_good psubst_subst_compose_freshEnv
 subst_psubst_idEnv updEnv_preserves_good)

lemma substEnv_compose2:
assumes  "goodEnv rho" and "good Y" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((rho &[Y / y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[(Y #[Z / z]_zs) / y]_ys)"
  by (metis assms fresh freshEnv_updEnv_I getEnv_idEnv idEnv_preserves_good
   option.discI psubstEnv_substEnv_compose_freshEnv substEnv_def
  subst_psubst_idEnv updEnv_preserves_good)

lemma subst_vsubst_compose2:
assumes  "good X" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((X #[y1 // y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose2)

lemma substEnv_vsubstEnv_compose2:
assumes  "goodEnv rho" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((rho &[y1 // y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubstEnv_def by(simp add: substEnv_compose2)

lemma vsubst_subst_compose2:
assumes  "good X" and "good Y"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((X #[Y / y]_ys) #[z1 // z]_zs) = ((X #[z1 // z]_zs) #[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose2)

lemma vsubstEnv_substEnv_compose2:
assumes  "goodEnv rho" and "good Y"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((rho &[Y / y]_ys) &[z1 // z]_zs) = ((rho &[z1 // z]_zs) &[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose2)

lemma vsubst_compose2:
assumes  "good X"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((X #[y1 // y]_ys) #[z1 // z]_zs) =
       ((X #[z1 // z]_zs) #[(y1 @ys[z1 / z]_zs) // y]_ys)"
by (metis vsubst_def Var_preserves_good assms vsubst_Var_simp vsubst_def
    vsubst_subst_compose2)

lemma vsubstEnv_compose2:
assumes "goodEnv rho"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((rho &[y1 // y]_ys) &[z1 // z]_zs) =
       ((rho &[z1 // z]_zs) &[(y1 @ys[z1 / z]_zs) // y]_ys)"
by (metis Var_preserves_good assms
vsubstEnv_def vsubstEnv_substEnv_compose2 vsubst_Var_simp)

subsection \<open>Properties specific to variable-for-variable substitution\<close>

(* Note: The results in this section cannot be lifted to environments, and therefore
we don't have ``environment versions" of these.  *)

lemma vsubstAll_ident:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and zs
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> z. z \<in> varsOf P \<longrightarrow> (X #[z // z]_zs) = X))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> z. z \<in> varsOf P \<longrightarrow> (A $[z // z]_zs) = A))"
proof(induct rule: term_induct_fresh[of P])
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding vsubst_def vsubstAbs_def liftAll_def lift_def
  by simp (auto simp: lift_def substInp_def2 substBinp_def2 vsubstInp_def2
        split: option.splits)
next
  case (Abs xs x X)
  then show ?case
  by (metis empty_iff insert_iff vsubstAbs_simp)
qed(insert assms, simp_all)

corollary vsubst_ident[simp]:
assumes "good X"
shows "(X #[z // z]_zs) = X"
using assms vsubstAll_ident[of "Par [z] [] [] []" X]
unfolding goodPar_def by simp

corollary subst_ident[simp]:
assumes "good X"
shows "(X #[(Var zs z) / z]_zs) = X"
using assms vsubst_ident unfolding vsubst_def by auto

lemma vsubstAll_swapAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and ys
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<and> fresh ys y1 X \<longrightarrow>
            (X #[y1 // y2]_ys) = (X #[y1 \<and> y2]_ys)))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<and> freshAbs ys y1 A  \<longrightarrow>
            (A $[y1 // y2]_ys) = (A $[y1 \<and> y2]_ys)))"
apply(induction rule: term_induct_fresh[OF P])
subgoal by (force simp add: sw_def)
subgoal by simp (auto
  simp: vsubstInp_def substInp_def2 vsubst_def swapInp_def
              vsubstBinp_def substBinp_def2 vsubstAbs_def swapBinp_def
              freshInp_def  freshBinp_def lift_def liftAll_def
  split: option.splits)
subgoal by simp (metis Var_preserves_good fresh_Var_simp substAbs_simp sw_def
  vsubstAbs_def vsubst_def) .

corollary vsubst_eq_swap:
assumes "good X" and "y1 = y2 \<or> fresh ys y1 X"
shows "(X #[y1 // y2]_ys) = (X #[y1 \<and> y2]_ys)"
apply(cases "y1 = y2")
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" X]
unfolding goodPar_def by auto

lemma skelAll_vsubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and ys
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<longrightarrow>
            skel (X #[y1 // y2]_ys) = skel X))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<longrightarrow>
            skelAbs (A $[y1 // y2]_ys) = skelAbs A))"
proof(induction rule: term_induct_fresh[of P])
  case (Op delta inp binp)
  then show ?case
  by (simp add: skelInp_def2 skelBinp_def2)
   (auto simp: vsubst_def vsubstInp_def substInp_def2
       vsubstAbs_def vsubstBinp_def substBinp_def2 lift_def liftAll_def
       split: option.splits)
next
  case (Abs xs x X)
  then show ?case using assms
  by simp (metis not_equals_and_not_equals_not_in
     skelAbs_simp vsubstAbs_simp vsubst_preserves_good)
qed(insert assms, simp_all)

corollary skel_vsubst:
assumes "good X"
shows "skel (X #[y1 // y2]_ys) = skel X"
using assms skelAll_vsubstAll[of "Par [y1, y2] [] [] []" X]
unfolding goodPar_def by simp

lemma subst_vsubst_trans:
assumes  "good X" and "good Y" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[Y / y1]_ys) = (X #[Y / y]_ys)"
using assms unfolding subst_def vsubst_def
by (cases "y1 = y") (simp_all add: fresh_psubst_updEnv psubstEnv_updEnv_idEnv
  psubst_compose updEnv_commute)

lemma vsubst_trans:
assumes  "good X" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[y2 // y1]_ys) = (X #[y2 // y]_ys)"
unfolding vsubst_def[of _ y2 y1] vsubst_def[of _ y2 y]
using assms by(simp add: subst_vsubst_trans)

lemma vsubst_commute:
assumes X: "good X"
and "xs \<noteq> xs' \<or> {x,y} \<inter> {x',y'} = {}" and "fresh xs x X" and "fresh xs' x' X"
shows "((X #[x // y]_xs) #[x' // y']_xs') = ((X #[x' // y']_xs') #[x // y]_xs)"
proof-
  have "fresh xs' x' (X #[x // y]_xs)"
  using assms by (intro vsubst_preserves_fresh) auto
  moreover have "fresh xs x (X #[x' // y']_xs')"
  using assms by (intro vsubst_preserves_fresh) auto
  ultimately show ?thesis using assms
  by (auto simp: vsubst_eq_swap intro!: swap_commute)
qed

subsection \<open>Abstraction versions of the properties\<close>

text\<open>Environment identity and update versus other operators:\<close>

lemma psubstAbs_idEnv[simp]:
"goodAbs A \<Longrightarrow> (A $[idEnv]) = A"
by(simp add: psubstAll_idEnv)

text\<open>Substitution versus other operators:\<close>

corollary freshAbs_psubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows
"freshAbs zs z (A $[rho]) =
 (\<forall> ys y. freshAbs ys y A \<or> freshImEnvAt zs z rho ys y)"
using assms freshAll_psubstAll[of "Par [z] [] [] [rho]"]
unfolding goodPar_def by simp

corollary freshAbs_psubstAbs_E1:
assumes "goodAbs A" and "goodEnv rho"
and "rho ys y = None" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A \<or> (ys \<noteq> zs \<or> y \<noteq> z)"
using assms freshAbs_psubstAbs unfolding freshImEnvAt_def by fastforce

corollary freshAbs_psubstAbs_E2:
assumes "goodAbs A" and "goodEnv rho"
and "rho ys y = Some Y" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A \<or> fresh zs z Y"
using assms freshAbs_psubstAbs[of A rho] unfolding freshImEnvAt_def by fastforce

corollary freshAbs_psubstAbs_I1:
assumes "goodAbs A" and "goodEnv rho"
and "freshAbs zs z A" and "freshEnv zs z rho"
shows "freshAbs zs z (A $[rho])"
using assms apply(simp add: freshAbs_psubstAbs)
unfolding freshEnv_def liftAll_def freshImEnvAt_def by auto

corollary freshAbs_psubstAbs_I:
assumes "goodAbs A" and "goodEnv rho"
and "rho zs z = None \<Longrightarrow> freshAbs zs z A" and
    "\<And> ys y Y. rho ys y = Some Y \<Longrightarrow> freshAbs ys y A \<or> fresh zs z Y"
shows "freshAbs zs z (A $[rho])"
using assms using option.exhaust_sel
by (simp add: freshAbs_psubstAbs freshImEnvAt_def) blast

lemma freshAbs_substAbs:
assumes "goodAbs A" and "good Y"
shows "freshAbs zs z (A $[Y / y]_ys) =
       (((zs = ys \<and> z = y) \<or> freshAbs zs z A) \<and> (freshAbs ys y A \<or> fresh zs z Y))"
unfolding substAbs_def using assms
by (auto simp: freshAbs_psubstAbs freshImEnvAt_def)

lemma freshAbs_vsubstAbs:
assumes "goodAbs A"
shows "freshAbs zs z (A $[y1 // y]_ys) =
       (((zs = ys \<and> z = y) \<or> freshAbs zs z A) \<and>
        (freshAbs ys y A \<or> (zs \<noteq> ys \<or> z \<noteq> y1)))"
unfolding vsubstAbs_def using assms by(auto simp: freshAbs_substAbs)

lemma substAbs_preserves_freshAbs:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z A" and "fresh zs z Y"
shows "freshAbs zs z (A $[Y / y]_ys)"
using assms by(simp add: freshAbs_substAbs)

lemma vsubstAbs_preserves_freshAbs:
assumes "goodAbs A"
and "freshAbs zs z A" and "zs \<noteq> ys \<or> z \<noteq> y1"
shows "freshAbs zs z (A $[y1 // y]_ys)"
using assms by(simp add: freshAbs_vsubstAbs)

lemma fresh_freshAbs_substAbs[simp]:
assumes "good Y" and "goodAbs A"
and "fresh ys y Y"
shows "freshAbs ys y (A $[Y / y]_ys)"
using assms by(simp add: freshAbs_substAbs)

lemma diff_freshAbs_vsubstAbs[simp]:
assumes "goodAbs A"
and "y \<noteq> y1"
shows "freshAbs ys y (A $[y1 // y]_ys)"
using assms by(simp add: freshAbs_vsubstAbs)

lemma freshAbs_substAbs_E1:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z (A $[Y / y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshAbs zs z A"
using assms by(auto simp: freshAbs_substAbs)

lemma freshAbs_vsubstAbs_E1:
assumes "goodAbs A"
and "freshAbs zs z (A $[y1 // y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshAbs zs z A"
using assms by(auto simp: freshAbs_vsubstAbs)

lemma freshAbs_substAbs_E2:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z (A $[Y / y]_ys)"
shows "freshAbs ys y A \<or> fresh zs z Y"
using assms by(simp add: freshAbs_substAbs)

lemma freshAbs_vsubstAbs_E2:
assumes "goodAbs A"
and "freshAbs zs z (A $[y1 // y]_ys)"
shows "freshAbs ys y A \<or> zs \<noteq> ys \<or> z \<noteq> y1"
using assms by(simp add: freshAbs_vsubstAbs)

corollary psubstAbs_cong[fundef_cong]:
assumes "goodAbs A" and "goodEnv rho" and "goodEnv rho'"
and "\<And> ys y. freshAbs ys y A \<or> rho ys y = rho' ys y"
shows "(A $[rho]) = (A $[rho'])"
using assms psubstAll_cong[of "Par [] [] [] [rho,rho']"]
unfolding goodPar_def by simp

lemma freshAbs_psubstAbs_updEnv:
assumes "good X" and "goodAbs A" and "goodEnv rho"
and "freshAbs xs x A"
shows "(A $[rho [x \<leftarrow> X]_xs]) = (A $[rho])"
using assms by (intro psubstAbs_cong) auto

corollary freshEnv_psubstAbs_ident[simp]:
fixes A :: "('index,'bindex,'varSort,'var,'opSym)abs"
assumes "goodAbs A" and "goodEnv rho"
and "\<And> zs z. freshEnv zs z rho \<or> freshAbs zs z A"
shows "(A $[rho]) = A"
using assms psubstAll_ident[of "Par [] [] [] [rho]"]
unfolding goodPar_def by simp

lemma freshAbs_substAbs_ident[simp]:
assumes "good X" and "goodAbs A" and "freshAbs xs x A"
shows "(A $[X / x]_xs) = A"
by (simp add: assms freshAbs_psubstAbs_updEnv substAbs_def)

corollary substAbs_Abs[simp]:
assumes "good X" and "good Y"
shows "((Abs xs x X) $[Y / x]_xs) = Abs xs x X"
using assms by simp

lemma freshAbs_vsubstAbs_ident[simp]:
assumes "goodAbs A" and "freshAbs xs x A"
shows "(A $[x1 // x]_xs) = A"
using assms unfolding vsubstAbs_def by(auto simp: freshAbs_substAbs_ident)

lemma swapAbs_psubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[rho]) $[z1 \<and> z2]_zs) = ((A $[z1 \<and> z2]_zs) $[rho &[z1 \<and> z2]_zs])"
using assms swapAll_psubstAll[of "Par [z1,z2] [] [] [rho]"]
unfolding goodPar_def by auto

lemma swapAbs_substAbs:
assumes "goodAbs A" and "good Y"
shows "((A $[Y / y]_ys) $[z1 \<and> z2]_zs) =
       ((A $[z1 \<and> z2]_zs) $[(Y #[z1 \<and> z2]_zs) / (y @ys[z1 \<and> z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1 \<and> z2]_zs) \<leftarrow> (Y #[z1 \<and> z2]_zs)]_ys) =
           ((idEnv [y \<leftarrow> Y]_ys) &[z1 \<and> z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  unfolding substAbs_def 1 using assms by (intro swapAbs_psubstAbs) auto
qed

lemma swapAbs_vsubstAbs:
assumes "goodAbs A"
shows "((A $[y1 // y]_ys) $[z1 \<and> z2]_zs) =
       ((A $[z1 \<and> z2]_zs) $[(y1 @ys[z1 \<and> z2]_zs) // (y @ys[z1 \<and> z2]_zs)]_ys)"
using assms unfolding vsubstAbs_def
by(simp add: swapAbs_substAbs)

lemma psubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho" and "goodEnv rho'"
shows "((A $[rho]) $[rho']) = (A $[(rho &[rho'])])"
using assms psubstAll_compose[of "Par [] [] [] [rho, rho']"]
unfolding goodPar_def by auto

lemma psubstAbs_substAbs_compose:
assumes "goodAbs A" and "good Y" and "goodEnv rho"
shows "((A $[Y / y]_ys) $[rho]) = (A $[(rho [y \<leftarrow> (Y #[rho])]_ys)])"
by (simp add: assms psubstAbs_compose psubstEnv_updEnv_idEnv substAbs_def)

lemma psubstAbs_vsubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[y1 // y]_ys) $[rho]) = (A $[(rho [y \<leftarrow> ((Var ys y1) #[rho])]_ys)])"
using assms unfolding vsubstAbs_def by(simp add: psubstAbs_substAbs_compose)

lemma substAbs_psubstAbs_compose:
assumes "goodAbs A" and "good Y" and "goodEnv rho"
shows "((A $[rho]) $[Y / y]_ys) = (A $[(rho &[Y / y]_ys)])"
unfolding substAbs_def substEnv_def using assms by(simp add: psubstAbs_compose)

lemma psubstAbs_substAbs_compose_freshEnv:
assumes "goodAbs A" and "goodEnv rho" and "good Y"
assumes "freshEnv ys y rho"
shows "((A $[Y / y]_ys) $[rho]) = ((A $[rho]) $[(Y #[rho]) / y]_ys)"
using assms by (simp add: substAbs_psubstAbs_compose psubstAbs_substAbs_compose)

lemma vsubstAbs_psubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[rho]) $[y1 // y]_ys) = (A $[(rho &[y1 // y]_ys)])"
unfolding vsubstAbs_def vsubstEnv_def using assms
by(simp add: substAbs_psubstAbs_compose)

lemma substAbs_compose1:
assumes "goodAbs A" and "good Y1" and "good Y2"
shows "((A $[Y1 / y]_ys) $[Y2 / y]_ys) = (A $[(Y1 #[Y2 / y]_ys) / y]_ys)"
by (metis assms idEnv_preserves_good psubstAbs_substAbs_compose substAbs_def
  subst_psubst_idEnv updEnv_overwrite updEnv_preserves_good)

lemma substAbs_vsubstAbs_compose1:
assumes "goodAbs A" and "good Y" and "y \<noteq> y1"
shows "((A $[y1 // y]_ys) $[Y / y]_ys) = (A $[y1 // y]_ys)"
using assms unfolding vsubstAbs_def by(simp add: substAbs_compose1)

lemma vsubstAbs_substAbs_compose1:
assumes "goodAbs A" and "good Y"
shows "((A $[Y / y]_ys) $[y1 // y]_ys) = (A $[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubstAbs_def vsubst_def by(simp add: substAbs_compose1)

lemma vsubstAbs_compose1:
assumes "goodAbs A"
shows "((A $[y1 // y]_ys) $[y2 // y]_ys) = (A $[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubstAbs_def
by(cases "y = y1") (auto simp: substAbs_compose1)

lemma substAbs_vsubstAbs_compose2:
assumes "goodAbs A" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((A $[y1 // y]_ys) $[Z / z]_zs) = ((A $[Z / z]_zs) $[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubstAbs_def by(simp add: substAbs_compose2)

lemma vsubstAbs_substAbs_compose2:
assumes  "goodAbs A" and "good Y"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((A $[Y / y]_ys) $[z1 // z]_zs) = ((A $[z1 // z]_zs) $[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubstAbs_def vsubst_def by(simp add: substAbs_compose2)

lemma vsubstAbs_compose2:
assumes  "goodAbs A"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((A $[y1 // y]_ys) $[z1 // z]_zs) =
       ((A $[z1 // z]_zs) $[(y1 @ys[z1 / z]_zs) // y]_ys)"
unfolding vsubstAbs_def
by (smt Var_preserves_good assms fresh_Var_simp insertCI
   substAbs_compose2 vsubst_Var_simp vsubst_def)

text\<open>Properties specific to variable-for-variable substitution:\<close>

corollary vsubstAbs_ident[simp]:
assumes "goodAbs A"
shows "(A $[z // z]_zs) = A"
using assms vsubstAll_ident[of "Par [z] [] [] []" _ _ A]
unfolding goodPar_def by simp

corollary substAbs_ident[simp]:
assumes "goodAbs A"
shows "(A $[(Var zs z) / z]_zs) = A"
using assms vsubstAbs_ident unfolding vsubstAbs_def by auto

corollary vsubstAbs_eq_swapAbs:
assumes "goodAbs A" and "freshAbs ys y1 A"
shows "(A $[y1 // y2]_ys) = (A $[y1 \<and> y2]_ys)"
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by simp

corollary skelAbs_vsubstAbs:
assumes "goodAbs A"
shows "skelAbs (A $[y1 // y2]_ys) = skelAbs A"
using assms skelAll_vsubstAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by simp

lemma substAbs_vsubstAbs_trans:
assumes  "goodAbs A" and "good Y" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[Y / y1]_ys) = (A $[Y / y]_ys)"
using assms unfolding substAbs_def vsubstAbs_def
by (cases "y1 = y") (auto simp: freshAbs_psubstAbs_updEnv psubstAbs_compose
  psubstEnv_updEnv_idEnv updEnv_commute)

lemma vsubstAbs_trans:
assumes  "goodAbs A" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[y2 // y1]_ys) = (A $[y2 // y]_ys)"
unfolding vsubstAbs_def[of _ y2 y1] vsubstAbs_def[of _ y2 y]
using assms by(simp add: substAbs_vsubstAbs_trans)

lemmas good_psubstAll_freshAll_otherSimps =
psubst_idEnv psubstEnv_idEnv_id psubstAbs_idEnv
freshEnv_psubst_ident freshEnv_psubstAbs_ident

lemmas good_substAll_freshAll_otherSimps =
fresh_fresh_subst fresh_subst_ident fresh_substEnv_updEnv subst_ident
fresh_freshAbs_substAbs freshAbs_substAbs_ident substAbs_ident

lemmas good_vsubstAll_freshAll_otherSimps =
diff_fresh_vsubst fresh_vsubst_ident fresh_vsubstEnv_updEnv vsubst_ident
diff_freshAbs_vsubstAbs freshAbs_vsubstAbs_ident vsubstAbs_ident

lemmas good_allOpers_otherSimps =
good_swapAll_freshAll_otherSimps
good_psubstAll_freshAll_otherSimps
good_substAll_freshAll_otherSimps
good_vsubstAll_freshAll_otherSimps

lemmas good_item_simps =
param_simps
all_preserve_good
good_freeCons
good_allOpers_simps
good_allOpers_otherSimps

end  (* context FixVars *)

end


(*  Title:      HOL/Nitpick_Examples/Special_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's "specialize" optimization.
*)

section \<open>Examples Featuring Nitpick's \textit{specialize} Optimization\<close>

theory Special_Nits
imports Main
begin

nitpick_params [verbose, card = 4, sat_solver = MiniSat, max_threads = 1,
                timeout = 240]

fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f1 a b c d e = a + b + c + d + e"

lemma "f1 0 0 0 0 0 = f1 0 0 0 0 (1 - 1)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f1 u v w x y = f1 y x w v u"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f2 a b c d (Suc e) = a + b + c + d + e"

lemma "f2 0 0 0 0 0 = f2 (1 - 1) 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 0 (v - v) 0 (x - x) 0 = f2 (u - u) 0 (w - w) 0 (y - y)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 1 0 0 0 0 = f2 0 1 0 0 0"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f2 0 0 0 0 0 = f2 0 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f3 (Suc a) b 0 d (Suc e) = a + b + d + e" |
"f3 0 b 0 d 0 = b + d"

lemma "f3 a b c d e = f3 e d c b a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f3 a b c d a = f3 a d c d a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "\<lbrakk>c < 1; a \<ge> e; e \<ge> a\<rbrakk> \<Longrightarrow> f3 a b c d a = f3 e d c b e"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "(\<forall>u. a = u \<longrightarrow> f3 a a a a a = f3 u u u u u)
       \<and> (\<forall>u. b = u \<longrightarrow> f3 b b u b b = f3 u u b u u)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

function f4 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"f4 x x = 1" |
"f4 y z = (if y = z then 1 else 0)"
by auto
termination by lexicographic_order

lemma "f4 a b = f4 b a"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f4 a (Suc a) = f4 a a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

fun f5 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
"f5 f (Suc a) = f a"

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {2}. \<exists>two \<in> {1}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = potential]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11 \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then a else h b\<^sub>2) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = none]
nitpick [dont_box, expect = none]
nitpick [dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11::nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 \<ge> b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize,
         expect = potential]
oops

end


(*  Title:      HOL/Examples/Records.thy
    Author:     Wolfgang Naraschewski, TU Muenchen
    Author:     Norbert Schirmer, TU Muenchen
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Using extensible records in HOL -- points and coloured points\<close>

theory Records
  imports MainRLT
begin

subsection \<open>Points\<close>

record point =
  xpos :: nat
  ypos :: nat

text \<open>
  Apart many other things, above record declaration produces the
  following theorems:
\<close>

thm point.simps
thm point.iffs
thm point.defs

text \<open>
  The set of theorems @{thm [source] point.simps} is added
  automatically to the standard simpset, @{thm [source] point.iffs} is
  added to the Classical Reasoner and Simplifier context.

  \<^medskip> Record declarations define new types and type abbreviations:
  @{text [display]
\<open>point = \<lparr>xpos :: nat, ypos :: nat\<rparr> = () point_ext_type
'a point_scheme = \<lparr>xpos :: nat, ypos :: nat, ... :: 'a\<rparr>  = 'a point_ext_type\<close>}
\<close>

consts foo2 :: "\<lparr>xpos :: nat, ypos :: nat\<rparr>"
consts foo4 :: "'a \<Rightarrow> \<lparr>xpos :: nat, ypos :: nat, \<dots> :: 'a\<rparr>"

subsubsection \<open>Introducing concrete records and record schemes\<close>

definition foo1 :: point
  where "foo1 = \<lparr>xpos = 1, ypos = 0\<rparr>"

definition foo3 :: "'a \<Rightarrow> 'a point_scheme"
  where "foo3 ext = \<lparr>xpos = 1, ypos = 0, \<dots> = ext\<rparr>"

subsubsection \<open>Record selection and record update\<close>

definition getX :: "'a point_scheme \<Rightarrow> nat"
  where "getX r = xpos r"

definition setX :: "'a point_scheme \<Rightarrow> nat \<Rightarrow> 'a point_scheme"
  where "setX r n = r \<lparr>xpos := n\<rparr>"

subsubsection \<open>Some lemmas about records\<close>

text \<open>Basic simplifications.\<close>

lemma "point.make n p = \<lparr>xpos = n, ypos = p\<rparr>"
  by (simp only: point.make_def)

lemma "xpos \<lparr>xpos = m, ypos = n, \<dots> = p\<rparr> = m"
  by simp

lemma "\<lparr>xpos = m, ypos = n, \<dots> = p\<rparr>\<lparr>xpos:= 0\<rparr> = \<lparr>xpos = 0, ypos = n, \<dots> = p\<rparr>"
  by simp

text \<open>\<^medskip> Equality of records.\<close>

lemma "n = n' \<Longrightarrow> p = p' \<Longrightarrow> \<lparr>xpos = n, ypos = p\<rparr> = \<lparr>xpos = n', ypos = p'\<rparr>"
  \<comment> \<open>introduction of concrete record equality\<close>
  by simp

lemma "\<lparr>xpos = n, ypos = p\<rparr> = \<lparr>xpos = n', ypos = p'\<rparr> \<Longrightarrow> n = n'"
  \<comment> \<open>elimination of concrete record equality\<close>
  by simp

lemma "r\<lparr>xpos := n\<rparr>\<lparr>ypos := m\<rparr> = r\<lparr>ypos := m\<rparr>\<lparr>xpos := n\<rparr>"
  \<comment> \<open>introduction of abstract record equality\<close>
  by simp

lemma "r\<lparr>xpos := n\<rparr> = r\<lparr>xpos := n'\<rparr>" if "n = n'"
  \<comment> \<open>elimination of abstract record equality (manual proof)\<close>
proof -
  let "?lhs = ?rhs" = ?thesis
  from that have "xpos ?lhs = xpos ?rhs" by simp
  then show ?thesis by simp
qed

text \<open>\<^medskip> Surjective pairing\<close>

lemma "r = \<lparr>xpos = xpos r, ypos = ypos r\<rparr>"
  by simp

lemma "r = \<lparr>xpos = xpos r, ypos = ypos r, \<dots> = point.more r\<rparr>"
  by simp

text \<open>\<^medskip> Representation of records by cases or (degenerate) induction.\<close>

lemma "r\<lparr>xpos := n\<rparr>\<lparr>ypos := m\<rparr> = r\<lparr>ypos := m\<rparr>\<lparr>xpos := n\<rparr>"
proof (cases r)
  fix xpos ypos more
  assume "r = \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>"
  then show ?thesis by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>ypos := m\<rparr> = r\<lparr>ypos := m\<rparr>\<lparr>xpos := n\<rparr>"
proof (induct r)
  fix xpos ypos more
  show "\<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>\<lparr>xpos := n, ypos := m\<rparr> =
      \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>\<lparr>ypos := m, xpos := n\<rparr>"
    by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>xpos := m\<rparr> = r\<lparr>xpos := m\<rparr>"
proof (cases r)
  fix xpos ypos more
  assume "r = \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>"
  then show ?thesis by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>xpos := m\<rparr> = r\<lparr>xpos := m\<rparr>"
proof (cases r)
  case fields
  then show ?thesis by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>xpos := m\<rparr> = r\<lparr>xpos := m\<rparr>"
  by (cases r) simp

text \<open>\<^medskip> Concrete records are type instances of record schemes.\<close>

definition foo5 :: nat
  where "foo5 = getX \<lparr>xpos = 1, ypos = 0\<rparr>"

text \<open>\<^medskip> Manipulating the ``\<open>...\<close>'' (more) part.\<close>

definition incX :: "'a point_scheme \<Rightarrow> 'a point_scheme"
  where "incX r = \<lparr>xpos = xpos r + 1, ypos = ypos r, \<dots> = point.more r\<rparr>"

lemma "incX r = setX r (Suc (getX r))"
  by (simp add: getX_def setX_def incX_def)

text \<open>\<^medskip> An alternative definition.\<close>

definition incX' :: "'a point_scheme \<Rightarrow> 'a point_scheme"
  where "incX' r = r\<lparr>xpos := xpos r + 1\<rparr>"

subsection \<open>Coloured points: record extension\<close>

datatype colour = Red | Green | Blue

record cpoint = point +
  colour :: colour

text \<open>
  The record declaration defines a new type constructor and abbreviations:
  @{text [display]
\<open>cpoint = \<lparr>xpos :: nat, ypos :: nat, colour :: colour\<rparr> =
  () cpoint_ext_type point_ext_type
'a cpoint_scheme = \<lparr>xpos :: nat, ypos :: nat, colour :: colour, \<dots> :: 'a\<rparr> =
  'a cpoint_ext_type point_ext_type\<close>}
\<close>

consts foo6 :: cpoint
consts foo7 :: "\<lparr>xpos :: nat, ypos :: nat, colour :: colour\<rparr>"
consts foo8 :: "'a cpoint_scheme"
consts foo9 :: "\<lparr>xpos :: nat, ypos :: nat, colour :: colour, \<dots> :: 'a\<rparr>"

text \<open>Functions on \<open>point\<close> schemes work for \<open>cpoints\<close> as well.\<close>

definition foo10 :: nat
  where "foo10 = getX \<lparr>xpos = 2, ypos = 0, colour = Blue\<rparr>"

subsubsection \<open>Non-coercive structural subtyping\<close>

text \<open>Term \<^term>\<open>foo11\<close> has type \<^typ>\<open>cpoint\<close>, not type \<^typ>\<open>point\<close> --- Great!\<close>

definition foo11 :: cpoint
  where "foo11 = setX \<lparr>xpos = 2, ypos = 0, colour = Blue\<rparr> 0"

subsection \<open>Other features\<close>

text \<open>Field names contribute to record identity.\<close>

record point' =
  xpos' :: nat
  ypos' :: nat

text \<open>
  \<^noindent> May not apply \<^term>\<open>getX\<close> to @{term [source] "\<lparr>xpos' = 2, ypos' = 0\<rparr>"}
  --- type error.
\<close>

text \<open>\<^medskip> Polymorphic records.\<close>

record 'a point'' = point +
  content :: 'a

type_synonym cpoint'' = "colour point''"

text \<open>Updating a record field with an identical value is simplified.\<close>
lemma "r\<lparr>xpos := xpos r\<rparr> = r"
  by simp

text \<open>Only the most recent update to a component survives simplification.\<close>
lemma "r\<lparr>xpos := x, ypos := y, xpos := x'\<rparr> = r\<lparr>ypos := y, xpos := x'\<rparr>"
  by simp

text \<open>
  In some cases its convenient to automatically split (quantified) records.
  For this purpose there is the simproc @{ML [source] "Record.split_simproc"}
  and the tactic @{ML [source] "Record.split_simp_tac"}. The simplification
  procedure only splits the records, whereas the tactic also simplifies the
  resulting goal with the standard record simplification rules. A
  (generalized) predicate on the record is passed as parameter that decides
  whether or how `deep' to split the record. It can peek on the subterm
  starting at the quantified occurrence of the record (including the
  quantifier). The value \<^ML>\<open>0\<close> indicates no split, a value greater
  \<^ML>\<open>0\<close> splits up to the given bound of record extension and finally the
  value \<^ML>\<open>~1\<close> completely splits the record. @{ML [source]
  "Record.split_simp_tac"} additionally takes a list of equations for
  simplification and can also split fixed record variables.
\<close>

lemma "(\<forall>r. P (xpos r)) \<longrightarrow> (\<forall>x. P x)"
  apply (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.split_simproc (K ~1)]) 1\<close>)
  apply simp
  done

lemma "(\<forall>r. P (xpos r)) \<longrightarrow> (\<forall>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply simp
  done

lemma "(\<exists>r. P (xpos r)) \<longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.split_simproc (K ~1)]) 1\<close>)
  apply simp
  done

lemma "(\<exists>r. P (xpos r)) \<longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply simp
  done

lemma "\<And>r. P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.split_simproc (K ~1)]) 1\<close>)
  apply auto
  done

lemma "\<And>r. P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply auto
  done

lemma "P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply auto
  done

notepad
begin
  have "\<exists>x. P x"
    if "P (xpos r)" for P r
    apply (insert that)
    apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
    apply auto
    done
end

text \<open>
  The effect of simproc @{ML [source] Record.ex_sel_eq_simproc} is illustrated
  by the following lemma.\<close>

lemma "\<exists>r. xpos r = x"
  by (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.ex_sel_eq_simproc]) 1\<close>)

subsection \<open>A more complex record expression\<close>

record ('a, 'b, 'c) bar = bar1 :: 'a
  bar2 :: 'b
  bar3 :: 'c
  bar21 :: "'b \<times> 'a"
  bar32 :: "'c \<times> 'b"
  bar31 :: "'c \<times> 'a"

print_record "('a,'b,'c) bar"

subsection \<open>Some code generation\<close>

export_code foo1 foo3 foo5 foo10 checking SML

text \<open>
  Code generation can also be switched off, for instance for very large
  records:\<close>

declare [[record_codegen = false]]

record not_so_large_record =
  bar520 :: nat
  bar521 :: "nat \<times> nat"

declare [[record_codegen = true]]

end


section \<open>Proof Infrastructure\<close>
subsection \<open>Bisimulation\<close>

theory MyBisimulation
imports
  Stuttering
begin

(* WIP strong bisimilar
fun strongly_bisimilar :: "
(IRGraph \<times> ID \<times> MapState \<times> FieldRefHeap) rel
\<Rightarrow> (IRGraph \<times> ID \<times> MapState \<times> FieldRefHeap)
\<Rightarrow> (IRGraph \<times> ID \<times> MapState \<times> FieldRefHeap)
\<Rightarrow> bool"
  where
  "strongly_bisimilar \<R> (g1, nid1, m1, h1) (g2, nid2, m2, h2) =
    ((((g1, nid1, m1, h1), (g2, nid2, m2, h2)) \<in> \<R>) \<longrightarrow>
    ((\<forall>P'. (g1 \<turnstile> (nid1, m1, h1) \<rightarrow> P') \<longrightarrow> (\<exists>Q' . (g2 \<turnstile> (nid2, m2, h2) \<rightarrow> Q') \<and> ((g1,P'), (g2,Q')) \<in> \<R>)) \<and>
    (\<forall>Q'. (g2 \<turnstile> (nid2, m2, h2) \<rightarrow> Q') \<longrightarrow> (\<exists>P' . (g1 \<turnstile> (nid1, m1, h1) \<rightarrow> P') \<and> ((g1,P'), (g2,Q')) \<in> \<R>))))"
*)

inductive weak_bisimilar :: "ID \<Rightarrow> IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool"
  ("_ . _ \<sim> _") for nid where
  "\<lbrakk>\<forall>P'. (g m p h \<turnstile> nid \<leadsto> P') \<longrightarrow> (\<exists>Q' . (g' m p h \<turnstile> nid \<leadsto> Q') \<and> P' = Q');
    \<forall>Q'. (g' m p h \<turnstile> nid \<leadsto> Q') \<longrightarrow> (\<exists>P' . (g m p h \<turnstile> nid \<leadsto> P') \<and> P' = Q')\<rbrakk>
  \<Longrightarrow> nid . g \<sim> g'"

text \<open>A strong bisimilution between no-op transitions\<close>
inductive strong_noop_bisimilar :: "ID \<Rightarrow> MapState \<Rightarrow> FieldRefHeap \<Rightarrow> IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool"
  ("_ _ _ | _ \<sim> _") for nid where
  "\<lbrakk>\<forall>P'. (g, p \<turnstile> (nid, m, h) \<rightarrow> P') \<longrightarrow> (\<exists>Q' . (g', p \<turnstile> (nid, m, h) \<rightarrow> Q') \<and> P' = Q');
    \<forall>Q'. (g', p \<turnstile> (nid, m, h) \<rightarrow> Q') \<longrightarrow> (\<exists>P' . (g, p \<turnstile> (nid, m, h) \<rightarrow> P') \<and> P' = Q')\<rbrakk>
  \<Longrightarrow> nid m h | g \<sim> g'"

lemma lockstep_strong_bisimilulation:
  assumes "g' = replace_node nid node g"
  assumes "g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h)"
  assumes "g', p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h)"
  shows "nid m h | g \<sim> g'"
  using assms(2) assms(3) stepDet strong_noop_bisimilar.simps by metis

lemma no_step_bisimulation:
  assumes "\<forall>m p h nid' m' h'. \<not>(g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h'))"
  assumes "\<forall>m p h nid' m' h'. \<not>(g', p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h'))"
  shows "nid m h | g \<sim> g'"
  using assms
  by (simp add: assms(1) assms(2) strong_noop_bisimilar.intros)

end


chapter \<open>Static Intraprocedural Slicing\<close>

theory Distance imports "../Basic/CFG" begin

text \<open>
  Static Slicing analyses a CFG prior to execution. Whereas dynamic
  slicing can provide better results for certain inputs (i.e.\ trace and
  initial state), static slicing is more conservative but provides
  results independent of inputs.

  Correctness for static slicing is
  defined differently than correctness of dynamic slicing by a weak
  simulation between nodes and states when traversing the original and
  the sliced graph. The weak simulation property demands that if a
  (node,state) tuples $(n_1,s_1)$ simulates $(n_2,s_2)$
  and making an observable move in the original graph leads from
  $(n_1,s_1)$ to $(n_1',s_1')$, this tuple simulates a
  tuple $(n_2,s_2)$ which is the result of making an
  observable move in the sliced graph beginning in $(n_2',s_2')$.

  We also show how a ``dynamic slicing style'' correctness criterion for
  static slicing of a given trace and initial state could look like.

  This formalization of static intraprocedural slicing is instantiable
  with three different kinds of control dependences: standard control,
  weak control and weak order dependence. The correctness proof for
  slicing is independent of the control dependence used, it bases only
  on one property every control dependence definition hass to fulfill.
\<close>

section \<open>Distance of Paths\<close>

context CFG begin

inductive distance :: "'node \<Rightarrow> 'node \<Rightarrow> nat \<Rightarrow> bool"
where distanceI:
  "\<lbrakk>n -as\<rightarrow>* n'; length as = x; \<forall>as'. n -as'\<rightarrow>* n' \<longrightarrow> x \<le> length as'\<rbrakk>
  \<Longrightarrow> distance n n' x"

lemma every_path_distance:
  assumes "n -as\<rightarrow>* n'"
  obtains x where "distance n n' x" and "x \<le> length as"
proof -
  have "\<exists>x. distance n n' x \<and> x \<le> length as"
  proof(cases "\<exists>as'. n -as'\<rightarrow>* n' \<and>
                     (\<forall>asx. n -asx\<rightarrow>* n' \<longrightarrow> length as' \<le> length asx)")
    case True
    then obtain as'
      where "n -as'\<rightarrow>* n' \<and> (\<forall>asx. n -asx\<rightarrow>* n' \<longrightarrow> length as' \<le> length asx)"
      by blast
    hence "n -as'\<rightarrow>* n'" and all:"\<forall>asx. n -asx\<rightarrow>* n' \<longrightarrow> length as' \<le> length asx"
      by simp_all
    hence "distance n n' (length as')" by(fastforce intro:distanceI)
    from \<open>n -as\<rightarrow>* n'\<close> all have "length as' \<le> length as" by fastforce
    with \<open>distance n n' (length as')\<close> show ?thesis by blast
  next
    case False
    hence all:"\<forall>as'. n -as'\<rightarrow>* n' \<longrightarrow> (\<exists>asx. n -asx\<rightarrow>* n' \<and> length as' > length asx)"
      by fastforce
    have "wf (measure length)" by simp
    from \<open>n -as\<rightarrow>* n'\<close> have "as \<in> {as. n -as\<rightarrow>* n'}" by simp
    with \<open>wf (measure length)\<close> obtain as' where "as' \<in> {as. n -as\<rightarrow>* n'}"
      and notin:"\<And>as''. (as'',as') \<in> (measure length) \<Longrightarrow> as'' \<notin> {as. n -as\<rightarrow>* n'}"
      by(erule wfE_min)
    from \<open>as' \<in> {as. n -as\<rightarrow>* n'}\<close> have "n -as'\<rightarrow>* n'" by simp
    with all obtain asx where "n -asx\<rightarrow>* n'"
      and "length as' > length asx"
      by blast
    with notin have  "asx \<notin> {as. n -as\<rightarrow>* n'}" by simp
    hence "\<not> n -asx\<rightarrow>* n'" by simp
    with \<open>n -asx\<rightarrow>* n'\<close> have False by simp
    thus ?thesis by simp
  qed
  with that show ?thesis by blast
qed

lemma distance_det:
  "\<lbrakk>distance n n' x; distance n n' x'\<rbrakk> \<Longrightarrow> x = x'"
apply(erule distance.cases)+ apply clarsimp
apply(erule_tac x="asa" in allE) apply(erule_tac x="as" in allE)
by simp

lemma only_one_SOME_dist_edge:
  assumes valid:"valid_edge a" and dist:"distance (targetnode a) n' x"
  shows "\<exists>!a'. sourcenode a = sourcenode a' \<and> distance (targetnode a') n' x \<and>
               valid_edge a' \<and>
               targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                              distance (targetnode a') n' x \<and>
                                              valid_edge a' \<and> targetnode a' = nx)"
proof(rule ex_ex1I)
  show "\<exists>a'. sourcenode a = sourcenode a' \<and>
             distance (targetnode a') n' x \<and> valid_edge a' \<and>
             targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                            distance (targetnode a') n' x \<and>
                                            valid_edge a' \<and> targetnode a' = nx)"
  proof -
    have "(\<exists>a'. sourcenode a = sourcenode a' \<and>
                distance (targetnode a') n' x \<and> valid_edge a' \<and>
                targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                               distance (targetnode a') n' x \<and>
                                               valid_edge a' \<and> targetnode a' = nx)) =
      (\<exists>nx. \<exists>a'. sourcenode a = sourcenode a' \<and> distance (targetnode a') n' x \<and>
                 valid_edge a' \<and> targetnode a' = nx)"
      apply(unfold some_eq_ex[of "\<lambda>nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                distance (targetnode a') n' x \<and>valid_edge a' \<and>  targetnode a' = nx"])
      by simp
    also have "\<dots>" using valid dist by blast
    finally show ?thesis .
  qed
next
  fix a' ax
  assume "sourcenode a = sourcenode a' \<and>
    distance (targetnode a') n' x \<and> valid_edge a' \<and>
    targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                   distance (targetnode a') n' x \<and>
                                   valid_edge a' \<and> targetnode a' = nx)"
    and "sourcenode a = sourcenode ax \<and>
    distance (targetnode ax) n' x \<and> valid_edge ax \<and>
    targetnode ax = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                   distance (targetnode a') n' x \<and>
                                   valid_edge a' \<and> targetnode a' = nx)"
  thus "a' = ax" by(fastforce intro!:edge_det)
qed

lemma distance_successor_distance:
  assumes "distance n n' x" and "x \<noteq> 0"
  obtains a where "valid_edge a" and "n = sourcenode a"
  and "distance (targetnode a) n' (x - 1)"
  and "targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                     distance (targetnode a') n' (x - 1) \<and>
                                     valid_edge a' \<and> targetnode a' = nx)"
proof -
  have "\<exists>a. valid_edge a \<and> n = sourcenode a \<and> distance (targetnode a) n' (x - 1) \<and>
    targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                  distance (targetnode a') n' (x - 1) \<and>
                                  valid_edge a' \<and> targetnode a' = nx)"
  proof(rule ccontr)
    assume "\<not> (\<exists>a. valid_edge a \<and> n = sourcenode a \<and>
                   distance (targetnode a) n' (x - 1) \<and>
                   targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                                 distance (targetnode a') n' (x - 1) \<and>
                                                 valid_edge a' \<and> targetnode a' = nx))"
    hence imp:"\<forall>a. valid_edge a \<and> n = sourcenode a \<and>
                   targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                                 distance (targetnode a') n' (x - 1) \<and>
                                                 valid_edge a' \<and> targetnode a' = nx)
                 \<longrightarrow> \<not> distance (targetnode a) n' (x - 1)" by blast
    from \<open>distance n n' x\<close> obtain as where "n -as\<rightarrow>* n'" and "x = length as"
      and "\<forall>as'. n -as'\<rightarrow>* n' \<longrightarrow> x \<le> length as'"
      by(auto elim:distance.cases)
    thus False using imp
    proof(induct rule:path.induct)
      case (empty_path n)
      from \<open>x = length []\<close> \<open>x \<noteq> 0\<close> show False by simp
    next
      case (Cons_path n'' as n' a n)
      note imp = \<open>\<forall>a. valid_edge a \<and> n = sourcenode a \<and>
                      targetnode a = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                                 distance (targetnode a') n' (x - 1) \<and>
                                                 valid_edge a' \<and> targetnode a' = nx)
                    \<longrightarrow> \<not> distance (targetnode a) n' (x - 1)\<close>
      note all = \<open>\<forall>as'. n -as'\<rightarrow>* n' \<longrightarrow> x \<le> length as'\<close>
      from \<open>n'' -as\<rightarrow>* n'\<close> obtain y where "distance n'' n' y"
        and "y \<le> length as" by(erule every_path_distance)
      from \<open>distance n'' n' y\<close> obtain as' where "n'' -as'\<rightarrow>* n'"
        and "y = length as'"
        by(auto elim:distance.cases)
      show False
      proof(cases "y < length as")
        case True
        from \<open>valid_edge a\<close> \<open>sourcenode a = n\<close> \<open>targetnode a = n''\<close> \<open>n'' -as'\<rightarrow>* n'\<close>
        have "n -a#as'\<rightarrow>* n'" by -(rule path.Cons_path)
        with all have "x \<le> length (a#as')" by blast
        with \<open>x = length (a#as)\<close> True \<open>y = length as'\<close> show False by simp
      next
        case False
        with \<open>y \<le> length as\<close> \<open>x = length (a#as)\<close> have "y = x - 1" by simp
        from \<open>targetnode a = n''\<close> \<open>distance n'' n' y\<close>
        have "distance (targetnode a) n' y" by simp
        with \<open>valid_edge a\<close>
        obtain a' where "sourcenode a = sourcenode a'"
          and "distance (targetnode a') n' y" and "valid_edge a'"
          and "targetnode a' = (SOME nx. \<exists>a'. sourcenode a = sourcenode a' \<and>
                                              distance (targetnode a') n' y \<and>
                                              valid_edge a' \<and> targetnode a' = nx)"
          by(auto dest:only_one_SOME_dist_edge)
        with imp \<open>sourcenode a = n\<close> \<open>y = x - 1\<close> show False by fastforce
      qed
    qed
  qed
  with that show ?thesis by blast
qed

end

end


theory K_R_Spark_User
imports K_R_Spark_Specification K_R_Spark_Declaration

begin

lemma goal6'1:
  assumes H1: " (0 :: int) <= j'' "
  assumes H2: " j'' <= (15 :: int) "
  shows " (1352829926 :: int) = k_r' j'' " (is "?C1")
  using assms by (simp add: K'_def)

lemma goal7'1:
  assumes H1: " (16 :: int) <= j'' "
  assumes H2: " j'' <= (31 :: int) "
  shows " (1548603684 :: int) = k_r' j'' " (is "?C1")
proof-
  from H1 have "16 <= nat j''" by simp
  moreover from H2 have "nat j'' <= 31" by simp
  ultimately show ?thesis by (simp add: K'_def)
qed

lemma goal8'1:
  assumes H1: " (32 :: int) <= j'' "
  assumes H2: " j'' <= (47 :: int) "
  shows " (1836072691 :: int) = k_r' j'' " (is "?C1")
proof -
  from H1 have "32 <= nat j''" by simp
  moreover from H2 have "nat j'' <= 47" by simp
  ultimately show ?thesis by (simp add: K'_def)
qed

lemma goal9'1:
  assumes H1: " (48 :: int) <= j'' "
  assumes H2: " j'' <= (63 :: int) "
  shows " (2053994217 :: int) = k_r' j'' " (is "?C1")
proof -
  from H1 have "48 <= nat j''" by simp
  moreover from H2 have "nat j'' <= 63" by simp
  ultimately show ?thesis by (simp add: K'_def)
qed

lemma goal10'1:
  assumes H2: " j'' <= (79 :: int) "
  assumes H6: " (63 :: int) < j'' "
  shows " (0 :: int) = k_r' j'' " (is "?C1")
proof -
  from H6 have "64 <= nat j''" by simp
  moreover from H2 have "nat j'' <= 79" by simp
  ultimately show ?thesis by (simp add: K'_def)
qed

lemmas userlemmas =
  goal6'1
  goal7'1
  goal8'1
  goal9'1
  goal10'1
end


(*File: MutiStep.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Transitive closure of the Language.Step relation
*)
(*<*)
theory MultiStep imports Language begin
(*>*)

section\<open>Auxiliary operational judgements\<close>

text\<open>Beside the basic operational judgements \<open>Step\<close> and \<open>Exec\<close>, the interpretation of judgements refers to two multi-step
relations which we now define.\<close>

subsection\<open>Multistep execution\<close>

text\<open>The first additional operational judgement is the reflexive and
transitive closure of \<open>Step\<close>. It relates states $s$ and $t$ if
the latter can be reached from the former by a chain if single steps,
all in the same frame. Note that $t$ does not need to be a terminal
state. As was the case in the definition of \<open>Step\<close>, we first
define a relation with an explicit derivation height index (\<open>MStep\<close>).\<close>

inductive_set
MStep::"(Mbody \<times> Label \<times> State \<times> nat \<times> Label \<times> State) set"
where
MS_zero: "\<lbrakk>k=0; t=s; ll=l\<rbrakk> \<Longrightarrow> (M,l,s,k,ll,t):MStep"
|
MS_step: "\<lbrakk>(M,l,s,n,l1,r):Step; (M,l1,r,k,l2,t):MStep; m=Suc k+n\<rbrakk>
         \<Longrightarrow> (M,l,s,m,l2,t) : MStep"

text\<open>The following properties of \<open>MStep\<close> are useful to
notice.\<close>

(*<*)
lemma ZeroHeightMultiElimAux[rule_format]:
  "(M, l, s, k, ll, r) \<in> MStep \<Longrightarrow> 0=k \<longrightarrow> (r=s \<and> ll=l)"
by (erule MStep.induct, simp_all)
(*>*)
lemma ZeroHeightMultiElim: "(M,l,s,0,ll,r) \<in> MStep \<Longrightarrow> r=s \<and> ll=l"
(*<*)
by (erule ZeroHeightMultiElimAux, simp)
(*>*)
(*<*)
lemma MultiSplitAux[rule_format]:
  "(M, l, s, k, ll, t) \<in> MStep \<Longrightarrow>
    1 \<le> k \<longrightarrow> (\<exists> n m r l1. (M,l,s,n,l1,r):Step \<and>
                        (M,l1,r,m,ll,t):MStep \<and> Suc m +n =k)"
apply (erule MStep.induct, simp_all)
apply clarsimp
  apply (case_tac k, clarsimp)
    apply (drule ZeroHeightMultiElim[simplified], clarsimp)
      apply (rule, rule,rule, rule,rule, rule, rule, assumption)
      apply (rule,rule MS_zero) apply simp apply simp apply simp
  apply clarsimp
    apply (rule, rule,rule, rule,rule, rule,rule,assumption) apply (rule,assumption)
    apply simp
done
(*>*)

lemma MultiSplit:
  "\<lbrakk>(M, l, s, k, ll, t) \<in> MStep; 1 \<le> k\<rbrakk> \<Longrightarrow>
  \<exists> n m r l1. (M,l,s,n,l1,r):Step \<and> (M,l1,r,m,ll,t):MStep \<and> Suc m + n =k"
(*<*)by (erule MultiSplitAux, assumption)(*>*)

(*<*)
lemma MStep_returnElimAux[rule_format]:
"(M,l,s,k,ll,t) \<in> MStep \<Longrightarrow>
 (get_ins M l = Some vreturn \<longrightarrow> t=s \<and> ll=l)"
apply (erule MStep.induct)
apply clarsimp
apply clarsimp apply (drule RetElim1) apply simp apply clarsimp
done
(*>*)

lemma MStep_returnElim:
  "\<lbrakk>(M,l,s,k,ll,t) \<in> MStep; get_ins M l = Some vreturn\<rbrakk> \<Longrightarrow> t=s \<and> ll = l"
(*<*)
by (erule MStep_returnElimAux, assumption)
(*>*)

(*<*)
lemma MultiAppAux[rule_format]:
"(M,l,s,k,l1,r):MStep \<Longrightarrow>
  (\<forall> n t l2. (M,l1,r,n,l2,t):Step \<longrightarrow> (M,l,s,Suc k+n,l2,t):MStep)"
apply (erule MStep.induct)
apply clarsimp apply (erule MS_step) apply (rule MS_zero) apply (simp,simp, simp, simp)
apply (rule, rule, rule, rule)
apply (erule MS_step)
  apply (erule_tac x=na in allE, erule_tac x=ta in allE)
  apply (erule_tac x=l2a in allE , erule impE) apply assumption
    apply assumption
    apply simp
done
(*>*)

lemma MultiApp:
  "\<lbrakk>(M,l,s,k,l1,r):MStep; (M,l1,r,n,l2,t):Step\<rbrakk> \<Longrightarrow> (M,l,s,Suc k+n,l2,t):MStep"
(*<*)
by (erule MultiAppAux, assumption)
(*>*)

(*<*)
lemma MStep_Compose_Aux:"(M,l,s,n,l1,r):MStep \<Longrightarrow> (\<forall> k t l2. (M,l1,r,k,l2,t):MStep \<longrightarrow> (M,l,s,n + k,l2,t):MStep)"
apply (erule MStep.induct)
apply clarsimp
apply (rule, rule, rule, rule)
  apply (erule_tac x=ka in allE, erule_tac x=ta in allE)
  apply (erule_tac x=l2a in allE, erule impE, assumption)
  apply (erule MS_step, assumption)
  apply simp
done
(*>*)

lemma MStep_Compose:
  "\<lbrakk>(M,l,s,n,l1,r):MStep; (M,l1,r,k,l2,t):MStep; nk=n+k\<rbrakk>
  \<Longrightarrow> (M,l,s,nk,l2,t):MStep"
(*<*)
by (drule MStep_Compose_Aux, fastforce)
(*>*)

text\<open>Here are two simple lemmas relating the operational judgements.\<close>

(*<*)
lemma MStep_Exec1_Aux[rule_format]:
"(M, l, s, kb, l1, t) \<in> MStep \<Longrightarrow>
 (\<forall> hh v . (\<exists> k . (M, l, s, k, hh, v) \<in> Exec) \<longrightarrow> (\<exists> n. (M, l1, t, n, hh, v) \<in> Exec))"
apply (erule MStep.induct)
apply clarsimp
apply (rule, rule, rule)
  apply (erule exE)
  apply (erule_tac x=hh in allE, erule_tac x=v in allE, erule mp)
  apply (case_tac s, clarify)
  apply (drule ExecElim1, clarsimp)
  apply (erule disjE) apply clarsimp apply (drule RetElim1, simp,simp)
  apply clarsimp
  apply (drule Step_determ, assumption, clarsimp)
  apply (rule, assumption)
done
(*>*)
lemma MStep_Exec1:
  "\<lbrakk>(M, l, s, kb, l1, t) \<in> MStep; (M, l, s, k, hh, v) \<in> Exec\<rbrakk>
  \<Longrightarrow> \<exists> n. (M, l1, t, n, hh, v) \<in> Exec"
(*<*)
by (erule MStep_Exec1_Aux, fast)
(*>*)

(*<*)
lemma MStep_Exec2_Aux[rule_format]:
"(M, l, s, kb, l1, t) \<in> MStep \<Longrightarrow>
 (\<forall> hh v . (\<exists> k . (M, l1, t, k, hh, v) \<in> Exec) \<longrightarrow> (\<exists> n. (M, l, s, n, hh, v) \<in> Exec))"
apply (erule MStep.induct)
apply clarsimp
apply (rule, rule, rule)
  apply (erule exE)
  apply (erule_tac x=hh in allE, erule_tac x=v in allE, erule impE)
    apply (rule, assumption)
  apply (erule exE)
  apply (rule, rule Run) apply assumption+ apply simp
done
(*>*)

lemma MStep_Exec2:
  "\<lbrakk> (M, l, s, kb, l1, t) \<in> MStep; (M, l1, t, k, hh, v) \<in> Exec\<rbrakk>
  \<Longrightarrow> \<exists> n. (M, l, s, n, hh, v) \<in> Exec"
(*<*)
by (erule MStep_Exec2_Aux, fast)
(*>*)

text\<open>Finally, the definition of the non-height-indexed relation.\<close>

definition MS::"Mbody \<Rightarrow> Label \<Rightarrow> State \<Rightarrow> Label \<Rightarrow> State \<Rightarrow> bool"
where "MS M l s ll t = (\<exists> k . (M,l,s,k,ll,t):MStep)"

(*<*)
end
(*>*)


theory State_Monad_HL
imports
  Main
  "~~/src/HOL/Library/State_Monad"
begin

definition TT:: "'a \<Rightarrow> bool" where "TT x = True"
definition TTT:: "'b \<Rightarrow> 'a \<Rightarrow> bool" where "TTT x y = True"
definition FF:: "'a \<Rightarrow> bool" where "FF x = False"
definition GG:: "('a \<Rightarrow> bool) \<Rightarrow> ('b => 'a \<Rightarrow> bool)" where "GG p x = p"
definition UU:: "('a \<Rightarrow> bool) \<Rightarrow> (unit => 'a \<Rightarrow> bool)" where "UU p x = p"

record status =
    ok:: bool

definition return:: "'a \<Rightarrow> (status + 'b, 'a) state" where "return = State_Monad.return"
definition get_state:: "(status + 'a, status + 'a) state" where "get_state = State (\<lambda>x. (x,x))"
definition put_state:: "status + 'a \<Rightarrow> (status + 'a, unit) state" where "put_state x = State (\<lambda>_. ((),x))"
definition skip:: "(status + 'a, unit) state" where "skip = State (\<lambda>x. ((),x))"

definition get:: "(status + 'a \<Rightarrow> 'b) \<Rightarrow> (status + 'a, 'b) state" where
  "get v = do { x \<leftarrow> get_state; return (v x) }"

definition put:: "(status + 'a \<Rightarrow> 'b \<Rightarrow> status + 'a) \<Rightarrow>  'b \<Rightarrow> (status + 'a, unit) state" where
  "put vu a = do { x \<leftarrow> get_state; put_state (vu x a) }"

definition assign:: "(status + 'a \<Rightarrow> 'b \<Rightarrow> status + 'a) \<Rightarrow> (status + 'a \<Rightarrow> 'b) \<Rightarrow> (status + 'a, unit) state" ("(2_ :=/ _)" [70, 65] 61) where
  "assign vu v = do { a \<leftarrow> get v; put vu a }"

definition spec:: "(status + 'a \<Rightarrow> bool) \<Rightarrow> (status +  'a, 'b) state \<Rightarrow> ('b \<Rightarrow> status +  'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "spec p S q = (\<forall>x. p x  \<longrightarrow> (let (y, z) = run_state S x in q y z))"

theorem get_state_rule: "spec (\<lambda>x. p x x) (get_state) p"
  by (simp add: get_state_def spec_def)

theorem get_rule: "\<forall>x. spec (\<lambda>y. p y \<and> v x = v y) (S (v x)) q \<Longrightarrow> spec p (get v \<bind> S) q"
  by (simp add: spec_def get_def return_def case_prod_unfold get_state_def)

theorem return_rule: "spec (p v) (return v) p"
  by (simp add: return_def spec_def)

(*
theorem assign_rule: "spec (p) (assign vu v) p"
  by (simp add: return_def spec_def)
*)

theorem seq_rule: "\<lbrakk>spec p S q; \<forall>x. spec (q x) T r\<rbrakk> \<Longrightarrow> spec p (do { S; T }) r"
  apply (simp add: spec_def)
  by fastforce

theorem let_rule: "let v = E in spec p (do { T }) r \<Longrightarrow> spec p (do { let v = E; T }) r"
  by (simp add: spec_def snd_def)

theorem skip_left_rule: "spec p (do { skip; S }) q \<Longrightarrow> spec p S q"
  by (simp add: spec_def skip_def)

theorem conj_rule: "\<lbrakk>spec p S q; spec r S s\<rbrakk> \<Longrightarrow> spec (\<lambda>x. p x \<and> r x) S (\<lambda>x y. q x y \<and> s x y)"
  apply (simp add: spec_def)
  by (simp add: case_prod_unfold)

theorem conj_rule_right: "\<lbrakk>spec p S q; spec p S s\<rbrakk> \<Longrightarrow> spec p S (\<lambda>x y. q x y \<and> s x y)"
  apply (simp add: spec_def)
  by (simp add: case_prod_unfold)

theorem weaken_rule: "\<lbrakk>\<forall>x. (p x \<longrightarrow> p0 x); spec p0 S q\<rbrakk> \<Longrightarrow> spec p S q"
  by (simp add: spec_def)

theorem strengthen_rule: "\<lbrakk>\<forall>x y. (q0 x y \<longrightarrow> q x y); spec p S q0\<rbrakk> \<Longrightarrow> spec p S q"
  apply (simp add: spec_def)
  by (simp add: case_prod_unfold)

theorem cond_rule: "\<lbrakk>spec (\<lambda>x. p x \<and> b) S q; spec (\<lambda>x. p x \<and> \<not>b) T q\<rbrakk> \<Longrightarrow> spec p (if b then S else T) q"
  by (simp add: spec_def)

(*While loop and extensive records of state. Read chapters 0-4.*)

end


theory Bounded_Copy_SST_Transducer
  imports Main HOL.Finite_Set
          "../Core/Update" "../Composition/Compose_SST_Transducer" "../Single_Use/Single_Use"
begin

lemma count_list_H:
  "count_list (extract_variables (Transducer.hat2 (delta2f f tr) (eta2f to) (q, u))) (q0, x0)
 \<le> count_list (extract_variables u) x0"
  by (induct u arbitrary: q rule: xa_induct, simp_all add: Nat.le_SucI)

lemma compose_reachable:
  assumes "reachable (compose_SST_Transducer sst td) (q1, f)"
  shows "reachable sst q1"
  unfolding reachable_def
proof -
  obtain w where *: "(q1, f) = delta_hat (compose_SST_Transducer sst td)
                                (initial (compose_SST_Transducer sst td), w)"
    using assms unfolding reachable_def by auto
  show "\<exists>w. q1 = delta_hat sst (initial sst, w)" proof
    show "q1 = delta_hat sst (initial sst, w)"
      using * by (simp add: compose_\<delta>_hat compose_SST_Transducer_def)
  qed
qed

theorem compose_SST_Transducer_bounded:
  fixes sst :: "('q1::finite, 'x::finite, 'a, 'b) SST"
  fixes td  :: "('q2::finite, 'b, 'c) transducer"
  assumes "bounded_copy_SST k sst"
  shows "bounded_copy_SST (card (UNIV::'q2 set) * k) (compose_SST_Transducer sst td)"
proof (simp add: bounded_copy_SST_def, intro allI, rule impI)
  fix w qs f
  let ?tr = "delta td" and ?to = "transducer.eta td"
  let ?xi = "SST.eta_hat sst (qs, w)"
  assume r0: "reachable (compose_SST_Transducer sst td) (qs, f)"
  have reach: "reachable sst qs" by (rule compose_reachable, rule r0)
  show "bounded (card (UNIV::'q2 set) * k) (SST.eta_hat (compose_SST_Transducer sst td) ((qs, f), w))"
    unfolding compose_SST_Transducer_def bounded_def count_var_def
  proof (simp add: compose_\<eta>_hat, intro allI)
    fix q0 x0
    have "(\<Sum>y\<in>(UNIV::('q2\<times>'x)set). count_list (extract_variables (H ?tr ?to (f, ?xi) y)) (q0, x0))
        = (\<Sum>q\<in>(UNIV::'q2 set). \<Sum>x\<in>(UNIV::'x set). count_list (extract_variables (H ?tr ?to (f, ?xi) (q, x))) (q0, x0))"
      by (simp add: sum.Sigma)
    also have "... = (\<Sum>q\<in>(UNIV::'q2 set). \<Sum>x\<in>(UNIV::'x set).
                         count_list (extract_variables (Transducer.hat2 (delta2f f ?tr) (eta2f ?to) (q, ?xi x))) (q0, x0))"
      by (simp add: H_def)
    also have "... \<le> (\<Sum>q\<in>(UNIV::'q2 set). \<Sum>x\<in>(UNIV::'x set).
                         count_list (extract_variables (?xi x)) x0)" by (intro sum_mono, rule count_list_H)
    also have "... = card (UNIV::'q2 set) * (\<Sum>x\<in>(UNIV::'x set). count_list (extract_variables (?xi x)) x0)" by (simp)
    also have "... \<le> card (UNIV::'q2 set) * k"
      using assms reach unfolding bounded_copy_SST_def bounded_def count_var_def
      by (simp add: reach)
    finally show "(\<Sum>y\<in>(UNIV::('q2\<times>'x)set). count_list (extract_variables (H ?tr ?to (f, ?xi) y)) (q0, x0))
                \<le> card (UNIV::'q2 set) * k" .
  qed
qed

end


(*  Title:      HOL/Nitpick_Examples/Special_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's "specialize" optimization.
*)

section {* Examples Featuring Nitpick's \textit{specialize} Optimization *}

theory Special_Nits
imports Main
begin

nitpick_params [verbose, card = 4, sat_solver = MiniSat_JNI, max_threads = 1,
                timeout = 240]

fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f1 a b c d e = a + b + c + d + e"

lemma "f1 0 0 0 0 0 = f1 0 0 0 0 (1 - 1)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f1 u v w x y = f1 y x w v u"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f2 a b c d (Suc e) = a + b + c + d + e"

lemma "f2 0 0 0 0 0 = f2 (1 - 1) 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 0 (v - v) 0 (x - x) 0 = f2 (u - u) 0 (w - w) 0 (y - y)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f2 1 0 0 0 0 = f2 0 1 0 0 0"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f2 0 0 0 0 0 = f2 0 0 0 0 0"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

fun f3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"f3 (Suc a) b 0 d (Suc e) = a + b + d + e" |
"f3 0 b 0 d 0 = b + d"

lemma "f3 a b c d e = f3 e d c b a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "f3 a b c d a = f3 a d c d a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "\<lbrakk>c < 1; a \<ge> e; e \<ge> a\<rbrakk> \<Longrightarrow> f3 a b c d a = f3 e d c b e"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "(\<forall>u. a = u \<longrightarrow> f3 a a a a a = f3 u u u u u)
       \<and> (\<forall>u. b = u \<longrightarrow> f3 b b u b b = f3 u u b u u)"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

function f4 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"f4 x x = 1" |
"f4 y z = (if y = z then 1 else 0)"
by auto
termination by lexicographic_order

lemma "f4 a b = f4 b a"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "f4 a (Suc a) = f4 a a"
nitpick [expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

fun f5 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
"f5 f (Suc a) = f a"

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) (Suc x) = x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<exists>one \<in> {1}. \<exists>two \<in> {2}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<exists>two \<in> {2}. \<exists>one \<in> {1}.
       f5 (\<lambda>a. if a = one then 2 else if a = two then 1 else a) (Suc x) = x"
nitpick [expect = genuine]
oops

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {1}. \<exists>two \<in> {2}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = none]
nitpick [dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>one \<in> {2}. \<exists>two \<in> {1}. f5 g x =
                      f5 (\<lambda>a. if a = one then 1 else if a = two then 2 else a) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = potential]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11\<Colon>nat).
           b\<^sub>1 < b\<^sub>11 \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then a else h b\<^sub>2) x"
nitpick [expect = potential]
nitpick [dont_specialize, expect = none]
nitpick [dont_box, expect = none]
nitpick [dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11\<Colon>nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 < b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = none]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize, expect = none]
sorry

lemma "\<forall>a. g a = a
       \<Longrightarrow> \<exists>b\<^sub>1 b\<^sub>2 b\<^sub>3 b\<^sub>4 b\<^sub>5 b\<^sub>6 b\<^sub>7 b\<^sub>8 b\<^sub>9 b\<^sub>10 (b\<^sub>11\<Colon>nat).
           b\<^sub>1 < b\<^sub>11
           \<and> f5 g x = f5 (\<lambda>a. if b\<^sub>1 \<ge> b\<^sub>11 then
                                a
                              else
                                h b\<^sub>2 + h b\<^sub>3 + h b\<^sub>4 + h b\<^sub>5 + h b\<^sub>6 + h b\<^sub>7 + h b\<^sub>8
                                + h b\<^sub>9 + h b\<^sub>10) x"
nitpick [card nat = 2, card 'a = 1, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_specialize, expect = potential]
nitpick [card nat = 2, card 'a = 1, dont_box, dont_specialize,
         expect = potential]
oops

end