(*  Title:      HOL/Unix/Nested_Environment.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Nested environments\<close>

theory Nested_Environment
imports MainRLT
begin

text \<open>
  Consider a partial function @{term [source] "e :: 'a \<Rightarrow> 'b option"}; this may
  be understood as an \<^emph>\<open>environment\<close> mapping indexes \<^typ>\<open>'a\<close> to optional
  entry values \<^typ>\<open>'b\<close> (cf.\ the basic theory \<open>Map\<close> of Isabelle/HOL). This
  basic idea is easily generalized to that of a \<^emph>\<open>nested environment\<close>, where
  entries may be either basic values or again proper environments. Then each
  entry is accessed by a \<^emph>\<open>path\<close>, i.e.\ a list of indexes leading to its
  position within the structure.
\<close>

datatype (dead 'a, dead 'b, dead 'c) env =
    Val 'a
  | Env 'b  "'c \<Rightarrow> ('a, 'b, 'c) env option"

text \<open>
  \<^medskip>
  In the type \<^typ>\<open>('a, 'b, 'c) env\<close> the parameter \<^typ>\<open>'a\<close> refers to
  basic values (occurring in terminal positions), type \<^typ>\<open>'b\<close> to values
  associated with proper (inner) environments, and type \<^typ>\<open>'c\<close> with the
  index type for branching. Note that there is no restriction on any of these
  types. In particular, arbitrary branching may yield rather large
  (transfinite) tree structures.
\<close>

subsection \<open>The lookup operation\<close>

text \<open>
  Lookup in nested environments works by following a given path of index
  elements, leading to an optional result (a terminal value or nested
  environment). A \<^emph>\<open>defined position\<close> within a nested environment is one where
  \<^term>\<open>lookup\<close> at its path does not yield \<^term>\<open>None\<close>.
\<close>

primrec lookup :: "('a, 'b, 'c) env \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"
  and lookup_option :: "('a, 'b, 'c) env option \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"
where
    "lookup (Val a) xs = (if xs = [] then Some (Val a) else None)"
  | "lookup (Env b es) xs =
      (case xs of
        [] \<Rightarrow> Some (Env b es)
      | y # ys \<Rightarrow> lookup_option (es y) ys)"
  | "lookup_option None xs = None"
  | "lookup_option (Some e) xs = lookup e xs"

hide_const lookup_option

text \<open>
  \<^medskip>
  The characteristic cases of \<^term>\<open>lookup\<close> are expressed by the following
  equalities.
\<close>

theorem lookup_nil: "lookup e [] = Some e"
  by (cases e) simp_all

theorem lookup_val_cons: "lookup (Val a) (x # xs) = None"
  by simp

theorem lookup_env_cons:
  "lookup (Env b es) (x # xs) =
    (case es x of
      None \<Rightarrow> None
    | Some e \<Rightarrow> lookup e xs)"
  by (cases "es x") simp_all

lemmas lookup.simps [simp del] lookup_option.simps [simp del]
  and lookup_simps [simp] = lookup_nil lookup_val_cons lookup_env_cons

theorem lookup_eq:
  "lookup env xs =
    (case xs of
      [] \<Rightarrow> Some env
    | x # xs \<Rightarrow>
      (case env of
        Val a \<Rightarrow> None
      | Env b es \<Rightarrow>
          (case es x of
            None \<Rightarrow> None
          | Some e \<Rightarrow> lookup e xs)))"
  by (simp split: list.split env.split)

text \<open>
  \<^medskip>
  Displaced \<^term>\<open>lookup\<close> operations, relative to a certain base path prefix,
  may be reduced as follows. There are two cases, depending whether the
  environment actually extends far enough to follow the base path.
\<close>

theorem lookup_append_none:
  assumes "lookup env xs = None"
  shows "lookup env (xs @ ys) = None"
  using assms
proof (induct xs arbitrary: env)
  case Nil
  then have False by simp
  then show ?case ..
next
  case (Cons x xs)
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with Env show ?thesis by simp
    next
      case (Some e)
      note es = \<open>es x = Some e\<close>
      show ?thesis
      proof (cases "lookup e xs")
        case None
        then have "lookup e (xs @ ys) = None" by (rule Cons.hyps)
        with Env Some show ?thesis by simp
      next
        case Some
        with Env es have False using Cons.prems by simp
        then show ?thesis ..
      qed
    qed
  qed
qed

theorem lookup_append_some:
  assumes "lookup env xs = Some e"
  shows "lookup env (xs @ ys) = lookup e ys"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show "lookup env ([] @ ys) = lookup e ys" by simp
next
  case (Cons x xs)
  note asm = \<open>lookup env (x # xs) = Some e\<close>
  show "lookup env ((x # xs) @ ys) = lookup e ys"
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases "lookup e' xs")
        case None
        with asm Env es have False by simp
        then show ?thesis ..
      next
        case Some
        with asm Env es have "lookup e' xs = Some e"
          by simp
        then have "lookup e' (xs @ ys) = lookup e ys" by (rule Cons.hyps)
        with Env es show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \<^medskip>
  Successful \<^term>\<open>lookup\<close> deeper down an environment structure means we are
  able to peek further up as well. Note that this is basically just the
  contrapositive statement of @{thm [source] lookup_append_none} above.
\<close>

theorem lookup_some_append:
  assumes "lookup env (xs @ ys) = Some e"
  shows "\<exists>e. lookup env xs = Some e"
proof -
  from assms have "lookup env (xs @ ys) \<noteq> None" by simp
  then have "lookup env xs \<noteq> None"
    by (rule contrapos_nn) (simp only: lookup_append_none)
  then show ?thesis by (simp)
qed

text \<open>
  The subsequent statement describes in more detail how a successful \<^term>\<open>lookup\<close> with a non-empty path results in a certain situation at any upper
  position.
\<close>

theorem lookup_some_upper:
  assumes "lookup env (xs @ y # ys) = Some e"
  shows "\<exists>b' es' env'.
    lookup env xs = Some (Env b' es') \<and>
    es' y = Some env' \<and>
    lookup env' ys = Some e"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  from Nil.prems have "lookup env (y # ys) = Some e"
    by simp
  then obtain b' es' env' where
      env: "env = Env b' es'" and
      es': "es' y = Some env'" and
      look': "lookup env' ys = Some e"
    by (auto simp add: lookup_eq split: option.splits env.splits)
  from env have "lookup env [] = Some (Env b' es')" by simp
  with es' look' show ?case by blast
next
  case (Cons x xs)
  from Cons.prems
  obtain b' es' env' where
      env: "env = Env b' es'" and
      es': "es' x = Some env'" and
      look': "lookup env' (xs @ y # ys) = Some e"
    by (auto simp add: lookup_eq split: option.splits env.splits)
  from Cons.hyps [OF look'] obtain b'' es'' env'' where
      upper': "lookup env' xs = Some (Env b'' es'')" and
      es'': "es'' y = Some env''" and
      look'': "lookup env'' ys = Some e"
    by blast
  from env es' upper' have "lookup env (x # xs) = Some (Env b'' es'')"
    by simp
  with es'' look'' show ?case by blast
qed

subsection \<open>The update operation\<close>

text \<open>
  Update at a certain position in a nested environment may either delete an
  existing entry, or overwrite an existing one. Note that update at undefined
  positions is simple absorbed, i.e.\ the environment is left unchanged.
\<close>

primrec update :: "'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow>
    ('a, 'b, 'c) env \<Rightarrow> ('a, 'b, 'c) env"
  and update_option :: "'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow>
    ('a, 'b, 'c) env option \<Rightarrow> ('a, 'b, 'c) env option"
where
  "update xs opt (Val a) =
    (if xs = [] then (case opt of None \<Rightarrow> Val a | Some e \<Rightarrow> e)
     else Val a)"
| "update xs opt (Env b es) =
    (case xs of
      [] \<Rightarrow> (case opt of None \<Rightarrow> Env b es | Some e \<Rightarrow> e)
    | y # ys \<Rightarrow> Env b (es (y := update_option ys opt (es y))))"
| "update_option xs opt None =
    (if xs = [] then opt else None)"
| "update_option xs opt (Some e) =
    (if xs = [] then opt else Some (update xs opt e))"

hide_const update_option

text \<open>
  \<^medskip>
  The characteristic cases of \<^term>\<open>update\<close> are expressed by the following
  equalities.
\<close>

theorem update_nil_none: "update [] None env = env"
  by (cases env) simp_all

theorem update_nil_some: "update [] (Some e) env = e"
  by (cases env) simp_all

theorem update_cons_val: "update (x # xs) opt (Val a) = Val a"
  by simp

theorem update_cons_nil_env:
    "update [x] opt (Env b es) = Env b (es (x := opt))"
  by (cases "es x") simp_all

theorem update_cons_cons_env:
  "update (x # y # ys) opt (Env b es) =
    Env b (es (x :=
      (case es x of
        None \<Rightarrow> None
      | Some e \<Rightarrow> Some (update (y # ys) opt e))))"
  by (cases "es x") simp_all

lemmas update.simps [simp del] update_option.simps [simp del]
  and update_simps [simp] = update_nil_none update_nil_some
    update_cons_val update_cons_nil_env update_cons_cons_env

lemma update_eq:
  "update xs opt env =
    (case xs of
      [] \<Rightarrow>
        (case opt of
          None \<Rightarrow> env
        | Some e \<Rightarrow> e)
    | x # xs \<Rightarrow>
        (case env of
          Val a \<Rightarrow> Val a
        | Env b es \<Rightarrow>
            (case xs of
              [] \<Rightarrow> Env b (es (x := opt))
            | y # ys \<Rightarrow>
                Env b (es (x :=
                  (case es x of
                    None \<Rightarrow> None
                  | Some e \<Rightarrow> Some (update (y # ys) opt e)))))))"
  by (simp split: list.split env.split option.split)

text \<open>
  \<^medskip>
  The most basic correspondence of \<^term>\<open>lookup\<close> and \<^term>\<open>update\<close> states
  that after \<^term>\<open>update\<close> at a defined position, subsequent \<^term>\<open>lookup\<close>
  operations would yield the new value.
\<close>

theorem lookup_update_some:
  assumes "lookup env xs = Some e"
  shows "lookup (update xs (Some env') env) xs = Some env'"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show ?case by simp
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = Some e\<close>
  show ?case
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with Env show ?thesis by simp
      next
        case (Cons x' xs')
        from asm Env es have "lookup e' xs = Some e" by simp
        then have "lookup (update xs (Some env') e') xs = Some env'" by (rule hyp)
        with Env es Cons show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \<^medskip>
  The properties of displaced \<^term>\<open>update\<close> operations are analogous to those
  of \<^term>\<open>lookup\<close> above. There are two cases: below an undefined position
  \<^term>\<open>update\<close> is absorbed altogether, and below a defined positions \<^term>\<open>update\<close> affects subsequent \<^term>\<open>lookup\<close> operations in the obvious way.
\<close>

theorem update_append_none:
  assumes "lookup env xs = None"
  shows "update (xs @ y # ys) opt env = env"
  using assms
proof (induct xs arbitrary: env)
  case Nil
  then have False by simp
  then show ?case ..
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = None\<close>
  show "update ((x # xs) @ y # ys) opt env = env"
  proof (cases env)
    case (Val a)
    then show ?thesis by simp
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      note es = \<open>es x = None\<close>
      show ?thesis
        by (cases xs) (simp_all add: es Env fun_upd_idem_iff)
    next
      case (Some e)
      note es = \<open>es x = Some e\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with asm Env Some have False by simp
        then show ?thesis ..
      next
        case (Cons x' xs')
        from asm Env es have "lookup e xs = None" by simp
        then have "update (xs @ y # ys) opt e = e" by (rule hyp)
        with Env es Cons show "update ((x # xs) @ y # ys) opt env = env"
          by (simp add: fun_upd_idem_iff)
      qed
    qed
  qed
qed

theorem update_append_some:
  assumes "lookup env xs = Some e"
  shows "lookup (update (xs @ y # ys) opt env) xs = Some (update (y # ys) opt e)"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show ?case by simp
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = Some e\<close>
  show "lookup (update ((x # xs) @ y # ys) opt env) (x # xs) =
      Some (update (y # ys) opt e)"
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with asm Env es have "e = e'" by simp
        with Env es Nil show ?thesis by simp
      next
        case (Cons x' xs')
        from asm Env es have "lookup e' xs = Some e" by simp
        then have "lookup (update (xs @ y # ys) opt e') xs =
          Some (update (y # ys) opt e)" by (rule hyp)
        with Env es Cons show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \<^medskip>
  Apparently, \<^term>\<open>update\<close> does not affect the result of subsequent \<^term>\<open>lookup\<close> operations at independent positions, i.e.\ in case that the paths
  for \<^term>\<open>update\<close> and \<^term>\<open>lookup\<close> fork at a certain point.
\<close>

theorem lookup_update_other:
  assumes neq: "y \<noteq> (z::'c)"
  shows "lookup (update (xs @ z # zs) opt env) (xs @ y # ys) =
    lookup env (xs @ y # ys)"
proof (induct xs arbitrary: env)
  case Nil
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case Env
    show ?thesis
    proof (cases zs)
      case Nil
      with neq Env show ?thesis by simp
    next
      case Cons
      with neq Env show ?thesis by simp
    qed
  qed
next
  case (Cons x xs)
  note hyp = Cons.hyps
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case (Env y es)
    show ?thesis
    proof (cases xs)
      case Nil
      show ?thesis
      proof (cases "es x")
        case None
        with Env Nil show ?thesis by simp
      next
        case Some
        with neq hyp and Env Nil show ?thesis by simp
      qed
    next
      case (Cons x' xs')
      show ?thesis
      proof (cases "es x")
        case None
        with Env Cons show ?thesis by simp
      next
        case Some
        with neq hyp and Env Cons show ?thesis by simp
      qed
    qed
  qed
qed

subsection \<open>Code generation\<close>

lemma equal_env_code [code]:
  fixes x y :: "'a::equal"
    and f g :: "'c::{equal, finite} \<Rightarrow> ('b::equal, 'a, 'c) env option"
  shows
    "HOL.equal (Env x f) (Env y g) \<longleftrightarrow>
      HOL.equal x y \<and> (\<forall>z \<in> UNIV.
        case f z of
          None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
        | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> HOL.equal a b))" (is ?env)
    and "HOL.equal (Val a) (Val b) \<longleftrightarrow> HOL.equal a b"
    and "HOL.equal (Val a) (Env y g) \<longleftrightarrow> False"
    and "HOL.equal (Env x f) (Val b) \<longleftrightarrow> False"
proof (unfold equal)
  have "f = g \<longleftrightarrow>
    (\<forall>z. case f z of
      None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
    | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> a = b))" (is "?lhs = ?rhs")
  proof
    assume ?lhs
    then show ?rhs by (auto split: option.splits)
  next
    assume ?rhs (is "\<forall>z. ?prop z")
    show ?lhs
    proof
      fix z
      from \<open>?rhs\<close> have "?prop z" ..
      then show "f z = g z" by (auto split: option.splits)
    qed
  qed
  then show "Env x f = Env y g \<longleftrightarrow>
    x = y \<and> (\<forall>z \<in> UNIV.
      case f z of
        None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
      | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> a = b))" by simp
qed simp_all

lemma [code nbe]: "HOL.equal (x :: (_, _, _) env) x \<longleftrightarrow> True"
  by (fact equal_refl)

end


subsubsection\<open>Mimicking the original\<close>

theory SC_Gentzen
imports SC_Depth SC_Cut
begin

text\<open>This system attempts to mimic the original sequent calculus
  (``Reihen von Formeln, durch Kommata getrennt'', translates roughly to sequences of formulas, separated by a comma)~\<^cite>\<open>"gentzen1935untersuchungen"\<close>.\<close>
inductive SCg :: "'a formula list \<Rightarrow> 'a formula list \<Rightarrow> bool" (infix "\<Rightarrow>" 30) where
Anfang: "[\<DD>] \<Rightarrow> [\<DD>]" |
FalschA: "[\<bottom>] \<Rightarrow> []" |
VerduennungA: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
VerduennungS: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Theta>" |
ZusammenziehungA: "\<DD>#\<DD>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
ZusammenziehungS: "\<Gamma> \<Rightarrow> \<DD>#\<DD>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Theta>" |
VertauschungA: "\<Delta>@\<DD>#\<EE>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Delta>@\<EE>#\<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
VertauschungS: "\<Gamma> \<Rightarrow> \<Theta>@\<EE>#\<DD>#\<Lambda> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<DD>#\<EE>#\<Lambda>" |
Schnitt: "\<lbrakk>\<Gamma> \<Rightarrow> \<DD>#\<Theta>; \<DD>#\<Delta> \<Rightarrow> \<Lambda>\<rbrakk> \<Longrightarrow> \<Gamma>@\<Delta> \<Rightarrow> \<Theta>@\<Lambda>" |
UES: "\<lbrakk>\<Gamma> \<Rightarrow> \<AA>#\<Theta>; \<Gamma> \<Rightarrow> \<BB>#\<Theta>\<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<and>\<BB>#\<Theta>" |
UEA1: "\<AA>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<AA>\<^bold>\<and>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" | UEA2: "\<BB>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<AA>\<^bold>\<and>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" |
OEA: "\<lbrakk>\<AA>#\<Gamma> \<Rightarrow> \<Theta>; \<BB>#\<Gamma> \<Rightarrow> \<Theta>\<rbrakk> \<Longrightarrow> \<AA>\<^bold>\<or>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" |
OES1: "\<Gamma> \<Rightarrow> \<AA>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<or>\<BB>#\<Theta>" | OES2: "\<Gamma> \<Rightarrow> \<BB>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<or>\<BB>#\<Theta>" |
FES: "\<AA>#\<Gamma> \<Rightarrow> \<BB>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<rightarrow>\<BB>#\<Theta>" |
FEA: "\<lbrakk>\<Gamma> \<Rightarrow> \<AA>#\<Theta>; \<BB>#\<Delta> \<Rightarrow> \<Lambda>\<rbrakk> \<Longrightarrow> \<AA>\<^bold>\<rightarrow>\<BB>#\<Gamma>@\<Delta> \<Rightarrow> \<Theta>@\<Lambda>" |
NES: "\<AA>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<^bold>\<not>\<AA>#\<Theta>" |
NEA: "\<Gamma> \<Rightarrow> \<AA>#\<Theta> \<Longrightarrow> \<^bold>\<not>\<AA>#\<Gamma> \<Rightarrow> \<Theta>"
text\<open>Nota bene: E here stands for ``Einführung'', which is introduction and not elemination.\<close>
text\<open>The rule for @{term \<bottom>} is not part of the original calculus. Its addition is necessary to show equivalence to our @{const SCp}.\<close>

text\<open>Note that we purposefully did not recreate the fact that Gentzen sometimes puts his principal formulas on end and sometimes on the beginning of the list.\<close>

lemma AnfangTauschA: "\<DD>#\<Delta>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Delta>@\<DD>#\<Gamma> \<Rightarrow> \<Theta>"
  by(induction \<Delta> arbitrary: \<Gamma> rule: List.rev_induct) (simp_all add: VertauschungA)
lemma AnfangTauschS: "\<Gamma> \<Rightarrow> \<DD>#\<Delta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>@\<DD>#\<Theta>"
  by(induction \<Delta> arbitrary: \<Theta> rule: List.rev_induct) (simp_all add: VertauschungS)
lemma MittenTauschA: "\<Delta>@\<DD>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Delta>@\<Gamma> \<Rightarrow> \<Theta>"
  by(induction \<Delta> arbitrary: \<Gamma> rule: List.rev_induct) (simp_all add: VertauschungA)
lemma MittenTauschS: "\<Gamma> \<Rightarrow> \<Delta>@\<DD>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Delta>@\<Theta>"
  by(induction \<Delta> arbitrary: \<Theta> rule: List.rev_induct) (simp_all add: VertauschungS)

lemma BotLe: "\<bottom>\<in>set \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>"
proof -
  have A: "\<bottom>#\<Gamma>\<Rightarrow>[]" for \<Gamma> by(induction \<Gamma>) (simp_all add: FalschA VerduennungA VertauschungA[where \<Delta>=Nil, simplified])
  have *: "\<bottom>#\<Gamma>\<Rightarrow>\<Delta>" for \<Gamma> by(induction \<Delta>) (simp_all add: A VerduennungS)
  assume "\<bottom>\<in>set \<Gamma>" then obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1@\<bottom>#\<Gamma>2" by (meson split_list)
  show ?thesis unfolding \<Gamma> using AnfangTauschA * by blast
qed

lemma Axe: "A \<in> set \<Gamma> \<Longrightarrow> A \<in> set \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  have A: "A#\<Gamma> \<Rightarrow> [A]" for \<Gamma> by(induction \<Gamma>) (simp_all add: Anfang VertauschungA[where \<Delta>=Nil, simplified] VerduennungA)
  have S: "A#\<Gamma> \<Rightarrow> A#\<Delta>" for \<Gamma> \<Delta> by(induction \<Delta>) (simp_all add: A Anfang VertauschungS[where \<Theta>=Nil, simplified] VerduennungS)
  assume "A \<in> set \<Gamma>" "A \<in> set \<Delta>" thus ?thesis
    apply(-)
    apply(drule split_list)+
    apply(clarify)
    apply(intro AnfangTauschA AnfangTauschS)
    apply(rule S)
  done
qed

lemma VerduennungListeA: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma>@\<Gamma> \<Rightarrow> \<Theta>"
proof -
  have "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Gamma>''. \<Gamma>=\<Gamma>''@\<Gamma>' \<Longrightarrow> \<Gamma>'@\<Gamma> \<Rightarrow> \<Theta>" for \<Gamma>'
  proof(induction \<Gamma>')
    case (Cons a as)
    then obtain \<Gamma>'' where "\<Gamma> = \<Gamma>'' @ a # as" by blast
    hence "\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ as" by(intro exI[where x="\<Gamma>'' @ [a]"]) simp
    from Cons.IH[OF Cons.prems(1) this] have "as @ \<Gamma> \<Rightarrow> \<Theta>" .
    thus ?case using VerduennungA by simp
  qed simp
  thus "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma>@\<Gamma> \<Rightarrow> \<Theta>" by simp
qed
lemma VerduennungListeS: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<Theta>"
proof -
  have "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Theta>''. \<Theta>=\<Theta>''@\<Theta>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>'@\<Theta>" for \<Theta>'
  proof(induction \<Theta>')
    case (Cons a as)
    then obtain \<Theta>'' where "\<Theta> = \<Theta>'' @ a # as" by blast
    hence "\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ as" by(intro exI[where x="\<Theta>'' @ [a]"]) simp
    from Cons.IH[OF Cons.prems(1) this] have " \<Gamma> \<Rightarrow> as @ \<Theta>" .
    thus ?case using VerduennungS by simp
  qed simp
  thus "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<Theta>" by simp
qed
(* wak, those weren't the droids I was looking for. *)
lemma ZusammenziehungListeA: "\<Gamma>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>"
proof -
  have "\<Gamma>'@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Gamma>''. \<Gamma>=\<Gamma>''@\<Gamma>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" for \<Gamma>'
  proof(induction \<Gamma>')
    case (Cons a \<Gamma>')
    then obtain \<Gamma>'' where \<Gamma>'': "\<Gamma> = \<Gamma>'' @ a # \<Gamma>'" by blast
    then obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ a # \<Gamma>2" by blast
    from \<Gamma>'' have **: "\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ \<Gamma>'" by(intro exI[where x="\<Gamma>'' @ [a]"]) simp
    from Cons.prems(1) have "a # (a # \<Gamma>') @ \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Theta>" unfolding \<Gamma>  using MittenTauschA by (metis append_assoc)
    hence "(a # \<Gamma>') @ \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Theta>" using ZusammenziehungA by auto
    hence "\<Gamma>' @ \<Gamma> \<Rightarrow> \<Theta>" unfolding \<Gamma>  using AnfangTauschA by (metis append_Cons append_assoc)
    from Cons.IH[OF this **] show "\<Gamma> \<Rightarrow> \<Theta>" .
  qed simp
  thus "\<Gamma>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" by simp
qed
lemma ZusammenziehungListeS: "\<Gamma> \<Rightarrow> \<Theta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>"
proof -
  have "\<Gamma> \<Rightarrow> \<Theta>'@\<Theta> \<Longrightarrow> \<exists>\<Theta>''. \<Theta>=\<Theta>''@\<Theta>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" for \<Theta>'
  proof(induction \<Theta>')
    case (Cons a \<Theta>')
    then obtain \<Theta>'' where \<Theta>'': "\<Theta> = \<Theta>'' @ a # \<Theta>'" by blast
    then obtain \<Theta>1 \<Theta>2 where \<Theta>: "\<Theta> = \<Theta>1 @ a # \<Theta>2" by blast
    from \<Theta>'' have **: "\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ \<Theta>'" by(intro exI[where x="\<Theta>'' @ [a]"]) simp
    from Cons.prems(1) have "\<Gamma> \<Rightarrow> a # (a # \<Theta>') @ \<Theta>1 @ \<Theta>2" unfolding \<Theta>  using MittenTauschS by (metis append_assoc)
    hence "\<Gamma> \<Rightarrow> (a # \<Theta>') @ \<Theta>1 @ \<Theta>2" using ZusammenziehungS by auto
    hence "\<Gamma> \<Rightarrow> \<Theta>' @ \<Theta>" unfolding \<Theta>  using AnfangTauschS by (metis append_Cons append_assoc)
    from Cons.IH[OF this **] show "\<Gamma> \<Rightarrow> \<Theta>" .
  qed simp
  thus "\<Gamma> \<Rightarrow> \<Theta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow>\<Theta>" by simp
qed

theorem gentzen_sc_eq: "mset \<Gamma> \<Rightarrow> mset \<Delta> \<longleftrightarrow> \<Gamma> \<Rightarrow> \<Delta>" proof
  assume "mset \<Gamma> \<Rightarrow> mset \<Delta>"
  then obtain n where "mset \<Gamma> \<Rightarrow> mset \<Delta> \<down> n" unfolding SC_SCp_eq[symmetric] ..
  thus "\<Gamma> \<Rightarrow> \<Delta>"
  (* structural induction not necessary at all. I still don't get it. *)
  proof(induction n arbitrary: \<Gamma> \<Delta> rule: nat.induct)
    case (Suc n)
    have sr: "\<exists>\<Gamma>1 \<Gamma>2. \<Gamma> = \<Gamma>1 @ F # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" (is "?s") if "mset \<Gamma> = F, \<Gamma>'" for \<Gamma> \<Gamma>' F proof -
      from that obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F # \<Gamma>2" by (metis split_list add.commute ex_mset list.set_intros(1) mset.simps(2) set_mset_mset)
      hence \<Gamma>': "\<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" using that by auto
      show ?s using \<Gamma> \<Gamma>' by blast
    qed
    from Suc.prems show ?case proof(cases rule: SCc.cases)
      case BotL thus ?thesis using BotLe by simp
    next
      case Ax thus ?thesis using Axe by simp
    next
      case (NotL \<Gamma>' F)
      from \<open>mset \<Gamma> = \<^bold>\<not> F, \<Gamma>'\<close> obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ \<^bold>\<not> F # \<Gamma>2"
        by (metis split_list add.commute ex_mset list.set_intros(1) mset.simps(2) set_mset_mset)
      hence \<Gamma>': "\<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" using NotL(1) by simp
      from \<open>\<Gamma>' \<Rightarrow> F, mset \<Delta> \<down> n\<close> have "mset (\<Gamma>1@\<Gamma>2) \<Rightarrow> mset (F#\<Delta>) \<down> n" unfolding \<Gamma>' by (simp add: add.commute)
      from Suc.IH[OF this] show ?thesis unfolding \<Gamma> using AnfangTauschA NEA by blast
    next
      case (NotR F \<Delta>')
      from sr[OF NotR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ \<^bold>\<not> F # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
        by blast
      with NotR have "mset (F#\<Gamma>) \<Rightarrow> mset (\<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)
      from Suc.IH[OF this] show ?thesis using \<Delta> using AnfangTauschS NES by blast
    next
      case (AndR F \<Delta>' G)
      from sr[OF AndR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ F \<^bold>\<and> G # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
        by blast
      with AndR have "mset \<Gamma> \<Rightarrow> mset (F # \<Delta>1@\<Delta>2) \<down> n" "mset \<Gamma> \<Rightarrow> mset (G # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)+
      from this[THEN Suc.IH] show ?thesis using \<Delta> using AnfangTauschS UES by blast
    next
      case (OrR F G \<Delta>')
      from sr[OF OrR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ F \<^bold>\<or> G # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
        by blast
      with OrR have "mset \<Gamma> \<Rightarrow> mset (G # F # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute add.left_commute add_mset_commute)
      from this[THEN Suc.IH] have "\<Gamma> \<Rightarrow> G # F # \<Delta>1 @ \<Delta>2" .
      with OES2 have "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # F # \<Delta>1 @ \<Delta>2" .
      with VertauschungS[where \<Theta>=Nil, simplified] have "\<Gamma> \<Rightarrow> F # F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" .
      with OES1 have "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" .
      hence "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" using ZusammenziehungS by fast
      thus ?thesis unfolding \<Delta>[THEN conjunct1] using AnfangTauschS by blast
    next
      case (ImpR F G \<Delta>')
      from sr[OF ImpR(1)] obtain \<Delta>1 \<Delta>2 where \<Delta>: "\<Delta> = \<Delta>1 @ F \<^bold>\<rightarrow> G # \<Delta>2 \<and> \<Delta>' = mset (\<Delta>1 @ \<Delta>2)"
        by blast
      with ImpR have "mset (F#\<Gamma>) \<Rightarrow> mset (G # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)
      from this[THEN Suc.IH] show ?thesis using \<Delta> using AnfangTauschS FES by blast
    next
      case (AndL F G \<Gamma>')
      from sr[OF this(1)] obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F \<^bold>\<and> G # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1 @ \<Gamma>2)"
        by blast
      with AndL have "mset (G # F # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute add.left_commute add_mset_commute)
      from this[THEN Suc.IH] have "G # F # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      with UEA2 have "F \<^bold>\<and> G # F # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      with VertauschungA[where \<Delta>=Nil, simplified] have "F # F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      with UEA1 have "F \<^bold>\<and> G # F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      hence "F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" using ZusammenziehungA by fast
      thus ?thesis unfolding \<Gamma>[THEN conjunct1] using AnfangTauschA by blast
    next
      case (OrL F \<Delta>' G)
      from sr[OF this(1)] obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F \<^bold>\<or> G # \<Gamma>2 \<and> \<Delta>' = mset (\<Gamma>1 @ \<Gamma>2)"
        by blast
      with OrL have "mset (F # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" "mset (G # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute)+
      from this[THEN Suc.IH] show ?thesis using \<Gamma> using AnfangTauschA OEA by blast
    next
      case (ImpL \<Gamma>' F G)
      from sr[OF this(1)] obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F \<^bold>\<rightarrow> G # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1 @ \<Gamma>2)"
        by blast
      with ImpL have "mset (\<Gamma>1@\<Gamma>2) \<Rightarrow> mset (F#\<Delta>) \<down> n" "mset (G # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute)+
      from this[THEN Suc.IH] have "\<Gamma>1 @ \<Gamma>2 \<Rightarrow> F # \<Delta>" "G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      from FEA[OF this] have "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) @ (\<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" .
      hence "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) @ (F \<^bold>\<rightarrow> G # \<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" using AnfangTauschA VerduennungA by blast (* given the form of ZusammenziehungListeA, using this intermediate step is just easier. maybe a different from for ZusammenziehungListeA would be nice? *)
      hence "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" using ZusammenziehungListeA[where \<Gamma>="F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2)"] by simp
      thus ?thesis unfolding \<Gamma>[THEN conjunct1] by(intro AnfangTauschA; elim ZusammenziehungListeS)
    qed
  qed blast
next
  have mset_Cons[simp]: "mset (A # S) = A, mset S" for A::"'a formula" and S by (simp add: add.commute)
  note mset.simps(2)[simp del]
  show "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> mset \<Gamma> \<Rightarrow> mset \<Delta>" proof(induction rule: SCg.induct)
    (*sed -n '/^\([^\\]*\):/ {N;s/_\\\?//g; s/let.*$//; s/\n//; s/[\\:]//g; s/fix //; s/  / /g; s/^.*$/case (&) thus ?case sorry/; p;}' ${print_cases} *)
    case (Anfang \<DD>) thus ?case using extended_Ax SC_SCp_eq by force
  next
    case (FalschA) thus ?case using SCp.BotL by force
  next
    case (VerduennungA \<Gamma> \<Theta> \<DD>) thus ?case by (simp add: SC.weakenL)
  next
    case (VerduennungS \<Gamma> \<Theta> \<DD>) thus ?case by (simp add: SC.weakenR)
  next
    case (ZusammenziehungA \<DD> \<Gamma> \<Theta>) thus ?case using contractL by force
  next
    case (ZusammenziehungS \<Gamma> \<DD> \<Theta>) thus ?case using contract by force
  next
    case (VertauschungA \<Delta> \<DD> \<EE> \<Gamma> \<Theta>) thus ?case by fastforce
  next
    case (VertauschungS \<Gamma> \<Theta> \<EE> \<DD> \<Lambda>) thus ?case by fastforce
  next
    case (Schnitt \<Gamma> \<DD> \<Theta> \<Delta> \<Lambda>)
    hence "mset \<Gamma> \<Rightarrow> \<DD>,mset \<Theta>" "\<DD>,mset \<Delta> \<Rightarrow> mset \<Lambda>" using SC_SCp_eq by auto
    from cut_cf[OF this] show ?case unfolding SC_SCp_eq by simp
  next
    case (UES \<Gamma> \<AA> \<Theta> \<BB>) thus ?case using SCp.AndR by (simp add: SC_SCp_eq)
  next
    case (UEA1 \<AA> \<Gamma> \<Theta> \<BB>)
    from \<open>mset (\<AA> # \<Gamma>) \<Rightarrow> mset \<Theta>\<close> have "\<AA>,\<BB>,mset \<Gamma> \<Rightarrow> mset \<Theta>" using SC.weakenL by auto
    thus ?case using SCp.AndL by force
  next
    case (UEA2 \<BB> \<Gamma> \<Theta> \<AA>)
    from \<open>mset (\<BB> # \<Gamma>) \<Rightarrow> mset \<Theta>\<close> have "\<AA>,\<BB>,mset \<Gamma> \<Rightarrow> mset \<Theta>" using SC.weakenL by auto
    thus ?case using SCp.AndL by force
  next
    case (OEA \<AA> \<Gamma> \<Theta> \<BB>) thus ?case unfolding SC_SCp_eq by (simp add: SCp.OrL)
  next
    case (OES1 \<Gamma> \<AA> \<Theta> \<BB>) thus ?case using SC.weakenR[where 'a='a] by(auto intro!: SCp.intros(3-))
  next
    case (OES2 \<Gamma> \<BB> \<Theta> \<AA>) thus ?case by (simp add: SC.weakenR SCp.OrR)
  next
    case (FES \<AA> \<Gamma> \<BB> \<Theta>) thus ?case using weakenR unfolding SC_SCp_eq by (simp add: SCp.ImpR)
  next
    case (FEA \<Gamma> \<AA> \<Theta> \<BB> \<Delta> \<Lambda>)
    from \<open>mset \<Gamma> \<Rightarrow> mset (\<AA> # \<Theta>)\<close>[THEN weakenL_set, THEN weakenR_set, of "mset \<Delta>" "mset \<Lambda>"]
    have S: "mset (\<Gamma>@\<Delta>) \<Rightarrow> \<AA>,mset (\<Theta>@\<Lambda>)" unfolding mset_append mset_Cons by (simp add: add_ac) (* sledgehammer comes up with some funny proof using cut\<dots> *)
    from FEA obtain m where "mset (\<BB> # \<Delta>) \<Rightarrow> mset \<Lambda>" by blast
    hence "mset \<Gamma> + mset (\<BB> # \<Delta>) \<Rightarrow> mset \<Theta> + mset \<Lambda>" using weakenL_set weakenR_set by fast
    hence A: "\<BB>,mset (\<Gamma>@\<Delta>) \<Rightarrow> mset (\<Theta>@\<Lambda>)" by (simp add: add.left_commute)
    show ?case using S A SC_SCp_eq SCp.ImpL unfolding mset_Cons by blast
  next
    case (NES \<AA> \<Gamma> \<Theta>) thus ?case using SCp.NotR by(simp add: SC_SCp_eq)
  next
    case (NEA \<Gamma> \<AA> \<Theta>) thus ?case using SCp.NotL by(simp add: SC_SCp_eq)
  qed
qed

end


theory TA_DBM_Operations
  imports Timed_Automata DBM.DBM_Operations
begin

section \<open>From Clock Constraints to DBMs\<close>

fun abstra ::
  "('c, 't::{linordered_cancel_ab_monoid_add,uminus}) acconstraint \<Rightarrow> 't DBM \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> 't DBM"
where
  "abstra (EQ c d) M v =
    (\<lambda> i j . if i = 0 \<and> j = v c then min (M i j) (Le (-d)) else if i = v c \<and> j = 0 then min (M i j) (Le d) else M i j)" |
  "abstra (LT c d) M v =
    (\<lambda> i j . if i = v c \<and> j = 0 then min (M i j) (Lt d) else M i j)" |
  "abstra (LE c d) M v =
    (\<lambda> i j . if i = v c \<and> j = 0 then min (M i j) (Le d) else M i j)" |
  "abstra (GT c d) M v =
    (\<lambda> i j. if i = 0 \<and> j = v c then min (M i j) (Lt (- d)) else M i j)" |
  "abstra (GE c d) M v =
    (\<lambda> i j. if i = 0 \<and> j = v c then min (M i j) (Le (- d)) else M i j)"

fun abstr ::"('c, 't::{linordered_cancel_ab_monoid_add,uminus}) cconstraint \<Rightarrow> 't DBM \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> 't DBM"
where
  "abstr cc M v = fold (\<lambda> ac M. abstra ac M v) cc M"

(* XXX Move *)
lemma collect_clks_Cons[simp]:
  "collect_clks (ac # cc) = insert (constraint_clk ac) (collect_clks cc)"
unfolding collect_clks_def by auto

lemma abstr_id1:
  "c \<notin> collect_clks cc \<Longrightarrow> clock_numbering' v n \<Longrightarrow> \<forall> c \<in> collect_clks cc. v c \<le> n
    \<Longrightarrow> abstr cc M v 0 (v c) = M 0 (v c)"
apply (induction cc arbitrary: M c)
apply (simp; fail)
 subgoal for a
  apply simp
  apply (cases a)
 by auto
done

lemma abstr_id2:
  "c \<notin> collect_clks cc \<Longrightarrow> clock_numbering' v n \<Longrightarrow> \<forall> c \<in> collect_clks cc. v c \<le> n
    \<Longrightarrow> abstr cc M v (v c) 0 = M (v c) 0"
apply (induction cc arbitrary: M c)
apply (simp; fail)
 subgoal for a
  apply simp
  apply (cases a)
 by auto
done

text \<open>
  This lemma is trivial because we constrained our theory to difference constraints.
\<close>

lemma abstra_id3:
  assumes "clock_numbering v"
  shows "abstra ac M v (v c1) (v c2) = M (v c1) (v c2)"
proof -
  have "\<And>c. v c = 0 \<Longrightarrow> False"
  proof -
    fix c assume "v c = 0"
    moreover from assms have "v c > 0" by auto
    ultimately show False by linarith
  qed
  then show ?thesis by (cases ac) auto
qed

lemma abstr_id3:
  "clock_numbering v \<Longrightarrow> abstr cc M v (v c1) (v c2) = M (v c1) (v c2)"
by (induction cc arbitrary: M) (auto simp add: abstra_id3)

lemma abstra_id3':
  assumes "\<forall>c. 0 < v c"
  shows "abstra ac M v 0 0 = M 0 0"
proof -
  have "\<And>c. v c = 0 \<Longrightarrow> False"
  proof -
    fix c assume "v c = 0"
    moreover from assms have "v c > 0" by auto
    ultimately show False by linarith
  qed
  then show ?thesis by (cases ac) auto
qed

lemma abstr_id3':
  "clock_numbering v \<Longrightarrow> abstr cc M v 0 0 = M 0 0"
by (induction cc arbitrary: M) (auto simp add: abstra_id3')

(* XXX Move *)
lemma clock_numberingD:
  assumes "clock_numbering v" "v c = 0"
  shows "A"
proof-
  from assms(1) have "v c > 0" by auto
  with \<open>v c = 0\<close> show ?thesis by linarith
qed

lemma dbm_abstra_soundness:
  "\<lbrakk>u \<turnstile>\<^sub>a ac; u \<turnstile>\<^bsub>v,n\<^esub> M; clock_numbering' v n; v (constraint_clk ac) \<le> n\<rbrakk>
    \<Longrightarrow> DBM_val_bounded v u (abstra ac M v) n"
proof (unfold DBM_val_bounded_def, auto, goal_cases)
  case prems: 1
  from abstra_id3'[OF this(4)] have "abstra ac M v 0 0 = M 0 0" .
  with prems show ?case unfolding dbm_le_def by auto
next
  case prems: (2 c)
  then have "clock_numbering' v n" by auto
  note A = prems(1) this prems(6,3)
  let ?c = "constraint_clk ac"
  show ?case
  proof (cases "c = ?c")
    case True
    then show ?thesis using prems by (cases ac) (auto split: split_min intro: clock_numberingD)
  next
    case False
    then show ?thesis using A(3) prems by (cases ac) auto
  qed
next
  case prems: (3 c)
  then have "clock_numbering' v n" by auto
  then have gt0: "v c > 0" by auto
  let ?c = "constraint_clk ac"
  show ?case
  proof (cases "c = ?c")
    case True
    then show ?thesis using prems gt0 by (cases ac) (auto split: split_min intro: clock_numberingD)
  next
    case False
    then show ?thesis using \<open>clock_numbering' v n\<close> prems by (cases ac) auto
  qed
next
  text \<open>Trivial because of missing difference constraints\<close>
  case prems: (4 c1 c2)
  from abstra_id3[OF this(4)] have "abstra ac M v (v c1) (v c2) = M (v c1) (v c2)" by auto
  with prems show ?case by auto
qed

lemma dbm_abstr_soundness':
  "\<lbrakk>u \<turnstile> cc; u \<turnstile>\<^bsub>v,n\<^esub> M; clock_numbering' v n; \<forall> c \<in> collect_clks cc. v c \<le> n\<rbrakk>
    \<Longrightarrow> DBM_val_bounded v u (abstr cc M v) n"
  by (induction cc arbitrary: M) (auto simp: clock_val_def dest: dbm_abstra_soundness)

lemmas dbm_abstr_soundness = dbm_abstr_soundness'[OF _ DBM_triv]

lemma dbm_abstra_completeness:
  "\<lbrakk>DBM_val_bounded v u (abstra ac M v) n; \<forall>c. v c > 0; v (constraint_clk ac) \<le> n\<rbrakk>
    \<Longrightarrow> u \<turnstile>\<^sub>a ac"
proof (cases ac, goal_cases)
  case prems: (1 c d)
  then have "v c \<le> n" by auto
  with prems(1,4) have "dbm_entry_val u (Some c) None ((abstra (LT c d) M v) (v c) 0)"
  by (auto simp: DBM_val_bounded_def)
  moreover from prems(2) have "v c > 0" by auto
  ultimately show ?case using prems(4) by (auto dest: dbm_entry_dbm_min3)
next
  case prems: (2 c d)
  from this have "v c \<le> n" by auto
  with prems(1,4) have "dbm_entry_val u (Some c) None ((abstra (LE c d) M v) (v c) 0)"
  by (auto simp: DBM_val_bounded_def)
  moreover from prems(2) have "v c > 0" by auto
  ultimately show ?case using prems(4) by (auto dest: dbm_entry_dbm_min3)
next
  case prems: (3 c d)
  from this have c: "v c > 0" "v c \<le> n" by auto
  with prems(1,4) have B:
    "dbm_entry_val u (Some c) None ((abstra (EQ c d) M v) (v c) 0)"
    "dbm_entry_val u None (Some c) ((abstra (EQ c d) M v) 0 (v c))"
  by (auto simp: DBM_val_bounded_def)
  from c B have "u c \<le> d" "- u c \<le> -d" by (auto dest: dbm_entry_dbm_min2 dbm_entry_dbm_min3)
  with prems(4) show ?case by auto
next
  case prems: (4 c d)
  from this have "v c \<le> n" by auto
  with prems(1,4) have "dbm_entry_val u None (Some c) ((abstra (GT c d) M v) 0 (v c))"
  by (auto simp: DBM_val_bounded_def)
  moreover from prems(2) have "v c > 0" by auto
  ultimately show ?case using prems(4) by (auto dest!: dbm_entry_dbm_min2)
next
  case prems: (5 c d)
  from this have "v c \<le> n" by auto
  with prems(1,4) have "dbm_entry_val u None (Some c) ((abstra (GE c d) M v) 0 (v c))"
  by (auto simp: DBM_val_bounded_def)
  moreover from prems(2) have "v c > 0" by auto
  ultimately show ?case using prems(4) by (auto dest!: dbm_entry_dbm_min2)
qed

lemma abstra_mono:
  "abstra ac M v i j \<le> M i j"
by (cases ac) auto

lemma abstra_subset:
  "[abstra ac M v]\<^bsub>v,n\<^esub> \<subseteq> [M]\<^bsub>v,n\<^esub>"
using abstra_mono
 apply (simp add: less_eq)
 apply safe
by (rule DBM_le_subset; force)

lemma abstr_subset:
  "[abstr cc M v]\<^bsub>v,n\<^esub> \<subseteq> [M]\<^bsub>v,n\<^esub>"
apply (induction cc arbitrary: M)
 apply (simp; fail)
using abstra_subset by fastforce

(* Move to DBM operations *)
lemma dbm_abstra_zone_eq:
  assumes "clock_numbering' v n" "v (constraint_clk ac) \<le> n"
  shows "[abstra ac M v]\<^bsub>v,n\<^esub> = {u. u \<turnstile>\<^sub>a ac} \<inter> [M]\<^bsub>v,n\<^esub>"
  apply safe
  subgoal
    unfolding DBM_zone_repr_def using assms by (auto intro: dbm_abstra_completeness)
  subgoal
    using abstra_subset by blast
  subgoal
    unfolding DBM_zone_repr_def using assms by (auto intro: dbm_abstra_soundness)
  done

(* XXX Move *)

lemma clock_val_Cons:
  assumes "u \<turnstile>\<^sub>a ac" "u \<turnstile> cc"
  shows "u \<turnstile> (ac # cc)"
  using assms by (induction cc) (auto simp: clock_val_def)

lemma abstra_commute:
  "abstra ac1 (abstra ac2 M v) v = abstra ac2 (abstra ac1 M v) v"
  by (cases ac1; cases ac2; fastforce simp: min.commute min.left_commute clock_val_def)

lemma dbm_abstr_completeness_aux:
  "\<lbrakk>DBM_val_bounded v u (abstr cc (abstra ac M v) v) n; \<forall>c. v c > 0; v (constraint_clk ac) \<le> n\<rbrakk>
    \<Longrightarrow> u \<turnstile>\<^sub>a ac"
apply (induction cc arbitrary: M)
 apply (auto intro: dbm_abstra_completeness; fail)
apply simp
apply (subst (asm) abstra_commute)
by auto

lemma dbm_abstr_completeness:
  "\<lbrakk>DBM_val_bounded v u (abstr cc M v) n; \<forall>c. v c > 0; \<forall> c \<in> collect_clks cc. v c \<le> n\<rbrakk>
    \<Longrightarrow> u \<turnstile> cc"
apply (induction cc arbitrary: M)
 apply (simp; fail)
apply (rule clock_val_Cons)
apply (rule dbm_abstr_completeness_aux)
by auto

lemma dbm_abstr_zone_eq:
  assumes "clock_numbering' v n" "\<forall>c\<in>collect_clks cc. v c \<le> n"
  shows "[abstr cc (\<lambda>i j. \<infinity>) v]\<^bsub>v,n\<^esub> = {u. u \<turnstile> cc}"
using dbm_abstr_soundness dbm_abstr_completeness assms unfolding DBM_zone_repr_def by metis

lemma dbm_abstr_zone_eq2:
  assumes "clock_numbering' v n" "\<forall>c\<in>collect_clks cc. v c \<le> n"
  shows "[abstr cc M v]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub> \<inter> {u. u \<turnstile> cc}"
apply standard
 apply (rule Int_greatest)
  apply (rule abstr_subset)
 unfolding DBM_zone_repr_def
 apply safe
 apply (rule dbm_abstr_completeness)
   using assms apply auto[3]
apply (rule dbm_abstr_soundness')
using assms by auto

abbreviation global_clock_numbering ::
  "('a, 'c, 't, 's) ta \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> bool"
where
  "global_clock_numbering A v n \<equiv>
    clock_numbering' v n \<and> (\<forall> c \<in> clk_set A. v c \<le> n) \<and> (\<forall>k\<le>n. k > 0 \<longrightarrow> (\<exists>c. v c = k))"

lemma dbm_int_all_abstra:
  assumes "dbm_int_all M" "snd (constraint_pair ac) \<in> \<int>"
  shows "dbm_int_all (abstra ac M v)"
using assms by (cases ac) (auto split: split_min)

lemma dbm_int_all_abstr:
  assumes "dbm_int_all M" "\<forall> (x, m) \<in> collect_clock_pairs g. m \<in> \<int>"
  shows "dbm_int_all (abstr g M v)"
using assms
proof (induction g arbitrary: M)
  case Nil
  then show ?case by auto
next
  case (Cons ac cc)
  from Cons.IH[OF dbm_int_all_abstra, OF Cons.prems(1)] Cons.prems(2-) have
    "dbm_int_all (abstr cc (abstra ac M v) v)"
  unfolding collect_clock_pairs_def by force
  then show ?case by auto
qed

lemma dbm_int_all_abstr':
  assumes "\<forall> (x, m) \<in> collect_clock_pairs g. m \<in> \<int>"
  shows "dbm_int_all (abstr g (\<lambda>i j. \<infinity>) v)"
 apply (rule dbm_int_all_abstr)
using assms by auto

lemma dbm_int_all_inv_abstr:
  assumes "\<forall>(x,m) \<in> clkp_set A. m \<in> \<nat>"
  shows "dbm_int_all (abstr (inv_of A l) (\<lambda>i j. \<infinity>) v)"
proof -
  from assms have "\<forall> (x, m) \<in> collect_clock_pairs (inv_of A l). m \<in> \<int>"
  unfolding clkp_set_def collect_clki_def inv_of_def using Nats_subset_Ints by auto
  from dbm_int_all_abstr'[OF this] show ?thesis .
qed

lemma dbm_int_all_guard_abstr:
  assumes "\<forall> (x, m) \<in> clkp_set A. m \<in> \<nat>" "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'"
  shows "dbm_int_all (abstr g (\<lambda>i j. \<infinity>) v)"
proof -
  from assms have "\<forall> (x, m) \<in> collect_clock_pairs g. m \<in> \<int>"
  unfolding clkp_set_def collect_clkt_def using assms(2) Nats_subset_Ints by fastforce
  from dbm_int_all_abstr'[OF this] show ?thesis .
qed

lemma dbm_int_abstra:
  assumes "dbm_int M n" "snd (constraint_pair ac) \<in> \<int>"
  shows "dbm_int (abstra ac M v) n"
using assms by (cases ac) (auto split: split_min)

lemma dbm_int_abstr:
  assumes "dbm_int M n" "\<forall> (x, m) \<in> collect_clock_pairs g. m \<in> \<int>"
  shows "dbm_int (abstr g M v) n"
using assms
proof (induction g arbitrary: M)
  case Nil
  then show ?case by auto
next
  case (Cons ac cc)
  from Cons.IH[OF dbm_int_abstra, OF Cons.prems(1)] Cons.prems(2-) have
    "dbm_int (abstr cc (abstra ac M v) v) n"
  unfolding collect_clock_pairs_def by force
  then show ?case by auto
qed

lemma dbm_int_abstr':
  assumes "\<forall> (x, m) \<in> collect_clock_pairs g. m \<in> \<int>"
  shows "dbm_int (abstr g (\<lambda>i j. \<infinity>) v) n"
 apply (rule dbm_int_abstr)
using assms by auto

lemma int_zone_dbm:
  assumes "clock_numbering' v n"
    "\<forall> (_,d) \<in> collect_clock_pairs cc. d \<in> \<int>" "\<forall> c \<in> collect_clks cc. v c \<le> n"
  obtains M where "{u. u \<turnstile> cc} = [M]\<^bsub>v,n\<^esub>"
            and   "\<forall> i \<le> n. \<forall> j \<le> n. M i j \<noteq> \<infinity> \<longrightarrow> get_const (M i j) \<in> \<int>"
proof -
  let ?M = "abstr cc (\<lambda>i j. \<infinity>) v"
  from assms(2) have "\<forall> i \<le> n. \<forall> j \<le> n. ?M i j \<noteq> \<infinity> \<longrightarrow> get_const (?M i j) \<in> \<int>"
  by (rule dbm_int_abstr')
  with dbm_abstr_zone_eq[OF assms(1) assms(3)] show ?thesis by (auto intro: that)
qed

lemma dbm_int_inv_abstr:
  assumes "\<forall>(x,m) \<in> clkp_set A. m \<in> \<nat>"
  shows "dbm_int (abstr (inv_of A l) (\<lambda>i j. \<infinity>) v) n"
proof -
  from assms have "\<forall> (x, m) \<in> collect_clock_pairs (inv_of A l). m \<in> \<int>"
  unfolding clkp_set_def collect_clki_def inv_of_def using Nats_subset_Ints by auto
  from dbm_int_abstr'[OF this] show ?thesis .
qed

lemma dbm_int_guard_abstr:
  assumes "\<forall> (x, m) \<in> clkp_set A. m \<in> \<nat>" "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'"
  shows "dbm_int (abstr g (\<lambda>i j. \<infinity>) v) n"
proof -
  from assms have "\<forall> (x, m) \<in> collect_clock_pairs g. m \<in> \<int>"
  unfolding clkp_set_def collect_clkt_def using assms(2) Nats_subset_Ints by fastforce
  from dbm_int_abstr'[OF this] show ?thesis .
qed

lemma collect_clks_id: "collect_clks cc = fst ` collect_clock_pairs cc"
proof -
  have "constraint_clk ac = fst (constraint_pair ac)" for ac by (cases ac) auto
  then show ?thesis unfolding collect_clks_def collect_clock_pairs_def by auto
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory DataStructures
imports Main
begin

(*
 * Proofs on abstract data structures that should be applicable
 * to concrete C proofs.
 *)

(*
 * Singly-linked list definitions and lemmas adapted from:
 *
 *   "Proving Pointer Programs in Higher-Order Logic"
 *   Farhad Mehta, Tobias Nipkow
 *)

locale linked_list =
  (* Fetch next pointer from object. *)
  fixes list_next :: "'a \<Rightarrow> 'p"
  (* Null pointer. *)
  and NULL :: "'p"

context linked_list begin

primrec
  list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "list s [] i = (i = NULL)"
| "list s (x#xs) i =
    (i = x \<and> x \<noteq> NULL \<and> (\<exists>a. s x = Some a \<and>  list s xs (list_next a)))"

definition
  is_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> bool"
where
  "is_list s p \<equiv> \<exists>xs. list s xs p"

definition
  the_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list"
where
  "the_list s p \<equiv> (THE xs. list s xs p)"

lemma list_empty [simp]: "list s xs NULL = (xs = [])"
  by (case_tac "xs", auto)

lemma is_list_empty [simp]: "is_list s NULL"
  by (clarsimp simp: is_list_def)

lemma the_list_empty [simp]: "the_list s NULL = []"
  by (clarsimp simp: the_list_def)

lemma list_unique: "\<lbrakk> list s xs p; list s ys p \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p)
   apply simp
  apply (case_tac ys, auto)
  done

lemma list_ptr_unique: "\<lbrakk> list s xs p; list s xs p' \<rbrakk> \<Longrightarrow> p = p'"
  by (metis linked_list.list.simps(1) linked_list.list.simps(2) neq_Nil_conv)

lemma list_non_NULL:
  "p \<noteq> NULL \<Longrightarrow>
    list s xs p = (\<exists>ys. xs= p#ys \<and> (\<exists>a. s p = Some a \<and> list s ys (list_next a)))"
  by (case_tac xs, auto)

lemma is_list_non_NULL:
  "p \<noteq> NULL \<Longrightarrow>
    is_list s p = (\<exists>a. s p = Some a \<and> is_list s (list_next a))"
  apply (clarsimp simp: is_list_def list_non_NULL)
  apply force
  done

lemma the_list_non_NULL:
  "\<lbrakk> p \<noteq> NULL; is_list s p \<rbrakk> \<Longrightarrow>
    the_list s p = (p # (the_list s (list_next (the (s p)))))"
  apply (clarsimp simp: the_list_def is_list_def list_non_NULL)
  apply (rule the_equality)
   apply (clarsimp simp: list_unique)
   apply (metis (lifting) list_unique the_equality)
  apply clarsimp
  apply (metis (lifting) list_unique the_equality)
  done

lemma list_is_list: "list s xs p \<Longrightarrow> is_list s p"
  apply (clarsimp simp: is_list_def)
  apply force
  done

lemma list_the_list: "list s xs p \<Longrightarrow> the_list s p = xs"
  apply (clarsimp simp: the_list_def)
  apply (metis (lifting) list_unique the_equality)
  done

lemma the_list_empty' [simp]:
    "is_list s p \<Longrightarrow> (the_list s p = []) = (p = NULL)"
  by (metis is_list_def list_empty list_ptr_unique list_the_list)

lemma list_last_is_NULL:
    "\<lbrakk> is_list s p; the_list s p = l; p \<noteq> NULL \<rbrakk> \<Longrightarrow> list_next (the (s (last l))) = NULL"
  apply (induct l arbitrary: p)
   apply clarsimp
  apply (metis is_list_non_NULL last_ConsL last_ConsR linked_list.the_list_non_NULL option.sel the_list_empty' list.sel(3))
  done

lemma list_in_Some:
  "\<lbrakk> list s xs p; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p, auto)
  done

lemma list_mem: "\<lbrakk> list s xs p; p \<noteq> NULL \<rbrakk> \<Longrightarrow> p \<in> set xs"
  by (case_tac xs, auto)

lemma list_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> list (s(x := v)) xs p = list s xs p"
  apply (induct xs arbitrary: p)
   apply clarsimp
  apply atomize
  apply clarsimp
  done

lemma list_ign_ext' [intro, iff]:
    "\<lbrakk> \<forall>x \<in> set xs. (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a) \<and> (list_next (the (s x)) = list_next (the (s' x)))  \<rbrakk> \<Longrightarrow> list s xs p = list s' xs p"
  apply (induct xs arbitrary: p, auto)
  done

lemma list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> list s xs p = list s' xs p"
  apply force
  done

lemma list_append_Ex:
  "list s (xs@ys) p \<Longrightarrow> (\<exists>q. list s ys q)"
  apply (induct xs arbitrary: ys p)
   apply force
  apply force
  done

lemma list_head_not_in_list: "\<lbrakk> list s xs (list_next a); s p = Some a \<rbrakk> \<Longrightarrow> p \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule list_append_Ex)
  apply clarsimp
  apply (drule (1) list_unique)
  apply clarsimp
  done

lemma list_distinct: "list s xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x)
   apply clarsimp
  apply clarsimp
  apply (drule (1) list_head_not_in_list)
  apply clarsimp
  done

lemma list_next: "\<lbrakk> list s xs x; s x = Some a; x \<noteq> NULL \<rbrakk> \<Longrightarrow> list s (tl xs) (list_next a)"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

primrec
  path :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "path s x [] y = (x = y)"
| "path s x (a#as) y = (x \<noteq> NULL \<and> x = a \<and> (\<exists>v. s x = Some v \<and> path s (list_next v) as y))"

lemma path_null [simp]: "path s NULL as x = (as = [] \<and> x = NULL)"
  by (case_tac as, auto)

lemma path_no_null [simp]: "\<lbrakk> path s a xs b \<rbrakk> \<Longrightarrow> NULL \<notin> set xs"
  apply (induct xs arbitrary: a)
   apply clarsimp
  apply clarsimp
  done

lemma path_next:
  "\<lbrakk> x \<noteq> NULL \<rbrakk> \<Longrightarrow> path s x as y = ((as = [] \<and> x = y)
    \<or> (\<exists>bs. as = x # bs \<and> (\<exists>a. s x = Some a \<and> path s (list_next a) bs y)))"
  apply (case_tac as, auto)
  done

lemma path_null_list: "path s a xs NULL = list s xs a"
  apply (induct xs arbitrary: a, auto)
  done

lemma path_ign [iff]: "u \<notin> set as \<Longrightarrow> path (s(u := v)) x as y = path s x as y"
  by (induct as arbitrary: x y, auto)

lemma path_split [simp]: "path s x (as @ bs) z = (\<exists>y. path s x as y \<and> path s y bs z)"
  apply (induct as arbitrary: x, auto)
  done

lemma list_split [simp]: "list s (as @ bs) x = (\<exists>y. path s x as y \<and> list s bs y)"
  by (induct as arbitrary: x, auto)

end

(*
 * Doubly-linked list, with NULL pointers.
 *)
locale dbl_linked_list =
  linked_list +
  constrains list_next :: "'a \<Rightarrow> 'p" and NULL :: "'p"
  (* Fetch prev pointer from object. *)
  fixes list_prev :: "'a \<Rightarrow> 'p"

context dbl_linked_list begin

primrec
  dbl_list_tail :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "dbl_list_tail s p [] h = (h = NULL)"
| "dbl_list_tail s p (x#xs) h =
    (h = x \<and> x \<noteq> NULL \<and> (\<exists>a. s x = Some a \<and> list_prev a = p \<and> dbl_list_tail s x xs (list_next a)))"

abbreviation
  dbl_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "dbl_list s l h \<equiv> dbl_list_tail s NULL l h"

lemma dbl_list_null_empty [simp]: "dbl_list_tail s p [] NULL"
  by simp

lemma dbl_list_empty [simp]: "dbl_list_tail s p xs NULL = (xs = [])"
  by (case_tac xs, auto)

lemma dbl_list_single: "\<lbrakk> s x = Some y; list_prev y = NULL; list_next y = NULL; x \<noteq> NULL \<rbrakk> \<Longrightarrow> dbl_list s [x] x"
  by simp

lemma dbl_list_tail_non_NULL:
  "h \<noteq> NULL \<Longrightarrow>
    dbl_list_tail s p xs h =
      (\<exists>ys. xs= h#ys \<and> (\<exists>a. s h = Some a \<and> list_prev a = p \<and> dbl_list_tail s h ys (list_next a)))"
  apply (case_tac xs, auto)
  done

lemma dbl_list_tail_in_Some:
  "\<lbrakk> dbl_list_tail s p xs h; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p h, auto)
  done

lemma dbl_list_tail_mem: "\<lbrakk> dbl_list_tail s p xs h; h \<noteq> NULL \<rbrakk> \<Longrightarrow> h \<in> set xs"
  by (case_tac xs, auto)

lemma dbl_list_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> dbl_list_tail (s(x := v)) p xs h = dbl_list_tail s p xs h"
  apply (induct xs arbitrary: p h)
   apply clarsimp
  apply atomize
  apply clarsimp
  done

lemma dbl_list_ign_ext' [intro, iff]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x))) \<rbrakk> \<Longrightarrow>
     dbl_list_tail s p xs h = dbl_list_tail s' p xs h"
  apply (induct xs arbitrary: p h, auto)
  done

lemma dbl_list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> dbl_list_tail s p xs h = dbl_list_tail s' p xs h"
  apply force
  done

lemma dbl_list_unique: "\<lbrakk> dbl_list_tail s p xs h; dbl_list_tail s p' ys h \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p p' h)
   apply simp
  apply (case_tac ys, auto)
  done

lemma dbl_list_append_Ex:
  "dbl_list_tail s p (xs@ys) h \<Longrightarrow> (\<exists>q. dbl_list_tail s (last (p#xs)) ys q)"
  apply (induct xs arbitrary: ys p h)
   apply force
  apply force
  done

lemma dbl_list_head_not_in_list: "\<lbrakk> dbl_list_tail s p xs (list_next a); s h = Some a \<rbrakk> \<Longrightarrow> h \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule dbl_list_append_Ex)
  apply clarsimp
  apply (drule (1) dbl_list_unique)
  apply clarsimp
  done

lemma dbl_list_distinct: "dbl_list_tail s p xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x p)
   apply clarsimp
  apply clarsimp
  apply (drule (1) dbl_list_head_not_in_list)
  apply clarsimp
  done

lemma dbl_list_next: "\<lbrakk> dbl_list_tail s p xs x; s x = Some a; x \<noteq> NULL \<rbrakk> \<Longrightarrow> dbl_list_tail s x (tl xs) (list_next a)"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

end

(*
 * Circular-linked list, with a head node.
 *)
locale circ_linked_list =
  (* Fetch next pointer from object. *)
  fixes list_next :: "'a \<Rightarrow> 'p"
  (* Fetch previous pointer from object. *)
  fixes list_prev :: "'a \<Rightarrow> 'p"

context circ_linked_list begin

fun
  circ_list_tail :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> 'p \<Rightarrow> bool"
where
  "circ_list_tail s head prev [] current = (current = head)"
| "circ_list_tail s head prev (x#xs) current =
        (current = x \<and> current \<noteq> head \<and>
          (\<exists>a. s x = Some a \<and> list_prev a = prev
            \<and> circ_list_tail s head x xs (list_next a)))"

lemma circ_list_defn_test: "
  \<lbrakk> s head = Some headNode;
    s n1 = Some node1;
    s n2 = Some node2;
    list_next headNode = n1; list_next node1 = n2; list_next node2 = head;
    list_prev headNode = n2; list_prev node1 = head; list_prev node2 = n1;
    n1 \<noteq> head; n2 \<noteq> head \<rbrakk> \<Longrightarrow>
   circ_list_tail s head head [n1, n2] n1"
  apply clarsimp
  done

definition
  circ_list :: "('p \<Rightarrow> 'a option) \<Rightarrow> 'p \<Rightarrow> 'p list \<Rightarrow> bool"
where
  "circ_list s head l \<equiv> (\<exists>a. s head = Some a \<and> (list_prev a = (last (head # l))) \<and> (circ_list_tail s head head l (list_next a)))"

lemma circ_list_tail_empty [simp]: "circ_list_tail s head p xs head = (xs = [])"
  apply (case_tac xs)
   apply clarsimp
  apply clarsimp
  done

lemma circ_list_empty: "\<lbrakk> s head = Some a; list_next a = head; list_prev a = head \<rbrakk> \<Longrightarrow> circ_list s head []"
  apply (clarsimp simp: circ_list_def)
  done

lemma circ_list_single: "\<lbrakk>
    x \<noteq> head;
    s x = Some a; list_next a = head; list_prev a = head;
    s head = Some b; list_next b = x; list_prev b = x
  \<rbrakk> \<Longrightarrow> circ_list s head [x]"
  apply (clarsimp simp: circ_list_def)
  done

lemma circ_list_tail_in_Some:
  "\<lbrakk> circ_list_tail s head p xs h; x \<in> set xs \<rbrakk> \<Longrightarrow> \<exists>a. s x = Some a"
  apply (induct xs arbitrary: p h, auto)
  done

lemma circ_list_tail_ign [iff]: "\<lbrakk> x \<notin> set xs \<rbrakk> \<Longrightarrow> circ_list_tail (s(x := v)) head p xs h = circ_list_tail s head p xs h"
  apply (induct xs arbitrary: p h)
   apply clarsimp
  apply clarsimp
  done

lemma circ_list_ign [iff]: "\<lbrakk> x \<notin> set xs; x \<noteq> head \<rbrakk> \<Longrightarrow> circ_list (s(x := v)) head xs = circ_list s head xs"
  apply (clarsimp simp: circ_list_def)
  done

lemmas circ_list_tail_ign' [iff] = circ_list_tail_ign [unfolded fun_upd_def]
lemmas circ_list_ign' [iff] = circ_list_ign [unfolded fun_upd_def]

lemma circ_list_tail_ign_ext' [intro?, iff?]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x))) \<rbrakk> \<Longrightarrow>
     circ_list_tail s head p xs h = circ_list_tail s' head p xs h"
  apply (induct xs arbitrary: p h, auto)
  done

lemma circ_list_ign_ext' [intro?, iff?]:
    "\<lbrakk> \<forall>x \<in> set xs.
        (\<exists>a. s x = Some a) = (\<exists>a. s' x = Some a)
        \<and> (list_next (the (s x)) = list_next (the (s' x)))
        \<and> (list_prev (the (s x)) = list_prev (the (s' x)));
       (\<exists>a. s head = Some a) = (\<exists>a. s' head = Some a);
       (list_next (the (s head)) = list_next (the (s' head)));
       (list_prev (the (s head)) = list_prev (the (s' head))) \<rbrakk> \<Longrightarrow>
     circ_list s head xs = circ_list s' head xs"
  apply (clarsimp simp: circ_list_def)
  apply (case_tac xs)
   apply force
  apply (clarsimp, safe, auto iff: circ_list_tail_ign_ext')
  done

lemma circ_list_tail_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x \<rbrakk> \<Longrightarrow> circ_list_tail s head p xs h = circ_list_tail s' head p xs h"
  apply (force iff: circ_list_tail_ign_ext')
  done

lemma circ_list_ign_ext [iff?]: "\<lbrakk> \<forall>x \<in> set xs. s x = s' x; s head = s' head \<rbrakk> \<Longrightarrow> circ_list s head xs = circ_list s' head xs"
  apply (force iff: circ_list_ign_ext')
  done

lemma circ_list_tail_unique: "\<lbrakk> circ_list_tail s head p xs h; circ_list_tail s head p' ys h \<rbrakk> \<Longrightarrow> xs = ys"
  apply (induct xs arbitrary: ys p p' h)
   apply clarsimp
  apply (case_tac ys, auto)
  done

lemma circ_list_unique: "\<lbrakk> circ_list s h xs; circ_list s h ys \<rbrakk> \<Longrightarrow> xs = ys"
  apply (clarsimp simp: circ_list_def)
  apply (erule (1) circ_list_tail_unique)
  done

lemma circ_list_tail_append_Ex:
  "circ_list_tail s head p (xs@ys) h \<Longrightarrow> (\<exists>q. circ_list_tail s head (last (p#xs)) ys q)"
  apply (induct xs arbitrary: ys p h)
   apply force
  apply force
  done

lemma circ_list_tail_head_not_in_list: "\<lbrakk> circ_list_tail s head p xs (list_next a); s h = Some a \<rbrakk> \<Longrightarrow> h \<notin> set xs"
  apply (rule ccontr)
  apply clarsimp
  apply (frule split_list)
  apply clarsimp
  apply (frule circ_list_tail_append_Ex)
  apply clarsimp
  apply (drule (1) circ_list_tail_unique)
  apply clarsimp
  done

lemma circ_list_head_not_in_list: "\<lbrakk> circ_list s head xs \<rbrakk> \<Longrightarrow> head \<notin> set xs"
  apply (clarsimp simp: circ_list_def)
  apply (drule (1) circ_list_tail_head_not_in_list)
  apply simp
  done

lemma circ_list_tail_distinct: "circ_list_tail s head p xs x \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: x p)
   apply clarsimp
  apply clarsimp
  apply (drule (1) circ_list_tail_head_not_in_list)
  apply clarsimp
  done

lemma circ_list_distinct: "circ_list s head xs \<Longrightarrow> distinct xs"
  by (metis circ_list_def circ_list_tail_distinct)

lemma circ_list_tail_prev':
  "\<lbrakk> circ_list_tail s h p a x; n \<in> set a; s n = Some m; list_prev m \<noteq> p \<rbrakk> \<Longrightarrow> list_prev m \<in> set a"
  apply (induct a arbitrary: p x)
   apply clarsimp
  apply force
  done

lemma circ_list_tail_prev:
  "\<lbrakk> circ_list_tail s h p a x; n \<in> set a; s n = Some m; list_prev m \<notin> set a \<rbrakk> \<Longrightarrow> list_prev m = p"
  apply (induct a arbitrary: p x)
   apply clarsimp
  apply force
  done

lemma circ_list_tail_h_not_in_list:
  "\<lbrakk> circ_list_tail s h p a x \<rbrakk> \<Longrightarrow> h \<notin> set a"
  by (induct a arbitrary: p x, auto)

lemma circ_list_tail_cong:
  "\<lbrakk> \<And>i. \<lbrakk> i \<in> set a; i \<noteq> h \<rbrakk> \<Longrightarrow> s i = s' i; h = h'; p = p'; a = a'; x = x' \<rbrakk>
     \<Longrightarrow> circ_list_tail s h p a x = circ_list_tail s' h' p' a' x'"
  apply clarsimp
  apply (case_tac "h' \<in> set a'")
   apply (metis circ_list_tail_h_not_in_list)
  apply (rule circ_list_tail_ign_ext')
  apply clarsimp
  apply metis
  done

end

end