theory Bisimilarity_Abstraction
  imports TA.Timed_Automata TA.Closure
begin

inductive ta_bisim where
  "ta_bisim A R" if
    "\<And> l u l' u'. R (l, u) (l', u') \<Longrightarrow> l = l'"
    "\<And> l1 u1 l2 u2 d l1' u1'. R (l1, u1) (l2, u2) \<Longrightarrow> A \<turnstile> \<langle>l1, u1\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l1', u1'\<rangle>
    \<Longrightarrow> \<exists> d' l2' u2'. A \<turnstile> \<langle>l2, u2\<rangle> \<rightarrow>\<^bsup>d'\<^esup> \<langle>l2', u2'\<rangle> \<and> R (l1', u1') (l2', u2')"
    "\<And> l1 u1 l2 u2 a l1' u1'. R (l1, u1) (l2, u2) \<Longrightarrow> A \<turnstile> \<langle>l1, u1\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l1', u1'\<rangle>
    \<Longrightarrow> \<exists> l2' u2'. A \<turnstile> \<langle>l2, u2\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l2', u2'\<rangle> \<and> R (l1', u1') (l2', u2')"
    "\<And> l u. R (l, u) (l, u)"
    "\<And> l1 u1 l2 u2. R (l1, u1) (l2, u2) \<Longrightarrow> R (l2, u2) (l1, u1)"
    "\<And> l1 u1 l2 u2 l3 u3. R (l1, u1) (l2, u2) \<Longrightarrow> R (l2, u2) (l3, u3) \<Longrightarrow> R (l1, u1) (l3, u3)"

context
  fixes A :: "('a, 'c, 't :: time, 's) ta"
  fixes R :: "('s * ('c, ('t::time)) cval) \<Rightarrow> ('s * ('c, 't) cval) \<Rightarrow> bool"
  assumes bisim: "ta_bisim A R"
begin

lemma
    locs:
    "R (l, u) (l', u') \<Longrightarrow> l = l'"
    and delay:
    "R (l1, u1) (l2, u2) \<Longrightarrow> A \<turnstile> \<langle>l1, u1\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>l1', u1'\<rangle>
    \<Longrightarrow> \<exists> d' l2' u2'. A \<turnstile> \<langle>l2, u2\<rangle> \<rightarrow>\<^bsup>d'\<^esup> \<langle>l2', u2'\<rangle> \<and> R (l1', u1') (l2', u2')"
    and action:
    "R (l1, u1) (l2, u2) \<Longrightarrow> A \<turnstile> \<langle>l1, u1\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l1', u1'\<rangle>
    \<Longrightarrow> \<exists> l2' u2'. A \<turnstile> \<langle>l2, u2\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l2', u2'\<rangle> \<and> R (l1', u1') (l2', u2')"
    and refl:
    "R (l, u) (l, u)"
    and sym:
    "R (l1, u1) (l2, u2) \<Longrightarrow> R (l2, u2) (l1, u1)"
    and trans:
    "R (l1, u1) (l2, u2) \<Longrightarrow> R (l2, u2) (l3, u3) \<Longrightarrow> R (l1, u1) (l3, u3)"
  using bisim by (cases; metis)+

definition "Cl l Z = {u. \<exists> u' \<in> Z. R (l, u) (l, u')}"

(*
inductive step_z_cl ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> 'a action \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow>\<^bsub>\<equiv>,_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  step_alpha: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^bsub>\<equiv>,a\<^esub> \<langle>l', Cl l' Z\<rangle>"
*)

inductive cl_steps ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>_, _\<rangle>" [61,61,61] 61)
where
  cl_refl: "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l, Z\<rangle>" (* if "Cl l Z = Z" *) |
  cl_step: "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l'', Z''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l'', Z''\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l''', Z'''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l''', Cl l''' Z'''\<rangle>"

lemmas [intro] = cl_steps.intros

  (*
inductive cl_steps ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> 's \<Rightarrow> ('c, 't) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>_, _\<rangle>" [61,61,61] 61)
where
  cl_refl: "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l, Z\<rangle>" if "Cl l Z = Z" |
  cl_step: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l', Z'\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l'', Z''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l'', Z''\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l''', Z'''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l''', Cl l''' Z'''\<rangle>" if "Cl l Z = Z"
*)

lemma Cl_idempotent:
  "Cl l (Cl l Z) = Cl l Z"
  unfolding Cl_def using sym trans refl by blast

(*
lemma cl_steps_cl:
  assumes "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Z'\<rangle>"
  obtains Z'' where "Z' = Cl l' Z''"
    apply atomize_elim
  using assms by (cases; blast)
*)

(* XXX Move *)
lemma step_z_sound':
  assumes "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l'', Z''\<rangle>" "A \<turnstile> \<langle>l'', Z''\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l''', Z'''\<rangle>" "u' \<in> Z'''"
  shows "\<exists> u. A \<turnstile>' \<langle>l', u\<rangle> \<rightarrow> \<langle>l''', u'\<rangle> \<and> u \<in> Z'"
  using assms by (auto 4 6 simp: zone_delay_def zone_set_def intro: step_a.intros)

lemma steps'_altI:
  "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u'\<rangle> \<Longrightarrow> A \<turnstile>' \<langle>l', u'\<rangle> \<rightarrow> \<langle>l'', u''\<rangle> \<Longrightarrow> A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l'', u''\<rangle>"
  by (induction rule: steps'.induct; blast)

    (*
lemma
  assumes "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Z'\<rangle>" "u' \<in> Z'"
    shows "\<exists> u. A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u'\<rangle> \<and> u \<in> Z"
  using assms
proof (induction arbitrary: u')
  case (cl_refl l Z)
  then show ?case by auto
next
  case (cl_step l Z l' Z' a l'' Z'' l''' Z''')
  from \<open>u' \<in> Cl l''' Z'''\<close> obtain u'' where "u'' \<in> Z'''" "R (l''', u') (l''', u'')"
    unfolding Cl_def by auto
  with cl_step[] thm steps_z_sound

      oops
  with cl_step obtain u''' where u''':
    "A \<turnstile>' \<langle>l', u'''\<rangle> \<rightarrow> \<langle>l''', u''\<rangle>" "u''' \<in> Z'"
    by atomize_elim (drule step_z_sound'; assumption)
  from cl_step(4)[OF this(2)] obtain u where
    "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u'''\<rangle>" "u \<in> Z"
    by blast
  with u'''(1) show ?case
    apply -
    apply (drule steps'_altI, assumption)

    using steps'_altI
  with step_z_sound cl_step obtain u''' where
    "u''' \<in> Z'" "A \<turnstile>' \<langle>l', u'\<rangle> \<rightarrow> \<langle>l''', u''\<rangle>"

  then show ?case sorry
qed
  *)

lemma step:
  "\<exists> l2' u2'. A \<turnstile>' \<langle>l2, u2\<rangle> \<rightarrow> \<langle>l2', u2'\<rangle> \<and> R (l1', u1') (l2', u2')"
  if "A \<turnstile>' \<langle>l1, u1\<rangle> \<rightarrow> \<langle>l1', u1'\<rangle>" "R (l1, u1) (l2, u2)"
  by (metis Bisimilarity_Abstraction.action bisim delay step'.cases step'.intros that)

lemma cl_steps_sound:
  assumes "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Z'\<rangle>" "u' \<in> Z'"
    shows "\<exists> u u''. A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u''\<rangle> \<and> u \<in> Z \<and> u'' \<in> Z' \<and> R (l', u') (l', u'')"
  using assms
proof (induction arbitrary: u')
  case prems: (cl_refl l Z)
  with refl show ?case by auto
next
  case (cl_step l Z l' Z' l'' Z'' a l''' Z''')
  from \<open>u' \<in> Cl l''' Z'''\<close> obtain u'' where u'': "u'' \<in> Z'''" "R (l''', u') (l''', u'')"
    unfolding Cl_def by auto
  with cl_step obtain u3 where u3:
    "A \<turnstile>' \<langle>l', u3\<rangle> \<rightarrow> \<langle>l''', u''\<rangle>" "u3 \<in> Z'"
    by atomize_elim (drule step_z_sound'; assumption)
  from cl_step(4)[OF this(2)] obtain u u4 where u4:
    "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u4\<rangle>" "u \<in> Z" "u4 \<in> Z'" "R (l', u3) (l', u4)"
    by blast
  from step[OF u3(1) u4(4)] obtain l2 u2 where l2:
    "A \<turnstile>' \<langle>l', u4\<rangle> \<rightarrow> \<langle>l2, u2\<rangle>" "R (l''', u'') (l2, u2)"
    by blast
  with locs[OF l2(2)] \<open>u'' \<in> Z'''\<close> have "u2 \<in> local.Cl l2 Z'''"
    unfolding Cl_def by (auto intro: sym)
  from l2(2) u''(2) locs[OF l2(2)] have "R (l2, u') (l2, u2)"
    by (auto intro: trans)
  with l2 u4(1) \<open>u \<in> Z\<close> locs[OF l2(2)] \<open>u'' \<in> Z'''\<close> \<open>u2 \<in> _\<close> show ?case
    by - (drule steps'_altI; auto)
qed

lemma step_z_complete':
  "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l'', u'\<rangle> \<Longrightarrow> u \<in> Z
  \<Longrightarrow> \<exists> l' Z' Z'' a. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l', Z'\<rangle> \<and> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l'', Z''\<rangle> \<and> u' \<in> Z''"
  by (meson step_z'_def step_z_complete')

lemma
  "A \<turnstile> \<langle>l, Cl l Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Cl l' Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z'\<rangle>"
  oops

lemma
  "\<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', W'\<rangle> \<and> Z' \<subseteq> W'" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l', Z'\<rangle>" "Z \<subseteq> W"
  using that
    oops

lemma
  "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Cl l' Z'\<rangle>" if "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l', Z'\<rangle>"
  using that
    oops

lemma Cl_subset:
  "Z \<subseteq> Cl l Z"
  unfolding Cl_def using refl by auto

lemma Cl_mono:
  "Cl l Z \<subseteq> Cl l W" if "Z \<subseteq> W"
  using that unfolding Cl_def by blast

lemma cl_steps_cl:
  "\<exists> W'. A \<turnstile> \<langle>l, Cl l Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', W'\<rangle> \<and> Z' \<subseteq> W'" if "A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Z'\<rangle>"
  using that
  proof (induction A \<equiv> A _ _ _ _)
    case (cl_refl l Z)
    with Cl_subset show ?case by blast
  next
    case (cl_step l Z l' Z' l'' Z'' a l''' Z''')
    then obtain W' where
      "A \<turnstile> \<langle>l, Cl l Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', W'\<rangle>" "Z' \<subseteq> W'"
      by auto
    moreover from step_z_mono[OF cl_step(3) this(2)] obtain W'' where
      "A \<turnstile> \<langle>l', W'\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l'', W''\<rangle>" "Z'' \<subseteq> W''"
      by auto
    moreover from step_z_mono[OF cl_step(4) this(2)] obtain W''' where
      "A \<turnstile> \<langle>l'', W''\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l''', W'''\<rangle>" "Z''' \<subseteq> W'''"
      by auto
    ultimately show ?case by (blast dest: Cl_mono)
  qed

lemma cl_step_altI:
  "A \<turnstile> \<langle>l'', Cl l'' Z''\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l''', Z'''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l', Z'\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l'', Z''\<rangle>
  \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l''', Z'''\<rangle>"
  by (induction "Cl l'' Z''" _ _ rule: cl_steps.induct; blast)

lemma cl_steps_complete:
  assumes "A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow>* \<langle>l', u'\<rangle>" "u \<in> Z"
  shows "\<exists> Z'. A \<turnstile> \<langle>l, Cl l Z\<rangle> \<rightarrow>\<^sub>\<equiv>\<^sup>* \<langle>l', Z'\<rangle> \<and> u' \<in> Z'"
  using assms
proof (induction A \<equiv> A _ _ _ _ arbitrary: Z)
  case (refl' l u)
  with Cl_subset show ?case by blast
next
  case prems: (step' l u l' u' l'' u'')
  from step_z_complete'[OF prems(1,4)] obtain l1 Z' Z'' a where
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>\<tau>\<^esub> \<langle>l1, Z'\<rangle>" "A \<turnstile> \<langle>l1, Z'\<rangle> \<leadsto>\<^bsub>\<upharpoonleft>a\<^esub> \<langle>l', Z''\<rangle>" "u' \<in> Z''"
    by blast
  with prems(3)[OF this(3)] show ?case by (blast dest: cl_steps_cl cl_step_altI)
qed

end

context
  fixes A :: "('a, 'c, 't :: time, 's) ta"
  fixes k :: "'s \<Rightarrow> 'c \<Rightarrow> 't"
  assumes inv_ceiling:
    "\<And> l c m. (c, m) \<in> collect_clock_pairs (inv_of A l) \<Longrightarrow> k l c \<ge> m"
  and guard_ceiling:
    "\<And> l c m g a r l'. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<Longrightarrow> (c, m) \<in> collect_clock_pairs g \<Longrightarrow> k l c \<ge> m"
  and active:
    "\<And> l c g a r l'. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<Longrightarrow> c \<notin> set r \<Longrightarrow> k l c \<ge> k l' c"
begin

definition
  "Cl_loc \<equiv> \<lambda> (l, u) (l', u'). l = l' \<and> (\<forall> c. u c = u' c \<or> (u c > k l c \<and> u' c > k l c))"

lemma Cl_loc_delay:
  "Cl_loc (l, u \<oplus> d) (l', u' \<oplus> d)" if "Cl_loc (l, u) (l', u')" "d \<ge> 0"
  using that unfolding Cl_loc_def
  by (auto simp: cval_add_def) (metis add.commute add_strict_increasing2)+

lemma ac_cong:
  "u' \<turnstile>\<^sub>a ac" if
  "u \<turnstile>\<^sub>a ac" "ac \<in> set g" "Cl_loc (l, u) (l', u')" "\<forall> (c, m) \<in> collect_clock_pairs g. k l c \<ge> m"
proof -
  let ?c = "fst (constraint_pair ac)"
  let ?d = "snd (constraint_pair ac)"
  from that(2,4) have "k l ?c \<ge> ?d" unfolding collect_clock_pairs_def by auto
  show ?thesis
  proof (cases "u ?c = u' ?c")
    case True
    with that(1) show ?thesis by cases auto
  next
    case False
    with that(1,3) \<open>k l ?c \<ge> ?d\<close> show ?thesis unfolding Cl_loc_def by cases (auto 4 3)
  qed
qed

lemma Cl_loc_reset:
  "Cl_loc (l1', [r\<rightarrow>0]u) (l1', [r\<rightarrow>0]u')" if
  "Cl_loc (l1, u) (l2, u')" "\<forall> c. c \<notin> set r \<longrightarrow> k l1 c \<ge> k l1' c"
  using that unfolding Cl_loc_def
  apply safe
  subgoal for c
    by (cases "c \<in> set r"; force)
  subgoal for c
    by (cases "c \<in> set r"; force)
  done

lemma cc_cong:
  "u' \<turnstile> g" if "u \<turnstile> g" "Cl_loc (l, u) (l', u')" "\<forall> (c, m) \<in> collect_clock_pairs g. k l c \<ge> m"
  using that by (auto simp: list_all_iff clock_val_def intro: ac_cong)

(* XXX How to make this simp rule work? *)
lemma Cl_loc_id[simp]:
  "l' = l" if "Cl_loc (l, u) (l', u')"
  using that unfolding Cl_loc_def by auto

lemma Cl_loc_ta_bisim:
  "ta_bisim A Cl_loc"
  apply rule
  subgoal
    unfolding Cl_loc_def by auto
  subgoal
    apply (erule step_t.cases)
    apply simp
    apply (drule Cl_loc_delay, assumption)
    apply (drule cc_cong, assumption)
    using inv_ceiling Cl_loc_id by blast+
  subgoal
    apply (erule step_a.cases)
    subgoal for A l g a' r l' u u'
      apply simp
      apply (drule cc_cong, assumption)
      using guard_ceiling apply force
      apply (subst Cl_loc_id, assumption)
      apply (drule Cl_loc_reset[where r = r and l1' = l'])
      using active apply force
      apply (drule cc_cong, assumption)
      using inv_ceiling apply force
      by (assumption | rule)+
    done
  subgoal
    unfolding Cl_loc_def by auto
  subgoal
    unfolding Cl_loc_def by force
  subgoal
    unfolding Cl_loc_def by (auto; metis)
  done

end

end


(*****************************************************************************
 * ESPL --- an embedded security protocol logic
 *          http://people.inf.ethz.ch/meiersi/espl/
 *
 *   Copyright (c) 2009-2011, Simon Meier, ETH Zurich, Switzerland
 *
 * Extension to compromising adversaries:
 *
 *   Copyright (c) 2010-2011, Martin Schaub, ETH Zurich, Switzerland
 *
 * All rights reserved. See file LICENCE for more information.
 ******************************************************************************)
theory Message
imports Main
begin

chapter{* Security Protocol Model *}

section{* Cryptographic Messages *}

types id = string

text{*
  A general message datatype which is polymorphic over
  the type of its literals.
*}

datatype 'lit msg = Lit  "'lit"
                  | Tup  "'lit msg" "'lit msg"
                  | Enc  "'lit msg" "'lit msg"
                  | Hash "'lit msg"
                  | K    "'lit msg" "'lit msg"
                  | PK   "'lit msg"
                  | SK   "'lit msg"

text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
  "@MTuple"      :: "['a, args] => 'a * 'b"       ("(2{|_,/ _|})")

syntax (xsymbols)
  "@MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")

translations
  "{|x, y, z|}"   == "{|x, {|y, z|}|}"
  "{|x, y|}"      == "Tup x y"

subsection{* Operations *}

fun inv :: "'lit msg \<Rightarrow> 'lit msg"
where
  "inv (PK m)  = SK m"
| "inv (SK m)  = PK m"
| "inv m       = m"

fun unpair :: "'lit msg \<Rightarrow> 'lit msg set"
where
  "unpair (Tup x y) = unpair x \<union> unpair y"
| "unpair m         = {m}"

text{*
  We do not use neither subterms nor parts in our reasoning
  infrastructure. However it used to formulate a few lemmas
  illustrating the relation between Paulsons' approach and ours.
*}

fun subterms :: "'lit msg \<Rightarrow> 'lit msg set"
where
  "subterms (Lit l)   = {Lit l}"
| "subterms (Tup x y) = insert (Tup x y) (subterms x \<union> subterms y)"
| "subterms (Enc m k) = insert (Enc m k) (subterms m \<union> subterms k)"
| "subterms (Hash m)  = insert (Hash m)  (subterms m)"
| "subterms (K a b)   = insert (K a b)   (subterms a \<union> subterms b)"
| "subterms (PK a)    = insert (PK a)    (subterms a)"
| "subterms (SK a)    = insert (SK a)    (subterms a)"

fun parts :: "'a msg \<Rightarrow> 'a msg set"
where
  "parts (Lit l)   = {Lit l}"
| "parts (Tup x y) = insert (Tup x y) (parts x \<union> parts y)"
| "parts (Enc m k) = insert (Enc m k) (parts m)"
| "parts (Hash m)  = {Hash m}"
| "parts (K a b)   = {K a b}"
| "parts (PK a)    = {PK a}"
| "parts (SK a)    = {SK a}"

fun pairParts :: "'a msg \<Rightarrow> 'a msg set"
where
  "pairParts (Tup x y) =
      insert (Tup x y) (pairParts x \<union> pairParts y)"
| "pairParts m = {m}"

inductive_set
  infer :: "'a msg set \<Rightarrow> 'a msg set"
  for M :: "'a msg set"
where
  Inj [simp,intro]: "m \<in> M                     \<Longrightarrow> m \<in> infer M"
| Tup:  "\<lbrakk> x \<in> infer M; y \<in> infer M \<rbrakk>           \<Longrightarrow> Tup x y \<in> infer M"
| Fst:  "Tup x y \<in> infer M                      \<Longrightarrow> x \<in> infer M"
| Snd:  "Tup x y \<in> infer M                      \<Longrightarrow> y \<in> infer M"
| Hash: "m \<in> infer M                            \<Longrightarrow> Hash m \<in> infer M"
| Enc:  "\<lbrakk> m \<in> infer M; k \<in> infer M \<rbrakk>           \<Longrightarrow> Enc m k \<in> infer M"
| Dec:  "\<lbrakk> Enc m k \<in> infer M; inv k \<in> infer M \<rbrakk> \<Longrightarrow> m \<in> infer M"

subsection{* Properties *}

subsubsection{* Unification modulo key-inversion *}

lemma size_inv [simp]: "size (inv x) = size x"
  by (cases x) auto

lemma inv_eqs [iff]:
  "(inv x = Lit m)     = (x = Lit m)"
  "(inv x = Tup m1 m2) = (x = Tup m1 m2)"
  "(inv x = Enc m1 m2) = (x = Enc m1 m2)"
  "(inv x = Hash m1)   = (x = Hash m1)"
  "(inv x = K m1 m2)   = (x = K m1 m2)"
  "(inv x = PK m1)     = (x = SK m1)"
  "(inv x = SK m1)     = (x = PK m1)"
  "(Lit m = inv x)     = (x = Lit m)"
  "(Tup m1 m2 = inv x) = (x = Tup m1 m2)"
  "(Enc m1 m2 = inv x) = (x = Enc m1 m2)"
  "(Hash m1 = inv x)   = (x = Hash m1)"
  "(K m1 m2 = inv x)   = (x = K m1 m2)"
  "(PK m1 = inv x)     = (x = SK m1)"
  "(SK m1 = inv x)     = (x = PK m1)"
 by (auto) (induct x, simp+)+

lemma inv_inj [iff]:
  "(inv x = inv y) = (x = y)"
  by (auto) (induct x, auto)

subsubsection{* @{term subterms}  *}

lemma subterms_trans:
  "\<lbrakk> x \<in> subterms y; y \<in> subterms z \<rbrakk> \<Longrightarrow> x \<in> subterms z"
  by(induct z, auto)

lemma unpair_subset_subterms:
  "unpair m \<subseteq> subterms m"
  by(induct m, auto)

lemmas unpair_subtermsD =
  subsetD[OF unpair_subset_subterms, rule_format]

subsubsection{* @{term infer} *}

text{* Monotonicity *}

lemma infer_mono [trans]: "M \<subseteq> N \<Longrightarrow> infer M \<subseteq> infer N"
  by(auto, erule infer.induct, auto intro: infer.intros)

lemma infer_increasing: "M \<subseteq> infer M"
  by(blast)

text{* Converse fails: A message composed from subterms of both
  sets is not in the union of the individual inferable sets. *}
lemma infer_Un: "infer M \<union> infer N \<subseteq> infer (M \<union> N)"
  by(intro Un_least infer_mono Un_upper1 Un_upper2)

lemmas infer_UnD = subsetD[OF infer_Un, rule_format]

lemma infer_insert: "insert x (infer M) \<subseteq> infer (insert x M)"
  by(blast intro: infer_mono[THEN [2] rev_subsetD])

text{* Idempotence and transitivity *}

lemma infer_inferD [dest!]: "x \<in> infer (infer M) \<Longrightarrow> x \<in> infer M"
  by (induct rule: infer.induct) (auto intro: infer.intros)

lemma infer_idem [iff]: "infer (infer M) = infer M"
  by blast

lemma infer_subset_iff [simp]:
  "(infer M \<subseteq> infer N) = (M \<subseteq> infer N)" (is "?lhs = ?rhs")
proof
  assume ?lhs
  have "M \<subseteq> infer M" by(rule infer_increasing)
  also note `?lhs`
  finally show ?rhs .
next
  assume ?rhs
  hence "infer M \<subseteq> infer (infer N)" by(rule infer_mono)
  thus ?lhs by simp
qed

lemma infer_trans: "\<lbrakk> x \<in> infer M;  M \<subseteq> infer N  \<rbrakk> \<Longrightarrow> x \<in> infer N"
by (drule infer_mono, blast)

text{*Cut; Lemma 2 of Lowe*}
lemma infer_cut:
  "\<lbrakk> y \<in> infer (insert x M);  x \<in> infer M \<rbrakk> \<Longrightarrow> y \<in> infer M"
  by (erule infer_trans, blast)

lemma Tup_in_infer [simp]:
  "Tup x y \<in> infer M = (x \<in> infer M \<and> y \<in> infer M)"
  by(blast intro: infer.intros)

lemma infer_insert_Tup [simp]:
  "infer (insert (Tup x y) M) = infer (insert x (insert y M))"
  by(safe, (erule infer.induct, auto intro: infer.intros)+)

lemma infer_insertI [intro]: "x \<in> infer M \<Longrightarrow> x \<in> infer (insert y M)"
  by(erule rev_subsetD[OF _ infer_mono], blast)

lemma infer_finite_support:
  assumes "m \<in> infer M"
  shows "\<exists> N. N \<subseteq> M \<and> finite N \<and> m \<in> infer N"  (is "\<exists> N. ?support m N")
using assms
proof(induct rule: infer.induct)
  case (Inj m)
    hence "?support m {m}" by fast
    thus ?case by blast
next
  case (Hash m)
    then obtain Nm where "?support m Nm" by blast
    hence "?support (Hash m) Nm" by (blast intro: infer.intros)
    thus ?case by blast
next
  case (Tup x y) note IH = this
             obtain Nx where "?support x Nx" using IH by blast
    moreover obtain Ny where "?support y Ny" using IH by blast
    ultimately have "?support (Tup x y) (Nx \<union> Ny)"
      by (blast intro: infer.intros infer_UnD)
    thus ?case by blast
next
  case (Fst x y)
    then obtain Nxy where "?support \<lbrace>x, y\<rbrace> Nxy" by blast
    hence "?support x Nxy" by (blast intro: infer.intros)
    thus ?case by blast
next
  case (Snd x y)
    then obtain Nxy where "?support \<lbrace>x, y\<rbrace> Nxy" by blast
    hence "?support y Nxy" by (blast intro: infer.intros)
    thus ?case by blast
next
  case (Enc m k) note IH = this
             obtain Nm where "?support m Nm" using IH by blast
    moreover obtain Nk where "?support k Nk" using IH by blast
    ultimately have "?support (Enc m k) (Nm \<union> Nk)"
      by (blast intro: infer.intros infer_UnD)
    thus ?case by blast
next
  case (Dec m k) note IH = this
             obtain Nmk where "?support (Enc m k) Nmk" using IH by blast
    moreover obtain Nk where "?support (inv k) Nk" using IH by blast
    ultimately have "?support m (Nmk \<union> Nk)"
      by (blast intro: infer.intros infer_UnD)
    thus ?case by blast
qed

subsubsection{* @{term pairParts} *}

lemma pairParts_mono [iff]: "m \<in> pairParts m"
  by(induct m rule: pairParts.induct, auto)

lemma pairParts_idem:
  "m' \<in> pairParts m \<Longrightarrow> pairParts m' \<subseteq> pairParts m"
  by(induct m, auto)

lemmas pairParts_idemD =
  subsetD[OF pairParts_idem, rule_format]

lemma pairParts_in_infer:
  "\<lbrakk> x \<in> pairParts m; m \<in> infer M \<rbrakk> \<Longrightarrow> x \<in> infer M"
  by(induct m arbitrary: x, auto)

lemma unpair_subset_pairParts: "unpair m \<subseteq> pairParts m"
  by(induct m, auto)

lemmas unpair_subset_pairPartsD =
  subsetD[OF unpair_subset_pairParts, rule_format]

end


(*  Title:      statecharts/SA/SA.thy

    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Sequential Automata\<close>
theory SA
imports Expr
begin

definition
  SeqAuto :: "['s set,
               's,
               (('s,'e,'d)label) set,
               (('s,'e,'d)trans) set]
              => bool" where
  "SeqAuto S I L D =  (I \<in> S \<and> S \<noteq> {} \<and>  finite S \<and> finite D \<and>
                       (\<forall> (s,l,t) \<in> D. s \<in> S \<and> t \<in> S \<and> l \<in> L))"

lemma SeqAuto_EmptySet:
 "({@x .True}, (@x .True), {}, {}) \<in> {(S,I,L,D) | S I L D. SeqAuto S I L D}"
by (unfold SeqAuto_def, auto)

definition
  "seqauto =
    { (S,I,L,D) |
              (S::'s set)
              (I::'s)
              (L::(('s,'e,'d)label) set)
              (D::(('s,'e,'d)trans) set).
             SeqAuto S I L D}"

typedef ('s,'e,'d) seqauto =
    "seqauto :: ('s set * 's * (('s,'e,'d)label) set * (('s,'e,'d)trans) set) set"
  unfolding seqauto_def
  apply (rule exI)
  apply (rule SeqAuto_EmptySet)
  done

definition
 States :: "(('s,'e,'d)seqauto) => 's set" where
 "States = fst o Rep_seqauto"

definition
 InitState :: "(('s,'e,'d)seqauto) => 's" where
 "InitState = fst o snd o Rep_seqauto"

definition
 Labels :: "(('s,'e,'d)seqauto) => (('s,'e,'d)label) set" where
 "Labels = fst o snd o snd o Rep_seqauto"

definition
 Delta :: "(('s,'e,'d)seqauto) => (('s,'e,'d)trans) set" where
 "Delta = snd o snd o snd o Rep_seqauto"

definition
 SAEvents :: "(('s,'e,'d)seqauto) => 'e set" where
 "SAEvents SA = (\<Union> l \<in> Label (Delta SA). (fst (action l)) \<union> (ExprEvents (expr l)))"

lemma Rep_seqauto_tuple:
  "Rep_seqauto SA = (States SA, InitState SA, Labels SA, Delta SA)"
by (unfold States_def InitState_def Labels_def Delta_def, auto)

lemma Rep_seqauto_select:
  "(States SA,InitState SA,Labels SA,Delta SA) \<in>  seqauto"
by (rule Rep_seqauto_tuple [THEN subst], rule Rep_seqauto)

lemma SeqAuto_select:
  "SeqAuto (States SA) (InitState SA) (Labels SA) (Delta SA)"
by (cut_tac SA=SA in Rep_seqauto_select, unfold seqauto_def, auto)

lemma neq_States [simp]:
  "States SA \<noteq> {}"
apply (cut_tac Rep_seqauto_select)
apply auto
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma SA_States_disjunct :
 "(States A) \<inter> (States A') = {} \<Longrightarrow> A' \<noteq> A"
by auto

lemma SA_States_disjunct2 :
 "\<lbrakk> (States A) \<inter> C = {}; States B \<subseteq> C \<rbrakk> \<Longrightarrow> B \<noteq> A"
apply (rule SA_States_disjunct)
apply auto
done

lemma SA_States_disjunct3 :
 "\<lbrakk> C \<inter> States A = {}; States B \<subseteq> C \<rbrakk> \<Longrightarrow>  States A \<inter> States B = {}"
apply (cut_tac SA=B in neq_States)
apply fast
done

lemma EX_State_SA [simp]:
  "\<exists> S. S \<in> States SA"
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma finite_States [simp]:
  "finite (States A)"
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma finite_Delta [simp]:
  "finite (Delta A)"
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma InitState_States [simp]:
  "InitState A \<in> States A"
apply (cut_tac Rep_seqauto_select)
apply (unfold seqauto_def SeqAuto_def)
apply auto
done

lemma SeqAuto_EmptySet_States [simp]:
 "(States (Abs_seqauto ({@x. True}, (@x. True), {}, {}))) = {(@x. True)}"
apply (unfold States_def)
apply (simp)
apply (subst Abs_seqauto_inverse)
apply (unfold seqauto_def)
apply (rule SeqAuto_EmptySet)
apply auto
done

lemma SeqAuto_EmptySet_SAEvents [simp]:
 "(SAEvents (Abs_seqauto ({@x. True}, (@x. True), {}, {}))) = {}"
apply (unfold SAEvents_def Delta_def)
apply simp
apply (subst Abs_seqauto_inverse)
apply (unfold seqauto_def)
apply (rule SeqAuto_EmptySet)
apply auto
done

lemma Label_Delta_subset [simp]:
  "(Label (Delta SA)) \<subseteq> Labels SA"
apply (unfold Label_def label_def)
apply auto
apply (cut_tac SA=SA in SeqAuto_select)
apply (unfold SeqAuto_def)
apply auto
done

lemma Target_SAs_Delta_States:
  "Target (\<Union>(Delta ` (SAs HA))) \<subseteq> \<Union>(States ` (SAs HA))"
apply (unfold image_def Target_def target_def)
apply auto
apply (rename_tac SA Source Trigger Guard Action Update Target)
apply (cut_tac SA=SA in SeqAuto_select)
apply (unfold SeqAuto_def)
apply auto
done

lemma States_Int_not_mem:
 "(\<Union>(States ` F) Int States SA) = {} \<Longrightarrow> SA \<notin> F"
apply (unfold Int_def)
apply auto
apply (subgoal_tac "\<exists> S. S \<in> States SA")
prefer 2
apply (rule EX_State_SA)
apply (erule exE)
apply (rename_tac T)
apply (erule_tac x=T in allE)
apply auto
done

lemma Delta_target_States [simp]:
  "\<lbrakk> T \<in> Delta A\<rbrakk> \<Longrightarrow> target T \<in> States A"
apply (cut_tac SA=A in SeqAuto_select)
apply (unfold SeqAuto_def source_def target_def)
apply auto
done

lemma Delta_source_States [simp]:
  "\<lbrakk> T \<in> Delta A \<rbrakk> \<Longrightarrow> source T \<in> States A"
apply (cut_tac SA=A in SeqAuto_select)
apply (unfold SeqAuto_def source_def target_def)
apply auto
done

end


theory SestoftConf
imports Launchbury.Terms Launchbury.Substitution
begin

datatype stack_elem = Alts exp exp | Arg var | Upd var | Dummy var

instantiation stack_elem :: pt
begin
definition  "\<pi> \<bullet> x = (case x of (Alts e1 e2) \<Rightarrow> Alts (\<pi> \<bullet> e1) (\<pi> \<bullet> e2) | (Arg v) \<Rightarrow> Arg (\<pi> \<bullet> v) | (Upd v) \<Rightarrow> Upd (\<pi> \<bullet> v) | (Dummy v) \<Rightarrow> Dummy (\<pi> \<bullet> v))"
instance
  by standard (auto simp add: permute_stack_elem_def split:stack_elem.split)
end

lemma Alts_eqvt[eqvt]: "\<pi> \<bullet> (Alts e1 e2) = Alts (\<pi> \<bullet> e1) (\<pi> \<bullet> e2)"
  and Arg_eqvt[eqvt]: "\<pi> \<bullet> (Arg v) = Arg (\<pi> \<bullet> v)"
  and Upd_eqvt[eqvt]: "\<pi> \<bullet> (Upd v) = Upd (\<pi> \<bullet> v)"
  and Dummy_eqvt[eqvt]: "\<pi> \<bullet> (Dummy v) = Dummy (\<pi> \<bullet> v)"
  by (auto simp add: permute_stack_elem_def split:stack_elem.split)

lemma supp_Alts[simp]: "supp (Alts e1 e2) = supp e1 \<union> supp e2" unfolding supp_def by (auto simp add: Collect_imp_eq Collect_neg_eq)
lemma supp_Arg[simp]: "supp (Arg v) = supp v"  unfolding supp_def by auto
lemma supp_Upd[simp]: "supp (Upd v) = supp v"  unfolding supp_def by auto
lemma supp_Dummy[simp]: "supp (Dummy v) = supp v"  unfolding supp_def by auto
lemma fresh_Alts[simp]: "a \<sharp> Alts e1 e2 = (a \<sharp> e1 \<and> a \<sharp> e2)" unfolding fresh_def by auto
lemma fresh_star_Alts[simp]: "a \<sharp>* Alts e1 e2 = (a \<sharp>* e1 \<and> a \<sharp>* e2)" unfolding fresh_star_def by auto
lemma fresh_Arg[simp]: "a \<sharp> Arg v = a \<sharp> v" unfolding fresh_def by auto
lemma fresh_Upd[simp]: "a \<sharp> Upd v = a \<sharp> v" unfolding fresh_def by auto
lemma fresh_Dummy[simp]: "a \<sharp> Dummy v = a \<sharp> v" unfolding fresh_def by auto
lemma fv_Alts[simp]: "fv (Alts e1 e2) = fv e1 \<union> fv e2"  unfolding fv_def by auto
lemma fv_Arg[simp]: "fv (Arg v) = fv v"  unfolding fv_def by auto
lemma fv_Upd[simp]: "fv (Upd v) = fv v"  unfolding fv_def by auto
lemma fv_Dummy[simp]: "fv (Dummy v) = fv v"  unfolding fv_def by auto

instance stack_elem :: fs
  by standard (case_tac x, auto simp add: finite_supp)

type_synonym stack = "stack_elem list"

fun ap :: "stack \<Rightarrow> var set" where
  "ap [] = {}"
| "ap (Alts e1 e2 # S) = ap S"
| "ap (Arg x # S) = insert x (ap S)"
| "ap (Upd x # S) = ap S"
| "ap (Dummy x # S) = ap S"
fun upds :: "stack \<Rightarrow> var set" where
  "upds [] = {}"
| "upds (Alts e1 e2 # S) = upds S"
| "upds (Upd x # S) = insert x (upds S)"
| "upds (Arg x # S) = upds S"
| "upds (Dummy x # S) = upds S"
fun dummies :: "stack \<Rightarrow> var set" where
  "dummies [] = {}"
| "dummies (Alts e1 e2 # S) = dummies S"
| "dummies (Upd x # S) = dummies S"
| "dummies (Arg x # S) = dummies S"
| "dummies (Dummy x # S) = insert x (dummies S)"
fun flattn :: "stack \<Rightarrow> var list" where
  "flattn [] = []"
| "flattn (Alts e1 e2 # S) = fv_list e1 @ fv_list e2 @ flattn S"
| "flattn (Upd x # S) = x # flattn S"
| "flattn (Arg x # S) = x # flattn S"
| "flattn (Dummy x # S) = x # flattn S"
fun upds_list :: "stack \<Rightarrow> var list" where
  "upds_list [] = []"
| "upds_list (Alts e1 e2 # S) = upds_list S"
| "upds_list (Upd x # S) = x # upds_list S"
| "upds_list (Arg x # S) = upds_list S"
| "upds_list (Dummy x # S) = upds_list S"

lemma set_upds_list[simp]:
  "set (upds_list S) = upds S"
  by (induction S rule: upds_list.induct) auto

lemma ups_fv_subset: "upds S \<subseteq> fv S"
  by (induction S rule: upds.induct) auto
lemma fresh_distinct_ups: "atom ` V \<sharp>* S \<Longrightarrow> V \<inter> upds S = {}"
   by (auto dest!: fresh_distinct_fv subsetD[OF ups_fv_subset])
lemma ap_fv_subset: "ap S \<subseteq> fv S"
  by (induction S rule: upds.induct) auto
lemma dummies_fv_subset: "dummies S \<subseteq> fv S"
  by (induction S rule: dummies.induct) auto

lemma fresh_flattn[simp]: "atom (a::var) \<sharp> flattn S \<longleftrightarrow> atom a \<sharp> S"
  by (induction S rule:flattn.induct) (auto simp add: fresh_Nil fresh_Cons fresh_append fresh_fv[OF finite_fv])
lemma fresh_star_flattn[simp]: "atom ` (as:: var set) \<sharp>* flattn S \<longleftrightarrow> atom ` as \<sharp>* S"
  by (auto simp add: fresh_star_def)
lemma fresh_upds_list[simp]: "atom a \<sharp> S \<Longrightarrow> atom (a::var) \<sharp> upds_list S"
  by (induction S rule:upds_list.induct) (auto simp add: fresh_Nil fresh_Cons fresh_append fresh_fv[OF finite_fv])
lemma fresh_star_upds_list[simp]: "atom ` (as:: var set) \<sharp>* S \<Longrightarrow> atom ` (as:: var set) \<sharp>* upds_list S"
  by (auto simp add: fresh_star_def)

lemma upds_append[simp]: "upds (S@S') = upds S \<union> upds S'"
  by (induction S rule: upds.induct) auto
lemma upds_map_Dummy[simp]: "upds (map Dummy l) = {}"
  by (induction l) auto

lemma upds_list_append[simp]: "upds_list (S@S') = upds_list S @ upds_list S'"
  by (induction S rule: upds.induct) auto
lemma upds_list_map_Dummy[simp]: "upds_list (map Dummy l) = []"
  by (induction l) auto

lemma dummies_append[simp]: "dummies (S@S') = dummies S \<union> dummies S'"
  by (induction S rule: dummies.induct) auto
lemma dummies_map_Dummy[simp]: "dummies (map Dummy l) = set l"
  by (induction l) auto

lemma map_Dummy_inj[simp]: "map Dummy l = map Dummy l' \<longleftrightarrow> l = l'"
  apply (induction l arbitrary: l')
  apply (case_tac [!] l')
  apply auto
  done

type_synonym conf = "(heap \<times> exp \<times> stack)"

inductive boring_step where
  "isVal e \<Longrightarrow> boring_step (\<Gamma>, e, Upd x # S)"

fun restr_stack :: "var set \<Rightarrow> stack \<Rightarrow> stack"
  where "restr_stack V [] = []"
      | "restr_stack V (Alts e1 e2 # S) = Alts e1 e2 # restr_stack V S"
      | "restr_stack V (Arg x # S) = Arg x # restr_stack V S"
      | "restr_stack V (Upd x # S) = (if x \<in> V then Upd x # restr_stack V S else restr_stack V S)"
      | "restr_stack V (Dummy x # S) = Dummy x # restr_stack V S"

lemma restr_stack_cong:
  "(\<And> x. x \<in> upds S \<Longrightarrow> x \<in> V \<longleftrightarrow> x \<in> V') \<Longrightarrow> restr_stack V S = restr_stack V' S"
  by (induction V S rule: restr_stack.induct) auto

lemma fresh_star_restict_stack[intro]:
  "a \<sharp>* S \<Longrightarrow> a \<sharp>* restr_stack V S"
  by (induction V S rule: restr_stack.induct) (auto simp add: fresh_star_Cons)

lemma restr_stack_restr_stack[simp]:
  "restr_stack V (restr_stack V' S) = restr_stack (V \<inter> V') S"
  by (induction V S rule: restr_stack.induct) auto

lemma Upd_eq_restr_stackD:
  assumes "Upd x # S = restr_stack V S'"
  shows "x \<in> V"
  using arg_cong[where f = upds, OF assms]
  by auto
lemma Upd_eq_restr_stackD2:
  assumes "restr_stack V S' = Upd x # S"
  shows "x \<in> V"
  using arg_cong[where f = upds, OF assms]
  by auto

lemma restr_stack_noop[simp]:
  "restr_stack V S = S \<longleftrightarrow> upds S \<subseteq> V"
  by (induction V S rule: restr_stack.induct)
     (auto dest: Upd_eq_restr_stackD2)

subsubsection \<open>Invariants of the semantics\<close>

inductive invariant :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "(\<And> x y. rel x y \<Longrightarrow> I x \<Longrightarrow> I y) \<Longrightarrow> invariant rel I"

lemmas invariant.intros[case_names step]

lemma invariantE:
  "invariant rel I \<Longrightarrow> rel x y \<Longrightarrow> I x \<Longrightarrow> I y" by (auto elim: invariant.cases)

lemma invariant_starE:
  "rtranclp rel x y \<Longrightarrow> invariant rel I \<Longrightarrow>  I x \<Longrightarrow> I y"
  by (induction rule: rtranclp.induct) (auto elim: invariantE)

lemma invariant_True:
  "invariant rel (\<lambda> _. True)"
by (auto intro: invariant.intros)

lemma invariant_conj:
  "invariant rel I1 \<Longrightarrow> invariant rel I2 \<Longrightarrow> invariant rel (\<lambda> x. I1 x \<and> I2 x)"
by (auto simp add: invariant.simps)

lemma rtranclp_invariant_induct[consumes 3, case_names base step]:
  assumes "r\<^sup>*\<^sup>* a b"
  assumes "invariant r I"
  assumes "I a"
  assumes "P a"
  assumes "(\<And>y z. r\<^sup>*\<^sup>* a y \<Longrightarrow> r y z \<Longrightarrow> I y \<Longrightarrow> I z \<Longrightarrow> P y \<Longrightarrow> P z)"
  shows "P b"
proof-
  from assms(1,3)
  have "P b" and "I b"
  proof(induction)
    case base
    from \<open>P a\<close> show "P a".
    from \<open>I a\<close> show "I a".
  next
    case (step y z)
    with \<open>I a\<close> have "P y" and "I y" by auto

    from assms(2) \<open>r y z\<close> \<open>I y\<close>
    show "I z" by (rule invariantE)

    from \<open>r\<^sup>*\<^sup>* a y\<close> \<open>r y z\<close> \<open>I y\<close> \<open>I z\<close> \<open>P y\<close>
    show "P z" by (rule assms(5))
  qed
  thus "P b" by-
qed

fun closed :: "conf \<Rightarrow> bool"
  where "closed (\<Gamma>, e, S) \<longleftrightarrow> fv (\<Gamma>, e, S) \<subseteq> domA \<Gamma> \<union> upds S"

fun heap_upds_ok where "heap_upds_ok (\<Gamma>,S) \<longleftrightarrow> domA \<Gamma> \<inter> upds S = {} \<and> distinct (upds_list S)"

abbreviation heap_upds_ok_conf :: "conf \<Rightarrow> bool"
  where "heap_upds_ok_conf c \<equiv> heap_upds_ok (fst c, snd (snd c))"

lemma heap_upds_okE: "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> x \<in> domA \<Gamma> \<Longrightarrow> x \<notin> upds S"
  by auto

lemma heap_upds_ok_Nil[simp]: "heap_upds_ok (\<Gamma>, [])" by auto
lemma heap_upds_ok_app1: "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (\<Gamma>,Arg x # S)" by auto
lemma heap_upds_ok_app2: "heap_upds_ok (\<Gamma>, Arg x # S) \<Longrightarrow> heap_upds_ok (\<Gamma>, S)" by auto
lemma heap_upds_ok_alts1: "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (\<Gamma>,Alts e1 e2 # S)" by auto
lemma heap_upds_ok_alts2: "heap_upds_ok (\<Gamma>, Alts e1 e2 # S) \<Longrightarrow> heap_upds_ok (\<Gamma>, S)" by auto

lemma heap_upds_ok_append:
  assumes "domA \<Delta> \<inter> upds S = {}"
  assumes "heap_upds_ok (\<Gamma>,S)"
  shows "heap_upds_ok (\<Delta>@\<Gamma>, S)"
  using assms
  unfolding heap_upds_ok.simps
  by auto

lemma heap_upds_ok_let:
  assumes "atom ` domA \<Delta> \<sharp>* S"
  assumes "heap_upds_ok (\<Gamma>, S)"
  shows "heap_upds_ok (\<Delta> @ \<Gamma>, S)"
using assms(2) fresh_distinct_fv[OF assms(1)]
by (auto intro: heap_upds_ok_append dest: subsetD[OF ups_fv_subset])

lemma heap_upds_ok_to_stack:
  "x \<in> domA \<Gamma> \<Longrightarrow> heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (delete x \<Gamma>, Upd x #S)"
  by (auto)

lemma heap_upds_ok_to_stack':
  "map_of \<Gamma> x = Some e \<Longrightarrow> heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (delete x \<Gamma>, Upd x #S)"
  by (metis Domain.DomainI domA_def fst_eq_Domain heap_upds_ok_to_stack map_of_SomeD)

lemma heap_upds_ok_delete:
  "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (delete x \<Gamma>, S)"
  by auto

lemma heap_upds_ok_restrictA:
  "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (restrictA V \<Gamma>, S)"
  by auto

lemma heap_upds_ok_restr_stack:
  "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (\<Gamma>, restr_stack V S)"
  apply auto
  by (induction V S rule: restr_stack.induct) auto

lemma heap_upds_ok_reorder:
  "x \<in> domA \<Gamma> \<Longrightarrow> heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok ((x,e) # delete x \<Gamma>, S)"
  by (intro heap_upds_ok_to_heap heap_upds_ok_to_stack)

lemma heap_upds_ok_upd:
"heap_upds_ok (\<Gamma>, Upd x # S) \<Longrightarrow> x \<notin> domA \<Gamma> \<and> x \<notin> upds S"
  by auto

lemmas heap_upds_ok_intros[intro] =
  heap_upds_ok_to_heap heap_upds_ok_to_stack heap_upds_ok_to_stack' heap_upds_ok_reorder
  heap_upds_ok_app1 heap_upds_ok_app2 heap_upds_ok_alts1 heap_upds_ok_alts2 heap_upds_ok_delete
  heap_upds_ok_restrictA heap_upds_ok_restr_stack
  heap_upds_ok_let
lemmas heap_upds_ok.simps[simp del]

end


theory TickTock_FL

imports
  TickTock_Max_FL
  TickTock_Max_TT1
  TickTock_FL_Pri
begin

text \<open> This theory defines the overall Galois connection between FL and Tick-Tock, using the
       two Galois connections, defined in TickTock_Max_FL and TickTock_Max_TT1. \<close>

section \<open> Adjoints \<close>

definition "fl2tt(P) = mkTT1(fl2ttm(P))"

definition "tt2fl(P) = ttm2fl(unTT1(P))"

section \<open> Properties \<close>

lemma fl2tt_mono:
  assumes "P \<subseteq> Q"
  shows "fl2tt(P) \<subseteq> fl2tt(Q)"
  using assms
  by (simp add: fl2tt_def fl2ttm_mono mkTT1_mono)

lemma tt2fl_mono:
  assumes "P \<subseteq> Q"
  shows "tt2fl(P) \<subseteq> tt2fl(Q)"
  using assms
  by (simp add: tt2fl_def ttm2fl_mono unTT1_mono)

lemma TT_fl2tt_closed:
  assumes "FL0 P" "FL1 P" "FL2 P" "FL3 P"
  shows "TTwf(fl2tt(P))"
        "TT0(fl2tt(P))"
        "TT1(fl2tt(P))"
        "TT2(fl2tt(P))"
        "ttWFx(fl2tt(P))"
        "TT3(fl2tt(P))"
  using assms unfolding fl2tt_def
  using TTwf_fl2ttm TTwf_mkTT1 apply blast
      apply (simp add: TT0_fl2ttm TT0_mkTT1 assms(1) assms(2) assms(3) assms(4))
     apply (simp add: TT1_mkTT1)
    apply (simp add: TT1w_fl2ttm TT2_fl2ttm TT2_mkTT1 TTM1_fl2ttm_for_FL2_FL1_FL0 TTM2_fl2ttm_for_FL2_FL1_FL0 assms(1) assms(2) assms(3) assms(4))
   apply (simp add: ttWFx_fl2ttm ttWFx_mkTT1)
  by (simp add: TT3_fl2ttm TT3_mkTT1 assms(4))

lemma FL_tt2fl_closed:
  assumes "TT(P)"
  shows "FL0(tt2fl(P))" "FL1(tt2fl(P))" "FL2(tt2fl(P))" "FL3(tt2fl(P))"
  using assms unfolding tt2fl_def
     apply (simp add: FL0_ttm2fl TT0_unTT1 TT1w_unTT1 TT_TT0 TT_TT1)
    apply (simp add: FL1_ttm2fl)
   apply (simp add: FL2_ttm2fl TT1w_unTT1 TTM1_unTT1 TTM2_unTT1)
  by (simp add: FL_ttm2fl_closed(4) TT0_unTT1 TT1w_unTT1 TTM1_unTT1 TTM2_unTT1 TTM3_unTT1 TT_TT0 TT_TT1 assms)

lemma
  shows "ttm2fl P = \<Union>{fl. FL3 fl \<and> FL0 fl \<and> FL1 fl \<and> (fl2ttm fl) \<subseteq> P}"
  unfolding ttm2fl_def apply auto
  using FL0_def by blast

lemma ttm2fl_alt:
  assumes "TTM1 P" "TTM2 P" "TT1w P"
  shows "ttm2fl P = \<Union>{fl. FL3 fl \<and> FL2 fl \<and> FL1 fl \<and> FL0 fl \<and> (fl2ttm fl) \<subseteq> P}"
  using assms unfolding ttm2fl_def fl2ttm_def apply auto
  (*The following seems to give me an easy way to generalise this kind of proof. *)
  apply (rule_tac x="\<Union>{fl. FL3 fl \<and> FL1 fl \<and> {fl2ttobs fla |fla. fla \<in> fl} \<subseteq> P}" in exI, auto)
    apply (smt FLTick0_def mem_Collect_eq mem_simps(9))
  using  FL2_ttm2fl
   apply (simp add: fl2ttm_def ttm2fl_def)
  using FL2_ttm2fl assms(1) assms(2) assms(3) apply blast
   apply (smt FL1_def Union_iff mem_Collect_eq)
  using FL0_def by blast

(* Move the following into FL theories. *)
definition mkFL2 :: "'a fltraces \<Rightarrow> 'a fltraces" where
"mkFL2 P \<equiv> P \<union> {s. \<exists>\<beta> A a. \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> a \<in>\<^sub>\<F>\<^sub>\<L> A \<and> s = \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>}"

lemma mkFL2_disj_univ: "mkFL2 (\<Union> P) = \<Union> ({mkFL2(x)|x. x \<in> P})"
  unfolding mkFL2_def by auto

lemma FL2_fixpoint: "FL2 P \<longleftrightarrow> mkFL2 P = P"
  unfolding FL2_def mkFL2_def by auto

lemma mkFL2_is_FL2: "FL2(mkFL2(P))"
  unfolding mkFL2_def FL2_def apply auto
  by (metis Finite_Linear_Model.last.simps(1) amember.simps(1) concat_FL_last_not_bullet_absorb last_bullet_then_last_cons last_cons_bullet_iff)

definition mkFL12 :: "'a fltraces \<Rightarrow> 'a fltraces" where
"mkFL12 P \<equiv> P \<union> {s. \<exists>\<beta> A a. \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> a \<in>\<^sub>\<F>\<^sub>\<L> A \<and> s \<le> \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>}"

lemma mkFL12_eq_mkFL1_mkFL2:
  assumes "FL1 P"
  shows "mkFL12(P) = mkFL1(mkFL2(P))"
  using assms unfolding mkFL1_def mkFL2_def mkFL12_def apply safe
  apply blast+
  using FL1_def by blast+

lemma mkFL12_disj_univ: "mkFL12 (\<Union> P) = \<Union> ({mkFL12(x)|x. x \<in> P})"
  unfolding mkFL12_def by auto

lemma mkFL12_is_FL2:
  assumes "FL1 P"
  shows "FL1(mkFL12(P))"
  using assms unfolding mkFL12_def FL1_def apply safe
  apply blast
  using order_trans by blast

lemma FL2_disj_imp:
  assumes "FL2 P" "FL2 Q"
  shows "FL2(P \<union> Q)"
  using assms unfolding FL2_def by auto

lemma
  "\<rho> \<in> x \<Longrightarrow> add_Tick_refusal_trace \<rho> \<in> mkTT3 x"
  unfolding mkTT3_def by auto

lemma unTT1_alt:
  assumes "TT P" "TT3 P"
  shows "unTT1 P = \<Union>{x. TT0 x \<and> TT2 x \<and> ttWFx x \<and> TT3 x \<and> TTM1 x \<and> TTM2 x \<and> TTM3 x \<and> TT1w x \<and> TTwf x \<and> (mkTT1 x) \<subseteq> P}"
  unfolding unTT1_def mkTT1_def apply auto
  using assms apply (rule_tac x="unTT1 P" in exI, auto)
  using TT0_unTT1 TT_TT0 TT_TT1 apply blast
  using TT3_TT1_imp_TT3w assms using TT2_unTT1 TT_TT1 apply blast
  using ttWFx_unTT1 TT_TT1 TT_ttWFx apply blast
  using TT3_unTT1 TT_TT1 apply blast
  using TTM1_unTT1 apply blast
  using TTM2_unTT1 apply blast
  using TTM3_unTT1 apply blast
  using TT1w_unTT1 apply blast
  unfolding unTT1_def apply auto
  apply (metis TT_TTwf TTwf_unTT1 unTT1_def)
  apply (metis (mono_tags, lifting) UnI1 contra_subsetD mkTT1_def)
   apply (metis (mono_tags, lifting) contra_subsetD mem_Collect_eq mkTT1_simp)
  apply (rule_tac x="X" in exI, auto)
  by (metis contra_subsetD mkTT1_simp)

(* TODO: Below move into other theories. *)

lemma
  assumes "last \<beta> \<noteq> \<bullet>"
  shows "\<not>(\<exists>z. z \<le> \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<and> \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> \<le> z \<and> z \<noteq> \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  using assms apply auto
  by (simp add: concat_FL_last_not_bullet_absorb)

lemma fltrace_less_imp_not_less:
  assumes "\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> < z"
  shows "\<not> z < \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms  apply (induct z \<beta> rule:less_eq_fltrace.induct, auto)
  apply (metis acceptance.distinct(1) acceptance_set dual_order.strict_iff_order fltrace_concat2.simps(3) less_eq_acceptance.elims(2) less_eq_fltrace.simps(1) less_eq_fltrace.simps(2) plus_acceptance.elims)
  using less_eq_fltrace.simps(4) less_fltrace_def apply blast
   apply (simp add: less_le_not_le)
  by (metis Finite_Linear_Model.last.simps(1) aevent_less_eq_iff_components bullet_left_zero2 concat_FL_last_not_bullet_absorb fltrace_concat2.simps(1) less_eq_acceptance.elims(2) less_eq_aevent_def less_eq_fltrace.simps(2) less_eq_fltrace.simps(3) less_fltrace_def x_le_x_concat2)

lemma fltrace_less_imp_not_less':
  assumes "\<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> < z"
  shows "\<not> z < \<beta> &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms  apply (induct z \<beta> rule:less_eq_fltrace.induct, auto)
apply (metis acceptance.distinct(1) acceptance_set dual_order.strict_iff_order fltrace_concat2.simps(3) less_eq_acceptance.elims(2) less_eq_fltrace.simps(1) less_eq_fltrace.simps(2) plus_acceptance.elims)
  using less_eq_fltrace.simps(4) less_fltrace_def apply blast
   apply (simp add: less_le_not_le)
  by (metis Finite_Linear_Model.last.simps(1) aevent_less_eq_iff_components bullet_left_zero2 concat_FL_last_not_bullet_absorb fltrace_concat2.simps(1) less_eq_acceptance.elims(2) less_eq_aevent_def less_eq_fltrace.simps(2) less_eq_fltrace.simps(3) less_fltrace_def x_le_x_concat2)

lemma order_no_intermediate_imp_eq:
  fixes x ::"'a::order"
  assumes "\<forall>y. y \<le> c \<longrightarrow> x \<noteq> y" "c \<le> x" "x \<le> b" "\<not>(\<exists>z. c < z \<and> z < b)"
  shows "b \<le> x"
  using assms apply auto
  using dual_order.order_iff_strict by blast

lemma fltrace_consFL_less_eq_case:
  assumes "a \<in>\<^sub>\<F>\<^sub>\<L> A \<or> A = \<bullet>"
  shows "x &\<^sub>\<F>\<^sub>\<L> \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> \<le> x &\<^sub>\<F>\<^sub>\<L> \<langle>(A,a)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms
  apply (induct x, auto)
   apply (case_tac x, auto)
   apply (cases A, auto)
  by (case_tac x, auto)

lemma FL3_union_imp_dist:
  assumes "FL3 (P \<union> Q)"
  shows "FL3 P"
  using assms unfolding FLTick0_def by auto

lemma FL3_mkFL2:
  assumes "FL3 X"
  shows "FL3 (mkFL2 X)"
  using assms unfolding mkFL2_def  apply auto
  by (smt FLTick0_def Un_iff mem_Collect_eq tickWF_acceptance_imp_tickWF_consFL)

lemma TTM3_TT3w:
  assumes "TTM3 P"
  shows "TT3w P"
  using assms unfolding TTM3_def TT3w_def apply auto
  using TTM3_TTick_part assms insert_absorb by force

lemma PriTT_eq_fl2tt_Pri_tt2fl:
  assumes "TT P" "TT2 P" "TT3 P"
  shows "PriTT p P = fl2tt(Pri p (tt2fl P))"
proof-
  have "PriTT p P = PriTT1 p P"
    by (simp add: PriTT_eq_priTT assms(1) assms(2) assms(3))
  also have "... = mkTT1(PriMax p (unTT1 P))"
    by (simp add: TT3_TT1_imp_TT3w TT_TT1 TT_ttWFx assms(1) assms(2) assms(3) mkTT1_PriMax_unTT1_priTT)
  also have "... = mkTT1(fl2ttm(Pri p (ttm2fl (unTT1 P))))"
  proof -
    have TTs:
         "TT0 (unTT1 P)"
         "TTwf (unTT1 P)"
         "TT1w (unTT1 P)"
         "ttWFx (unTT1 P)"
         "TT3 (unTT1 P)"
         "TTM3 (unTT1 P)"
      by (simp_all add: assms unTT1_TT_closure)
    then have TT3w:"TT3w (unTT1 P)"
      using TTM3_TT3w by auto

    have TTick:"TTick (unTT1 P)"
      using assms TTM3_TTick TTM3_unTT1 by blast

    have "PriMax p (unTT1 P) = fl2ttm(Pri p (ttm2fl (unTT1 P)))"
      using TTs TTick TT3w fl2ttm_pri_ttm2fl_PriMax by auto
    then show ?thesis by auto
  qed
  also have "... = fl2tt(Pri p (ttm2fl (unTT1 P)))"
    unfolding fl2tt_def by auto
  also have "... = fl2tt(Pri p (tt2fl P))"
    unfolding tt2fl_def by auto
  finally show ?thesis .
qed

end


theory Pattern1
  imports OperatorAmbiguity DerivationTrees_Ambiguity Containers.Containers

begin
type_synonym ('a, 'b) pattern = "(('a, 'b) symbol \<times> ('a, 'b) symbol list \<times> ('a, 'b) symbol list \<times> ('a, 'b) symbol list)"

(*need to specify transitive closure*)
locale Pattern  = OperatorAmbiguity +
  fixes \<P> :: "('a, 'b) pattern list"
  assumes Pattern_valid: "\<forall>(s, r1, r1' , r2) \<in> (set \<P>) . (s, r2) \<in> \<RR> \<and> (s, r1@r1') \<in> \<RR>"
  assumes Pattern_safety:"\<forall>(s, r1, r1', r2) \<in> (set \<P>) . ((s, r2), (s, r1@r1')) \<in> (Priority \<union> Left \<union> Right)" (*possibly stronger specification needed*)
  assumes Pattern_right_left:"\<forall>(s, r1, r1', r2) \<in> (set \<P>) . r1 = [] \<or> (r1' = [s] \<and> r1 \<noteq> [])"

  (*? filters on left nonterminal, so patterns are in priority or Left ?*)
assumes Pattern_safety_left:"\<forall>(s, r1, r1', r2) \<in> set \<P> . r1 = [] \<Longrightarrow>  ((s, r2), (s, r1@r1')) \<in>  (Priority \<union> Left)"
assumes Pattern_safety_right:"\<forall>(s, r1, r1', r2) \<in> set \<P> . (r1' = [s] \<and> r1 \<noteq> []) \<Longrightarrow>  ((s, r2), (s, r1@r1')) \<in>  (Priority \<union> Right)"

begin

section "Interpretation of patterns as one level filters

        then need to additionally prove that the rewriting algorithm rewrites a grammar in such a
        way that all pattern assumptions are fulfilled"

fun containsRule::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) rule \<Rightarrow> bool" where
"containsRule (DT r' b) r = (if r' = r then True else False)"|
"containsRule _ _= False"

(*termination of subtree measures?*)

(*function denoting conflict freedom in left direction*)
function containsRuleLeft::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) rule \<Rightarrow> bool" where
"containsRuleLeft (DT r' b) r = (if r' = r then True else containsRuleLeft (hd b) r )"|
"containsRuleLeft (Inner s) r = False" |
"containsRuleLeft (Leaf s) r = False"
        apply(auto)
by (metis derivtree.distinct(5) insert_left.simps(2) insert_left.simps(3))
termination
  by (metis derivtree.distinct(5) insert_left.simps(2) insert_left.simps(3))
function containsRuleRight::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) rule \<Rightarrow> bool" where
"containsRuleRight (DT r' b) r = (if r' = r then True else containsRuleRight (last b) r )"|
"containsRuleRight (Inner s) r = False"|
"containsRuleRight (Leaf s)  r = False"
  apply(auto)
  by (metis derivtree.distinct(5) insert_left.simps(2) insert_left.simps(3))
termination by (metis derivtree.distinct(5) insert_left.simps(2) insert_left.simps(3))

  thm "derivtree.distinct"
  thm "insert_left.simps"
fun filtered::"('a, 'b) derivtree \<Rightarrow> ('a, 'b)rule \<Rightarrow> bool" where
"filtered T r= (\<not>(containsRule T r))"

fun patterns::"('a, 'b) rule \<Rightarrow> ('a, 'b) pattern set" where
"patterns r = {(s, r1, r1', r2) \<in> set \<P> . (s, r1@r1') = r}"

(*definition via all patterns?*)
fun filter'::"('a, 'b) pattern \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> bool" where
"filter' (s, [], r1', r2) (DT r b) = (\<not> containsRuleRight (hd b) (s, r2))"|
"filter' (s, r1, [s'], r2) (DT r b) = (\<not> containsRuleLeft (last b) (s, r2))"|
"filter' _ _ = True"

fun valid_root_pattern::"('a, 'b) pattern \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> bool" where
"valid_root_pattern (s, r1, r1', r2)  (DT r b) = (if (s, r1@r1') = r then
  (filter' (s, r1, r1', r2) (DT r b)) else True)" |
"valid_root_pattern _ _ = True"

lemma pattern_inapp_implies_true:"(s, r1@r1') \<noteq> r \<Longrightarrow> valid_root_pattern (s, r1, r1', r2)  (DT r b)"
  by simp

fun valid_tree_pattern::"('a, 'b) pattern \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> bool" where
"valid_tree_pattern p (DT r b) = (valid_root_pattern p (DT r b) \<and> list_all (valid_tree_pattern p) b) "|
"valid_tree_pattern p _ = True"

fun valid_tree1::"('a, 'b) derivtree \<Rightarrow> bool" where
"valid_tree1 T = (\<forall> p \<in> set \<P> . valid_tree_pattern p T)"

fun valid_tree::"('a, 'b) derivtree \<Rightarrow> bool" where
"valid_tree (DT r b)  = (\<forall> p \<in> set \<P> . valid_root_pattern p (DT r b) \<and> (\<forall> t \<in> set b . valid_tree t))"|
"valid_tree _ = True"

(*have to add tree wellformed to ensure that there actually exist the needed values*)
lemma  exclusion_implies_patterns:"Tree_wf x \<Longrightarrow> \<not> valid_tree x \<Longrightarrow> \<exists>a aa ab b. (a, aa, ab, b) \<in> set \<P>"
proof(induction x)
  case (Leaf x)
  then show ?case by auto
next
  case (Inner x)
  then show ?case by auto
next
  case (DT r b)
  from DT.prems have "\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b) \<or> (\<exists> t \<in> set b . \<not> valid_tree t)" by auto
  {
    assume "\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b)"
    then obtain p where "\<not> valid_root_pattern p (DT r  b)" by blast
    then have " \<exists>a aa ab b. (a, aa, ab, b) \<in> set \<P>" sorry (*probably has to be based on wellformedness*)
  }
   show ?case sorry
qed
section "leftrecursive Ea \<Longrightarrow> rightrecursive bE \<Longrightarrow> valid_pattern Ea bE \<Longrightarrow> if a d
erivation is banned by this pattern, it is also banned by the operator ambiguity scheme"

lemma caseDT:"\<not> (leftconflictfree r s) \<Longrightarrow> s = (DT r' b')"
  sorry

lemma soundness_root:"\<forall> p \<in> set \<P>. valid_root_pattern p T \<Longrightarrow> conflictfree_root T"
proof (induction T)
  case (Leaf x)
  then show ?case by auto
next
  case (Inner x)
  then show ?case by auto
next
  case (DT r b)
  {assume L1:"\<not> conflictfree_root (DT r b)"
  then have "(\<exists> s \<in> set (leftspine1 (DT r b)) .  \<not> (leftconflictfree r s)) \<or>
             (\<exists> s \<in> set (rightspine1 (DT r b)) .  \<not> (rightconflictfree r s))" by auto
  (*assume "(\<exists> s \<in> set (leftspine1 (DT r b)) .  \<not> (leftconflictfree r s))"
  then obtain s where child:"s \<in> set (leftspine1 (DT r b))" and conflict:"(\<not> (leftconflictfree r s))" by blast
  from conflict obtain r' where "s = (DT r' b')" using caseDT by blast
  with conflict have "(r, r') \<in> (Priority \<union> Left)" by simp
  *) (*need additional case distinction on rightspine/leftspine*)
  have "(\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b))" sorry
}
  from this have "\<forall> p \<in> set \<P>. valid_root_pattern p (DT r b) \<Longrightarrow> conflictfree_root (DT r b)" by fast
  (*need to construct that r' is contained in subtree under pattern and therefore a violation*)
  with DT.prems show ?case by blast
qed

subsection "Equivalence proof with regards to rotation system"
lemma pattern_soundness:"valid_tree T \<Longrightarrow> conflict_free T"
proof (induction T)
  case (Leaf x)
  then show ?case by auto
next
  case (Inner x)
  then show ?case by auto
next
  case (DT r b)
  {assume L1:"\<not> conflict_free (DT r b)"
  then have assms:"\<not> (conflictfree_root (DT r b) \<or> (\<exists> subtree \<in> set b . \<not> conflict_free subtree))" sorry
  {assume "\<not> (conflictfree_root (DT r b))"
    with soundness_root have "(\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b))" by blast
      then have "\<not> (valid_tree (DT r b))" by auto
  }
  from this have 1:"\<not> (conflictfree_root (DT r b)) \<Longrightarrow>  \<not>(valid_tree (DT r b))" by blast
  {
    assume "(\<exists> subtree \<in> set b . \<not> conflict_free subtree)"
    then obtain s where s:"s \<in> set b \<and> \<not> conflict_free s" by blast
    with DT.IH have "\<not> valid_tree s" by blast
    with s have " (\<exists> s \<in> set b . \<not> valid_tree s)" by blast
    from this have "\<not> (\<forall> s \<in> set b. valid_tree s)" by blast
    from this have "\<not> (valid_tree (DT r b))"  apply(auto) using exclusion_implies_patterns sorry (*wf based needed*)
  }
  with assms 1 have "\<not> (valid_tree (DT r b))" by blast
  }
  with DT.prems show ?case by blast
qed

(*proof by contradiction, assume a tree is not conflict free, then the conflict will also hurt the filtering assumption*)
(*hat this is equivalent to either the disambiguation system in either Derivation Trees or LeftDerivations*)

  (*by (metis butlast.simps(2) drop_last list.simps(3)) (*invalid possible*)
*)
lemma "\<exists> s \<in> set (rightspine1 (DT r b)). \<not> rightconflictfree r s \<Longrightarrow> \<not> conflictfree_root (DT r b)"
proof -
  assume assms:"\<exists> s \<in> set (rightspine1 (DT r b)). \<not> rightconflictfree r s"
  {assume "conflictfree_root (DT r b)"
    then have "\<forall> s \<in> set (rightspine1 (DT r b)) . rightconflictfree r s" using conflictfree_root.simps(1) by blast
  }
  then show ?thesis using assms by blast
qed

subsection "Relation of valid pattern semantics as used in rewriting vs disambiguation"
(*relation of semantics of patterns*)
lemma right_contains_implies_conflict:"(r, r') \<in> (Priority \<union> Left)
   \<Longrightarrow> containsRuleRight (hd b) r'  \<Longrightarrow> \<exists>s \<in> set (leftspine1 (DT r b)) .  \<not>(leftconflictfree r s)"
  sorry

(*relation of semantics of patterns*)
lemma left_contains_implies_conflict:"(r, r') \<in> (Priority \<union> Right)
   \<Longrightarrow> containsRuleLeft (last b) r'  \<Longrightarrow> \<exists>s \<in> set (rightspine1 (DT r b)) . \<not> (rightconflictfree r s)"
  sorry

lemma pattern_completeness_root:"conflictfree_root T \<Longrightarrow> \<forall> p \<in> set \<P> . valid_root_pattern p T"
proof (induction T)
  case (Leaf x)
  then show ?case by auto
next
  case (Inner x)
  then show ?case by auto
next
  case (DT r b)
  {
    assume assms0: "\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b)"
    then obtain p  where  valid:"\<not> valid_root_pattern p (DT r b)" "p \<in> set \<P>"by blast
    (*the transitivity of patterns (itself only level 1 filtering) then implies an violation along left or right spine*)
    then obtain s r1 r1' r2 where p:"p = (s, r1, r1', r2)"   apply (cases p) by simp
    with valid have r1_r:"(s, r1@r1') = r" using pattern_inapp_implies_true by blast
    (*still have to prove why valid_root_pattern wrong implies r = s1@s1'*)
    with valid p have filter:"\<not> (filter' (s, r1, r1', r2) (DT r b))"  by auto
    from valid p have assms:"r1 = [] \<or> (r1' = [s] \<and> r1 \<noteq> [])" using Pattern_right_left by fast (*pattern right left correct assumption?*)
    {
      assume left:"r1 = []"
      with filter have rightcontain:"containsRuleRight (hd b) (s, r2)" using filter'.simps(1) by blast
      (*containsright then applies that there exists a DT in hd b such that (s, r2) is its rule*)
      (*(\<forall> s \<in> set (leftspine1 (DT r b)) .  (leftconflictfree r s)*)
      from left valid p have " (r, (s, r2)) \<in> (Priority \<union> Left)" using Pattern_safety_left sorry
      with r1_r rightcontain right_contains_implies_conflict have
          "\<exists>s\<in>set (leftspine1 (DT r b)). \<not> leftconflictfree r s" by blast
      then have "\<not> conflictfree_root (DT r b)" by fastforce
    }
    then have  leftcase:"r1 = [] \<Longrightarrow> \<not> conflictfree_root (DT r b)" by blast
    {
      assume right:"r1' = [s]" "r1 \<noteq> []"
      with filter have leftcontain:"containsRuleLeft (last b) (s, r2)" using filter.simps(2) sorry
      from right valid p have "(r, (s, r2)) \<in> (Priority \<union> Right)" using Pattern_safety_right sorry
      with r1_r leftcontain have "\<exists> s \<in> set (rightspine1 (DT r b)). \<not> rightconflictfree r s"
          using left_contains_implies_conflict by blast
      then have "\<not> conflictfree_root (DT r b)" by auto
    }
    (*case distinction on filtering*)
    with leftcase assms have "\<not> conflictfree_root (DT r b)" by blast
  }
  with DT.prems show ?case by blast
qed

lemma conflictfree_sub:"\<exists> t \<in> set b.\<not> conflict_free t \<Longrightarrow>\<not> conflict_free (DT r b)"
proof -
  assume assms:"\<exists> t \<in> set b.\<not> conflict_free t"
  {assume "conflict_free (DT r b)"
    then have "list_all conflict_free b" by simp
    then have "\<forall> t \<in> set b. conflict_free t" using list_all_def by metis
  }
  then have "\<exists> t \<in> set b.\<not> conflict_free t \<Longrightarrow>\<not> conflict_free (DT r b)" by blast
  with assms  show ?thesis by blast
qed

(*? are the pattern definitions even correct*)
lemma pattern_completeness:"conflict_free T \<Longrightarrow> valid_tree T"
proof (induction T)
  case (Leaf x)
  then show ?case by auto
next
  case (Inner x)
  then show ?case by auto
next
  case (DT r b)
  {
    assume "\<not> valid_tree (DT r b)"
    from this have assms:"(\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b) \<or> (\<exists> t \<in> set b . \<not> valid_tree t))" by simp
    {
      assume "\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b)"
      (*then obtain p where " \<not> valid_root_pattern p (DT r b)" by auto*)
      then have "\<not> conflictfree_root (DT r b)" using pattern_completeness_root by blast
      then have "\<not> conflict_free (DT r b)" by auto
    }
    then have 1:"(\<exists> p \<in> set \<P> . \<not> valid_root_pattern p (DT r b)) \<Longrightarrow> \<not> conflict_free (DT r b)" by blast
    {
      assume  "\<exists> t \<in> set b . \<not> valid_tree t"
      then have "\<exists> t \<in> set b.\<not> conflict_free t" using DT.IH by blast
      then have "\<not> conflict_free (DT r b)" using conflictfree_sub by blast
    }
    with 1 assms have "\<not> conflict_free (DT r b)" by blast
  }
  with DT.prems show ?case by blast
qed
(*assume something is not filtered according to the patterns and their axioms,
prove that this would also constitute a violation under disambiguition rules*)

definition new_nonterm1::"('a \<times> nat, 'b) symbol set" where
"new_nonterm1 = undefined"

term case_sum
definition new_term1::"('a \<times> nat, 'b) symbol set" where
"new_term1 = (case_sum (\<lambda> t. Inl (t, 0)) Inr) ` \<TT>"

definition rules1::"('a \<times> nat,  'b) rule set" where
"rules1 = undefined"

definition start1::"('a \<times> nat, 'b) symbol" where
"start1 = case_sum (\<lambda> t. Inl (t, 0)) Inr \<SS>  "

end

end