(*  Title:      FOL/IFOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section \<open>Intuitionistic first-order logic\<close>

theory IFOL
  imports Pure
  abbrevs "?<" = "\<exists>\<^sub>\<le>\<^sub>1"
begin

ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>
ML_file \<open>~~/src/Provers/splitter.ML\<close>
ML_file \<open>~~/src/Provers/hypsubst.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/zipper.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/isand.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/rw_inst.ML\<close>
ML_file \<open>~~/src/Provers/quantifier1.ML\<close>
ML_file \<open>~~/src/Tools/intuitionistic.ML\<close>
ML_file \<open>~~/src/Tools/project_rule.ML\<close>
ML_file \<open>~~/src/Tools/atomize_elim.ML\<close>

subsection \<open>Syntax and axiomatic basis\<close>

setup Pure_Thy.old_appl_syntax_setup
setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc [])\<close>

class "term"
default_sort \<open>term\<close>

typedecl o

judgment
  Trueprop :: \<open>o \<Rightarrow> prop\<close>  (\<open>(_)\<close> 5)

subsubsection \<open>Equality\<close>

axiomatization
  eq :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>=\<close> 50)
where
  refl: \<open>a = a\<close> and
  subst: \<open>a = b \<Longrightarrow> P(a) \<Longrightarrow> P(b)\<close>

subsubsection \<open>Propositional logic\<close>

axiomatization
  False :: \<open>o\<close> and
  conj :: \<open>[o, o] => o\<close>  (infixr \<open>\<and>\<close> 35) and
  disj :: \<open>[o, o] => o\<close>  (infixr \<open>\<or>\<close> 30) and
  imp :: \<open>[o, o] => o\<close>  (infixr \<open>\<longrightarrow>\<close> 25)
where
  conjI: \<open>\<lbrakk>P;  Q\<rbrakk> \<Longrightarrow> P \<and> Q\<close> and
  conjunct1: \<open>P \<and> Q \<Longrightarrow> P\<close> and
  conjunct2: \<open>P \<and> Q \<Longrightarrow> Q\<close> and

  disjI1: \<open>P \<Longrightarrow> P \<or> Q\<close> and
  disjI2: \<open>Q \<Longrightarrow> P \<or> Q\<close> and
  disjE: \<open>\<lbrakk>P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close> and

  impI: \<open>(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q\<close> and
  mp: \<open>\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close> and

  FalseE: \<open>False \<Longrightarrow> P\<close>

subsubsection \<open>Quantifiers\<close>

axiomatization
  All :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<forall>\<close> 10) and
  Ex :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>\<close> 10)
where
  allI: \<open>(\<And>x. P(x)) \<Longrightarrow> (\<forall>x. P(x))\<close> and
  spec: \<open>(\<forall>x. P(x)) \<Longrightarrow> P(x)\<close> and
  exI: \<open>P(x) \<Longrightarrow> (\<exists>x. P(x))\<close> and
  exE: \<open>\<lbrakk>\<exists>x. P(x); \<And>x. P(x) \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close>

subsubsection \<open>Definitions\<close>

definition \<open>True \<equiv> False \<longrightarrow> False\<close>

definition Not (\<open>\<not> _\<close> [40] 40)
  where not_def: \<open>\<not> P \<equiv> P \<longrightarrow> False\<close>

definition iff  (infixr \<open>\<longleftrightarrow>\<close> 25)
  where \<open>P \<longleftrightarrow> Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)\<close>

definition Uniq :: "('a \<Rightarrow> o) \<Rightarrow> o"
  where \<open>Uniq(P) \<equiv> (\<forall>x y. P(x) \<longrightarrow> P(y) \<longrightarrow> y = x)\<close>

definition Ex1 :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>!\<close> 10)
  where ex1_def: \<open>\<exists>!x. P(x) \<equiv> \<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x)\<close>

axiomatization where  \<comment> \<open>Reflection, admissible\<close>
  eq_reflection: \<open>(x = y) \<Longrightarrow> (x \<equiv> y)\<close> and
  iff_reflection: \<open>(P \<longleftrightarrow> Q) \<Longrightarrow> (P \<equiv> Q)\<close>

abbreviation not_equal :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>\<noteq>\<close> 50)
  where \<open>x \<noteq> y \<equiv> \<not> (x = y)\<close>

syntax "_Uniq" :: "pttrn \<Rightarrow> o \<Rightarrow> o"  ("(2\<exists>\<^sub>\<le>\<^sub>1 _./ _)" [0, 10] 10)
translations "\<exists>\<^sub>\<le>\<^sub>1x. P" \<rightleftharpoons> "CONST Uniq (\<lambda>x. P)"

print_translation \<open>
 [Syntax_Trans.preserve_binder_abs_tr' \<^const_syntax>\<open>Uniq\<close> \<^syntax_const>\<open>_Uniq\<close>]
\<close> \<comment> \<open>to avoid eta-contraction of body\<close>

subsubsection \<open>Old-style ASCII syntax\<close>

notation (ASCII)
  not_equal  (infixl \<open>~=\<close> 50) and
  Not  (\<open>~ _\<close> [40] 40) and
  conj  (infixr \<open>&\<close> 35) and
  disj  (infixr \<open>|\<close> 30) and
  All  (binder \<open>ALL \<close> 10) and
  Ex  (binder \<open>EX \<close> 10) and
  Ex1  (binder \<open>EX! \<close> 10) and
  imp  (infixr \<open>-->\<close> 25) and
  iff  (infixr \<open><->\<close> 25)

subsection \<open>Lemmas and proof tools\<close>

lemmas strip = impI allI

lemma TrueI: \<open>True\<close>
  unfolding True_def by (rule impI)

subsubsection \<open>Sequent-style elimination rules for \<open>\<and>\<close> \<open>\<longrightarrow>\<close> and \<open>\<forall>\<close>\<close>

lemma conjE:
  assumes major: \<open>P \<and> Q\<close>
    and r: \<open>\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
proof (rule r)
  show "P"
    by (rule major [THEN conjunct1])
  show "Q"
    by (rule major [THEN conjunct2])
qed

lemma impE:
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and \<open>P\<close>
  and r: \<open>Q \<Longrightarrow> R\<close>
  shows \<open>R\<close>
proof (rule r)
  show "Q"
    by (rule mp [OF major \<open>P\<close>])
qed

lemma allE:
  assumes major: \<open>\<forall>x. P(x)\<close>
    and r: \<open>P(x) \<Longrightarrow> R\<close>
  shows \<open>R\<close>
proof (rule r)
  show "P(x)"
    by (rule major [THEN spec])
qed

text \<open>Duplicates the quantifier; for use with \<^ML>\<open>eresolve_tac\<close>.\<close>
lemma all_dupE:
  assumes major: \<open>\<forall>x. P(x)\<close>
    and r: \<open>\<lbrakk>P(x); \<forall>x. P(x)\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
proof (rule r)
  show "P(x)"
    by (rule major [THEN spec])
qed (rule major)

subsubsection \<open>Negation rules, which translate between \<open>\<not> P\<close> and \<open>P \<longrightarrow> False\<close>\<close>

lemma notI: \<open>(P \<Longrightarrow> False) \<Longrightarrow> \<not> P\<close>
  unfolding not_def by (erule impI)

lemma notE: \<open>\<lbrakk>\<not> P; P\<rbrakk> \<Longrightarrow> R\<close>
  unfolding not_def by (erule mp [THEN FalseE])

lemma rev_notE: \<open>\<lbrakk>P; \<not> P\<rbrakk> \<Longrightarrow> R\<close>
  by (erule notE)

text \<open>This is useful with the special implication rules for each kind of \<open>P\<close>.\<close>
lemma not_to_imp:
  assumes \<open>\<not> P\<close>
    and r: \<open>P \<longrightarrow> False \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
  apply (rule r)
  apply (rule impI)
  apply (erule notE [OF \<open>\<not> P\<close>])
  done

text \<open>
  For substitution into an assumption \<open>P\<close>, reduce \<open>Q\<close> to \<open>P \<longrightarrow> Q\<close>, substitute into this implication, then apply \<open>impI\<close> to
  move \<open>P\<close> back into the assumptions.
\<close>
lemma rev_mp: \<open>\<lbrakk>P; P \<longrightarrow> Q\<rbrakk> \<Longrightarrow> Q\<close>
  by (erule mp)

text \<open>Contrapositive of an inference rule.\<close>
lemma contrapos:
  assumes major: \<open>\<not> Q\<close>
    and minor: \<open>P \<Longrightarrow> Q\<close>
  shows \<open>\<not> P\<close>
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

subsubsection \<open>Modus Ponens Tactics\<close>

text \<open>
  Finds \<open>P \<longrightarrow> Q\<close> and P in the assumptions, replaces implication by
  \<open>Q\<close>.
\<close>
ML \<open>
  fun mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN assume_tac ctxt i;
  fun eq_mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN eq_assume_tac i;
\<close>

subsection \<open>If-and-only-if\<close>

lemma iffI: \<open>\<lbrakk>P \<Longrightarrow> Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  unfolding iff_def
  by (rule conjI; erule impI)

lemma iffE:
  assumes major: \<open>P \<longleftrightarrow> Q\<close>
    and r: \<open>\<lbrakk>P \<longrightarrow> Q; Q \<longrightarrow> P\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  using major
  unfolding iff_def
  apply (rule conjE)
  apply (erule r)
  apply assumption
  done

subsubsection \<open>Destruct rules for \<open>\<longleftrightarrow>\<close> similar to Modus Ponens\<close>

lemma iffD1: \<open>\<lbrakk>P \<longleftrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close>
  unfolding iff_def
  apply (erule conjunct1 [THEN mp])
  apply assumption
  done

lemma iffD2: \<open>\<lbrakk>P \<longleftrightarrow> Q; Q\<rbrakk> \<Longrightarrow> P\<close>
  unfolding iff_def
  apply (erule conjunct2 [THEN mp])
  apply assumption
  done

lemma rev_iffD1: \<open>\<lbrakk>P; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> Q\<close>
  apply (erule iffD1)
  apply assumption
  done

lemma rev_iffD2: \<open>\<lbrakk>Q; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (erule iffD2)
  apply assumption
  done

lemma iff_refl: \<open>P \<longleftrightarrow> P\<close>
  by (rule iffI)

lemma iff_sym: \<open>Q \<longleftrightarrow> P \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  apply (erule iffE)
  apply (rule iffI)
  apply (assumption | erule mp)+
  done

lemma iff_trans: \<open>\<lbrakk>P \<longleftrightarrow> Q; Q \<longleftrightarrow> R\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> R\<close>
  apply (rule iffI)
  apply (assumption | erule iffE | erule (1) notE impE)+
  done

subsection \<open>Unique existence\<close>

text \<open>
  NOTE THAT the following 2 quantifications:

    \<^item> \<open>\<exists>!x\<close> such that [\<open>\<exists>!y\<close> such that P(x,y)]   (sequential)
    \<^item> \<open>\<exists>!x,y\<close> such that P(x,y)                   (simultaneous)

  do NOT mean the same thing. The parser treats \<open>\<exists>!x y.P(x,y)\<close> as sequential.
\<close>

lemma ex1I: \<open>P(a) \<Longrightarrow> (\<And>x. P(x) \<Longrightarrow> x = a) \<Longrightarrow> \<exists>!x. P(x)\<close>
  unfolding ex1_def
  apply (assumption | rule exI conjI allI impI)+
  done

text \<open>Sometimes easier to use: the premises have no shared variables. Safe!\<close>
lemma ex_ex1I: \<open>\<exists>x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> \<exists>!x. P(x)\<close>
  apply (erule exE)
  apply (rule ex1I)
   apply assumption
  apply assumption
  done

lemma ex1E: \<open>\<exists>! x. P(x) \<Longrightarrow> (\<And>x. \<lbrakk>P(x); \<forall>y. P(y) \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R\<close>
  unfolding ex1_def
  apply (assumption | erule exE conjE)+
  done

subsubsection \<open>\<open>\<longleftrightarrow>\<close> congruence rules for simplification\<close>

text \<open>Use \<open>iffE\<close> on a premise. For \<open>conj_cong\<close>, \<open>imp_cong\<close>, \<open>all_cong\<close>, \<open>ex_cong\<close>.\<close>
ML \<open>
  fun iff_tac ctxt prems i =
    resolve_tac ctxt (prems RL @{thms iffE}) i THEN
    REPEAT1 (eresolve_tac ctxt @{thms asm_rl mp} i);
\<close>

method_setup iff =
  \<open>Attrib.thms >>
    (fn prems => fn ctxt => SIMPLE_METHOD' (iff_tac ctxt prems))\<close>

lemma conj_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<and> Q) \<longleftrightarrow> (P' \<and> Q')\<close>
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

text \<open>Reversed congruence rule!  Used in ZF/Order.\<close>
lemma conj_cong2:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(Q \<and> P) \<longleftrightarrow> (Q' \<and> P')\<close>
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

lemma disj_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close> and \<open>Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<or> Q) \<longleftrightarrow> (P' \<or> Q')\<close>
  apply (insert assms)
  apply (erule iffE disjE disjI1 disjI2 |
    assumption | rule iffI | erule (1) notE impE)+
  done

lemma imp_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q')\<close>
  apply (insert assms)
  apply (assumption | rule iffI impI | erule iffE | erule (1) notE impE | iff assms)+
  done

lemma iff_cong: \<open>\<lbrakk>P \<longleftrightarrow> P'; Q \<longleftrightarrow> Q'\<rbrakk> \<Longrightarrow> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P' \<longleftrightarrow> Q')\<close>
  apply (erule iffE | assumption | rule iffI | erule (1) notE impE)+
  done

lemma not_cong: \<open>P \<longleftrightarrow> P' \<Longrightarrow> \<not> P \<longleftrightarrow> \<not> P'\<close>
  apply (assumption | rule iffI notI | erule (1) notE impE | erule iffE notE)+
  done

lemma all_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))\<close>
  apply (assumption | rule iffI allI | erule (1) notE impE | erule allE | iff assms)+
  done

lemma ex_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))\<close>
  apply (erule exE | assumption | rule iffI exI | erule (1) notE impE | iff assms)+
  done

lemma ex1_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<exists>!x. P(x)) \<longleftrightarrow> (\<exists>!x. Q(x))\<close>
  apply (erule ex1E spec [THEN mp] | assumption | rule iffI ex1I | erule (1) notE impE | iff assms)+
  done

subsection \<open>Equality rules\<close>

lemma sym: \<open>a = b \<Longrightarrow> b = a\<close>
  apply (erule subst)
  apply (rule refl)
  done

lemma trans: \<open>\<lbrakk>a = b; b = c\<rbrakk> \<Longrightarrow> a = c\<close>
  apply (erule subst, assumption)
  done

lemma not_sym: \<open>b \<noteq> a \<Longrightarrow> a \<noteq> b\<close>
  apply (erule contrapos)
  apply (erule sym)
  done

text \<open>
  Two theorems for rewriting only one instance of a definition:
  the first for definitions of formulae and the second for terms.
\<close>

lemma def_imp_iff: \<open>(A \<equiv> B) \<Longrightarrow> A \<longleftrightarrow> B\<close>
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: \<open>(A \<equiv> B) \<Longrightarrow> A = B\<close>
  apply unfold
  apply (rule refl)
  done

lemma meta_eq_to_iff: \<open>x \<equiv> y \<Longrightarrow> x \<longleftrightarrow> y\<close>
  by unfold (rule iff_refl)

text \<open>Substitution.\<close>
lemma ssubst: \<open>\<lbrakk>b = a; P(a)\<rbrakk> \<Longrightarrow> P(b)\<close>
  apply (drule sym)
  apply (erule (1) subst)
  done

text \<open>A special case of \<open>ex1E\<close> that would otherwise need quantifier
  expansion.\<close>
lemma ex1_equalsE: \<open>\<lbrakk>\<exists>!x. P(x); P(a); P(b)\<rbrakk> \<Longrightarrow> a = b\<close>
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

subsection \<open>Simplifications of assumed implications\<close>

text \<open>
  Roy Dyckhoff has proved that \<open>conj_impE\<close>, \<open>disj_impE\<close>, and
  \<open>imp_impE\<close> used with \<^ML>\<open>mp_tac\<close> (restricted to atomic formulae) is
  COMPLETE for intuitionistic propositional logic.

  See R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
  (preprint, University of St Andrews, 1991).
\<close>

lemma conj_impE:
  assumes major: \<open>(P \<and> Q) \<longrightarrow> S\<close>
    and r: \<open>P \<longrightarrow> (Q \<longrightarrow> S) \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule conjI impI major [THEN mp] r)+

lemma disj_impE:
  assumes major: \<open>(P \<or> Q) \<longrightarrow> S\<close>
    and r: \<open>\<lbrakk>P \<longrightarrow> S; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule disjI1 disjI2 impI major [THEN mp] r)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.\<close>
lemma imp_impE:
  assumes major: \<open>(P \<longrightarrow> Q) \<longrightarrow> S\<close>
    and r1: \<open>\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q\<close>
    and r2: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule impI major [THEN mp] r1 r2)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.\<close>
lemma not_impE: \<open>\<not> P \<longrightarrow> S \<Longrightarrow> (P \<Longrightarrow> False) \<Longrightarrow> (S \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (drule mp)
   apply (rule notI | assumption)+
  done

text \<open>Simplifies the implication. UNSAFE.\<close>
lemma iff_impE:
  assumes major: \<open>(P \<longleftrightarrow> Q) \<longrightarrow> S\<close>
    and r1: \<open>\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q\<close>
    and r2: \<open>\<lbrakk>Q; P \<longrightarrow> S\<rbrakk> \<Longrightarrow> P\<close>
    and r3: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+

text \<open>What if \<open>(\<forall>x. \<not> \<not> P(x)) \<longrightarrow> \<not> \<not> (\<forall>x. P(x))\<close> is an assumption?
  UNSAFE.\<close>
lemma all_impE:
  assumes major: \<open>(\<forall>x. P(x)) \<longrightarrow> S\<close>
    and r1: \<open>\<And>x. P(x)\<close>
    and r2: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (rule allI impI major [THEN mp] r1 r2)+

text \<open>
  Unsafe: \<open>\<exists>x. P(x)) \<longrightarrow> S\<close> is equivalent
  to \<open>\<forall>x. P(x) \<longrightarrow> S\<close>.\<close>
lemma ex_impE:
  assumes major: \<open>(\<exists>x. P(x)) \<longrightarrow> S\<close>
    and r: \<open>P(x) \<longrightarrow> S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule exI impI major [THEN mp] r)+

text \<open>Courtesy of Krzysztof Grabczewski.\<close>
lemma disj_imp_disj: \<open>P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> S) \<Longrightarrow> R \<or> S\<close>
  apply (erule disjE)
  apply (rule disjI1) apply assumption
  apply (rule disjI2) apply assumption
  done

ML \<open>
structure Project_Rule = Project_Rule
(
  val conjunct1 = @{thm conjunct1}
  val conjunct2 = @{thm conjunct2}
  val mp = @{thm mp}
)
\<close>

ML_file \<open>fologic.ML\<close>

lemma thin_refl: \<open>\<lbrakk>x = x; PROP W\<rbrakk> \<Longrightarrow> PROP W\<close> .

ML \<open>
structure Hypsubst = Hypsubst
(
  val dest_eq = FOLogic.dest_eq
  val dest_Trueprop = \<^dest_judgment>
  val dest_imp = FOLogic.dest_imp
  val eq_reflection = @{thm eq_reflection}
  val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
  val imp_intr = @{thm impI}
  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
\<close>

ML_file \<open>intprover.ML\<close>

subsection \<open>Intuitionistic Reasoning\<close>

setup \<open>Intuitionistic.method_setup \<^binding>\<open>iprover\<close>\<close>

lemma impE':
  assumes 1: \<open>P \<longrightarrow> Q\<close>
    and 2: \<open>Q \<Longrightarrow> R\<close>
    and 3: \<open>P \<longrightarrow> Q \<Longrightarrow> P\<close>
  shows \<open>R\<close>
proof -
  from 3 and 1 have \<open>P\<close> .
  with 1 have \<open>Q\<close> by (rule impE)
  with 2 show \<open>R\<close> .
qed

lemma allE':
  assumes 1: \<open>\<forall>x. P(x)\<close>
    and 2: \<open>P(x) \<Longrightarrow> \<forall>x. P(x) \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
proof -
  from 1 have \<open>P(x)\<close> by (rule spec)
  from this and 1 show \<open>Q\<close> by (rule 2)
qed

lemma notE':
  assumes 1: \<open>\<not> P\<close>
    and 2: \<open>\<not> P \<Longrightarrow> P\<close>
  shows \<open>R\<close>
proof -
  from 2 and 1 have \<open>P\<close> .
  with 1 show \<open>R\<close> by (rule notE)
qed

lemmas [Pure.elim!] = disjE iffE FalseE conjE exE
  and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
  and [Pure.elim 2] = allE notE' impE'
  and [Pure.intro] = exI disjI2 disjI1

setup \<open>
  Context_Rules.addSWrapper
    (fn ctxt => fn tac => hyp_subst_tac ctxt ORELSE' tac)
\<close>

lemma iff_not_sym: \<open>\<not> (Q \<longleftrightarrow> P) \<Longrightarrow> \<not> (P \<longleftrightarrow> Q)\<close>
  by iprover

lemmas [sym] = sym iff_sym not_sym iff_not_sym
  and [Pure.elim?] = iffD1 iffD2 impE

lemma eq_commute: \<open>a = b \<longleftrightarrow> b = a\<close>
  by iprover

subsection \<open>Polymorphic congruence rules\<close>

lemma subst_context: \<open>a = b \<Longrightarrow> t(a) = t(b)\<close>
  by iprover

lemma subst_context2: \<open>\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> t(a,c) = t(b,d)\<close>
  by iprover

lemma subst_context3: \<open>\<lbrakk>a = b; c = d; e = f\<rbrakk> \<Longrightarrow> t(a,c,e) = t(b,d,f)\<close>
  by iprover

text \<open>
  Useful with \<^ML>\<open>eresolve_tac\<close> for proving equalities from known
  equalities.

        a = b
        |   |
        c = d
\<close>
lemma box_equals: \<open>\<lbrakk>a = b; a = c; b = d\<rbrakk> \<Longrightarrow> c = d\<close>
  by iprover

text \<open>Dual of \<open>box_equals\<close>: for proving equalities backwards.\<close>
lemma simp_equals: \<open>\<lbrakk>a = c; b = d; c = d\<rbrakk> \<Longrightarrow> a = b\<close>
  by iprover

subsubsection \<open>Congruence rules for predicate letters\<close>

lemma pred1_cong: \<open>a = a' \<Longrightarrow> P(a) \<longleftrightarrow> P(a')\<close>
  by iprover

lemma pred2_cong: \<open>\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> P(a,b) \<longleftrightarrow> P(a',b')\<close>
  by iprover

lemma pred3_cong: \<open>\<lbrakk>a = a'; b = b'; c = c'\<rbrakk> \<Longrightarrow> P(a,b,c) \<longleftrightarrow> P(a',b',c')\<close>
  by iprover

text \<open>Special case for the equality predicate!\<close>
lemma eq_cong: \<open>\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> a = b \<longleftrightarrow> a' = b'\<close>
  by iprover

subsection \<open>Atomizing meta-level rules\<close>

lemma atomize_all [atomize]: \<open>(\<And>x. P(x)) \<equiv> Trueprop (\<forall>x. P(x))\<close>
proof
  assume \<open>\<And>x. P(x)\<close>
  then show \<open>\<forall>x. P(x)\<close> ..
next
  assume \<open>\<forall>x. P(x)\<close>
  then show \<open>\<And>x. P(x)\<close> ..
qed

lemma atomize_imp [atomize]: \<open>(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)\<close>
proof
  assume \<open>A \<Longrightarrow> B\<close>
  then show \<open>A \<longrightarrow> B\<close> ..
next
  assume \<open>A \<longrightarrow> B\<close> and \<open>A\<close>
  then show \<open>B\<close> by (rule mp)
qed

lemma atomize_eq [atomize]: \<open>(x \<equiv> y) \<equiv> Trueprop (x = y)\<close>
proof
  assume \<open>x \<equiv> y\<close>
  show \<open>x = y\<close> unfolding \<open>x \<equiv> y\<close> by (rule refl)
next
  assume \<open>x = y\<close>
  then show \<open>x \<equiv> y\<close> by (rule eq_reflection)
qed

lemma atomize_iff [atomize]: \<open>(A \<equiv> B) \<equiv> Trueprop (A \<longleftrightarrow> B)\<close>
proof
  assume \<open>A \<equiv> B\<close>
  show \<open>A \<longleftrightarrow> B\<close> unfolding \<open>A \<equiv> B\<close> by (rule iff_refl)
next
  assume \<open>A \<longleftrightarrow> B\<close>
  then show \<open>A \<equiv> B\<close> by (rule iff_reflection)
qed

lemma atomize_conj [atomize]: \<open>(A &&& B) \<equiv> Trueprop (A \<and> B)\<close>
proof
  assume conj: \<open>A &&& B\<close>
  show \<open>A \<and> B\<close>
  proof (rule conjI)
    from conj show \<open>A\<close> by (rule conjunctionD1)
    from conj show \<open>B\<close> by (rule conjunctionD2)
  qed
next
  assume conj: \<open>A \<and> B\<close>
  show \<open>A &&& B\<close>
  proof -
    from conj show \<open>A\<close> ..
    from conj show \<open>B\<close> ..
  qed
qed

lemmas [symmetric, rulify] = atomize_all atomize_imp
  and [symmetric, defn] = atomize_all atomize_imp atomize_eq atomize_iff

subsection \<open>Atomizing elimination rules\<close>

lemma atomize_exL[atomize_elim]: \<open>(\<And>x. P(x) \<Longrightarrow> Q) \<equiv> ((\<exists>x. P(x)) \<Longrightarrow> Q)\<close>
  by rule iprover+

lemma atomize_conjL[atomize_elim]: \<open>(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (A \<and> B \<Longrightarrow> C)\<close>
  by rule iprover+

lemma atomize_disjL[atomize_elim]: \<open>((A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C) \<equiv> ((A \<or> B \<Longrightarrow> C) \<Longrightarrow> C)\<close>
  by rule iprover+

lemma atomize_elimL[atomize_elim]: \<open>(\<And>B. (A \<Longrightarrow> B) \<Longrightarrow> B) \<equiv> Trueprop(A)\<close> ..

subsection \<open>Calculational rules\<close>

lemma forw_subst: \<open>a = b \<Longrightarrow> P(b) \<Longrightarrow> P(a)\<close>
  by (rule ssubst)

lemma back_subst: \<open>P(a) \<Longrightarrow> a = b \<Longrightarrow> P(b)\<close>
  by (rule subst)

text \<open>
  Note that this list of rules is in reverse order of priorities.
\<close>

lemmas basic_trans_rules [trans] =
  forw_subst
  back_subst
  rev_mp
  mp
  trans

subsection \<open>``Let'' declarations\<close>

nonterminal letbinds and letbind

definition Let :: \<open>['a::{}, 'a => 'b] \<Rightarrow> ('b::{})\<close>
  where \<open>Let(s, f) \<equiv> f(s)\<close>

syntax
  "_bind"       :: \<open>[pttrn, 'a] => letbind\<close>           (\<open>(2_ =/ _)\<close> 10)
  ""            :: \<open>letbind => letbinds\<close>              (\<open>_\<close>)
  "_binds"      :: \<open>[letbind, letbinds] => letbinds\<close>  (\<open>_;/ _\<close>)
  "_Let"        :: \<open>[letbinds, 'a] => 'a\<close>             (\<open>(let (_)/ in (_))\<close> 10)

translations
  "_Let(_binds(b, bs), e)"  == "_Let(b, _Let(bs, e))"
  "let x = a in e"          == "CONST Let(a, \<lambda>x. e)"

lemma LetI:
  assumes \<open>\<And>x. x = t \<Longrightarrow> P(u(x))\<close>
  shows \<open>P(let x = t in u(x))\<close>
  unfolding Let_def
  apply (rule refl [THEN assms])
  done

subsection \<open>Intuitionistic simplification rules\<close>

lemma conj_simps:
  \<open>P \<and> True \<longleftrightarrow> P\<close>
  \<open>True \<and> P \<longleftrightarrow> P\<close>
  \<open>P \<and> False \<longleftrightarrow> False\<close>
  \<open>False \<and> P \<longleftrightarrow> False\<close>
  \<open>P \<and> P \<longleftrightarrow> P\<close>
  \<open>P \<and> P \<and> Q \<longleftrightarrow> P \<and> Q\<close>
  \<open>P \<and> \<not> P \<longleftrightarrow> False\<close>
  \<open>\<not> P \<and> P \<longleftrightarrow> False\<close>
  \<open>(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)\<close>
  by iprover+

lemma disj_simps:
  \<open>P \<or> True \<longleftrightarrow> True\<close>
  \<open>True \<or> P \<longleftrightarrow> True\<close>
  \<open>P \<or> False \<longleftrightarrow> P\<close>
  \<open>False \<or> P \<longleftrightarrow> P\<close>
  \<open>P \<or> P \<longleftrightarrow> P\<close>
  \<open>P \<or> P \<or> Q \<longleftrightarrow> P \<or> Q\<close>
  \<open>(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)\<close>
  by iprover+

lemma not_simps:
  \<open>\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q\<close>
  \<open>\<not> False \<longleftrightarrow> True\<close>
  \<open>\<not> True \<longleftrightarrow> False\<close>
  by iprover+

lemma imp_simps:
  \<open>(P \<longrightarrow> False) \<longleftrightarrow> \<not> P\<close>
  \<open>(P \<longrightarrow> True) \<longleftrightarrow> True\<close>
  \<open>(False \<longrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(True \<longrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(P \<longrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(P \<longrightarrow> \<not> P) \<longleftrightarrow> \<not> P\<close>
  by iprover+

lemma iff_simps:
  \<open>(True \<longleftrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(P \<longleftrightarrow> True) \<longleftrightarrow> P\<close>
  \<open>(P \<longleftrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(False \<longleftrightarrow> P) \<longleftrightarrow> \<not> P\<close>
  \<open>(P \<longleftrightarrow> False) \<longleftrightarrow> \<not> P\<close>
  by iprover+

text \<open>The \<open>x = t\<close> versions are needed for the simplification
  procedures.\<close>
lemma quant_simps:
  \<open>\<And>P. (\<forall>x. P) \<longleftrightarrow> P\<close>
  \<open>(\<forall>x. x = t \<longrightarrow> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>(\<forall>x. t = x \<longrightarrow> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>\<And>P. (\<exists>x. P) \<longleftrightarrow> P\<close>
  \<open>\<exists>x. x = t\<close>
  \<open>\<exists>x. t = x\<close>
  \<open>(\<exists>x. x = t \<and> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>(\<exists>x. t = x \<and> P(x)) \<longleftrightarrow> P(t)\<close>
  by iprover+

text \<open>These are NOT supplied by default!\<close>
lemma distrib_simps:
  \<open>P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R\<close>
  \<open>(Q \<or> R) \<and> P \<longleftrightarrow> Q \<and> P \<or> R \<and> P\<close>
  \<open>(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)\<close>
  by iprover+

lemma subst_all:
  \<open>(\<And>x. x = a \<Longrightarrow> PROP P(x)) \<equiv> PROP P(a)\<close>
  \<open>(\<And>x. a = x \<Longrightarrow> PROP P(x)) \<equiv> PROP P(a)\<close>
proof -
  show \<open>(\<And>x. x = a \<Longrightarrow> PROP P(x)) \<equiv> PROP P(a)\<close>
  proof (rule equal_intr_rule)
    assume *: \<open>\<And>x. x = a \<Longrightarrow> PROP P(x)\<close>
    show \<open>PROP P(a)\<close>
      by (rule *) (rule refl)
  next
    fix x
    assume \<open>PROP P(a)\<close> and \<open>x = a\<close>
    from \<open>x = a\<close> have \<open>x \<equiv> a\<close>
      by (rule eq_reflection)
    with \<open>PROP P(a)\<close> show \<open>PROP P(x)\<close>
      by simp
  qed
  show \<open>(\<And>x. a = x \<Longrightarrow> PROP P(x)) \<equiv> PROP P(a)\<close>
  proof (rule equal_intr_rule)
    assume *: \<open>\<And>x. a = x \<Longrightarrow> PROP P(x)\<close>
    show \<open>PROP P(a)\<close>
      by (rule *) (rule refl)
  next
    fix x
    assume \<open>PROP P(a)\<close> and \<open>a = x\<close>
    from \<open>a = x\<close> have \<open>a \<equiv> x\<close>
      by (rule eq_reflection)
    with \<open>PROP P(a)\<close> show \<open>PROP P(x)\<close>
      by simp
  qed
qed

subsubsection \<open>Conversion into rewrite rules\<close>

lemma P_iff_F: \<open>\<not> P \<Longrightarrow> (P \<longleftrightarrow> False)\<close>
  by iprover
lemma iff_reflection_F: \<open>\<not> P \<Longrightarrow> (P \<equiv> False)\<close>
  by (rule P_iff_F [THEN iff_reflection])

lemma P_iff_T: \<open>P \<Longrightarrow> (P \<longleftrightarrow> True)\<close>
  by iprover
lemma iff_reflection_T: \<open>P \<Longrightarrow> (P \<equiv> True)\<close>
  by (rule P_iff_T [THEN iff_reflection])

subsubsection \<open>More rewrite rules\<close>

lemma conj_commute: \<open>P \<and> Q \<longleftrightarrow> Q \<and> P\<close> by iprover
lemma conj_left_commute: \<open>P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)\<close> by iprover
lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: \<open>P \<or> Q \<longleftrightarrow> Q \<or> P\<close> by iprover
lemma disj_left_commute: \<open>P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)\<close> by iprover
lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: \<open>P \<and> (Q \<or> R) \<longleftrightarrow> (P \<and> Q \<or> P \<and> R)\<close> by iprover
lemma conj_disj_distribR: \<open>(P \<or> Q) \<and> R \<longleftrightarrow> (P \<and> R \<or> Q \<and> R)\<close> by iprover

lemma disj_conj_distribL: \<open>P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)\<close> by iprover
lemma disj_conj_distribR: \<open>(P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)\<close> by iprover

lemma imp_conj_distrib: \<open>(P \<longrightarrow> (Q \<and> R)) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)\<close> by iprover
lemma imp_conj: \<open>((P \<and> Q) \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))\<close> by iprover
lemma imp_disj: \<open>(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)\<close> by iprover

lemma de_Morgan_disj: \<open>(\<not> (P \<or> Q)) \<longleftrightarrow> (\<not> P \<and> \<not> Q)\<close> by iprover

lemma not_ex: \<open>(\<not> (\<exists>x. P(x))) \<longleftrightarrow> (\<forall>x. \<not> P(x))\<close> by iprover
lemma imp_ex: \<open>((\<exists>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> Q)\<close> by iprover

lemma ex_disj_distrib: \<open>(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> ((\<exists>x. P(x)) \<or> (\<exists>x. Q(x)))\<close>
  by iprover

lemma all_conj_distrib: \<open>(\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> ((\<forall>x. P(x)) \<and> (\<forall>x. Q(x)))\<close>
  by iprover

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*<*)
theory Chapter3_HoareHeap
imports "AutoCorres.AutoCorres"
begin

external_file "swap.c"
(*>*)

subsection \<open>\texttt{swap}\<close>

text \<open>

  Here, we use AutoCorres to verify a C program that reads and writes to the heap.
  Our C function, \texttt{swap}, swaps two words in memory:

\lstinputlisting[language=C, firstline=11]{swap.c}

  Again, we translate the program using the C parser and AutoCorres.
\<close>

install_C_file "swap.c"
autocorres [heap_abs_syntax, ts_rules = nondet] "swap.c"
(*<*)
context swap begin
(*>*)

text \<open>
  Most heap operations in C programs consist of accessing a pointer.
  AutoCorres abstracts the global C heap by creating one heap for
  each type. (In our simple \texttt{swap} example, it creates only
  a @{typ word32} heap.) This makes verification easier as long as
  the program does not access the same memory as two different types.

  There are other operations that are relevant to program verification,
  such as changing the type that occupies a given region of memory.
  AutoCorres will not abstract any functions that use these operations,
  so verifying them will be more complicated (but still possible).
\<close>

text \<open>
  The C parser expresses \texttt{swap} like this:
\<close>

thm swap_body_def
text \<open>@{thm [display] swap_body_def}\<close>

text \<open>
  AutoCorres abstracts the function to this:
\<close>

thm swap'_def
text \<open>@{thm [display] swap'_def }\<close>

text \<open>
  There are some things to note:

  The function contains guards (assertions) that the pointers
  \texttt{a} and \texttt{b} are valid. We need to prove that
  these guards never fail when verifying \texttt{swap}.
  Conversely, when verifying any function that calls
  \texttt{swap}, we need to show that the arguments are
  valid pointers.

  We saw a monadic program in the previous section, but here
  the monad is actually being used to carry the program heap.
\<close>

(* FIXME: something about heap syntax here. *)

text \<open>
  Now we prove that \texttt{swap} is correct. We use @{term x}
  and @{term y} to ``remember'' the initial values so that we can
  talk about them in the postcondition.
\<close>
lemma "\<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply clarsimp
  txt \<open>
    The C parser and AutoCorres both model the C heap using functions,
    which takes a pointer to some object in memory. Heap updates are
    modelled using the functional update @{term fun_upd}:

      @{thm [display] fun_upd_def}

    To reason about functional updates, we use the rule fun\_upd\_apply.
\<close>
  apply (simp add: fun_upd_apply)
  done

text \<open>
  Note that we have ``only'' proved that the function swaps its
  arguments. We have not proved that it does \emph{not} change
  any other state. This is a typical \emph{frame problem} with
  pointer reasoning. We can prove a more complete specification
  of \texttt{swap}:
\<close>
lemma "(\<And>x y s. P (s[a := x][b := y]) = P s) \<Longrightarrow>
       \<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<and> P s \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<and> P s \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

text \<open>
  In other words, if predicate @{term P} does not depend on the
  inputs to \texttt{swap}, it will continue to hold.

  \emph{Separation logic} provides a more structured approach
  to this problem.
\<close>

(*<*)
end
end
(*>*)


(*    Title:              SATSolverVerification/Trail.thy
      Author:             Filip Maric
      Maintainer:         Filip Maric <filip at matf.bg.ac.yu>
*)

section\<open>Trail datatype definition and its properties\<close>

theory Trail
imports MoreList
begin

text\<open>Trail is a list in which some elements can be marked.\<close>
type_synonym 'a Trail = "('a*bool) list"

abbreviation
  element :: "('a*bool) \<Rightarrow> 'a"
  where "element x == fst x"

abbreviation
  marked :: "('a*bool) \<Rightarrow> bool"
  where "marked  x == snd x"

(*--------------------------------------------------------------------------------*)
subsection\<open>Trail elements\<close>

text\<open>Elements of the trail with marks removed\<close>
primrec
elements              :: "'a Trail \<Rightarrow> 'a list"
where
  "elements [] = []"
| "elements (h#t) = (element h) # (elements t)"

lemma
"elements t = map fst t"
by (induct t) auto

lemma eitherMarkedOrNotMarkedElement:
  shows "a = (element a, True) \<or> a = (element a, False)"
by (cases a) auto

lemma eitherMarkedOrNotMarked:
  assumes "e \<in> set (elements M)"
  shows "(e, True) \<in> set M \<or> (e, False) \<in> set M"
using assms
proof (induct M)
  case (Cons m M')
  thus ?case
    proof (cases "e = element m")
      case True
      thus ?thesis
        using eitherMarkedOrNotMarkedElement [of "m"]
        by auto
    next
      case False
      with Cons
      show ?thesis
        by auto
    qed
qed simp

lemma elementMemElements [simp]:
  assumes "x \<in> set M"
  shows "element x \<in> set (elements M)"
using assms
by (induct M) (auto split: if_split_asm)

lemma elementsAppend [simp]:
  shows "elements (a @ b) = elements a @ elements b"
by (induct a) auto

lemma elementsEmptyIffTrailEmpty [simp]:
  shows "(elements list = []) = (list = [])"
by (induct list) auto

lemma elementsButlastTrailIsButlastElementsTrail [simp]:
  shows "elements (butlast M) = butlast (elements M)"
by (induct M) auto

lemma elementLastTrailIsLastElementsTrail [simp]:
  assumes "M \<noteq> []"
  shows "element (last M) = last (elements M)"
using assms
by (induct M) auto

lemma isPrefixElements:
  assumes "isPrefix a b"
  shows "isPrefix (elements a) (elements b)"
using assms
unfolding isPrefix_def
by auto

lemma prefixElementsAreTrailElements:
  assumes
  "isPrefix p M"
  shows
  "set (elements p) \<subseteq> set (elements M)"
using assms
unfolding isPrefix_def
by auto

lemma uniqElementsTrailImpliesUniqElementsPrefix:
  assumes
  "isPrefix p M" and "uniq (elements M)"
  shows
  "uniq (elements p)"
proof-
  from \<open>isPrefix p M\<close>
  obtain s
    where "M = p @ s"
    unfolding isPrefix_def
    by auto
  with \<open>uniq (elements M)\<close>
  show ?thesis
    using uniqAppend[of "elements p" "elements s"]
    by simp
qed

lemma uniqImpliesExclusiveTrueOrFalse:
  assumes
  "(e, d) \<in> set M" and "uniq (elements M)"
  shows
  "\<not> (e, \<not> d) \<in> set M"
using assms
proof (induct M)
  case (Cons m M')
  {
    assume "(e, d) = m"
    hence "(e, \<not> d) \<noteq> m"
      by auto
    from \<open>(e, d) = m\<close> \<open>uniq (elements (m # M'))\<close>
    have "\<not> (e, d) \<in> set M'"
      by (auto simp add: uniqAppendIff)
    with Cons
    have ?case
      by (auto split: if_split_asm)
  }
  moreover
  {
    assume "(e, \<not> d) = m"
    hence "(e, d) \<noteq> m"
      by auto
    from \<open>(e, \<not> d) = m\<close> \<open>uniq (elements (m # M'))\<close>
    have "\<not> (e, \<not> d) \<in> set M'"
      by (auto simp add: uniqAppendIff)
    with Cons
    have ?case
      by (auto split: if_split_asm)
  }
  moreover
  {
    assume "(e, d) \<noteq> m" "(e, \<not> d) \<noteq> m"
    from \<open>(e, d) \<noteq> m\<close> \<open>(e, d) \<in> set (m # M')\<close> have
      "(e, d) \<in> set M'"
      by simp
    with \<open>uniq (elements (m # M'))\<close> Cons(1)
    have "\<not> (e, \<not> d) \<in> set M'"
      by simp
    with \<open>(e, \<not> d) \<noteq> m\<close>
    have ?case
      by simp
  }
  moreover
  {
    have "(e, d) = m \<or> (e, \<not> d) = m \<or> (e, d) \<noteq> m \<and> (e, \<not> d) \<noteq> m"
      by auto
  }
  ultimately
  show ?case
    by auto
qed simp

(*--------------------------------------------------------------------------------*)
subsection\<open>Marked trail elements\<close>

primrec
markedElements        :: "'a Trail \<Rightarrow> 'a list"
where
  "markedElements [] = []"
| "markedElements (h#t) =  (if (marked h) then (element h) # (markedElements t) else (markedElements t))"

lemma
"markedElements t = (elements (filter snd t))"
by (induct t) auto

lemma markedElementIsMarkedTrue:
  shows "(m \<in> set (markedElements M)) = ((m, True) \<in> set M)"
by (induct M) (auto split: if_split_asm)

lemma markedElementsAppend:
  shows "markedElements (M1 @ M2) = markedElements M1 @ markedElements M2"
by (induct M1) auto

lemma markedElementsAreElements:
  assumes "m \<in> set (markedElements M)"
  shows   "m \<in> set (elements M)"
using assms markedElementIsMarkedTrue[of "m" "M"]
by auto

lemma markedAndMemberImpliesIsMarkedElement:
  assumes "marked m" "m \<in> set M"
  shows "(element m) \<in> set (markedElements M)"
proof-
  have "m = (element m, marked m)"
    by auto
  with \<open>marked m\<close>
  have "m = (element m, True)"
    by simp
  with \<open>m \<in> set M\<close> have
    "(element m, True) \<in> set M"
    by simp
  thus ?thesis
    using markedElementIsMarkedTrue [of "element m" "M"]
    by simp
qed

lemma markedElementsPrefixAreMarkedElementsTrail:
  assumes "isPrefix p M" "m \<in> set (markedElements p)"
  shows "m \<in> set (markedElements M)"
proof-
  from \<open>m \<in> set (markedElements p)\<close>
  have "(m, True) \<in> set p"
    by (simp add: markedElementIsMarkedTrue)
  with \<open>isPrefix p M\<close>
  have "(m, True) \<in> set M"
    using prefixIsSubset[of "p" "M"]
    by auto
  thus ?thesis
    by (simp add: markedElementIsMarkedTrue)
qed

lemma markedElementsTrailMemPrefixAreMarkedElementsPrefix:
  assumes
  "uniq (elements M)" and
  "isPrefix p M" and
  "m \<in> set (elements p)" and
  "m \<in> set (markedElements M)"
  shows
  "m \<in> set (markedElements p)"
proof-
  from \<open>m \<in> set (markedElements M)\<close> have "(m, True) \<in> set M"
    by (simp add: markedElementIsMarkedTrue)
  with \<open>uniq (elements M)\<close> \<open>m \<in> set (elements p)\<close>
  have "(m, True) \<in> set p"
  proof-
    {
      assume "(m, False) \<in> set p"
      with \<open>isPrefix p M\<close>
      have "(m, False) \<in> set M"
        using prefixIsSubset[of "p" "M"]
        by auto
      with \<open>(m, True) \<in> set M\<close> \<open>uniq (elements M)\<close>
      have False
        using uniqImpliesExclusiveTrueOrFalse[of "m" "True" "M"]
        by simp
    }
    with \<open>m \<in> set (elements p)\<close>
    show ?thesis
      using eitherMarkedOrNotMarked[of "m" "p"]
      by auto
  qed
  thus ?thesis
    using markedElementIsMarkedTrue[of "m" "p"]
    by simp
qed

(*--------------------------------------------------------------------------------*)
subsection\<open>Prefix before/upto a trail element\<close>

text\<open>Elements of the trail before the first occurrence of a given element - not incuding it\<close>
primrec
prefixBeforeElement  :: "'a \<Rightarrow> 'a Trail \<Rightarrow> 'a Trail"
where
  "prefixBeforeElement e [] = []"
| "prefixBeforeElement e (h#t) =
 (if (element h) = e then
     []
  else
     (h # (prefixBeforeElement e t))
 )"

lemma "prefixBeforeElement e t = takeWhile (\<lambda> e'. element e' \<noteq> e) t"
by (induct t) auto

lemma "prefixBeforeElement e t = take (firstPos e (elements t)) t"
by (induct t) auto

text\<open>Elements of the trail before the first occurrence of a given element - incuding it\<close>
primrec
prefixToElement  :: "'a \<Rightarrow> 'a Trail \<Rightarrow> 'a Trail"
where
  "prefixToElement e [] = []"
| "prefixToElement e (h#t) =
   (if (element h) = e then
      [h]
    else
      (h # (prefixToElement e t))
   )"

lemma "prefixToElement e t = take ((firstPos e (elements t)) + 1) t"
by (induct t) auto

lemma isPrefixPrefixToElement:
  shows "isPrefix (prefixToElement e t) t"
unfolding isPrefix_def
by (induct t) auto

lemma isPrefixPrefixBeforeElement:
  shows "isPrefix (prefixBeforeElement e t) t"
unfolding isPrefix_def
by (induct t) auto

lemma prefixToElementContainsTrailElement:
  assumes "e \<in> set (elements M)"
  shows "e \<in> set (elements (prefixToElement e M))"
using assms
by (induct M) auto

lemma prefixBeforeElementDoesNotContainTrailElement:
  assumes "e \<in> set (elements M)"
  shows "e \<notin> set (elements (prefixBeforeElement e M))"
using assms
by (induct M) auto

lemma prefixToElementAppend:
  shows "prefixToElement e (M1 @ M2) =
            (if e \<in> set (elements M1) then
                prefixToElement e M1
             else
                M1 @ prefixToElement e M2
             )"
by (induct M1) auto

lemma prefixToElementToPrefixElement:
  assumes
  "isPrefix p M" and "e \<in> set (elements p)"
  shows
  "prefixToElement e M = prefixToElement e p"
using assms
unfolding isPrefix_def
proof (induct p arbitrary: M)
  case (Cons a p')
  then obtain s
    where "(a # p') @ s = M"
    by auto
  show ?case
  proof (cases "(element a) = e")
    case True
    from True \<open>(a # p') @ s = M\<close> have "prefixToElement e M = [a]"
      by auto
    moreover
    from True have "prefixToElement e (a # p') = [a]"
      by auto
    ultimately
    show ?thesis
      by simp
  next
    case False
    from False \<open>(a # p') @ s = M\<close> have "prefixToElement e M = a # prefixToElement e (p' @ s)"
      by auto
    moreover
    from False have "prefixToElement e (a # p') = a # prefixToElement e p'"
      by simp
    moreover
    from False \<open>e \<in> set (elements (a # p'))\<close> have "e \<in> set (elements p')"
      by simp
    have "? s . (p' @ s = p' @ s)"
      by simp
    from \<open>e \<in> set (elements p')\<close>  \<open>? s. (p' @ s = p' @ s)\<close>
      have "prefixToElement e (p' @ s) = prefixToElement e p'"
      using Cons(1) [of "p' @ s"]
      by simp
    ultimately show ?thesis
      by simp
  qed
qed simp

(*--------------------------------------------------------------------------------*)
subsection\<open>Marked elements upto a given trail element\<close>

text\<open>Marked elements of the trail upto the given element (which is also included if it is marked)\<close>
definition
markedElementsTo :: "'a \<Rightarrow> 'a Trail \<Rightarrow> 'a list"
where
"markedElementsTo e t = markedElements (prefixToElement e t)"

lemma markedElementsToArePrefixOfMarkedElements:
  shows "isPrefix (markedElementsTo e M) (markedElements M)"
unfolding isPrefix_def
unfolding markedElementsTo_def
by (induct M) auto

lemma markedElementsToAreMarkedElements:
  assumes "m \<in> set (markedElementsTo e M)"
  shows "m \<in> set (markedElements M)"
using assms
using markedElementsToArePrefixOfMarkedElements[of "e" "M"]
using prefixIsSubset
by auto

lemma markedElementsToNonMemberAreAllMarkedElements:
  assumes "e \<notin> set (elements M)"
  shows "markedElementsTo e M = markedElements M"
using assms
unfolding markedElementsTo_def
by (induct M) auto

lemma markedElementsToAppend:
  shows "markedElementsTo e (M1 @ M2) =
          (if e \<in> set (elements M1) then
                 markedElementsTo e M1
           else
                 markedElements M1 @ markedElementsTo e M2
          )"
unfolding markedElementsTo_def
by (auto simp add: prefixToElementAppend markedElementsAppend)

lemma markedElementsEmptyImpliesMarkedElementsToEmpty:
  assumes "markedElements M = []"
  shows "markedElementsTo e M = []"
using assms
using markedElementsToArePrefixOfMarkedElements [of "e" "M"]
unfolding isPrefix_def
by auto

lemma markedElementIsMemberOfItsMarkedElementsTo:
  assumes
  "uniq (elements M)" and "marked e" and "e \<in> set M"
  shows
  "element e \<in> set (markedElementsTo (element e) M)"
using assms
unfolding markedElementsTo_def
by (induct M) (auto split: if_split_asm)

lemma markedElementsToPrefixElement:
  assumes "isPrefix p M" and "e \<in> set (elements p)"
  shows "markedElementsTo e M = markedElementsTo e p"
unfolding markedElementsTo_def
using assms
by (simp add: prefixToElementToPrefixElement)

(*--------------------------------------------------------------------------------*)
subsection\<open>Last marked element in a trail\<close>

definition
lastMarked :: "'a Trail \<Rightarrow> 'a"
where
"lastMarked t = last (markedElements t)"

lemma lastMarkedIsMarkedElement:
  assumes "markedElements M \<noteq> []"
  shows "lastMarked M \<in> set (markedElements M)"
using assms
unfolding lastMarked_def
by simp

lemma removeLastMarkedFromMarkedElementsToLastMarkedAreAllMarkedElementsInPrefixLastMarked:
  assumes
  "markedElements M \<noteq> []"
  shows
  "removeAll (lastMarked M) (markedElementsTo (lastMarked M) M) = markedElements (prefixBeforeElement (lastMarked M) M)"
using assms
unfolding lastMarked_def
unfolding markedElementsTo_def
by (induct M) auto

lemma markedElementsToLastMarkedAreAllMarkedElements:
  assumes
  "uniq (elements M)" and "markedElements M \<noteq> []"
  shows
  "markedElementsTo (lastMarked M) M = markedElements M"
using assms
unfolding lastMarked_def
unfolding markedElementsTo_def
by (induct M) (auto simp add: markedElementsAreElements)

lemma lastTrailElementMarkedImpliesMarkedElementsToLastElementAreAllMarkedElements:
  assumes
  "marked (last M)" and "last (elements M) \<notin> set (butlast (elements M))"
  shows
  "markedElementsTo (last (elements M)) M = markedElements M"
using assms
unfolding markedElementsTo_def
by (induct M) auto

lemma lastMarkedIsMemberOfItsMarkedElementsTo:
  assumes
  "uniq (elements M)" and "markedElements M \<noteq> []"
  shows
  "lastMarked M \<in> set (markedElementsTo (lastMarked M) M)"
using assms
using markedElementsToLastMarkedAreAllMarkedElements [of "M"]
using lastMarkedIsMarkedElement [of "M"]
by auto

lemma lastTrailElementNotMarkedImpliesMarkedElementsToLAreMarkedElementsToLInButlastTrail:
  assumes "\<not> marked (last M)"
  shows "markedElementsTo e M = markedElementsTo e (butlast M)"
using assms
unfolding markedElementsTo_def
by (induct M) auto

(*--------------------------------------------------------------------------------*)
subsection\<open>Level of a trail element\<close>

text\<open>Level of an element is the number of marked elements that precede it\<close>

definition
elementLevel :: "'a \<Rightarrow> 'a Trail \<Rightarrow> nat"
where
"elementLevel e t = length (markedElementsTo e t)"

lemma elementLevelMarkedGeq1:
  assumes
  "uniq (elements M)" and "e \<in> set (markedElements M)"
  shows
  "elementLevel e M >= 1"
proof-
  from \<open>e \<in> set (markedElements M)\<close> have "(e, True) \<in> set M"
    by (simp add: markedElementIsMarkedTrue)
  with \<open>uniq (elements M)\<close>  have "e \<in> set (markedElementsTo e M)"
    using markedElementIsMemberOfItsMarkedElementsTo[of "M" "(e, True)"]
    by simp
  hence "markedElementsTo e M \<noteq> []"
    by auto
  thus ?thesis
    unfolding elementLevel_def
    using length_greater_0_conv[of "markedElementsTo e M"]
    by arith
qed

lemma elementLevelAppend:
  assumes "a \<in> set (elements M)"
  shows "elementLevel a M = elementLevel a (M @ M')"
using assms
unfolding elementLevel_def
by (simp add: markedElementsToAppend)

lemma elementLevelPrecedesLeq:
  assumes
  "precedes a b (elements M)"
  shows
  "elementLevel a M \<le> elementLevel b M"
using assms
proof (induct M)
  case (Cons m M')
  {
    assume "a = element m"
    hence ?case
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by simp
  }
  moreover
  {
    assume "b = element m"
    {
      assume "a \<noteq> b"
      hence "\<not> precedes a b (b # (elements M'))"
        by (rule noElementsPrecedesFirstElement)
      with \<open>b = element m\<close> \<open>precedes a b (elements (m # M'))\<close>
      have False
        by simp
    }
    hence "a = b"
      by auto
    hence ?case
      by simp
  }
  moreover
  {
    assume "a \<noteq> element m" "b \<noteq> element m"
    moreover
    from \<open>precedes a b (elements (m # M'))\<close>
    have "a \<in> set (elements (m # M'))" "b \<in> set (elements (m # M'))"
      unfolding precedes_def
      by (auto split: if_split_asm)
    from \<open>a \<noteq> element m\<close> \<open>a \<in> set (elements (m # M'))\<close>
    have "a \<in> set (elements M')"
      by simp
    moreover
    from \<open>b \<noteq> element m\<close> \<open>b \<in> set (elements (m # M'))\<close>
    have "b \<in> set (elements M')"
      by simp
    ultimately
    have "elementLevel a M' \<le> elementLevel b M'"
      using Cons
      unfolding precedes_def
      by auto
    hence ?case
      using \<open>a \<noteq> element m\<close> \<open>b \<noteq> element m\<close>
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by auto
  }
  ultimately
  show ?case
    by auto
next
  case Nil
  thus ?case
    unfolding precedes_def
    by simp
qed

lemma elementLevelPrecedesMarkedElementLt:
  assumes
  "uniq (elements M)" and
  "e \<noteq> d" and
  "d \<in> set (markedElements M)" and
  "precedes e d (elements M)"
  shows
  "elementLevel e M < elementLevel d M"
using assms
proof (induct M)
  case (Cons m M')
  {
    assume "e = element m"
    moreover
    with \<open>e \<noteq> d\<close> have "d \<noteq> element m"
      by simp
    moreover
    from \<open>uniq (elements (m # M'))\<close> \<open>d \<in> set (markedElements (m # M'))\<close>
    have "1 \<le> elementLevel d (m # M')"
      using elementLevelMarkedGeq1[of "m # M'" "d"]
      by auto
    moreover
    from \<open>d \<noteq> element m\<close> \<open>d \<in> set (markedElements (m # M'))\<close>
    have "d \<in> set (markedElements M')"
      by (simp split: if_split_asm)
    from \<open>uniq (elements (m # M'))\<close> \<open>d \<in> set (markedElements M')\<close>
    have "1 \<le> elementLevel d M'"
      using elementLevelMarkedGeq1[of "M'" "d"]
      by auto
    ultimately
    have ?case
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by (auto split: if_split_asm)
  }
  moreover
  {
    assume "d = element m"
    from \<open>e \<noteq> d\<close> have "\<not> precedes e d (d # (elements M'))"
      using noElementsPrecedesFirstElement[of "e" "d" "elements M'"]
      by simp
    with \<open>d = element m\<close> \<open>precedes e d (elements (m # M'))\<close>
    have False
      by simp
    hence ?case
      by simp
  }
  moreover
  {
    assume "e \<noteq> element m" "d \<noteq> element m"
    moreover
    from \<open>precedes e d (elements (m # M'))\<close>
    have "e \<in> set (elements (m # M'))" "d \<in> set (elements (m # M'))"
      unfolding precedes_def
      by (auto split: if_split_asm)
    from \<open>e \<noteq> element m\<close> \<open>e \<in> set (elements (m # M'))\<close>
    have "e \<in> set (elements M')"
      by simp
    moreover
    from \<open>d \<noteq> element m\<close> \<open>d \<in> set (elements (m # M'))\<close>
    have "d \<in> set (elements M')"
      by simp
    moreover
    from \<open>d \<noteq> element m\<close> \<open>d \<in> set (markedElements (m # M'))\<close>
    have "d \<in> set (markedElements M')"
      by (simp split: if_split_asm)
    ultimately
    have "elementLevel e M' < elementLevel d M'"
      using \<open>uniq (elements (m # M'))\<close> Cons
      unfolding precedes_def
      by auto
    hence ?case
      using \<open>e \<noteq> element m\<close> \<open>d \<noteq> element m\<close>
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by auto
  }
  ultimately
  show ?case
    by auto
qed simp

lemma differentMarkedElementsHaveDifferentLevels:
  assumes
  "uniq (elements M)" and
  "a \<in> set (markedElements M)" and
  "b \<in> set (markedElements M)" and
  "a \<noteq> b"
  shows "elementLevel a M \<noteq> elementLevel b M"
proof-
  from \<open>a \<in> set (markedElements M)\<close>
  have "a \<in> set (elements M)"
    by (simp add: markedElementsAreElements)
  moreover
  from \<open>b \<in> set (markedElements M)\<close>
  have "b \<in> set (elements M)"
    by (simp add: markedElementsAreElements)
  ultimately
  have "precedes a b (elements M) \<or> precedes b a (elements M)"
    using \<open>a \<noteq> b\<close>
    using precedesTotalOrder[of "a" "elements M" "b"]
    by simp
  moreover
  {
    assume "precedes a b (elements M)"
    with assms
    have ?thesis
      using elementLevelPrecedesMarkedElementLt[of "M" "a" "b"]
      by auto
  }
  moreover
  {
    assume "precedes b a (elements M)"
    with assms
    have ?thesis
      using elementLevelPrecedesMarkedElementLt[of "M" "b" "a"]
      by auto
  }
  ultimately
  show ?thesis
    by auto
qed

(* ------------------------------------------------------------------------- *)
subsection\<open>Current trail level\<close>

text\<open>Current level is the number of marked elements in the trail\<close>

definition
currentLevel :: "'a Trail \<Rightarrow> nat"
where
"currentLevel t = length (markedElements t)"

lemma currentLevelNonMarked:
  shows "currentLevel M = currentLevel (M @ [(l, False)])"
by (auto simp add:currentLevel_def markedElementsAppend)

lemma currentLevelPrefix:
  assumes "isPrefix a b"
  shows "currentLevel a <= currentLevel b"
using assms
unfolding isPrefix_def
unfolding currentLevel_def
by (auto simp add: markedElementsAppend)

lemma elementOnCurrentLevel:
  assumes "a \<notin> set (elements M)"
  shows "elementLevel a (M @ [(a, d)]) = currentLevel  (M @ [(a, d)])"
using assms
unfolding currentLevel_def
unfolding elementLevel_def
unfolding markedElementsTo_def
by (auto simp add: prefixToElementAppend)

(*--------------------------------------------------------------------------------*)
subsection\<open>Prefix to a given trail level\<close>

text\<open>Prefix is made or elements of the trail up to a given element level\<close>

primrec
prefixToLevel_aux :: "'a Trail \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a Trail"
where
  "(prefixToLevel_aux [] l cl) = []"
| "(prefixToLevel_aux (h#t) l cl) =
  (if (marked h) then
    (if (cl >= l) then [] else (h # (prefixToLevel_aux t l (cl+1))))
  else
    (h # (prefixToLevel_aux t l cl))
  )"

definition
prefixToLevel :: "nat \<Rightarrow> 'a Trail \<Rightarrow> 'a Trail"
where
prefixToLevel_def: "(prefixToLevel l t) == (prefixToLevel_aux t l 0)"

lemma isPrefixPrefixToLevel_aux:
  shows "\<exists> s. prefixToLevel_aux t l i @ s = t"
by (induct t arbitrary: i) auto

lemma isPrefixPrefixToLevel:
  shows "(isPrefix (prefixToLevel l t) t)"
using isPrefixPrefixToLevel_aux[of "t" "l"]
unfolding isPrefix_def
unfolding prefixToLevel_def
by simp

lemma currentLevelPrefixToLevel_aux:
  assumes "l \<ge> i"
  shows "currentLevel (prefixToLevel_aux M l i) <= l - i"
using assms
proof (induct M arbitrary: i)
  case (Cons m M')
  {
    assume "marked m" "i = l"
    hence ?case
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked m" "i < l"
    hence ?case
      using Cons(1) [of "i+1"]
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "\<not> marked m"
    hence ?case
      using Cons
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using \<open>i <= l\<close>
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma currentLevelPrefixToLevel:
  shows "currentLevel (prefixToLevel level M) \<le> level"
using currentLevelPrefixToLevel_aux[of "0" "level" "M"]
unfolding prefixToLevel_def
by simp

lemma currentLevelPrefixToLevelEq_aux:
  assumes "l \<ge> i" "currentLevel M >= l - i"
  shows "currentLevel (prefixToLevel_aux M l i) = l - i"
using assms
proof (induct M arbitrary: i)
  case (Cons m M')
  {
    assume "marked m" "i = l"
    hence ?case
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked m" "i < l"
    hence ?case
      using Cons(1) [of "i+1"]
      using Cons(3)
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "\<not> marked m"
    hence ?case
      using Cons
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using \<open>i <= l\<close>
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma currentLevelPrefixToLevelEq:
assumes
  "level \<le> currentLevel M"
shows
  "currentLevel (prefixToLevel level M) = level"
using assms
unfolding prefixToLevel_def
using currentLevelPrefixToLevelEq_aux[of "0" "level" "M"]
by simp

lemma prefixToLevel_auxIncreaseAuxilaryCounter:
  assumes "k \<ge> i"
  shows "prefixToLevel_aux M l i = prefixToLevel_aux M (l + (k - i)) k"
using assms
proof (induct M arbitrary: i k)
  case (Cons m M')
  {
    assume "\<not> marked m"
    hence ?case
      using Cons(1)[of "i" "k"] Cons(2)
      by simp
  }
  moreover
  {
    assume "i \<ge> l" "marked m"
    hence ?case
      using \<open>k \<ge> i\<close>
      by simp
  }
  moreover
  {
    assume "i < l" "marked m"
    hence ?case
      using Cons(1)[of "i+1" "k+1"] Cons(2)
      by simp
  }
  ultimately
  show ?case
    by (auto split: if_split_asm)
qed simp

lemma isPrefixPrefixToLevel_auxLowerLevel:
  assumes "i \<le> j"
  shows "isPrefix (prefixToLevel_aux M i k) (prefixToLevel_aux M j k)"
using assms
by (induct M arbitrary: k) (auto simp add:isPrefix_def)

lemma isPrefixPrefixToLevelLowerLevel:
assumes "level < level'"
shows "isPrefix (prefixToLevel level M) (prefixToLevel level' M)"
using assms
unfolding prefixToLevel_def
using isPrefixPrefixToLevel_auxLowerLevel[of "level" "level'" "M" "0"]
by simp

lemma prefixToLevel_auxPrefixToLevel_auxHigherLevel:
  assumes "i \<le> j"
  shows "prefixToLevel_aux a i k = prefixToLevel_aux (prefixToLevel_aux a j k) i k"
using assms
by (induct a arbitrary: k) auto

lemma prefixToLevelPrefixToLevelHigherLevel:
  assumes "level \<le> level'"
  shows "prefixToLevel level M = prefixToLevel level (prefixToLevel level' M)"
using assms
unfolding prefixToLevel_def
using prefixToLevel_auxPrefixToLevel_auxHigherLevel[of "level" "level'" "M" "0"]
by simp

lemma prefixToLevelAppend_aux1:
  assumes
  "l \<ge> i" and "l - i < currentLevel a"
  shows
  "prefixToLevel_aux (a @ b) l i = prefixToLevel_aux a l i"
using assms
proof (induct a arbitrary: i)
  case (Cons a a')
  {
    assume "\<not> marked a"
    hence ?case
      using Cons(1)[of "i"] \<open>i \<le> l\<close> \<open>l - i < currentLevel (a # a')\<close>
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked a" "l = i"
    hence ?case
      by simp
  }
  moreover
  {
    assume "marked a" "l > i"
    hence ?case
      using Cons(1)[of "i + 1"] \<open>i \<le> l\<close> \<open>l - i < currentLevel (a # a')\<close>
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using \<open>i \<le> l\<close>
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma prefixToLevelAppend_aux2:
  assumes
  "i \<le> l" and "currentLevel a + i \<le> l"
  shows "prefixToLevel_aux (a @ b) l i = a @ prefixToLevel_aux b l (i + (currentLevel a))"
using assms
proof (induct a arbitrary: i)
  case (Cons a a')
  {
    assume "\<not> marked a"
    hence ?case
      using Cons
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked a" "l = i"
    hence ?case
      using \<open>(currentLevel (a # a')) + i \<le> l\<close>
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked a" "l > i"
    hence "prefixToLevel_aux (a' @ b) l (i + 1) = a' @ prefixToLevel_aux b l (i + 1 + currentLevel a')"
      using Cons(1) [of "i + 1"] \<open>(currentLevel (a # a')) + i \<le> l\<close>
      unfolding currentLevel_def
      by simp
    moreover
    have "i + 1 + length (markedElements a') = i + (1 + length (markedElements a'))"
      by simp
    ultimately
    have ?case
      using \<open>marked a\<close> \<open>l > i\<close>
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using \<open>l \<ge> i\<close>
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma prefixToLevelAppend:
  shows "prefixToLevel level (a @ b) =
  (if level < currentLevel a then
      prefixToLevel level a
  else
      a @ prefixToLevel_aux b level (currentLevel a)
  )"
proof (cases "level < currentLevel a")
  case True
  thus ?thesis
    unfolding prefixToLevel_def
    using prefixToLevelAppend_aux1[of "0" "level" "a"]
    by simp
next
  case False
  thus ?thesis
    unfolding prefixToLevel_def
    using prefixToLevelAppend_aux2[of "0" "level" "a"]
    by simp
qed

lemma isProperPrefixPrefixToLevel:
  assumes "level < currentLevel t"
  shows "\<exists> s. (prefixToLevel level t) @ s = t \<and> s \<noteq> [] \<and> (marked (hd s))"
proof-
  have "isPrefix (prefixToLevel level t) t"
    by (simp add:isPrefixPrefixToLevel)
  then obtain s::"'a Trail"
    where "(prefixToLevel level t) @ s = t"
    unfolding isPrefix_def
    by auto
  moreover
  have "s \<noteq> []"
  proof-
    {
      assume "s = []"
      with \<open>(prefixToLevel level t) @ s = t\<close>
      have "prefixToLevel level t = t"
        by simp
      hence "currentLevel (prefixToLevel level t) \<le> level"
        using currentLevelPrefixToLevel[of "level" "t"]
        by simp
      with \<open>prefixToLevel level t = t\<close> have "currentLevel t \<le> level"
        by simp
      with \<open>level < currentLevel t\<close> have False
        by simp
    }
    thus ?thesis
      by auto
  qed
  moreover
  have "marked (hd s)"
  proof-
    {
      assume "\<not> marked (hd s)"
      have "currentLevel (prefixToLevel level t) \<le> level"
        by (simp add:currentLevelPrefixToLevel)
      from \<open>s \<noteq> []\<close> have "s = [hd s] @ (tl s)"
        by simp
      with \<open>(prefixToLevel level t) @ s = t\<close> have
        "t = (prefixToLevel level t) @ [hd s] @ (tl s)"
        by simp
      hence "(prefixToLevel level t) = (prefixToLevel level ((prefixToLevel level t) @ [hd s] @ (tl s)))"
        by simp
      also
      with \<open>currentLevel (prefixToLevel level t) \<le> level\<close>
      have "\<dots> = ((prefixToLevel level t) @ (prefixToLevel_aux ([hd s] @ (tl s)) level (currentLevel (prefixToLevel level t))))"
        by (auto simp add: prefixToLevelAppend)
      also
      have "\<dots> =
        ((prefixToLevel level t) @ (hd s) # prefixToLevel_aux (tl s) level (currentLevel (prefixToLevel level t)))"
      proof-
        from \<open>currentLevel (prefixToLevel level t) <= level\<close> \<open>\<not> marked (hd s)\<close>
        have "prefixToLevel_aux ([hd s] @ (tl s)) level (currentLevel (prefixToLevel level t)) =
          (hd s) # prefixToLevel_aux (tl s) level (currentLevel (prefixToLevel level t))"
          by simp
        thus ?thesis
          by simp
      qed
      ultimately
      have "(prefixToLevel level t) = (prefixToLevel level t) @ (hd s) # prefixToLevel_aux (tl s) level (currentLevel (prefixToLevel level t))"
        by simp
      hence "False"
        by auto
    }
    thus ?thesis
      by auto
  qed
  ultimately
  show ?thesis
    by auto
qed

lemma prefixToLevelElementsElementLevel:
  assumes
  "e  \<in> set (elements (prefixToLevel level M))"
  shows
  "elementLevel e M \<le> level"
proof -
  have "elementLevel e (prefixToLevel level M) \<le> currentLevel (prefixToLevel  level M)"
    by (simp add: elementLevelLeqCurrentLevel)
  moreover
  hence "currentLevel (prefixToLevel level M) \<le> level"
    using currentLevelPrefixToLevel[of "level" "M"]
    by simp
  ultimately have "elementLevel e (prefixToLevel level M) \<le> level"
    by simp
  moreover
  have "isPrefix (prefixToLevel level M) M"
    by (simp add:isPrefixPrefixToLevel)
  then obtain s
    where "(prefixToLevel level M) @ s = M"
    unfolding isPrefix_def
    by auto
  with \<open>e  \<in> set (elements (prefixToLevel level M))\<close>
  have "elementLevel e (prefixToLevel level M) = elementLevel e M"
    using elementLevelAppend [of "e" "prefixToLevel level M" "s"]
    by simp
  ultimately
  show ?thesis
    by simp
qed

lemma elementLevelLtLevelImpliesMemberPrefixToLevel_aux:
  assumes
  "e  \<in> set(elements M)" and
  "elementLevel e M + i \<le> level" and
  "i \<le> level"
  shows
  "e  \<in> set (elements (prefixToLevel_aux M level i))"
using assms
proof (induct M arbitrary: i)
  case (Cons m M')
  thus ?case
  proof (cases "e = element m")
    case True
    thus ?thesis
      using \<open>elementLevel e (m # M') + i \<le> level\<close>
      unfolding prefixToLevel_def
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by (simp split: if_split_asm)
  next
    case False
    with \<open>e \<in> set (elements (m # M'))\<close>
    have "e \<in> set (elements M')"
      by simp

    show ?thesis
    proof (cases "marked m")
      case True
      with Cons \<open>e \<noteq> element m\<close>
      have "(elementLevel e M') + i + 1 \<le> level"
        unfolding elementLevel_def
        unfolding markedElementsTo_def
        by (simp split: if_split_asm)
      moreover
      have "elementLevel e M' \<ge> 0"
        by auto
      ultimately
      have "i + 1 \<le> level"
        by simp
      with \<open>e \<in> set (elements M')\<close> \<open>(elementLevel e M') + i + 1 \<le> level\<close> Cons(1)[of "i+1"]
      have "e \<in> set (elements (prefixToLevel_aux M' level (i + 1)))"
        by simp
      with \<open>e \<noteq> element m\<close> \<open>i + 1 \<le> level\<close> True
      show ?thesis
        by simp
    next
      case False
      with \<open>e \<noteq> element m\<close> \<open>elementLevel e (m # M') + i \<le> level\<close> have "elementLevel e M' + i \<le> level"
        unfolding elementLevel_def
        unfolding markedElementsTo_def
        by (simp split: if_split_asm)
      with \<open>e \<in> set (elements M')\<close> have "e \<in> set (elements (prefixToLevel_aux M' level i))"
        using Cons
        by (auto split: if_split_asm)
      with \<open>e \<noteq> element m\<close> False show ?thesis
        by simp
    qed
  qed
qed simp

lemma elementLevelLtLevelImpliesMemberPrefixToLevel:
  assumes
  "e \<in> set (elements M)" and
  "elementLevel e M \<le> level"
  shows
  "e \<in> set (elements (prefixToLevel level M))"
using assms
using elementLevelLtLevelImpliesMemberPrefixToLevel_aux[of "e" "M" "0" "level"]
unfolding prefixToLevel_def
by simp

lemma literalNotInEarlierLevelsThanItsLevel:
  assumes
  "level < elementLevel e M"
  shows
  "e \<notin> set (elements (prefixToLevel level M))"
proof-
  {
    assume "\<not> ?thesis"
    hence "level \<ge> elementLevel e M"
      by (simp add: prefixToLevelElementsElementLevel)
    with \<open>level < elementLevel e M\<close>
    have False
      by simp
  }
  thus ?thesis
    by auto
qed

lemma elementLevelPrefixElement:
  assumes "e \<in> set (elements (prefixToLevel level M))"
  shows "elementLevel e (prefixToLevel level M) = elementLevel e M"
using assms
proof-
  have "isPrefix (prefixToLevel level M) M"
    by (simp add: isPrefixPrefixToLevel)
  then obtain s where "(prefixToLevel level M) @ s = M"
    unfolding isPrefix_def
    by auto
  with assms show ?thesis
    using elementLevelAppend[of "e" "prefixToLevel level M" "s"]
    by auto
qed

lemma currentLevelZeroTrailEqualsItsPrefixToLevelZero:
  assumes "currentLevel M = 0"
  shows "M = prefixToLevel 0 M"
using assms
proof (induct M)
  case (Cons a M')
  show ?case
  proof-
    from Cons
    have "currentLevel M' = 0" and "markedElements M' = []" and "\<not> marked a"
      unfolding currentLevel_def
      by (auto split: if_split_asm)
    thus ?thesis
      using Cons
      unfolding prefixToLevel_def
      by auto
  qed
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    unfolding prefixToLevel_def
    by simp
qed

(*--------------------------------------------------------------------------------*)
subsection\<open>Number of literals of every trail level\<close>

primrec
levelsCounter_aux :: "'a Trail \<Rightarrow> nat list \<Rightarrow> nat list"
where
  "levelsCounter_aux [] l = l"
| "levelsCounter_aux (h # t) l =
    (if (marked h) then
        levelsCounter_aux t (l @ [1])
     else
        levelsCounter_aux t (butlast l @ [Suc (last l)])
    )"

definition
levelsCounter :: "'a Trail \<Rightarrow> nat list"
where
"levelsCounter t = levelsCounter_aux t [0]"

lemma levelsCounter_aux_startIrellevant:
  "\<forall> y. y \<noteq> [] \<longrightarrow> levelsCounter_aux a (x @ y) = (x @ levelsCounter_aux a y)"
by (induct a) (auto simp add: butlastAppend)

lemma levelsCounter_auxSuffixContinues: "\<forall> l. levelsCounter_aux (a @ b) l = levelsCounter_aux b (levelsCounter_aux a l)"
by (induct a) auto

lemma levelsCounter_auxNotEmpty: "\<forall> l. l \<noteq> [] \<longrightarrow> levelsCounter_aux a l \<noteq> []"
by (induct a) auto

lemma levelsCounter_auxIncreasesFirst:
"\<forall> m n l1 l2. levelsCounter_aux a (m # l1) = n # l2 \<longrightarrow> m <= n"
proof (induct "a")
  case Nil
  {
    fix m::nat and n::nat and l1::"nat list" and l2::"nat list"
    assume "levelsCounter_aux [] (m # l1) = n # l2"
    hence "m = n"
      by simp
  }
  thus ?case
    by simp
next
  case (Cons a list)
  {
    fix m::nat and n::nat and l1::"nat list" and l2::"nat list"
    assume "levelsCounter_aux (a # list) (m # l1) = n # l2"
    have "m <= n"
    proof (cases "marked a")
      case True
      with \<open>levelsCounter_aux (a # list) (m # l1) = n # l2\<close>
      have "levelsCounter_aux list (m # l1 @ [Suc 0]) = n # l2"
        by simp
      with Cons
      show ?thesis
        by auto
    next
      case False
      show ?thesis
      proof (cases "l1 = []")
        case True
        with \<open>\<not> marked a\<close> \<open>levelsCounter_aux (a # list) (m # l1) = n # l2\<close>
        have "levelsCounter_aux list [Suc m] = n # l2"
          by simp
        with Cons
        have "Suc m <= n"
          by auto
        thus ?thesis
          by simp
      next
        case False
        with \<open>\<not> marked a\<close> \<open>levelsCounter_aux (a # list) (m # l1) = n # l2\<close>
        have "levelsCounter_aux list (m # butlast l1 @ [Suc (last l1)]) = n # l2"
          by simp
        with Cons
        show ?thesis
          by auto
      qed
    qed
  }
  thus ?case
    by simp
qed

lemma levelsCounterPrefix:
  assumes "(isPrefix p a)"
  shows "? rest. rest \<noteq> [] \<and> levelsCounter a = butlast (levelsCounter p) @ rest \<and> last (levelsCounter p) \<le> hd rest"
proof-
  from assms
  obtain s :: "'a Trail" where "p @ s = a"
    unfolding isPrefix_def
    by auto
  from \<open>p @ s = a\<close> have "levelsCounter a = levelsCounter (p @ s)"
    by simp
  show ?thesis
  proof (cases "s = []")
    case True
    have "(levelsCounter a) = (butlast (levelsCounter p)) @ [last (levelsCounter p)] \<and>
      (last (levelsCounter p)) <= hd [last (levelsCounter p)]"
      using \<open>p @ s = a\<close> \<open>s = []\<close>
      unfolding levelsCounter_def
      using levelsCounter_auxNotEmpty[of "p"]
      by auto
    thus ?thesis
      by auto
  next
    case False
    show ?thesis
    proof (cases "marked (hd s)")
      case True
      from \<open>p @ s = a\<close> have "levelsCounter a = levelsCounter (p @ s)"
        by simp
      also
      have "\<dots> = levelsCounter_aux s (levelsCounter_aux p [0])"
        unfolding levelsCounter_def
        by (simp add: levelsCounter_auxSuffixContinues)
      also
      have "\<dots> = levelsCounter_aux (tl s) ((levelsCounter_aux p [0]) @ [1])"
      proof-
        from \<open>s \<noteq> []\<close> have "s = hd s # tl s"
          by simp
        then have "levelsCounter_aux s (levelsCounter_aux p [0]) = levelsCounter_aux (hd s # tl s) (levelsCounter_aux p [0])"
          by simp
        with \<open>marked (hd s)\<close> show ?thesis
          by simp
      qed
      also
      have "\<dots> = levelsCounter_aux p [0] @ (levelsCounter_aux (tl s) [1])"
        by (simp add: levelsCounter_aux_startIrellevant)
      finally
      have "levelsCounter a = levelsCounter p @ (levelsCounter_aux (tl s) [1])"
        unfolding levelsCounter_def
        by simp
      hence "(levelsCounter a) = (butlast (levelsCounter p)) @ ([last (levelsCounter p)] @ (levelsCounter_aux (tl s) [1])) \<and>
        (last (levelsCounter p)) <= hd ([last (levelsCounter p)] @ (levelsCounter_aux (tl s) [1]))"
        unfolding levelsCounter_def
        using levelsCounter_auxNotEmpty[of "p"]
        by auto
      thus ?thesis
        by auto
    next
      case False
      from \<open>p @ s = a\<close> have "levelsCounter a = levelsCounter (p @ s)"
        by simp
      also
      have "\<dots> = levelsCounter_aux s (levelsCounter_aux p [0])"
        unfolding levelsCounter_def
        by (simp add: levelsCounter_auxSuffixContinues)
      also
      have "\<dots> = levelsCounter_aux (tl s) ((butlast (levelsCounter_aux p [0])) @ [Suc (last (levelsCounter_aux p [0]))])"
      proof-
        from \<open>s \<noteq> []\<close> have "s = hd s # tl s"
          by simp
        then have "levelsCounter_aux s (levelsCounter_aux p [0]) = levelsCounter_aux (hd s # tl s) (levelsCounter_aux p [0])"
          by simp
        with \<open>~marked (hd s)\<close> show ?thesis
          by simp
      qed
      also
      have "\<dots> = butlast (levelsCounter_aux p [0]) @ (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"
        by (simp add: levelsCounter_aux_startIrellevant)
      finally
      have "levelsCounter a = butlast (levelsCounter_aux p [0]) @ (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"
        unfolding levelsCounter_def
        by simp
      moreover
      have "hd (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) >= Suc (last (levelsCounter_aux p [0]))"
      proof-
        have "(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) \<noteq> []"
          using levelsCounter_auxNotEmpty[of "tl s"]
          by simp
        then obtain h t where "(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) = h # t"
          using neq_Nil_conv[of "(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"]
          by auto
        hence "h \<ge> Suc (last (levelsCounter_aux p [0]))"
          using levelsCounter_auxIncreasesFirst[of "tl s"]
          by auto
        with \<open>(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) = h # t\<close>
        show ?thesis
          by simp
      qed
      ultimately
      have "levelsCounter a = butlast (levelsCounter p) @ (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) \<and>
        last (levelsCounter p) \<le> hd (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"
        unfolding levelsCounter_def
        by simp
      thus ?thesis
        using levelsCounter_auxNotEmpty[of "tl s"]
        by auto
    qed
  qed
qed

lemma levelsCounterPrefixToLevel:
  assumes "p = prefixToLevel level a" "level \<ge> 0" "level < currentLevel a"
  shows "? rest . rest \<noteq> [] \<and> (levelsCounter a) = (levelsCounter p) @ rest"
proof-
  from assms
  obtain s :: "'a Trail" where "p @ s = a" "s \<noteq> []" "marked (hd s)"
    using isProperPrefixPrefixToLevel[of "level" "a"]
    by auto
  from \<open>p @ s = a\<close> have "levelsCounter a = levelsCounter (p @ s)"
    by simp
  also
  have "\<dots> = levelsCounter_aux s (levelsCounter_aux p [0])"
    unfolding levelsCounter_def
    by (simp add: levelsCounter_auxSuffixContinues)
  also
  have "\<dots> = levelsCounter_aux (tl s) ((levelsCounter_aux p [0]) @ [1])"
  proof-
    from \<open>s \<noteq> []\<close> have "s = hd s # tl s"
      by simp
    then have "levelsCounter_aux s (levelsCounter_aux p [0]) = levelsCounter_aux (hd s # tl s) (levelsCounter_aux p [0])"
      by simp
    with \<open>marked (hd s)\<close> show ?thesis
      by simp
  qed
  also
  have "\<dots> = levelsCounter_aux p [0] @ (levelsCounter_aux (tl s) [1])"
    by (simp add: levelsCounter_aux_startIrellevant)
  finally
  have "levelsCounter a = levelsCounter p @ (levelsCounter_aux (tl s) [1])"
    unfolding levelsCounter_def
    by simp
  moreover
  have "levelsCounter_aux (tl s) [1] \<noteq> []"
    by (simp add: levelsCounter_auxNotEmpty)
  ultimately
  show ?thesis
    by simp
qed

(*--------------------------------------------------------------------------------*)
subsection\<open>Prefix before last marked element\<close>

primrec
prefixBeforeLastMarked  :: "'a Trail \<Rightarrow> 'a Trail"
where
  "prefixBeforeLastMarked [] = []"
| "prefixBeforeLastMarked (h#t) =  (if (marked h) \<and> (markedElements t) = [] then [] else (h#(prefixBeforeLastMarked t)))"

lemma prefixBeforeLastMarkedIsPrefixBeforeLastLevel:
  assumes "markedElements M \<noteq> []"
  shows "prefixBeforeLastMarked M = prefixToLevel ((currentLevel M) - 1) M"
using assms
proof (induct M)
  case Nil
  thus ?case
    by simp
next
  case (Cons a M')
  thus ?case
  proof (cases "marked a")
    case True
    hence "currentLevel (a # M') \<ge> 1"
      unfolding currentLevel_def
      by simp
    with True Cons show ?thesis
      using prefixToLevel_auxIncreaseAuxilaryCounter[of "0" "1" "M'" "currentLevel M' - 1"]
      unfolding prefixToLevel_def
      unfolding currentLevel_def
      by auto
  next
    case False
    with Cons show ?thesis
      unfolding prefixToLevel_def
      unfolding currentLevel_def
      by auto
  qed
qed

lemma isPrefixPrefixBeforeLastMarked:
  shows "isPrefix (prefixBeforeLastMarked M) M"
unfolding isPrefix_def
by (induct M) auto

lemma lastMarkedNotInPrefixBeforeLastMarked:
  assumes "uniq (elements M)" and "markedElements M \<noteq> []"
  shows "\<not> (lastMarked M) \<in> set (elements (prefixBeforeLastMarked M))"
using assms
unfolding lastMarked_def
by (induct M) (auto split: if_split_asm simp add: markedElementsAreElements)

lemma uniqImpliesPrefixBeforeLastMarkedIsPrefixBeforeLastMarked:
  assumes "markedElements M \<noteq> []" and "(lastMarked M) \<notin> set (elements M)"
  shows "prefixBeforeLastMarked M = prefixBeforeElement (lastMarked M) M"
using assms
unfolding lastMarked_def
proof (induct M)
  case Nil
  thus ?case
    by auto
next
  case (Cons a M')
  show ?case
  proof (cases "marked a \<and> (markedElements M') = []")
    case True
    thus ?thesis
      unfolding lastMarked_def
      by auto
  next
    case False
    hence "last (markedElements (a # M')) = last (markedElements M')"
      by auto
    thus ?thesis
      using Cons
      by (auto split: if_split_asm simp add: markedElementsAreElements)
  qed
qed

lemma markedElementsAreElementsBeforeLastDecisionAndLastDecision:
  assumes "markedElements M \<noteq> []"
  shows "(markedElements M) = (markedElements (prefixBeforeLastMarked M)) @ [lastMarked M]"
using assms
unfolding lastMarked_def
by (induct M) (auto split: if_split_asm)

end


(*  Title:       Executable Matrix Operations on Matrices of Arbitrary Dimensions
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2013 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
theory Ordered_Semiring
imports
  "~~/src/HOL/Algebra/Ring"
  "../Abstract-Rewriting/SN_Orders"
begin

locale semiring = abelian_monoid R + monoid R for R (structure) +
  assumes l_distr: "\<lbrakk> x \<in> carrier R; y \<in> carrier R; z \<in> carrier R \<rbrakk>
      \<Longrightarrow> (x \<oplus> y) \<otimes> z = x \<otimes> z \<oplus> y \<otimes> z"
  and r_distr: "\<lbrakk> x \<in> carrier R; y \<in> carrier R; z \<in> carrier R \<rbrakk>
      \<Longrightarrow> z \<otimes> (x \<oplus> y) = z \<otimes> x \<oplus> z \<otimes> y"
  and l_null[simp]: "x \<in> carrier R \<Longrightarrow> \<zero> \<otimes> x = \<zero>"
  and r_null[simp]: "x \<in> carrier R \<Longrightarrow> x \<otimes> \<zero> = \<zero>"

lemmas (in semiring) semiring_simprules
  [algebra ring "zero R" "add R" "a_inv R" "one R" "mult R"] =
  a_closed zero_closed  m_closed one_closed
  a_assoc l_zero  a_comm m_assoc l_one l_distr
  r_zero l_null r_null
  a_lcomm r_distr

sublocale ring < semiring
  by (unfold_locales, rule l_distr, blast+, rule r_distr, blast+, auto)

record 'a ordered_semiring = "'a ring" +
  geq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succeq>\<index>" 50)
  gt :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>\<index>" 50)
  max :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("Max\<index>")

lemmas ordered_semiring_record_simps = ring_record_simps ordered_semiring.simps

locale ordered_semiring = semiring +
  assumes compat: "\<lbrakk>s \<succeq> (t :: 'a); t \<succ> u; s \<in> carrier R; t \<in> carrier R; u \<in> carrier R\<rbrakk> \<Longrightarrow> s \<succ> u"
  and compat2: "\<lbrakk>s \<succ> (t :: 'a); t \<succeq> u; s \<in> carrier R ; t \<in> carrier R; u \<in> carrier R\<rbrakk> \<Longrightarrow> s \<succ> u"
  and plus_left_mono: "\<lbrakk>x \<succeq> y; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<oplus> z \<succeq> y \<oplus> z"
  and times_left_mono: "\<lbrakk>z \<succeq> \<zero>; x \<succeq> y; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> z \<succeq> y \<otimes> z"
  and times_right_mono: "\<lbrakk>x \<succeq> \<zero>; y \<succeq> z; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> y \<succeq> x \<otimes> z"
  and geq_refl: "x \<in> carrier R \<Longrightarrow> x \<succeq> x"
  and geq_trans[trans]: "\<lbrakk>x \<succeq> y; y \<succeq> z; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<succeq> z"
  and gt_trans[trans]: "\<lbrakk>x \<succ> y; y \<succ> z; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<succ> z"
  and gt_imp_ge: "x \<succ> y \<Longrightarrow> x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> x \<succeq> y"
  and max_comm: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> Max x y = Max y x"
  and max_ge: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> Max x y \<succeq> x"
  and max_id: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> x \<succeq> y \<Longrightarrow> Max x y = x"
  and max_mono: "x \<succeq> y \<Longrightarrow> x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> z \<in> carrier R \<Longrightarrow> Max z x \<succeq> Max z y"
  and wf_max[simp, intro]: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> Max x y \<in> carrier R"
  and one_geq_zero: "\<one> \<succeq> \<zero>"
begin
lemma max_ge_right: assumes x: "x \<in> carrier R" and y: "y \<in> carrier R" shows "Max x y \<succeq> y"
  by (unfold max_comm[OF x y], rule max_ge[OF y x])

lemma wf_max0: "x \<in> carrier R \<Longrightarrow> Max \<zero> x \<in> carrier R" using wf_max[of \<zero> x] by auto

lemma max0_id_pos: assumes x: "x \<succeq> \<zero>" and wf: "x \<in> carrier R"
  shows "Max \<zero> x = x" unfolding max_comm[OF zero_closed wf] by (rule max_id[OF wf zero_closed x])
end
hide_const (open) gt geq max

subsection {* A connection between class based semirings and set based semirings *}

definition class_semiring :: "'a itself \<Rightarrow> 'b \<Rightarrow> ('a :: {plus,times,one,zero},'b)ring_scheme" where
  "class_semiring _ b \<equiv> \<lparr> carrier = UNIV, mult = op *, one = 1, zero = 0, add = op +, \<dots> = b\<rparr>"

lemma class_semiring: "semiring (class_semiring (TYPE('a :: ordered_semiring_1)) b)"
  unfolding class_semiring_def
  by (unfold_locales, auto simp: field_simps)

definition class_ordered_semiring :: "'a itself \<Rightarrow> ('a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> ('a,'b) ordered_semiring_scheme" where
  "class_ordered_semiring a gt b \<equiv> class_semiring a \<lparr>
    ordered_semiring.geq = op \<ge>,
    gt = gt,
    max = max,
    \<dots> = b\<rparr>"

lemma class_ordered_semiring: assumes "order_pair (gt :: ('a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool)) d"
  shows "ordered_semiring
    (class_ordered_semiring (TYPE('a)) gt b)"
  (is "ordered_semiring ?R")
proof -
  interpret order_pair gt d by fact
  interpret semiring ?R unfolding class_ordered_semiring_def by (rule class_semiring)
  show ?thesis
    by (unfold_locales, unfold class_ordered_semiring_def class_semiring_def, auto
    intro: compat compat2 gt_imp_ge ge_trans max_comm max_id max_mono ge_refl one_ge_zero
     times_left_mono times_right_mono plus_left_mono)
qed

lemma (in one_mono_ordered_semiring_1) class_ordered_semiring:
  "ordered_semiring
    (class_ordered_semiring (TYPE('a)) op \<succ> b)"
  by (rule class_ordered_semiring[of _ default], unfold_locales)

lemma (in both_mono_ordered_semiring_1) class_ordered_semiring:
  "ordered_semiring
    (class_ordered_semiring (TYPE('a)) op \<succ> b)"
  by (rule class_ordered_semiring[of _ default], unfold_locales)

end