(*  Title:      HOL/Auth/Guard/Guard.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section{*Protocol-Independent Confidentiality Theorem on Nonces*}

theory Guard imports Analz Extensions begin

(******************************************************************************
messages where all the occurrences of Nonce n are
in a sub-message of the form Crypt (invKey K) X with K:Ks
******************************************************************************)

inductive_set
  guard :: "nat => key set => msg set"
  for n :: nat and Ks :: "key set"
where
  No_Nonce [intro]: "Nonce n ~:parts {X} ==> X:guard n Ks"
| Guard_Nonce [intro]: "invKey K:Ks ==> Crypt K X:guard n Ks"
| Crypt [intro]: "X:guard n Ks ==> Crypt K X:guard n Ks"
| Pair [intro]: "[| X:guard n Ks; Y:guard n Ks |] ==> {|X,Y|}:guard n Ks"

subsection{*basic facts about @{term guard}*}

lemma Key_is_guard [iff]: "Key K:guard n Ks"
by auto

lemma Agent_is_guard [iff]: "Agent A:guard n Ks"
by auto

lemma Number_is_guard [iff]: "Number r:guard n Ks"
by auto

lemma Nonce_notin_guard: "X:guard n Ks ==> X ~= Nonce n"
by (erule guard.induct, auto)

lemma Nonce_notin_guard_iff [iff]: "Nonce n ~:guard n Ks"
by (auto dest: Nonce_notin_guard)

lemma guard_has_Crypt [rule_format]: "X:guard n Ks ==> Nonce n:parts {X}
--> (EX K Y. Crypt K Y:kparts {X} & Nonce n:parts {Y})"
by (erule guard.induct, auto)

lemma Nonce_notin_kparts_msg: "X:guard n Ks ==> Nonce n ~:kparts {X}"
by (erule guard.induct, auto)

lemma Nonce_in_kparts_imp_no_guard: "Nonce n:kparts H
==> EX X. X:H & X ~:guard n Ks"
apply (drule in_kparts, clarify)
apply (rule_tac x=X in exI, clarify)
by (auto dest: Nonce_notin_kparts_msg)

lemma guard_kparts [rule_format]: "X:guard n Ks ==>
Y:kparts {X} --> Y:guard n Ks"
by (erule guard.induct, auto)

lemma guard_Crypt: "[| Crypt K Y:guard n Ks; K ~:invKey`Ks |] ==> Y:guard n Ks"
  by (ind_cases "Crypt K Y:guard n Ks") (auto intro!: image_eqI)

lemma guard_MPair [iff]: "({|X,Y|}:guard n Ks) = (X:guard n Ks & Y:guard n Ks)"
by (auto, (ind_cases "{|X,Y|}:guard n Ks", auto)+)

lemma guard_not_guard [rule_format]: "X:guard n Ks ==>
Crypt K Y:kparts {X} --> Nonce n:kparts {Y} --> Y ~:guard n Ks"
by (erule guard.induct, auto dest: guard_kparts)

lemma guard_extand: "[| X:guard n Ks; Ks <= Ks' |] ==> X:guard n Ks'"
by (erule guard.induct, auto)

subsection{*guarded sets*}

definition Guard :: "nat => key set => msg set => bool" where
"Guard n Ks H == ALL X. X:H --> X:guard n Ks"

subsection{*basic facts about @{term Guard}*}

lemma Guard_empty [iff]: "Guard n Ks {}"
by (simp add: Guard_def)

lemma notin_parts_Guard [intro]: "Nonce n ~:parts G ==> Guard n Ks G"
apply (unfold Guard_def, clarify)
apply (subgoal_tac "Nonce n ~:parts {X}")
by (auto dest: parts_sub)

lemma Nonce_notin_kparts [simplified]: "Guard n Ks H ==> Nonce n ~:kparts H"
by (auto simp: Guard_def dest: in_kparts Nonce_notin_kparts_msg)

lemma Guard_must_decrypt: "[| Guard n Ks H; Nonce n:analz H |] ==>
EX K Y. Crypt K Y:kparts H & Key (invKey K):kparts H"
apply (drule_tac P="%G. Nonce n:G" in analz_pparts_kparts_substD, simp)
by (drule must_decrypt, auto dest: Nonce_notin_kparts)

lemma Guard_kparts [intro]: "Guard n Ks H ==> Guard n Ks (kparts H)"
by (auto simp: Guard_def dest: in_kparts guard_kparts)

lemma Guard_mono: "[| Guard n Ks H; G <= H |] ==> Guard n Ks G"
by (auto simp: Guard_def)

lemma Guard_insert [iff]: "Guard n Ks (insert X H)
= (Guard n Ks H & X:guard n Ks)"
by (auto simp: Guard_def)

lemma Guard_Un [iff]: "Guard n Ks (G Un H) = (Guard n Ks G & Guard n Ks H)"
by (auto simp: Guard_def)

lemma Guard_synth [intro]: "Guard n Ks G ==> Guard n Ks (synth G)"
by (auto simp: Guard_def, erule synth.induct, auto)

lemma Guard_analz [intro]: "[| Guard n Ks G; ALL K. K:Ks --> Key K ~:analz G |]
==> Guard n Ks (analz G)"
apply (auto simp: Guard_def)
apply (erule analz.induct, auto)
by (ind_cases "Crypt K Xa:guard n Ks" for K Xa, auto)

lemma in_Guard [dest]: "[| X:G; Guard n Ks G |] ==> X:guard n Ks"
by (auto simp: Guard_def)

lemma in_synth_Guard: "[| X:synth G; Guard n Ks G |] ==> X:guard n Ks"
by (drule Guard_synth, auto)

lemma in_analz_Guard: "[| X:analz G; Guard n Ks G;
ALL K. K:Ks --> Key K ~:analz G |] ==> X:guard n Ks"
by (drule Guard_analz, auto)

lemma Guard_keyset [simp]: "keyset G ==> Guard n Ks G"
by (auto simp: Guard_def)

lemma Guard_Un_keyset: "[| Guard n Ks G; keyset H |] ==> Guard n Ks (G Un H)"
by auto

lemma in_Guard_kparts: "[| X:G; Guard n Ks G; Y:kparts {X} |] ==> Y:guard n Ks"
by blast

lemma in_Guard_kparts_neq: "[| X:G; Guard n Ks G; Nonce n':kparts {X} |]
==> n ~= n'"
by (blast dest: in_Guard_kparts)

lemma in_Guard_kparts_Crypt: "[| X:G; Guard n Ks G; is_MPair X;
Crypt K Y:kparts {X}; Nonce n:kparts {Y} |] ==> invKey K:Ks"
apply (drule in_Guard, simp)
apply (frule guard_not_guard, simp+)
apply (drule guard_kparts, simp)
by (ind_cases "Crypt K Y:guard n Ks", auto)

lemma Guard_extand: "[| Guard n Ks G; Ks <= Ks' |] ==> Guard n Ks' G"
by (auto simp: Guard_def dest: guard_extand)

lemma guard_invKey [rule_format]: "[| X:guard n Ks; Nonce n:kparts {Y} |] ==>
Crypt K Y:kparts {X} --> invKey K:Ks"
by (erule guard.induct, auto)

lemma Crypt_guard_invKey [rule_format]: "[| Crypt K Y:guard n Ks;
Nonce n:kparts {Y} |] ==> invKey K:Ks"
by (auto dest: guard_invKey)

subsection{*set obtained by decrypting a message*}

abbreviation (input)
  decrypt :: "msg set => key => msg => msg set" where
  "decrypt H K Y == insert Y (H - {Crypt K Y})"

lemma analz_decrypt: "[| Crypt K Y:H; Key (invKey K):H; Nonce n:analz H |]
==> Nonce n:analz (decrypt H K Y)"
apply (drule_tac P="%H. Nonce n:analz H" in ssubst [OF insert_Diff])
apply assumption
apply (simp only: analz_Crypt_if, simp)
done

lemma parts_decrypt: "[| Crypt K Y:H; X:parts (decrypt H K Y) |] ==> X:parts H"
by (erule parts.induct, auto intro: parts.Fst parts.Snd parts.Body)

subsection{*number of Crypt's in a message*}

fun crypt_nb :: "msg => nat"
where
  "crypt_nb (Crypt K X) = Suc (crypt_nb X)"
| "crypt_nb {|X,Y|} = crypt_nb X + crypt_nb Y"
| "crypt_nb X = 0" (* otherwise *)

subsection{*basic facts about @{term crypt_nb}*}

lemma non_empty_crypt_msg: "Crypt K Y:parts {X} ==> crypt_nb X \<noteq> 0"
by (induct X, simp_all, safe, simp_all)

subsection{*number of Crypt's in a message list*}

primrec cnb :: "msg list => nat"
where
  "cnb [] = 0"
| "cnb (X#l) = crypt_nb X + cnb l"

subsection{*basic facts about @{term cnb}*}

lemma cnb_app [simp]: "cnb (l @ l') = cnb l + cnb l'"
by (induct l, auto)

lemma mem_cnb_minus: "x \<in> set l ==> cnb l = crypt_nb x + (cnb l - crypt_nb x)"
  by (induct l) auto

lemmas mem_cnb_minus_substI = mem_cnb_minus [THEN ssubst]

lemma cnb_minus [simp]: "x \<in> set l ==> cnb (remove l x) = cnb l - crypt_nb x"
apply (induct l, auto)
apply (erule_tac l=l and x=x in mem_cnb_minus_substI)
apply simp
done

lemma parts_cnb: "Z:parts (set l) ==>
cnb l = (cnb l - crypt_nb Z) + crypt_nb Z"
by (erule parts.induct, auto simp: in_set_conv_decomp)

lemma non_empty_crypt: "Crypt K Y:parts (set l) ==> cnb l \<noteq> 0"
by (induct l, auto dest: non_empty_crypt_msg parts_insert_substD)

subsection{*list of kparts*}

lemma kparts_msg_set: "EX l. kparts {X} = set l & cnb l = crypt_nb X"
apply (induct X, simp_all)
apply (rename_tac agent, rule_tac x="[Agent agent]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Number nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Nonce nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Key nat]" in exI, simp)
apply (rename_tac X, rule_tac x="[Hash X]" in exI, simp)
apply (clarify, rule_tac x="l@la" in exI, simp)
by (clarify, rename_tac nat X y, rule_tac x="[Crypt nat X]" in exI, simp)

lemma kparts_set: "EX l'. kparts (set l) = set l' & cnb l' = cnb l"
apply (induct l)
apply (rule_tac x="[]" in exI, simp, clarsimp)
apply (rename_tac a b l')
apply (subgoal_tac "EX l''.  kparts {a} = set l'' & cnb l'' = crypt_nb a", clarify)
apply (rule_tac x="l''@l'" in exI, simp)
apply (rule kparts_insert_substI, simp)
by (rule kparts_msg_set)

subsection{*list corresponding to "decrypt"*}

definition decrypt' :: "msg list => key => msg => msg list" where
"decrypt' l K Y == Y # remove l (Crypt K Y)"

declare decrypt'_def [simp]

subsection{*basic facts about @{term decrypt'}*}

lemma decrypt_minus: "decrypt (set l) K Y <= set (decrypt' l K Y)"
by (induct l, auto)

subsection{*if the analyse of a finite guarded set gives n then it must also gives
one of the keys of Ks*}

lemma Guard_invKey_by_list [rule_format]: "ALL l. cnb l = p
--> Guard n Ks (set l) --> Nonce n:analz (set l)
--> (EX K. K:Ks & Key K:analz (set l))"
apply (induct p)
(* case p=0 *)
apply (clarify, drule Guard_must_decrypt, simp, clarify)
apply (drule kparts_parts, drule non_empty_crypt, simp)
(* case p>0 *)
apply (clarify, frule Guard_must_decrypt, simp, clarify)
apply (drule_tac P="%G. Nonce n:G" in analz_pparts_kparts_substD, simp)
apply (frule analz_decrypt, simp_all)
apply (subgoal_tac "EX l'. kparts (set l) = set l' & cnb l' = cnb l", clarsimp)
apply (drule_tac G="insert Y (set l' - {Crypt K Y})"
and H="set (decrypt' l' K Y)" in analz_sub, rule decrypt_minus)
apply (rule_tac analz_pparts_kparts_substI, simp)
apply (case_tac "K:invKey`Ks")
(* K:invKey`Ks *)
apply (clarsimp, blast)
(* K ~:invKey`Ks *)
apply (subgoal_tac "Guard n Ks (set (decrypt' l' K Y))")
apply (drule_tac x="decrypt' l' K Y" in spec, simp)
apply (subgoal_tac "Crypt K Y:parts (set l)")
apply (drule parts_cnb, rotate_tac -1, simp)
apply (clarify, drule_tac X="Key Ka" and H="insert Y (set l')" in analz_sub)
apply (rule insert_mono, rule set_remove)
apply (simp add: analz_insertD, blast)
(* Crypt K Y:parts (set l) *)
apply (blast dest: kparts_parts)
(* Guard n Ks (set (decrypt' l' K Y)) *)
apply (rule_tac H="insert Y (set l')" in Guard_mono)
apply (subgoal_tac "Guard n Ks (set l')", simp)
apply (rule_tac K=K in guard_Crypt, simp add: Guard_def, simp)
apply (drule_tac t="set l'" in sym, simp)
apply (rule Guard_kparts, simp, simp)
apply (rule_tac B="set l'" in subset_trans, rule set_remove, blast)
by (rule kparts_set)

lemma Guard_invKey_finite: "[| Nonce n:analz G; Guard n Ks G; finite G |]
==> EX K. K:Ks & Key K:analz G"
apply (drule finite_list, clarify)
by (rule Guard_invKey_by_list, auto)

lemma Guard_invKey: "[| Nonce n:analz G; Guard n Ks G |]
==> EX K. K:Ks & Key K:analz G"
by (auto dest: analz_needs_only_finite Guard_invKey_finite)

subsection{*if the analyse of a finite guarded set and a (possibly infinite) set of keys
gives n then it must also gives Ks*}

lemma Guard_invKey_keyset: "[| Nonce n:analz (G Un H); Guard n Ks G; finite G;
keyset H |] ==> EX K. K:Ks & Key K:analz (G Un H)"
apply (frule_tac P="%G. Nonce n:G" and G=G in analz_keyset_substD, simp_all)
apply (drule_tac G="G Un (H Int keysfor G)" in Guard_invKey_finite)
by (auto simp: Guard_def intro: analz_sub)

end


theory Petersons
imports OpSem
begin

datatype PC =
  L1
| L2
| L3
| L4
| L5
| L6
| L7

consts t1 :: T
consts t2 :: T
consts flag1 :: L
consts flag2 :: L
consts turn :: L

definition "thrdsvars \<equiv>  t1 \<noteq> 0 \<and> t2 \<noteq> 0 \<and> t1 \<noteq> t2 \<and>
                         flag1 \<noteq> flag2 \<and>
                         flag1 \<noteq> turn \<and>
                         flag2 \<noteq> turn"

record mp_state =
  pc :: "T \<Rightarrow> PC"
  state :: surrey_state
  r1 :: "T \<Rightarrow> V"
  r2 :: "T \<Rightarrow> V"
  (* auxiliary *)
  after :: "T \<Rightarrow> V"

(*
  tv1 :: V
  tv2 :: V
*)
definition
  "update_loc t nv pcf \<equiv> pcf (t := nv)"

(*
definition
  "tv_id s s' \<equiv> tv1 s' = tv1 s \<and> tv2 s' = tv2 s"

definition
  "after_id s s' \<equiv> after1 s' = after1 s \<and> after2 s' = after2 s"
*)

definition
  "aux_id s s' \<equiv>  after s = after s'"
(* tv_id s s' \<and>*)

definition
  "locals_id s s' \<equiv> r1 s' = r1 s \<and> r2 s' = r2 s  \<and> aux_id s s'"

lemmas mp_simps [simp] =
  locals_id_def
  aux_id_def
  update_loc_def
  thrdsvars_def
(*  tv_id_def*)

(*\<and> (\<exists> v. (state s) RMW[turn, v, t']\<^sub>t (state s'))*)
definition prog :: "T \<Rightarrow>  mp_state \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog t s s' \<equiv>
(
if t = t1
then let t' = t2 in
  if (pc s) t = L1
    then
      pc s' = update_loc t L2 (pc s) \<and>
      ((state s) [flag1 := 1]\<^sub>t (state s')) \<and>
      locals_id s s'
   else
  if (pc s) t = L2
    then
      pc s' = update_loc t L3 (pc s) \<and>
      (state s) SWAP[turn, t']\<^sub>t (state s')
      \<and> after s' = update_loc t 1 (after s)  \<and>
      r1 s' = r1 s \<and> r2 s' = r2 s
  else
  if (pc s) t = L3
    then
      pc s' = update_loc t L4 (pc s) \<and>
      ((state s) [r1 s' t \<leftarrow>\<^sup>A flag2]\<^sub>t (state s')) \<and>
      r1 s t' = r1 s' t' \<and> r2 s' = r2 s \<and> aux_id s s'
  else
  if (pc s) t = L4
    then
      pc s' = update_loc t L5 (pc s) \<and>
      ((state s) [r2 s' t \<leftarrow> turn]\<^sub>t (state s')) \<and>
      r1 s' = r1 s \<and> r2 s' t' = r2 s t' \<and> aux_id s s'
  else
  if (pc s) t = L5
    then
      (if r1 s t = 0 \<or> r2 s t = t
       then pc s' = update_loc t L6 (pc s)
       else pc s' = update_loc t L3 (pc s))
      \<and>  locals_id s s' \<and> state s = state s'
  else
  if (pc s) t = L6
    then
      pc s' = update_loc t L7 (pc s)
      \<and> ((state s) [flag1 :=\<^sup>R 0]\<^sub>t (state s'))
      \<and> after s' = update_loc t 0 (after s)
      \<and> r1 s' = r1 s \<and> r2 s' = r2 s
  else
  False
else
if t = t2
then let t' = t1 in
  if (pc s) t = L1
    then
      pc s' = update_loc t L2 (pc s) \<and>
      ((state s) [flag2 := 1]\<^sub>t (state s')) \<and>
      locals_id s s'
  else
  if (pc s) t = L2
    then
      pc s' = update_loc t L3 (pc s) \<and>
      (((state s) SWAP[turn, t']\<^sub>t (state s')))
      \<and> after s' = update_loc t 1 (after s) \<and>
      r1 s' = r1 s \<and> r2 s' = r2 s
  else
  if (pc s) t = L3
    then
      pc s' = update_loc t L4 (pc s) \<and>
      ((state s) [r1 s' t \<leftarrow>\<^sup>A flag1]\<^sub>t (state s')) \<and>
      r1 s' t' = r1 s t' \<and> r2 s' = r2 s \<and> aux_id s s'
  else
  if (pc s) t = L4
    then
      pc s' = update_loc t L5 (pc s) \<and>
      ((state s) [r2 s' t \<leftarrow> turn]\<^sub>t (state s')) \<and>
      r1 s' = r1 s \<and> r2 s' t' = r2 s t' \<and> aux_id s s'
  else
  if (pc s) t = L5
    then
      (if (r1 s t = 0 \<or> r2 s t = t)
      then pc s' = update_loc t L6 (pc s)
      else pc s' = update_loc t L3 (pc s))
      \<and> locals_id s s' \<and> state s = state s'
  else
  if (pc s) t = L6
    then
      pc s' = update_loc t L7 (pc s) \<and>
      ((state s) [flag2 :=\<^sup>R 0]\<^sub>t (state s')) \<and> after s' = update_loc t 0 (after s) \<and>
      r1 s' = r1 s \<and> r2 s' = r2 s
  else
  False
else
False
)"

definition prog_inv :: "T \<Rightarrow> PC \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog_inv t p s \<equiv>
  if t = t1
  then let t' = t2 in
    (case p of
          L1 \<Rightarrow> after s t = 0 \<and> [flag1 =\<^sub>t 0] (state s) \<and> (cvd[turn, 0] (state s) \<or> cvd[turn, t1] (state s))
                \<and> (after s t' = 1 \<longrightarrow> cvd[turn, t1] (state s) \<and> [turn = t]\<^sub>t\<lparr>flag2 = 1\<rparr> (state s))
                \<and>  \<not> [turn \<approx>\<^sub>t' t'] (state s)
\<comment> \<open>[flag1 := 1]t\<close>
        | L2 \<Rightarrow> after s t = 0 \<and> [flag1 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<longrightarrow> cvd[turn, t1] (state s) \<and> [turn = t]\<^sub>t\<lparr>flag2 = 1\<rparr> (state s))
                \<and>  \<not> [turn \<approx>\<^sub>t' t'] (state s)
\<comment> \<open>RMW[turn, v, t2]t\<close>
        | L3 \<Rightarrow> after s t = 1 \<and> [flag1 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<and> ([flag2 \<approx>\<^sub>t 0] (state s) \<or> [turn \<approx>\<^sub>t t] (state s)) \<longrightarrow>  [turn =\<^sub>t' t] (state s))

\<comment> \<open>[r1 s' \<leftarrow>A flag2]t\<close>
        | L4 \<Rightarrow> after s t = 1 \<and> [flag1 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<and> (r1 s t = 0 \<or> [turn \<approx>\<^sub>t t] (state s) \<or> [flag2 \<approx>\<^sub>t 0] (state s)) \<longrightarrow>  [turn =\<^sub>t' t] (state s))
\<comment> \<open>[r2 s' \<leftarrow> turn]t\<close>
        | L5 \<Rightarrow> after s t = 1 \<and> [flag1 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<and> (r1 s t = 0 \<or> r2 s t = t \<or> [turn \<approx>\<^sub>t t] (state s) \<or> [flag2 \<approx>\<^sub>t 0] (state s)) \<longrightarrow>  [turn =\<^sub>t' t] (state s))
\<comment> \<open>r1 s = 0 \<or> r2 s = t1\<close>
        | L6 \<Rightarrow> after s t = 1 \<and> [flag1 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<longrightarrow> [turn =\<^sub>t' t] (state s))
\<comment> \<open>[flag1 :=R 0]t\<close>
        | _ \<Rightarrow> True
    )
  else
    if t = t2 then let t' = t1 in
      (case p of
          L1 \<Rightarrow> after s t = 0 \<and> [flag2 =\<^sub>t 0] (state s) \<and> (cvd[turn, 0] (state s) \<or> cvd[turn, t] (state s))
                \<and> (after s t' = 1 \<longrightarrow> cvd[turn, t2] (state s) \<and> [turn = t]\<^sub>t\<lparr>flag1 = 1\<rparr> (state s))
                \<and> \<not> [turn \<approx>\<^sub>t' t'] (state s)
        | L2 \<Rightarrow> after s t = 0 \<and> [flag2 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<longrightarrow> cvd[turn, t2] (state s) \<and> [turn = t]\<^sub>t\<lparr>flag1 = 1\<rparr> (state s))
                \<and> \<not> [turn \<approx>\<^sub>t' t'] (state s)
\<comment> \<open>test ok to enter\<close>
        | L3 \<Rightarrow> after s t = 1 \<and> [flag2 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<and> ([flag1 \<approx>\<^sub>t 0] (state s) \<or> [turn \<approx>\<^sub>t t] (state s)) \<longrightarrow>  [turn =\<^sub>t' t] (state s))
        | L4 \<Rightarrow> after s t = 1 \<and> [flag2 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<and> (r1 s t = 0 \<or> [turn \<approx>\<^sub>t t] (state s) \<or> [flag1 \<approx>\<^sub>t 0] (state s)) \<longrightarrow>  [turn =\<^sub>t' t] (state s))
        | L5 \<Rightarrow> after s t = 1 \<and> [flag2 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<and> (r1 s t = 0 \<or> r2 s t = t \<or> [turn \<approx>\<^sub>t t] (state s) \<or> [flag1 \<approx>\<^sub>t 0] (state s)) \<longrightarrow>  [turn =\<^sub>t' t] (state s))
\<comment> \<open>critical section\<close>
        | L6 \<Rightarrow> after s t = 1 \<and> [flag2 =\<^sub>t 1] (state s)
                \<and> (after s t' = 1 \<longrightarrow> [turn =\<^sub>t' t] (state s))
        | _ \<Rightarrow> True
      )
  else
    False
"

lemma mutex:
  "thrdsvars \<Longrightarrow>
    prog_inv t1 L6 s \<Longrightarrow> prog_inv t2 L6 s \<Longrightarrow> False"
  by (simp add: prog_inv_def d_obs_def d_obs_t_def)

(*initial_state \<sigma> I*)
definition init_map  :: "(L \<Rightarrow> V) \<Rightarrow> bool" where
  "init_map \<phi> \<equiv> \<phi> flag1 = 0 \<and> \<phi> flag2 = 0 \<and> \<phi> turn = 0"

definition init_s  :: "surrey_state  \<Rightarrow> bool"
  where
    "init_s ss \<equiv> \<exists> \<phi>. initial_state ss \<phi> \<and> init_map \<phi>"

definition init  :: "mp_state  \<Rightarrow> bool"
  where
    "init s \<equiv>
        (\<forall> t. t \<in> {t1, t2} \<longrightarrow> (pc s) t = L1 \<and> (r1 s) t = 0 \<and> (r2 s) t = 0 \<and> after s t = 0)
      \<and> init_s (state s) \<and> thrdsvars"

definition "global_inital_vals s \<equiv> init_val (state s) flag1 0
                                \<and>  init_val (state s) flag2 0
                                \<and>  init_val (state s) turn 0"

definition "global_covered s \<equiv> cvd[turn, 0] (state s)
                             \<or> cvd[turn, t1] (state s)
                             \<or> cvd[turn, t2] (state s)"

definition "global_covered_turn_0 s \<equiv> cvd[turn, 0] (state s) \<longrightarrow> after s t1 = 0 \<and> after s t2 = 0"

definition "global_after_values s \<equiv> (after s t1 = 0 \<or> after s t1 = 1) \<and>  (after s t2 = 0 \<or> after s t2 = 1)"

(*add proved global invariants here*)
definition "global_invs s \<equiv> global_inital_vals s
                          \<and> global_covered s"

lemmas global_simp [simp] =
  global_covered_def
  global_inital_vals_def
  global_covered_turn_0_def
  global_after_values_def

lemmas prog_simp  =
  prog_def
  prog_inv_def
  init_def
  init_s_def
  init_map_def

(***************** Global Invariant *************************)

lemma init_hold_global_after_values: "init s\<Longrightarrow> thrdsvars  \<Longrightarrow> global_after_values s"
  using global_after_values_def init_def by blast

lemma global_hold_global_after_values:
  assumes "global_after_values s"
   and "prog t s s'"
   and "t\<in>{t1,t2}"
   and "thrdsvars"
 shows "global_after_values s'"
  using assms
  apply (simp_all add:  prog_def)
  apply(elim disjE)
     apply(cases "pc s t1", simp_all)
   by(cases "pc s t2", simp_all)

lemma init_hold_global_inital_vals: "init s\<Longrightarrow> thrdsvars  \<Longrightarrow> global_inital_vals s"
  apply (simp add: init_val_def prog_simp)
  apply (elim conjE, intro conjI)
  apply(unfold writes_on_def value_def initial_state_def mo_def, simp)
  by auto[3]

lemma global_hold_global_inital_vals:
  assumes "global_inital_vals s"
   and "prog t s s'"
   and "t\<in>{t1,t2}"
   and "thrdsvars"
 shows "global_inital_vals s'"
  using assms
  apply (simp_all add:  prog_def)
  apply(elim conjE disjE)
   apply(intro conjI)
     apply clarsimp
  apply (cases "pc s t1", simp_all)
  using init_val_pres apply blast+
  apply (cases "pc s t1", simp_all)
  using init_val_pres apply blast+
  apply (cases "pc s t1", simp_all)
  using init_val_pres apply blast+
  apply (cases "pc s t2", simp_all)
  using init_val_pres by blast+

lemma init_hold_global_covered: "init s\<Longrightarrow> thrdsvars  \<Longrightarrow> global_covered s"
  apply (simp add:  prog_simp)
  apply (elim conjE)
  by (metis init_covered_v)

lemma global_hold_global_covered:
  assumes "global_covered s"
   and "wfs (state s)"
   and "prog t s s'"
   and "t\<in>{t1,t2}"
   and "thrdsvars"
 shows "global_covered s'"
  using assms
  apply (simp_all add:  prog_def)
  apply(elim disjE)
  apply(cases "pc s t1", simp_all)
  apply(elim conjE)
  using covered_diff_var_pres
  apply (metis cvd_WrX_other_var_pres, metis cvd_RMW_pres, metis cvd_RdA_pres, metis cvd_Rdx_pres, metis cvd_WrR_other_var_pres)
  apply (cases "pc s t2", simp_all)
  apply (metis cvd_WrX_other_var_pres, metis cvd_RMW_pres, metis cvd_RdA_pres, metis cvd_Rdx_pres, metis cvd_WrR_other_var_pres)
  apply (cases "pc s t1", simp_all)
  apply (metis cvd_WrX_other_var_pres, metis cvd_RMW_pres, metis cvd_RdA_pres, metis cvd_Rdx_pres, metis cvd_WrR_other_var_pres)
  apply (cases "pc s t1", simp_all)
  apply (metis cvd_WrX_other_var_pres, metis cvd_RMW_pres, metis cvd_RdA_pres, metis cvd_Rdx_pres, metis cvd_WrR_other_var_pres)
  apply (cases "pc s t2", simp_all)
  apply (metis cvd_WrX_other_var_pres, metis cvd_RMW_pres, metis cvd_RdA_pres, metis cvd_Rdx_pres, metis cvd_WrR_other_var_pres)
  apply (cases "pc s t2", simp_all)
  by (metis cvd_WrX_other_var_pres, metis cvd_RMW_pres, metis cvd_RdA_pres, metis cvd_Rdx_pres, metis cvd_WrR_other_var_pres)

lemma init_hold_global_covered_turn_0: "init s\<Longrightarrow> thrdsvars  \<Longrightarrow> global_covered_turn_0 s"
  by (simp add:  prog_simp)

lemma global_hold_global_covered_turn_0:
  assumes "global_covered_turn_0 s"
   and "wfs (state s)"
   and "prog_inv t (pc s t) s"
   and "prog t s s'"
   and "t\<in>{t1,t2}"
   and "thrdsvars"
 shows "global_covered_turn_0 s'"
  using assms
  apply (simp_all add:  prog_def  prog_inv_def)
  apply(elim disjE)
   apply(cases "pc s t1", simp_all)
             apply(elim conjE, intro impI conjI)
       apply(case_tac "cvd[turn, 0] (state s)")
        apply blast
  using cvd_backwards_WrX apply blast
      apply(elim conjE)
      defer
  using cvd_backwards_RdA apply blast
  defer
  using cvd_backwards_WrR apply blast
   apply(cases "pc s t2", simp_all)
   using cvd_backwards_WrX apply blast
        defer
   using cvd_backwards_RdA apply blast
   defer
   using cvd_backwards_WrR apply blast
      apply(case_tac "cvd[turn, 0] (state s)")
       apply simp
       apply(case_tac "cvd[turn, t2] (state s')")
   using cvd_u_not_cvd_v
   defer
   using cvd_RMW_new_cvd apply blast
       apply simp
       apply(case_tac "after s t2 = Suc 0")
        defer     apply simp
   using RMW_exist_w_in_post
   apply (metis assms(6) covered_v_def thrdsvars_def)
   using not_cvd_RdX_pres apply blast
   using RMW_exist_w_in_post
   apply (metis assms(6) covered_v_def thrdsvars_def)
   using not_cvd_RdX_pres apply blast
   using RMW_exist_w_in_post
   using cvd_u_not_cvd_v apply blast
    using RMW_exist_w_in_post
  by (metis assms(6) cvd_RMW_new_cvd cvd_u_not_cvd_v thrdsvars_def)

(***************** Initialisation *************************)

lemma init_inv : "init s \<Longrightarrow> global_invs s \<Longrightarrow> thrdsvars \<Longrightarrow> t\<in>{t1,t2} \<Longrightarrow> prog_inv t L1 s"
  apply (simp add: prog_simp global_invs_def)
  apply (intro conjI, elim conjE exE)
  using init_d_obs
   apply clarsimp
  apply (metis d_obs_p_obs_agree init_covered_v initial_wfs less_numeral_extra(3))
  by (metis d_obs_p_obs_agree gr_implies_not0 init_covered_v init_d_obs initial_wfs)

(********************* Thread 1 ************************)

lemma local:
  assumes "wfs (state s)"
  and "prog_inv t (pc s t) s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t s s'"
  and "t \<in> {t1, t2}"
shows  "prog_inv t ((pc s') t) s'"
  using assms apply (simp add: prog_inv_def prog_def)
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t1", simp_all)
  apply (metis assms(1) c_obs_WrX_pres cvd_WrX_other_var_pres d_obs_WrX_set not_p_obs_WrX_pres)
  apply (metis Up_reads_cvd_v avar.simps(3) c_obs_UpRA_d_obs covered_v_RMW_d_obs d_obs_RMW_other d_obs_p_obs_agree isUp.simps(3) n_not_Suc_n wfs_preserved wr_val.simps(2))
  apply (metis assms(1) d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres p_obs_RdA_intro)
  apply (metis assms(1) d_obs_RdX_other dobs_RdX_pres not_pobs_RdX_pres p_obs_RdX_intro)
  apply (cases "r1 s t = 0 \<or> r2 s t = t", auto)
  apply (cases "pc s t2", simp_all)
  apply (metis assms(1) c_obs_WrX_pres cvd_WrX_other_var_pres d_obs_WrX_set not_p_obs_WrX_pres)
  apply (metis Up_reads_cvd_v c_obs_UpRA_d_obs cvd_RMW_d_obs d_obs_RMW_other d_obs_p_obs_agree n_not_Suc_n wfs_preserved)
  apply (metis assms(1) d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres p_obs_RdA_intro)
  apply (metis assms(1) d_obs_RdX_other dobs_RdX_pres not_pobs_RdX_pres p_obs_RdX_intro)
  by (cases "r1 s t = 0 \<or> r2 s t = t", auto)

  (* Global proofs *)

lemma global_L1 :
  assumes "wfs (state s)"
  and "pc s t = L1"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (simp add: prog_inv_def prog_def )
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t", simp_all)
  apply (cases "pc s t'", simp_all)
  apply (metis cvd_WrX_other_var_pres dobs_WrX_pres not_p_obs_WrX_diff_var_pres)
  apply (metis c_obs_RMW_intro cvd_RMW_new_cvd dobs_RMW_pres not_p_obs_RMW_val_pres)
  apply (metis cobs_RdA_diff_var_pres cvd_RdA_pres dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis c_obs_RdX_pres cvd_Rdx_pres dobs_RdX_pres not_pobs_RdX_pres)
  apply (metis assms(6) cvd_WrR_other_var_pres dobs_WrR_pres not_p_obs_WrR_val_pres thrdsvars_def)
  apply (cases "pc s t'", simp_all)
  apply (metis cvd_WrX_other_var_pres dobs_WrX_pres not_p_obs_WrX_diff_var_pres)
  apply (metis c_obs_RMW_intro cvd_RMW_new_cvd dobs_RMW_pres not_p_obs_RMW_val_pres)
  apply (metis cobs_RdA_diff_var_pres cvd_RdA_pres dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis c_obs_RdX_pres cvd_Rdx_pres dobs_RdX_pres not_pobs_RdX_pres)
  by (metis assms(6) cvd_WrR_other_var_pres dobs_WrR_pres not_p_obs_WrR_val_pres thrdsvars_def)

lemma global_L2 :
  assumes "wfs (state s)"
  and "pc s t = L2"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (simp add: prog_inv_def prog_def )
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t", simp_all)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres not_p_obs_WrX_diff_var_pres)
  apply (metis c_obs_RMW_intro cvd_RMW_new_cvd dobs_RMW_pres global_covered_def global_invs_def not_p_obs_RMW_val_pres)
  apply (metis cobs_RdA_diff_var_pres cvd_RdA_pres dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis c_obs_RdX_pres cvd_Rdx_pres dobs_RdX_pres not_pobs_RdX_pres)
  apply (metis assms(10) dobs_WrR_pres not_p_obs_WrA_diff_var_pres)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres not_p_obs_WrX_diff_var_pres)
  apply (metis c_obs_RMW_intro cvd_RMW_new_cvd dobs_RMW_pres global_covered_def global_invs_def not_p_obs_RMW_val_pres)
  apply (metis cobs_RdA_diff_var_pres cvd_RdA_pres dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis c_obs_RdX_pres cvd_Rdx_pres dobs_RdX_pres not_pobs_RdX_pres)
  by (metis assms(10) dobs_WrR_pres not_p_obs_WrA_diff_var_pres)

lemma global_L3 :
  assumes "wfs (state s)"
  and "pc s t = L3"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (simp add: prog_inv_def prog_def )
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t", simp_all)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  using cvd_RMW_d_obs dobs_RMW_pres apply blast
  apply (metis d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres not_pobs_RdX_pres)
  apply (metis dobs_WrR_pres)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  apply (metis cvd_RMW_d_obs dobs_RMW_pres)
  apply (metis d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres not_pobs_RdX_pres)
  by (metis dobs_WrR_pres)

lemma global_L4 :
  assumes "wfs (state s)"
  and "pc s t = L4"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (simp add: prog_inv_def prog_def )
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t", simp_all)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  using cvd_RMW_d_obs dobs_RMW_pres apply blast
  apply (metis d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres not_pobs_RdX_pres)
  apply (metis dobs_WrR_pres)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  apply (metis cvd_RMW_d_obs dobs_RMW_pres)
  apply (metis d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres not_pobs_RdX_pres)
  by (metis dobs_WrR_pres)

lemma global_L5 :
  assumes "wfs (state s)"
  and "pc s t = L5"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (simp add: prog_inv_def prog_def )
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t", simp_all)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  using cvd_RMW_d_obs dobs_RMW_pres apply blast
  apply (metis d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres not_pobs_RdX_pres)
  apply (metis dobs_WrR_pres)
  apply (cases "pc s t'", simp_all)
      apply (metis dobs_WrX_pres)
  apply (metis cvd_RMW_d_obs dobs_RMW_pres)
  apply (metis d_obs_RdA_other dobs_RdA_pres not_pobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres not_pobs_RdX_pres)
  by (metis dobs_WrR_pres)

lemma global_L6 :
  assumes "wfs (state s)"
  and "pc s t = L6"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (simp add: prog_inv_def prog_def )
  apply (cases "t = t1", simp_all)
  apply (cases "pc s t", simp_all)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  using cvd_RMW_d_obs dobs_RMW_pres apply blast
  apply (metis d_obs_RdA_other dobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres)
  apply (metis dobs_WrR_pres)
  apply (cases "pc s t'", simp_all)
  apply (metis dobs_WrX_pres)
  apply (metis cvd_RMW_d_obs dobs_RMW_pres)
  apply (metis d_obs_RdA_other dobs_RdA_pres)
  apply (metis d_obs_RdX_pres dobs_RdX_pres)
  by (metis dobs_WrR_pres)

lemma global :
  assumes "wfs (state s)"
  and "prog_inv t (pc s t) s"
  and "prog_inv t' (pc s t') s"
  and "global_invs s"
  and "thrdsvars"
  and "prog t' s s'"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "t \<noteq> t'"
shows  "prog_inv t (pc s t) s'"
  using assms apply (cases "pc s t")
  using global_L1 apply blast
  using global_L2 apply blast
  using global_L3 apply blast
  using global_L4 apply blast
  using global_L5 apply blast
  using global_L6 apply blast
  using prog_simp(2) by auto

end


(*  Title:      HOL/BNF_Greatest_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Greatest fixpoint (codatatype) operation on bounded natural functors.
*)

section {* Greatest Fixpoint (Codatatype) Operation on Bounded Natural Functors *}

theory BNF_Greatest_Fixpoint
imports BNF_Fixpoint_Base String
keywords
  "codatatype" :: thy_decl and
  "primcorecursive" :: thy_goal and
  "primcorec" :: thy_decl
begin

setup {* Sign.const_alias @{binding proj} @{const_name Equiv_Relations.proj} *}

lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases s) auto

lemma not_TrueE: "\<not> True \<Longrightarrow> P"
  by (erule notE, rule TrueI)

lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
  by fast

lemma case_sum_expand_Inr: "f o Inl = g \<Longrightarrow> f x = case_sum g (f o Inr) x"
  by (auto split: sum.splits)

lemma case_sum_expand_Inr': "f o Inl = g \<Longrightarrow> h = f o Inr \<longleftrightarrow> case_sum g h = f"
  apply rule
   apply (rule ext, force split: sum.split)
  by (rule ext, metis case_sum_o_inj(2))

lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
  by fast

lemma equiv_proj:
  assumes e: "equiv A R" and m: "z \<in> R"
  shows "(proj R o fst) z = (proj R o snd) z"
proof -
  from m have z: "(fst z, snd z) \<in> R" by auto
  with e have "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R"
    unfolding equiv_def sym_def trans_def by blast+
  then show ?thesis unfolding proj_def[abs_def] by auto
qed

(* Operators: *)
definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"

lemma Id_on_Gr: "Id_on A = Gr A id"
  unfolding Id_on_def Gr_def by auto

lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
  unfolding image2_def by auto

lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
  by auto

lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
  unfolding image2_def Gr_def by auto

lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
  unfolding Gr_def by simp

lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
  unfolding Gr_def by simp

lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
  unfolding Gr_def by auto

lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
  by blast

lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
  by blast

lemma in_rel_Collect_split_eq: "in_rel (Collect (split X)) = X"
  unfolding fun_eq_iff by auto

lemma Collect_split_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (split (in_rel Y))"
  by auto

lemma Collect_split_in_rel_leE: "X \<subseteq> Collect (split (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
  by force

lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
  unfolding fun_eq_iff by auto

lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
  unfolding fun_eq_iff by auto

lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
  unfolding Gr_def Grp_def fun_eq_iff by auto

definition relImage where
  "relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"

definition relInvImage where
  "relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"

lemma relImage_Gr:
  "\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
  unfolding relImage_def Gr_def relcomp_def by auto

lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
  unfolding Gr_def relcomp_def image_def relInvImage_def by auto

lemma relImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
  unfolding relImage_def by auto

lemma relInvImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
  unfolding relInvImage_def by auto

lemma relInvImage_Id_on:
  "(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
  unfolding relInvImage_def Id_on_def by auto

lemma relInvImage_UNIV_relImage:
  "R \<subseteq> relInvImage UNIV (relImage R f) f"
  unfolding relInvImage_def relImage_def by auto

lemma relImage_proj:
  assumes "equiv A R"
  shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
  unfolding relImage_def Id_on_def
  using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
  by (auto simp: proj_preserves)

lemma relImage_relInvImage:
  assumes "R \<subseteq> f ` A <*> f ` A"
  shows "relImage (relInvImage A R f) f = R"
  using assms unfolding relImage_def relInvImage_def by fast

lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
  by simp

lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z" by simp
lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z" by simp

lemma fst_diag_fst: "fst o ((\<lambda>x. (x, x)) o fst) = fst" by auto
lemma snd_diag_fst: "snd o ((\<lambda>x. (x, x)) o fst) = fst" by auto
lemma fst_diag_snd: "fst o ((\<lambda>x. (x, x)) o snd) = snd" by auto
lemma snd_diag_snd: "snd o ((\<lambda>x. (x, x)) o snd) = snd" by auto

definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"

lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
  unfolding Shift_def Succ_def by simp

lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
  unfolding Succ_def by simp

lemmas SuccE = SuccD[elim_format]

lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
  unfolding Succ_def by simp

lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
  unfolding Shift_def by simp

lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
  unfolding Succ_def Shift_def by auto

lemma length_Cons: "length (x # xs) = Suc (length xs)"
  by simp

lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
  by simp

(*injection into the field of a cardinal*)
definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
definition "toCard A r \<equiv> SOME f. toCard_pred A r f"

lemma ex_toCard_pred:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
  unfolding toCard_pred_def
  using card_of_ordLeq[of A "Field r"]
    ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
  by blast

lemma toCard_pred_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
  unfolding toCard_def using someI_ex[OF ex_toCard_pred] .

lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> toCard A r x = toCard A r y \<longleftrightarrow> x = y"
  using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast

definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"

lemma fromCard_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
  unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)

lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma rec_nat_0_imp: "f = rec_nat f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
  by auto

lemma rec_nat_Suc_imp: "f = rec_nat f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
  by auto

lemma rec_list_Nil_imp: "f = rec_list f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
  by auto

lemma rec_list_Cons_imp: "f = rec_list f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
  by auto

lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
  by simp

definition image2p where
  "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"

lemma image2pI: "R x y \<Longrightarrow> image2p f g R (f x) (g y)"
  unfolding image2p_def by blast

lemma image2pE: "\<lbrakk>image2p f g R fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
  unfolding image2p_def by blast

lemma rel_fun_iff_geq_image2p: "rel_fun R S f g = (image2p f g R \<le> S)"
  unfolding rel_fun_def image2p_def by auto

lemma rel_fun_image2p: "rel_fun R (image2p f g R) f g"
  unfolding rel_fun_def image2p_def by auto

subsection {* Equivalence relations, quotients, and Hilbert's choice *}

lemma equiv_Eps_in:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
  apply (rule someI2_ex)
  using in_quotient_imp_non_empty by blast

lemma equiv_Eps_preserves:
  assumes ECH: "equiv A r" and X: "X \<in> A//r"
  shows "Eps (%x. x \<in> X) \<in> A"
  apply (rule in_mono[rule_format])
   using assms apply (rule in_quotient_imp_subset)
  by (rule equiv_Eps_in) (rule assms)+

lemma proj_Eps:
  assumes "equiv A r" and "X \<in> A//r"
  shows "proj r (Eps (%x. x \<in> X)) = X"
unfolding proj_def
proof auto
  fix x assume x: "x \<in> X"
  thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
next
  fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
qed

definition univ where "univ f X == f (Eps (%x. x \<in> X))"

lemma univ_commute:
assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
shows "(univ f) (proj r x) = f x"
proof (unfold univ_def)
  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
  hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
  moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
  ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
  thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
qed

lemma univ_preserves:
  assumes ECH: "equiv A r" and RES: "f respects r" and PRES: "\<forall>x \<in> A. f x \<in> B"
  shows "\<forall>X \<in> A//r. univ f X \<in> B"
proof
  fix X assume "X \<in> A//r"
  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  hence "univ f X = f x" using ECH RES univ_commute by fastforce
  thus "univ f X \<in> B" using x PRES by simp
qed

ML_file "Tools/BNF/bnf_gfp_util.ML"
ML_file "Tools/BNF/bnf_gfp_tactics.ML"
ML_file "Tools/BNF/bnf_gfp.ML"
ML_file "Tools/BNF/bnf_gfp_rec_sugar_tactics.ML"
ML_file "Tools/BNF/bnf_gfp_rec_sugar.ML"

end


theory Proofs_5
  imports Requirements ExtraInv VCTheoryLemmas
begin

definition inv5 where "inv5 s \<equiv> R5 s \<and> extraInv s"

thm R5_def

definition pred5 where "pred5 s1 s2 s s5 \<equiv>
substate s1 s2 \<and> substate s2 s5 \<and> substate s5 s \<and> toEnvP s1 \<and> toEnvP s1 \<and> toEnvP s2 \<and> toEnvP s5 \<and>
toEnvNum s1 s2 = 1 \<and> toEnvNum s2 s = 1 \<and>
(getVarBool s1 up' = True \<or> getVarBool s1 down' = True) \<and> getVarBool s2 alarmButton' \<and>
(\<forall> s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s5 \<and> s4 \<noteq> s5 \<longrightarrow>
(getVarBool s4 up' = True \<or> getVarBool s4 down' = True)) \<longrightarrow>
(\<exists> s4. toEnvP s4 \<and> substate s5 s4 \<and> substate s4 s \<and> toEnvNum s2 s4 \<le> 1 \<and>
getVarBool s4 up' = False \<and> getVarBool s4 down' = False \<and>
(\<forall> s3. toEnvP s3 \<and> substate s5 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
(getVarBool s3 up' = True \<or> getVarBool s3 down' = True)))"

lemma goUp_not_moving:
 " toEnvP s1 \<and> toEnvP s0 \<and> substate s1 s0 \<and>  substate s0 s \<and> toEnvNum s1 s0 = 0 \<and>
 getVarBool s1 alarmButton' \<and> getPstate s0 Ctrl' = Ctrl'goUp \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Ctrl'goUp \<longrightarrow> ltime s1 ERROR \<le> DELAY'TIMEOUT) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Ctrl'goUp \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goUp) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = UP') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s \<and> getPstate s3 ERROR = Ctrl'goUp \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 ERROR \<longrightarrow> getPstate s1 ERROR = Ctrl'goUp) \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 < ltime s3 ERROR - ERROR \<longrightarrow>
            \<not> getVarBool s2 alarmButton' \<and> \<not> getVarBool s2 stuck' \<and> \<not> (getVarBool s2 userAtTop' \<or> getVarBool s2 userAtBottom')))
\<Longrightarrow>
\<exists> s4. toEnvP s4 \<and> substate s4 s0 \<and> toEnvNum s4 s0 \<le> 1  \<and> getVarBool s4 up' = False \<and> getVarBool s4 down' = False"
    apply(cases "ltime s0 Ctrl' \<le> 1")
  apply(rule exE[of " (\<lambda> s2. \<exists> s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s0 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s0 = ltime s0 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goUp) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = UP') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')"])
    apply blast
   apply (drule exE)
    prefer 2
    apply assumption
  subgoal for s2 s3
    by (smt (verit) One_nat_def le_0_eq le_Suc_eq nat_le_linear shift_toEnvNum substate_antisym substate_shift substate_trans toEnvNum_id)
  by (metis leI zero_less_diff)

theorem proof_5_1: "VC1 inv5 s0"
  apply(simp only: VC1_def inv5_def R5_def extraInv_def)
  by auto

theorem proof_6_7: "VC7 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC7_def)
  by auto

theorem proof_6_9: "VC9 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC9_def)
  by auto

theorem proof_6_11: "VC11 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC11_def)
  by auto

end


theory Rewriting1
  imports LocalLexingSpecification Pattern1 DerivationTrees1 DerivationTrees_Ambiguity
  Containers.Containers
begin
text "Grammar Rewriting implementing the rewriting based on patterns as in Pattern1"

text "can this be defined using transitive closure"
(*alternative*)
(*describes patter [A, \<alpha>, \<circ>X\<delta>, alternative_rule]*)
type_synonym ('a, 'b) pattern = "('a, 'b) symbol \<times> ('a, 'b) symbol list \<times> ('a, 'b) symbol list \<times> ('a, 'b) symbol list"

type_synonym ('a, 'c) rule = "('a, 'c) symbol \<times> ('a, 'c) symbol list"

lemma csorted_set_to_list:
  assumes "ID ccompare = Some (c::('a::ccompare)  comparator)"
          "finite s"
  shows"set (csorted_list_of_set (s::('a::ccompare  set))) = s \<and> distinct (csorted_list_of_set (s::('a::ccompare  set)))"
proof -
  have 1:"class.linorder (le_of_comp c) (lt_of_comp c)" using ID_ccompare' [OF assms(1)] comparator.linorder by blast
  show ?thesis using linorder.set_sorted_list_of_set [OF 1 assms(2)] assms(2)
      linorder.distinct_sorted_list_of_set [OF 1] unfolding csorted_list_of_set_def assms(1) by auto
qed

type_synonym ('a, 'c) assoc_group = "('a, 'c) rule set \<times> bias"
type_synonym ('a, 'c) disambig = "(('a, 'c) rule \<times> ('a, 'c) rule) set"

(*datatype ('a, 'c ) grammar = Grammar (nonterms: "('a, 'c) symbol set") (terms: "('a, 'c) symbol set")(rules:"('a, 'c) rule set") (start: "('a, 'c) symbol")
*)
type_synonym ('a, 'c ) grammar =  "('a, 'c) symbol set \<times> ('a, 'c) symbol set \<times>
  ('a, 'c) rule set \<times>('a, 'c) symbol"(*\<NN> \<TT> \<RR> \<SS>*)

type_synonym ('a,'c) recursrel = "(('a,  'c) symbol \<times> ('a, 'c) symbol) set"

fun fresh::"((('a, 'c) symbol) \<Rightarrow> nat option) \<Rightarrow> ('a, 'c) symbol \<Rightarrow> ((('a, 'c) symbol) \<Rightarrow> nat option)"  where
"fresh m s = (if m s = None then  m(s \<mapsto> 1)  else m(s \<mapsto> (the (m s)) + 1))"

fun convert::"nat \<Rightarrow> ('a, 'c) symbol \<Rightarrow> ('a \<times> nat, 'c) symbol" where
"convert a = (case_sum (\<lambda> t. Inl (t, a)) Inr) "

fun convert_back::"('a \<times> nat, 'c) symbol \<Rightarrow> ('a, 'c) symbol" where
"convert_back s= (case_sum (\<lambda> t . Inl (fst t)) Inr) s"

fun convert_back_sentence::"('a \<times> nat, 'c) symbol list\<Rightarrow> ('a, 'c) symbol list" where
"convert_back_sentence l= map convert_back l"
fun basic_convert::"('a, 'c) symbol \<Rightarrow> ('a \<times> nat, 'c ) symbol" where
"basic_convert a = convert 0 a"

fun stage0::"('a, 'c) grammar \<Rightarrow> ('a \<times> nat, 'c) grammar " where
"stage0 (\<NN>, \<TT>, R, s) = (((convert 0) ` \<NN>), ((convert 0) ` \<TT>), ((\<lambda>(n, l). ((convert 0 n), map (convert 0 ) l))` R) ,(convert 0 s))"

context CFG
begin

definition new_nonterm::"('a \<times> nat) set" where
"new_nonterm = ((\<lambda> a. (a, 0))  ` \<A>)"

term case_sum
definition new_term::"'b  set" where
"new_term = \<B>"

definition rules::"('a \<times> nat,  'b) rule set" where
"rules = ((\<lambda>(n, l). ((convert 0 n), map (convert 0 ) l))` \<RR>)"

definition start::"'a \<times> nat" where
"start =  (\<S>, 0)"

lemma start_valid:"start \<in> new_nonterm"
by (auto simp add: startsymbol_dom  start_def new_nonterm_def)

lemma h1:"(a, b) \<in> local.rules \<Longrightarrow> a \<in> Inl ` (\<lambda>a. (a, 0)) ` \<A>"
proof -
  assume "(a, b) \<in> rules"
  then obtain n  l where n:"(n, l) \<in> \<RR> \<and> (a = (convert 0 n)) \<and> b = map (convert 0) l" using rules_def by auto
  then have "n \<in> Inl ` \<A>" using validRules by blast
  with n have "a  \<in> (convert 0) ` Inl ` \<A>" by blast
  then show ?thesis by auto
qed

lemma h2:"(a, b) \<in> local.rules \<Longrightarrow> s \<in> set b \<Longrightarrow> s \<notin> Inr ` new_term \<Longrightarrow> s \<in> Inl ` (\<lambda>a. (a, 0)) ` \<A> "
proof -
  assume assms:"(a, b) \<in> rules" "s \<in> set b" "s \<notin> Inr ` new_term"
  then obtain n  l where n:"(n, l) \<in> \<RR> \<and> (a = (convert 0 n)) \<and> b = map (convert 0) l" using rules_def by auto
  then have "\<forall> s \<in> set l . s \<in> (Inl ` \<A>) \<union> (Inr ` \<B>)" using validRules by fast
  with n have "\<forall> s \<in> set b . s \<in> ((convert 0) `(Inl ` \<A>) \<union> (Inr ` \<B>))" by force
  then have "\<forall> s \<in> set b . s \<in> ((convert 0) `(Inl ` \<A>)) \<union> (Inr ` \<B>)" by blast
  then have "\<forall> s \<in> set b . s \<in> (Inl `(\<lambda> a. (a, 0)) ` \<A>) \<union> (Inr ` new_term)" using new_term_def by auto
  with assms show ?thesis by auto
qed

lemma finite_rules:"finite rules"
  by (auto simp add: finite_grammar rules_def)

interpretation grammar2: CFG new_nonterm new_term rules start
  apply(unfold_locales)
   apply(auto simp add: startsymbol_dom  start_def new_nonterm_def)
     apply(auto simp add: h1 h2 finite_rules)
  apply (auto simp add: new_term_def finite_terminals)
  done

lemma terminal_equality:"grammar2.is_terminal x \<Longrightarrow> is_terminal (convert_back x)"
  apply(auto simp add: grammar2.is_terminal_def is_terminal_def new_term_def)
  by (smt (verit, ccfv_threshold) case_sum_inject disjE_realizer grammar2.is_terminal_def new_term_def surjective_sum)

lemma terminal_equality':"is_terminal x \<Longrightarrow> grammar2.is_terminal (convert 0 x)"
  apply(auto simp add: grammar2.is_terminal_def is_terminal_def new_term_def)
  by (smt (verit, ccfv_threshold) case_sum_inject disjE_realizer grammar2.is_terminal_def new_term_def surjective_sum)

lemma nonterminal_equality:"grammar2.is_nonterminal x \<Longrightarrow> is_nonterminal (convert_back x)"
proof -
  assume "grammar2.is_nonterminal x"
  then have "case_sum (\<lambda> s. s \<in> new_nonterm) (\<lambda> t. False) x"  by (simp add:grammar2.is_nonterminal_def)
  then obtain s where 1:"x  = Inl s \<and> s \<in> ((\<lambda> a. (a, 0))  ` \<A>)" using new_nonterm_def
    by (metis old.sum.simps(5) old.sum.simps(6) sumE)
  then obtain s' where valid:"s = (s', 0) \<and> s' \<in> \<A>" by blast
  with 1 have "convert_back x = Inl s'" by simp
  with valid  show ?thesis using is_nonterminal_def by simp
qed
(*list all helpers*)

lemma list_all_map:"list_all f (map g b) \<Longrightarrow> list_all (f \<circ> g) b"
  by (simp add: list.pred_map)

lemma list_all_implies:"list_all f b \<Longrightarrow> \<forall> x . (f x\<longrightarrow> g x) \<Longrightarrow> list_all g b"
  using list_all_pos_neg_ex by blast

lemma list_all2_implies:"list_all2 f b b' \<Longrightarrow> \<forall> x y. (f x y\<longrightarrow> g x y) \<Longrightarrow> list_all2 g b b'"
  using list_all2_mono by blast
lemma list_all2_implies_list_all:"list_all2 (\<lambda> x y. f x) b b' \<Longrightarrow> list_all f b"
proof (induction b arbitrary: b')
  case Nil
  then show ?case by simp
next
  case (Cons a b)
  then obtain x xs where"b' = x#xs" by (meson list_all2_Cons1)
  with Cons(2) have "(\<lambda>x y. f x) a x \<and>list_all2 (\<lambda>x y. f x) b xs" by blast
  with Cons(1) have "f a \<and> list_all f b" by blast
  then show ?case by simp
qed

lemma nonterminal_equality':"is_nonterminal x \<Longrightarrow> grammar2.is_nonterminal (convert 0 x)"
proof -
  assume "is_nonterminal x"
  then have "case_sum (\<lambda> s. s \<in> \<A>) (\<lambda> t. False) x"  by (simp add: is_nonterminal_def)
  then obtain s where 1:"x  = Inl s \<and> s \<in> \<A>"
    by (metis old.sum.simps(5) old.sum.simps(6) sumE)
  then obtain s'::"('a \<times> nat)" where valid:"s' = (\<lambda> a. (a, 0)) s \<and> s' \<in> new_nonterm" using new_nonterm_def by blast
  with 1 have "convert 0 x = Inl s'" by simp
  with valid grammar2.is_nonterminal_def  show ?thesis  by fastforce
qed

lemma backconversion:"N = convert_back (convert n N)"
proof (cases N)
  case (Inl a)
  then show ?thesis by simp
next
  case (Inr b)
  then show ?thesis by simp
qed

lemma backconversion_sen:"N = convert_back_sentence (map (convert n) N)"
proof (induction N)
  case Nil
  then show ?case by auto
next
  case (Cons a N)
  have "convert_back_sentence (map (convert n) (a # N)) = (convert_back (convert n a))#N" using Cons by simp
  then show ?case using backconversion by auto
qed

lemma rule_equality:"(N, \<alpha>) \<in> rules \<Longrightarrow> (convert_back N, convert_back_sentence \<alpha>) \<in> \<RR>"
proof -
  assume "(N, \<alpha>) \<in> rules"
  then obtain N' \<alpha>' where alt:"N = convert 0 N' \<and> \<alpha> = map (convert 0) \<alpha>' \<and> (N', \<alpha>') \<in> \<RR>" using rules_def by auto
  then have "N' = convert_back N \<and> \<alpha>' = convert_back_sentence \<alpha>" using backconversion backconversion_sen by auto
  with alt show ?thesis by auto
qed

lemma rule_equality':"\<forall> (N, \<alpha>) \<in> \<RR> . (convert 0 N, map (convert 0) \<alpha> ) \<in> rules"
  using rules_def by auto

fun convertback_rule::"('a \<times> nat, 'b) rule \<Rightarrow> ('a, 'b) rule" where
"convertback_rule (N, a) = (convert_back N, convert_back_sentence a)"

lemma convertback_rule_split:"fst (convertback_rule s) = (convert_back (fst s))
  \<and> snd (convertback_rule s) = (convert_back_sentence (snd s))"
  apply(cases s) by simp

lemma start_conversion:"convert 0 \<SS> = grammar2.\<SS>"
  using grammar2.\<SS>_def  \<SS>_def local.start_def by auto

lemma start_conversion':"\<SS> = convert_back grammar2.\<SS>"
  using grammar2.\<SS>_def  \<SS>_def local.start_def by auto

lemma equality:"grammar2.Tree_wf T \<Longrightarrow> (s, a) = DeriveFromTree T \<Longrightarrow> \<exists> T'. Tree_wf T'
  \<and> (convert_back s, convert_back_sentence a) = DeriveFromTree T'"
proof (induction T arbitrary: s a)
  case (Leaf x)
  then have 1:"grammar2.is_terminal x" by simp
  from Leaf(2) have s:"s = x \<and> a = [x]" by simp
  then have a:"convert_back_sentence a = [convert_back x]" by simp
  from 1 have terminal:"is_terminal (convert_back x)" using terminal_equality by blast
  obtain leaf where def:"leaf = (Leaf (convert_back x))" by blast
  with terminal have wf:"Tree_wf leaf" by simp
  from def a s have  "(convert_back s, convert_back_sentence a )= DeriveFromTree leaf" by simp
  with wf show ?case by blast
next
  case (Inner x)
  then have 1:"grammar2.is_nonterminal x" by simp
  from Inner(2) have s:"s = x \<and> a = [x]" by simp
  then have a:"convert_back_sentence a = [convert_back x]" by simp
  from 1 have terminal:"is_nonterminal (convert_back x)" using nonterminal_equality by blast
  obtain leaf where def:"leaf = (Inner (convert_back x))" by blast
  with terminal have wf:"Tree_wf leaf" by simp
  from def a s have  "(convert_back s, convert_back_sentence a )= DeriveFromTree leaf" by simp
  with wf show ?case by blast
next
  case (DT r b)
  then have validrule:"r \<in> rules" by auto (*need implication that *)
  obtain N \<alpha> where na:"N = fst r \<and> \<alpha> = snd r" by blast
  with validrule have valid_rule:"(convert_back N, convert_back_sentence \<alpha>) \<in> \<RR>" using rule_equality by auto
  from na have \<alpha>_def:"(map (\<lambda> t . fst (DeriveFromTree t)) b)  = \<alpha>"
    using DT(2) grammar2.TreeSym_equal_DeriveFrom_root'' by fastforce
  from DT.prems(1) have "snd r = concat (map grammar2.TreeSym b)" by simp (*downright impossible to convert unless ? define specific conversion function*)
  (*just need lemma that derives root is equal to TreeSym*)
  then have "snd r = concat (map (\<lambda> t . [fst (DeriveFromTree t)]) b)" using grammar2.TreeSym_implies_DeriveFrom_root by presburger
  with na have "convert_back_sentence \<alpha> = concat (map (\<lambda> t . [convert_back (fst (DeriveFromTree t))]) b)" by auto
  (*how to apply IH on all subtrees in list?*)
  from DT(2) have "\<forall> i \<in> set b . grammar2.Tree_wf i" by (auto simp add: list_all_def)
  with DT(1) have "\<forall> x \<in> set b .(\<exists>T'. Tree_wf T' \<and> convertback_rule (DeriveFromTree x)
    = DeriveFromTree T') " by (metis convertback_rule.cases convertback_rule.simps)
  then have "list_all (\<lambda> T . \<exists> T'. Tree_wf T' \<and> convertback_rule (DeriveFromTree T)
    = DeriveFromTree T') b"  by (simp add:list_all_def)
  then obtain b'' where b'':"list_all2 (\<lambda> T' T . Tree_wf T' \<and> convertback_rule (DeriveFromTree T)
    = DeriveFromTree T') b'' b" using implied_existence' by fast
  then have "list_all2 (\<lambda> T' T . Tree_wf T') b'' b" using list_all2_implies by fast
  then have wf_subtrees:"list_all Tree_wf b''" using list_all2_implies_list_all by auto
  from b'' have "list_all2  (\<lambda> T' T . convertback_rule (DeriveFromTree T)
    = DeriveFromTree T') b'' b" using list_all2_implies by fast
  then have "list_all2  (\<lambda> T' T .
     DeriveFromTree T' = (\<lambda> t. convertback_rule (DeriveFromTree t)) T) b'' b" using list_all2_mono by fastforce
  with list_all2_map2 have 2:"map (\<lambda> t. convertback_rule (DeriveFromTree t)) b = map DeriveFromTree b''" by force
  then have "map fst (map (\<lambda> t. convertback_rule (DeriveFromTree t)) b) = map fst (map DeriveFromTree b'')" by simp
  then have "map (\<lambda> t. fst (convertback_rule (DeriveFromTree t))) b = map (\<lambda> t. fst (DeriveFromTree t)) b''"
    using map_map [where ?f="fst" and ?g="(\<lambda> t. convertback_rule (DeriveFromTree t))" and ?xs="b"]
    map_map [where ?f="fst" and ?g="DeriveFromTree" and ?xs="b''"] sorry (*Composition weird*)
  then have "map (\<lambda> t . convert_back (fst (DeriveFromTree t))) b = map (\<lambda> t. fst (DeriveFromTree t)) b''"
    using map_map convertback_rule_split by auto
  then have "map convert_back (map (\<lambda> t . fst (DeriveFromTree t)) b) = map (\<lambda> t. fst (DeriveFromTree t)) b''"
      using map_map [where ?f="convert_back" and ?g="\<lambda> t. fst (DeriveFromTree t)"] sorry (*again composition*)
  then have valid_subtrees':"convert_back_sentence \<alpha> = concat (map TreeSym b'')" using TreeSym_equal_DeriveFrom_root''
    \<alpha>_def by auto
  from DT.prems(2) have a_def:"a = (concat( map (\<lambda>subtree . (snd (DeriveFromTree subtree))) b))" by simp

  from 2 have "map snd (map (\<lambda> t. convertback_rule (DeriveFromTree t)) b) = map snd (map DeriveFromTree b'')" by simp
  then have "map (\<lambda> t. snd (convertback_rule (DeriveFromTree t))) b = map (\<lambda> t. snd (DeriveFromTree t)) b''"
    using map_map [where ?f="fst"] sorry (*should jus be this rule application*)
  then have subderiv_eq:"map (\<lambda> t . convert_back_sentence (snd (DeriveFromTree t))) b = map (\<lambda> t. snd (DeriveFromTree t)) b''"
    using map_map convertback_rule_split by auto
   then have "map convert_back_sentence (map (\<lambda> t . snd (DeriveFromTree t)) b) = map (\<lambda> t. snd (DeriveFromTree t)) b''"
      using map_map [where ?f="convert_back" and ?g="\<lambda> t. fst (DeriveFromTree t)"] sorry
  (*using concat_map or something*)
  from map_concat [where ?f="convert_back" and ?xs="(map (\<lambda> t . snd (DeriveFromTree t)) b)"]
  have "convert_back_sentence a = (concat( map (convert_back_sentence )
     (map (\<lambda>subtree .  (snd (DeriveFromTree subtree))) b)))"
     by (metis convert_back_sentence.simps map_eq_conv a_def)
  then have deriv:"convert_back_sentence a = (concat( map (\<lambda>subtree . (convert_back_sentence (snd (DeriveFromTree subtree)))) b))"
     using map_map [where ?f="convert_back_sentence" and ?g="(\<lambda>subtree .  (snd (DeriveFromTree subtree)))" and ?xs="b"] sorry
     (*using \<open>map (\<lambda>t. convert_back_sentence (snd (DeriveFromTree t))) b = map (\<lambda>t. snd (DeriveFromTree t)) b''\<close>
       \<open>map convert_back_sentence (map (\<lambda>t. snd (DeriveFromTree t)) b) = map (\<lambda>t. snd (DeriveFromTree t)) b''\<close> by presburger
     *)
   then have derive':"convert_back_sentence a = (concat( map (\<lambda>subtree . (snd (DeriveFromTree subtree))) b''))"
     using subderiv_eq by simp
  obtain T' where tree:"T' = (DT (convert_back N, convert_back_sentence \<alpha>) b'')" by blast
  then have wf:"Tree_wf T'" using valid_rule valid_subtrees'  wf_subtrees by auto
   from na have "N = s" using DT.prems(2) by simp
  with tree derive' have "DeriveFromTree T' = (convert_back s, convert_back_sentence a)" by simp
  with wf show ?case by auto
qed

fun convert_tree::"('a \<times> nat, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree" where
"convert_tree (Leaf s) = Leaf (convert_back s)"|
"convert_tree (Inner s) = Inner (convert_back s)"|
"convert_tree (DT r b) = DT (convertback_rule r) (map convert_tree b)"

lemma equality':"Tree_wf T \<Longrightarrow> \<exists> T' . grammar2.Tree_wf T'
  \<and> T = (convert_tree T') \<and> (fst (DeriveFromTree T')) = convert 0 (fst (DeriveFromTree T))
    \<and> (snd (DeriveFromTree T')) = map (convert 0) (snd (DeriveFromTree T)) "
proof (induction T)
  case (Leaf x)
  then have 1:"is_terminal x" by simp
  from 1 have "grammar2.is_terminal (convert 0 x)" using terminal_equality' by blast
  then have 2:"grammar2.Tree_wf (Leaf (convert 0 x))" by simp
  have 3:"convert_back (convert 0 x) = x" by (metis backconversion)
  then show ?case using 2 by fastforce
next
  case (Inner x)
  then have 1:"is_nonterminal x" by simp
  from 1 have "grammar2.is_nonterminal (convert 0 x)" using nonterminal_equality' by blast
  then have 2:"grammar2.Tree_wf (Inner (convert 0 x))" by simp
  have 3:"convert_back (convert 0 x) = x" by (metis backconversion)
  then show ?case using 2 by fastforce
next
  case (DT r b)
  then have r:"r \<in> \<RR> \<and> snd r = (map (\<lambda> t. (fst (DeriveFromTree t))) b)"
      by (simp add :TreeSym_equal_DeriveFrom_root'')
  obtain N \<alpha> where na:"(N, \<alpha>) = r" apply(cases r) by blast
  with r have valid_rule:"(convert 0 N, map (convert 0) \<alpha>) \<in> rules" using rule_equality' by blast
  have convertback:"convertback_rule (convert 0 N, map (convert 0) \<alpha>) = r" using na
    by (metis backconversion backconversion_sen convertback_rule.simps)
  (*subtrees*)
  from DT(2) have "list_all Tree_wf b" by simp
  then have "list_all ( \<lambda> t. \<exists>T'. grammar2.Tree_wf T' \<and> t = convert_tree T' \<and>
    fst (DeriveFromTree T') = convert 0 (fst (DeriveFromTree t))
      \<and> snd (DeriveFromTree T') = map (convert 0) (snd (DeriveFromTree t))) b"
    using DT(1) list.pred_mono_strong by force
  then obtain b' where b':"list_all2 ( \<lambda>T' t.  grammar2.Tree_wf T' \<and> t = convert_tree T' \<and>
    fst (DeriveFromTree T') = convert 0 (fst (DeriveFromTree t))
    \<and> snd (DeriveFromTree T') = map (convert 0) (snd (DeriveFromTree t)))b' b" using implied_existence' by fast
  then have 1:"list_all grammar2.Tree_wf b'" and 2:"list_all2 ( \<lambda>T' t.   convert_tree T' = t)b' b"
    and 3:"list_all2 ( \<lambda>T' t. fst (DeriveFromTree T') = convert 0 (fst (DeriveFromTree t)) ) b' b"
    and sndderiv:"list_all2 ( \<lambda>T' t. snd (DeriveFromTree T') = map (convert 0) (snd (DeriveFromTree t)) ) b' b"
      apply (metis (no_types, lifting) list_all2_implies_list_all list_all2_implies)
    using b' list_all2_implies apply fast using b' list_all2_implies apply fast using list_all2_implies b' by fast
  from 2 list_all2_map have 4:"map convert_tree b' = b" by blast
  from 3 have "map (\<lambda> t. fst (DeriveFromTree t)) b' = map (\<lambda> t. convert 0 (fst (DeriveFromTree t))) b"
    by (metis list_all2_map2)
  then have "concat (map grammar2.TreeSym b') = map (convert 0) (map (\<lambda> t. (fst (DeriveFromTree t))) b)"
    using map_map grammar2.TreeSym_equal_DeriveFrom_root'' by simp
  then have subtree_deriv:"concat (map grammar2.TreeSym b') = map (convert 0)  \<alpha>" using na r by auto
  from sndderiv have "map (\<lambda> t. snd (DeriveFromTree t)) b' = map (\<lambda> t. map (convert 0) (snd (DeriveFromTree t))) b"
    by (metis list_all2_map2)
  then have "(map (\<lambda> t. snd (DeriveFromTree t)) b') = map (\<lambda> t. map (convert 0) (snd (DeriveFromTree t))) b" by blast
  with  map_map have "(map (\<lambda> t. snd (DeriveFromTree t)) b') = map (map (convert 0)) (map (\<lambda> t. (snd (DeriveFromTree t))) b)"
    by auto
  then have "concat (map (\<lambda> t. snd (DeriveFromTree t)) b') = concat (map
      (map (convert 0)) (map (\<lambda> t. (snd (DeriveFromTree t))) b))" by simp
  with map_concat have final:"concat (map (\<lambda> t. snd (DeriveFromTree t)) b') = map (convert 0)
    (concat (map (\<lambda> t. snd (DeriveFromTree t)) b))" by metis
  obtain T where T:"T = DT (convert 0 N, map (convert 0) \<alpha>) b'" by blast
  then have wf:"grammar2.Tree_wf T" using valid_rule subtree_deriv 1 by auto
  from convertback 4 T have conv:"convert_tree T = (DT r b)" by simp
  from T na have root:"fst (DeriveFromTree T) = convert 0 (fst (DeriveFromTree (DT r b)))" by auto
  from T na final have deriv:"snd (DeriveFromTree T) = map (convert 0) (snd (DeriveFromTree (DT r b)))" by auto
  then show ?case using wf conv root by auto
qed

lemma terminal_equality2_help:"grammar2.is_terminal x \<Longrightarrow> (is_terminal \<circ> convert_back) x"
  using terminal_equality by simp

lemma grammar2_is_word_implies_is_word:"grammar2.is_word xa \<Longrightarrow> is_word (convert_back_sentence xa)"
  apply(simp add: grammar2.is_word_def is_word_def)
  using terminal_equality2_help list_all_map [where ?f="is_terminal" and ?g="convert_back" and ?b="xa"]
    list_all_implies list.pred_map by blast

lemma grammar2_derivations:
  assumes "grammar2.is_derivation xa"
  shows "is_derivation  (convert_back_sentence xa)"
proof -
  from assms obtain T where" DeriveFromTree T = (grammar2.\<SS>, xa) \<and> grammar2.Tree_wf T"
    by (auto simp add: grammar2.is_derivation_def dest!: grammar2.derives_implies_Derivation grammar2.DerivationSymbol_implies_DerivTree
        [OF _ grammar2.\<SS>_symbol])
  then obtain T' where "Tree_wf T' \<and> DeriveFromTree T' = (\<SS>,
    convert_back_sentence xa)"  by (metis equality start_conversion')
  then show ?thesis using DerivationTree_implies_Derivation
      Derivation_implies_derives is_derivation_def by fastforce
qed

lemma grammar2_is_word_derivations:"grammar2.is_word xa \<Longrightarrow> grammar2.is_derivation xa \<Longrightarrow>
  is_derivation (convert_back_sentence xa) \<and> is_word (convert_back_sentence xa)"
  using  grammar2_is_word_implies_is_word grammar2_derivations by auto

lemma terminal_equality2_help':"is_terminal x \<Longrightarrow> (grammar2.is_terminal \<circ> (convert 0)) x"
  using terminal_equality' by simp

lemma is_word_implies_grammar2_is_word:"is_word xa \<Longrightarrow> grammar2.is_word (map (convert 0) xa)"
  apply(simp add: grammar2.is_word_def is_word_def del: convert.simps)
  using terminal_equality2_help' list_all_map [where ?f="grammar2.is_terminal" and ?g="convert 0" and ?b="xa"]
    list_all_implies list.pred_map by blast

lemma word_derivat:
  assumes "DeriveFromTree tree = (\<SS>, xa) " "Tree_wf tree"
   (*would use completeness lemma*)
  shows "grammar2.is_derivation  (map (convert 0) xa)"
proof -
  from assms obtain T' where T':"grammar2.Tree_wf T'
  \<and> tree = (convert_tree T') \<and> (fst (DeriveFromTree T')) = convert 0 \<SS> \<and>
    (snd (DeriveFromTree T'))  = map (convert 0) xa" using equality' by force
  then have "DeriveFromTree T'= (grammar2.\<SS>, map (convert 0) xa)"
    by (metis prod.collapse start_conversion)
  then show ?thesis using T' grammar2.DerivationTree_implies_Derivation
      grammar2.Derivation_implies_derives grammar2.is_derivation_def by fastforce
 qed

lemma grammar2_is_word_derivations':"is_word xa \<Longrightarrow> DeriveFromTree tree = (\<SS>, xa)  \<Longrightarrow>Tree_wf tree \<Longrightarrow>
  grammar2.is_word (map (convert 0)xa ) \<and> grammar2.is_derivation (map (convert 0) xa)"
  using word_derivat is_word_implies_grammar2_is_word by blast

lemma is_word_projr:"is_word xa \<Longrightarrow> map projr xa = map projr (map (convert 0) xa)"
  apply(auto simp add: is_word_def is_terminal_def)
  by (metis old.sum.simps(5) old.sum.simps(6) projr_def sum.exhaust_sel)

lemma is_word_projr':"grammar2.is_word xa \<Longrightarrow> map projr xa = map projr (convert_back_sentence xa)"
  apply(auto simp add: grammar2.is_word_def grammar2.is_terminal_def)
   by (metis old.sum.simps(5) old.sum.simps(6) projr_def sum.exhaust_sel)

theorem grammar2_eq:"grammar2.\<L>_t = \<L>_t"
 apply(auto simp add: \<L>_t_def grammar2.\<L>_t_def  \<L>_def  grammar2.\<L>_def is_derivation_def
      dest!: derives_implies_Derivation DerivationSymbol_implies_DerivTree [OF _ \<SS>_symbol])
  using grammar2_is_word_derivations is_word_projr' is_derivation_def apply fast
  apply(auto simp add: grammar2.is_derivation_def
        dest!: grammar2.derives_implies_Derivation grammar2.DerivationSymbol_implies_DerivTree  )
  using grammar2_is_word_derivations' is_word_projr grammar2.is_derivation_def by blast

end
(*main invariant of rewriting:*)
end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               February 2005               |
            |                   June 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_ufp
imports CSP_T_continuous CSP_T_contraction CSP_T_mono CSP_T_law_decompo
begin

(*****************************************************************

         1. cms fixed point theory in CSP-Prover
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*=======================================================*
 |                                                       |
 |                        CMS                            |
 |                                                       |
 *=======================================================*)

(*-------------*
 |  existency  |
 *-------------*)

lemma semT_hasUFP_cms:
 "[| Pf = PNfun ; guardedfun (Pf) |]
  ==> [[Pf]]Tfun hasUFP"
apply (rule Banach_thm_EX)
apply (rule contraction_semTfun)
apply (simp)
done

lemma semT_UFP_cms:
  "[| Pf = PNfun ;
      guardedfun (Pf) ;
      FPmode = CMSmode |]
  ==> [[$p]]T = UFP [[Pf]]Tfun p"
apply (simp add: semT_def semTf_def)
apply (simp add: traces_iff)
apply (simp add: MT_def)
apply (simp add: semTfix_def)
done

lemma semT_UFP_fun_cms:
  "[| Pf = PNfun ;
      guardedfun (Pf) ;
      FPmode = CMSmode |]
  ==> (%p. [[$p]]T) = UFP [[Pf]]Tfun"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semT_UFP_cms)
done

(*---------*
 |    MT   |
 *---------*)

lemma MT_fixed_point_cms:
      "[| (Pf::'p=>('p,'a) proc) = PNfun; guardedfun Pf ; FPmode = CMSmode|]
        ==> [[Pf]]Tfun (MT::'p => 'a domT) = (MT::'p => 'a domT)"
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (rule UFP_fp)
apply (simp add: semT_hasUFP_cms)
done

(*---------*
 |  unique |
 *---------*)

lemma ALL_cspT_unique_cms:
  "[| Pf = PNfun ; guardedfun Pf ;
       FPmode = CMSmode ;
       ALL p. (Pf p) << f =T f p |] ==> ALL p. f p =T $p"
apply (simp add: cspT_semantics)
apply (simp add: fun_eq_iff[THEN sym])
apply (rule hasUFP_unique_solution[of "[[PNfun]]Tfun"])
apply (simp add: semT_hasUFP_cms)

apply (simp add: traces_subst)
apply (simp add: semTfun_def semTf_def)

apply (fold semTf_def semT_def)
apply (simp add: semT_UFP_fun_cms)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

lemma cspT_unique_cms:
  "[| Pf = PNfun ; guardedfun Pf ;
       FPmode = CMSmode ;
       ALL p. (Pf p) << f =T f p |] ==> f p =T $p"
by (simp add: ALL_cspT_unique_cms)

(*-------------------------------------------------------*
 |                                                       |
 |           Fixpoint unwind (CSP-Prover rule)           |
 |                                                       |
 *-------------------------------------------------------*)

lemma ALL_cspT_unwind_cms:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode |]
     ==> ALL p. ($p =T Pf p)"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: traces_semTfun)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

(*  csp law  *)

lemma cspT_unwind_cms:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode |]
     ==> $p =T Pf p"
by (simp add: ALL_cspT_unwind_cms)

(*-------------------------------------------------------*
 |                                                       |
 |    fixed point inducntion (CSP-Prover intro rule)     |
 |                                                       |
 *-------------------------------------------------------*)

(*----------- refinement -----------*)

(*** left ***)

lemma cspT_fp_induct_cms_ref_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p <=T Q ;
       ALL p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
apply (simp add: refT_semT)
apply (insert cms_fixpoint_induction_ref
       [of "[[Pf]]Tfun" "(%p. [[f p]]T)" "UFP [[Pf]]Tfun"])
apply (simp add: UFP_fp semT_hasUFP_cms)
apply (simp add: fold_order_prod_def)
apply (simp add: semT_subst_semTfun)
apply (simp add: mono_semTfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semTfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+
apply (simp add: semT_UFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_cms_ref_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p <=T Q;
       !! p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
by (simp add: cspT_fp_induct_cms_ref_left_ALL)

(*** right ***)

lemma cspT_fp_induct_cms_ref_right_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q <=T f p;
       ALL p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
apply (simp add: refT_semT)
apply (insert cms_fixpoint_induction_rev
       [of "[[Pf]]Tfun" "(%p. [[f p]]T)" "UFP [[Pf]]Tfun"])
apply (simp add: UFP_fp semT_hasUFP_cms)
apply (simp add: fold_order_prod_def)
apply (simp add: semT_subst_semTfun)
apply (simp add: mono_semTfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semTfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+

apply (simp add: semT_UFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_cms_ref_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q <=T f p;
       !! p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
by (simp add: cspT_fp_induct_cms_ref_right_ALL)

(*----------- equality -----------*)

(*** left ***)

lemma cspT_fp_induct_cms_eq_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p =T Q ;
       ALL p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
apply (simp add: eqT_semT)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semT_subst_semTfun)
apply (insert semT_UFP_fun_cms[of Pf])
apply (simp)
apply (subgoal_tac "(%p. [[$p]]T) = (%p. [[f p]]T)")
apply (simp add: fun_eq_iff)

apply (rule hasUFP_unique_solution[of "[[Pf]]Tfun"])
apply (simp_all add: semT_hasUFP_cms)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_cms_eq_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       f p =T Q ;
       !! p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
by (simp add: cspT_fp_induct_cms_eq_left_ALL)

lemma cspT_fp_induct_cms_eq_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = CMSmode ;
       Q =T f p;
       !! p. f p =T (Pf p)<<f |]
    ==> Q =T $p"
apply (rule cspT_sym)
apply (rule cspT_fp_induct_cms_eq_left[of Pf f p Q])
apply (simp_all)
apply (rule cspT_sym)
apply (simp)
apply (rule cspT_sym)
apply (simp)
done

lemmas cspT_fp_induct_cms_left
     = cspT_fp_induct_cms_ref_left cspT_fp_induct_cms_eq_left

lemmas cspT_fp_induct_cms_right
     = cspT_fp_induct_cms_ref_right cspT_fp_induct_cms_eq_right

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(* 2017
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end