theory take
imports Main

begin

lemma lemma_ai [thy_expl]: "prop_57.take x3 Nil2 = Nil2"
by (hipster_induct_schemes prop_57.take.simps)

lemma lemma_aj [thy_expl]: "prop_57.take x3 (prop_57.take x3 y3) = prop_57.take x3 y3"
by (hipster_induct_schemes prop_57.take.simps)

lemma lemma_ak [thy_expl]: "prop_57.take (S x3) (prop_57.take x3 y3) = prop_57.take x3 y3"
by (hipster_induct_schemes prop_57.take.simps)

lemma unknown [thy_expl]: "prop_57.take x (prop_57.take y z) = prop_57.take y (prop_57.take x z)"
oops

end


theory MyTheory
imports Complex_Main (* Main https://isabelle.in.tum.de/library/HOL/HOL/Main.html *)
begin
(* https://isabelle.in.tum.de/dist/Isabelle2019/doc/main.pdf *)
datatype mytype = Here | There

fun flippo :: "mytype \<Rightarrow> mytype" where
"flippo Here = There" |
"flippo There = Here"

lemma flipflop [simp] : "flippo (flippo x) = x"
  apply(induction)
  apply(auto)
done

text "markup you can write stuff"

lemma add_comm : "(x :: nat) + y = y + x"
  apply(auto)
  done

value "(1 :: nat) + 1"
value "(1 :: real) + 1"

type_synonym foo = "mytype"

value "[ 1 , 2 , 3 ] :: nat list"
value "True :: bool"
value "True | False"
value "True & False"
value "~ True"
value "fst (True,False)"
value "Some True :: bool option"
value "None :: nat option"
value "if True then 1 else 2 :: nat"
value "append [x,y] [z]"
value "Nil :: nat list"
value "hd [True,False]"
value "tl [True,False]"
value "length []"
value "Suc 0"
value "[1 .. 10]"
value "[2 * x . x <- [1 .. 10] ]"
value "(1 :: nat) \<le> 10"
value "() :: unit" (* https://isabelle.in.tum.de/dist/library/HOL/HOL/Product_Type.html *)
value "\<lambda> x. Suc x" (* lmabda functions *)
value "%x. Suc x"
value "(%x. Suc x) 3"
value "{} :: unit set" (* sets *)
value "{1,2,3,4} :: nat set"
value "real 3"
value "sum {1 .. (10 :: nat)}"

(* value "fn x  x"
value "{e . LAM e. e \<le> 10 }"
*)

(* \<forall> *)

(* Lists https://isabelle.in.tum.de/dist/library/HOL/HOL/List.html  *)
(*   *)
fun sumn :: "nat \<Rightarrow> nat" where
"sumn (Suc n) = (Suc n) + (sumn n)" |
"sumn 0 = 0"

lemma summer : "2 * (sumn n) = (n + 1) * n"
  apply(induction n)
  apply(auto)
  done

fun mynot :: "bool \<Rightarrow> bool" where
"mynot b = b"

lemma add_comm : "x + y = y + x"

end


section "Lemmas about the While language"

theory WhileLangLemmas imports WhileLang Coinductive.Coinductive_List_Prefix begin

lemma NRC_step_deterministic:
  "star_n step n x y \<Longrightarrow> star_n step n x z \<Longrightarrow> y = z"
proof (induct rule: star_n.induct)
  case (refl_n x)
  then show ?case
    apply -
    by (erule star_n.cases; simp)
next
  case (step_n x y n z)
  then show ?case
    apply (rotate_tac 3)
    apply (erule star_n.cases, simp)
    apply simp
    apply (drule (1) step_deterministic)
    by simp
qed

inductive exec where
  exec_skip:   "exec s Skip s"
| exec_assign: "exec s (Assign n x) (subst n x s)"
| exec_print:  "exec s (Print x) (print x s)"
| exec_seq:    "exec s0 p s1 \<Longrightarrow> exec s1 q s2 \<Longrightarrow>  exec s0 (Seq p q) s2"
| exec_if:     "exec s (if guard x s then p else q) s1 \<Longrightarrow> exec s (If x p q) s1"
| exec_while1: "\<not>guard x s \<Longrightarrow> exec s (While x p) s"
| exec_while2: "guard x s \<Longrightarrow> exec s p s1 \<Longrightarrow> exec s1 (While x p) s2
       \<Longrightarrow> exec s (While x p) s2"

declare exec.intros[intro!]

lemma NRC_step[simp]:
  "star_n step n (Skip,s) (Skip,t) \<Longrightarrow> s = t"
  by (induct n "(Skip, s)" "(Skip, t)" arbitrary: s t rule: star_n.induct; clarsimp)

lemma terminates_Skip:
  "terminates s Skip t \<longleftrightarrow> s = t"
  by (fastforce simp: terminates.simps star_eq_star_n)

lemma NRC_assign[simp]:
  "star_n step n (Assign n' x,s) (Skip, t) \<Longrightarrow> t = subst n' x s"
  by (induct n "(Assign n' x,s)" "(Skip, t)" arbitrary: n' x s t rule: star_n.induct)
     (fastforce dest: NRC_step)

lemma terminates_Assign:
  "terminates s (Assign n x) t \<longleftrightarrow> t = subst n x s"
  by (fastforce simp: terminates.simps star_eq_star_n)

lemma NRC_print[simp]:
  "star_n step n (Print x,s) (Skip, t) \<Longrightarrow> t = print x s"
  by (induct n "(Print x,s)" "(Skip, t)" arbitrary: x s t rule: star_n.induct)
     (fastforce dest: NRC_step)

lemma terminates_Print:
  "terminates s (Print x) t \<longleftrightarrow> t = print x s"
  by (fastforce simp: terminates.simps star_eq_star_n)

lemma terminates_If:
  "terminates s (If x p q) t \<longleftrightarrow> terminates s (if guard x s then p else q) t"
proof -
  have NRC_if1:
    "star_n step n (prog.If x p q, s) (Skip, t) \<Longrightarrow>
         \<exists>n. star_n step n (if guard x s then p else q, s) (Skip, t)" for n
    by (induct n "(If x p q,s)" "(Skip, t)" arbitrary: x p q s t rule: star_n.induct)
      fastforce
  have NRC_if2:
    "star_n step n (if guard x s then p else q, s) (Skip, t) \<Longrightarrow>
         \<exists>n. star_n step n (prog.If x p q, s) (Skip, t)" for n
  proof (induct n "(if guard x s then p else q, s)" "(Skip, t)"
                arbitrary: x p q s t rule: star_n.induct)
    case refl_n
    then show ?case by (fastforce split: if_split_asm)
  next
    case (step_n y n)
    then show ?case by (fastforce split: if_split_asm)
  qed
  show ?thesis
    by (fastforce dest: NRC_if1 NRC_if2 simp: star_eq_star_n terminates.simps)
qed

lemma terminates_While:
  "terminates s (While f c) t \<longleftrightarrow> terminates s (If f (Seq c (While f c)) Skip) t"
proof -
  have NRC_while1:
    "star_n step n (While f c, s) (Skip, t) \<Longrightarrow>
         \<exists>n. star_n step n (prog.If f (Seq c (While f c)) Skip, s) (Skip, t)" for n
    by (induct n "(While f c,s)" "(Skip, t)" arbitrary: f c s t rule: star_n.induct)
      fastforce

  have NRC_while2:
    "star_n step n (prog.If f (Seq c (While f c)) Skip, s) (Skip, t) \<Longrightarrow>
         \<exists>n. star_n step n (While f c, s) (Skip, t)" for n
    by (induct n "(If f (Seq c (While f c)) Skip, s)" "(Skip, t)"
        arbitrary: f c s t rule: star_n.induct)
      fastforce
  show ?thesis
    by (fastforce dest: NRC_while1 NRC_while2 simp: star_eq_star_n terminates.simps)
qed

definition real_step where
  "real_step \<equiv> \<lambda>(p, s) qt. p \<noteq> Skip \<and> step (p,s) qt"

lemma terminates:
  "terminates s p t \<longleftrightarrow> star real_step (p,s) (Skip,t)"
proof -
  have P1: "star_n step n (p, s) (Skip, t) \<Longrightarrow>
            \<exists>n. star_n (\<lambda>(p, s) qt. p \<noteq> Skip \<and> step (p, s) qt) n (p, s) (Skip, t)" for n
  proof (induct n "(p, s)" "(Skip, t)" arbitrary: p s t rule: star_n.induct)
    case refl_n
    then show ?case by fastforce
  next
    case (step_n y n)
    then show ?case
      apply (drule_tac x="fst y" and y="snd y" in meta_spec2)
      apply simp
      by blast
  qed
  have P2: "star_n (\<lambda>(p, s) qt. p \<noteq> Skip \<and> step (p, s) qt) n (p, s) (Skip, t) \<Longrightarrow>
            \<exists>n. star_n step n (p, s) (Skip, t)" for n
    by (induct n "(p, s)" "(Skip, t)" arbitrary: p s t rule: star_n.induct) fastforce+
  show ?thesis
    by (fastforce dest: P1 P2 simp: real_step_def star_eq_star_n terminates.simps)
qed

lemma NRC_real_step_Skip[simp]:
  "star_n real_step n (Skip,s) (Skip,t) \<longleftrightarrow> n = 0 \<and> s = t"
  apply (rule iffI; simp?)
  by (induct n "(Skip, s)" "(Skip, t)" arbitrary: s t rule: star_n.induct)
     (simp add: real_step_def)+

lemma NRC_real_step_not_Skip:
  "p \<noteq> Skip \<Longrightarrow>
  (star_n real_step n (p,s) (Skip,t) \<longleftrightarrow>
   (\<exists>k m. real_step (p,s) m \<and> star_n real_step k m (Skip,t) \<and> n = k + 1))"
  apply (rule iffI; rotate_tac)
  by (induct n "(p, s)" "(Skip, t)" arbitrary: p s t rule: star_n.induct, simp)
     fastforce+

lemma real_step_seqE:
  "real_step (Seq p q, s) x \<Longrightarrow>
    (x = (q, s) \<Longrightarrow> p = Skip \<Longrightarrow> P) \<Longrightarrow>
    (\<And>p' s'. x = (Seq p' q, s') \<Longrightarrow>  real_step (p, s) (p', s') \<Longrightarrow> p \<noteq> Skip \<Longrightarrow> P)
       \<Longrightarrow> P"
  by (clarsimp simp: real_step_def) (erule seqE; clarsimp)

lemma real_steps_Seq:
  "star_n real_step n (Seq p q,s) (Skip,t) \<longleftrightarrow>
    (\<exists>n1 n2 m.
      star_n real_step n1 (p,s) (Skip,m) \<and>
      star_n real_step n2 (q,m) (Skip,t) \<and> n = n1 + n2 + 1)"
proof
  assume H: "star_n real_step n (Seq p q, s) (Skip, t)"
  show "\<exists>n1 n2 m.
        star_n real_step n1 (p, s) (Skip, m) \<and>
        star_n real_step n2 (q, m) (Skip, t) \<and> n = n1 + n2 + 1" using H
  proof (induct n "(Seq p q,s)" "(Skip,t)" arbitrary: p q s t rule: star_n.induct)
    fix y n p q s t
    assume P1: "real_step (Seq p q, s) y"
      and P2: "star_n real_step n y (Skip, t)"
      and IH: "\<And>p q s. y = (Seq p q, s) \<Longrightarrow>
          (\<exists>n1 n2 r. star_n real_step n1 (p, s) (Skip, r) \<and>
                     star_n real_step n2 (q, r) (Skip, t) \<and>
                     n = n1 + n2 + 1)"
    then show "\<exists>n1 n2 r. star_n real_step n1 (p, s) (Skip, r) \<and>
           star_n real_step n2 (q, r) (Skip, t) \<and> Suc n = n1 + n2 + 1"
      by (fastforce elim!: real_step_seqE)
  qed
next
  assume H: "\<exists>n1 n2 m.
       star_n real_step n1 (p, s) (Skip, m) \<and>
       star_n real_step n2 (q, m) (Skip, t) \<and> n = n1 + n2 + 1"
  show "star_n real_step n (Seq p q, s) (Skip, t)"
    using H
    apply -
    apply (case_tac "p=Skip", clarsimp)
     apply (rule step_n[rotated], simp)
     apply (clarsimp simp: real_step_def)
    apply (elim exE conjE)
  proof -
    have H: "star_n real_step n1 (p, s) (Skip, m) \<Longrightarrow>
             star_n real_step n2 (q, m) (Skip, t) \<Longrightarrow>
             p \<noteq> Skip \<Longrightarrow>
             star_n real_step (n1 + n2 + 1) (Seq p q, s) (Skip, t)" for n1 n2 m
      apply (induct n1 "(p, s)" "(Skip, m)" arbitrary: s p m rule: star_n.induct)
       apply (clarsimp simp: real_step_def)
      apply (rename_tac y n s p m)
      apply (subgoal_tac "real_step (Seq p q, s) (Seq (fst y) q, snd y)")
       prefer 2
       apply (clarsimp simp: real_step_def)
      apply (case_tac "fst y = Skip")
       apply (subgoal_tac "\<And>a b. fst a = b \<Longrightarrow> (\<exists>c. a = (b, c) \<and> c = snd a)")
        prefer 2
        apply clarsimp
       apply (drule_tac x="y" and y="Skip" in meta_spec2)
       apply (drule (1) meta_mp)
       apply (elim exE conjE)
       apply (rename_tac c)
       apply (thin_tac "c = snd y")
       apply simp
       apply (erule step_n)
       apply (rule step_n[rotated])
        apply simp
       apply (clarsimp simp: real_step_def)
      apply clarsimp
      done
    thus "\<And>n1 n2 m.
          p \<noteq> Skip \<Longrightarrow>
          star_n real_step n1 (p, s) (Skip, m) \<Longrightarrow>
          star_n real_step n2 (q, m) (Skip, t) \<Longrightarrow>
          n = n1 + n2 + 1 \<Longrightarrow>
          star_n real_step n (Seq p q, s) (Skip, t)" by blast
  qed
qed

lemma terminates_Seq:
  "terminates s (Seq p q) t \<longleftrightarrow> (\<exists>m. terminates s p m \<and> terminates m q t)"
  by (fastforce simp: terminates star_eq_star_n real_steps_Seq)

lemma terminates_eq_exec:
  "terminates s p t \<longleftrightarrow> exec s p t"
proof -
  have P1: "star_n real_step n (p, s) (Skip, t) \<Longrightarrow> exec s p t" for n
  proof (induct n arbitrary: p s t rule: nat_less_induct)
    case (1 n)
    then show ?case
      apply -
      apply (case_tac p; clarsimp)
          apply (erule star_n.cases;
                 clarsimp simp: real_step_def NRC_real_step_Skip[simplified real_step_def])
          apply (drule sym[where s="subst _ _ _"], clarsimp)
         apply (erule star_n.cases;
                clarsimp simp: real_step_def NRC_real_step_Skip[simplified real_step_def])
         apply (drule sym[where s="print _ _"], clarsimp)
        apply (clarsimp simp: real_steps_Seq)
        apply (metis "1.hyps" exec_seq less_add_Suc1 less_add_Suc2)
       apply (erule star_n.cases;
              clarsimp simp: real_step_def NRC_real_step_Skip[simplified real_step_def]
                       split: if_split_asm)
        apply fastforce
       apply fastforce
      apply (erule star_n.cases; clarsimp simp: real_step_def)
      apply (erule whileE, clarsimp)
      apply (erule star_n.cases;
             clarsimp split: if_split_asm simp: NRC_real_step_Skip[simplified real_step_def])
       defer
       apply fastforce
      apply (clarsimp simp: real_steps_Seq[simplified real_step_def])
      by (meson exec_while2 less_SucI less_add_Suc1 less_add_Suc2)
  qed
  then have P1': "terminates s p t \<Longrightarrow> exec s p t"
    by (clarsimp simp: terminates star_eq_star_n)
  have P2: "exec s p t \<Longrightarrow> terminates s p t"
  proof (induct s p t rule: exec.induct; clarsimp)
    case (exec_skip s)
    then show ?case by (clarsimp simp: terminates_Skip)
  next
    case (exec_assign s n x)
    then show ?case by (clarsimp simp: terminates_Assign)
  next
    case (exec_print s x)
    then show ?case by (clarsimp simp: terminates_Print)
  next
    case (exec_seq s0 p s1 q s2)
    then show ?case by (cases s1; fastforce simp: terminates_Seq)
  next
    case (exec_if s x p q s1)
    then show ?case by (cases s1; fastforce simp: terminates_If)
  next
    case (exec_while1 x s p)
    then show ?case by (clarsimp simp: terminates_While terminates_If terminates_Skip)
  next
    case (exec_while2 x s p s1 s2)
    then show ?case
      apply (simp (no_asm) add: terminates_While terminates_If terminates_Skip)
      by (cases s1; fastforce simp: terminates_Seq)
  qed
  show ?thesis using P1' P2 by auto
qed

lemma terminates_While_NRC:
  assumes "terminates m p t"
  assumes "p = While f c"
  shows "\<exists>n. star_n (\<lambda>s t. guard f s \<and> terminates s c t) n m t \<and> \<not>guard f t"
  using assms
  apply (simp add: terminates_eq_exec)
  by (induct m "While f c" t arbitrary: f c rule: exec.induct; clarsimp; fastforce)

lemma not_diverges[simp]:
  "~diverges s Skip l"
  "~diverges s (Assign n x) l"
  "~diverges s (Print x) l"
  by (clarsimp simp: diverges.simps terminates_Skip terminates_Assign terminates_Print;
      metis surj_pair)+

lemma star_n_Skip:
  "star_n step n (Skip, s) (c', t) \<Longrightarrow> c' = Skip \<and> t = s"
  apply (induct n)
   apply (erule star_n.cases; clarsimp)+
  done

lemma star_n_Seq:
  "star_n step n (c, s) (c', t) \<Longrightarrow>
         \<exists>n. star_n step n (Seq c p, s) (Seq c' p, t) "
  apply (case_tac "c=Skip")
   apply (fastforce dest!: star_n_Skip)
  apply (induct n arbitrary: c s)
   apply (erule star_n.cases; simp; rename_tac x; case_tac x; rule_tac x=0 in exI, clarsimp)
  apply (erule star_n.cases, simp)
  apply (rename_tac y na z)
  apply (drule_tac x="fst y" and y="snd y" in meta_spec2)
  apply clarsimp
  apply (rename_tac ac ad bb na af bc)
  apply (case_tac "ac=Skip", simp)
   apply (fastforce dest!: star_n_Skip)
  apply clarsimp
  apply fastforce
  done

lemma RTC_Seq:
  "star step (c,s) (c',t) \<Longrightarrow>
   star step (Seq c p, s) (Seq c' p,t)"
  apply (clarsimp simp: star_eq_star_n star_n_Seq)
  done

lemma step_output_mono:
  "step s t \<Longrightarrow> prefix (output_of (snd s)) (output_of (snd t))"
  by (induct rule: step.induct; simp add: subst_def print_def split_def output_of_def)

lemma NRC_step_output_mono:
  "star_n step k (c,s) (c',s') \<Longrightarrow> prefix (output_of s) (output_of s')"
  apply (induct k arbitrary: c s c' s')
  apply (erule star_n.cases; clarsimp)
  apply (erule star_n.cases; clarsimp)
  apply (drule step_output_mono)
  apply fastforce
  done

lemma lprefix_chain_RTC_step':
  "Complete_Partial_Order.chain lprefix {llist_of out | out. (\<exists>q t. step x (q,t,out))}"
  apply (rule chainI)
  apply simp
  apply (elim exE impE conjE)
  by (metis lprefix_down_linear lprefix_llist_ofI prod.inject step_deterministic)

lemma star_n_step_decompose:
  "star_n step n x y \<Longrightarrow> star_n step n' x z \<Longrightarrow> n' < n
    \<Longrightarrow> star_n step (n - n') z y"
  by (fastforce elim!: star_n_decompose step_deterministic NRC_step_deterministic)

lemma lprefix_chain_NRC_step':
  "star_n step n x (q, t, out) \<Longrightarrow>
       star_n step n' x (q', t', out') \<Longrightarrow>
       lprefix (llist_of out) (llist_of out') \<or> lprefix (llist_of out') (llist_of out)"
  apply (insert less_linear[of n n'])
  apply (elim disjE)
    defer 2
    apply (drule (2) star_n_step_decompose,
           metis NRC_step_output_mono internal_case_prod_conv internal_case_prod_def
                 lprefix_llist_of output_of_def)+
  apply simp
  apply (drule (1) NRC_step_deterministic)
  by fastforce

lemma lprefix_chain_NRC_step:
  "Complete_Partial_Order.chain lprefix {llist_of out | out. (\<exists>q t. star_n step n x (q,t,out))}"
  by (rule chainI) (force dest: lprefix_chain_NRC_step')

lemma lprefix_chain_RTC_step:
  "Complete_Partial_Order.chain lprefix {llist_of out | out. (\<exists>q t. star step x (q,t,out))}"
  by (rule chainI) (force dest: lprefix_chain_NRC_step' star_star_n)

lemma lprefix_chain_NRC_step_ex:
  "Complete_Partial_Order.chain lprefix {llist_of out | out. (\<exists>q t n. star_n step n x (q,t,out))}"
  by (subst star_eq_star_n[symmetric]) (rule lprefix_chain_RTC_step)

definition lprefix_rel where
  "lprefix_rel ls ls' \<equiv> \<forall>l \<in> ls. \<exists>l' \<in> ls'. lprefix l l'"

lemma diverges_unique:
  "diverges s p l \<Longrightarrow> \<forall>l'. diverges s p l' \<longrightarrow> l' = l"
  using diverges_deterministic by blast

lemma terminates_unique:
  "terminates s p t \<Longrightarrow> \<forall>t'. terminates s p t' \<longrightarrow> t' = t"
  using terminates_deterministic by blast

(* diverges lemmas *)

lemma star_n_real_step_Seq_exact:
  "star_n real_step n (c, s) (Skip, t) \<Longrightarrow> star_n step n (Seq c c', s) (Seq Skip c', t)"
  by (induct "(c, s)" "(Skip, t)" arbitrary: c s t rule: star_n.induct) (auto simp: real_step_def)

lemma star_n_real_step_Seq_exact':
  "star_n real_step n (c, s) (Skip, t) \<Longrightarrow> star_n real_step n (Seq c c', s) (Seq Skip c', t)"
  by (induct "(c, s)" "(Skip, t)" arbitrary: c s t rule: star_n.induct) (auto simp: real_step_def)

lemma div_Seq1_always_Seq:
  "\<lbrakk> star_n step n (Seq c c', s) (q, s'); c \<noteq> Skip;
     \<forall>a b n. \<not> star_n step n (c, s) (Skip, a, b)\<rbrakk>
         \<Longrightarrow> \<exists>u. q = Seq u c' \<and> u \<noteq> Skip"
proof (induct "(Seq c c', s)" "(q, s')" arbitrary: c c' q s s' rule: star_n.induct)
  case (step_n y n)
  then show ?case
    by cases fastforce+
qed clarsimp

lemma div_Seq1_steps:
  "\<lbrakk>star_n step n (Seq c c', s) (Seq u c', s'); c \<noteq> Skip;
    \<forall>a b n. \<not> star_n step n (c, s) (Skip, a, b)\<rbrakk>
           \<Longrightarrow> star_n step n (c, s) (u, s')"
proof (induct "(Seq c c', s)" "(Seq u c', s')" arbitrary: c c' u s s' rule: star_n.induct)
  case (step_n y n)
  then show ?case by cases fastforce+
qed fastforce

lemma div_Seq1_lSup_eq:
  "\<forall>t. \<not> terminates s c t
    \<Longrightarrow> lSup {llist_of out |out. \<exists>q t. star step (c, s) (q, t, out)} =
        lSup {llist_of out |out. \<exists>q t. star step (Seq c c', s) (q, t, out)}"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
   apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
   apply (clarsimp simp: terminates star_eq_star_n)
   apply (drule star_n_Seq)
   apply fastforce
  apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
  apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
  apply clarsimp
  apply (clarsimp simp: terminates.simps star_eq_star_n)
  apply (frule div_Seq1_always_Seq)
    apply (metis (no_types, opaque_lifting) star_n.simps surj_pair)
   apply simp
  apply (erule star_n.cases, fastforce)
  by (metis (mono_tags, opaque_lifting) div_Seq1_steps prod.collapse refl_n step_n)

lemma star_n_real_step_step:
  "star_n real_step n x y \<Longrightarrow> star_n step n x y"
  by (induct rule: star_n.induct; clarsimp)
     (metis (no_types, lifting) prod.simps(2) real_step_def star_n.simps)

lemma div_Seq2_steps:
  "\<lbrakk> star_n real_step n' (c, s) (Skip, s'); n' < n;
     \<forall>t' n. \<not> star_n real_step n (c', s') (Skip, t');
     star_n step n (Seq c c', s) (q, t, out)\<rbrakk>
         \<Longrightarrow> \<exists>m q t'. star_n step m (c', s') (q, t', out)"
  apply (drule star_n_real_step_Seq_exact[where c'=c'])
  apply (drule (2) star_n_step_decompose)
  apply (erule_tac ?a1.0="n - n'" in star_n.cases)
   apply clarsimp
  apply clarsimp
  apply (erule step.cases; clarsimp)
  apply fastforce
  done

lemma div_Seq2_lSub_eq:
  "\<lbrakk>terminates s c s'; \<forall>t. \<not> terminates s' c' t\<rbrakk>
    \<Longrightarrow> lSup {llist_of out |out. \<exists>q t. star step (Seq c c', s) (q, t, out)} =
        lSup {llist_of out |out. \<exists>q t. star step (c', s') (q, t, out)}"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
   apply clarsimp
   apply (clarsimp simp: terminates star_eq_star_n)
   apply (rename_tac n na)
   apply (cases s; cases s'; simp)
   apply (case_tac "n < na")
    apply (rule chain_lprefix_lSup[OF lprefix_chain_NRC_step_ex])
    apply (drule (1) div_Seq2_steps; fastforce)
   apply (clarsimp simp: not_less)
   apply (drule star_n_real_step_Seq_exact[where c'=c'])
   apply (rename_tac aa ba)
   apply (subgoal_tac "lprefix (llist_of ba)
                        (lSup {llist_of out |out. \<exists>q t n. star_n step n (c', aa, ba) (q, t, out)})")
    prefer 2
    apply (rule chain_lprefix_lSup[OF lprefix_chain_NRC_step_ex])
    apply fastforce
   apply (case_tac "n=na"; simp?)
    apply (drule (1) NRC_step_deterministic)
    apply clarsimp
   apply (drule le_neq_trans, clarsimp, simp)
   apply (frule_tac n=n and n'=na in star_n_step_decompose; simp?)
   apply (drule_tac k="n-na" in NRC_step_output_mono)
   apply (clarsimp simp: output_of_def)
   apply (meson lprefix_llist_of lprefix_trans)
  apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
  apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
  apply (clarsimp simp: terminates star_eq_star_n)
  apply (drule star_n_real_step_Seq_exact[where c'=c'])
  apply (subgoal_tac "step (Seq Skip c', s') (c', s')")
   apply (drule (1) step_n_rev)
   apply (clarsimp dest!: star_n_star simp: star_eq_star_n[symmetric])
   apply (drule (1) star_trans)
   apply fastforce
  apply clarsimp
  done

lemma diverges_Seq:
  "diverges s (Seq c c') l \<longleftrightarrow> diverges s c l \<or> (\<exists>t. terminates s c t \<and> diverges t c' l)"
  apply (rule iffI)
   apply (case_tac "\<exists>t. terminates s c t"; simp)
    prefer 2
    apply (erule diverges.cases)
    apply (rule diverges.intros)
    apply (clarsimp simp: terminates.simps star_eq_star_n)
    apply (metis (no_types, opaque_lifting) div_Seq1_steps div_Seq1_always_Seq refl_n star_n_Seq)
   apply (rule disjI2, clarsimp)
   apply (rename_tac a b)
   apply (rule_tac x=a in exI, rule_tac x=b in exI, clarsimp)
   apply (clarsimp simp: diverges.simps terminates_Seq)
   apply (simp add: terminates_Seq forall_swap4)
   apply (drule_tac x=a and y=b in spec2)
   apply clarsimp
   apply (drule div_Seq2_lSub_eq; fastforce)
  apply (erule disjE)
   apply (rule diverges.intros, clarsimp)
   apply (rule conjI; clarsimp?)
    apply (erule diverges.cases, clarsimp)
    apply (simp add: terminates_Seq)
   apply (fastforce simp: div_Seq1_lSup_eq diverges.simps)
  apply clarsimp
  apply (erule diverges.cases, clarsimp)
  apply (rule diverges.intros, clarsimp)
  apply (rule conjI; clarsimp?)
  using terminates_Seq terminates_deterministic apply blast
  apply (drule div_Seq2_lSub_eq)
  by simp+

lemma div_true_If_lSup_eq:
  "\<lbrakk>\<forall>t. \<not> terminates s p t; guard f s\<rbrakk>
    \<Longrightarrow> lSup {llist_of out |out. \<exists>qa t. star step (prog.If f p q, s) (qa, t, out)} =
        lSup {llist_of out |out. \<exists>q t. star step (p, s) (q, t, out)}"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
   apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
   apply clarsimp
   apply (erule star.cases; fastforce)
  apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
  apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
  apply clarsimp
  apply (subgoal_tac "step (If f p q, s) (if guard f s then p else q, s)")
   apply simp
   apply (drule (1) step[where r=step])
   apply fastforce
  apply (rule step_if)
  done

lemma div_false_If_lSup_Eq:
  "\<lbrakk>\<forall>t. \<not> terminates s q t; \<not> guard f s\<rbrakk>
    \<Longrightarrow> lSup
         {llist_of out |out. \<exists>qa t. star step (prog.If f p q, s) (qa, t, out)} =
        lSup {llist_of out |out. \<exists>q' t. star step (q, s) (q', t, out)}"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
   apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
   apply clarsimp
   apply (erule star.cases; fastforce)
  apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
  apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
  apply clarsimp
  apply (subgoal_tac "step (If f p q, s) (if guard f s then p else q, s)")
   apply simp
   apply (drule (1) step[where r=step])
   apply fastforce
  apply (rule step_if)
  done

lemma diverges_If:
  "diverges s (If f p q) l = diverges s (if guard f s then p else q) l"
  by (fastforce simp: diverges.simps terminates_If
                      div_true_If_lSup_eq div_false_If_lSup_Eq)

lemma While_body_add3real_step:
  "\<lbrakk>star_n real_step n (c, s) (Skip, s'); guard g s\<rbrakk>
   \<Longrightarrow> star_n real_step (n + 3) (While g c, s) (While g c, s')"
  apply (drule star_n_real_step_Seq_exact'[where c'="While g c"])
  apply (subgoal_tac "real_step (Seq Skip (While g c), s') (While g c, s')")
   apply (drule (1) step_n_rev)
   apply (thin_tac "real_step _ _")
   apply (subgoal_tac "real_step (If g (Seq c (While g c)) Skip, s)
                                 (if guard g s then Seq c (While g c) else Skip, s)")
    apply (simp only: if_True)
    apply (drule (1) step_n[rotated])
    apply (thin_tac "real_step _ _")
    apply (subgoal_tac "real_step (While g c, s) (If g (Seq c (While g c)) Skip, s)")
     apply (drule (1) step_n[rotated])
     apply (thin_tac "real_step _ _")
     apply (simp add: numeral_3_eq_3)
    apply (fastforce simp: real_step_def)+
   apply (simp (no_asm) add: real_step_def)
  apply (fastforce simp: real_step_def)
  done

lemmas While_body_add3step = While_body_add3real_step[THEN star_n_real_step_step]

lemma div_body_While_lSup_eq:
  "\<lbrakk>guard g s; \<forall>t. \<not> terminates s c t\<rbrakk>
    \<Longrightarrow> lSup {llist_of out |out. \<exists>q t. star step (c, s) (q, t, out)} =
        lSup {llist_of out |out. \<exists>q t. star step (While g c, s) (q, t, out)}"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
   apply clarsimp
   apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
   apply (clarsimp simp:  star_eq_star_n)
   apply (subgoal_tac "step (If g (Seq c (While g c)) Skip, s)
                                  (if guard g s then (Seq c (While g c)) else Skip, s)")
    prefer 2
    apply (rule step_if)
   apply simp
   apply (subgoal_tac "step (While g c, s) (If g (Seq c (While g c)) Skip, s)")
    prefer 2
    apply (rule step_while)
   apply (drule star_n_Seq[where p="While g c"])
   apply (elim exE)
   apply fastforce
  apply (frule div_Seq1_lSup_eq[where c'="While g c"])
  apply (frule div_true_If_lSup_eq[where p="Seq c (While g c)" and q=Skip, rotated, THEN sym])
   apply (clarsimp simp: terminates_Seq)
  apply simp
  apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
  apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
  apply (clarsimp simp: star_eq_star_n)
  apply (erule star_n.cases)
   apply fastforce
  apply clarsimp
  apply (erule step.cases; simp)
  apply clarsimp
  apply fastforce
  done

lemma inf_loop_While_steps:
  "\<lbrakk> star_n real_step n' (c, s) (Skip, s'); n' + 3 < n; guard g s;
     star_n step n (While g c, s) (q, t, out)\<rbrakk>
         \<Longrightarrow> \<exists>q' t' n. star_n step n (While g c, s') (q', t', out)"
  by(blast dest: While_body_add3step star_n_step_decompose)

lemma inf_loop_While_lSup_eq:
  "\<lbrakk>guard g s; terminates s c (a, b); \<forall>aa ba. \<not> terminates (a, b) (While g c) (aa, ba)\<rbrakk>
           \<Longrightarrow> lSup {llist_of out |out. \<exists>q t. star step (While g c, a, b) (q, t, out)} =
               lSup {llist_of out |out. \<exists>q t. star step (While g c, s) (q, t, out)}"
  apply (rule lprefix_antisym)
   apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
   apply (rule chain_lprefix_lSup[OF lprefix_chain_RTC_step])
   apply clarsimp
   apply (clarsimp simp: terminates star_eq_star_n)
   apply (frule (1) While_body_add3step)
   apply (drule (1) star_n_trans, fastforce)
  apply (rule chain_lSup_lprefix[OF lprefix_chain_RTC_step])
  apply clarsimp
  apply (clarsimp simp: terminates star_eq_star_n)
  apply (rename_tac n na)
  apply (case_tac "n + 3 < na")
   apply (rule chain_lprefix_lSup[OF lprefix_chain_NRC_step_ex])
   apply (fastforce dest!: inf_loop_While_steps)
  apply (clarsimp simp: not_less)
  apply (drule (1) While_body_add3step)
  apply (rule lprefix_trans[of _ "llist_of b"])
   apply clarsimp
   apply (case_tac "na = n + 3"; simp?)
    apply (drule (1) NRC_step_deterministic)
    apply clarsimp
   apply (drule le_neq_trans, clarsimp, simp)
   apply (frule_tac n="n+3" and n'=na in star_n_step_decompose; simp?)
   apply (drule_tac k="n+3-na" in NRC_step_output_mono)
   apply (clarsimp simp: output_of_def)
  apply (rule chain_lprefix_lSup[OF lprefix_chain_NRC_step_ex])
  apply fastforce
  done

lemma diverges_While:
  "diverges s (While g c) l \<longleftrightarrow> diverges s (If g (Seq c (While g c)) Skip) l"
  apply (rule iffI; clarsimp simp: diverges_If diverges_Seq)
   defer
   apply (case_tac "guard g s"; simp)
   apply (clarsimp simp: diverges_Seq)
   apply (erule disjE; clarsimp?)
    apply (clarsimp simp: diverges.simps terminates_While terminates_If terminates_Seq)
    apply (fastforce simp: div_body_While_lSup_eq)
   apply (simp (no_asm) add: diverges.simps terminates_While terminates_If)
   apply clarsimp
   apply (simp only: terminates_Seq del: )
   apply (rule conjI)
    apply (clarsimp, drule (1) terminates_deterministic, clarsimp simp: diverges.simps)
   apply (clarsimp simp: diverges.simps)
   apply (fastforce simp: inf_loop_While_lSup_eq)
  apply (case_tac "guard g s"; simp)
   apply (subgoal_tac "diverges s (While g c) l \<Longrightarrow> guard g s
          \<Longrightarrow> (\<forall>a b. \<not> terminates s (Seq c (While g c)) (a, b))")
    prefer 2
    apply (clarsimp simp: diverges.simps terminates_While terminates_If)
   apply (clarsimp simp: terminates_Seq diverges.simps)
   apply (rule context_conjI)
    prefer 2
    apply (fastforce simp: div_body_While_lSup_eq)
   apply clarsimp
   apply (rename_tac a b)
   apply (simp add: forall_swap4)
   apply (drule_tac x=a and y=b in spec2)
   apply clarsimp
   apply (rotate_tac 2)
   apply (drule_tac x=a and y=b in spec2)
   apply clarsimp
   apply (erule notE)
   apply (fastforce simp: inf_loop_While_lSup_eq)
  apply (clarsimp simp: diverges.simps terminates_While terminates_If)
  apply (clarsimp simp: terminates.simps)
  by (metis star.refl surj_pair)

lemma NRC_terminates:
  assumes "star_n (\<lambda>x y. terminates x c y) i s t"
  shows "\<forall>t1. star_n (\<lambda>x y. terminates x c y) i s t1 \<longleftrightarrow> (t = t1)"
proof -
  have "\<And>a b. star_n (\<lambda>x. terminates x c) i s (a, b) \<Longrightarrow> t = (a, b)" using assms
  proof(induct i arbitrary: s t)
    case 0
    show ?case using 0
      by cases (erule star_n.cases; simp)
  next
    case (Suc i)
    show ?case using Suc.prems
      apply cases
      apply(erule star_n.cases; simp)
      by(blast dest: terminates_deterministic Suc.hyps)
  qed
  thus ?thesis using assms by fastforce
qed

lemma step_output_append:
  "step (c, a, b) (c', a', b') \<Longrightarrow> \<exists>new. b' = b @ new"
  by (induct c arbitrary: c' a a' b; fastforce simp: subst_def print_def dest!: seqE whileE)

lemma step_output_extend':
  "step (c, a, b) (c', a', b @ new) \<Longrightarrow> \<forall>xs. step (c, a, xs) (c', a', xs @ new)"
  apply (induct c arbitrary: c' a a' b)
       apply clarsimp
      apply clarsimp
      apply (rename_tac x1 x2 a a' b xs)
      apply (cases new; simp)
       apply (subgoal_tac "(a', xs) = subst x1 x2 (a, xs)")
        apply clarsimp
       apply (clarsimp simp: subst_def)
      apply (clarsimp simp: subst_def)
     apply clarsimp
     apply (rename_tac x a a' b xs)
     apply (subgoal_tac "(a', xs @ new) = print x (a, xs)")
      apply clarsimp
     apply (clarsimp simp: print_def)
    apply (erule seqE)
     apply fastforce
    apply fastforce
   apply (erule ifE)
   apply (erule Pair_inject)
   apply (erule Pair_inject)
   apply (simp only: append_self_conv append.right_neutral)
   apply (rule allI)
   apply (rename_tac x1 c1 c2 c' a a' b xs)
   apply (subgoal_tac "guard x1 (a, b) = guard x1 (a, xs)")
    prefer 2
    apply (simp add: guard_def)
   apply force
  apply (erule whileE)
  apply (erule Pair_inject)
  apply (erule Pair_inject)
  apply (simp only: append_self_conv append.right_neutral)
  apply (rule allI)
  apply (rename_tac x1 c c' a a' b xs)
  apply (subgoal_tac "guard x1 (a, b) = guard x1 (a, xs)")
   prefer 2
   apply (simp add: guard_def)
  apply force
  done

lemma step_output_extend:
  "step (c, a, b) (c', a', b') \<Longrightarrow> \<exists>new. b' = b @ new \<and> (\<forall>xs. step (c, a, xs) (c', a', xs @ new))"
  by (metis step_output_append step_output_extend')

lemma star_n_real_step_output_extend:
  "star_n real_step n (c, s) (Skip, t) \<Longrightarrow>
         \<exists>new. snd t = snd s @ new \<and>
               (\<forall>xs. \<exists>n. star_n real_step n (c, fst s, xs)
                          (Skip, fst t, xs @ new)) "
  apply (induct n arbitrary: c s t)
   apply (erule star_n.cases; fastforce)
  apply clarsimp
  apply (erule star_n.cases; simp)
  apply clarsimp
  apply (rename_tac c a b c' a0 b0 n a' b')
  apply (drule_tac x=c' in meta_spec)
  apply (drule_tac x=a0 and y=b0 in meta_spec2)
  apply (drule_tac x=a' and y=b' in meta_spec2)
  apply clarsimp
  apply (subgoal_tac "c \<noteq> Skip \<and> step (c, a, b) (c', a0, b0)")
   prefer 2
   apply (clarsimp simp: real_step_def)
  apply clarsimp
  apply (drule step_output_extend)
  apply clarsimp
  apply (rotate_tac -1)
  apply (rename_tac new newa xs)
  apply (drule_tac x=xs in spec)
  apply (drule_tac x="xs@newa" in spec)
  apply clarsimp
  apply (thin_tac "real_step _ _")
  apply (subgoal_tac "real_step (c, a, xs) (c', a0, xs @ newa)")
   prefer 2
   apply (clarsimp simp: real_step_def)
  apply (rename_tac na)
  apply (rule_tac x="Suc na" in exI)
  apply fastforce
  done

lemma terminates_history:
  "terminates s c t \<Longrightarrow>
      \<exists>new. snd t = snd s @ new \<and>
            (\<forall>xs. terminates (fst s,xs) c (fst t,xs @ new))"
  apply (clarsimp simp: terminates star_eq_star_n)
  using star_n_real_step_output_extend by auto

lemma terminates_ignores_history:
  "terminates (s, out1) c (t, out2) \<Longrightarrow>
  terminates (s, []) c (t, drop (length out1) out2)"
  by (metis append.simps(1) append_eq_conv_conj prod.sel(1) prod.sel(2) terminates_history)

end


(*  Title:      ZF/Constructible/MetaExists.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section\<open>The meta-existential quantifier\<close>

theory MetaExists imports ZF begin

text\<open>Allows quantification over any term.  Used to quantify over classes.
Yields a proposition rather than a FOL formula.\<close>

definition
  ex :: "(('a::{}) \<Rightarrow> prop) \<Rightarrow> prop"  (binder \<open>\<Or>\<close> 0) where
  "ex(P) \<equiv> (\<And>Q. (\<And>x. PROP P(x) \<Longrightarrow> PROP Q) \<Longrightarrow> PROP Q)"

lemma meta_exI: "PROP P(x) \<Longrightarrow> (\<Or>x. PROP P(x))"
proof (unfold ex_def)
  assume P: "PROP P(x)"
  fix Q
  assume PQ: "\<And>x. PROP P(x) \<Longrightarrow> PROP Q"
  from P show "PROP Q" by (rule PQ)
qed

lemma meta_exE: "\<lbrakk>\<Or>x. PROP P(x);  \<And>x. PROP P(x) \<Longrightarrow> PROP R\<rbrakk> \<Longrightarrow> PROP R"
proof (unfold ex_def)
  assume QPQ: "\<And>Q. (\<And>x. PROP P(x) \<Longrightarrow> PROP Q) \<Longrightarrow> PROP Q"
  assume PR: "\<And>x. PROP P(x) \<Longrightarrow> PROP R"
  from PR show "PROP R" by (rule QPQ)
qed

end


(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

section\<open>Increment-Decrement Counter\<close>

text\<open>The Increment-Decrement Counter is perhaps the simplest CRDT, and a paradigmatic example of a
    replicated data structure with commutative operations.\<close>

theory
  Counter
imports
  Network
begin

datatype operation = Increment | Decrement

fun counter_op :: "operation \<Rightarrow> int \<rightharpoonup> int" where
  "counter_op Increment x = Some (x + 1)" |
  "counter_op Decrement x = Some (x - 1)"

locale counter = network_with_ops _ counter_op 0

lemma (in counter) "counter_op x \<rhd> counter_op y = counter_op y \<rhd> counter_op x"
  by(case_tac x; case_tac y; auto simp add: kleisli_def)

lemma (in counter) concurrent_operations_commute:
  assumes "xs prefix of i"
  shows "hb.concurrent_ops_commute (node_deliver_messages xs)"
  using assms
  apply(clarsimp simp: hb.concurrent_ops_commute_def)
  apply(rename_tac a b x y)
  apply(case_tac b; case_tac y; force simp add: interp_msg_def kleisli_def)
  done

corollary (in counter) counter_convergence:
  assumes "set (node_deliver_messages xs) = set (node_deliver_messages ys)"
      and "xs prefix of i"
      and "ys prefix of j"
    shows "apply_operations xs = apply_operations ys"
  using assms by(auto simp add: apply_operations_def intro: hb.convergence_ext
      concurrent_operations_commute node_deliver_messages_distinct hb_consistent_prefix)

context counter begin

sublocale sec: strong_eventual_consistency weak_hb hb interp_msg
  "\<lambda>ops. \<exists>xs i. xs prefix of i \<and> node_deliver_messages xs = ops" 0
  apply(standard; clarsimp simp add: hb_consistent_prefix drop_last_message
      node_deliver_messages_distinct concurrent_operations_commute)
   apply(metis (full_types) interp_msg_def counter_op.elims)
  using drop_last_message apply blast
  done

end
end


subsection {* Weakest precondition calculus *}

theory utp_wp
imports "../../Isabelle-UTP-Extended/HoareLogic/PartialCorrectness/utp_hoare"
begin

text {* A very quick implementation of wp -- more laws still needed! *}

named_theorems wp

method wp_tac = (simp add: wp)

consts
  uwp :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infix "wp" 60)

definition wp_upred :: "('\<alpha>, '\<beta>) rel \<Rightarrow> '\<beta> cond \<Rightarrow> '\<alpha> cond" where
"wp_upred Q r = \<lfloor>\<not> (Q ;; (\<not> \<lceil>r\<rceil>\<^sub><)) :: ('\<alpha>, '\<beta>) rel\<rfloor>\<^sub><"

adhoc_overloading
  uwp wp_upred

declare wp_upred_def [urel_defs]

lemma wp_true [wp]: "p wp true = true"
  by (rel_simp)

theorem wp_assigns_r [wp]:
  "\<langle>\<sigma>\<rangle>\<^sub>a wp r = \<sigma> \<dagger> r"
  by rel_auto

theorem wp_skip_r [wp]:
  "II wp r = r"
  by rel_auto

theorem wp_abort [wp]:
  "r \<noteq> true \<Longrightarrow> true wp r = false"
  by rel_auto

theorem wp_conj [wp]:
  "P wp (q \<and> r) = (P wp q \<and> P wp r)"
  by rel_auto

theorem wp_seq_r [wp]: "(P ;; Q) wp r = P wp (Q wp r)"
  by rel_auto

theorem wp_cond [wp]: "(P \<triangleleft> b \<triangleright>\<^sub>r Q) wp r = ((b \<Rightarrow> P wp r) \<and> ((\<not> b) \<Rightarrow> Q wp r))"
  by rel_auto

theorem wp_hoare_link:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<longleftrightarrow> (Q wp r \<sqsubseteq> p)"
  by rel_auto

text {* If two programs have the same weakest precondition for any postcondition then the programs
  are the same. *}

theorem wp_eq_intro: "\<lbrakk> \<And> r. P wp r = Q wp r \<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto robust, fastforce+)
end


(*
  Title: BAN Kerberos Review
  Author: Felipe Rodopoulos de Oliveira
*)

theory BANKerberos

imports "~~/src/HOL/Auth/Public"

begin

(* DEFINITION OF CURRENT TIME *)
abbreviation CT :: "event list \<Rightarrow> nat" where
  "CT == length"

(* DEFINITION OF LIFETIME FOR ENTITIES *)
consts sesKlife :: nat (* session key *)
consts authlife :: nat (* authenticator *)

specification (sesKlife) sesKlife_freshness [iff]: "2 \<le> sesKlife"
  by blast

specification (authlife) authlife_freshness [iff]: "authlife \<noteq> 0"
  by blast

(* DEFINITION OF EXPIRATION PREDICATES *)
abbreviation
  expiredK :: "[nat, event list] => bool" where
  "expiredK T evs == sesKlife + T < CT evs"

abbreviation
  expiredA :: "[nat, event list] => bool" where
  "expiredA T evs == authlife + T < CT evs"

(* PROTOCOL MODEL *)
inductive_set bankerberos :: "event list set" where

  (* Nothing going on in the network *)
  NIL: "[] \<in> bankerberos" |

  (* Modeling the spy omnipotent premises.
     - evfk is a trace
     - X is derivable from the Spy's knowledge set
     - B is not the Spy

    Then the Spy can send a fraudulent message to B
  *)
  Fake: "\<lbrakk> evfk \<in> bankerberos; X \<in> synth (analz (spies evfk)) \<rbrakk>
    \<Longrightarrow> Says Spy B X # evfk \<in> bankerberos" |

  (* First step: A issues the Server with the communication pair of agents *)
  BK1: "\<lbrakk> evs1 \<in> bankerberos \<rbrakk>
    \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B\<rbrace> # evs1 \<in> bankerberos" |

  (* 2nd step: the Server responds A. For this, we that:
    - Event is valid
    - Session key K is fresh
    - Session key K is symmetric
    - Step 1 occured: Agent A must have issued the Server
  *)
  BK2: "\<lbrakk> evs2 \<in> bankerberos; Key K \<notin> used evs2; K \<in> symKeys;
        Says A' Server \<lbrace> Agent A, Agent B \<rbrace> \<in> set evs2 \<rbrakk>
    \<Longrightarrow> Says Server A (Crypt (shrK A)
          \<lbrace> Number (CT evs2), Agent B, Key K,
            (Crypt (shrK B) \<lbrace> Number (CT evs2), Agent A, Key K \<rbrace>)
          \<rbrace>) # evs2 \<in> bankerberos" |

  (* 3rd step: A send the ticket and the authenticator to B. Hence:
    - Event is valid
    - Step 2 occured
    - Step 1 occured
    - Timestamp for session key is not expired
  *)
  BK3: "\<lbrakk> evs3 \<in> bankerberos;
          Says S A (Crypt (shrK A) \<lbrace> Number Tk, Agent B, Key K, Ticket \<rbrace>) \<in> set evs3;
          Says A Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs3;
          \<not> expiredK Tk evs3 \<rbrakk>
    \<Longrightarrow> Says A B \<lbrace> Ticket, Crypt K \<lbrace> Agent A, Number (CT evs3) \<rbrace> \<rbrace> # evs3 \<in> bankerberos" |

  (* 4th step: B send his authenticator to A. For that:
    - Event is valid
    - Step 3 ocurred
    - Timestamp for session key is not expired
    - Timestamp for authenticator is not expired
  *)
  BK4: "\<lbrakk> evs4 \<in> bankerberos;
          Says A' B \<lbrace>
             (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>),
             (Crypt K \<lbrace>Agent A, Number Ta\<rbrace>)
          \<rbrace> \<in> set evs4;
          \<not> expiredK Tk evs4;
          \<not> expiredA Ta evs4
        \<rbrakk>
    \<Longrightarrow> Says B A (Crypt K (Number Ta)) # evs4 \<in> bankerberos" |

  (* Finally modeling the disclosure of key and leaking of info by a compromised agent *)
  Oops: "\<lbrakk> evop \<in> bankerberos;
           Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evop;
           expiredK Tk evop \<rbrakk>
    \<Longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> # evop \<in> bankerberos" print_theorems

(* MODELING THE PROTOCOL POSSIBILITIES *)
(*
  We have to prove that it is possible that some trace reach an end.
  This happens when we have a fresh session key being shared between A and B
*)
lemma "\<lbrakk> Key K \<notin> used []; K \<in> symKeys \<rbrakk>
        \<Longrightarrow> \<exists> Timestamp. \<exists> evs \<in> bankerberos.
          Says B A (Crypt K (Number Timestamp)) \<in> set evs"
  apply (cut_tac sesKlife_freshness)
  apply (intro exI)
  apply (intro bexI)
  apply (rule_tac [2] bankerberos.BK4)
  apply (rule_tac [2] bankerberos.BK3)
  apply (rule_tac [2] bankerberos.BK2)
  apply (rule_tac [2] bankerberos.BK1)
  apply (rule_tac [2] bankerberos.NIL)
  apply (simp) (* Killing subgoal 1: including event of BK4 *)
  apply (simp) (* Killing subgoal 2: first premise for BK2 \<rightarrow> K is fresh *)
  apply (simp) (* Killing subgoal 3: second premise for BK2 \<rightarrow> K is a symmetric key*)
  apply (simp) (* Killing subgoal 4: third premise for BK2 \<rightarrow> BK1 happened *)
  apply (simp) (* Killing subgoal 5: first premise for BK3 \<rightarrow> BK2 happened *)
  apply (simp) (* Killing subgoal 6: second premise for BK3 \<rightarrow> BK1 happened *)
  apply (simp (no_asm_simp)) (* Killing subgoal 7: third for BK3 \<rightarrow> Tk is valid *)
  apply (simp) (* Killing subgoal 8: first premise for BK4 \<rightarrow> BK happened *)
  apply (simp (no_asm_simp)) (* Killing subgoal 9: second premise for BK4 \<rightarrow> Tk is valid *)
  apply (simp) (* Killing subgoal 10: third premise for BK4 \<rightarrow> Ta is valid *)
  (* apply (simp_all (no_asm_simp))+ *)
done

(* Defining BEFORE function, that returns all events before a certain event *)
definition before :: "event \<Rightarrow> event list \<Rightarrow> event list" ("before _ on _") where
  "before ev on evs = takeWhile (\<lambda>z. z \<noteq> ev) (rev evs)"

(* TODO: Needed these two for proving both lemmas below. Don't know why. *)
declare Says_imp_knows_Spy [THEN parts.Inj, dest]
declare parts.Body [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

lemma Oops_reveals_ticket :
  "Says S A (Crypt Ka \<lbrace>Timestamp, B, K, Ticket\<rbrace>) \<in> set evs
    \<Longrightarrow> Ticket \<in> parts (spies evs)"
  apply (auto) (* I could have used blast here, but this is a simple implication *)
done

lemma Oops_reveals_key :
  "Says Server A (Crypt (shrK A) \<lbrace>Timestamp, B, K, Ticket\<rbrace>) \<in> set evs
    \<Longrightarrow> K \<in> parts(spies evs)"
  apply (auto) (* I could have used blast here, but this is a simple implication *)
done

lemma [simp] : "evs \<in> bankerberos \<Longrightarrow> Key (shrK A) \<in> parts(spies evs) = (A \<in> bad)"
  apply (erule bankerberos.induct)
  apply (frule_tac [7] Oops_reveals_key)
  apply (frule_tac [5] Oops_reveals_ticket)
  apply (simp_all)
  apply (blast)
  apply (blast)
  apply (blast)
done

lemma [simp] : "evs \<in> bankerberos \<Longrightarrow> (Key (shrK A) \<in> analz(spies evs)) = (A \<in> bad)"
  apply (auto)
done

(* Due to Inductive Method predicate USED definition *)
lemma used_Says_rev : "used (evs @ [Says A B X]) = parts {X} \<union> (used evs)"
  apply (induct_tac "evs")
  apply (simp)
  apply (induct_tac "a")
  apply (auto)
  done

(* Due to Inductive Method predicate USED definition *)
lemma used_Notes_rev : "used (evs @ [Notes B X]) = parts{X} \<union> (used evs)"
  apply (induct_tac "evs")
  apply (simp)
  apply (induct_tac "a")
  apply auto
  done

(* Due to Inductive Method predicate USED definition *)
lemma used_Gets_rev : "used (evs @ [Gets B X]) = (used evs)"
  apply (induct_tac "evs")
  apply (simp)
  apply (induct_tac "a")
  apply (auto)
  done

lemma used_evs_rev : "used evs = used (rev evs)"
  apply (induct_tac "evs")
  apply (simp)
  apply (induct_tac "a")
  apply (simp add: used_Says_rev)
  apply (simp add: used_Gets_rev)
  apply (simp add: used_Notes_rev)
  done

lemma takeWhile_void : "x \<notin> set evs \<longrightarrow> takeWhile(\<lambda>z. z \<noteq> x) evs = evs"
  apply auto
  done

(*
  Given the protocol second step belonging to the trace, we can assure that:
    - Ka is the A private key
    - K is a symmetric key
    - K is not a private key (that's trivial)
    - Key must not have appeared prior this step
    - Tk is defined as the time that this event that ocurred
*)
lemma BK_Says_Server_message_form :
  "\<lbrakk>Says Server A (Crypt Ka \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs; evs \<in> bankerberos\<rbrakk>
    \<Longrightarrow> Ka = shrK A \<and> K \<in> symKeys \<and> K \<notin> range shrK
        \<and> Ticket = Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
        \<and> Key K \<notin> used (before
          (Says Server A (Crypt Ka \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)) on evs)
        \<and> Tk = CT(before
          (Says Server A (Crypt Ka \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)) on evs)"
  apply (unfold before_def)
  apply (erule rev_mp)
  apply (erule bankerberos.induct)
  apply (simp_all add: takeWhile_tail)
  apply (auto)
  apply (metis length_rev set_rev takeWhile_void used_evs_rev)+
  done

(* AUTHENTICITY PROOFS *)

lemma BK_Kab_authentic :
  "\<lbrakk>A \<notin> bad; evs \<in> bankerberos;
   (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
    \<in> parts (spies evs)\<rbrakk> \<Longrightarrow>
   Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
    \<in> set evs"
  apply (erule rev_mp)
  apply (erule bankerberos.induct)
  apply (frule_tac [7] Oops_reveals_key)
  apply (frule_tac [5] Oops_reveals_ticket)
  apply (simp_all)
  done

end


(*  Title:       Preservation and respectfulness theorems for coinductive lists
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

section \<open>Setup for Isabelle's quotient package for lazy lists\<close>

theory Quotient_Coinductive_List imports
  "HOL-Library.Quotient_List"
  "HOL-Library.Quotient_Set"
  Coinductive_List
begin

subsection \<open>Rules for the Quotient package\<close>

declare llist.rel_eq[id_simps]

lemma transpD: "\<lbrakk> transp R; R a b; R b c \<rbrakk> \<Longrightarrow> R a c"
  by (erule transpE) blast

lemma id_respect [quot_respect]:
  "(R ===> R) id id"
  by (fact id_rsp)

lemma id_preserve [quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(Rep ---> Abs) id = id"
  using Quotient3_abs_rep [OF assms] by (simp add: fun_eq_iff)

functor lmap: lmap
   by (simp_all add: fun_eq_iff id_def llist.map_comp)

declare llist.map_id0 [id_simps]

lemma reflp_llist_all2: "reflp R \<Longrightarrow> reflp (llist_all2 R)"
  by (rule reflpI) (auto simp add: llist_all2_conv_all_lnth elim: reflpE)

lemma symp_llist_all2: "symp R \<Longrightarrow> symp (llist_all2 R)"
  by (rule sympI) (auto simp add: llist_all2_conv_all_lnth elim: sympE)

lemma transp_llist_all2: "transp R \<Longrightarrow> transp (llist_all2 R)"
  by (rule transpI) (rule llist_all2_trans)

lemma llist_equivp [quot_equiv]:
  "equivp R \<Longrightarrow> equivp (llist_all2 R)"
  by (simp add: equivp_reflp_symp_transp reflp_llist_all2 symp_llist_all2 transp_llist_all2)

lemma unfold_llist_preserve [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and q2: "Quotient3 R2 Abs2 Rep2"
  shows "((Abs1 ---> id) ---> (Abs1 ---> Rep2) ---> (Abs1 ---> Rep1) ---> Rep1 ---> lmap Abs2) unfold_llist = unfold_llist"
  (is "?lhs = ?rhs")
proof(intro ext)
  fix IS_LNIL LHD LTL a
  show "?lhs IS_LNIL LHD LTL a = ?rhs IS_LNIL LHD LTL a"
    by(coinduction arbitrary: a)(auto simp add: Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
qed

lemma Quotient_lmap_Abs_Rep:
  "Quotient3 R Abs Rep \<Longrightarrow> lmap Abs (lmap Rep a) = a"
  by (drule abs_o_rep) (simp add: llist.map_id0 llist.map_comp)

lemma llist_all2_rel:
  assumes "Quotient3 R Abs Rep"
  shows "llist_all2 R r s \<longleftrightarrow> llist_all2 R r r \<and> llist_all2 R s s \<and> (lmap Abs r = lmap Abs s)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume "?lhs"
  hence "llist_all2 R r r"
    apply -
    apply(rule llist_all2_reflI)
    apply(clarsimp simp add: lset_conv_lnth)
    apply(metis Quotient3_rel[OF assms] llist_all2_lnthD)
    done
  moreover from \<open>?lhs\<close> have "llist_all2 R s s"
    apply -
    apply(rule llist_all2_reflI)
    apply(clarsimp simp add: lset_conv_lnth)
    apply(metis Quotient3_rel[OF assms] llist_all2_lnthD2)
    done
  moreover from \<open>?lhs\<close> have "llength r = llength s" by(rule llist_all2_llengthD)
  hence "lmap Abs r = lmap Abs s" using \<open>?lhs\<close>
    unfolding lmap_eq_lmap_conv_llist_all2
    apply -
    apply(erule llist_all2_all_lnthI)
    apply(drule (1) llist_all2_lnthD)
    apply(metis Quotient3_rel[OF assms])
    done
  ultimately show ?rhs by blast
next
  assume ?rhs thus ?lhs
    unfolding lmap_eq_lmap_conv_llist_all2
    by(clarsimp simp add: llist_all2_conv_all_lnth simp del: llist_all2_same)(metis Quotient3_rel[OF assms])
qed

lemma Quotient_llist_all2_lmap_Rep:
  "Quotient3 R Abs Rep \<Longrightarrow> llist_all2 R (lmap Rep a) (lmap Rep a)"
by(auto intro!: llist_all2_all_lnthI intro: Quotient3_rep_reflp)

lemma llist_quotient [quot_thm]:
  "Quotient3 R Abs Rep \<Longrightarrow> Quotient3 (llist_all2 R) (lmap Abs) (lmap Rep)"
by(blast intro: Quotient3I dest: Quotient_lmap_Abs_Rep Quotient_llist_all2_lmap_Rep llist_all2_rel)

declare [[mapQ3 llist = (llist_all2, llist_quotient)]]

lemma LCons_preserve [quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(Rep ---> (lmap Rep) ---> (lmap Abs)) LCons = LCons"
using Quotient3_abs_rep[OF assms]
by(simp add: fun_eq_iff llist.map_comp o_def)

lemmas LCons_respect [quot_respect] = LCons_transfer

lemma LNil_preserve [quot_preserve]:
  "lmap Abs LNil = LNil"
by simp

lemmas LNil_respect [quot_respect] = LNil_transfer

lemma lmap_preserve [quot_preserve]:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> rep2) ---> (lmap rep1) ---> (lmap abs2)) lmap = lmap"
  and   "((abs1 ---> id) ---> lmap rep1 ---> id) lmap = lmap"
using Quotient3_abs_rep[OF a] Quotient3_abs_rep[OF b]
by(simp_all add: fun_eq_iff llist.map_comp o_def)

lemma lmap_respect [quot_respect]:
  shows "((R1 ===> R2) ===> (llist_all2 R1) ===> llist_all2 R2) lmap lmap"
  and   "((R1 ===> (=)) ===> (llist_all2 R1) ===> (=)) lmap lmap"
by(fact lmap_transfer)(simp add: llist_all2_conv_all_lnth lmap_eq_lmap_conv_llist_all2 rel_fun_def)

lemmas llist_all2_respect [quot_respect] = llist_all2_transfer

lemma llist_all2_preserve [quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "((Abs ---> Abs ---> id) ---> lmap Rep ---> lmap Rep ---> id) llist_all2 = llist_all2"
using Quotient3_abs_rep[OF assms]
by(simp add: fun_eq_iff llist_all2_lmap1 llist_all2_lmap2)

lemma llist_all2_preserve2 [quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(llist_all2 ((Rep ---> Rep ---> id) R) l m) = (l = m)"
  by (simp add: map_fun_def [abs_def] Quotient3_rel_rep [OF assms] llist.rel_eq comp_def)

lemma corec_llist_preserve [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and q2: "Quotient3 R2 Abs2 Rep2"
  shows "((Abs1 ---> id) ---> (Abs1 ---> Rep2) ---> (Abs1 ---> id) --->
          (Abs1 ---> lmap Rep2) ---> (Abs1 ---> Rep1) ---> Rep1 ---> lmap Abs2) corec_llist = corec_llist"
  (is "?lhs = ?rhs")
proof(intro ext)
  fix IS_LNIL LHD endORmore LTL_end LTL_more b
  show "?lhs IS_LNIL LHD endORmore LTL_end LTL_more b = ?rhs IS_LNIL LHD endORmore LTL_end LTL_more b"
    by(coinduction arbitrary: b rule: llist.coinduct_strong)
      (auto simp add: Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2] Quotient_lmap_Abs_Rep[OF q2])
qed

end