theory SymExec
imports Conf Labels
begin

subsection \<open>Symbolic Execution\<close>

text \<open>We model symbolic execution by an inductive predicate @{term "se"} which takes two
configurations @{term "c\<^sub>1"} and @{term "c\<^sub>2"} and a label @{term "l"} and evaluates to \emph{true} if
and only if @{term "c\<^sub>2"} is a \emph{possible result} of the symbolic execution of @{term "l"} from
@{term "c\<^sub>1"}. We say that @{term "c\<^sub>2"} is a possible result because, when @{term "l"} is of the
form @{term "Assign v e"}, we associate a fresh symbolic variable to the program variable @{term "v"},
but we do no specify how this fresh variable is chosen (see the two assumptions in the third case).
We could have model @{term "se"} (and @{term "se_star"}) by a function producing the new
configuration, instead of using inductive predicates. However this would require to provide the two
said assumptions in each lemma involving @{term se}, which is not necessary using a predicate. Modeling
symbolic execution in this way has the advantage that it simplifies the following proofs while not
requiring additional lemmas.\<close>

subsubsection \<open>Definitions of $\mathit{se}$ and $\mathit{se\_star}$\<close>

text \<open>Symbolic execution of @{term "Skip"} does not change the configuration from which it is
performed.\<close>

text \<open>When the label
is of the form @{term "Assume e"}, the adaptation of @{term "e"} to the store is added to the
@{term "pred"} component.\<close>

text \<open>In the case of an assignment, the @{term "store"} component is updated
such that it now maps a fresh symbolic variable to the assigned program variable. A constraint
relating this program variable with its new symbolic value is added to the @{term "pred"}
component.\<close>

text \<open>The second assumption in the third case requires that there exists at least one fresh
symbolic variable for @{term "c"}. In the following, a number of theorems are needed
to show that such variables exist for the configurations on which symbolic execution is performed.
\<close>

inductive se ::
  "('v,'d) conf \<Rightarrow> ('v,'d) label \<Rightarrow> ('v,'d) conf \<Rightarrow> bool"
where
  "se c Skip c"

| "se c (Assume e) \<lparr> store = store c, pred = pred c \<union> {adapt_bexp e (store c)} \<rparr>"

| "fst sv = v        \<Longrightarrow>
   fresh_symvar sv c \<Longrightarrow>
   se c (Assign v e) \<lparr> store = (store c)(v := snd sv),
                       pred  = pred c \<union> {(\<lambda> \<sigma>. \<sigma> sv = (adapt_aexp e (store c)) \<sigma>)} \<rparr>"

text \<open>In the same spirit, we extend symbolic execution to sequence of labels.\<close>

inductive se_star :: "('v,'d) conf \<Rightarrow> ('v,'d) label list \<Rightarrow> ('v,'d) conf \<Rightarrow> bool" where
  "se_star c [] c"
| "se c1 l c2 \<Longrightarrow> se_star c2 ls c3 \<Longrightarrow> se_star c1 (l # ls) c3"

subsubsection \<open>Basic properties of $\mathit{se}$\<close>

text \<open>If symbolic execution yields a satisfiable configuration, then it has been performed from
a satisfiable configuration.\<close>

lemma se_sat_imp_sat :
  assumes "se c l c'"
  assumes "sat c'"
  shows   "sat c"
using assms by cases (auto simp add : sat_def conjunct_def)

text \<open>If symbolic execution is performed from an unsatisfiable configuration, then it will yield
an unsatisfiable configuration.\<close>

lemma unsat_imp_se_unsat :
  assumes "se c l c'"
  assumes "\<not> sat c"
  shows   "\<not> sat c'"
using assms by cases (simp add : sat_def conjunct_def)+

text \<open>Given two configurations @{term "c"} and @{term "c'"} and a label @{term "l"} such that
@{term "se c l c'"}, the three following lemmas express @{term "c'"} as a function of @{term "c"}.\<close>

lemma [simp] :
  "se c Skip c' = (c' = c)"
by (simp add : se.simps)

lemma se_Assume_eq :
  "se c (Assume e) c' = (c' = \<lparr> store = store c, pred = pred c \<union> {adapt_bexp e (store c)} \<rparr>)"
by (simp add : se.simps)

lemma se_Assign_eq :
  "se c (Assign v e) c' =
  (\<exists> sv. fresh_symvar sv c
       \<and> fst sv = v
       \<and> c' = \<lparr> store = (store c)(v := snd sv),
                pred  = insert (\<lambda>\<sigma>. \<sigma> sv = adapt_aexp e (store c) \<sigma>) (pred c)\<rparr>)"
by (simp only : se.simps, blast)

text \<open>Given two configurations @{term "c"} and @{term "c'"} and a label @{term "l"} such that
@{term "se c l c'"}, the two following lemmas express the path predicate of @{term "c'"} as
a function of the path predicate of @{term "c"} when @{term "l"} models a guard or an
assignment.\<close>

lemma path_pred_of_se_Assume :
  assumes "se c (Assume e) c'"
  shows   "conjunct (pred c') =
            (\<lambda> \<sigma>. conjunct (pred c) \<sigma> \<and> adapt_bexp e (store c) \<sigma>)"
using assms se_Assume_eq[of c e c']
by (auto simp add : conjunct_def)

lemma path_pred_of_se_Assign :
  assumes "se c (Assign v e) c'"
  shows   "\<exists> sv. conjunct (pred c') =
            (\<lambda> \<sigma>. conjunct (pred c) \<sigma> \<and> \<sigma> sv = adapt_aexp e (store c) \<sigma>)"
using assms se_Assign_eq[of c v e c']
by (fastforce simp add : conjunct_def)

text \<open>Let @{term "c"} and @{term "c'"} be two configurations  such that @{term "c'"} is obtained
from @{term "c"} by symbolic execution of a label of the form @{term "Assume e"}. The states of
@{term "c'"} are the states of @{term "c"} that satisfy @{term "e"}. This theorem will help prove
that symbolic execution is monotonic wrt.\ subsumption.\<close>

theorem states_of_se_assume :
  assumes "se c (Assume e) c'"
  shows   "states c' = {\<sigma> \<in> states c. e \<sigma>}"
using assms se_Assume_eq[of c e c']
by (auto simp add : adapt_bexp_is_subst states_def conjunct_def)

text \<open>Let @{term "c"} and @{term "c'"} be two configurations  such that @{term "c'"} is obtained
from @{term "c"} by symbolic execution of a label of the form @{term "Assign v e"}. We want to
express the set of states of @{term "c'"} as a function of the set of states of @{term "c"}. Since
the proof requires a number of details, we split into two sub lemmas.\<close>

text \<open>First, we show that if @{term "\<sigma>'"} is a state of @{term "c'"}, then it has been obtain from
an adequate update of a state @{term "\<sigma>"} of @{term "c"}.\<close>

lemma states_of_se_assign1 :
  assumes "se c (Assign v e) c'"
  assumes "\<sigma>' \<in> states c'"
  shows   "\<exists> \<sigma> \<in> states c. \<sigma>' = (\<sigma> (v := e \<sigma>))"
proof -
  obtain \<sigma>\<^sub>s\<^sub>y\<^sub>m
  where 1 : "consistent \<sigma>' \<sigma>\<^sub>s\<^sub>y\<^sub>m (store c')"
  and   2 : "conjunct (pred c') \<sigma>\<^sub>s\<^sub>y\<^sub>m"
  using assms(2) unfolding states_def by blast

  then obtain \<sigma>
  where 3 : "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m (store c)"
  using consistentI2 by blast

  moreover
  have "conjunct (pred c) \<sigma>\<^sub>s\<^sub>y\<^sub>m"
  using assms(1) 2 by (auto simp add : se_Assign_eq conjunct_def)

  ultimately
  have "\<sigma> \<in> states c" by (simp add : states_def) blast

  moreover
  have "\<sigma>' = \<sigma> (v := e \<sigma>)"
  proof -
    have "\<sigma>' v = e \<sigma>"
    proof -
      have "\<sigma>' v = \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v (store c'))"
      using 1 by (simp add : consistent_def)

      moreover
      have "\<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar v (store c')) = (adapt_aexp e (store c)) \<sigma>\<^sub>s\<^sub>y\<^sub>m"
      using assms(1) 2 se_Assign_eq[of c v e c']
      by (force simp add : symvar_def conjunct_def)

      moreover
      have "(adapt_aexp e (store c)) \<sigma>\<^sub>s\<^sub>y\<^sub>m = e \<sigma>"
      using 3 by (rule adapt_aexp_is_subst)

      ultimately
      show ?thesis by simp
    qed

    moreover
    have "\<forall> x. x \<noteq> v \<longrightarrow> \<sigma>' x = \<sigma> x"
    proof (intro allI impI)
      fix x

      assume "x \<noteq> v"

      moreover
      hence "\<sigma>' x = \<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar x (store c))"
      using assms(1) 1 unfolding consistent_def symvar_def
      by (drule_tac ?x="x" in spec) (auto simp add : se_Assign_eq)

      moreover
      have "\<sigma>\<^sub>s\<^sub>y\<^sub>m (symvar x (store c)) = \<sigma> x"
      using 3 by (auto simp add : consistent_def)

      ultimately
      show "\<sigma>' x = \<sigma> x" by simp
    qed

    ultimately
    show ?thesis by auto
  qed

  ultimately
  show ?thesis by (simp add : states_def) blast
qed

text \<open>Then, we show that if there exists a state @{term "\<sigma>"} of @{term "c"} from which
@{term "\<sigma>'"} is obtained by an adequate update, then @{term "\<sigma>'"} is a state of @{term "c'"}.\<close>

lemma states_of_se_assign2 :
  assumes "se c (Assign v e) c'"
  assumes "\<exists> \<sigma> \<in> states c. \<sigma>' = \<sigma> (v := e \<sigma>)"
  shows   "\<sigma>' \<in> states c'"
proof -
  obtain \<sigma>
  where "\<sigma> \<in> states c"
  and   "\<sigma>' = \<sigma> (v := e \<sigma>)"
  using assms(2) by blast

  then obtain \<sigma>\<^sub>s\<^sub>y\<^sub>m
  where 1 : "consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m (store c)"
  and   2 : "conjunct (pred c) \<sigma>\<^sub>s\<^sub>y\<^sub>m"
  unfolding states_def by blast

  obtain sv
  where 3 : "fresh_symvar sv c"
  and   4 : "fst sv = v"
  and   5 : "c' = \<lparr> store = (store c)(v := snd sv),
                    pred    = insert (\<lambda>\<sigma>. \<sigma> sv = adapt_aexp e (store c) \<sigma>) (pred c) \<rparr>"
  using assms(1) se_Assign_eq[of c v e c'] by blast

  define \<sigma>\<^sub>s\<^sub>y\<^sub>m' where "\<sigma>\<^sub>s\<^sub>y\<^sub>m' = \<sigma>\<^sub>s\<^sub>y\<^sub>m (sv := e \<sigma>)"

  have "consistent \<sigma>' \<sigma>\<^sub>s\<^sub>y\<^sub>m' (store c')"
  using \<open>\<sigma>' = \<sigma> (v := e \<sigma>)\<close> 1 4 5
  by (auto simp add : symvar_def consistent_def \<sigma>\<^sub>s\<^sub>y\<^sub>m'_def)

  moreover
  have "conjunct (pred c') \<sigma>\<^sub>s\<^sub>y\<^sub>m'"
  proof -
    have "conjunct (pred c) \<sigma>\<^sub>s\<^sub>y\<^sub>m'"
    using 2 3 by (simp add : fresh_symvar_def symvars_def Bexp.vars_def \<sigma>\<^sub>s\<^sub>y\<^sub>m'_def)

    moreover
    have "\<sigma>\<^sub>s\<^sub>y\<^sub>m' sv = (adapt_aexp e (store c)) \<sigma>\<^sub>s\<^sub>y\<^sub>m'"
    proof -
      have "Aexp.fresh sv (adapt_aexp e (store c))"
      using 3 symvars_of_adapt_aexp[of e "store c"]
      by (auto simp add : fresh_symvar_def symvars_def)

      thus ?thesis
      using adapt_aexp_is_subst[OF 1, of e]
      by (simp add : Aexp.vars_def \<sigma>\<^sub>s\<^sub>y\<^sub>m'_def)
    qed

    ultimately
    show ?thesis using 5 by (simp add: conjunct_def)
  qed

  ultimately
  show ?thesis unfolding states_def by blast
qed

text \<open>The following theorem expressing the set of states of @{term c'} as a function of the set
of states of @{term c} trivially follows the two preceding lemmas.\<close>

theorem states_of_se_assign :
  assumes "se c (Assign v e) c'"
  shows   "states c' = {\<sigma> (v := e \<sigma>) | \<sigma>. \<sigma> \<in> states c}"
using assms states_of_se_assign1 states_of_se_assign2 by fast

subsubsection \<open>Monotonicity of $\mathit{se}$\<close>

text \<open>We are now ready to prove that symbolic execution is monotonic with respect to subsumption.
\<close>

theorem se_mono_for_sub :
  assumes "se c1 l c1'"
  assumes "se c2 l c2'"
  assumes "c2 \<sqsubseteq> c1"
  shows   "c2' \<sqsubseteq> c1'"
using assms
by ((cases l),
    (simp add : ),
    (simp add : states_of_se_assume subsums_def, blast),
    (simp add : states_of_se_assign subsums_def, blast))

text \<open>A stronger version of the previous theorem: symbolic execution is monotonic with respect to
states equality.\<close>

theorem se_mono_for_states_eq :
  assumes "states c1 = states c2"
  assumes "se c1 l c1'"
  assumes "se c2 l c2'"
  shows   "states c2' = states c1'"
using assms(1)
      se_mono_for_sub[OF assms(2,3)]
      se_mono_for_sub[OF assms(3,2)]
by (simp add : subsums_def)

text \<open>The previous theorem confirms the fact that the way the fresh symbolic variable is chosen
in the case of symbolic execution of an assignment does not matter as long as the new symbolic
variable is indeed fresh, which is more precisely expressed by the following lemma.\<close>

lemma se_succs_states :
  assumes "se c l c1"
  assumes "se c l c2"
  shows   "states c1 = states c2"
using assms se_mono_for_states_eq by fast

subsubsection \<open>Basic properties of $\mathit{se\_star}$\<close>

text \<open>Some simplification lemmas for @{term "se_star"}.\<close>

lemma [simp] :
  "se_star c [] c' = (c' = c)"
by (subst se_star.simps) auto

lemma se_star_Cons :
  "se_star c1 (l # ls) c2 = (\<exists> c. se c1 l c \<and> se_star c ls c2)"
by (subst (1) se_star.simps) blast

lemma se_star_one :
  "se_star c1 [l] c2 = se c1 l c2"
using se_star_Cons by force

lemma se_star_append :
  "se_star c1 (ls1 @ ls2) c2 = (\<exists> c. se_star c1 ls1 c \<and> se_star c ls2 c2)"
by (induct ls1 arbitrary : c1, simp_all add : se_star_Cons) blast

lemma se_star_append_one :
  "se_star c1 (ls @ [l]) c2 = (\<exists> c. se_star c1 ls c \<and> se c l c2)"
unfolding se_star_append se_star_one by (rule refl)

text \<open>Symbolic execution of a sequence of labels from an unsatisfiable configuration yields
an unsatisfiable configuration.\<close>

lemma unsat_imp_se_star_unsat :
  assumes "se_star c ls c'"
  assumes "\<not> sat c"
  shows   "\<not> sat c'"
using assms
by (induct ls arbitrary : c)
   (simp, force simp add : se_star_Cons unsat_imp_se_unsat)

text \<open>If symbolic execution yields a satisfiable configuration, then it has been performed from
a satisfiable configuration.\<close>

lemma se_star_sat_imp_sat :
  assumes "se_star c ls c'"
  assumes "sat c'"
  shows   "sat c"
using assms
by (induct ls arbitrary : c)
   (simp, force simp add : se_star_Cons se_sat_imp_sat)

subsubsection \<open>Monotonicity of $\mathit{se\_star}$\<close>

text \<open>Monotonicity of @{term "se"} extends to @{term "se_star"}.\<close>

lemma se_star_mono_for_states_eq :
  assumes "states c1 = states c2"
  assumes "se_star c1 ls c1'"
  assumes "se_star c2 ls c2'"
  shows   "states c2' = states c1'"
using assms(1)
      se_star_mono_for_sub[OF assms(2,3)]
      se_star_mono_for_sub[OF assms(3,2)]
by (simp add : subsums_def)

lemma se_star_succs_states :
  assumes "se_star c ls c1"
  assumes "se_star c ls c2"
  shows   "states c1 = states c2"
using assms se_star_mono_for_states_eq by fast

subsubsection \<open>Existence of successors\<close>

text \<open>Here, we are interested in proving that, under certain assumptions, there will always exist
fresh symbolic variables for configurations on which symbolic execution is performed. Thus symbolic
execution cannot ``block'' when an assignment is met. For symbolic execution not to block in this
case, the configuration from which it is performed must be such that there exist fresh symbolic
variables for each program variable. Such configurations are said to be \emph{updatable}.\<close>

definition updatable ::
  "('v,'d) conf \<Rightarrow> bool"
where
  "updatable c \<equiv> \<forall> v. \<exists> sv. fst sv = v \<and> fresh_symvar sv c"

text \<open>The following lemma shows that being updatable is a sufficient condition for a configuration
in order for @{term "se"} not to block.\<close>

lemma updatable_imp_ex_se_suc :
  assumes "updatable c"
  shows   "\<exists> c'. se c l c'"
using assms
by (cases l, simp_all add :  se_Assume_eq se_Assign_eq updatable_def)

text \<open>A sufficient condition for a configuration to be updatable is that its path predicate has
a finite number of variables. The @{term "store"} component has no influence here, since its set of
symbolic variables is always a strict subset of the set of symbolic variables (i.e.\ there always
exist fresh symbolic variables for a store). To establish this proof, we need the following
intermediate lemma.\<close>

text \<open>We want to prove that if the set of symbolic variables of the path predicate of a
configuration is finite, then we can find a fresh symbolic variable for it. However, we express this
with a more general lemma. We show that given a finite set of symbolic variables @{term "SV"} and a
program variable @{term "v"} such that there exist symbolic variables in @{term "SV"} that are
indexed versions of @{term "v"}, then there exists a symbolic variable for @{term "v"} whose index
is greater or equal than the index of any other symbolic variable for @{term "v"} in @{term SV}.\<close>

lemma finite_symvars_imp_ex_greatest_symvar :
  fixes SV :: "'a symvar set"
  assumes "finite SV"
  assumes "\<exists> sv \<in> SV. fst sv = v"
  shows   "\<exists> sv  \<in> {sv \<in> SV. fst sv = v}.
           \<forall> sv' \<in> {sv \<in> SV. fst sv = v}. snd sv' \<le> snd sv"
proof -
  have "finite (snd ` {sv \<in> SV. fst sv = v})"
  and  "snd ` {sv \<in> SV. fst sv = v} \<noteq> {}"
  using assms by auto

  moreover
  have "\<forall> (E::nat set). finite E \<and> E \<noteq> {} \<longrightarrow> (\<exists> n \<in> E. \<forall> m \<in> E. m \<le> n)"
  by (intro allI impI, induct_tac rule : finite_ne_induct)
     (simp+, force)

  ultimately
  obtain n
  where "n \<in> snd ` {sv \<in> SV. fst sv = v}"
  and   "\<forall> m \<in> snd ` {sv \<in> SV. fst sv = v}. m \<le> n"
  by blast

  moreover
  then obtain sv
  where "sv \<in> {sv \<in> SV. fst sv = v}" and "snd sv = n"
  by blast

  ultimately
  show ?thesis by blast
qed

text \<open>Thus, a configuration whose path predicate has a finite set of variables is updatable. For
example, for any program variable @{term "v"}, the symbolic variable  \<open>(v,i+1)\<close> is fresh for
this configuration, where @{term "i"} is the greater index associated to @{term "v"} among the
symbolic variables of this configuration. In practice, this is how we choose the fresh symbolic
variable.\<close>

lemma finite_pred_imp_se_updatable :
  assumes "finite (Bexp.vars (conjunct (pred c)))" (is "finite ?V")
  shows   "updatable c"
unfolding updatable_def
proof (intro allI)
  fix v

  show "\<exists>sv. fst sv = v \<and> fresh_symvar sv c"
  proof (case_tac "\<exists> sv \<in> ?V. fst sv = v", goal_cases)
    case 1

    then obtain max_sv
    where       "max_sv \<in> ?V"
    and         "fst max_sv = v"
    and   max : "\<forall>sv'\<in>{sv \<in> ?V. fst sv = v}. snd sv' \<le> snd max_sv"
    using assms finite_symvars_imp_ex_greatest_symvar[of ?V v]
    by blast

    show ?thesis
    using max
    unfolding fresh_symvar_def symvars_def Store.symvars_def symvar_def
    proof (case_tac "snd max_sv \<le> store c v", goal_cases)
      case 1 thus ?case by (rule_tac ?x="(v,Suc (store c v))" in exI) auto
    next
      case 2 thus ?case by (rule_tac ?x="(v,Suc (snd max_sv))" in exI) auto
    qed
  next
    case 2 thus ?thesis
    by (rule_tac ?x="(v, Suc (store c v))" in exI)
       (auto simp add : fresh_symvar_def symvars_def Store.symvars_def symvar_def)
  qed
qed

text \<open>The path predicate of a configuration whose @{term "pred"} component is finite and whose
elements all have finite sets of variables has a finite set of variables. Thus, this configuration
is updatable, and it has a successor by symbolic execution of any label. The following lemma
starts from these two assumptions and use the previous ones in order to directly get to the
conclusion (this will ease some of the following proofs).\<close>

lemma finite_imp_ex_se_succ :
  assumes "finite (pred c)"
  assumes "\<forall> e \<in> pred c. finite (Bexp.vars e)"
  shows   "\<exists> c'. se c l c'"
using finite_pred_imp_se_updatable[OF finite_conj[OF assms(1,2)]]
by (rule updatable_imp_ex_se_suc)

text \<open>For symbolic execution not to block \emph{along a sequence of labels}, it is not sufficient
for the first configuration to be updatable. It must also be such that (all) its successors are
updatable. A sufficient condition for this is that the set of variables of its path predicate is
finite and that the sub-expression of the label that is executed also has a finite set of variables.
Under these assumptions, symbolic execution preserves finiteness of the @{term "pred"} component and
of the sets of variables of its elements. Thus, successors @{term "se"} are also updatable because
they also have a path predicate with a finite set of variables. In the following, to prove
this we need two intermediate lemmas:
\begin{itemize}
  \item one stating that symbolic execution perserves the finiteness of the set of variables of the
elements of the @{term "pred"} component, provided that the sub expression of the label that is
executed has a finite set of variables,
  \item one stating that symbolic execution preserves the finiteness of the @{term "pred"}
component.
\end{itemize}\<close>

lemma se_preserves_finiteness1 :
  assumes "finite_label l"
  assumes "se c l c'"
  assumes "\<forall> e \<in> pred c.  finite (Bexp.vars e)"
  shows   "\<forall> e \<in> pred c'. finite (Bexp.vars e)"
proof (cases l)
  case Skip thus ?thesis using assms by (simp add : )
next
  case (Assume e) thus ?thesis
  using assms finite_vars_imp_finite_adapt_b
  by (auto simp add : se_Assume_eq finite_label_def)
next
  case (Assign v e)

  then obtain sv
  where "fresh_symvar sv c"
  and   "fst sv = v"
  and   "c' = \<lparr> store = (store c)(v := snd sv),
                pred  = insert (\<lambda>\<sigma>. \<sigma> sv = adapt_aexp e (store c) \<sigma>) (pred c)\<rparr>"
  using assms(2) se_Assign_eq[of c v e c'] by blast

  moreover
  have "finite (Bexp.vars (\<lambda>\<sigma>. \<sigma> sv = adapt_aexp e (store c) \<sigma>))"
  proof -
    have "finite (Aexp.vars (\<lambda>\<sigma>. \<sigma> sv))"
    by (auto simp add : Aexp.vars_def)

    moreover
    have "finite (Aexp.vars (adapt_aexp e (store c)))"
    using assms(1) Assign finite_vars_imp_finite_adapt_a
    by (auto simp add : finite_label_def)

    ultimately
    show ?thesis using finite_vars_of_a_eq by auto
  qed

  ultimately
  show ?thesis using assms by auto
qed

lemma se_preserves_finiteness2 :
  assumes "se c l c'"
  assumes "finite (pred c)"
  shows   "finite (pred c')"
using assms
by (cases l)
   (auto simp add :  se_Assume_eq se_Assign_eq)

text \<open>We are now ready to prove that a sufficient condition for symbolic execution not to block
along a sequence of labels is that the @{term "pred"} component of the ``initial
configuration'' is finite, as well as the set of variables of its elements,  and that the
sub-expression of the label that is executed also has a finite set of variables.\<close>

lemma finite_imp_ex_se_star_succ :
  assumes "finite (pred c)"
  assumes "\<forall> e \<in> pred c. finite (Bexp.vars e)"
  assumes "finite_labels ls"
  shows   "\<exists> c'. se_star c ls c'"
using assms
proof (induct ls arbitrary : c, goal_cases)
  case 1 show ?case using se_star.simps by blast
next
  case (2 l ls c)

  then obtain c1 where "se c l c1" using finite_imp_ex_se_succ by blast

  hence "finite (pred c1)"
  and   "\<forall> e \<in> pred c1. finite (Bexp.vars e)"
  using 2 se_preserves_finiteness1 se_preserves_finiteness2 by fastforce+

  moreover
  have "finite_labels ls" using 2 by simp

  ultimately
  obtain c2 where "se_star c1 ls c2" using 2 by blast

  thus ?case using \<open>se c l c1\<close> using se_star_Cons by blast
qed

subsection \<open>Feasibility of a sequence of labels\<close>

text \<open>A sequence of labels @{term "ls"} is said to be feasible from a configuration @{term "c"}
if there exists a satisfiable configuration @{term "c'"} obtained by symbolic execution of
@{term "ls"} from @{term "c"}.\<close>

definition feasible :: "('v,'d) conf \<Rightarrow> ('v,'d) label list \<Rightarrow> bool" where
  "feasible c ls \<equiv> (\<exists> c'. se_star c ls c' \<and> sat c')"

text \<open>A simplification lemma for the case where @{term "ls"} is not empty.\<close>

lemma feasible_Cons :
  "feasible c (l#ls) = (\<exists> c'. se c l c' \<and> sat c' \<and> feasible c' ls)"
proof (intro iffI, goal_cases)
  case 1 thus ?case
  using se_star_sat_imp_sat by (simp add : feasible_def se_star_Cons) blast
next
  case 2 thus ?case
  unfolding feasible_def se_star_Cons by blast
qed

text \<open>The following theorem is very important for the rest of this formalization. It states that,
given two
configurations @{term "c1"} and @{term "c2"} such that @{term "c1"} subsums @{term "c2"}, then
any feasible sequence of labels from @{term "c2"} is also feasible from @{term "c1"}. This is a crucial
point in order to prove that our approach preserves the set of feasible paths of the original LTS.
This proof requires a number of assumptions about the finiteness of the sequence of labels, of
the path predicates of the two configurations and of their states of variables.
Those assumptions are needed in order to show that there exist successors of
both configurations by symbolic execution of the sequence of labels.\<close>

lemma subsums_imp_feasible :
  assumes "finite_labels ls"
  assumes "finite (pred c1)"
  assumes "finite (pred c2)"
  assumes "\<forall> e \<in> pred c1. finite (Bexp.vars e)"
  assumes "\<forall> e \<in> pred c2. finite (Bexp.vars e)"
  assumes "c2 \<sqsubseteq> c1"
  assumes "feasible c2 ls"
  shows   "feasible c1 ls"
using assms
proof (induct ls arbitrary : c1 c2)
  case Nil thus ?case by (simp add : feasible_def sat_sub_by_sat)
next
  case (Cons l ls c1 c2)

  then obtain c2' where "se c2 l c2'"
                  and   "sat c2'"
                  and   "feasible c2' ls"
  using feasible_Cons by blast

  obtain c1' where "se c1 l c1'"
  using finite_conj[OF Cons(3,5)]
        finite_pred_imp_se_updatable
        updatable_imp_ex_se_suc
  by blast

  moreover
  hence "sat c1'"
  using  se_mono_for_sub[OF _ \<open>se c2 l c2'\<close> Cons(7)]
         sat_sub_by_sat[OF \<open>sat c2'\<close>]
  by fast

  moreover
  have "feasible c1' ls"
  proof -

    have "finite_label  l"
    and  "finite_labels ls" using Cons(2) by simp_all

    have "finite (pred c1')"
    by (rule se_preserves_finiteness2[OF \<open>se c1 l c1'\<close> Cons(3)])

    moreover
    have "finite (pred c2')"
    by (rule se_preserves_finiteness2[OF \<open>se c2 l c2'\<close> Cons(4)])

    moreover
    have "\<forall>e\<in>pred c1'. finite (Bexp.vars e)"
    by (rule se_preserves_finiteness1[OF \<open>finite_label l\<close> \<open>se c1 l c1'\<close> Cons(5)])

    moreover
    have "\<forall>e\<in>pred c2'. finite (Bexp.vars e)"
    by (rule se_preserves_finiteness1[OF \<open>finite_label l\<close> \<open>se c2 l c2'\<close> Cons(6)])

    moreover
    have "c2' \<sqsubseteq> c1'"
    by (rule se_mono_for_sub[OF \<open>se c1 l c1'\<close> \<open>se c2 l c2'\<close> Cons(7)])

    ultimately
    show ?thesis using Cons(1) \<open>feasible c2' ls\<close> \<open>finite_labels ls\<close> by fast
  qed

  ultimately
  show ?case by (auto simp add : feasible_Cons)
qed

subsection \<open>Concrete execution\<close>

text \<open>We illustrate our notion of symbolic execution by relating it with @{term ce}, an inductive
predicate describing concrete execution. Unlike symbolic execution, concrete execution describes
program behavior given program states, i.e.\ concrete valuations for program variables. The
goal of this section is to show that our notion of symbolic execution is correct, that is: given two
configurations such that one results from the symbolic execution of a sequence of labels from the
other, then the resulting configuration represents the set of states that are reachable by
concrete execution from the states of the original configuration.\<close>

inductive ce ::
  "('v,'d) state \<Rightarrow> ('v,'d) label \<Rightarrow> ('v,'d) state \<Rightarrow> bool"
where
  "ce \<sigma> Skip \<sigma>"
| "e \<sigma> \<Longrightarrow> ce \<sigma> (Assume e) \<sigma>"
| "ce \<sigma> (Assign v e) (\<sigma>(v := e \<sigma>))"

inductive ce_star :: "('v,'d) state \<Rightarrow> ('v,'d) label list \<Rightarrow> ('v,'d) state \<Rightarrow> bool" where
  "ce_star c [] c"
| "ce c1 l c2 \<Longrightarrow> ce_star c2 ls c3 \<Longrightarrow> ce_star c1 (l # ls) c3"

lemma [simp] :
  "ce \<sigma> Skip \<sigma>' = (\<sigma>' = \<sigma>)"
by (auto simp add : ce.simps)

lemma [simp] :
  "ce \<sigma> (Assume e) \<sigma>' = (\<sigma>' = \<sigma> \<and> e \<sigma>)"
by (auto simp add : ce.simps)

lemma [simp] :
  "ce \<sigma> (Assign v e) \<sigma>' = (\<sigma>' = \<sigma>(v := e \<sigma>))"
by (auto simp add : ce.simps)

lemma se_as_ce :
  assumes "se c l c'"
  shows   "states c' = {\<sigma>'. \<exists> \<sigma> \<in> states c. ce \<sigma> l \<sigma>'} "
using assms
by (cases l)
   (auto simp add: states_of_se_assume states_of_se_assign)

lemma [simp] :
  "ce_star \<sigma> [] \<sigma>' = (\<sigma>' = \<sigma>)"
by (subst ce_star.simps) simp

lemma ce_star_Cons :
  "ce_star \<sigma>1 (l # ls) \<sigma>2 = (\<exists> \<sigma>. ce \<sigma>1 l \<sigma> \<and> ce_star \<sigma> ls \<sigma>2)"
by (subst (1) ce_star.simps) blast

lemma se_star_as_ce_star :
  assumes "se_star c ls c'"
  shows   "states c' = {\<sigma>'. \<exists> \<sigma> \<in> states c. ce_star \<sigma> ls \<sigma>'}"
using assms
proof (induct ls arbitrary : c)
  case Nil thus ?case by simp
next
  case (Cons l ls c)

  then obtain c'' where "se c l c''"
                  and   "se_star c'' ls c'"
  using se_star_Cons by blast

  show ?case
  unfolding set_eq_iff Bex_def mem_Collect_eq
  proof (intro allI iffI, goal_cases)
    case (1 \<sigma>')

    then obtain \<sigma>'' where "\<sigma>'' \<in> states c''"
                    and   "ce_star \<sigma>'' ls \<sigma>'"
    using Cons(1) \<open>se_star c'' ls c'\<close> by blast

    moreover
    then obtain \<sigma> where "\<sigma> \<in> states c"
                  and   "ce \<sigma> l \<sigma>''"
    using \<open>se c l c''\<close>  se_as_ce by blast

    ultimately
    show ?case by (simp add: ce_star_Cons) blast
  next
    case (2 \<sigma>')

    then obtain \<sigma> where "\<sigma> \<in> states c"
                  and   "ce_star \<sigma> (l#ls) \<sigma>'"
    by blast

    moreover
    then obtain \<sigma>'' where "ce \<sigma> l \<sigma>''"
                    and   "ce_star \<sigma>'' ls \<sigma>'"
    using ce_star_Cons by blast

    ultimately
    show ?case
    using Cons(1) \<open>se_star c'' ls c'\<close> \<open>se c l c''\<close> by (auto simp add : se_as_ce)
  qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_NStoogeSort2Count
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function twoThirds :: "Nat => Nat" where
  "twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"
  by pat_completeness auto

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

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
  and nstoogesort2 :: "Nat list => Nat list"
  and nstooge2sort1 :: "Nat list => Nat list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

theorem property0 :
  "((count y (nstoogesort2 xs)) = (count y xs))"
  oops

end


theory Splay_Heap
imports Amor "~~/src/HOL/Library/Tree"
begin

section "Splay Heap"

text{* Splay heaps were invented by Okasaki~\cite{Okasaki}. *}

(* mv *)
fun (in linorder) bst_eq :: "'a tree \<Rightarrow> bool" where
"bst_eq Leaf \<longleftrightarrow> True" |
"bst_eq (Node l a r) \<longleftrightarrow>
 bst_eq l \<and> bst_eq r \<and> (\<forall>x\<in>set_tree l. x \<le> a) \<and> (\<forall>x\<in>set_tree r. a \<le> x)"

subsection{* Definition and Correctness *}

fun partition :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree * 'a tree" where
"partition p Leaf = (Leaf,Leaf)" |
"partition p (Node l a r) =
  (if a \<le> p then
     case r of
       Leaf \<Rightarrow> (Node l a r, Leaf) |
       Node rl b rr \<Rightarrow>
         if b \<le> p
         then let (rrl,rrr) = partition p rr in (Node (Node l a rl) b rrl, rrr)
         else let (rll,rlr) = partition p rl in (Node l a rll, Node rlr b rr)
   else case l of
       Leaf \<Rightarrow> (Leaf, Node l a r) |
       Node ll b lr \<Rightarrow>
         if b \<le> p
         then let (lrl,lrr) = partition p lr in (Node ll b lrl, Node lrr a r)
         else let (lll,llr) = partition p ll in (lll, Node llr b (Node lr a r)))"

definition insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x h = (let (l,r) = partition x h in Node l x r)"

fun del_min :: "'a::linorder tree \<Rightarrow> 'a tree" where
"del_min Leaf = Leaf" |
"del_min (Node Leaf _ r) = r" |
"del_min (Node (Node Leaf _ l) b r) = Node l b r" |
"del_min (Node (Node ll a lr) b r) = Node (del_min ll) a (Node lr b r)"

lemma size_partition: "partition p t = (l',r') \<Longrightarrow> size t = size l' + size r'"
by (induction p t arbitrary: l' r' rule: partition.induct)
   (auto split: if_splits tree.splits prod.splits)

lemma set_partition: "\<lbrakk> bst_eq(t); partition p t = (l',r') \<rbrakk>
 \<Longrightarrow> set_tree t = set_tree l' \<union> set_tree r'"
proof(induction p t arbitrary: l' r' rule: partition.induct)
  case 1 thus ?case by simp
next
  case (2 p l a r)
  show ?case
  proof cases
    assume "a \<le> p"
    show ?thesis
    proof (cases r)
      case Leaf thus ?thesis using `a \<le> p` "2.prems" by auto
    next
      case (Node rl b rr)
      show ?thesis
      proof cases
        assume "b \<le> p"
        thus ?thesis using Node `a \<le> p` "2.prems" "2.IH"(1)[OF _ Node]
          by (auto split: prod.splits)
      next
        assume "\<not> b \<le> p"
        thus ?thesis using Node `a \<le> p` "2.prems" "2.IH"(2)[OF _ Node]
          by (auto split: prod.splits)
      qed
    qed
  next
    assume "\<not> a \<le> p"
    show ?thesis
    proof (cases l)
      case Leaf thus ?thesis using `\<not> a \<le> p` "2.prems" by auto
    next
      case (Node ll b lr)
      show ?thesis
      proof cases
        assume "b \<le> p"
        thus ?thesis using Node `\<not> a \<le> p` "2.prems" "2.IH"(3)[OF _ Node]
          by (auto split: prod.splits)
      next
        assume "\<not> b \<le> p"
        thus ?thesis using Node `\<not> a \<le> p` "2.prems" "2.IH"(4)[OF _ Node]
          by (auto split: prod.splits)
      qed
    qed
  qed
qed

lemma bst_partition:
  "bst_eq(t) \<Longrightarrow> partition p t = (l',r') \<Longrightarrow> bst_eq (Node l' p r')"
proof(induction p t arbitrary: l' r' rule: partition.induct)
  case 1 thus ?case by simp
next
  case (2 p l a r)
  show ?case
  proof cases
    assume "a \<le> p"
    show ?thesis
    proof (cases r)
      case Leaf thus ?thesis using `a \<le> p` "2.prems" by fastforce
    next
      case (Node rl b rr)
      show ?thesis
      proof cases
        assume "b \<le> p"
        thus ?thesis
          using Node `a \<le> p` "2.prems" "2.IH"(1)[OF _ Node] set_partition[of rr]
          by (fastforce split: prod.splits)
      next
        assume "\<not> b \<le> p"
        thus ?thesis
          using Node `a \<le> p` "2.prems" "2.IH"(2)[OF _ Node] set_partition[of rl]
          by (fastforce split: prod.splits)
      qed
    qed
  next
    assume "\<not> a \<le> p"
    show ?thesis
    proof (cases l)
      case Leaf thus ?thesis using `\<not> a \<le> p` "2.prems" by fastforce
    next
      case (Node ll b lr)
      show ?thesis
      proof cases
        assume "b \<le> p"
        thus ?thesis
          using Node `\<not> a \<le> p` "2.prems" "2.IH"(3)[OF _ Node] set_partition[of lr]
          by (fastforce split: prod.splits)
      next
        assume "\<not> b \<le> p"
        thus ?thesis
          using Node `\<not> a \<le> p` "2.prems" "2.IH"(4)[OF _ Node] set_partition[of ll]
          by (fastforce split: prod.splits)
      qed
    qed
  qed
qed

lemma size_del_min[simp]: "size(del_min t) = size t - 1"
by(induction t rule: del_min.induct) auto

lemma set_del_min: "set_tree(del_min t) \<le> set_tree t"
by(induction t rule: del_min.induct) auto

lemma bst_del_min: "bst_eq t \<Longrightarrow> bst_eq(del_min t)"
apply(induction t rule: del_min.induct)
   apply simp
  apply simp
 apply simp
using set_del_min by fastforce

subsection{* Analysis *}

fun t_part :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_part p Leaf = 0" |
"t_part p (Node l a r) =
  (if a \<le> p then
     case r of
       Leaf \<Rightarrow> 0 |
       Node rl b rr \<Rightarrow> if b \<le> p then t_part p rr + 1 else t_part p rl + 1
   else case l of
       Leaf \<Rightarrow> 0 |
       Node ll b lr \<Rightarrow> if b \<le> p then t_part p lr + 1 else t_part p ll + 1)"

definition t_in :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_in x h = t_part x h"

fun t_dm :: "'a::linorder tree \<Rightarrow> nat" where
"t_dm Leaf = 0" |
"t_dm (Node Leaf _ r) = 0" |
"t_dm (Node (Node Leaf _ l) b r) = 0" |
"t_dm (Node (Node ll a lr) b r) = t_dm ll + 1"

abbreviation "\<phi> t == log 2 (size1 t)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l a r) = \<Phi> l + \<Phi> r + \<phi> (Node l a r)"

lemma add_log_log1:
  assumes "x > 0" "y > 0" shows "1 + log 2 x + log 2 y < 2 * log 2 (x+y)"
proof -
  have 1: "2*x*y < (x+y)^2" using assms
    by(simp add: numeral_eq_Suc algebra_simps add_pos_pos)
  show ?thesis
    apply(rule powr_less_cancel_iff[of 2, THEN iffD1])
     apply simp
    using assms 1 by(simp add: powr_add log_powr[symmetric] powr_numeral)
qed

lemma add_log_log2: assumes "x \<ge> 2" "y \<ge> 2"
  shows "1 + log 2 x + log 2 y \<le> 2 * log 2 (x + y - 1)"
proof-
  from assms have "2*x \<le> x*x" "2*y \<le> y*y" by simp_all
  hence 1: "2 * x * y \<le> (x + y - 1)^2"
    by(simp add: numeral_eq_Suc algebra_simps)
  show ?thesis
    apply(rule powr_le_cancel_iff[of 2, THEN iffD1])
     apply simp
    using assms 1 by(simp add: powr_add log_powr[symmetric] powr_numeral)
qed

lemma amor_del_min: "t_dm t + \<Phi> (del_min t) - \<Phi> t \<le> 2 * \<phi> t"
proof(induction t rule: del_min.induct)
  case (3 a l b r)
  let ?t = "Node (Node Leaf a l) b r"
  have 1: "log 2 (real (size1 l) + real (size1 r))
      \<le> 3 * log 2 (real (size1 l) + real (size1 r) + 1)" (is "?l \<le> 3 * ?r")
  proof -
    have "?l \<le> ?r" by(simp add: size1_def)
    also have "\<dots> \<le> 3 * ?r" by(simp)
    finally show ?thesis .
  qed
  have 2: "log 2 (real (size1 l) + 1) \<ge> 0" by simp
  thus ?case apply(simp add: real_of_nat_Suc) using 1 2 by linarith
next
  case (4 lx x ly a r b u)
  let ?l = "Node lx x ly"  let ?l' = "del_min ?l"
  let ?s = "Node ?l a r"  let ?t = "Node ?s b u"
  let ?s' = "Node r b u"  let ?t' = "Node ?l' b ?s'"
  have 1: "\<phi> ?t' < \<phi> ?t" by(simp add: size1_def)
  have 2: "\<phi> ?l < \<phi> ?s" by(simp add: size1_def)
  have 3: "log 2 (size1 ?l + size1 ?s') \<le> log 2 (size1 ?t)" by(simp add: size1_def)
  have "t_dm ?t + \<Phi> (del_min ?t) - \<Phi> ?t
      = 1 + t_dm ?l + \<Phi> (del_min ?t) - \<Phi> ?t" by simp
  also have "\<dots> \<le> 1 + 2 * \<phi> ?l + \<Phi> ?l - \<Phi> ?l'  + \<Phi> (del_min ?t) - \<Phi> ?t"
    using 4 by linarith
  also have "\<dots> = 1 + 2 * \<phi> ?l + \<phi> ?t' + \<phi> ?s' - \<phi> ?t - \<phi> ?s" by(simp)
  also have "\<dots> \<le> 1 + \<phi> ?l + \<phi> ?s'" using 1 2 by linarith
  also have "\<dots> < 2 * \<phi> ?t" using 3 add_log_log1[of "size1 ?l" "size1 ?s'"]
    by (simp add: size1_def real_of_nat_Suc)
  finally show ?case by simp
qed auto

lemma zig_zag:
fixes s u r r1' r2' T a b
defines "t == Node s a (Node u b r)" and "t' == Node (Node s a u) b r1'"
assumes "size r1' \<le> size r"
    "t_part p r + \<Phi> r1' + \<Phi> r2' - \<Phi> r \<le> 2 * \<phi> r"
shows "t_part p r + 1 + \<Phi> t' + \<Phi> r2' - \<Phi> t \<le> 2 * \<phi> t"
proof -
  have 1: "\<phi> r \<le> \<phi> (Node u b r)" by (simp add: size1_def)
  have 2: "log 2 (real (size1 s + size1 u + size1 r1')) \<le> \<phi> t"
    using assms(3) by (simp add: t_def size1_def)
  from add_log_log1[of "size1 s + size1 u" "size1 r"]
  have "1 + \<phi> r + log 2 (size1 s + size1 u) \<le> 2 * log 2 (size1 s + size1 u + size1 r)"
    by(simp add: size1_def real_of_nat_Suc)
  thus ?thesis using assms 1 2 by (simp add: real_of_nat_Suc algebra_simps)
qed

lemma zig_zig:
fixes s u r r1' r2' a b
defines "t \<equiv> Node s a (Node r b u)" and "t1' == Node s a r1'" and "t2' \<equiv> Node u b r2'"
assumes "size r = size r1' + size r2'"
    "t_part p r + \<Phi> r1' + \<Phi> r2' - \<Phi> r \<le> 2 * \<phi> r"
shows "t_part p r + 1 + \<Phi> t1' + \<Phi> t2' - \<Phi> t \<le> 2 * \<phi> t"
proof -
  have 1: "\<phi> r \<le> \<phi> (Node u b r)" by (simp add: size1_def)
  have 2: "\<phi> r \<le> \<phi> t" by (simp add: t_def size1_def)
  from add_log_log2[of "size1 s + size1 r1'" "size1 u + size1 r2'"]
  have "1 + log 2 (size1 s + size1 r1') + log 2 (size1 u + size1 r2') \<le> 2 * \<phi> t"
    by(simp add: assms(4) size1_def real_of_nat_Suc t_def ac_simps)
  thus ?thesis using assms 1 2 by (simp add: real_of_nat_Suc algebra_simps)
qed

lemma amor_partition: "bst_eq t \<Longrightarrow> partition p t = (l',r')
  \<Longrightarrow> t_part p t + \<Phi> l' + \<Phi> r' - \<Phi> t \<le> 2 * log 2 (size1 t)"
proof(induction p t arbitrary: l' r' rule: partition.induct)
  case 1 thus ?case by simp
next
  case (2 p l a r)
  show ?case
  proof cases
    assume "a \<le> p"
    show ?thesis
    proof (cases r)
      case Leaf thus ?thesis using `a \<le> p` "2.prems" by fastforce
    next
      case (Node rl b rr)[simp]
      let ?t = "Node l a r"
      show ?thesis
      proof cases
        assume "b \<le> p"
        with `a \<le> p` "2.prems" obtain rrl
          where 0: "partition p rr = (rrl, r')" "l' = Node (Node l a rl) b rrl"
          by (auto split: tree.splits prod.splits)
        have "size rrl \<le> size rr"
          using size_partition[OF 0(1)] by (simp add: size1_def)
        with 0 `a \<le> p` `b \<le> p` "2.prems"(1) "2.IH"(1)[OF _ Node , of rrl r']
          zig_zag[where s=l and u=rl and r=rr and r1'=rrl and r2'=r' and p=p, of a b]
        show ?thesis by (simp add: real_of_nat_Suc algebra_simps)
      next
        assume "\<not> b \<le> p"
        with `a \<le> p` "2.prems" obtain rll rlr
          where 0: "partition p rl = (rll, rlr)" "l' = Node l a rll" "r' = Node rlr b rr"
          by (auto split: tree.splits prod.splits)
        from 0 `a \<le> p` `\<not> b \<le> p` "2.prems"(1) "2.IH"(2)[OF _ Node, of rll rlr]
          size_partition[OF 0(1)]
          zig_zig[where s=l and u=rr and r=rl and r1'=rll and r2'=rlr and p=p, of a b]
        show ?thesis by (simp add: real_of_nat_Suc algebra_simps)
      qed
    qed
  next
    assume "\<not> a \<le> p"
    show ?thesis
    proof (cases l)
      case Leaf thus ?thesis using `\<not> a \<le> p` "2.prems" by fastforce
    next
      case (Node ll b lr)[simp]
      let ?t = "Node l a r"
      show ?thesis
      proof cases
        assume "b \<le> p"
        with `\<not> a \<le> p` "2.prems" obtain lrl lrr
          where 0: "partition p lr = (lrl, lrr)" "l' = Node ll b lrl" "r' = Node lrr a r"
          by (auto split: tree.splits prod.splits)
        from 0 `\<not> a \<le> p` `b \<le> p` "2.prems"(1) "2.IH"(3)[OF _ Node, of lrl lrr]
          size_partition[OF 0(1)]
          zig_zig[where s=r and u=ll and r=lr and r1'=lrr and r2'=lrl and p=p, of a b]
        show ?thesis by (auto simp: real_of_nat_Suc algebra_simps)
      next
        assume "\<not> b \<le> p"
        with `\<not> a \<le> p` "2.prems" obtain llr
          where 0: "partition p ll = (l',llr)" "r' = Node llr b (Node lr a r)"
          by (auto split: tree.splits prod.splits)
        have "size llr \<le> size ll"
          using size_partition[OF 0(1)] by (simp add: size1_def)
        with 0 `\<not> a \<le> p` `\<not> b \<le> p` "2.prems"(1) "2.IH"(4)[OF _ Node, of l' llr]
          zig_zag[where s=r and u=lr and r=ll and r1'=llr and r2'=l' and p=p, of a b]
        show ?thesis by (auto simp: real_of_nat_Suc algebra_simps)
      qed
    qed
  qed
qed

datatype 'a op\<^sub>p\<^sub>q = Insert 'a | Delmin

fun nxt\<^sub>p\<^sub>q :: "'a::linorder op\<^sub>p\<^sub>q \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"nxt\<^sub>p\<^sub>q (Insert a) h = insert a h" |
"nxt\<^sub>p\<^sub>q Delmin h = del_min h"

fun t\<^sub>p\<^sub>q :: "'a::linorder op\<^sub>p\<^sub>q \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t\<^sub>p\<^sub>q (Insert a) h = t_in a h" |
"t\<^sub>p\<^sub>q Delmin h = t_dm h"

interpretation splay_heap: amor
where init = "Leaf" and nxt = "nxt\<^sub>p\<^sub>q" and inv = "bst_eq"
and t = t\<^sub>p\<^sub>q and \<Phi> = \<Phi>
and U = "\<lambda>f s. case f of Delmin \<Rightarrow> 2 * \<phi> s | Insert _ \<Rightarrow> 3 * log 2 (size1 s + 1)"
proof
  case goal1 show ?case by simp
next
  case goal2 thus ?case
    by(cases f)
       (auto simp: insert_def bst_del_min dest: bst_partition split: prod.splits)
next
  case goal3 show ?case by(induction s) (auto simp: size1_def)
next
  case goal4 show ?case by(simp)
next
  case goal5
  show ?case
  proof (cases f)
    case Delmin with goal5 show ?thesis by(simp add: amor_del_min)
  next
    case (Insert x)
    { fix l r assume 1: "partition x s = (l,r)"
      have "log 2 (1 + size s) < log 2 (2 + size s)" by simp
      with 1 amor_partition[OF goal5 1] size_partition[OF 1] Insert have ?thesis
        by(simp add: t_in_def insert_def real_of_nat_Suc algebra_simps size1_def
             del: log_less_cancel_iff) }
    thus ?thesis using Insert by(simp add: insert_def split: prod.split)
  qed
qed

end


(*  Title:      CCL/Type.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section {* Types in CCL are defined as sets of terms *}

theory Type
imports Term
begin

consts

  Subtype       :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> 'a set"
  Bool          :: "i set"
  Unit          :: "i set"
  Plus           :: "[i set, i set] \<Rightarrow> i set"        (infixr "+" 55)
  Pi            :: "[i set, i \<Rightarrow> i set] \<Rightarrow> i set"
  Sigma         :: "[i set, i \<Rightarrow> i set] \<Rightarrow> i set"
  Nat           :: "i set"
  List          :: "i set \<Rightarrow> i set"
  Lists         :: "i set \<Rightarrow> i set"
  ILists        :: "i set \<Rightarrow> i set"
  TAll          :: "(i set \<Rightarrow> i set) \<Rightarrow> i set"       (binder "TALL " 55)
  TEx           :: "(i set \<Rightarrow> i set) \<Rightarrow> i set"       (binder "TEX " 55)
  Lift          :: "i set \<Rightarrow> i set"                  ("(3[_])")

  SPLIT         :: "[i, [i, i] \<Rightarrow> i set] \<Rightarrow> i set"

syntax
  "_Pi"         :: "[idt, i set, i set] \<Rightarrow> i set"    ("(3PROD _:_./ _)"
                                [0,0,60] 60)

  "_Sigma"      :: "[idt, i set, i set] \<Rightarrow> i set"    ("(3SUM _:_./ _)"
                                [0,0,60] 60)

  "_arrow"      :: "[i set, i set] \<Rightarrow> i set"         ("(_ ->/ _)"  [54, 53] 53)
  "_star"       :: "[i set, i set] \<Rightarrow> i set"         ("(_ */ _)" [56, 55] 55)
  "_Subtype"    :: "[idt, 'a set, o] \<Rightarrow> 'a set"      ("(1{_: _ ./ _})")

translations
  "PROD x:A. B" => "CONST Pi(A, \<lambda>x. B)"
  "A -> B"      => "CONST Pi(A, \<lambda>_. B)"
  "SUM x:A. B"  => "CONST Sigma(A, \<lambda>x. B)"
  "A * B"       => "CONST Sigma(A, \<lambda>_. B)"
  "{x: A. B}"   == "CONST Subtype(A, \<lambda>x. B)"

print_translation {*
 [(@{const_syntax Pi},
    fn _ => Syntax_Trans.dependent_tr' (@{syntax_const "_Pi"}, @{syntax_const "_arrow"})),
  (@{const_syntax Sigma},
    fn _ => Syntax_Trans.dependent_tr' (@{syntax_const "_Sigma"}, @{syntax_const "_star"}))]
*}

defs
  Subtype_def: "{x:A. P(x)} == {x. x:A \<and> P(x)}"
  Unit_def:          "Unit == {x. x=one}"
  Bool_def:          "Bool == {x. x=true | x=false}"
  Plus_def:           "A+B == {x. (EX a:A. x=inl(a)) | (EX b:B. x=inr(b))}"
  Pi_def:         "Pi(A,B) == {x. EX b. x=lam x. b(x) \<and> (ALL x:A. b(x):B(x))}"
  Sigma_def:   "Sigma(A,B) == {x. EX a:A. EX b:B(a).x=<a,b>}"
  Nat_def:            "Nat == lfp(\<lambda>X. Unit + X)"
  List_def:       "List(A) == lfp(\<lambda>X. Unit + A*X)"

  Lists_def:     "Lists(A) == gfp(\<lambda>X. Unit + A*X)"
  ILists_def:   "ILists(A) == gfp(\<lambda>X.{} + A*X)"

  Tall_def:   "TALL X. B(X) == Inter({X. EX Y. X=B(Y)})"
  Tex_def:     "TEX X. B(X) == Union({X. EX Y. X=B(Y)})"
  Lift_def:           "[A] == A Un {bot}"

  SPLIT_def:   "SPLIT(p,B) == Union({A. EX x y. p=<x,y> \<and> A=B(x,y)})"

lemmas simp_type_defs =
    Subtype_def Unit_def Bool_def Plus_def Sigma_def Pi_def Lift_def Tall_def Tex_def
  and ind_type_defs = Nat_def List_def
  and simp_data_defs = one_def inl_def inr_def
  and ind_data_defs = zero_def succ_def nil_def cons_def

lemma subsetXH: "A <= B \<longleftrightarrow> (ALL x. x:A \<longrightarrow> x:B)"
  by blast

subsection {* Exhaustion Rules *}

lemma EmptyXH: "\<And>a. a : {} \<longleftrightarrow> False"
  and SubtypeXH: "\<And>a A P. a : {x:A. P(x)} \<longleftrightarrow> (a:A \<and> P(a))"
  and UnitXH: "\<And>a. a : Unit          \<longleftrightarrow> a=one"
  and BoolXH: "\<And>a. a : Bool          \<longleftrightarrow> a=true | a=false"
  and PlusXH: "\<And>a A B. a : A+B           \<longleftrightarrow> (EX x:A. a=inl(x)) | (EX x:B. a=inr(x))"
  and PiXH: "\<And>a A B. a : PROD x:A. B(x) \<longleftrightarrow> (EX b. a=lam x. b(x) \<and> (ALL x:A. b(x):B(x)))"
  and SgXH: "\<And>a A B. a : SUM x:A. B(x)  \<longleftrightarrow> (EX x:A. EX y:B(x).a=<x,y>)"
  unfolding simp_type_defs by blast+

lemmas XHs = EmptyXH SubtypeXH UnitXH BoolXH PlusXH PiXH SgXH

lemma LiftXH: "a : [A] \<longleftrightarrow> (a=bot | a:A)"
  and TallXH: "a : TALL X. B(X) \<longleftrightarrow> (ALL X. a:B(X))"
  and TexXH: "a : TEX X. B(X) \<longleftrightarrow> (EX X. a:B(X))"
  unfolding simp_type_defs by blast+

ML {* ML_Thms.bind_thms ("case_rls", XH_to_Es @{thms XHs}) *}

subsection {* Canonical Type Rules *}

lemma oneT: "one : Unit"
  and trueT: "true : Bool"
  and falseT: "false : Bool"
  and lamT: "\<And>b B. (\<And>x. x:A \<Longrightarrow> b(x):B(x)) \<Longrightarrow> lam x. b(x) : Pi(A,B)"
  and pairT: "\<And>b B. \<lbrakk>a:A; b:B(a)\<rbrakk> \<Longrightarrow> <a,b>:Sigma(A,B)"
  and inlT: "a:A \<Longrightarrow> inl(a) : A+B"
  and inrT: "b:B \<Longrightarrow> inr(b) : A+B"
  by (blast intro: XHs [THEN iffD2])+

lemmas canTs = oneT trueT falseT pairT lamT inlT inrT

subsection {* Non-Canonical Type Rules *}

lemma lem: "\<lbrakk>a:B(u); u = v\<rbrakk> \<Longrightarrow> a : B(v)"
  by blast

ML {*
fun mk_ncanT_tac top_crls crls =
  SUBPROOF (fn {context = ctxt, prems = major :: prems, ...} =>
    resolve_tac ([major] RL top_crls) 1 THEN
    REPEAT_SOME (eresolve_tac (crls @ [@{thm exE}, @{thm bexE}, @{thm conjE}, @{thm disjE}])) THEN
    ALLGOALS (asm_simp_tac ctxt) THEN
    ALLGOALS (ares_tac (prems RL [@{thm lem}]) ORELSE' etac @{thm bspec}) THEN
    safe_tac (ctxt addSIs prems))
*}

method_setup ncanT = {*
  Scan.succeed (SIMPLE_METHOD' o mk_ncanT_tac @{thms case_rls} @{thms case_rls})
*}

lemma ifT: "\<lbrakk>b:Bool; b=true \<Longrightarrow> t:A(true); b=false \<Longrightarrow> u:A(false)\<rbrakk> \<Longrightarrow> if b then t else u : A(b)"
  by ncanT

lemma applyT: "\<lbrakk>f : Pi(A,B); a:A\<rbrakk> \<Longrightarrow> f ` a : B(a)"
  by ncanT

lemma splitT: "\<lbrakk>p:Sigma(A,B); \<And>x y. \<lbrakk>x:A; y:B(x); p=<x,y>\<rbrakk> \<Longrightarrow> c(x,y):C(<x,y>)\<rbrakk> \<Longrightarrow> split(p,c):C(p)"
  by ncanT

lemma whenT:
  "\<lbrakk>p:A+B;
    \<And>x. \<lbrakk>x:A; p=inl(x)\<rbrakk> \<Longrightarrow> a(x):C(inl(x));
    \<And>y. \<lbrakk>y:B;  p=inr(y)\<rbrakk> \<Longrightarrow> b(y):C(inr(y))\<rbrakk> \<Longrightarrow> when(p,a,b) : C(p)"
  by ncanT

lemmas ncanTs = ifT applyT splitT whenT

subsection {* Subtypes *}

lemma SubtypeD1: "a : Subtype(A, P) \<Longrightarrow> a : A"
  and SubtypeD2: "a : Subtype(A, P) \<Longrightarrow> P(a)"
  by (simp_all add: SubtypeXH)

lemma SubtypeI: "\<lbrakk>a:A; P(a)\<rbrakk> \<Longrightarrow> a : {x:A. P(x)}"
  by (simp add: SubtypeXH)

lemma SubtypeE: "\<lbrakk>a : {x:A. P(x)}; \<lbrakk>a:A; P(a)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (simp add: SubtypeXH)

subsection {* Monotonicity *}

lemma idM: "mono (\<lambda>X. X)"
  apply (rule monoI)
  apply assumption
  done

lemma constM: "mono(\<lambda>X. A)"
  apply (rule monoI)
  apply (rule subset_refl)
  done

lemma "mono(\<lambda>X. A(X)) \<Longrightarrow> mono(\<lambda>X.[A(X)])"
  apply (rule subsetI [THEN monoI])
  apply (drule LiftXH [THEN iffD1])
  apply (erule disjE)
   apply (erule disjI1 [THEN LiftXH [THEN iffD2]])
  apply (rule disjI2 [THEN LiftXH [THEN iffD2]])
  apply (drule (1) monoD)
  apply blast
  done

lemma SgM:
  "\<lbrakk>mono(\<lambda>X. A(X)); \<And>x X. x:A(X) \<Longrightarrow> mono(\<lambda>X. B(X,x))\<rbrakk> \<Longrightarrow>
    mono(\<lambda>X. Sigma(A(X),B(X)))"
  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
    dest!: monoD [THEN subsetD])

lemma PiM: "(\<And>x. x:A \<Longrightarrow> mono(\<lambda>X. B(X,x))) \<Longrightarrow> mono(\<lambda>X. Pi(A,B(X)))"
  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
    dest!: monoD [THEN subsetD])

lemma PlusM: "\<lbrakk>mono(\<lambda>X. A(X)); mono(\<lambda>X. B(X))\<rbrakk> \<Longrightarrow> mono(\<lambda>X. A(X)+B(X))"
  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
    dest!: monoD [THEN subsetD])

subsection {* Recursive types *}

subsubsection {* Conversion Rules for Fixed Points via monotonicity and Tarski *}

lemma NatM: "mono(\<lambda>X. Unit+X)"
  apply (rule PlusM constM idM)+
  done

lemma def_NatB: "Nat = Unit + Nat"
  apply (rule def_lfp_Tarski [OF Nat_def])
  apply (rule NatM)
  done

lemma ListM: "mono(\<lambda>X.(Unit+Sigma(A,\<lambda>y. X)))"
  apply (rule PlusM SgM constM idM)+
  done

lemma def_ListB: "List(A) = Unit + A * List(A)"
  apply (rule def_lfp_Tarski [OF List_def])
  apply (rule ListM)
  done

lemma def_ListsB: "Lists(A) = Unit + A * Lists(A)"
  apply (rule def_gfp_Tarski [OF Lists_def])
  apply (rule ListM)
  done

lemma IListsM: "mono(\<lambda>X.({} + Sigma(A,\<lambda>y. X)))"
  apply (rule PlusM SgM constM idM)+
  done

lemma def_IListsB: "ILists(A) = {} + A * ILists(A)"
  apply (rule def_gfp_Tarski [OF ILists_def])
  apply (rule IListsM)
  done

lemmas ind_type_eqs = def_NatB def_ListB def_ListsB def_IListsB

subsection {* Exhaustion Rules *}

lemma NatXH: "a : Nat \<longleftrightarrow> (a=zero | (EX x:Nat. a=succ(x)))"
  and ListXH: "a : List(A) \<longleftrightarrow> (a=[] | (EX x:A. EX xs:List(A).a=x$xs))"
  and ListsXH: "a : Lists(A) \<longleftrightarrow> (a=[] | (EX x:A. EX xs:Lists(A).a=x$xs))"
  and IListsXH: "a : ILists(A) \<longleftrightarrow> (EX x:A. EX xs:ILists(A).a=x$xs)"
  unfolding ind_data_defs
  by (rule ind_type_eqs [THEN XHlemma1], blast intro!: canTs elim!: case_rls)+

lemmas iXHs = NatXH ListXH

ML {* ML_Thms.bind_thms ("icase_rls", XH_to_Es @{thms iXHs}) *}

subsection {* Type Rules *}

lemma zeroT: "zero : Nat"
  and succT: "n:Nat \<Longrightarrow> succ(n) : Nat"
  and nilT: "[] : List(A)"
  and consT: "\<lbrakk>h:A; t:List(A)\<rbrakk> \<Longrightarrow> h$t : List(A)"
  by (blast intro: iXHs [THEN iffD2])+

lemmas icanTs = zeroT succT nilT consT

method_setup incanT = {*
  Scan.succeed (SIMPLE_METHOD' o mk_ncanT_tac @{thms icase_rls} @{thms case_rls})
*}

lemma ncaseT: "\<lbrakk>n:Nat; n=zero \<Longrightarrow> b:C(zero); \<And>x. \<lbrakk>x:Nat; n=succ(x)\<rbrakk> \<Longrightarrow> c(x):C(succ(x))\<rbrakk>
    \<Longrightarrow> ncase(n,b,c) : C(n)"
  by incanT

lemma lcaseT: "\<lbrakk>l:List(A); l = [] \<Longrightarrow> b:C([]); \<And>h t. \<lbrakk>h:A; t:List(A); l=h$t\<rbrakk> \<Longrightarrow> c(h,t):C(h$t)\<rbrakk>
    \<Longrightarrow> lcase(l,b,c) : C(l)"
  by incanT

lemmas incanTs = ncaseT lcaseT

subsection {* Induction Rules *}

lemmas ind_Ms = NatM ListM

lemma Nat_ind: "\<lbrakk>n:Nat; P(zero); \<And>x. \<lbrakk>x:Nat; P(x)\<rbrakk> \<Longrightarrow> P(succ(x))\<rbrakk> \<Longrightarrow> P(n)"
  apply (unfold ind_data_defs)
  apply (erule def_induct [OF Nat_def _ NatM])
  apply (blast intro: canTs elim!: case_rls)
  done

lemma List_ind: "\<lbrakk>l:List(A); P([]); \<And>x xs. \<lbrakk>x:A; xs:List(A); P(xs)\<rbrakk> \<Longrightarrow> P(x$xs)\<rbrakk> \<Longrightarrow> P(l)"
  apply (unfold ind_data_defs)
  apply (erule def_induct [OF List_def _ ListM])
  apply (blast intro: canTs elim!: case_rls)
  done

lemmas inds = Nat_ind List_ind

subsection {* Primitive Recursive Rules *}

lemma nrecT: "\<lbrakk>n:Nat; b:C(zero); \<And>x g. \<lbrakk>x:Nat; g:C(x)\<rbrakk> \<Longrightarrow> c(x,g):C(succ(x))\<rbrakk>
    \<Longrightarrow> nrec(n,b,c) : C(n)"
  by (erule Nat_ind) auto

lemma lrecT: "\<lbrakk>l:List(A); b:C([]); \<And>x xs g. \<lbrakk>x:A; xs:List(A); g:C(xs)\<rbrakk> \<Longrightarrow> c(x,xs,g):C(x$xs) \<rbrakk>
    \<Longrightarrow> lrec(l,b,c) : C(l)"
  by (erule List_ind) auto

lemmas precTs = nrecT lrecT

subsection {* Theorem proving *}

lemma SgE2: "\<lbrakk><a,b> : Sigma(A,B); \<lbrakk>a:A; b:B(a)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  unfolding SgXH by blast

(* General theorem proving ignores non-canonical term-formers,             *)
(*         - intro rules are type rules for canonical terms                *)
(*         - elim rules are case rules (no non-canonical terms appear)     *)

ML {* ML_Thms.bind_thms ("XHEs", XH_to_Es @{thms XHs}) *}

lemmas [intro!] = SubtypeI canTs icanTs
  and [elim!] = SubtypeE XHEs

subsection {* Infinite Data Types *}

lemma lfp_subset_gfp: "mono(f) \<Longrightarrow> lfp(f) <= gfp(f)"
  apply (rule lfp_lowerbound [THEN subset_trans])
   apply (erule gfp_lemma3)
  apply (rule subset_refl)
  done

lemma gfpI:
  assumes "a:A"
    and "\<And>x X. \<lbrakk>x:A; ALL y:A. t(y):X\<rbrakk> \<Longrightarrow> t(x) : B(X)"
  shows "t(a) : gfp(B)"
  apply (rule coinduct)
   apply (rule_tac P = "\<lambda>x. EX y:A. x=t (y)" in CollectI)
   apply (blast intro!: assms)+
  done

lemma def_gfpI: "\<lbrakk>C == gfp(B); a:A; \<And>x X. \<lbrakk>x:A; ALL y:A. t(y):X\<rbrakk> \<Longrightarrow> t(x) : B(X)\<rbrakk> \<Longrightarrow> t(a) : C"
  apply unfold
  apply (erule gfpI)
  apply blast
  done

(* EG *)
lemma "letrec g x be zero$g(x) in g(bot) : Lists(Nat)"
  apply (rule refl [THEN UnitXH [THEN iffD2], THEN Lists_def [THEN def_gfpI]])
  apply (subst letrecB)
  apply (unfold cons_def)
  apply blast
  done

subsection {* Lemmas and tactics for using the rule @{text
  "coinduct3"} on @{text "[="} and @{text "="} *}

lemma lfpI: "\<lbrakk>mono(f); a : f(lfp(f))\<rbrakk> \<Longrightarrow> a : lfp(f)"
  apply (erule lfp_Tarski [THEN ssubst])
  apply assumption
  done

lemma ssubst_single: "\<lbrakk>a = a'; a' : A\<rbrakk> \<Longrightarrow> a : A"
  by simp

lemma ssubst_pair: "\<lbrakk>a = a'; b = b'; <a',b'> : A\<rbrakk> \<Longrightarrow> <a,b> : A"
  by simp

ML {*
  val coinduct3_tac = SUBPROOF (fn {context = ctxt, prems = mono :: prems, ...} =>
    fast_tac (ctxt addIs (mono RS @{thm coinduct3_mono_lemma} RS @{thm lfpI}) :: prems) 1);
*}

method_setup coinduct3 = {* Scan.succeed (SIMPLE_METHOD' o coinduct3_tac) *}

lemma ci3_RI: "\<lbrakk>mono(Agen); a : R\<rbrakk> \<Longrightarrow> a : lfp(\<lambda>x. Agen(x) Un R Un A)"
  by coinduct3

lemma ci3_AgenI: "\<lbrakk>mono(Agen); a : Agen(lfp(\<lambda>x. Agen(x) Un R Un A))\<rbrakk> \<Longrightarrow>
    a : lfp(\<lambda>x. Agen(x) Un R Un A)"
  by coinduct3

lemma ci3_AI: "\<lbrakk>mono(Agen); a : A\<rbrakk> \<Longrightarrow> a : lfp(\<lambda>x. Agen(x) Un R Un A)"
  by coinduct3

ML {*
fun genIs_tac ctxt genXH gen_mono =
  rtac (genXH RS @{thm iffD2}) THEN'
  simp_tac ctxt THEN'
  TRY o fast_tac
    (ctxt addIs [genXH RS @{thm iffD2}, gen_mono RS @{thm coinduct3_mono_lemma} RS @{thm lfpI}])
*}

method_setup genIs = {*
  Attrib.thm -- Attrib.thm >>
    (fn (genXH, gen_mono) => fn ctxt => SIMPLE_METHOD' (genIs_tac ctxt genXH gen_mono))
*}

subsection {* POgen *}

lemma PO_refl: "<a,a> : PO"
  by (rule po_refl [THEN PO_iff [THEN iffD1]])

lemma POgenIs:
  "<true,true> : POgen(R)"
  "<false,false> : POgen(R)"
  "\<lbrakk><a,a'> : R; <b,b'> : R\<rbrakk> \<Longrightarrow> <<a,b>,<a',b'>> : POgen(R)"
  "\<And>b b'. (\<And>x. <b(x),b'(x)> : R) \<Longrightarrow> <lam x. b(x),lam x. b'(x)> : POgen(R)"
  "<one,one> : POgen(R)"
  "<a,a'> : lfp(\<lambda>x. POgen(x) Un R Un PO) \<Longrightarrow>
    <inl(a),inl(a')> : POgen(lfp(\<lambda>x. POgen(x) Un R Un PO))"
  "<b,b'> : lfp(\<lambda>x. POgen(x) Un R Un PO) \<Longrightarrow>
    <inr(b),inr(b')> : POgen(lfp(\<lambda>x. POgen(x) Un R Un PO))"
  "<zero,zero> : POgen(lfp(\<lambda>x. POgen(x) Un R Un PO))"
  "<n,n'> : lfp(\<lambda>x. POgen(x) Un R Un PO) \<Longrightarrow>
    <succ(n),succ(n')> : POgen(lfp(\<lambda>x. POgen(x) Un R Un PO))"
  "<[],[]> : POgen(lfp(\<lambda>x. POgen(x) Un R Un PO))"
  "\<lbrakk><h,h'> : lfp(\<lambda>x. POgen(x) Un R Un PO);  <t,t'> : lfp(\<lambda>x. POgen(x) Un R Un PO)\<rbrakk>
    \<Longrightarrow> <h$t,h'$t'> : POgen(lfp(\<lambda>x. POgen(x) Un R Un PO))"
  unfolding data_defs by (genIs POgenXH POgen_mono)+

ML {*
fun POgen_tac ctxt (rla, rlb) i =
  SELECT_GOAL (safe_tac ctxt) i THEN
  rtac (rlb RS (rla RS @{thm ssubst_pair})) i THEN
  (REPEAT (resolve_tac
      (@{thms POgenIs} @ [@{thm PO_refl} RS (@{thm POgen_mono} RS @{thm ci3_AI})] @
        (@{thms POgenIs} RL [@{thm POgen_mono} RS @{thm ci3_AgenI}]) @
        [@{thm POgen_mono} RS @{thm ci3_RI}]) i))
*}

subsection {* EQgen *}

lemma EQ_refl: "<a,a> : EQ"
  by (rule refl [THEN EQ_iff [THEN iffD1]])

lemma EQgenIs:
  "<true,true> : EQgen(R)"
  "<false,false> : EQgen(R)"
  "\<lbrakk><a,a'> : R; <b,b'> : R\<rbrakk> \<Longrightarrow> <<a,b>,<a',b'>> : EQgen(R)"
  "\<And>b b'. (\<And>x. <b(x),b'(x)> : R) \<Longrightarrow> <lam x. b(x),lam x. b'(x)> : EQgen(R)"
  "<one,one> : EQgen(R)"
  "<a,a'> : lfp(\<lambda>x. EQgen(x) Un R Un EQ) \<Longrightarrow>
    <inl(a),inl(a')> : EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))"
  "<b,b'> : lfp(\<lambda>x. EQgen(x) Un R Un EQ) \<Longrightarrow>
    <inr(b),inr(b')> : EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))"
  "<zero,zero> : EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))"
  "<n,n'> : lfp(\<lambda>x. EQgen(x) Un R Un EQ) \<Longrightarrow>
    <succ(n),succ(n')> : EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))"
  "<[],[]> : EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))"
  "\<lbrakk><h,h'> : lfp(\<lambda>x. EQgen(x) Un R Un EQ); <t,t'> : lfp(\<lambda>x. EQgen(x) Un R Un EQ)\<rbrakk>
    \<Longrightarrow> <h$t,h'$t'> : EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))"
  unfolding data_defs by (genIs EQgenXH EQgen_mono)+

ML {*
fun EQgen_raw_tac i =
  (REPEAT (resolve_tac (@{thms EQgenIs} @
        [@{thm EQ_refl} RS (@{thm EQgen_mono} RS @{thm ci3_AI})] @
        (@{thms EQgenIs} RL [@{thm EQgen_mono} RS @{thm ci3_AgenI}]) @
        [@{thm EQgen_mono} RS @{thm ci3_RI}]) i))

(* Goals of the form R <= EQgen(R) - rewrite elements <a,b> : EQgen(R) using rews and *)
(* then reduce this to a goal <a',b'> : R (hopefully?)                                *)
(*      rews are rewrite rules that would cause looping in the simpifier              *)

fun EQgen_tac ctxt rews i =
 SELECT_GOAL
   (TRY (safe_tac ctxt) THEN
    resolve_tac ((rews @ [@{thm refl}]) RL ((rews @ [@{thm refl}]) RL [@{thm ssubst_pair}])) i THEN
    ALLGOALS (simp_tac ctxt) THEN
    ALLGOALS EQgen_raw_tac) i
*}

method_setup EQgen = {*
  Attrib.thms >> (fn ths => fn ctxt => SIMPLE_METHOD' (EQgen_tac ctxt ths))
*}

end


(*  Title:      FOL/ex/Propositional_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>First-Order Logic: propositional examples (intuitionistic version)\<close>

theory Propositional_Int
imports IFOL
begin

text \<open>commutative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>

lemma "P \<and> Q \<longrightarrow> Q \<and> P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "P \<or> Q \<longrightarrow> Q \<or> P"
  by (tactic "IntPr.fast_tac @{context} 1")

text \<open>associative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma "(P \<and> Q) \<and> R \<longrightarrow> P \<and> (Q \<and> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<or> Q) \<or> R \<longrightarrow> P \<or> (Q \<or> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

text \<open>distributive laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma "(P \<and> Q) \<or> R \<longrightarrow> (P \<or> R) \<and> (Q \<or> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<or> R) \<and> (Q \<or> R) \<longrightarrow> (P \<and> Q) \<or> R"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<or> Q) \<and> R \<longrightarrow> (P \<and> R) \<or> (Q \<and> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<and> R) \<or> (Q \<and> R) \<longrightarrow> (P \<or> Q) \<and> R"
  by (tactic "IntPr.fast_tac @{context} 1")

text \<open>Laws involving implication\<close>

lemma "(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R) \<longleftrightarrow> (P \<or> Q \<longrightarrow> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<and> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> ((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> (P \<and> Q \<longrightarrow> R) \<longrightarrow> R"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "\<not> (P \<longrightarrow> R) \<longrightarrow> \<not> (Q \<longrightarrow> R) \<longrightarrow> \<not> (P \<and> Q \<longrightarrow> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<longrightarrow> Q \<and> R) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

text \<open>Propositions-as-types\<close>

\<comment> \<open>The combinator K\<close>
lemma "P \<longrightarrow> (Q \<longrightarrow> P)"
  by (tactic "IntPr.fast_tac @{context} 1")

\<comment> \<open>The combinator S\<close>
lemma "(P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

\<comment> \<open>Converse is classical\<close>
lemma "(P \<longrightarrow> Q) \<or> (P \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q \<or> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P \<longrightarrow> Q) \<longrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
  by (tactic "IntPr.fast_tac @{context} 1")

text \<open>Schwichtenberg's examples (via T. Nipkow)\<close>

lemma stab_imp: "(((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma stab_to_peirce:
  "(((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> (((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q)
    \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma peirce_imp1:
  "(((Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> Q)
    \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q) \<longrightarrow> P \<longrightarrow> Q"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma peirce_imp2: "(((P \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> ((P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma mints: "((((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> Q) \<longrightarrow> Q"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma mints_solovev: "(P \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma tatsuta:
  "(((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P5"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma tatsuta1:
  "(((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9)
  \<longrightarrow> (((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7 \<longrightarrow> P5"
  by (tactic "IntPr.fast_tac @{context} 1")

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_MSortBU2Permutes
  imports "../../Test_Base"
begin

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

fun risers :: "int list => (int list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(int list) list => int list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu2 :: "int list => int list" where
  "msortbu2 x = mergingbu2 (risers x)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msortbu2 xs) xs"
  oops

end


theory Exercise7p7
imports Small_Step_sseefried
begin

(*  Exercise 7.7.

Let C :: nat \<Rightarrow> com be an infinite sequence of commands
and S :: nat \<Rightarrow> state an infinite sequence of states such that

a) C 0 = c;; d
b) \<forall>n. (C n, S n) \<longrightarrow> (C (Suc n), S (Suc n)).

Prove that either all C n are of the form c\<^sub>n;; d and it is always c\<^sub>n that is reduced, or c\<^sub>n
eventually becomes SKIP:
*)
thm small_step_induct

lemma
  fixes
  C :: "nat \<Rightarrow> com" and          (* infinite sequence of commands *)
  S :: "nat \<Rightarrow> state"            (* infinite sequence of states   *)
assumes
  "C 0 = c;;d"                   (* c is first command, d is remaining program *)
  "\<forall>n. (C n, S n) \<rightarrow> (C (Suc n), S (Suc n))"
  (* ^^^ This assumption ties commands/state to subsequent commands/states. It states that
    the small step reduction sequence is infinite. Not all programs would have an infinite
    reduction sequence.
  *)
shows
  "(\<forall>n. \<exists>c\<^sub>1 c\<^sub>2.
    C n = c\<^sub>1;;d \<and>                (* d is remaining program *)
    C (Suc n) = c\<^sub>2;;d \<and>          (* c1 \<rightarrow> c2 and d remains the same *)
    (c\<^sub>1, S n) \<rightarrow> (c\<^sub>2, S (Suc n))) (* Case where first command c\<^sub>1 never terminates.
                                     d never evaluated *)
 \<or>  (\<exists>k. C k = SKIP;;d)"        (* Case where we get a SKIP, then remaining program d can be
                                   evaluated *)
 (is "(\<forall>n. ?P n) \<or> ?Q")

proof cases
    assume "?Q"
    thus ?thesis by blast
 next
    assume "\<not> ?Q"
    have "\<forall>n. ?P n"
    proof
      fix n
      show "?P n"
      proof (induction n)
      case 0
        from assms obtain c\<^sub>1 where c1: "C 0 = c\<^sub>1;; d" by auto
        from assms have "(C 0, S 0) \<rightarrow> (C (Suc 0), S (Suc 0))" by blast
        with c1 have "(c\<^sub>1;;d, S 0) \<rightarrow> (C (Suc 0), S (Suc 0))" by auto
        then obtain c\<^sub>2 where "C (Suc 0) = c\<^sub>2;;d"
                         and "(c\<^sub>1, S 0) \<rightarrow> (c\<^sub>2, S (Suc 0))"
                       using c1 `\<not> ?Q` by blast
        thus ?case using c1 by blast
      next
        case (Suc n)
        (* The trick here is that we set c\<^sub>1 to be the skolem constant for the c\<^sub>2 in the
           existential *)
        then obtain c\<^sub>1 where cn: "C (Suc n) = c\<^sub>1;;d" by blast
        from assms have "(C (Suc n), S (Suc n)) \<rightarrow> (C (Suc (Suc n)), S (Suc (Suc n)))" by blast
        with cn have "(c\<^sub>1;;d, S (Suc n)) \<rightarrow> (C (Suc (Suc n)), S (Suc (Suc n)))" by auto
        then obtain c\<^sub>2 where "C (Suc (Suc n)) = c\<^sub>2;;d"
                         and "(c\<^sub>1, S (Suc n)) \<rightarrow> (c\<^sub>2, (S (Suc (Suc n))))"
                       using cn `\<not> ?Q` by blast
        thus ?case using cn by blast
      qed
    qed
    then show ?thesis by blast
  qed

(*
   The condition "\<forall>n. (C n, S n) \<rightarrow> (C (Suc n), S (Suc n))" got me thinking that
   if this is true then the first command cannot be SKIP because that "gets stuck".
   and it can't be an assignment since that will "get stuck" after one step

   So I decided to prove it.

   There are many programs that could lead to an infinite sequence of reductions but these two
   are not among them!
 *)
lemma
  fixes
  C :: "nat \<Rightarrow> com" and          (* infinite sequence of commands *)
  S :: "nat \<Rightarrow> state"            (* infinite sequence of states   *)
assumes
  "\<forall>n. (C n, S n) \<rightarrow> (C (Suc n), S (Suc n))" (* States that small step eduction occurs infinitely *)
shows
  "(\<forall>x a. C 0 \<noteq> x ::= a \<and> C 0 \<noteq> SKIP)" (is "\<forall>x a. ?P x a")
proof (rule allI, rule allI)
  fix x a
  from assms have "(C 0, S 0) \<rightarrow> (C (Suc 0), S (Suc 0))" by blast
  moreover from assms have "(C (Suc 0), S (Suc 0)) \<rightarrow> (C (Suc (Suc 0)), S (Suc (Suc 0)))" by blast
  ultimately show "?P x a"
    by (induction "C 0" "S 0" "C (Suc 0)" "S (Suc 0)" rule: small_step_induct, auto)
qed

end


theory Submission
  imports Defs
begin

lemma count_append[simp]:
  "count (u @ v) c = count u c + count v c"
  by (induction u) auto

lemma L_alphabet:
  "set w \<subseteq> {a, b}" if "w \<in> L"
  using that by induction auto

lemma L_count:
  "#w\<^bsub>a\<^esub> = 2 * #w\<^bsub>b\<^esub>" if "w \<in> L"
  using that by induction auto

text \<open>First task\<close>
theorem L_sub: "L \<subseteq> M"
  using L_alphabet L_count unfolding M_def by auto

lemma L_len:
  "w = [] \<or> length w \<ge> 3" if "w \<in> L"
  using that by induction auto

lemma [simp]:
  "h (b # x) = h x + 2"
  unfolding h_def by auto

lemma [simp]:
  "h (a # x) = h x - 1"
  unfolding h_def by auto

lemma [simp]:
  "h (c # x) = h x" if "c \<noteq> a" "c \<noteq> b"
  using that unfolding h_def by auto

lemma [simp]:
  "h [] = 0"
  unfolding h_def by auto

text \<open>Second task\<close>
lemma h_first_zero:
  assumes "h (xs @ ys) < 0" "h xs \<ge> 0"
  shows "\<exists> as bs. ys = as @ bs \<and> h (xs @ as) = 0"
  using assms
proof (induction ys arbitrary: xs rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc x ys xs)
  consider "x = a" | "x = b" | "x \<noteq> a" "x \<noteq> b"
    by auto
  then show ?case
    using snoc by (cases; simp; smt append.assoc)
qed

text \<open>Essential properties of prefixes\<close>
lemma [simp]:
  "v \<prec> [] \<longleftrightarrow> False"
  unfolding prefix_def by auto

lemma prefix_Cons_conv:
  "u \<prec> x # w \<longleftrightarrow> u = [] \<or> (u = [x] \<and> w \<noteq> []) \<or> (\<exists>v. u = x # v \<and> v \<prec> w)"
  unfolding prefix_def
  apply auto
     apply (metis hd_Cons_tl hd_append2 list.sel(1) list.sel(3) tl_append2)
  apply (simp add: Cons_eq_append_conv; fail)
  done

lemma prefix_empty[simp]:
  "u \<prec> [] \<longleftrightarrow> False"
  unfolding prefix_def by auto

lemma prefix_append_conv:
  "w \<prec> u @ v \<longleftrightarrow> w \<prec> u \<or> w = u \<and> u \<noteq> [] \<and> v \<noteq> [] \<or> (\<exists> w'. w = u @ w' \<and> w' \<prec> v)"
  unfolding prefix_def by (safe, subst (asm) append_eq_append_conv2, fastforce) auto

text \<open>Third task\<close>
lemma h_2_split:
  assumes "h w = 2" "\<forall>v. v \<prec> w \<longrightarrow> h v \<noteq> 1"
  obtains x y where "h x = 0" "h y = 0" "w = x @ b # y"
proof -
  define v where "v \<equiv> ARG_MIN length v. \<exists>x. w = v @ x \<and> h v > 0"
  have "\<exists> x. w = v @ x \<and> h v > 0"
    unfolding v_def by (rule arg_min_natI[where k = w]) (auto simp: \<open>h w = 2\<close>)
  then obtain u where [simp]: "w = v @ u" and "h v > 0"
    by auto
  then have "v \<noteq> []"
    by auto
  then obtain x c where [simp]: "v = x @ [c]"
    using rev_exhaust by blast
  have *: False if "h x > 0"
  proof -
    have "length x < length v"
      by auto
    with \<open>h x > 0\<close> show False
      unfolding v_def by (simp add: arg_min_nat_le leD)
  qed
  consider "c = a" | "c = b" | "c \<noteq> a" "c \<noteq> b"
    by auto
  then have "h x = 0 \<and> c = b \<and> h u = 0"
  proof cases
    case 1
    with \<open>h v > 0\<close> show ?thesis
      using * by force
  next
    case [simp]: 2
    consider (0) "h x = 0" | (neg) "h x < 0" | (pos) "h x > 0"
      by force
    then have "h x = 0"
    proof cases
      case 0
      then show ?thesis .
    next
      case neg
      with \<open>h w = 2\<close> have "u \<noteq> []"
        by auto
      from \<open>h x < 0\<close> \<open>h v > 0\<close> have "h v = 1"
        by simp
      moreover from \<open>u \<noteq> []\<close> have "v \<prec> w"
        by (auto simp: prefix_append_conv prefix_Cons_conv)
      ultimately show ?thesis
        using assms(2) by auto
    next
      case pos
      then show ?thesis
        using * by force
    qed
    with \<open>h w = 2\<close> show ?thesis
      by auto
  next
    case 3
    with \<open>h v > 0\<close> show ?thesis
      using * by force
  qed
  then show ?thesis
    by - (rule that, auto)
qed

lemma L_rev:
  assumes "w \<in> L"
  shows "rev w \<in> L"
  using assms by induction (auto intro: L.intros)

lemma count_rev[simp]:
  "count (rev xs) x = count xs x"
  by (induction xs) auto

lemma h_rev[simp]:
  "h (rev v) = h v"
  unfolding h_def by auto

text \<open>Task 4\<close>
theorem L_sup:
  assumes h_first_zero:
    "\<And>xs ys. h (xs @ ys) < 0 \<Longrightarrow> 0 \<le> h xs \<Longrightarrow> \<exists>as bs. ys = as @ bs \<and> h (xs @ as) = 0"
  assumes h_2_split:
    "\<And>t w. h w = 2 \<Longrightarrow> \<forall>v. v \<prec> w \<longrightarrow> h v \<noteq> 1 \<Longrightarrow> (\<And>x y. h x = 0 \<Longrightarrow> h y = 0 \<Longrightarrow> w = x @ b # y \<Longrightarrow> t)
      \<Longrightarrow> t"
  assumes "h w = 0" "set w \<subseteq> {a, b}"
  shows "w \<in> L"
  using assms(3-)
proof (induction "length w" arbitrary: w rule: less_induct)
  case less
  show ?case
  proof (cases "\<exists> x y. w = x @ y \<and> x \<noteq> [] \<and> y \<noteq> [] \<and> h x = 0 \<and> h y = 0")
    case True
    then obtain x y where "w = x @ y" "x \<noteq> []" "y \<noteq> []" "h x = 0" "h y = 0"
      by auto
    with less have "x \<in> L" "y \<in> L"
      by auto
    then show ?thesis
      unfolding \<open>w = _\<close> by (rule L.intros)
  next
    case F: False
    have 1: "w \<in> L" if
      "w = b # w'" "3 \<le> length w" "h w = 0" "set w \<subseteq> {a, b}"
      and F: "\<nexists> x y. w = x @ y \<and> x \<noteq> [] \<and> y \<noteq> [] \<and> h x = 0 \<and> h y = 0"
      and IH: "\<And>w'. length w' < length w \<Longrightarrow> h w' = 0 \<Longrightarrow> set w' \<subseteq> {a, b} \<Longrightarrow> w' \<in> L"
    for w w'
    proof -
      from \<open>h w = 0\<close> have "h w' = -2"
        unfolding \<open>w = _\<close> by simp
      obtain w'' c1 c2 where "w' = w'' @ [c1, c2]"
        using \<open>length w \<ge> 3\<close> unfolding \<open>w = _\<close>
        by clarsimp
          (metis One_nat_def add.commute add.right_neutral antisym_conv
            append.assoc append_Cons append_Nil impossible_Cons
            list.size(3) list.size(4) numeral_One numeral_le_iff
            order_trans rev_exhaust semiring_norm(68) semiring_norm(83))
      note [simp] = \<open>w = _\<close> \<open>w' = _\<close>
      consider "c1 = a" "c2 = a" | "c1 = a" "c2 = b" | "c1 = b" "c2 = a" | "c1 = b" "c2 = b"
        using \<open>set w \<subseteq> _\<close> unfolding \<open>w = _\<close> \<open>w' = _\<close> by auto
      then have "c1 = a \<and> c2 = a"
      proof cases
        case 1
        then show ?thesis ..
      next
        case 2
        with h_first_zero[of "[b]" w''] obtain as bs where "w'' = as @ bs" "h ([b] @ as) = 0"
          using \<open>h w' = -2\<close> by auto
        then show ?thesis
          using F \<open>h w = 0\<close> by (auto elim: allE[of _ "b # as"])
      next
        case 3
        with h_first_zero[of "[b]" w''] obtain as bs where "w'' = as @ bs" "h ([b] @ as) = 0"
          using \<open>h w' = -2\<close> by auto
        then show ?thesis
          using F \<open>h w = 0\<close> by (auto elim: allE[of _ "b # as"])
      next
        case 4
        with h_first_zero[of "[b]" w''] obtain as bs where "w'' = as @ bs" "h ([b] @ as) = 0"
          using \<open>h w' = -2\<close> by auto
        then show ?thesis
          using F \<open>h w = 0\<close> by (auto elim: allE[of _ "b # as"])
      qed
      with \<open>h w = 0\<close> have "h w'' = 0"
        unfolding \<open>w = _\<close> \<open>w' = _\<close> by simp
      moreover have "set w'' \<subseteq> {a, b}"
        using \<open>set w \<subseteq> _\<close> unfolding \<open>w = _\<close> \<open>w' = _\<close> by simp
      ultimately have "w'' \<in> L"
        using IH unfolding \<open>w = _\<close> \<open>w' = _\<close> by simp
      then show "w \<in> L"
        unfolding \<open>w = _\<close> \<open>w' = _\<close>
        by (simp only: \<open>c1 = a \<and> c2 = a\<close>, intro L.intros(5)[of w'' "[]", simplified] L.intros(1))
    qed
    show ?thesis
    proof (cases "w = []")
      case True
      then show ?thesis
        by simp (rule L.intros)
    next
      case False
      with \<open>h w = 0\<close> \<open>set w \<subseteq> _\<close> have "3 \<le> length w"
        unfolding h_def
        apply auto
        apply (cases w, simp)
        apply (case_tac list)
         apply (auto split: if_split_asm)
           apply (case_tac lista, auto)+
        done
      then obtain c w' where "w = c # w'"
        by (cases w) auto
      with \<open>set w \<subseteq> _\<close> have "c = a \<or> c = b"
        by auto
      then show ?thesis
      proof
        assume "c = b"
        with less \<open>length w \<ge> 3\<close> F show ?thesis
          unfolding \<open>w = _\<close> by - (rule 1[of _ w'], auto)
      next
        assume "c = a"
        from \<open>h w = 0\<close> have "h w' = 1"
          unfolding \<open>w = _\<close> \<open>c = _\<close> by simp
        obtain v c1 where "w' = v @ [c1]"
          using \<open>length w \<ge> 3\<close> unfolding \<open>w = _\<close>
          by simp (metis length_0_conv not_numeral_le_zero rev_exhaust)
        note [simp] = \<open>w = _\<close> \<open>w' = _\<close> \<open>c = _\<close>
        consider (a) "c1 = a" | (b) "c1 = b"
          using \<open>set w \<subseteq> _\<close> by auto
        then show "w \<in> L"
        proof cases
          case [simp]: a
          have *: False if "h u = 1" "u \<prec> v" for u
          proof -
            from \<open>u \<prec> v\<close> obtain xs where "w = a # u @ xs @ [a]"
              unfolding prefix_def by auto
            with \<open>h u = 1\<close> F \<open>h w = 0\<close> show ?thesis
              by (auto elim: allE[of _ "a # u"])
          qed
          from \<open>h w' = 1\<close> have "h v = 2"
            by simp
          then obtain x y where "h x = 0" "h y = 0" "v = x @ b # y"
            by (rule h_2_split) (auto intro: *)
          with less have "x \<in> L" "y \<in> L"
            by auto
          then show ?thesis
            by (simp add: \<open>v = _\<close>; intro L.intros)
        next
          case b
          with less \<open>length w \<ge> 3\<close> F have "rev w \<in> L"
            apply simp
            apply (rule 1, rule HOL.refl)
                apply clarsimp+
             apply (metis append_Cons h_rev rev.simps(2) rev_append rev_eq_Cons_iff rev_is_Nil_conv)
            apply clarsimp
            done
          then show ?thesis
            by - (drule L_rev, auto)
        qed
      qed
    qed
  qed
qed

text \<open>The final theorem\<close>
corollary
  "L = M"
  using L_sub L_sup[OF h_first_zero h_2_split] unfolding h_def M_def by auto

end