section {* Timed Relations *}

theory utp_time_rel
  imports
  "UTP1-Reactive.utp_rea_hoare"
begin

type_synonym '\<alpha> trel = "('\<alpha>, real pos) rdes"

translations
  (type) "'\<alpha> trel" <= (type) "('\<alpha>, real pos) rdes"

abbreviation time :: "real pos \<Longrightarrow> (real pos, 'a) rp" where
"time \<equiv> tr"

definition wait_trel :: "(real pos, '\<alpha>) uexpr \<Rightarrow> '\<alpha> trel" ("wait\<^sub>r") where
[upred_defs]: "wait\<^sub>r(n) = ($st\<acute> =\<^sub>u $st \<and> $time\<acute> =\<^sub>u $time + \<lceil>n\<rceil>\<^sub>S\<^sub><)"

lemma wait_RR_closed [closure]: "wait\<^sub>r n is RR"
  using diff_add_cancel_left' by (rel_auto, fastforce)

lemma st_subst_rea_wait [usubst]:
  "\<sigma> \<dagger>\<^sub>S wait\<^sub>r n = wait\<^sub>r (\<sigma> \<dagger> n) ;; \<langle>\<sigma>\<rangle>\<^sub>r"
  by (rel_auto)

lemma wait_zero: "wait\<^sub>r(0) = II\<^sub>r"
  by (rel_auto)

lemma wait_plus: "wait\<^sub>r(m) ;; wait\<^sub>r(n) = wait\<^sub>r(m + n)"
  by (rel_auto, simp_all add: add.commute add.left_commute)

lemma wait_cond: "wait\<^sub>r(m) ;; (P \<triangleleft> b \<triangleright>\<^sub>R Q) = (wait\<^sub>r(m) ;; P \<triangleleft> b \<triangleright>\<^sub>R wait\<^sub>r(m) ;; Q)"
  by (rel_auto)

lemma wait_assign: "x \<sharp> m \<Longrightarrow> wait\<^sub>r(m) ;; x :=\<^sub>r v = x :=\<^sub>r v ;; wait\<^sub>r(m)"
  by (rel_auto)

lemma wait_hoare_rp [hoare_safe]:
  "\<lbrace>p\<rbrace>wait\<^sub>r n\<lbrace>p\<rbrace>\<^sub>r"
  by (rel_auto)

lemma hoare_rp_wait_comp [hoare_safe]:
  "\<lbrace>p\<rbrace> Q \<lbrace>r\<rbrace>\<^sub>r \<Longrightarrow> \<lbrace>p\<rbrace> wait\<^sub>r n ;; Q \<lbrace>r\<rbrace>\<^sub>r"
  by (rel_auto)

lemma rea_frame_wait [frame]:
  "vwb_lens x \<Longrightarrow> x:[wait\<^sub>r(n)]\<^sub>r = wait\<^sub>r(n)"
  by (rel_auto)

end


header "Small-Step Semantics of Commands"

theory Small_Step_7_9 imports Star Big_Step_7_9 begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Repeat:  "(REPEAT c UNTIL b,s) \<rightarrow>
            (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b,s)" |
Or1:     "(c\<^sub>1 OR c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
Or2:     "(c\<^sub>1 OR c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection{* Executability *}

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'' OR ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection{* Proof infrastructure *}

subsubsection{* Induction rules *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection{* Proof automation *}

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"
inductive_cases RepeatE[elim]: "(REPEAT c UNTIL b, s) \<rightarrow> ct"
inductive_cases OrE[elim!]: "(c1 OR c2, s) \<rightarrow> ct"
thm OrE

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text{* The following proof corresponds to one on the board where one would
show chains of @{text "\<rightarrow>"} and @{text "\<rightarrow>*"} steps. *}

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b t c s
  let ?ru = "IF b THEN SKIP ELSE REPEAT c UNTIL b"
  assume "bval b t"
  hence "(?ru, t) \<rightarrow>* (SKIP, t)" by auto
  moreover assume  "(c, s) \<rightarrow>* (SKIP, t)"
  ultimately have "(c;; ?ru, s) \<rightarrow>* (SKIP, t)" using seq_comp by blast
  moreover have "(REPEAT c UNTIL b, s) \<rightarrow> (c;; ?ru, s)" by auto
  ultimately show "(REPEAT c UNTIL b, s) \<rightarrow>* (SKIP, t)" by (auto intro: star.step)
next
  fix b s\<^sub>2 c s\<^sub>1 s\<^sub>3
  let ?ru = "IF b THEN SKIP ELSE REPEAT c UNTIL b"
  assume "\<not> bval b s\<^sub>2"
  assume "(c, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>2)"
  hence "(REPEAT c UNTIL b, s\<^sub>1) \<rightarrow>* (SKIP;; ?ru, s\<^sub>2)" using star_seq2
    by (auto intro: star.step)
  moreover have "(SKIP;; ?ru, s\<^sub>2) \<rightarrow>* (REPEAT c UNTIL b, s\<^sub>2)" using `\<not> bval b s\<^sub>2`
    by (auto intro: star.step)
  moreover assume "(REPEAT c UNTIL b, s\<^sub>2) \<rightarrow>* (SKIP, s\<^sub>3)"
  ultimately show "(REPEAT c UNTIL b, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>3)"
    by (auto intro: star_trans)
next
  fix c1 s t c2
  assume "(c1, s) \<rightarrow>* (SKIP, t)"
  moreover have "(c1 OR c2, s) \<rightarrow> (c1, s)" by simp
  ultimately show "(c1 OR c2, s) \<rightarrow>* (SKIP, t)" by (metis star.step)
next
  fix c1 s t c2
  assume "(c2, s) \<rightarrow>* (SKIP, t)"
  moreover have "(c1 OR c2, s) \<rightarrow> (c2, s)" by simp
  ultimately show "(c1 OR c2, s) \<rightarrow>* (SKIP, t)" by (metis star.step)
qed

text{* Each case of the induction can be proved automatically: *}
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
next
  case RepeatTrue
  thus ?case
    by (blast intro: seq_comp star.step)
next
  case RepeatFalse
  thus ?case
    by (metis star_trans star.step[OF Repeat star_seq2]
      star.step[OF Seq1 star.step[OF IfFalse star.refl[of small_step]]])
next
  case Or1
  thus ?case by (metis small_step.Or1 star.step)
next
  case Or2
  thus ?case by (metis small_step.Or2 star.step)
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction cs "(SKIP,t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(EX cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis SkipE finalD final_def)

text{* Now we can show that @{text"\<Rightarrow>"} yields a final state iff @{text"\<rightarrow>"}
terminates: *}

lemma big_iff_small_termination:
  "(EX t. cs \<Rightarrow> t) \<longleftrightarrow> (EX cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text{* This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since @{text"\<rightarrow>"} is determininistic, there is no difference
between may and must terminate. *}

end


section \<open>Lenses\<close>
theory Lenses
imports Error_Monad
begin

  subsection \<open>Basic Definition\<close>
  type_synonym ('a,'b,'e) elens = "('a \<Rightarrow> ('b,'e) error) \<times> ('b \<Rightarrow> 'a \<Rightarrow> ('a,'e) error)"

  primrec eget :: "('a,'b,'e) elens \<Rightarrow> 'a \<Rightarrow> ('b,'e) error" where "eget (g,s) = g"
  primrec eset :: "('a,'b,'e) elens \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> ('a,'e) error" where "eset (g,s) = s"

  (* TODO: The behaviour in case of error is not specified here *)
  locale elens =
    fixes l :: "('a,'b,'e) elens"
    assumes get_set[e_vcg]: "e_spec (op = b) (\<lambda>_. True) True (eset l b a \<bind> eget l)"
    assumes set_get[e_vcg]: "e_spec (op = a) (\<lambda>_. True) True (do { b \<leftarrow> eget l a; eset l b a })"
    assumes get_term[simp]: "\<not>is_nonterm (eget l a)"
    assumes set_term[simp]: "\<not>is_nonterm (eset l b a)"
    (*assumes set_set[simp]: "eset l b a \<bind> eset l b = eset l b a"*)

  definition ecompose :: "('a,'b,'e) elens \<Rightarrow> ('b,'c,'e) elens \<Rightarrow> ('a,'c,'e) elens" (infixl "o\<^sub>l" 55)
  where
    "ecompose \<equiv> \<lambda>l1 l2. ( \<lambda>a. eget l1 a \<bind> eget l2, \<lambda>c a. do { b \<leftarrow> eget l1 a; b \<leftarrow> eset l2 c b; eset l1 b a })"

  notation ecompose (infixl "\<circ>\<^sub>l" 55)

  lemma elens_compose[simp]:
    assumes "elens l1"
    assumes "elens l2"
    shows "elens (ecompose l1 l2)"
  proof -
    interpret l1: elens l1 by fact
    interpret l2: elens l2 by fact

    show ?thesis
      apply unfold_locales
      using l1.get_set l2.get_set
      apply (simp add: ecompose_def pw_espec_iff; blast)

      using l1.set_get l2.set_get
      apply (simp add: ecompose_def pw_espec_iff)
      apply safe
      apply (metis is_res.elims(2) is_res.simps(1))
      apply (simp add: ecompose_def pw_espec_iff)
      apply (simp add: ecompose_def pw_espec_iff)
      done
  qed

  lemma e_vcg_e_compose_get[e_vcg]:
    assumes [e_vcg]: "e_spec P1 E1 T1 (eget l1 a)"
    assumes [e_vcg]: "\<And>b. P1 b \<Longrightarrow> e_spec (P2 b) (E2 b) (T2 b) (eget l2 b)"
    shows "e_spec
      (\<lambda>c. \<exists>b. P1 b \<and> P2 b c)
      (\<lambda>e. E1 e \<or> (\<exists>b. P1 b \<and> E2 b e))
      (T1 \<or> (\<exists>b. P1 b \<and> T2 b))
      (eget (l1 o\<^sub>l l2) a)"
    unfolding ecompose_def
    by e_vcg

  lemma e_vcg_e_compose_set[e_vcg]:
    assumes [e_vcg]: "e_spec P1 E1 T1 (eget l1 a)"
    assumes [e_vcg]: "\<And>b. P1 b \<Longrightarrow> e_spec (P2 b) (E2 b) (T2 b) (eset l2 c b)"
    assumes [e_vcg]: "\<And>b c. \<lbrakk>P1 b; P2 b c\<rbrakk> \<Longrightarrow> e_spec (P3 b c) (E3 b c) (T3 b c) (eset l1 c a)"
    shows "e_spec
      (\<lambda>a. \<exists>b c. P1 b \<and> P2 b c \<and> P3 b c a)
      (\<lambda>e. E1 e \<or> (\<exists>b. P1 b \<and> (E2 b e \<or> (\<exists>c. P2 b c \<and> E3 b c e))))
      (T1 \<or> (\<exists>b. P1 b \<and> (T2 b \<or> (\<exists>c. P2 b c \<and> T3 b c))))
      (eset (l1 o\<^sub>l l2) c a)"
    unfolding ecompose_def
    by e_vcg

  lemma ecompose_assoc:
    "a o\<^sub>l (b o\<^sub>l c) = (a o\<^sub>l b) o\<^sub>l c"
    unfolding ecompose_def
    apply (auto )
    oops (* TODO: Spec of elens not yet adequate for error-case ?*)

  lemmas [simp, intro!] = elens.get_term elens.set_term

  subsection \<open>Basic Lenses\<close>
  definition l_id :: "('a,'a,_) elens" where "l_id \<equiv> (return, \<lambda>a _. return a)"

  lemma elens_id[simp]: "elens (l_id)"
    unfolding l_id_def
    by (unfold_locales) e_vcg+

  lemma l_id_get_spec[e_vcg]: "e_spec (op = a) (\<lambda>_. False) (False) (eget l_id a)"
    unfolding l_id_def by e_vcg

  lemma l_id_set_spec[e_vcg]: "e_spec (op = a) (\<lambda>_. False) (False) (eset l_id a foo)"
    unfolding l_id_def by e_vcg

  definition l_fail :: "'e \<Rightarrow> ('a,'b,'e) elens" where "l_fail e \<equiv> (\<lambda>_. EAssert e, \<lambda>_ _. EAssert e)"

  lemma elens_fail[simp]: "elens (l_fail e)"
    unfolding l_fail_def
    by (unfold_locales) e_vcg+

  subsection \<open>Generic Lenses\<close>
  text \<open>Generic lens to access one-argument constructors\<close>

  context
    fixes isC :: "'a \<Rightarrow> bool"
    and theC :: "'a \<Rightarrow> 'b"
    and C :: "'b \<Rightarrow> 'a"
    and e :: "'e"
  begin
    -- \<open>This indirection is required for code generation to work properly. (sigh)\<close>
    definition "l_C1_lens \<equiv> (
      \<lambda>a. if isC a then return (theC a) else EAssert e,
      \<lambda>b a. if isC a then return (C b) else EAssert e
    )"
  end

  locale l_C1 =
    fixes isC :: "'a \<Rightarrow> bool"
    and theC :: "'a \<Rightarrow> 'b"
    and C :: "'b \<Rightarrow> 'a"
    and e :: "'e"
    assumes [simp]: "\<And>x. theC (C x) = x"
    assumes [simp]: "\<And>x. isC x \<Longrightarrow> C (theC x) = x"
  begin
    abbreviation "l \<equiv> l_C1_lens isC theC C e"
    lemmas l_def = l_C1_lens_def[of isC theC C e]

    lemma
      is_elens[simp]: "elens l" and
      get_spec[e_vcg]: "e_spec (\<lambda>b. isC a \<and> b=theC a) (\<lambda>e'. e'=e \<and> \<not>isC a) False (eget l a)" and
      set_spec[e_vcg]: "e_spec (\<lambda>a'. isC a \<and> a'=C b) (\<lambda>e'. e'=e \<and> \<not>isC a) False (eset l b a)"
    apply unfold_locales
    unfolding l_def l_C1_def
    by auto

    lemma E: assumes "isC a" obtains b where "a=C b"
      apply (rule that[of "theC a"])
      using assms
      by auto

  end

  subsection \<open>Standard Lenses\<close>

  definition "l_nth e i \<equiv> (
    \<lambda>as. do { assert (i<length as) e; return (as!i) },
    \<lambda>a as. do { assert (i<length as) e; return (as[i:=a]) })"

  lemma elens_nth[simp]: "elens (l_nth e i)"
    unfolding l_nth_def
    by (unfold_locales) e_vcg+

  lemma l_nth_get_spec[e_vcg]: "e_spec (\<lambda>x. l!i = x \<and> i<length l) (\<lambda>e'. e'=e \<and> \<not>(i<length l)) False (eget (l_nth e i) l)"
    unfolding l_nth_def by e_vcg

  lemma l_nth_set_spec[e_vcg]: "e_spec (\<lambda>x. x = l[i:=b] \<and> i<length l) (\<lambda>e'. e'=e \<and> \<not>(i<length l)) False (eset (l_nth e i) b l)"
    unfolding l_nth_def by e_vcg

  definition l_last :: "'e \<Rightarrow> ('a list,'a,'e) elens" where
    "l_last e \<equiv> (
      \<lambda>l. if l=[] then EAssert e else return (last l),
      \<lambda>a l. if l=[] then EAssert e else return (butlast l@[a]))"

  lemma elens_last[simp]: "elens (l_last e)"
    unfolding l_last_def
    by (unfold_locales) e_vcg+

  lemma l_last_spec[e_vcg]:
    "e_spec (\<lambda>a. \<exists>l'. l=l'@[a]) (\<lambda>e'. e'=e \<and> l=[]) False (eget (l_last e) l)"
    "e_spec (\<lambda>l'. \<exists>lh ah. l=lh@[ah] \<and> l'=lh@[a]) (\<lambda>e'. e'=e \<and> l=[]) False (eset (l_last e) a l)"
    unfolding l_last_def
    by (cases l rule: rev_cases; auto)+

  definition l_butlast :: "'e \<Rightarrow> ('a list,'a list,'e) elens" where
    "l_butlast e \<equiv> (
      \<lambda>l. if l=[] then EAssert e else return (butlast l),
      \<lambda>a l. if l=[] then EAssert e else return (a@[last l]))"

  lemma elens_butlast[simp]: "elens (l_butlast e)"
    unfolding l_butlast_def
    by (unfold_locales) e_vcg+

  lemma l_butlast_spec[e_vcg]:
    "e_spec (\<lambda>l'. \<exists>x. l=l'@[x]) (\<lambda>e'. e'=e \<and> l=[]) False (eget (l_butlast e) l)"
    "e_spec (\<lambda>l'. \<exists>lh ah. l=lh@[ah] \<and> l'=ln@[ah]) (\<lambda>e'. e'=e \<and> l=[]) False (eset (l_butlast e) ln l)"
    unfolding l_butlast_def
    by (cases l rule: rev_cases; auto)+

  definition "l_fst \<equiv> (return o fst, \<lambda>a (_,b). return (a,b))"
  lemma elens_fst[simp]: "elens l_fst"
    unfolding l_fst_def
    by (unfold_locales) e_vcg+

  lemma l_fst_get_spec[e_vcg]: "e_spec (op = (fst a)) (\<lambda>_. False) False (eget l_fst a)"
    unfolding l_fst_def by e_vcg

  lemma l_fst_set_spec[e_vcg]: "e_spec (op = (b,snd a)) (\<lambda>_. False) False (eset l_fst b a)"
    unfolding l_fst_def by e_vcg

  definition "l_snd \<equiv> (return o snd, \<lambda>b (a,_). return (a,b))"
  lemma elens_snd[simp]: "elens l_snd"
    unfolding l_snd_def
    by (unfold_locales) e_vcg+

  lemma l_snd_get_spec[e_vcg]: "e_spec (op = (snd a)) (\<lambda>_. False) False (eget l_snd a)"
    unfolding l_snd_def by e_vcg

  lemma l_snd_set_spec[e_vcg]: "e_spec (op = (fst a,b)) (\<lambda>_. False) False (eset l_snd b a)"
    unfolding l_snd_def by e_vcg

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Noninterference_Base_Refinement_Example
imports
  Noninterference_Base_Refinement
begin

(* I don't like the 'refinedby' definition above.
   the following example shows why.

   let the spec be:
   s0 \<rightarrow> s1 \<rightarrow> s1
      \<rightarrow> s2 \<rightarrow> s3 \<rightarrow> s3

   and let the implementation be:
   s0 \<rightarrow> s1 \<rightarrow> s3 \<rightarrow> s3
      \<rightarrow> s2 \<rightarrow> s3 \<rightarrow> s3

   Then the implementation can transition from s1 \<rightarrow> s3 but the
   spec cannot. But the implementation still refines the spec
   according to refinedby above. We prove this below.

   The 'refinedby' definition above seems to correspond to our
   top-level refinement statement on ADTs for seL4.

   TODO: - check whether our 'corres' can be derived from the
           forward simulation results for seL4.
*)

datatype state = S0 | S1 | S2 | S3

datatype event = OnlyEvent
definition Step  :: "event \<Rightarrow> (state \<times> state) set" where
  "Step \<equiv> (\<lambda> a. {(S0,S1), (S0,S2), (S1,S1), (S2,S3), (S3,S3)})"

definition Step' :: "event \<Rightarrow> (state \<times> state) set" where
  "Step' \<equiv> (\<lambda> a. {(S0,S1), (S0,S2), (S1,S3), (S2,S3), (S3,S3)})"

datatype domain = OnlyDom
definition dom :: "event \<Rightarrow> state \<Rightarrow> domain" where "dom \<equiv> \<lambda> x y. OnlyDom"

definition uwr :: "domain \<Rightarrow> (state \<times> state) set" where "uwr \<equiv> \<lambda> x. {(y,z). True}"

definition policy :: "(domain \<times> domain) set" where "policy \<equiv> {(OnlyDom,OnlyDom)}"

definition out :: "domain \<Rightarrow> state \<Rightarrow> state" where "out \<equiv> \<lambda> d x. x"

lemma execution_Step_0:
  "length as = 0 \<Longrightarrow> execution Step S0 as = {S0}"
  apply(clarsimp simp: execution_def)
  done

lemma execution_Step'_0:
  "length as = 0 \<Longrightarrow> execution Step' S0 as = {S0}"
  apply(clarsimp simp: execution_def)
  done

lemma length_nonzero:
  "length xs = Suc n \<Longrightarrow> \<exists> as a. xs = as @ [a] \<and> length as = n"
  apply(induct xs rule: rev_induct)
   apply simp
  apply simp
  done

lemma execution_Step_1:
  "length as = 1 \<Longrightarrow> execution Step S0 as = {S1,S2}"
  apply simp
  apply(drule length_nonzero)
  apply(clarify)
  apply(subst execution_append_one)
  apply(auto simp: execution_def Step_def)
  done

lemma execution_Step'_1:
  "length as = 1 \<Longrightarrow> execution Step' S0 as = {S1,S2}"
  apply simp
  apply(drule length_nonzero)
  apply(clarify)
  apply(subst execution_append_one)
  apply(auto simp: execution_def Step'_def)
  done

lemma execution_Step_2up:
  "\<lbrakk>length as = (Suc n); n \<ge> (Suc 0)\<rbrakk> \<Longrightarrow> execution Step S0 as = {S1,S3}"
  apply(induct n arbitrary: as)
   apply simp
  apply simp
  apply(case_tac "n=0")
   apply(frule length_nonzero)
   apply(clarify)
   apply(subst execution_append_one)
   apply clarsimp
   apply(rule equalityI)
    apply clarsimp
    apply(drule execution_Step_1[simplified])
    apply(fastforce simp: Step_def)
   apply (subst execution_Step_1, simp)
   apply (fastforce simp: Step_def)
  apply(frule length_nonzero)
  apply(clarify)
  apply(subst execution_append_one)
  apply clarsimp
  apply (fastforce simp: Step_def)
  done

lemma execution_Step'_2up:
  "\<lbrakk>length as = (Suc n); n \<ge> (Suc 0)\<rbrakk> \<Longrightarrow> execution Step' S0 as = {S3}"
  apply(induct n arbitrary: as)
   apply simp
  apply simp
  apply(case_tac "n=0")
   apply(frule length_nonzero)
   apply(clarify)
   apply(subst execution_append_one)
   apply clarsimp
   apply(rule equalityI)
    apply clarsimp
    apply(drule execution_Step'_1[simplified])
    apply(fastforce simp: Step'_def)
   apply (subst execution_Step'_1, simp)
   apply (fastforce simp: Step'_def)
  apply(frule length_nonzero)
  apply(clarify)
  apply(subst execution_append_one)
  apply clarsimp
  apply (fastforce simp: Step'_def)
  done

interpretation enabled_system_refinement Step S0 dom uwr policy out OnlyDom Step' S0
  apply(unfold_locales)
         apply(clarsimp)
         apply(case_tac s)
            apply(auto simp: Step_def uwr_def refl_on_def sym_def trans_def dom_def policy_def)[8]
    apply(case_tac d, simp_all add: policy_def)
  apply clarsimp
  apply(case_tac s, auto simp: Step'_def)
  done

lemma refinedby:
  "enabled_system_refinement.refinedby Step S0 Step'"
  apply(clarsimp simp: refinedby_def)
  apply(case_tac as)
   apply(subst (asm) execution_Step'_0, simp)
   apply(subst execution_Step_0, simp)
   apply assumption
  apply(case_tac "length list  = 0")
   apply(subst (asm) execution_Step'_1, simp)
   apply(subst execution_Step_1, simp)
   apply assumption
  apply(subst (asm) execution_Step'_2up, simp)
   apply(case_tac list, fastforce+)
  apply(subst execution_Step_2up, simp)
   apply(case_tac list, fastforce+)
  done

lemma not_corres:
  "\<not> enabled_system_refinement.corres Step S0 Step'"
  apply(clarsimp simp: corres_def)
  apply(rule_tac x="S1" in exI)
  apply(rule conjI)
   apply(simp add: reachable_def)
   apply(rule_tac x="[OnlyEvent]" in exI)
   apply(fastforce simp: Step'_def)
  apply(rule_tac x="OnlyEvent" in exI)
  apply(rule_tac x="S3" in exI)
  apply(fastforce simp: Step_def Step'_def)
  done

end


(* Title:      HOL/Presburger.thy
   Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Decision Procedure for Presburger Arithmetic\<close>

theory Presburger
imports Groebner_Basis Set_Interval
keywords "try0" :: diag
begin

ML_file \<open>Tools/Qelim/qelim.ML\<close>
ML_file \<open>Tools/Qelim/cooper_procedure.ML\<close>

subsection\<open>The \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Properties\<close>

lemma minf:
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x = t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<noteq> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x < t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<le> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x > t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<ge> t) = False"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (d dvd x + s) = (d dvd x + s)"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
  "\<exists>z.\<forall>x<z. F = F"
proof safe
  fix z1 z2
  assume "\<forall>x<z1. P x = P' x" and "\<forall>x<z2. Q x = Q' x"
  then have "\<forall>x < min z1 z2. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by blast
next
  fix z1 z2
  assume "\<forall>x<z1. P x = P' x" and "\<forall>x<z2. Q x = Q' x"
  then have "\<forall>x < min z1 z2. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by blast
next
  have "\<forall>x<t. x \<le> t"
    by fastforce
  then show "\<exists>z. \<forall>x<z. (x \<le> t) = True"
    by auto
next
  have "\<forall>x<t. \<not> t < x"
    by fastforce
  then show "\<exists>z. \<forall>x<z. (t < x) = False"
    by auto
next
  have "\<forall>x<t. \<not> t \<le> x"
    by fastforce
  then show "\<exists>z. \<forall>x<z. (t \<le> x) = False"
    by auto
qed auto

lemma pinf:
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x = t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<noteq> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x < t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<le> t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x > t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<ge> t) = True"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (d dvd x + s) = (d dvd x + s)"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
  "\<exists>z.\<forall>x>z. F = F"
proof safe
  fix z1 z2
  assume "\<forall>x>z1. P x = P' x" and "\<forall>x>z2. Q x = Q' x"
  then have "\<forall>x > max z1 z2. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
    by blast
next
  fix z1 z2
  assume "\<forall>x>z1. P x = P' x" and "\<forall>x>z2. Q x = Q' x"
  then have "\<forall>x > max z1 z2. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by simp
  then show "\<exists>z. \<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
    by blast
next
  have "\<forall>x>t. \<not> x < t"
    by fastforce
  then show "\<exists>z. \<forall>x>z. x < t = False"
    by blast
next
  have "\<forall>x>t. \<not> x \<le> t"
    by fastforce
  then show "\<exists>z. \<forall>x>z. x \<le> t = False"
    by blast
next
  have "\<forall>x>t. t \<le> x"
    by fastforce
  then show "\<exists>z. \<forall>x>z. t \<le> x = True"
    by blast
qed auto

lemma inf_period:
  "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
    \<Longrightarrow> \<forall>x k. (P x \<and> Q x) = (P (x - k*D) \<and> Q (x - k*D))"
  "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
    \<Longrightarrow> \<forall>x k. (P x \<or> Q x) = (P (x - k*D) \<or> Q (x - k*D))"
  "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (d dvd x + t) = (d dvd (x - k*D) + t)"
  "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (\<not>d dvd x + t) = (\<not>d dvd (x - k*D) + t)"
  "\<forall>x k. F = F"
apply (auto elim!: dvdE simp add: algebra_simps)
unfolding mult.assoc [symmetric] distrib_right [symmetric] left_diff_distrib [symmetric]
unfolding dvd_def mult.commute [of d]
by auto

subsection\<open>The A and B sets\<close>
lemma bset:
  "\<lbrakk>\<forall>x.(\<forall>j \<in> {1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x - D) \<and> Q (x - D))"
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x - D) \<or> Q (x - D))"
  "\<lbrakk>D>0; t - 1\<in> B\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
  "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
  "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))"
  "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t))"
  "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t))"
  "\<lbrakk>D>0 ; t - 1 \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x - D) + t))"
  "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> F \<longrightarrow> F"
proof (blast, blast)
  assume dp: "D > 0" and tB: "t - 1\<in> B"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
    apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t - 1"])
    apply algebra using dp tB by simp_all
next
  assume dp: "D > 0" and tB: "t \<in> B"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
    apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
    apply algebra
    using dp tB by simp_all
next
  assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))" by arith
next
  assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t)" by arith
next
  assume dp: "D > 0" and tB:"t \<in> B"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x > t" and ng: "\<not> (x - D) > t"
    hence "x -t \<le> D" and "1 \<le> x - t" by simp+
      hence "\<exists>j \<in> {1 .. D}. x - t = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = t + j" by (simp add: algebra_simps)
      with nob tB have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t)" by blast
next
  assume dp: "D > 0" and tB:"t - 1\<in> B"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x \<ge> t" and ng: "\<not> (x - D) \<ge> t"
    hence "x - (t - 1) \<le> D" and "1 \<le> x - (t - 1)" by simp+
      hence "\<exists>j \<in> {1 .. D}. x - (t - 1) = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = (t - 1) + j" by (simp add: algebra_simps)
      with nob tB have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t)" by blast
next
  assume d: "d dvd D"
  {fix x assume H: "d dvd x + t" with d have "d dvd (x - D) + t" by algebra}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t)" by simp
next
  assume d: "d dvd D"
  {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not> d dvd (x - D) + t"
      by (clarsimp simp add: dvd_def,erule_tac x= "ka + k" in allE,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x - D) + t)" by auto
qed blast

lemma aset:
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x + D) \<and> Q (x + D))"
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x + D) \<or> Q (x + D))"
  "\<lbrakk>D>0; t + 1\<in> A\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
  "\<lbrakk>D>0 ; t \<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
  "\<lbrakk>D>0; t\<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int). (\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t))"
  "\<lbrakk>D>0; t + 1 \<in> A\<rbrakk> \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t))"
  "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))"
  "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x + D) + t))"
  "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> F \<longrightarrow> F"
proof (blast, blast)
  assume dp: "D > 0" and tA: "t + 1 \<in> A"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
    apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t + 1"])
    using dp tA by simp_all
next
  assume dp: "D > 0" and tA: "t \<in> A"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
    apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
    using dp tA by simp_all
next
  assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))" by arith
next
  assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t)" by arith
next
  assume dp: "D > 0" and tA:"t \<in> A"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x < t" and ng: "\<not> (x + D) < t"
    hence "t - x \<le> D" and "1 \<le> t - x" by simp+
      hence "\<exists>j \<in> {1 .. D}. t - x = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = t - j" by (auto simp add: algebra_simps)
      with nob tA have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t)" by blast
next
  assume dp: "D > 0" and tA:"t + 1\<in> A"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x \<le> t" and ng: "\<not> (x + D) \<le> t"
    hence "(t + 1) - x \<le> D" and "1 \<le> (t + 1) - x" by (simp_all add: algebra_simps)
      hence "\<exists>j \<in> {1 .. D}. (t + 1) - x = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = (t + 1) - j" by (auto simp add: algebra_simps)
      with nob tA have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t)" by blast
next
  assume d: "d dvd D"
  have "\<And>x. d dvd x + t \<Longrightarrow> d dvd x + D + t"
  proof -
    fix x
    assume H: "d dvd x + t"
    then obtain ka where "x + t = d * ka"
      unfolding dvd_def by blast
    moreover from d obtain k where *:"D = d * k"
      unfolding dvd_def by blast
    ultimately have "x + d * k + t = d * (ka + k)"
      by (simp add: algebra_simps)
    then show "d dvd (x + D) + t"
      using * unfolding dvd_def by blast
  qed
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t)" by simp
next
  assume d: "d dvd D"
  {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not>d dvd (x + D) + t"
      by (clarsimp simp add: dvd_def,erule_tac x= "ka - k" in allE,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x + D) + t)" by auto
qed blast

subsection\<open>Cooper's Theorem \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Version\<close>

subsubsection\<open>First some trivial facts about periodic sets or predicates\<close>
lemma periodic_finite_ex:
  assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
  shows "(\<exists>x. P x) = (\<exists>j \<in> {1..d}. P j)"
  (is "?LHS = ?RHS")
proof
  assume ?LHS
  then obtain x where P: "P x" ..
  have "x mod d = x - (x div d)*d" by(simp add:mult_div_mod_eq [symmetric] ac_simps eq_diff_eq)
  hence Pmod: "P x = P(x mod d)" using modd by simp
  show ?RHS
  proof (cases)
    assume "x mod d = 0"
    hence "P 0" using P Pmod by simp
    moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
    ultimately have "P d" by simp
    moreover have "d \<in> {1..d}" using dpos by simp
    ultimately show ?RHS ..
  next
    assume not0: "x mod d \<noteq> 0"
    have "P(x mod d)" using dpos P Pmod by simp
    moreover have "x mod d \<in> {1..d}"
    proof -
      from dpos have "0 \<le> x mod d" by(rule pos_mod_sign)
      moreover from dpos have "x mod d < d" by(rule pos_mod_bound)
      ultimately show ?thesis using not0 by simp
    qed
    ultimately show ?RHS ..
  qed
qed auto

subsubsection\<open>The \<open>-\<infinity>\<close> Version\<close>

lemma decr_lemma: "0 < (d::int) \<Longrightarrow> x - (\<bar>x - z\<bar> + 1) * d < z"
  by (induct rule: int_gr_induct) (simp_all add: int_distrib)

lemma incr_lemma: "0 < (d::int) \<Longrightarrow> z < x + (\<bar>x - z\<bar> + 1) * d"
  by (induct rule: int_gr_induct) (simp_all add: int_distrib)

lemma decr_mult_lemma:
  assumes dpos: "(0::int) < d" and minus: "\<forall>x. P x \<longrightarrow> P(x - d)" and knneg: "0 <= k"
  shows "\<forall>x. P x \<longrightarrow> P(x - k*d)"
using knneg
proof (induct rule:int_ge_induct)
  case base thus ?case by simp
next
  case (step i)
  {fix x
    have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
    also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)" using minus[THEN spec, of "x - i * d"]
      by (simp add: algebra_simps)
    ultimately have "P x \<longrightarrow> P(x - (i + 1) * d)" by blast}
  thus ?case ..
qed

lemma  minusinfinity:
  assumes dpos: "0 < d" and
    P1eqP1: "\<forall>x k. P1 x = P1(x - k*d)" and ePeqP1: "\<exists>z::int. \<forall>x. x < z \<longrightarrow> (P x = P1 x)"
  shows "(\<exists>x. P1 x) \<longrightarrow> (\<exists>x. P x)"
proof
  assume eP1: "\<exists>x. P1 x"
  then obtain x where P1: "P1 x" ..
  from ePeqP1 obtain z where P1eqP: "\<forall>x. x < z \<longrightarrow> (P x = P1 x)" ..
  let ?w = "x - (\<bar>x - z\<bar> + 1) * d"
  from dpos have w: "?w < z" by(rule decr_lemma)
  have "P1 x = P1 ?w" using P1eqP1 by blast
  also have "\<dots> = P(?w)" using w P1eqP by blast
  finally have "P ?w" using P1 by blast
  thus "\<exists>x. P x" ..
qed

lemma cpmi:
  assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x< z. P x = P' x"
  and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> B. x \<noteq> b+j) \<longrightarrow> P (x) \<longrightarrow> P (x - D)"
  and pd: "\<forall> x k. P' x = P' (x-k*D)"
  shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists>j \<in> {1..D}. \<exists> b \<in> B. P (b+j)))"
         (is "?L = (?R1 \<or> ?R2)")
proof-
 {assume "?R2" hence "?L"  by blast}
 moreover
 {assume H:"?R1" hence "?L" using minusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
 moreover
 { fix x
   assume P: "P x" and H: "\<not> ?R2"
   {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>B. P (b + j))" and P: "P y"
     hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. y = b+j)" by auto
     with nb P  have "P (y - D)" by auto }
   hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)" by blast
   with H P have th: " \<forall>x. P x \<longrightarrow> P (x - D)" by auto
   from p1 obtain z where z: "\<forall>x. x < z \<longrightarrow> (P x = P' x)" by blast
   let ?y = "x - (\<bar>x - z\<bar> + 1)*D"
   have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
   from dp have yz: "?y < z" using decr_lemma[OF dp] by simp
   from z[rule_format, OF yz] decr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
   with periodic_finite_ex[OF dp pd]
   have "?R1" by blast}
 ultimately show ?thesis by blast
qed

subsubsection \<open>The \<open>+\<infinity>\<close> Version\<close>

lemma  plusinfinity:
  assumes dpos: "(0::int) < d" and
    P1eqP1: "\<forall>x k. P' x = P'(x - k*d)" and ePeqP1: "\<exists> z. \<forall> x>z. P x = P' x"
  shows "(\<exists> x. P' x) \<longrightarrow> (\<exists> x. P x)"
proof
  assume eP1: "\<exists>x. P' x"
  then obtain x where P1: "P' x" ..
  from ePeqP1 obtain z where P1eqP: "\<forall>x>z. P x = P' x" ..
  let ?w' = "x + (\<bar>x - z\<bar> + 1) * d"
  let ?w = "x - (- (\<bar>x - z\<bar> + 1)) * d"
  have ww'[simp]: "?w = ?w'" by (simp add: algebra_simps)
  from dpos have w: "?w > z" by(simp only: ww' incr_lemma)
  hence "P' x = P' ?w" using P1eqP1 by blast
  also have "\<dots> = P(?w)" using w P1eqP by blast
  finally have "P ?w" using P1 by blast
  thus "\<exists>x. P x" ..
qed

lemma incr_mult_lemma:
  assumes dpos: "(0::int) < d" and plus: "\<forall>x::int. P x \<longrightarrow> P(x + d)" and knneg: "0 <= k"
  shows "\<forall>x. P x \<longrightarrow> P(x + k*d)"
using knneg
proof (induct rule:int_ge_induct)
  case base thus ?case by simp
next
  case (step i)
  {fix x
    have "P x \<longrightarrow> P (x + i * d)" using step.hyps by blast
    also have "\<dots> \<longrightarrow> P(x + (i + 1) * d)" using plus[THEN spec, of "x + i * d"]
      by (simp add:int_distrib ac_simps)
    ultimately have "P x \<longrightarrow> P(x + (i + 1) * d)" by blast}
  thus ?case ..
qed

lemma cppi:
  assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x> z. P x = P' x"
  and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> A. x \<noteq> b - j) \<longrightarrow> P (x) \<longrightarrow> P (x + D)"
  and pd: "\<forall> x k. P' x= P' (x-k*D)"
  shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists> j \<in> {1..D}. \<exists> b\<in> A. P (b - j)))" (is "?L = (?R1 \<or> ?R2)")
proof-
 {assume "?R2" hence "?L"  by blast}
 moreover
 {assume H:"?R1" hence "?L" using plusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
 moreover
 { fix x
   assume P: "P x" and H: "\<not> ?R2"
   {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>A. P (b - j))" and P: "P y"
     hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. y = b - j)" by auto
     with nb P  have "P (y + D)" by auto }
   hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. P(b-j)) \<longrightarrow> P (x) \<longrightarrow> P (x + D)" by blast
   with H P have th: " \<forall>x. P x \<longrightarrow> P (x + D)" by auto
   from p1 obtain z where z: "\<forall>x. x > z \<longrightarrow> (P x = P' x)" by blast
   let ?y = "x + (\<bar>x - z\<bar> + 1)*D"
   have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
   from dp have yz: "?y > z" using incr_lemma[OF dp] by simp
   from z[rule_format, OF yz] incr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
   with periodic_finite_ex[OF dp pd]
   have "?R1" by blast}
 ultimately show ?thesis by blast
qed

lemma simp_from_to: "{i..j::int} = (if j < i then {} else insert i {i+1..j})"
apply(simp add:atLeastAtMost_def atLeast_def atMost_def)
apply(fastforce)
done

theorem unity_coeff_ex: "(\<exists>(x::'a::{semiring_0,Rings.dvd}). P (l * x)) \<equiv> (\<exists>x. l dvd (x + 0) \<and> P x)"
  unfolding dvd_def by (rule eq_reflection, rule iffI) auto

lemma zdvd_mono:
  fixes k m t :: int
  assumes "k \<noteq> 0"
  shows "m dvd t \<equiv> k * m dvd k * t"
  using assms by simp

lemma uminus_dvd_conv:
  fixes d t :: int
  shows "d dvd t \<equiv> - d dvd t" and "d dvd t \<equiv> d dvd - t"
  by simp_all

text \<open>\bigskip Theorems for transforming predicates on nat to predicates on \<open>int\<close>\<close>

lemma zdiff_int_split: "P (int (x - y)) =
  ((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
  by (cases "y \<le> x") (simp_all add: of_nat_diff)

text \<open>
  \medskip Specific instances of congruence rules, to prevent
  simplifier from looping.\<close>

theorem imp_le_cong:
  "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<longrightarrow> P) = (0 \<le> x' \<longrightarrow> P')"
  by simp

theorem conj_le_cong:
  "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<and> P) = (0 \<le> x' \<and> P')"
  by (simp cong: conj_cong)

ML_file \<open>Tools/Qelim/cooper.ML\<close>

method_setup presburger = \<open>
  let
    fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
    fun simple_keyword k = Scan.lift (Args.$$$ k) >> K ()
    val addN = "add"
    val delN = "del"
    val elimN = "elim"
    val any_keyword = keyword addN || keyword delN || simple_keyword elimN
    val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm)
  in
    Scan.optional (simple_keyword elimN >> K false) true --
    Scan.optional (keyword addN |-- thms) [] --
    Scan.optional (keyword delN |-- thms) [] >>
    (fn ((elim, add_ths), del_ths) => fn ctxt =>
      SIMPLE_METHOD' (Cooper.tac elim add_ths del_ths ctxt))
  end
\<close> "Cooper's algorithm for Presburger arithmetic"

declare mod_eq_0_iff_dvd [presburger]
declare mod_by_Suc_0 [presburger]
declare mod_0 [presburger]
declare mod_by_1 [presburger]
declare mod_self [presburger]
declare div_by_0 [presburger]
declare mod_by_0 [presburger]
declare mod_div_trivial [presburger]
declare mult_div_mod_eq [presburger]
declare div_mult_mod_eq [presburger]
declare mod_mult_self1 [presburger]
declare mod_mult_self2 [presburger]
declare mod2_Suc_Suc [presburger]
declare not_mod_2_eq_0_eq_1 [presburger]
declare nat_zero_less_power_iff [presburger]

lemma [presburger, algebra]: "m mod 2 = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod 2 = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod 2 = (1::int) \<longleftrightarrow> \<not> 2 dvd m " by presburger

context semiring_parity
begin

declare even_mult_iff [presburger]

declare even_power [presburger]

lemma [presburger]:
  "even (a + b) \<longleftrightarrow> even a \<and> even b \<or> odd a \<and> odd b"
  by auto

end

context ring_parity
begin

declare even_minus [presburger]

end

context linordered_idom
begin

declare zero_le_power_eq [presburger]

declare zero_less_power_eq [presburger]

declare power_less_zero_eq [presburger]

declare power_le_zero_eq [presburger]

end

declare even_Suc [presburger]

lemma [presburger]:
  "Suc n div Suc (Suc 0) = n div Suc (Suc 0) \<longleftrightarrow> even n"
  by presburger

declare even_diff_nat [presburger]

lemma [presburger]:
  fixes k :: int
  shows "(k + 1) div 2 = k div 2 \<longleftrightarrow> even k"
  by presburger

lemma [presburger]:
  fixes k :: int
  shows "(k + 1) div 2 = k div 2 + 1 \<longleftrightarrow> odd k"
  by presburger

lemma [presburger]:
  "even n \<longleftrightarrow> even (int n)"
  by simp

subsection \<open>Nice facts about division by \<^term>\<open>4\<close>\<close>

lemma even_even_mod_4_iff:
  "even (n::nat) \<longleftrightarrow> even (n mod 4)"
  by presburger

lemma odd_mod_4_div_2:
  "n mod 4 = (3::nat) \<Longrightarrow> odd ((n - Suc 0) div 2)"
  by presburger

lemma even_mod_4_div_2:
  "n mod 4 = Suc 0 \<Longrightarrow> even ((n - Suc 0) div 2)"
  by presburger

subsection \<open>Try0\<close>

ML_file \<open>Tools/try0.ML\<close>

end


theory Proof_5_36
  imports Proofs_5
begin

theorem proof_5_8: "VC36 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC36_def inv5_def R5_def extraInv_def)
  apply(rule impI)
  apply((drule conjE)+)
                      prefer 22
                      apply assumption
                      prefer 21
                      apply assumption
                     prefer 20
                     apply assumption
                    prefer 19
                    apply assumption
                   prefer 18
                   apply assumption
                  prefer 17
                  apply assumption
                 prefer 16
                 apply assumption
                prefer 15
                apply assumption
               prefer 14
               apply assumption
              prefer 13
              apply assumption
             prefer 12
             apply assumption
            prefer 11
            apply assumption
           prefer 10
           apply assumption
          prefer 9
          apply assumption
         prefer 8
         apply assumption
        prefer 7
        apply assumption
       prefer 6
       apply assumption
      prefer 5
      apply assumption
     prefer 4
     apply assumption
    prefer 3
    apply assumption
   prefer 2
   apply assumption
  by (metis One_nat_def Suc_1 Zero_not_Suc getPstate.simps(9) numeral_3_eq_3 substate_refl zero_neq_numeral)


(*  Title:      Presburger-Automata/Exec.thy
    Author:     Stefan Berghofer, TU Muenchen, 2008-2009
*)

theory Exec
imports Presburger_Automata "~~/src/HOL/Library/Code_Target_Numeral"
begin

declare gen_dfs_simps [code]

lemma [code_unfold]: "op \<longrightarrow> = (\<lambda>P. op \<or> (\<not> P))"
  by (simp add: fun_eq_iff)

lemma "\<forall>x. (\<exists>xa. int xa - int x = 5) \<or> (\<forall>xa xb. \<not> 6 \<le> int xb \<longrightarrow> int xb + (6 * int xa - int x) = 0 \<longrightarrow> int xa = 1)"
proof -
  have "?thesis = eval_pf (Forall (Exist (Or (Eq [1, -1] 5)
    (Forall (Forall (Imp (Neg (Le [-1, 0] (- 6))) (Imp (Eq [1, 6, 0, -1] 0) (Eq [0, 1] 1)))))))) []"
    (is "_ = eval_pf ?P []")
    by simp
  also have "\<dots> = dfa_accepts (dfa_of_pf 0 ?P) []"
    by (simp add: dfa_of_pf_correctness del: dfa_of_pf.simps)
  also have "\<dots>" by eval
  finally show ?thesis .
qed

lemma "\<forall>x xa xb. \<not> 2 \<le> int xb \<longrightarrow> int xb + (2 * int xa - int x) = 1 \<longrightarrow>
  (\<forall>xb xc. \<not> 2 \<le> int xc \<longrightarrow> int xc + (2 * int xb - int x) = 0 \<longrightarrow> (\<exists>xa. 2 * int xa = int x) \<longrightarrow> xb = xa)"
proof -
  have "?thesis = eval_pf (Forall (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
    (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
      (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [2, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))) []"
    (is "_ = eval_pf ?P []")
    by simp
  also have "\<dots> = dfa_accepts (dfa_of_pf 0 ?P) []"
    by (simp add: dfa_of_pf_correctness del: dfa_of_pf.simps)
  also have "\<dots>" by eval
  finally show ?thesis .
qed

definition "mk_dfa = dfa_of_pf 0"

definition "stamp = Forall (Imp (Le [-1] (- 8)) (Exist (Exist (Eq [5, 3, -1] 0))))"
definition "stamp_false = Forall (Imp (Le [-1] (- 7)) (Exist (Exist (Eq [5, 3, -1] 0))))"
definition "example = Forall (Exist (Or (Eq [1, -1] 5)
  (Forall (Forall (Imp (Neg (Le [-1, 0] (- 6))) (Imp (Eq [1, 6, 0, -1] 0) (Eq [0, 1] 1)))))))"
definition "example2 = Forall (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
  (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
    (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [2, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))"
definition "example2_false = Forall (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
  (Imp (Eq [1, 2, -1] 1) (Forall (Forall (Imp (Neg (Le [-1] (- 2)))
    (Imp (Eq [1, 2, 0, 0, -1] 0) (Imp (Exist (Eq [3, 0, 0, 0, 0, -1] 0)) (Eq [0, 1, 0, -1] 0))))))))))"
definition "harrison1 = Exist (Forall (Imp (Le [-1, 1] 0) (Exist (Exist
  (And (Le [0, -1] 0) (And (Le [-1] 0) (Eq [8, 3, -1] 0)))))))"
definition "harrison2 = Exist (Forall (Imp (Le [-1, 1] 0) (Exist (Exist
  (And (Le [0, -1] 0) (And (Le [-1] 0) (Eq [8, 7, -1] 0)))))))"

value "mk_dfa stamp"
value "min_dfa (mk_dfa stamp)"
value "mk_dfa stamp_false"
value "mk_dfa example"
value "mk_dfa example2"
value "mk_dfa example2_false"
value "mk_dfa harrison1"
value "mk_dfa harrison2"

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Pre-Conway Algebra with Tests\<close>

theory Conway_Tests
  imports Kleene_Algebra.Conway Test_Dioid

begin

class near_conway_zerol_tests = near_conway_zerol + test_near_semiring_zerol_distrib

begin

lemma n_preserve1_var: "n x \<cdot> y \<le> n x \<cdot> y \<cdot> n x \<Longrightarrow> n x \<cdot> (n x \<cdot> y + t x \<cdot> z)\<^sup>\<dagger> \<le> (n x \<cdot> y)\<^sup>\<dagger> \<cdot> n x"
proof -
  assume a: "n x \<cdot> y \<le> n x \<cdot> y \<cdot> n x"
  have "n x \<cdot> (n x \<cdot> y + t x \<cdot> z) = n x \<cdot> y"
    by (metis (no_types) local.add_zeror local.annil local.n_left_distrib local.n_mult_idem local.test_mult_comp mult_assoc)
  hence "n x \<cdot> (n x \<cdot> y + t x \<cdot> z) \<le> n x \<cdot> y \<cdot> n x"
    by (simp add: a)
  thus " n x \<cdot> (n x \<cdot> y + t x \<cdot> z)\<^sup>\<dagger> \<le> (n x \<cdot> y)\<^sup>\<dagger> \<cdot> n x"
    by (simp add: local.dagger_simr)
qed

lemma test_preserve1_var: "test p \<Longrightarrow> p \<cdot> x \<le> p \<cdot> x \<cdot> p \<Longrightarrow> p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<le> (p \<cdot> x)\<^sup>\<dagger> \<cdot> p"
  by (metis local.test_double_comp_var n_preserve1_var)

end

class test_pre_conway = pre_conway + test_pre_dioid_zerol

begin

subclass near_conway_zerol_tests
  by (unfold_locales)

lemma test_preserve: "test p \<Longrightarrow>  p \<cdot> x \<le> p \<cdot> x \<cdot> p  \<Longrightarrow> p \<cdot> x\<^sup>\<dagger> = (p \<cdot> x)\<^sup>\<dagger> \<cdot> p"
  using local.preservation1_eq local.test_restrictr by auto

lemma test_preserve2: "test p \<Longrightarrow> p \<cdot> x \<cdot> p = p \<cdot> x \<Longrightarrow> p \<cdot> (p \<cdot> x + !p \<cdot> y)\<^sup>\<dagger> \<le> x\<^sup>\<dagger>"
  by (metis (no_types) local.eq_refl local.test_restrictl test_preserve test_preserve1)

end

end


theory propositional_Sound
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Form =  "Form" "Form" | Not "Form" | Var "int"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun or3 :: "bool list => bool" where
"or3 (Nil2) = False"
| "or3 (Cons2 y xs) = or2 y (or3 xs)"

fun models3 :: "int => ((int, bool) Pair2) list => bool list" where
"models3 x (Nil2) = Nil2"
| "models3 x (Cons2 (Pair y2 True) x2) = models3 x x2"
| "models3 x (Cons2 (Pair y2 False) x2) =
     Cons2 (x = y2) (models3 x x2)"

fun fst :: "('a, 'b) Pair2 => 'a" where
"fst (Pair y z) = y"

fun filter :: "('t => bool) => 't list => 't list" where
"filter p (Nil2) = Nil2"
| "filter p (Cons2 y z) =
     (if p y then Cons2 y (filter p z) else filter p z)"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun all :: "('t => bool) => 't list => bool" where
"all x (Nil2) = True"
| "all x (Cons2 z xs) = and2 (x z) (all x xs)"

fun 3 :: "int => ((int, bool) Pair2) list => bool list" where
"3 x (Nil2) = Nil2"
| "3 x (Cons2 (Pair y2 True) x2) = Cons2 (x = y2) (3 x x2)"
| "3 x (Cons2 (Pair y2 False) x2) = 3 x x2"

function models :: "Form => ((int, bool) Pair2) list =>
                  (((int, bool) Pair2) list) list"
         and
           models2 :: "Form => (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list"
         and
           models4 :: "Form => (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list" where
"models ( p q) y = models2 q (models p y)"
| "models (Not ( p2 q2)) y =
     append (models (Not p2) y) (models ( p2 (Not q2)) y)"
| "models (Not (Not p3)) y = models p3 y"
| "models (Not (Var x2)) y =
     (if ~ (or3 (3 x2 y)) then
        Cons2
          (Cons2
             (Pair x2 False)
             (filter
                (% (x3 :: (int, bool) Pair2) =>
                   dot
                     (% (x4 :: int) => x2 ~= x4) (% (x5 :: (int, bool) Pair2) => fst x5)
                     x3)
                y))
          (Nil2)
        else
        Nil2)"
| "models (Var x6) y =
     (if ~ (or3 (models3 x6 y)) then
        Cons2
          (Cons2
             (Pair x6 True)
             (filter
                (% (x7 :: (int, bool) Pair2) =>
                   dot
                     (% (x8 :: int) => x6 ~= x8) (% (x9 :: (int, bool) Pair2) => fst x9)
                     x7)
                y))
          (Nil2)
        else
        Nil2)"
| "models2 q (Nil2) = Nil2"
| "models2 q (Cons2 y z) = models4 q z (models q y)"
| "models4 q x (Nil2) = models2 q x"
| "models4 q x (Cons2 z x2) = Cons2 z (models4 q x x2)"
by pat_completeness auto

fun 2 :: "((int, bool) Pair2) list => Form => bool" where
"2 x ( p q) = and2 (2 x p) (2 x q)"
| "2 x (Not p2) = ~ (2 x p2)"
| "2 x (Var z) = or3 (3 z x)"

(*hipster or2
          or3
          models3
          fst
          filter
          dot
          append
          and2
          all
          3
          models
          models2
          models4
          2 *)

theorem x0 :
  "!! (p :: Form) .
     all (% (x :: ((int, bool) Pair2) list) => 2 x p) (models p (Nil2))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Lappend_inf
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

inductive lfinite :: "'a Llist \<Rightarrow> bool"
where
  lfinite_LNil:  "lfinite LNil"
| lfinite_LConsI: "lfinite xs \<Longrightarrow> lfinite (LCons x xs)"

(* hipster lappend lfinite
Fails because: No code equations for lfinite
*)
theorem  "\<not> lfinite xs \<Longrightarrow> lappend xs ys = xs"
  by hipster_coinduct_sledgehammer
end


(*  Title:      HOL/SET_Protocol/Public_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>The Public-Key Theory, Modified for SET\<close>

theory Public_SET
imports Event_SET
begin

subsection\<open>Symmetric and Asymmetric Keys\<close>

text\<open>definitions influenced by the wish to assign asymmetric keys
  - since the beginning - only to RCA and CAs, namely we need a partial
  function on type Agent\<close>

text\<open>The SET specs mention two signature keys for CAs - we only have one\<close>

consts
  publicKey :: "[bool, agent] \<Rightarrow> key"
    \<comment> \<open>the boolean is TRUE if a signing key\<close>

abbreviation "pubEK == publicKey False"
abbreviation "pubSK == publicKey True"

(*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
abbreviation "priEK A == invKey (pubEK A)"
abbreviation "priSK A == invKey (pubSK A)"

text\<open>By freeness of agents, no two agents have the same key. Since
 \<^term>\<open>True\<noteq>False\<close>, no agent has the same signing and encryption keys.\<close>

specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' \<Longrightarrow> b=c \<and> A=A'"
(*<*)
   apply (rule exI [of _ "%b A. 2 * nat_of_agent A + (if b then 1 else 0)"])
   apply (auto simp add: inj_on_def inj_nat_of_agent [THEN inj_eq] split: agent.split)
   apply (drule_tac f="%x. x mod 2" in arg_cong, simp add: mod_Suc)+
(*or this, but presburger won't abstract out the function applications
   apply presburger+
*)
   done
(*>*)

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]:
      "invKey (publicKey b A) \<noteq> publicKey b' A'"

declare privateKey_neq_publicKey [THEN not_sym, iff]

subsection\<open>Initial Knowledge\<close>

text\<open>This information is not necessary.  Each protocol distributes any needed
certificates, and anyway our proofs require a formalization of the Spy's
knowledge only.  However, the initial knowledge is as follows:
   All agents know RCA's public keys;
   RCA and CAs know their own respective keys;
   RCA (has already certified and therefore) knows all CAs public keys;
   Spy knows all keys of all bad agents.\<close>

overloading initState \<equiv> "initState"
begin

primrec initState where
(*<*)
  initState_CA:
    "initState (CA i)  =
       (if i=0 then Key ` ({priEK RCA, priSK RCA} \<union>
                            pubEK ` (range CA) \<union> pubSK ` (range CA))
        else {Key (priEK (CA i)), Key (priSK (CA i)),
              Key (pubEK (CA i)), Key (pubSK (CA i)),
              Key (pubEK RCA), Key (pubSK RCA)})"

| initState_Cardholder:
    "initState (Cardholder i)  =
       {Key (priEK (Cardholder i)), Key (priSK (Cardholder i)),
        Key (pubEK (Cardholder i)), Key (pubSK (Cardholder i)),
        Key (pubEK RCA), Key (pubSK RCA)}"

| initState_Merchant:
    "initState (Merchant i)  =
       {Key (priEK (Merchant i)), Key (priSK (Merchant i)),
        Key (pubEK (Merchant i)), Key (pubSK (Merchant i)),
        Key (pubEK RCA), Key (pubSK RCA)}"

| initState_PG:
    "initState (PG i)  =
       {Key (priEK (PG i)), Key (priSK (PG i)),
        Key (pubEK (PG i)), Key (pubSK (PG i)),
        Key (pubEK RCA), Key (pubSK RCA)}"
(*>*)
| initState_Spy:
    "initState Spy = Key ` (invKey ` pubEK ` bad \<union>
                            invKey ` pubSK ` bad \<union>
                            range pubEK \<union> range pubSK)"

end

text\<open>Injective mapping from agents to PANs: an agent can have only one card\<close>

consts  pan :: "agent \<Rightarrow> nat"

specification (pan)
  inj_pan: "inj pan"
  \<comment> \<open>No two agents have the same PAN\<close>
(*<*)
   apply (rule exI [of _ "nat_of_agent"])
   apply (simp add: inj_on_def inj_nat_of_agent [THEN inj_eq])
   done
(*>*)

declare inj_pan [THEN inj_eq, iff]

consts
  XOR :: "nat*nat \<Rightarrow> nat"  \<comment> \<open>no properties are assumed of exclusive-or\<close>

subsection\<open>Signature Primitives\<close>

definition
 (* Signature = Message + signed Digest *)
  sign :: "[key, msg]\<Rightarrow>msg"
  where "sign K X = \<lbrace>X, Crypt K (Hash X) \<rbrace>"

definition
 (* Signature Only = signed Digest Only *)
  signOnly :: "[key, msg]\<Rightarrow>msg"
  where "signOnly K X = Crypt K (Hash X)"

definition
 (* Signature for Certificates = Message + signed Message *)
  signCert :: "[key, msg]\<Rightarrow>msg"
  where "signCert K X = \<lbrace>X, Crypt K X \<rbrace>"

definition
 (* Certification Authority's Certificate.
    Contains agent name, a key, a number specifying the key's target use,
              a key to sign the entire certificate.

    Should prove if signK=priSK RCA and C=CA i,
                  then Ka=pubEK i or pubSK i depending on T  ??
 *)
  cert :: "[agent, key, msg, key] \<Rightarrow> msg"
  where "cert A Ka T signK = signCert signK \<lbrace>Agent A, Key Ka, T\<rbrace>"

definition
 (* Cardholder's Certificate.
    Contains a PAN, the certified key Ka, the PANSecret PS,
    a number specifying the target use for Ka, the signing key signK.
 *)
  certC :: "[nat, key, nat, msg, key] \<Rightarrow> msg"
  where "certC PAN Ka PS T signK =
    signCert signK \<lbrace>Hash \<lbrace>Nonce PS, Pan PAN\<rbrace>, Key Ka, T\<rbrace>"

(*cert and certA have no repeated elements, so they could be abbreviations,
  but that's tricky and makes proofs slower*)

abbreviation "onlyEnc == Number 0"
abbreviation "onlySig == Number (Suc 0)"
abbreviation "authCode == Number (Suc (Suc 0))"

subsection\<open>Encryption Primitives\<close>

definition EXcrypt :: "[key,key,msg,msg] \<Rightarrow> msg" where
  \<comment> \<open>Extra Encryption\<close>
    (*K: the symmetric key   EK: the public encryption key*)
    "EXcrypt K EK M m =
       \<lbrace>Crypt K \<lbrace>M, Hash m\<rbrace>, Crypt EK \<lbrace>Key K, m\<rbrace>\<rbrace>"

definition EXHcrypt :: "[key,key,msg,msg] \<Rightarrow> msg" where
  \<comment> \<open>Extra Encryption with Hashing\<close>
    (*K: the symmetric key   EK: the public encryption key*)
    "EXHcrypt K EK M m =
       \<lbrace>Crypt K \<lbrace>M, Hash m\<rbrace>, Crypt EK \<lbrace>Key K, m, Hash M\<rbrace>\<rbrace>"

definition Enc :: "[key,key,key,msg] \<Rightarrow> msg" where
  \<comment> \<open>Simple Encapsulation with SIGNATURE\<close>
    (*SK: the sender's signing key
      K: the symmetric key
      EK: the public encryption key*)
    "Enc SK K EK M =
       \<lbrace>Crypt K (sign SK M), Crypt EK (Key K)\<rbrace>"

definition EncB :: "[key,key,key,msg,msg] \<Rightarrow> msg" where
  \<comment> \<open>Encapsulation with Baggage.  Keys as above, and baggage b.\<close>
    "EncB SK K EK M b =
       \<lbrace>Enc SK K EK \<lbrace>M, Hash b\<rbrace>, b\<rbrace>"

subsection\<open>Basic Properties of pubEK, pubSK, priEK and priSK\<close>

lemma publicKey_eq_iff [iff]:
     "(publicKey b A = publicKey b' A') = (b=b' \<and> A=A')"
by (blast dest: injective_publicKey)

lemma privateKey_eq_iff [iff]:
     "(invKey (publicKey b A) = invKey (publicKey b' A')) = (b=b' \<and> A=A')"
by auto

lemma not_symKeys_publicKey [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_privateKey [iff]: "invKey (publicKey b A) \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKeys_invKey_eq [simp]: "K \<in> symKeys \<Longrightarrow> invKey K = K"
by (simp add: symKeys_def)

lemma symKeys_invKey_iff [simp]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

text\<open>Can be slow (or even loop) as a simprule\<close>
lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) \<Longrightarrow> K \<noteq> K'"
by blast

text\<open>These alternatives to \<open>symKeys_neq_imp_neq\<close> don't seem any better
in practice.\<close>
lemma publicKey_neq_symKey: "K \<in> symKeys \<Longrightarrow> publicKey b A \<noteq> K"
by blast

lemma symKey_neq_publicKey: "K \<in> symKeys \<Longrightarrow> K \<noteq> publicKey b A"
by blast

lemma privateKey_neq_symKey: "K \<in> symKeys \<Longrightarrow> invKey (publicKey b A) \<noteq> K"
by blast

lemma symKey_neq_privateKey: "K \<in> symKeys \<Longrightarrow> K \<noteq> invKey (publicKey b A)"
by blast

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by auto

subsection\<open>"Image" Equations That Hold for Injective Functions\<close>

lemma invKey_image_eq [iff]: "(invKey x \<in> invKey`A) = (x\<in>A)"
by auto

text\<open>holds because invKey is injective\<close>
lemma publicKey_image_eq [iff]:
     "(publicKey b A \<in> publicKey c ` AS) = (b=c \<and> A\<in>AS)"
by auto

lemma privateKey_image_eq [iff]:
     "(invKey (publicKey b A) \<in> invKey ` publicKey c ` AS) = (b=c \<and> A\<in>AS)"
by auto

lemma privateKey_notin_image_publicKey [iff]:
     "invKey (publicKey b A) \<notin> publicKey c ` AS"
by auto

lemma publicKey_notin_image_privateKey [iff]:
     "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (simp add: keysFor_def)
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

text\<open>for proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X H));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts H) | Key (invKey K) \<in> parts H"
by (force dest!:
         parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
         analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
            intro: analz_into_parts)

lemma Crypt_imp_keysFor [intro]:
     "[|K \<in> symKeys; Crypt K X \<in> H|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text\<open>Agents see their own private keys!\<close>
lemma privateKey_in_initStateCA [iff]:
     "Key (invKey (publicKey b A)) \<in> initState A"
by (case_tac "A", auto)

text\<open>Agents see their own public keys!\<close>
lemma publicKey_in_initStateCA [iff]: "Key (publicKey b A) \<in> initState A"
by (case_tac "A", auto)

text\<open>RCA sees CAs' public keys!\<close>
lemma pubK_CA_in_initState_RCA [iff]:
     "Key (publicKey b (CA i)) \<in> initState RCA"
by auto

text\<open>Spy knows all public keys\<close>
lemma knows_Spy_pubEK_i [iff]: "Key (publicKey b A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all add: imageI knows_Cons split: event.split)
done

declare knows_Spy_pubEK_i [THEN analz.Inj, iff]
                            (*needed????*)

text\<open>Spy sees private keys of bad agents! [and obviously public keys too]\<close>
lemma knows_Spy_bad_privateKey [intro!]:
     "A \<in> bad \<Longrightarrow> Key (invKey (publicKey b A)) \<in> knows Spy evs"
by (rule initState_subset_knows [THEN subsetD], simp)

subsection\<open>Fresh Nonces for Possibility Theorems\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

text\<open>In any trace, there is an upper bound N on the greatest nonce in use.\<close>
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all add: used_Cons split: event.split, safe)
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection\<open>Specialized Methods for Possibility Theorems\<close>

ML
\<open>
(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt delsimps [@{thm used_Says}, @{thm used_Notes}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as SET_CR!), where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))
\<close>

method_setup possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o possibility_tac)\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o basic_possibility_tac)\<close>
    "for proving possibility theorems"

subsection\<open>Specialized Rewriting for Theorems About \<^term>\<open>analz\<close> and Image\<close>

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image:
     "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

text\<open>Needed for \<open>DK_fresh_not_KeyCryptKey\<close>\<close>
lemma publicKey_in_used [iff]: "Key (publicKey b A) \<in> used evs"
by auto

lemma privateKey_in_used [iff]: "Key (invKey (publicKey b A)) \<in> used evs"
by (blast intro!: initState_into_used)

text\<open>Reverse the normal simplification of "image" to build up (not break down)
  the set of keys.  Based on \<open>analz_image_freshK_ss\<close>, but simpler.\<close>
lemmas analz_image_keys_simps =
       simp_thms mem_simps \<comment> \<open>these two allow its use with \<open>only:\<close>\<close>
       image_insert [THEN sym] image_Un [THEN sym]
       rangeI symKeys_neq_imp_neq
       insert_Key_singleton insert_Key_image Un_assoc [THEN sym]

(*General lemmas proved by Larry*)

subsection\<open>Controlled Unfolding of Abbreviations\<close>

text\<open>A set is expanded only if a relation is applied to it\<close>
lemma def_abbrev_simp_relation:
     "A = B \<Longrightarrow> (A \<in> X) = (B \<in> X) \<and>
                 (u = A) = (u = B) \<and>
                 (A = u) = (B = u)"
by auto

text\<open>A set is expanded only if one of the given functions is applied to it\<close>
lemma def_abbrev_simp_function:
     "A = B
      \<Longrightarrow> parts (insert A X) = parts (insert B X) \<and>
          analz (insert A X) = analz (insert B X) \<and>
          keysFor (insert A X) = keysFor (insert B X)"
by auto

subsubsection\<open>Special Simplification Rules for \<^term>\<open>signCert\<close>\<close>

text\<open>Avoids duplicating X and its components!\<close>
lemma parts_insert_signCert:
     "parts (insert (signCert K X) H) =
      insert \<lbrace>X, Crypt K X\<rbrace> (parts (insert (Crypt K X) H))"
by (simp add: signCert_def insert_commute [of X])

text\<open>Avoids a case split! [X is always available]\<close>
lemma analz_insert_signCert:
     "analz (insert (signCert K X) H) =
      insert \<lbrace>X, Crypt K X\<rbrace> (insert (Crypt K X) (analz (insert X H)))"
by (simp add: signCert_def insert_commute [of X])

lemma keysFor_insert_signCert: "keysFor (insert (signCert K X) H) = keysFor H"
by (simp add: signCert_def)

text\<open>Controlled rewrite rules for \<^term>\<open>signCert\<close>, just the definitions
  of the others. Encryption primitives are just expanded, despite their huge
  redundancy!\<close>
lemmas abbrev_simps [simp] =
    parts_insert_signCert analz_insert_signCert keysFor_insert_signCert
    sign_def     [THEN def_abbrev_simp_relation]
    sign_def     [THEN def_abbrev_simp_function]
    signCert_def [THEN def_abbrev_simp_relation]
    signCert_def [THEN def_abbrev_simp_function]
    certC_def    [THEN def_abbrev_simp_relation]
    certC_def    [THEN def_abbrev_simp_function]
    cert_def     [THEN def_abbrev_simp_relation]
    cert_def     [THEN def_abbrev_simp_function]
    EXcrypt_def  [THEN def_abbrev_simp_relation]
    EXcrypt_def  [THEN def_abbrev_simp_function]
    EXHcrypt_def [THEN def_abbrev_simp_relation]
    EXHcrypt_def [THEN def_abbrev_simp_function]
    Enc_def      [THEN def_abbrev_simp_relation]
    Enc_def      [THEN def_abbrev_simp_function]
    EncB_def     [THEN def_abbrev_simp_relation]
    EncB_def     [THEN def_abbrev_simp_function]

subsubsection\<open>Elimination Rules for Controlled Rewriting\<close>

lemma Enc_partsE:
     "!!R. [|Enc SK K EK M \<in> parts H;
             [|Crypt K (sign SK M) \<in> parts H;
               Crypt EK (Key K) \<in> parts H|] ==> R|]
           ==> R"

by (unfold Enc_def, blast)

lemma EncB_partsE:
     "!!R. [|EncB SK K EK M b \<in> parts H;
             [|Crypt K (sign SK \<lbrace>M, Hash b\<rbrace>) \<in> parts H;
               Crypt EK (Key K) \<in> parts H;
               b \<in> parts H|] ==> R|]
           ==> R"
by (unfold EncB_def Enc_def, blast)

lemma EXcrypt_partsE:
     "!!R. [|EXcrypt K EK M m \<in> parts H;
             [|Crypt K \<lbrace>M, Hash m\<rbrace> \<in> parts H;
               Crypt EK \<lbrace>Key K, m\<rbrace> \<in> parts H|] ==> R|]
           ==> R"
by (unfold EXcrypt_def, blast)

subsection\<open>Lemmas to Simplify Expressions Involving \<^term>\<open>analz\<close>\<close>

lemma analz_knows_absorb:
     "Key K \<in> analz (knows Spy evs)
      ==> analz (Key ` (insert K H) \<union> knows Spy evs) =
          analz (Key ` H \<union> knows Spy evs)"
by (simp add: analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD])

lemma analz_knows_absorb2:
     "Key K \<in> analz (knows Spy evs)
      ==> analz (Key ` (insert X (insert K H)) \<union> knows Spy evs) =
          analz (Key ` (insert X H) \<union> knows Spy evs)"
apply (subst insert_commute)
apply (erule analz_knows_absorb)
done

lemma analz_insert_subset_eq:
     "[|X \<in> analz (knows Spy evs);  knows Spy evs \<subseteq> H|]
      ==> analz (insert X H) = analz H"
apply (rule analz_insert_eq)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])
done

lemmas analz_insert_simps =
         analz_insert_subset_eq Un_upper2
         subset_insertI [THEN [2] subset_trans]

subsection\<open>Freshness Lemmas\<close>

lemma in_parts_Says_imp_used:
     "[|Key K \<in> parts {X}; Says A B X \<in> set evs|] ==> Key K \<in> used evs"
by (blast intro: parts_trans dest!: Says_imp_knows_Spy [THEN parts.Inj])

text\<open>A useful rewrite rule with \<^term>\<open>analz_image_keys_simps\<close>\<close>
lemma Crypt_notin_image_Key: "Crypt K X \<notin> Key ` KK"
by auto

lemma fresh_notin_analz_knows_Spy:
     "Key K \<notin> used evs \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (auto dest: analz_into_parts)

end


theory "necessity_of_"
  imports Main "../QML"
begin

axiomatization where refl :"(\<forall>x. x r x)"
axiomatization where symm : "(\<forall>x y. x r y \<longrightarrow> y r x)"
axiomatization where transitive :"(\<forall>x y z. ((x r y) \<and> (y r z) \<longrightarrow> (x r z)))"
axiomatization where euclidean :"(\<forall>x y z. ((x r y) \<and> (x r z) \<longrightarrow> (y r z)))"

consts makeTable ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("T")

lemma
  assumes compossibilty1: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))))\<rfloor>"
  assumes origin_uniqueness: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))))\<rfloor>"
  assumes sufficiency1: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<diamond>(T x' y) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x y) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx')))\<rfloor>"
  shows independence: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>z. T x y \<^bold>\<rightarrow> \<^bold>\<box>(((\<^bold>\<not>(y\<^bold>=\<^sup>Lz)) \<^bold>\<and> T x' z) \<^bold>\<rightarrow> \<^bold>\<diamond>(T x y \<^bold>\<and> T x' z)))\<rfloor>"
  oops

lemma necessity_of_distinctness_leib: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>=\<^sup>L y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>=\<^sup>L y))\<rfloor>"
  by auto

lemma necessity_of_identity_leib: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. ((x \<^bold>=\<^sup>L y)) \<^bold>\<rightarrow> \<^bold>\<box>((x \<^bold>=\<^sup>L y))\<rfloor>"
  by auto

lemma
  assumes indiscernibility_of_identicals: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)\<rfloor>"
  shows necessity_of_identity: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)\<rfloor>"
proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
    proof (rule allI)
      fix y
      show "((x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
      proof (rule impI)
        assume "(x \<^bold>\<leftrightarrow> y) w"
        show "(\<^bold>\<box>(x \<^bold>\<leftrightarrow> y)) w"
        proof (rule allI)
          fix v
          show "w r v \<longrightarrow> ((x \<^bold>\<leftrightarrow> y) v)"
          proof (rule impI)
            assume "w r v"
            show "(x \<^bold>\<leftrightarrow> y) v"
            proof(rule iffI)
              from indiscernibility_of_identicals have "(\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v"..
              then have "(\<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "((x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "(x \<^bold>\<leftrightarrow> y) v" by (rule conjE)
              then show "(y v \<Longrightarrow> x v)" by simp
            next  (* show "(x v \<Longrightarrow> y v)" using `(x \<^bold>\<leftrightarrow> y) v` by simp *)
              from indiscernibility_of_identicals have "(\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v"..
              then have "(\<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "((x \<^bold>\<leftrightarrow> y) \<^bold>\<and> (\<^bold>\<forall>F. F x \<^bold>\<rightarrow> F y)) v" by (rule allE)
              then have "(x \<^bold>\<leftrightarrow> y) v" by (rule conjE)
              then show "(x v \<Longrightarrow> y v)" by simp
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma
  assumes necessity_of_identity: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. (x \<^bold>\<leftrightarrow> y) \<^bold>\<rightarrow> \<^bold>\<box>(x \<^bold>\<leftrightarrow> y)\<rfloor>"
  shows necessity_of_distinctness: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))\<rfloor>"
proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
      proof (rule impI)
        assume possibility: "(\<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w"
        show "\<^bold>\<box>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) w"
        proof (rule allI)
          fix v
          show "w r v \<longrightarrow> ((\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) v)"
          proof (rule impI)
            assume "w r v"
            show "(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y)) v"
            proof (rule notI)
              assume "((x \<^bold>\<leftrightarrow> y)) v"

              from possibility have "(\<^bold>\<diamond>(\<^bold>\<not>(x \<^bold>\<leftrightarrow> y))) w" by simp
              then have "\<^bold>\<not>(x \<^bold>\<leftrightarrow> y) v"
                by (smt `w r v` local.necessity_of_identity symm)
              then show "False" using `(x \<^bold>\<leftrightarrow> y) v` by (rule notE)
            qed
          qed
        qed
      qed
    qed
  qed
qed

end