(*  Title:      List2.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

header {* Additional definitions and results for lists *}

theory List2
imports "../CommonSet/SetIntervalCut"
begin

subsection {* Additional definitions and results for lists *}

text {*
  Infix syntactical abbreviations for operators @{term take} and @{term drop}.
  The abbreviations resemble to the operator symbols used later
  for take and drop operators on infinite lists in ListInf. *}

(*
syntax (xsymbols)
  "_f_take" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" (infixl "\<down>" 100)
  "_f_drop" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" (infixl "\<up>" 100)
translations
  "xs \<down> n" \<rightleftharpoons> "CONST take n xs"
  "xs \<up> n" \<rightleftharpoons> "CONST drop n xs"
*)

abbreviation (xsymbols)
  "f_take'" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" (infixl "\<down>" 100)
where
  "xs \<down> n \<equiv> take n xs"
abbreviation (xsymbols)
  "f_drop'" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" (infixl "\<up>" 100)
where
  "xs \<up> n \<equiv> drop n xs"
syntax (HTML output)
  "f_take'" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list"   (infixl "\<down>" 100)
  "f_drop'" :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list"   (infixl "\<up>" 100)

term "xs \<down> n"
term "xs \<up> n"

thm List.append_Cons
lemma append_eq_Cons: "[x] @ xs = x # xs"
by simp

lemma length_Cons: "length (x # xs) = Suc (length xs)"
by simp
lemma length_snoc: "length (xs @ [x]) = Suc (length xs)"
by simp

subsubsection {* Additional lemmata about list emptiness *}

lemma length_greater_imp_not_empty:"n < length xs \<Longrightarrow> xs \<noteq> []"
by fastforce

lemma length_ge_Suc_imp_not_empty:"Suc n \<le> length xs \<Longrightarrow> xs \<noteq> []"
by fastforce
thm length_take

lemma length_take_le: "length (xs \<down> n) \<le> length xs"
by simp

lemma take_not_empty_conv:"(xs \<down> n \<noteq> []) = (0 < n \<and> xs \<noteq> [])"
by simp

lemma drop_not_empty_conv:"(xs \<up> n \<noteq> []) = (n < length xs)"
by fastforce

lemma zip_not_empty_conv: "(zip xs ys \<noteq> []) = (xs \<noteq> [] \<and> ys \<noteq> [])"
by (simp add: zip_eq_Nil)

subsubsection {* Additional lemmata about @{term take}, @{term drop}, @{term hd}, @{term last}, @{text nth} and @{text filter}  *}

lemma nth_tl_eq_nth_Suc: "
  Suc n \<le> length xs \<Longrightarrow> (tl xs) ! n = xs ! Suc n"
thm hd_Cons_tl[OF length_ge_Suc_imp_not_empty, THEN subst]
by (rule hd_Cons_tl[OF length_ge_Suc_imp_not_empty, THEN subst], simp+)
corollary nth_tl_eq_nth_Suc2: "
  n < length xs \<Longrightarrow> (tl xs) ! n = xs ! Suc n"
by (simp add: nth_tl_eq_nth_Suc)

lemma hd_eq_first: "xs \<noteq> [] \<Longrightarrow> xs ! 0 = hd xs"
by (induct xs, simp_all)
corollary take_first:"xs \<noteq> [] \<Longrightarrow> xs \<down>  (Suc 0) = [xs ! 0]"
by (induct xs, simp_all)
corollary take_hd:"xs \<noteq> [] \<Longrightarrow> xs \<down>  (Suc 0) = [hd xs]"
by (simp add: take_first hd_eq_first)

thm last_conv_nth
theorem last_nth: "xs \<noteq> [] \<Longrightarrow> last xs = xs ! (length xs - Suc 0)"
by (simp add: last_conv_nth)

lemma last_take: "n < length xs \<Longrightarrow> last (xs \<down> Suc n) = xs ! n"
by (simp add: last_nth length_greater_imp_not_empty min_eqR)
corollary last_take2:"
  \<lbrakk> 0 < n; n \<le> length xs \<rbrakk> \<Longrightarrow> last (xs \<down> n) = xs ! (n - Suc 0)"
thm diff_Suc_less[THEN order_less_le_trans]
apply (frule diff_Suc_less[THEN order_less_le_trans, of _ "length xs" 0], assumption)
thm last_take[of "n - Suc 0" xs]
apply (drule last_take[of "n - Suc 0" xs])
apply simp
done

thm List.nth_drop
corollary nth_0_drop: "n \<le> length xs \<Longrightarrow> (xs \<up> n) ! 0 = xs ! n"
by (cut_tac nth_drop[of n 0 xs], simp+)
corollary hd_drop: "n < length xs \<Longrightarrow> hd (xs \<up> n) = xs ! n"
apply (frule drop_not_empty_conv[THEN iffD2])
apply (simp add: hd_eq_first[symmetric])
done

lemma drop_eq_tl: "xs \<up> (Suc 0) = tl xs"
by (simp add: drop_Suc)

lemma drop_take_1: "
  n < length xs \<Longrightarrow> xs \<up> n \<down> (Suc 0) = [xs ! n]"
thm take_hd hd_drop
by (simp add: take_hd hd_drop)

lemma upt_append: "m \<le> n \<Longrightarrow> [0..<m] @ [m..<n] = [0..<n]"
thm upt_add_eq_append[of 0 m "n - m"]
by (insert upt_add_eq_append[of 0 m "n - m"], simp)

thm nth_append
lemma nth_append1: "n < length xs \<Longrightarrow> (xs @ ys) ! n = xs ! n"
by (simp add: nth_append)
lemma nth_append2: "length xs \<le> n \<Longrightarrow> (xs @ ys) ! n = ys ! (n - length xs)"
by (simp add: nth_append)

lemma list_all_conv: "list_all P xs = (\<forall>i<length xs. P (xs ! i))"
by (rule list_all_length)

lemma expand_list_eq: "
  \<And>ys. (xs = ys) = (length xs = length ys \<and> (\<forall>i<length xs. xs ! i = ys ! i))"
by (rule list_eq_iff_nth_eq)
lemmas list_eq_iff = expand_list_eq

lemma list_take_drop_imp_eq: "
  \<lbrakk> xs \<down> n = ys \<down> n;  xs \<up> n = ys \<up> n \<rbrakk> \<Longrightarrow> xs = ys"
apply (rule subst[OF append_take_drop_id[of n xs]])
apply (rule subst[OF append_take_drop_id[of n ys]])
apply simp
done

lemma list_take_drop_eq_conv: "
  (xs = ys) = (\<exists>n. (xs \<down> n = ys \<down> n \<and> xs \<up> n = ys \<up> n))"
by (blast intro: list_take_drop_imp_eq)

lemma list_take_eq_conv: "(xs = ys) = (\<forall>n. xs \<down> n = ys \<down> n)"
apply (rule iffI, simp)
apply (drule_tac x="max (length xs) (length ys)" in spec)
apply simp
done

abbreviation (xsymbols)
  "replicate'" :: "'a \<Rightarrow> nat \<Rightarrow> 'a list" ("_\<^bsup>_\<^esup>" [1000,65])
where
  "x\<^bsup>n\<^esup> \<equiv> replicate n x"

term "length x\<^bsup>(a+b)\<^esup>"

thm List.replicate_Suc
thm List.replicate_app_Cons_same
lemma replicate_snoc: "x\<^bsup>n\<^esup> @ [x] = x\<^bsup>Suc n\<^esup>"
by (simp add: replicate_app_Cons_same)

thm List.nth_replicate
lemma eq_replicate_conv: "(\<forall>i<length xs. xs ! i = m) = (xs = m\<^bsup>length xs\<^esup>)"
apply (rule iffI)
 apply (simp add: expand_list_eq)
apply clarsimp
apply (rule ssubst[of xs "replicate (length xs) m"], assumption)
apply (rule nth_replicate, simp)
done

lemma replicate_Cons_length: "length (x # a\<^bsup>n\<^esup>) = Suc n"
by simp
lemma replicate_pred_Cons_length: "0 < n \<Longrightarrow> length (x # a\<^bsup>n - Suc 0\<^esup>) = n"
by simp

thm replicate_add
lemma replicate_le_diff: "m \<le> n \<Longrightarrow> x\<^bsup>m\<^esup> @ x\<^bsup>n - m\<^esup> = x\<^bsup>n\<^esup>"
by (simp add: replicate_add[symmetric])
lemma replicate_le_diff2: "\<lbrakk> k \<le> m; m \<le> n \<rbrakk> \<Longrightarrow> x\<^bsup>m - k\<^esup> @ x\<^bsup>n - m\<^esup> = x\<^bsup>n - k\<^esup>"
by (subst replicate_add[symmetric], simp)

thm list.induct
lemma append_constant_length_induct_aux: "\<And>xs.
  \<lbrakk> length xs div k = n; \<And>ys. k = 0 \<or> length ys < k \<Longrightarrow> P ys;
    \<And>xs ys. \<lbrakk> length xs = k; P ys \<rbrakk> \<Longrightarrow> P (xs @ ys) \<rbrakk> \<Longrightarrow> P xs"
apply (case_tac "k = 0", blast)
apply simp
apply (induct n)
 apply (simp add: div_eq_0_conv')
apply (subgoal_tac "k \<le> length xs")
 prefer 2
 apply (rule div_gr_imp_gr_divisor[of 0], simp)
apply (simp only: atomize_all atomize_imp, clarsimp)
apply (erule_tac x="drop k xs" in allE)
apply (simp add: div_diff_self2)
apply (erule_tac x=undefined in allE)
apply (erule_tac x="take k xs" in allE)
apply (simp add: min_eqR)
apply (erule_tac x="drop k xs" in allE)
apply simp
done

lemma append_constant_length_induct: "
  \<lbrakk> \<And>ys. k = 0 \<or> length ys < k \<Longrightarrow> P ys;
    \<And>xs ys. \<lbrakk> length xs = k; P ys \<rbrakk> \<Longrightarrow> P (xs @ ys) \<rbrakk> \<Longrightarrow> P xs"
by (simp add: append_constant_length_induct_aux[of _ _ "length xs div k"])

lemma zip_swap: "map (\<lambda>(y,x). (x,y)) (zip ys xs) = (zip xs ys)"
by (simp add: expand_list_eq)

lemma zip_takeL: "(zip xs ys) \<down> n = zip (xs \<down> n) ys"
by (simp add: expand_list_eq)

lemma zip_takeR: "(zip xs ys) \<down> n = zip xs (ys \<down> n)"
thm zip_swap[of ys]
apply (subst zip_swap[of ys, symmetric])
apply (subst take_map)
apply (subst zip_takeL)
apply (simp add: zip_swap)
done

lemma zip_take: "(zip xs ys) \<down> n = zip (xs \<down> n) (ys \<down> n)"
by (rule take_zip)

thm nth_zip
lemma hd_zip: "\<lbrakk> xs \<noteq> []; ys \<noteq> [] \<rbrakk> \<Longrightarrow> hd (zip xs ys) = (hd xs, hd ys)"
by (simp add: hd_conv_nth zip_not_empty_conv)

lemma map_id: "map id xs = xs"
by (simp add: id_def)

lemma map_id_subst: "P (map id xs) \<Longrightarrow> P xs"
by (subst map_id[symmetric])

lemma map_one: "map f [x] = [f x]"
by simp

lemma map_last: "xs \<noteq> [] \<Longrightarrow> last (map f xs) = f (last xs)"
by (rule last_map)

lemma filter_list_all: "list_all P xs \<Longrightarrow> filter P xs = xs"
by (induct xs, simp+)

lemma filter_snoc: "filter P (xs @ [x]) = (if P x then (filter P xs) @ [x] else filter P xs)"
by (case_tac "P x", simp+)

lemma filter_filter_eq: "list_all (\<lambda>x. P x = Q x) xs \<Longrightarrow> filter P xs = filter Q xs"
by (induct xs, simp+)

lemma filter_nth: "\<And>n.
  n < length (filter P xs) \<Longrightarrow>
  (filter P xs) ! n =
  xs ! (LEAST k.
    k < length xs \<and>
    n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)})"
apply (induct xs rule: rev_induct, simp)
apply (rename_tac x xs n)
thm filter_snoc
apply (simp only: filter_snoc)
apply (simp split del: split_if)
apply (case_tac "xs = []")
 apply (simp split del: split_if)
 apply (rule_tac
   t = "\<lambda>k i. i = 0 \<and> i \<le> k \<and> P ([x] ! i)" and
   s = "\<lambda>k i. i = 0 \<and> P x"
   in subst)
  apply (simp add: fun_eq_iff)
  apply fastforce
 apply (fastforce simp: Least_def)
apply (rule_tac
  t = "\<lambda>k. card {i. i \<le> k \<and> i < Suc (length xs) \<and> P ((xs @ [x]) ! i)}" and
  s = "\<lambda>k. (card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)} +
           (if k \<ge> length xs \<and> P x then Suc 0 else 0))"
  in subst)
 apply (clarsimp simp: fun_eq_iff split del: split_if, rename_tac k)
 apply (simp split del: split_if add: less_Suc_eq conj_disj_distribL conj_disj_distribR Collect_disj_eq)
 apply (subst card_Un_disjoint)
    apply (rule_tac n="length xs" in bounded_nat_set_is_finite, blast)
   apply (rule_tac n="Suc (length xs)" in bounded_nat_set_is_finite, blast)
  apply blast
 apply (rule_tac
   t = "\<lambda>i. i < length xs \<and> P ((xs @ [x]) ! i)" and
   s = "\<lambda>i. i < length xs \<and> P (xs ! i)"
   in subst)
  apply (rule fun_eq_iff[THEN iffD2])
  apply (fastforce simp: nth_append1)
 apply (rule nat_add_left_cancel[THEN iffD2])
 apply (rule_tac
   t = "\<lambda>i. i = length xs \<and> i \<le> k \<and> P ((xs @ [x]) ! i)" and
   s = "\<lambda>i. i = length xs \<and> i \<le> k \<and> P x"
   in subst)
  apply (rule fun_eq_iff[THEN iffD2])
  apply fastforce
 apply (case_tac "length xs \<le> k")
  apply clarsimp
  apply (rule_tac
    t = "\<lambda>i. i = length xs \<and> i \<le> k" and
    s = "\<lambda>i. i = length xs"
    in subst)
   apply (rule fun_eq_iff[THEN iffD2])
   apply fastforce
  apply simp
 apply simp
apply (simp split del: split_if add: less_Suc_eq conj_disj_distribL conj_disj_distribR)
apply (rule_tac
  t = "\<lambda>k. k < length xs \<and>
           n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)} + (if length xs \<le> k \<and> P x then Suc 0 else 0)" and
  s = "\<lambda>k. k < length xs \<and> n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)}"
  in subst)
 apply (simp add: fun_eq_iff)
apply (rule_tac
  t = "\<lambda>k. k = length xs \<and>
           n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)} + (if length xs \<le> k \<and> P x then Suc 0 else 0)" and
  s = "\<lambda>k. k = length xs \<and>
           n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)} + (if P x then Suc 0 else 0)"
  in subst)
 apply (simp add: fun_eq_iff)
apply (case_tac "n < length (filter P xs)")
 apply (rule_tac
   t = "(if P x then filter P xs @ [x] else filter P xs) ! n" and
   s = "(filter P xs) ! n"
   in subst)
  apply (simp add: nth_append1)
 apply (simp split del: split_if)
 apply (subgoal_tac "\<exists>k<length xs. n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)}")
  prefer 2
  apply (rule_tac x="length xs - Suc 0" in exI)
  apply (simp add: length_filter_conv_card less_eq_le_pred[symmetric])
 apply (subgoal_tac "\<exists>k\<le>length xs. n < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)}")
  prefer 2
  apply (blast intro: less_imp_le)
 thm Least_le_imp_le_disj
 apply (subst Least_le_imp_le_disj)
   apply simp
  apply simp
 thm nth_append1
 apply (rule sym, rule nth_append1)
 apply (rule LeastI2_ex, assumption)
 apply blast
apply (simp add: linorder_not_less)
apply (subgoal_tac "P x")
 prefer 2
 apply (rule ccontr, simp)
apply (simp add: length_snoc)
apply (drule less_Suc_eq_le[THEN iffD1], drule_tac x=n in order_antisym, assumption)
apply (simp add: nth_append2)
thm length_filter_conv_card
apply (simp add: length_filter_conv_card)
apply (rule_tac
  t = "\<lambda>k. card {i. i < length xs \<and> P (xs ! i)} < card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)}" and
  s = "\<lambda>k. False"
  in subst)
 apply (rule fun_eq_iff[THEN iffD2], rule allI, rename_tac k)
 apply (simp add: linorder_not_less)
 apply (rule card_mono)
  apply fastforce
 apply blast
apply simp
apply (rule_tac
  t = "(LEAST k. k = length xs \<and>
                 card {i. i < length xs \<and> P (xs ! i)} < Suc (card {i. i \<le> k \<and> i < length xs \<and> P (xs ! i)}))" and
  s = "length xs"
  in subst)
 apply (rule sym, rule Least_equality)
  apply simp
  apply (rule le_imp_less_Suc)
  apply (rule card_mono)
   apply fastforce
  apply fastforce
 apply simp
apply simp
done

subsubsection {* Ordered lists *}

fun
  list_ord :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a::ord) list \<Rightarrow> bool"
where
  "list_ord ord (x1 # x2 # xs) = (ord x1 x2 \<and> list_ord ord (x2 # xs))"
| "list_ord ord xs = True"

thm list_ord.simps
definition list_asc :: "('a::ord) list \<Rightarrow> bool" where
  "list_asc xs \<equiv> list_ord (op \<le>) xs"
definition list_strict_asc :: "('a::ord) list \<Rightarrow> bool" where
  "list_strict_asc xs \<equiv> list_ord (op <) xs"
value "list_asc  [1::nat, 2, 2]"
value "list_strict_asc  [1::nat, 2, 2]"
definition list_desc :: "('a::ord) list \<Rightarrow> bool" where
  "list_desc xs \<equiv> list_ord (op \<ge>) xs"
definition list_strict_desc :: "('a::ord) list \<Rightarrow> bool" where
  "list_strict_desc xs \<equiv> list_ord (op >) xs"

lemma list_ord_Nil: "list_ord ord []"
by simp
lemma list_ord_one: "list_ord ord [x]"
by simp
lemma list_ord_Cons: "
  list_ord ord (x # xs) =
  (xs = [] \<or> (ord x (hd xs) \<and> list_ord ord xs))"
by (induct xs, simp+)
lemma list_ord_Cons_imp: "\<lbrakk> list_ord ord xs; ord x (hd xs) \<rbrakk> \<Longrightarrow> list_ord ord (x # xs)"
by (induct xs, simp+)
lemma list_ord_append: "\<And>ys.
  list_ord ord (xs @ ys) =
  (list_ord ord xs \<and>
  (ys = [] \<or> (list_ord ord ys \<and> (xs = [] \<or> ord (last xs) (hd ys)))))"
apply (induct xs, fastforce)
apply (case_tac xs, case_tac ys, fastforce+)
done
lemma list_ord_snoc: "
  list_ord ord (xs @ [x]) =
  (xs = [] \<or> (ord (last xs) x \<and> list_ord ord xs))"
by (fastforce simp: list_ord_append)

lemma list_ord_all_conv: "
  (list_ord ord xs) = (\<forall>n < length xs - 1. ord (xs ! n) (xs ! Suc n))"
apply (rule iffI)
 apply (induct xs, simp)
 apply clarsimp
 apply (simp add: list_ord_Cons)
 apply (erule disjE, simp)
 apply clarsimp
 apply (case_tac n)
  apply (simp add: hd_conv_nth)
 apply simp
apply (induct xs, simp)
apply (simp add: list_ord_Cons)
apply (case_tac "xs = []", simp)
apply (drule meta_mp)
 apply (intro allI impI, rename_tac n)
 apply (drule_tac x="Suc n" in spec, simp)
apply (drule_tac x=0 in spec)
apply (simp add: hd_conv_nth)
done

lemma list_ord_imp: "
  \<lbrakk> \<And>x y. ord x y \<Longrightarrow> ord' x y; list_ord ord xs \<rbrakk> \<Longrightarrow>
  list_ord ord' xs"
apply (induct xs, simp)
apply (simp add: list_ord_Cons)
apply fastforce
done
corollary list_strict_asc_imp_list_asc: "
  list_strict_asc (xs::'a::preorder list) \<Longrightarrow> list_asc xs"
by (unfold list_strict_asc_def list_asc_def, rule list_ord_imp[of "op <"], rule order_less_imp_le)
corollary list_strict_desc_imp_list_desc: "
  list_strict_desc (xs::'a::preorder list) \<Longrightarrow> list_desc xs"
by (unfold list_strict_desc_def list_desc_def, rule list_ord_imp[of "op >"], rule order_less_imp_le)

lemma list_ord_trans_imp: "\<And>i.
  \<lbrakk> transP ord; list_ord ord xs; j < length xs; i < j \<rbrakk> \<Longrightarrow>
  ord (xs ! i) (xs ! j)"
apply (simp add: list_ord_all_conv)
apply (induct j, simp)
apply (case_tac "j < i", simp)
apply (simp add: linorder_not_less)
apply (case_tac "i = j", simp)
thm trans_def
apply (drule_tac x=i in meta_spec, simp)
apply (drule_tac x=j in spec, simp add: Suc_less_pred_conv)
apply (unfold trans_def)
apply (drule_tac x="xs ! i" in spec, drule_tac x="xs ! j" in spec, drule_tac x="xs ! Suc j" in spec)
apply simp
done

lemma list_ord_trans: "
  transP ord \<Longrightarrow>
  (list_ord ord xs) =
  (\<forall>j < length xs. \<forall>i < j. ord (xs ! i) (xs ! j))"
apply (rule iffI)
 apply (simp add: list_ord_trans_imp)
apply (simp add: list_ord_all_conv)
done

lemma list_ord_trans_refl_le: "
  \<lbrakk> transP ord; reflP ord \<rbrakk> \<Longrightarrow>
  (list_ord ord xs) =
  (\<forall>j < length xs. \<forall>i \<le> j. ord (xs ! i) (xs ! j))"
apply (subst list_ord_trans, simp)
apply (rule iffI)
 apply clarsimp
 apply (case_tac "i = j")
  apply (simp add: refl_on_def)
 apply simp+
done

lemma list_ord_trans_refl_le_imp: "
  \<lbrakk> transP ord; \<And>x y. ord x y \<Longrightarrow> ord' x y; reflP ord';
    list_ord ord xs \<rbrakk> \<Longrightarrow>
  (\<forall>j < length xs. \<forall>i \<le> j. ord' (xs ! i) (xs ! j))"
apply clarify
apply (case_tac "i = j")
 apply (simp add: refl_on_def)
thm list_ord_trans_imp
apply (simp add: list_ord_trans_imp)
done

corollary
  list_asc_trans: "
    (list_asc (xs::'a::preorder list)) =
    (\<forall>j < length xs. \<forall>i < j. xs ! i \<le> xs ! j)" and
  list_strict_asc_trans: "
    (list_strict_asc (xs::'a::preorder list)) =
    (\<forall>j < length xs. \<forall>i < j. xs ! i < xs ! j)" and
  list_desc_trans: "
    (list_desc (xs::'a::preorder list)) =
    (\<forall>j < length xs. \<forall>i < j. xs ! j \<le> xs ! i)" and
  list_strict_desc_trans: "
    (list_strict_desc (xs::'a::preorder list)) =
    (\<forall>j < length xs. \<forall>i < j. xs ! j < xs ! i)"
apply (unfold list_asc_def list_strict_asc_def list_desc_def list_strict_desc_def)
apply (rule list_ord_trans, unfold trans_def, blast intro: order_trans order_less_trans)+
done

corollary
  list_asc_trans_le: "
    (list_asc (xs::'a::preorder list)) =
    (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)" and
  list_desc_trans_le: "
    (list_desc (xs::'a::preorder list)) =
    (\<forall>j < length xs. \<forall>i \<le> j. xs ! j \<le> xs ! i)"
apply (unfold list_asc_def list_strict_asc_def list_desc_def list_strict_desc_def)
apply (rule list_ord_trans_refl_le, unfold trans_def, blast intro: order_trans, simp add: refl_on_def)+
done

corollary
  list_strict_asc_trans_le: "
    (list_strict_asc (xs::'a::preorder list)) \<Longrightarrow>
    (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"
apply (unfold list_strict_asc_def)
thm list_ord_trans_refl_le_imp
apply (rule list_ord_trans_refl_le_imp[where ord="op \<le>"])
   apply (unfold trans_def, blast intro: order_trans)
  apply assumption
 apply (unfold refl_on_def, clarsimp)
thm list_ord_imp
apply (rule list_ord_imp[where ord="op <"], simp_all add: less_imp_le)
done

lemma list_ord_le_sorted_eq: "list_asc xs = sorted xs"
apply (rule sym)
apply (simp add: list_asc_def)
apply (induct xs, simp)
apply (rename_tac x xs)
apply (simp add: list_ord_Cons sorted_Cons)
apply (case_tac "xs = []", simp_all)
apply (case_tac "list_ord op \<le> xs", simp_all)
apply (rule iffI)
 apply (drule_tac x="hd xs" in bspec, simp_all)
apply clarify
apply (drule in_set_conv_nth[THEN iffD1], clarsimp, rename_tac i1)
apply (simp add: hd_conv_nth)
apply (case_tac i1, simp)
apply (rename_tac i2)
apply simp
apply (fold list_asc_def)
thm list_asc_trans
apply (fastforce simp: list_asc_trans)
done
corollary list_asc_upto: "list_asc [m..n]"
by (simp add: list_ord_le_sorted_eq)

lemma list_strict_asc_upt: "list_strict_asc [m..<n]"
by (simp add: list_strict_asc_def list_ord_all_conv)
thm list_strict_asc_imp_list_asc[OF list_strict_asc_upt]

lemma list_ord_distinct_aux: "
  \<lbrakk> irrefl {(a, b). ord a b}; transP ord; list_ord ord xs;
    i < length xs; j < length xs; i < j \<rbrakk> \<Longrightarrow>
  xs ! i \<noteq> xs ! j"
apply (subgoal_tac "\<And>x y. ord x y \<Longrightarrow> x \<noteq> y")
 prefer 2
 apply (rule ccontr)
 apply (simp add: irrefl_def)
thm list_ord_trans
apply (simp add: list_ord_trans)
done
lemma list_ord_distinct: "
  \<lbrakk> irrefl {(a,b). ord a b}; transP ord; list_ord ord xs \<rbrakk> \<Longrightarrow>
  distinct xs"
thm distinct_conv_nth
apply (simp add: distinct_conv_nth, intro allI impI, rename_tac i j)
apply (drule neq_iff[THEN iffD1], erule disjE)
thm list_ord_distinct_aux
 apply (simp add: list_ord_distinct_aux)
thm list_ord_distinct_aux[THEN not_sym]
apply (simp add: list_ord_distinct_aux[THEN not_sym])
done

lemma list_strict_asc_distinct: "list_strict_asc (xs::'a::preorder list) \<Longrightarrow> distinct xs"
apply (rule_tac ord="op <" in list_ord_distinct)
apply (unfold irrefl_def list_strict_asc_def trans_def)
apply (blast intro: less_trans)+
done
lemma list_strict_desc_distinct: "list_strict_desc (xs::'a::preorder list) \<Longrightarrow> distinct xs"
apply (rule_tac ord="op >" in list_ord_distinct)
apply (unfold irrefl_def list_strict_desc_def trans_def)
apply (blast intro: less_trans)+
done

subsubsection {* Additional definitions and results for sublists *}

primrec
  sublist_list :: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list"
where
  "sublist_list xs [] = []"
| "sublist_list xs (y # ys) = (xs ! y) # (sublist_list xs ys)"

value "sublist_list [0::int,10::int,20,30,40,50] [1::nat,2,3]"
value "sublist_list [0::int,10::int,20,30,40,50] [1::nat,1,2,3]"
value "sublist_list [0::int,10::int,20,30,40,50] [1::nat,1,2,3,10]"

thm sublist_def
term "map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [0..<length xs]))"
term "map fst ([p\<leftarrow>(zip xs [0..<length xs]). (snd p \<in> A)])"

lemma sublist_list_length: "length (sublist_list xs ys) = length ys"
by (induct ys, simp_all)

lemma sublist_list_append: "
 \<And>zs. sublist_list xs (ys @ zs) = sublist_list xs ys @ sublist_list xs zs"
by (induct ys, simp_all)

lemma sublist_list_Nil: "sublist_list xs [] =[]"
by simp

lemma sublist_list_is_Nil_conv: "
  (sublist_list xs ys = []) = (ys = [])"
apply (rule iffI)
 apply (rule ccontr)
 apply (clarsimp simp: neq_Nil_conv)
apply simp
done

lemma sublist_list_nth: "
  \<And>n. n < length ys \<Longrightarrow> sublist_list xs ys ! n = xs ! (ys ! n)"
apply (induct ys, simp)
apply (case_tac n, simp_all)
done

lemma take_drop_eq_sublist_list: "
  m + n \<le> length xs \<Longrightarrow> xs \<up> m \<down> n = sublist_list xs [m..<m+n]"
apply (insert length_upt[of m "m+n"])
apply (simp add: expand_list_eq)
apply (simp add: sublist_list_length)
apply (frule add_le_imp_le_diff2)
apply (simp add: min_eqR)
apply (clarsimp, rename_tac i)
thm sublist_list_nth
apply (simp add: sublist_list_nth)
done

primrec
  sublist_list_if :: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list"
where
  "sublist_list_if xs [] = []"
| "sublist_list_if xs (y # ys) =
    (if y < length xs then (xs ! y) # (sublist_list_if xs ys)
     else (sublist_list_if xs ys))"

value "sublist_list_if [0::int,10::int,20,30,40,50] [1::nat,2,3]"
value "sublist_list_if [0::int,10::int,20,30,40,50] [1::nat,1,2,3]"
value "sublist_list_if [0::int,10::int,20,30,40,50] [1::nat,1,2,3,10]"

lemma sublist_list_if_sublist_list_filter_conv: "\<And>xs.
  sublist_list_if xs ys = sublist_list xs (filter (\<lambda>i. i < length xs) ys)"
by (induct ys, simp+)
corollary sublist_list_if_sublist_list_eq: "\<And>xs.
  list_all (\<lambda>i. i < length xs) ys \<Longrightarrow>
  sublist_list_if xs ys = sublist_list xs ys"
by (simp add: sublist_list_if_sublist_list_filter_conv filter_list_all)
corollary sublist_list_if_sublist_list_eq2: "\<And>xs.
  \<forall>n<length ys. ys ! n < length xs \<Longrightarrow>
  sublist_list_if xs ys = sublist_list xs ys"
thm list_all_conv[THEN iffD2]
by (rule sublist_list_if_sublist_list_eq, rule list_all_conv[THEN iffD2])

lemma sublist_list_if_Nil_left: "sublist_list_if [] ys = []"
by (induct ys, simp+)
lemma sublist_list_if_Nil_right: "sublist_list_if xs [] = []"
by simp

lemma sublist_list_if_length: "
  length (sublist_list_if xs ys) = length (filter (\<lambda>i. i < length xs) ys)"
by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_length)
lemma sublist_list_if_append: "
  sublist_list_if xs (ys @ zs) = sublist_list_if xs ys @ sublist_list_if xs zs"
by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_append)
lemma sublist_list_if_snoc: "
  sublist_list_if xs (ys @ [y]) = sublist_list_if xs ys @ (if y < length xs then [xs ! y] else [])"
by (simp add: sublist_list_if_append)

lemma sublist_list_if_is_Nil_conv: "
  (sublist_list_if xs ys = []) = (list_all (\<lambda>i. length xs \<le> i) ys)"
by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_is_Nil_conv filter_empty_conv list_all_iff linorder_not_less)

lemma sublist_list_if_nth: "
  n < length ((filter (\<lambda>i. i < length xs) ys)) \<Longrightarrow>
  sublist_list_if xs ys ! n = xs ! ((filter (\<lambda>i. i < length xs) ys) ! n)"
by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_nth)

lemma take_drop_eq_sublist_list_if: "
  m + n \<le> length xs \<Longrightarrow> xs \<up> m \<down> n = sublist_list_if xs [m..<m+n]"
thm take_drop_eq_sublist_list
by (simp add: sublist_list_if_sublist_list_filter_conv take_drop_eq_sublist_list)

lemma sublist_empty_conv: "(sublist xs I = []) = (\<forall>i\<in>I. length xs \<le> i)"
  using [[hypsubst_thin = true]]
by (fastforce simp: set_empty[symmetric] set_sublist linorder_not_le[symmetric])

thm sublist_singleton
lemma sublist_singleton2: "sublist xs {y} = (if y < length xs then [xs ! y] else [])"
apply (unfold sublist_def)
apply (induct xs rule: rev_induct, simp)
apply (simp add: nth_append)
done

lemma sublist_take_eq: "
  \<lbrakk> finite I; Max I < n \<rbrakk> \<Longrightarrow> sublist (xs \<down> n) I = sublist xs I"
apply (case_tac "I = {}", simp)
apply (case_tac "n < length xs")
 prefer 2
 apply simp
thm append_take_drop_id
apply (rule_tac
  t = "sublist xs I" and
  s = "sublist (xs \<down> n @ xs \<up> n) I"
  in subst)
 apply simp
apply (subst sublist_append)
apply (simp add: min_eqR)
apply (rule_tac t="{j. j + n \<in> I}" and s="{}" in subst)
 apply blast
apply simp
done

lemma sublist_drop_eq: "
  n \<le> iMin I \<Longrightarrow> sublist (xs \<up> n) {j. j + n \<in> I} = sublist xs I"
apply (case_tac "I = {}", simp)
apply (case_tac "n < length xs")
 prefer 2
 apply (simp add: sublist_def filter_empty_conv linorder_not_less)
 apply (clarsimp, rename_tac a b)
 thm set_zip_rightD
 apply (drule set_zip_rightD)
 apply fastforce
apply (rule_tac
  t = "sublist xs I" and
  s = "sublist (xs \<down> n @ xs \<up> n) I"
  in subst)
 apply simp
apply (subst sublist_append)
apply (fastforce simp: sublist_empty_conv min_eqR)
done

lemma sublist_cut_less_eq: "
  length xs \<le> n \<Longrightarrow> sublist xs (I \<down>< n) = sublist xs I"
apply (simp add: sublist_def cut_less_mem_iff)
apply (rule_tac f="\<lambda>xs. map fst xs" in arg_cong)
thm filter_filter_eq
apply (rule filter_filter_eq)
apply (simp add: list_all_conv)
done

lemma sublist_disjoint_Un: "
  \<lbrakk> finite A; Max A < iMin B \<rbrakk> \<Longrightarrow> sublist xs (A \<union> B) = sublist xs A @ sublist xs B"
apply (case_tac "A = {}", simp)
apply (case_tac "B = {}", simp)
apply (case_tac "length xs \<le> iMin B")
 thm sublist_cut_less_eq
 apply (subst sublist_cut_less_eq[of xs "iMin B", symmetric], assumption)
 apply (simp (no_asm_simp) add: cut_less_Un cut_less_Min_empty cut_less_Max_all)
 apply (simp add: sublist_empty_conv iMin_ge_iff)
apply (simp add: linorder_not_le)
thm sublist_append
apply (rule_tac
  t = "sublist xs (A \<union> B)" and
  s = "sublist (xs \<down> (iMin B) @ xs \<up> (iMin B)) (A \<union> B)"
  in subst)
 apply simp
apply (subst sublist_append)
apply (simp add: min_eqR)
thm sublist_cut_less_eq
apply (subst sublist_cut_less_eq[where xs="xs \<down> iMin B" and n="iMin B", symmetric], simp)
apply (simp add: cut_less_Un cut_less_Min_empty cut_less_Max_all)
thm sublist_take_eq
apply (simp add: sublist_take_eq)
apply (rule_tac
  t = "\<lambda>j. j + iMin B \<in> A \<or> j + iMin B \<in> B" and
  s = "\<lambda>j. j + iMin B \<in> B"
  in subst)
 apply (force simp: fun_eq_iff)
thm sublist_drop_eq
apply (simp add: sublist_drop_eq)
done
corollary sublist_disjoint_insert_left: "
  \<lbrakk> finite I; x < iMin I \<rbrakk> \<Longrightarrow> sublist xs (insert x I) = sublist xs {x} @ sublist xs I"
apply (rule_tac t="insert x I" and s="{x} \<union> I" in subst, simp)
apply (subst sublist_disjoint_Un)
apply simp_all
done
corollary sublist_disjoint_insert_right: "
  \<lbrakk> finite I; Max I < x \<rbrakk> \<Longrightarrow> sublist xs (insert x I) = sublist xs I @ sublist xs {x}"
apply (rule_tac t="insert x I" and s="I \<union> {x}" in subst, simp)
apply (subst sublist_disjoint_Un)
apply simp_all
done

lemma sublist_all: "{..<length xs} \<subseteq> I \<Longrightarrow> sublist xs I = xs"
apply (case_tac "xs = []", simp)
apply (rule_tac
  t = "I" and
  s = "I \<down>< (length xs) \<union> I \<down>\<ge> (length xs)"
  in subst)
 apply (simp add: cut_less_cut_ge_ident)
apply (rule_tac
  t = "I \<down>< length xs" and
  s = "{..<length xs}"
  in subst)
 apply blast
apply (case_tac "I \<down>\<ge> (length xs) = {}", simp)
apply (subst sublist_disjoint_Un[OF finite_lessThan])
 apply (rule less_imp_Max_less_iMin[OF finite_lessThan])
   apply blast
  apply blast
 apply (blast intro: less_le_trans)
apply (fastforce simp: sublist_empty_conv)
done
corollary sublist_UNIV: "sublist xs UNIV = xs"
by (rule sublist_all[OF subset_UNIV])

lemma sublist_list_sublist_eq: "\<And>xs.
  list_strict_asc ys \<Longrightarrow> sublist_list_if xs ys = sublist xs (set ys)"
apply (case_tac "xs = []")
 apply (simp add: sublist_list_if_Nil_left)
apply (induct ys rule: rev_induct, simp)
apply (rename_tac y ys xs)
apply (case_tac "ys = []")
 apply (simp add: sublist_singleton2)
apply (unfold list_strict_asc_def)
apply (simp add: sublist_list_if_snoc split del: split_if)
thm list_ord_append
apply (frule list_ord_append[THEN iffD1])
apply (clarsimp split del: split_if)
apply (subst sublist_disjoint_insert_right)
  apply simp
 apply (clarsimp simp: in_set_conv_nth, rename_tac i)
 thm list_strict_asc_trans[unfolded list_strict_asc_def, THEN iffD1, rule_format]
 apply (drule_tac i=i and j="length ys" in list_strict_asc_trans[unfolded list_strict_asc_def, THEN iffD1, rule_format])
 apply (simp add: nth_append split del: split_if)+
apply (simp add: sublist_singleton2)
done
lemma set_sublist_list_if: "\<And>xs. set (sublist_list_if xs ys) = {xs ! i |i. i < length xs \<and> i \<in> set ys}"
apply (induct ys, simp_all)
apply blast
done

lemma set_sublist_list: "
  list_all (\<lambda>i. i < length xs) ys \<Longrightarrow>
  set (sublist_list xs ys) = {xs ! i |i. i < length xs \<and> i \<in> set ys}"
by (simp add: sublist_list_if_sublist_list_eq[symmetric] set_sublist_list_if)

subsubsection {* Natural set images with lists *}

definition
  f_image :: "'a list \<Rightarrow> nat set \<Rightarrow> 'a set"      (infixr "`\<^sup>f" 90)
where
  "xs `\<^sup>f A \<equiv> {y. \<exists>n\<in>A. n < length xs \<and> y = xs ! n }"

abbreviation
  f_range :: "'a list \<Rightarrow> 'a set"
where
  "f_range xs \<equiv> f_image xs UNIV"

thm Set.image_eqI
lemma f_image_eqI[simp, intro]: "
  \<lbrakk> x = xs ! n; n \<in> A; n < length xs \<rbrakk> \<Longrightarrow> x \<in> xs `\<^sup>f A"
by (unfold f_image_def, blast)

thm Set.imageI
lemma f_imageI: "\<lbrakk> n \<in> A; n < length xs \<rbrakk> \<Longrightarrow> xs ! n \<in> xs `\<^sup>f A"
by blast

thm Set.rev_image_eqI
lemma rev_f_imageI: "\<lbrakk> n \<in> A; n < length xs; x = xs ! n \<rbrakk> \<Longrightarrow> x \<in> xs `\<^sup>f A"
by (rule f_image_eqI)

thm Set.imageE
lemma f_imageE[elim!]: "
  \<lbrakk> x \<in> xs `\<^sup>f A; \<And>n. \<lbrakk> x = xs ! n; n \<in> A; n < length xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (unfold f_image_def, blast)

thm Set.image_Un
lemma f_image_Un: "xs `\<^sup>f (A \<union> B) = xs `\<^sup>f A \<union> xs `\<^sup>f B"
by blast

thm Set.image_mono
lemma f_image_mono: "A \<subseteq> B ==> xs `\<^sup>f A \<subseteq> xs `\<^sup>f B"
by blast

thm Set.image_iff
lemma f_image_iff: "(x \<in> xs `\<^sup>f A) = (\<exists>n\<in>A. n < length xs \<and> x = xs ! n)"
by blast

thm Set.image_subset_iff
lemma f_image_subset_iff: "
  (xs `\<^sup>f A \<subseteq> B) = (\<forall>n\<in>A. n < length xs \<longrightarrow> xs ! n \<in> B)"
by blast
thm Set.subset_image_iff
lemma subset_f_image_iff: "(B \<subseteq> xs `\<^sup>f A) = (\<exists>A'\<subseteq>A. B = xs `\<^sup>f A')"
apply (rule iffI)
 apply (rule_tac x="{ n. n \<in> A \<and> n < length xs \<and> xs ! n \<in> B }" in exI)
 apply blast
apply (blast intro: f_image_mono)
done

thm image_subsetI
lemma f_image_subsetI: "
  \<lbrakk> \<And>n. n \<in> A \<and> n < length xs \<Longrightarrow> xs ! n \<in> B \<rbrakk> \<Longrightarrow> xs `\<^sup>f A \<subseteq> B"
by blast

thm Set.image_empty
lemma f_image_empty: "xs `\<^sup>f {} = {}"
by blast

thm Set.image_insert
lemma f_image_insert_if: "
  xs `\<^sup>f (insert n A) = (
  if n < length xs then insert (xs ! n) (xs `\<^sup>f A) else (xs `\<^sup>f A))"
by (split split_if, blast)
lemma f_image_insert_eq1: "
  n < length xs \<Longrightarrow> xs `\<^sup>f (insert n A) = insert (xs ! n) (xs `\<^sup>f A)"
by (simp add: f_image_insert_if)
lemma f_image_insert_eq2: "
  length xs \<le> n \<Longrightarrow> xs `\<^sup>f (insert n A) = (xs `\<^sup>f A)"
by (simp add: f_image_insert_if)

thm Set.insert_image
lemma insert_f_image: "
  \<lbrakk> n \<in> A; n < length xs \<rbrakk> \<Longrightarrow> insert (xs ! n) (xs `\<^sup>f A) = (xs `\<^sup>f A)"
by blast
thm Set.image_is_empty
lemma f_image_is_empty: "(xs `\<^sup>f A = {}) = ({x. x \<in> A \<and> x < length xs} = {})"
by blast

thm Set.image_Collect
lemma f_image_Collect: "xs `\<^sup>f {n. P n} = {xs ! n |n. P n \<and> n < length xs}"
by blast

lemma f_image_eq_set: "\<forall>n<length xs. n \<in> A \<Longrightarrow> xs `\<^sup>f A = set xs"
by (fastforce simp: in_set_conv_nth)
lemma f_range_eq_set: "f_range xs = set xs"
by (simp add: f_image_eq_set)

lemma f_image_eq_set_sublist: "xs `\<^sup>f A = set (sublist xs A)"
by (unfold set_sublist, blast)
lemma f_image_eq_set_sublist_list_if: "xs `\<^sup>f (set ys) = set (sublist_list_if xs ys)"
by (simp add: set_sublist_list_if_eq_set_sublist f_image_eq_set_sublist)
lemma f_image_eq_set_sublist_list: "
  list_all (\<lambda>i. i < length xs) ys \<Longrightarrow> xs `\<^sup>f (set ys) = set (sublist_list xs ys)"
by (simp add: sublist_list_if_sublist_list_eq f_image_eq_set_sublist_list_if)

thm Set.range_eqI
lemma f_range_eqI: "\<lbrakk> x = xs ! n; n < length xs \<rbrakk> \<Longrightarrow> x \<in> f_range xs"
by blast
thm Set.rangeI
lemma f_rangeI: "n < length xs \<Longrightarrow> xs ! n \<in> f_range xs"
by blast
thm Set.rangeE
lemma f_rangeE[elim?]: "
  \<lbrakk> x \<in> f_range xs; \<And>n. \<lbrakk> n < length xs; x = xs ! n \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by blast

subsubsection {* Mapping lists of functions to lists *}

primrec
  map_list :: "('a \<Rightarrow> 'b) list \<Rightarrow> 'a list \<Rightarrow> 'b list"
where
  "map_list [] xs = []"
| "map_list (f # fs) xs = f (hd xs) # map_list fs (tl xs)"

lemma map_list_Nil: "map_list [] xs = []"
by simp
lemma map_list_Cons_Cons: "
  map_list (f # fs) (x # xs) =
  (f x) # map_list fs xs"
by simp

lemma map_list_length: "\<And>xs.
  length (map_list fs xs) = length fs"
by (induct fs, simp+)
corollary map_list_empty_conv: "
  (map_list fs xs = []) = (fs = [])"
by (simp del: length_0_conv add: length_0_conv[symmetric] map_list_length)
corollary map_list_not_empty_conv: "
  (map_list fs xs \<noteq> []) = (fs \<noteq> [])"
by (simp add: map_list_empty_conv)

lemma map_list_nth: "\<And>n xs.
  \<lbrakk> n < length fs; n < length xs \<rbrakk> \<Longrightarrow>
  (map_list fs xs ! n) =
  (fs ! n) (xs ! n)"
apply (induct fs, simp+)
apply (case_tac n)
 apply (simp add: hd_conv_nth)
apply (simp add: nth_tl_eq_nth_Suc2)
done

lemma map_list_xs_take: "\<And>n xs.
  length fs \<le> n \<Longrightarrow>
  map_list fs (xs \<down> n) =
  map_list fs xs"
apply (induct fs, simp+)
apply (rename_tac f fs n xs)
apply (simp add: tl_take)
thm arg_cong
apply (rule_tac f=f in arg_cong)
apply (case_tac "xs = []", simp)
apply (simp add: hd_conv_nth)
done

lemma map_list_take: "\<And>n xs.
  (map_list fs xs) \<down> n =
  (map_list (fs \<down> n) xs)"
apply (induct fs, simp)
apply (case_tac n, simp+)
done
lemma map_list_take_take: "\<And>n xs.
  (map_list fs xs) \<down> n =
  (map_list (fs \<down> n) (xs \<down> n))"
by (simp add: map_list_take map_list_xs_take)
lemma map_list_drop: "\<And>n xs.
  (map_list fs xs) \<up> n =
  (map_list (fs \<up> n) (xs \<up> n))"
apply (induct fs, simp)
apply (case_tac n)
apply (simp add: drop_Suc)+
done

lemma map_list_append_append: "\<And>xs1 .
  length fs1 = length xs1 \<Longrightarrow>
  map_list (fs1 @ fs2) (xs1 @ xs2) =
  map_list fs1 xs1 @
  map_list fs2 xs2"
apply (induct fs1, simp+)
apply (case_tac "xs1", simp+)
done
lemma map_list_snoc_snoc: "
  length fs = length xs \<Longrightarrow>
  map_list (fs @ [f]) (xs @ [x]) =
  map_list fs xs @ [f x]"
by (simp add: map_list_append_append)
lemma map_list_snoc: "\<And>xs.
  length fs < length xs \<Longrightarrow>
  map_list (fs @ [f]) xs =
  map_list fs xs @  [f (xs ! (length fs))]"
apply (induct fs)
 apply (simp add: hd_conv_nth)
apply (simp add: nth_tl_eq_nth_Suc2)
done

lemma map_list_Cons_if: "
  map_list fs (x # xs) =
  (if (fs = []) then [] else (
    ((hd fs) x) # map_list (tl fs) xs))"
by (case_tac "fs", simp+)
lemma map_list_Cons_not_empty: "
  fs \<noteq> [] \<Longrightarrow>
  map_list fs (x # xs) =
  ((hd fs) x) # map_list (tl fs) xs"
by (simp add: map_list_Cons_if)

lemma map_eq_map_list_take: "\<And>xs.
  \<lbrakk> length fs \<le> length xs; list_all (\<lambda>x. x = f) fs \<rbrakk> \<Longrightarrow>
  map_list fs xs = map f (xs \<down> length fs)"
apply (induct fs, simp+)
apply (case_tac xs, simp+)
done
lemma map_eq_map_list_take2: "
  \<lbrakk> length fs = length xs; list_all (\<lambda>x. x = f) fs \<rbrakk> \<Longrightarrow>
  map_list fs xs = map f xs"
by (simp add: map_eq_map_list_take)
lemma map_eq_map_list_replicate: "
  map_list (f\<^bsup>length xs\<^esup>) xs = map f xs"
by (induct xs, simp+)

subsubsection {* Mapping functions with two arguments to lists *}

primrec map2 :: "
  (* Function taking two parameters *)
  ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow>
  (* Lists of parameters *)
  'a list \<Rightarrow> 'b list \<Rightarrow>
  'c list"
where
  "map2 f [] ys = []"
| "map2 f (x # xs) ys = f x (hd ys) # map2 f xs (tl ys)"

lemma map2_map_list_conv: "\<And>ys. map2 f xs ys = map_list (map f xs) ys"
by (induct xs, simp+)

lemma map2_Nil: "map2 f [] ys = []"
by simp
lemma map2_Cons_Cons: "
  map2 f (x # xs) (y # ys) =
  (f x y) # map2 f xs ys"
by simp

lemma map2_length: "\<And>ys. length (map2 f xs ys) = length xs"
by (induct xs, simp+)
corollary map2_empty_conv: "
  (map2 f xs ys = []) = (xs = [])"
by (simp del: length_0_conv add: length_0_conv[symmetric] map2_length)
corollary map2_not_empty_conv: "
  (map2 f xs ys \<noteq> []) = (xs \<noteq> [])"
by (simp add: map2_empty_conv)

lemma map2_nth: "\<And>n ys.
  \<lbrakk> n < length xs; n < length ys \<rbrakk> \<Longrightarrow>
  (map2 f xs ys ! n) =
  f (xs ! n) (ys ! n)"
thm map_list_nth
by (simp add: map2_map_list_conv map_list_nth)

lemma map2_ys_take: "\<And>n ys.
  length xs \<le> n \<Longrightarrow>
  map2 f xs (ys \<down> n) =
  map2 f xs ys"
thm map_list_xs_take
by (simp add: map2_map_list_conv map_list_xs_take)

lemma map2_take: "\<And>n ys.
  (map2 f xs ys) \<down> n =
  (map2 f (xs \<down> n) ys)"
thm map_list_take
by (simp add: map2_map_list_conv take_map map_list_take)
lemma map2_take_take: "\<And>n ys.
  (map2 f xs ys) \<down> n =
  (map2 f (xs \<down> n) (ys \<down> n))"
by (simp add: map2_take map2_ys_take)
lemma map2_drop: "\<And>n ys.
  (map2 f xs ys) \<up> n =
  (map2 f (xs \<up> n) (ys \<up> n))"
thm map_list_drop
by (simp add: map2_map_list_conv map_list_drop drop_map)

lemma map2_append_append: "\<And>ys1 .
  length xs1 = length ys1 \<Longrightarrow>
  map2 f (xs1 @ xs2) (ys1 @ ys2) =
  map2 f xs1 ys1 @
  map2 f xs2 ys2"
thm map_list_append_append
by (simp add: map2_map_list_conv map_list_append_append)
lemma map2_snoc_snoc: "
  length xs = length ys \<Longrightarrow>
  map2 f (xs @ [x]) (ys @ [y]) =
  map2 f xs ys @
  [f x y]"
by (simp add: map2_append_append)
lemma map2_snoc: "\<And>ys.
  length xs < length ys \<Longrightarrow>
  map2 f (xs @ [x]) ys =
  map2 f xs ys @
  [f x (ys ! (length xs))]"
thm map_list_snoc
by (simp add: map2_map_list_conv map_list_snoc)

lemma map2_Cons_if: "
  map2 f xs (y # ys) =
  (if (xs = []) then [] else (
    (f (hd xs) y) # map2 f (tl xs) ys))"
by (case_tac "xs", simp+)

lemma map2_append1_take_drop: "
  length xs1 \<le> length ys \<Longrightarrow>
  map2 f (xs1 @ xs2) ys =
  map2 f xs1 (ys \<down> length xs1) @
  map2 f xs2 (ys \<up> length xs1)"
thm map2_append_append
thm append_take_drop_id
apply (rule_tac
  t = "map2 f (xs1 @ xs2) ys" and
  s = "map2 f (xs1 @ xs2) (ys \<down> length xs1 @ ys \<up> length xs1)"
  in subst)
 apply simp
apply (simp add: map2_append_append del: append_take_drop_id)
done
lemma map2_append2_take_drop: "
  length ys1 \<le> length xs \<Longrightarrow>
  map2 f xs (ys1 @ ys2) =
  map2 f (xs \<down> length ys1) ys1 @
  map2 f (xs \<up> length ys1) ys2"
apply (rule_tac
  t = "map2 f xs (ys1 @ ys2)" and
  s = "map2 f (xs \<down> length ys1 @ xs \<up> length ys1) (ys1 @ ys2)"
  in subst)
 apply simp
apply (simp add: map2_append_append del: append_take_drop_id)
done

thm List.map_cong
lemma map2_cong: "
  \<lbrakk> xs1 = xs2; ys1 = ys2; length xs2 \<le> length ys2;
    \<And>x y. \<lbrakk> x \<in> set xs2; y \<in> set ys2 \<rbrakk> \<Longrightarrow> f x y = g x y \<rbrakk> \<Longrightarrow>
  map2 f xs1 ys1 = map2 g xs2 ys2"
by (simp (no_asm_simp) add: expand_list_eq map2_length map2_nth)

thm List.map_eq_conv
lemma map2_eq_conv: "
  length xs \<le> length ys \<Longrightarrow>
  (map2 f xs ys = map2 g xs ys) = (\<forall>i<length xs. f (xs ! i) (ys ! i) = g (xs ! i) (ys ! i))"
by (simp add: expand_list_eq map2_length map2_nth)

thm List.map_replicate
lemma map2_replicate: "map2 f x\<^bsup>n\<^esup> y\<^bsup>n\<^esup> = (f x y)\<^bsup>n\<^esup>"
by (induct n, simp+)

lemma map2_zip_conv: "\<And>ys.
  length xs \<le> length ys \<Longrightarrow>
  map2 f xs ys = map (\<lambda>(x,y). f x y) (zip xs ys)"
apply (induct xs, simp)
apply (case_tac ys, simp+)
done

lemma map2_rev: "\<And>ys.
  length xs = length ys \<Longrightarrow>
  rev (map2 f xs ys) = map2 f (rev xs) (rev ys)"
apply (induct xs, simp)
apply (case_tac ys, simp)
apply (simp add: map2_Cons_Cons map2_snoc_snoc)
done

end


theory Coinduction
  imports Main
begin

section \<open>Syntax\<close>

type_synonym name = string

datatype process =
  Inaction (\<open>\<zero>\<close>)
  | Out name process (\<open>_\<^bold>!._\<close> [50, 60] 200)
  | In name process (\<open>_\<^bold>?._\<close> [50, 60] 200)
  | Composition process process (\<open>_\<^bold>|_\<close> [50, 50] 300)
  | Replicate process (\<open>\<^bold>!_\<close> [50] 100)

primrec names where
  \<open>names Inaction = {}\<close>
| \<open>names (Out x P) = {x} \<union> names P\<close>
| \<open>names (In x P) = {x} \<union> names P\<close>
| \<open>names (Composition P Q) = names P \<union> names Q\<close>
| \<open>names (Replicate P) = names P\<close>

section \<open>Semantics\<close>

datatype actions =
  AOut name (\<open>_\<^bold>!\<close> 100)
  | AIn name (\<open>_\<^bold>?\<close> 100)
  | ATau (\<open>\<tau>\<close>)

inductive transition (\<open>_\<midarrow>_\<rightarrow>_\<close> [20, 20, 20] 30) where
  TOut[intro]: \<open>x\<^bold>!.P \<midarrow>x\<^bold>!\<rightarrow> P\<close>
| TIn[intro]: \<open>x\<^bold>?.P \<midarrow>x\<^bold>?\<rightarrow> P\<close>
| TParL[intro]: \<open>P \<midarrow>\<alpha>\<rightarrow> P' \<Longrightarrow> P \<^bold>| Q \<midarrow>\<alpha>\<rightarrow> P' \<^bold>| Q\<close>
| TParR[intro]: \<open>Q \<midarrow>\<alpha>\<rightarrow> Q' \<Longrightarrow> P \<^bold>| Q \<midarrow>\<alpha>\<rightarrow> P \<^bold>| Q'\<close>
| TCommL[intro]: \<open>P \<midarrow>x\<^bold>!\<rightarrow> P' \<Longrightarrow> Q \<midarrow>x\<^bold>?\<rightarrow> Q' \<Longrightarrow> P \<^bold>| Q \<midarrow>\<tau>\<rightarrow> P' \<^bold>| Q'\<close>
| TCommR[intro]: \<open>P \<midarrow>x\<^bold>?\<rightarrow> P' \<Longrightarrow> Q \<midarrow>x\<^bold>!\<rightarrow> Q' \<Longrightarrow> P \<^bold>| Q \<midarrow>\<tau>\<rightarrow> P' \<^bold>| Q'\<close>
| TRep[intro]: \<open>P \<midarrow>\<alpha>\<rightarrow> P' \<Longrightarrow> \<^bold>!P \<midarrow>\<alpha>\<rightarrow> P' \<^bold>| \<^bold>!P\<close>

lemma inaction_stuck [simp]: \<open>\<nexists>P. (\<zero> \<midarrow>\<alpha>\<rightarrow> P)\<close>
proof
  assume \<open>\<exists>P. \<zero> \<midarrow>\<alpha>\<rightarrow> P\<close>
  then obtain P where \<open>\<zero> \<midarrow>\<alpha>\<rightarrow> P\<close> ..
  then show False
    using transition.simps by blast
qed

lemma out_no_tau [simp]: \<open>\<nexists>P Q. x\<^bold>!.P \<midarrow>\<tau>\<rightarrow> Q\<close>
proof
  assume \<open>\<exists>P Q. x\<^bold>!.P \<midarrow>\<tau>\<rightarrow> Q\<close>
  then obtain P Q where \<open>x\<^bold>!.P \<midarrow>\<tau>\<rightarrow> Q\<close> by blast
  then show False
    by cases
qed

lemma in_no_tau [simp]: \<open>\<nexists>P Q. x\<^bold>?.P \<midarrow>\<tau>\<rightarrow> Q\<close>
proof
  assume \<open>\<exists>P Q. x\<^bold>?.P \<midarrow>\<tau>\<rightarrow> Q\<close>
  then obtain P Q where \<open>x\<^bold>?.P \<midarrow>\<tau>\<rightarrow> Q\<close> by blast
  then show False
    by cases
qed

lemma out_elim [elim]:
  assumes \<open>x\<^bold>!.P \<midarrow>y\<^bold>!\<rightarrow> Q\<close>
  shows \<open>x = y\<close> and \<open>P = Q\<close>
proof -
  from assms show \<open>x = y\<close>
    by cases auto
next
  show \<open>P = Q\<close>
  proof (rule ccontr)
    assume \<open>P \<noteq> Q\<close>
    with assms show False
      by cases auto
  qed
qed

lemma in_elim [elim]:
  assumes \<open>x\<^bold>?.P \<midarrow>y\<^bold>?\<rightarrow> Q\<close>
  shows \<open>x = y\<close> and \<open>P = Q\<close>
proof -
  from assms show \<open>x = y\<close>
    by cases auto
next
  show \<open>P = Q\<close>
  proof (rule ccontr)
    assume \<open>P \<noteq> Q\<close>
    with assms show False
      by cases auto
  qed
qed

lemma CommL_deterministic [simp]: \<open>\<exists>! R. (x\<^bold>!.P) \<^bold>| (x\<^bold>?.Q) \<midarrow>\<tau>\<rightarrow> R\<close>
proof
  fix R
  assume \<open>(x\<^bold>!.P) \<^bold>| (x\<^bold>?.Q) \<midarrow>\<tau>\<rightarrow> R\<close>
  then show \<open>R = (P \<^bold>| Q)\<close>
  proof cases
    case (TParL P')
    with out_no_tau show ?thesis by blast
  next
    case (TParR Q')
    with in_no_tau show ?thesis by blast
  next
    case (TCommL x' P' Q')
    then have \<open>P = P'\<close> by auto
    moreover from TCommL have \<open>Q = Q'\<close> by auto
    ultimately show ?thesis using TCommL by simp
  next
    case (TCommR x P' Q')
    from this(2) have False
      by cases
    then show ?thesis ..
  qed
qed blast

lemma CommR_deterministic [simp]: \<open>\<exists>! R. (x\<^bold>?.P) \<^bold>| (x\<^bold>!.Q) \<midarrow>\<tau>\<rightarrow> R\<close>
proof
  fix R
  assume \<open>(x\<^bold>?.P) \<^bold>| (x\<^bold>!.Q) \<midarrow>\<tau>\<rightarrow> R\<close>
  then show \<open>R = (P \<^bold>| Q)\<close>
  proof cases
    case (TParL P')
    with in_no_tau show ?thesis by blast
  next
    case (TParR Q')
    with out_no_tau show ?thesis by blast
  next
    case (TCommL x' P' Q')
    from this(2) have False
      by cases
    then show ?thesis ..
  next
    case (TCommR x P' Q')
    then have \<open>P = P'\<close> by auto
    moreover from TCommR have \<open>Q = Q'\<close> by auto
    ultimately show ?thesis using TCommR by simp
  qed
qed blast

section \<open>Bisimilarity\<close>

datatype observables =
  OOut name
  | OIn name

inductive observable where
  ObsOut[intro]: \<open>\<exists>P'. P \<midarrow>AOut x\<rightarrow> P' \<Longrightarrow> observable P (OOut x)\<close>
| ObsIn[intro]: \<open>\<exists>P'. P \<midarrow>AIn x\<rightarrow> P' \<Longrightarrow> observable P (OIn x)\<close>

lemma obs_out_I [intro, simp]: \<open>observable (x\<^bold>!.P) (OOut x)\<close>
proof
  have \<open>x\<^bold>!.P \<midarrow>x\<^bold>!\<rightarrow> P\<close>
    by auto
  then show \<open>\<exists>P'. x\<^bold>!.P\<midarrow>x\<^bold>!\<rightarrow>P'\<close> ..
qed

lemma obs_in_I [intro, simp]: \<open>observable (x\<^bold>?.P) (OIn x)\<close>
proof
  have \<open>x\<^bold>?.P \<midarrow>x\<^bold>?\<rightarrow> P\<close>
    by auto
  then show \<open>\<exists>P'. x\<^bold>?.P\<midarrow>x\<^bold>?\<rightarrow>P'\<close> ..
qed

lemma obs_out_eq [simp]: \<open>y \<noteq> x \<Longrightarrow> \<not> observable (x\<^bold>!.P) (OOut y)\<close>
proof
  assume *: \<open>y \<noteq> x\<close>
  assume \<open>observable (x\<^bold>!.P) (OOut y)\<close>
  then show False
  proof (cases)
    case ObsOut
    then obtain P' where \<open>(x\<^bold>!.P) \<midarrow>y\<^bold>!\<rightarrow> P'\<close> ..
    then show False
      by cases (simp add: *)
  qed
qed

lemma obs_in_eq [simp]: \<open>y \<noteq> x \<Longrightarrow> \<not> observable (x\<^bold>?.P) (OIn y)\<close>
proof
  assume *: \<open>y \<noteq> x\<close>
  assume \<open>observable (x\<^bold>?.P) (OIn y)\<close>
  then show False
  proof (cases)
    case ObsIn
    then obtain P' where \<open>(x\<^bold>?.P) \<midarrow>y\<^bold>?\<rightarrow> P'\<close> ..
    then show False
      by cases (simp add: *)
  qed
qed

lemma out_not_obs_in [simp]: \<open>P = (x\<^bold>!.Q) \<Longrightarrow> \<not> observable P (OIn y)\<close>
proof
  assume *: \<open>P = (x\<^bold>!.Q)\<close>
  have \<open>\<forall>P'. \<not> (P \<midarrow>AIn y\<rightarrow> P')\<close>
  proof
    fix P'
    show \<open>\<not> (P \<midarrow>y\<^bold>?\<rightarrow> P')\<close>
      unfolding not_def *
      by (rule impI, induction P') (use transition.simps in blast)+
  qed
  moreover assume \<open>observable P (OIn y)\<close>
  ultimately show False
    using observable.simps by auto
qed

lemma in_not_obs_out [simp]: \<open>P = (x\<^bold>?.Q) \<Longrightarrow> \<not> observable P (OOut y)\<close>
proof
  assume *: \<open>P = (x\<^bold>?.Q)\<close>
  have \<open>\<forall>P'. \<not> (P \<midarrow>AOut y\<rightarrow> P')\<close>
  proof
    fix P'
    show \<open>\<not> (P \<midarrow>y\<^bold>!\<rightarrow> P')\<close>
      unfolding not_def *
      by (rule impI, induction P') (use transition.simps in blast)+
  qed
  moreover assume \<open>observable P (OOut y)\<close>
  ultimately show False
    using observable.simps by auto
qed

lemma zero_no_obs [simp]: \<open>\<not> (observable \<zero> \<mu>)\<close>
proof safe
  assume \<open>observable \<zero> \<mu>\<close>
  then show False
    by cases auto
qed

lemma par_add_obs [simp]:
  assumes *: \<open>observable (P \<^bold>| Q) \<mu>\<close>
  shows \<open>observable P \<mu> \<or> observable Q \<mu>\<close>
proof (cases \<open>observable P \<mu>\<close>)
  case False
  from * have \<open>observable Q \<mu>\<close>
  proof cases
    case (ObsOut x)
    with False have NP: \<open>\<nexists>P'. P \<midarrow>x\<^bold>!\<rightarrow> P'\<close> by fast
    from ObsOut obtain Q'' where PQ: \<open>P \<^bold>| Q \<midarrow>x\<^bold>!\<rightarrow> Q''\<close> by blast
    then have \<open>\<exists>Q'. Q \<midarrow>x\<^bold>!\<rightarrow> Q'\<close>
    proof cases
      case TParL
      with NP show ?thesis by blast
    next
      case TParR
      then show \<open>(\<exists>Q'. (Q\<midarrow>x\<^bold>!\<rightarrow>Q'))\<close>
        by blast
    qed
    then show ?thesis using ObsOut
      by blast
  next
    case (ObsIn x)
    with False have NP: \<open>\<nexists>P'. P \<midarrow>x\<^bold>?\<rightarrow> P'\<close> by fast
    from ObsIn obtain Q'' where PQ: \<open>P \<^bold>| Q \<midarrow>x\<^bold>?\<rightarrow> Q''\<close> by blast
    then have \<open>\<exists>Q'. Q \<midarrow>x\<^bold>?\<rightarrow> Q'\<close>
    proof cases
      case TParL
      with NP show ?thesis by blast
    next
      case TParR
      then show \<open>(\<exists>Q'. (Q\<midarrow>x\<^bold>?\<rightarrow>Q'))\<close>
        by blast
    qed
    then show ?thesis using ObsIn
      by blast
  qed
  then show ?thesis ..
qed simp

lemma rep_preserves_obs [simp]: \<open>observable (\<^bold>!P) \<mu> \<Longrightarrow> observable P \<mu>\<close>
proof (induction P arbitrary: \<mu>)
  case Inaction
  then show ?case
  proof cases
    case (ObsOut x)
    then obtain P' where \<open>\<^bold>!\<zero> \<midarrow>x\<^bold>!\<rightarrow> P'\<close> by blast
    then have False
    proof (cases)
      case (TRep Q)
      with zero_no_obs show ?thesis by fast
    qed
    then show ?thesis ..
  next
    case (ObsIn x)
    then obtain P' where \<open>\<^bold>!\<zero> \<midarrow>x\<^bold>?\<rightarrow> P'\<close> by blast
    then have False
    proof (cases)
      case (TRep Q)
      with zero_no_obs show ?thesis by fast
    qed
    then show ?thesis ..
  qed
next
  case (Out x P)
  from this(2) show ?case
  proof (cases)
    case (ObsOut x')
    then show ?thesis
    proof (cases \<open>x = x'\<close>)
      case False
      from ObsOut obtain P' where \<open>\<^bold>!(x\<^bold>!.P) \<midarrow>x'\<^bold>!\<rightarrow> P'\<close> by blast
      then have False
      proof cases
        case (TRep Q)
        with False show ?thesis
          by (simp add: out_elim)
      qed
      then show ?thesis ..
    qed simp
  next
    case (ObsIn x')
    then obtain P' where \<open>\<^bold>!(x\<^bold>!.P) \<midarrow>x'\<^bold>?\<rightarrow> P'\<close> by blast
    then have False
    proof cases
      case (TRep Q)
      then show ?thesis
        using out_not_obs_in by blast
    qed
    then show ?thesis ..
  qed
next
  case (In x P)
  from this(2) show ?case
  proof (cases)
    case (ObsIn x')
    then show ?thesis
    proof (cases \<open>x = x'\<close>)
      case False
      from ObsIn obtain P' where \<open>\<^bold>!(x\<^bold>?.P) \<midarrow>x'\<^bold>?\<rightarrow> P'\<close> by blast
      then have False
      proof cases
        case (TRep Q)
        with False show ?thesis
          by (simp add: in_elim)
      qed
      then show ?thesis ..
    qed simp
  next
    case (ObsOut x')
    then obtain P' where \<open>\<^bold>!(x\<^bold>?.P) \<midarrow>x'\<^bold>!\<rightarrow> P'\<close> by blast
    then have False
    proof cases
      case (TRep Q)
      then show ?thesis
        using in_not_obs_out by blast
    qed
    then show ?thesis ..
  qed
next
  case (Composition P Q \<mu>)
  from this(3) show ?case
  proof cases
    case (ObsOut x)
    then obtain R where *: \<open>\<^bold>!(P \<^bold>| Q) \<midarrow>x\<^bold>!\<rightarrow> R\<close> by blast
    then show ?thesis
    proof (cases \<open>observable (\<^bold>!P) \<mu>\<close>)
      case True
      then show ?thesis
        using Composition.IH TParL observable.simps by metis
    next
      case PF: False
      then show ?thesis
      proof (cases \<open>observable (\<^bold>!Q) \<mu>\<close>)
        case True
        then show ?thesis
          using Composition.IH TParR observable.simps by metis
      next
        case False
        then have NQ: \<open>\<nexists>Q'. Q \<midarrow>x\<^bold>!\<rightarrow> Q'\<close>
          using ObsOut by blast
        moreover from PF have NP: \<open>\<nexists>P'. P \<midarrow>x\<^bold>!\<rightarrow> P'\<close>
          using ObsOut by blast
        moreover from * have \<open>(P \<midarrow>x\<^bold>!\<rightarrow> R) \<or> (Q \<midarrow>x\<^bold>!\<rightarrow> R)\<close>
        proof (cases rule: transition.cases)
          case (TRep P')
          then show ?thesis
            using NP NQ par_add_obs observable.simps by blast
        qed
        ultimately have False
          by blast
        then show ?thesis ..
      qed
    qed
  next
    case (ObsIn x)
    then obtain R where *: \<open>\<^bold>!(P \<^bold>| Q) \<midarrow>x\<^bold>?\<rightarrow> R\<close> by blast
    then show ?thesis
    proof (cases \<open>observable (\<^bold>!P) \<mu>\<close>)
      case True
      then show ?thesis
        using Composition.IH TParL observable.simps by metis
    next
      case PF: False
      then show ?thesis
      proof (cases \<open>observable (\<^bold>!Q) \<mu>\<close>)
        case True
        then show ?thesis
          using Composition.IH TParR observable.simps by metis
      next
        case False
        then have NQ: \<open>\<nexists>Q'. Q \<midarrow>x\<^bold>?\<rightarrow> Q'\<close>
          using ObsIn by blast
        moreover from PF have NP: \<open>\<nexists>P'. P \<midarrow>x\<^bold>?\<rightarrow> P'\<close>
          using ObsIn by blast
        moreover from * have \<open>(P \<midarrow>x\<^bold>?\<rightarrow> R) \<or> (Q \<midarrow>x\<^bold>?\<rightarrow> R)\<close>
        proof (cases rule: transition.cases)
          case (TRep P')
          then show ?thesis
            using NP NQ par_add_obs observable.simps by blast
        qed
        ultimately have False
          by blast
        then show ?thesis ..
      qed
    qed
  qed
next
  case (Replicate P)
  from this(2) show ?case
  proof (cases)
    case (ObsOut x)
    then obtain R where \<open>\<^bold>!\<^bold>!P \<midarrow>x\<^bold>!\<rightarrow> R\<close> by blast
    then show ?thesis
    proof (cases)
      case (TRep P')
      then show ?thesis using ObsOut Replicate.IH
        by blast
    qed
  next
    case (ObsIn x)
    then obtain R where \<open>\<^bold>!\<^bold>!P \<midarrow>x\<^bold>?\<rightarrow> R\<close> by blast
    then show ?thesis
    proof (cases)
      case (TRep P')
      then show ?thesis using ObsIn Replicate.IH
        by blast
    qed
  qed
qed

lemma obs_out_in_names: \<open>observable P (OOut x) \<Longrightarrow> x \<in> names P\<close>
proof (induction P)
  case (Out x' P)
  then show ?case
    by (cases \<open>x = x'\<close>) simp_all
next
  case (In x' P)
  then show ?case
    by (cases \<open>x = x'\<close>) simp_all
next
  case (Composition P Q)
  moreover from this consider \<open>observable P (OOut x)\<close> | \<open>observable Q (OOut x)\<close>
    using par_add_obs by blast
  ultimately show ?case
    by cases auto
next
  case (Replicate P)
  then show ?case
    using names.simps(5) rep_preserves_obs by blast
qed simp

definition sim (\<open>_ \<sim>[_]\<leadsto> _\<close>) where
  \<open>P \<sim>[Rel]\<leadsto> Q \<equiv> (\<forall>\<mu>. observable P \<mu> \<longrightarrow> observable Q \<mu>) \<and>
                   (\<forall>P'. (P \<midarrow>\<tau>\<rightarrow> P') \<longrightarrow> (\<exists>Q'. (Q \<midarrow>\<tau>\<rightarrow> Q') \<and> (Q',P') \<in> Rel))\<close>

lemma simCases [consumes 1, case_names Obs Sim]:
  assumes \<open>\<And>\<mu>. observable P \<mu> \<Longrightarrow> observable Q \<mu>\<close>
    and \<open>\<And>P'. P \<midarrow>\<tau>\<rightarrow> P' \<Longrightarrow> \<exists>Q'. (Q \<midarrow>\<tau>\<rightarrow> Q') \<and> (Q',P') \<in> Rel\<close>
  shows \<open>P \<sim>[Rel]\<leadsto> Q\<close>
  unfolding sim_def by (simp add: assms)

lemma sim_E [elim]:
  assumes \<open>P \<sim>[Rel]\<leadsto> Q\<close>
  shows \<open>observable P \<mu> \<Longrightarrow> observable Q \<mu>\<close>
    and \<open>P \<midarrow>\<tau>\<rightarrow> P' \<Longrightarrow> \<exists>Q'. (Q \<midarrow>\<tau>\<rightarrow> Q') \<and> (Q',P') \<in> Rel\<close>
  using assms unfolding sim_def by auto

lemma sim_refl [simp]: \<open>Id \<subseteq> R \<Longrightarrow> P \<sim>[R]\<leadsto> P\<close>
  unfolding sim_def by auto

lemma sim_trans [simp]:
  assumes PQ: \<open>P \<sim>[X]\<leadsto> Q\<close>
      and QR: \<open>Q \<sim>[Y]\<leadsto> R\<close>
      and XYZ: \<open>Y O X \<subseteq> Z\<close>
    shows \<open>P \<sim>[Z]\<leadsto> R\<close>
proof (cases rule: simCases)
  fix \<mu>
  assume \<open>observable P \<mu>\<close>
  then have \<open>observable Q \<mu>\<close> using PQ by auto
  then show \<open>observable R \<mu>\<close> using QR by auto
next
  fix P'
  assume \<open>P\<midarrow>\<tau>\<rightarrow>P'\<close>
  then have \<open>\<exists>Q'. (Q\<midarrow>\<tau>\<rightarrow>Q') \<and> (Q', P') \<in> X\<close>
    using PQ by auto
  then obtain Q' where \<open>(Q\<midarrow>\<tau>\<rightarrow>Q')\<close> and X: \<open>(Q', P') \<in> X\<close> by blast
  then have \<open>\<exists>R'. (R\<midarrow>\<tau>\<rightarrow>R') \<and> (R', Q') \<in> Y\<close> using QR by auto
  then obtain R' where \<open>(R\<midarrow>\<tau>\<rightarrow>R')\<close> and Y: \<open>(R', Q') \<in> Y\<close> by blast
  moreover have \<open>(R', P') \<in> Z\<close> using X Y XYZ by auto
  ultimately show \<open>\<exists>R'. (R\<midarrow>\<tau>\<rightarrow>R') \<and> (R', P') \<in> Z\<close> by auto
qed

lemma monoCoinduct: \<open>X \<le> Y \<Longrightarrow>
  (Q \<sim>[{(Q', P'). X Q' P'}]\<leadsto> P) \<longrightarrow> (Q \<sim>[{(Q', P'). Y Q' P'}]\<leadsto> P)\<close>
  by (meson Collect_case_prod_mono monotonic)

coinductive_set bisim where
  \<open>P \<sim>[bisim]\<leadsto> Q \<Longrightarrow> (Q,P) \<in> bisim \<Longrightarrow> (P,Q) \<in> bisim\<close>
monos monoCoinduct

abbreviation bisimulation (\<open>_ \<sim> _\<close> [60,60] 40) where
  \<open>P \<sim> Q \<equiv> (P,Q) \<in> bisim\<close>

lemma bisimCoinduct [case_names bisim bisym, consumes 1]:
  assumes pq: \<open>(P,Q) \<in> X\<close>
    and sim: \<open>\<And>R S. (R,S) \<in> X \<Longrightarrow> R \<sim>[X \<union> bisim]\<leadsto> S\<close>
    and sym: \<open>\<And>R S. (R,S) \<in> X \<Longrightarrow> (S,R) \<in> X\<close>
  shows \<open>P \<sim> Q\<close>
proof -
  have *: \<open>X \<union> bisim = {(P',Q'). (P',Q') \<in> X \<or> P' \<sim> Q'}\<close>
    by auto
  from pq show ?thesis
  proof (coinduct)
    case (bisim P Q)
    then show ?case
      using * sym sim by auto
  qed
qed

lemma bisim_E [elim]: \<open>P \<sim> Q \<Longrightarrow> P \<sim>[bisim]\<leadsto> Q\<close>
  by (auto intro: bisim.cases)

lemma bisim_I [intro]: \<open>P \<sim>[bisim]\<leadsto> Q \<Longrightarrow> Q \<sim> P \<Longrightarrow> P \<sim> Q\<close>
  by (rule bisim.intros)

lemma bisim_refl: \<open>reflp bisimulation\<close>
  unfolding reflp_def
proof
  fix P :: process
  have \<open>(P,P) \<in> Id\<close> ..
  then show \<open>P \<sim> P\<close>
    by (coinduct rule: bisimCoinduct) simp_all
qed

lemma bisim_sym: \<open>symp bisimulation\<close>
  by (auto dest: bisim.cases simp add: symp_def)

lemma bisim_trans: \<open>transp bisimulation\<close>
proof
  fix P Q R
  let ?BB = \<open>bisim O bisim\<close>
  assume \<open>P \<sim> Q\<close> \<open>Q \<sim> R\<close>
  then have \<open>(P,R) \<in> ?BB\<close> by blast
  then show \<open>P \<sim> R\<close>
  proof (coinduct rule: bisimCoinduct)
    case (bisim R S)
    then show ?case
      by (metis bisim_E prod.inject relcompE sim_trans sup_ge1)
  next
    case (bisym R S)
    then show ?case
      using bisim_sym sympE[of bisimulation] by auto
  qed
qed

theorem bisim_equiv: \<open>equivp bisimulation\<close>
  using bisim_refl bisim_sym bisim_trans equivpI by auto

subsection \<open>Examples\<close>

lemma \<open>x\<^bold>!.(y\<^bold>!.\<zero>) \<sim> x\<^bold>!.\<zero>\<close> (is \<open>?P \<sim> ?Q\<close>)
proof -
  let ?R = \<open>{(?P, ?Q), (?Q, ?P)}\<close>
  have \<open>(?P, ?Q) \<in> ?R\<close> by simp
  then show ?thesis
  proof (coinduct rule: bisimCoinduct)
    case (bisim R S)
    have \<open>R \<sim>[?R]\<leadsto> S\<close>
    proof (cases rule: simCases)
      fix \<mu>
      assume *: \<open>observable R \<mu>\<close>
      show \<open>observable S \<mu>\<close>
      proof (cases \<mu>)
        case (OOut x')
        then show ?thesis
          using bisim
        proof (cases R)
          case OR: (Out a R')
          then show ?thesis
            using bisim
          proof (cases S)
            case (Out b S')
            then have \<open>x' = x\<close>
              using OR OOut * obs_out_eq bisim by blast
            moreover have \<open>b = x\<close>
              using bisim Out by auto
            ultimately show ?thesis
              using Out OOut by simp
          qed simp_all
        qed simp_all
      next
        case (OIn x')
        then show ?thesis using bisim *
          by (cases R) simp_all
      qed
    next
      fix R'
      assume \<open>R \<midarrow>\<tau>\<rightarrow> R'\<close>
      then have \<open>False\<close>
        using bisim by cases blast+
      then show \<open>\<exists>S'. (S \<midarrow>\<tau>\<rightarrow> S') \<and> (S',R') \<in> ?R\<close> ..
    qed
    then show ?case
      using monotonic by blast
  qed auto
qed

lemma \<open>\<not> ((x\<^bold>!.(y\<^bold>!.\<zero>)) \<^bold>| (x\<^bold>?.\<zero>) \<sim> ((x\<^bold>!.\<zero>) \<^bold>| (x\<^bold>?.\<zero>)))\<close> (is \<open>\<not> (?P \<sim> ?Q)\<close>)
proof
  assume \<open>?P \<sim> ?Q\<close>
  then show False
  proof
    fix P Q
    assume \<open>Q \<sim> P\<close>
    let ?P' = \<open>(y\<^bold>!.\<zero>) \<^bold>| \<zero>\<close>
    assume \<open>?P = P\<close> \<open>?Q = Q\<close>
    moreover assume \<open>P \<sim>[bisim]\<leadsto> Q\<close>
    ultimately have \<open>?P \<sim>[bisim]\<leadsto> ?Q\<close>
      by simp
    then have \<open>\<And>P'. ?P \<midarrow>\<tau>\<rightarrow> P' \<Longrightarrow> \<exists>Q'. (?Q \<midarrow>\<tau>\<rightarrow> Q') \<and> (Q',P') \<in> bisim\<close>
      using sim_E by blast
    moreover have \<open>?P \<midarrow>\<tau>\<rightarrow> ?P'\<close>
      by auto
    ultimately have \<open>\<exists>Q'. (?Q \<midarrow>\<tau>\<rightarrow> Q') \<and> (Q',?P') \<in> bisim\<close>
      by auto
    then obtain Q' where \<open>(?Q \<midarrow>\<tau>\<rightarrow> Q')\<close> and *: \<open>(Q',?P') \<in> bisim\<close>
      by blast
    moreover from this have \<open>Q' = (\<zero> \<^bold>| \<zero>)\<close>
      using in_no_tau out_no_tau
    proof cases
      case (TCommL x' P' Q'')
      then show ?thesis
        using CommL_deterministic by blast
    next
      case (TCommR x' P' Q'')
      from this(2) have False
        by cases
      then show ?thesis ..
    qed fast+
    ultimately have \<open>\<zero> \<^bold>| \<zero> \<sim> ?P'\<close> by simp
    then show False
    proof
      fix R S
      assume \<open>(\<zero> \<^bold>| \<zero>) = R\<close> \<open>?P' = S\<close>
      moreover assume \<open>S \<sim> R\<close>
      ultimately have \<open>?P' \<sim>[bisim]\<leadsto> (\<zero> \<^bold>| \<zero>)\<close> by fast
      then have \<open>observable ?P' (OOut y) \<Longrightarrow> observable (\<zero> \<^bold>| \<zero>) (OOut y)\<close>
        using sim_E by blast
      then have \<open>observable (\<zero> \<^bold>| \<zero>) (OOut y)\<close> by blast
      then have \<open>observable \<zero> (OOut y)\<close>
        using par_add_obs by blast
      then show False by simp
    qed
  qed
qed

lemma \<open>\<^bold>!((x\<^bold>!.\<zero>) \<^bold>| (x\<^bold>?.\<zero>)) \<sim> (\<^bold>!(x\<^bold>!.\<zero>)) \<^bold>| (\<^bold>!(x\<^bold>?.\<zero>))\<close> (is \<open>?P \<sim> ?Q\<close>)
proof -
  let ?R = \<open>{(?P, ?Q), (?Q, ?P)}\<close>
  have \<open>(?P, ?Q) \<in> ?R\<close> by simp
  then show ?thesis
  proof (coinduct rule: bisimCoinduct)
    case (bisim R S)
    have \<open>R \<sim>[?R]\<leadsto> S\<close>
    proof (cases rule: simCases)
      fix \<mu>
      assume *: \<open>observable R \<mu>\<close>
      show \<open>observable S \<mu>\<close>
      proof (cases \<mu>)
        case (OOut x')
        then show ?thesis
          using bisim
        proof (cases R)
          case (Composition P Q)
          then have R: \<open>R = ((\<^bold>!(x\<^bold>!.\<zero>)) \<^bold>| (\<^bold>!(x\<^bold>?.\<zero>)))\<close>
            using bisim by simp
          then show ?thesis using bisim
          proof (cases S)
            case (Replicate P')
            then have \<open>S = \<^bold>!((x\<^bold>!.\<zero>)\<^bold>|(x\<^bold>?.\<zero>))\<close>
              using bisim by simp
            moreover from OOut * have \<open>x' = x\<close> sorry
            ultimately show ?thesis using * R OOut
              by blast
          qed simp_all
        next
          case (Replicate P')
          then show ?thesis sorry
        qed simp_all
      next
        case (OIn x')
        then show ?thesis using bisim * sorry
      qed
    next
      fix R'
      assume \<open>R \<midarrow>\<tau>\<rightarrow> R'\<close>
      then show \<open>\<exists>S'. (S \<midarrow>\<tau>\<rightarrow> S') \<and> (S',R') \<in> ?R\<close>
        using bisim sorry
    qed
    then show ?case
      using monotonic by blast
  qed fast
qed

section \<open>Reduction contexts\<close>

datatype ctx =
    CHole
  | CInaction
  | COut name ctx
  | CIn name ctx
  | CComposition ctx ctx
  | CReplicate ctx

primrec ctx_holes :: \<open>ctx \<Rightarrow> nat\<close> where
  \<open>ctx_holes CHole = 1\<close>
| \<open>ctx_holes CInaction = 0\<close>
| \<open>ctx_holes (COut _ P) = ctx_holes P\<close>
| \<open>ctx_holes (CIn _ P) = ctx_holes P\<close>
| \<open>ctx_holes (CComposition P Q) = ctx_holes P + ctx_holes Q\<close>
| \<open>ctx_holes (CReplicate P) = ctx_holes P\<close>

abbreviation \<open>wf_ctx C \<equiv> ctx_holes C = 1\<close>

primrec apply_ctx (\<open>_\<lbrakk>_\<rbrakk>\<close> [50, 50] 60) where
  \<open>apply_ctx CHole P = P\<close>
| \<open>apply_ctx CInaction P = Inaction\<close>
| \<open>apply_ctx (COut x C) P = Out x (apply_ctx C P)\<close>
| \<open>apply_ctx (CIn x C) P = In x (apply_ctx C P)\<close>
| \<open>apply_ctx (CComposition C1 C2) P = Composition (apply_ctx C1 P) (apply_ctx C2 P)\<close>
| \<open>apply_ctx (CReplicate C) P = Replicate (apply_ctx C P)\<close>

definition congruence where
  \<open>congruence S \<equiv> (\<forall>(P,Q) \<in> S. (\<forall>C. wf_ctx C \<longrightarrow> (C\<lbrakk>P\<rbrakk>, C\<lbrakk>Q\<rbrakk>) \<in> S))\<close>

section \<open>Strong barbed congruence\<close>

coinductive_set sbcong where
  \<open>(\<forall>C. wf_ctx C \<longrightarrow> C\<lbrakk>P\<rbrakk> \<sim> C\<lbrakk>Q\<rbrakk>) \<Longrightarrow> (P,Q) \<in> sbcong\<close>

abbreviation sbcongruence (\<open>_ \<simeq> _\<close> [50, 50] 70) where
  \<open>P \<simeq> Q \<equiv> (P,Q) \<in> sbcong\<close>

lemma sbcong_cong: \<open>congruence sbcong\<close>
  unfolding congruence_def
proof (safe)
  fix P Q C
  assume \<open>P \<simeq> Q\<close>
  assume \<open>wf_ctx C\<close>
  then show \<open>(C\<lbrakk>P\<rbrakk>) \<simeq> (C\<lbrakk>Q\<rbrakk>)\<close>
    sorry
qed

lemma sbcong_sym: \<open>symp sbcongruence\<close>
proof
  fix P Q
  assume \<open>P \<simeq> Q\<close>
  then have *: \<open>(\<forall>C. wf_ctx C \<longrightarrow> C\<lbrakk>P\<rbrakk> \<sim> C\<lbrakk>Q\<rbrakk>)\<close>
    by cases auto
  show \<open>Q \<simeq> P\<close>
  proof (coinduction)
    case sbcong
    have \<open>\<forall>C. wf_ctx C \<longrightarrow> C\<lbrakk>Q\<rbrakk> \<sim> C\<lbrakk>P\<rbrakk>\<close>
    proof (safe)
      fix C
      assume \<open>wf_ctx C\<close>
      then show \<open>C\<lbrakk>Q\<rbrakk> \<sim> C\<lbrakk>P\<rbrakk>\<close>
        using * bisim_sym bisim.cases by blast
    qed
    then show ?case
      by simp
  qed
qed

lemma sbcong_bisim: \<open>P \<simeq> Q \<Longrightarrow> P \<sim> Q\<close>
proof -
  assume \<open>(P,Q) \<in> sbcong\<close>
  then show \<open>P \<sim> Q\<close>
  proof (coinduct rule: bisimCoinduct)
    case (bisim R S)
    then show ?case sorry
  next
    case (bisym R S)
    then show ?case
      using sbcong_sym by (meson symp_def)
  qed
qed

lemma sbcong_largest: \<open>congruence S \<and> S \<subseteq> bisim \<Longrightarrow> S \<subseteq> sbcong\<close>
  oops

theorem challenge: \<open>P \<simeq> Q \<longleftrightarrow> (\<forall>R. (P \<^bold>| R) \<sim> (Q \<^bold>| R))\<close>
  oops

end


theory Peterson
  imports Examples
begin

datatype globals = flag0 | flag1 | turn
record aux = S :: bool

text \<open>
S indicates the conditions under which Thread 0 would have to wait.
Mutual exclusion is demonstrated by ensuring Thread 0 requires a false S,
whilst Thread 1 requires a true S.
\<close>

lemma peterson0:
  "FNBEGIN
    R: (\<^sup>1\<lbrakk>flag0\<rbrakk> \<longrightarrow> \<^sup>1\<^sup>aS \<longrightarrow> \<^sup>2\<^sup>aS) \<and> \<^sup>1\<lbrakk>flag0\<rbrakk> = \<^sup>2\<lbrakk>flag0\<rbrakk> \<and> (\<^sup>2\<lbrakk>turn\<rbrakk> = \<^sup>1\<lbrakk>turn\<rbrakk> \<or> (\<^sup>1\<lbrakk>turn\<rbrakk> \<and> \<not>\<^sup>2\<lbrakk>turn\<rbrakk> \<and> (\<^sup>1\<lbrakk>flag0\<rbrakk> \<longrightarrow> \<^sup>2\<^sup>aS)))
    G: (\<^sup>1\<lbrakk>flag1\<rbrakk> \<longrightarrow> \<^sup>2\<^sup>aS \<longrightarrow> \<^sup>1\<^sup>aS) \<and> \<^sup>1\<lbrakk>flag1\<rbrakk> = \<^sup>2\<lbrakk>flag1\<rbrakk> \<and> (\<^sup>2\<lbrakk>turn\<rbrakk> = \<^sup>1\<lbrakk>turn\<rbrakk> \<or> (\<not>\<^sup>1\<lbrakk>turn\<rbrakk> \<and> \<^sup>2\<lbrakk>turn\<rbrakk> \<and> (\<^sup>1\<lbrakk>flag1\<rbrakk> \<longrightarrow> \<not>\<^sup>2\<^sup>aS)))
    P: True
    {
      \<lbrakk>flag0\<rbrakk> := #True;
      fence;
      \<lbrakk>turn\<rbrakk> := #True :\<^sub>a \<^sup>aS := False;
      fence;
      do
        \<^bold>r(0::nat) := \<lbrakk>flag1\<rbrakk> :\<^sub>a \<^sup>aS := (\<^sup>aS \<or> \<not>\<^sup>0\<lbrakk>flag1\<rbrakk>);
        \<^bold>r1 := \<lbrakk>turn\<rbrakk>
      inv \<lbrace>\<^sup>0\<lbrakk>flag0\<rbrakk> \<and> (\<^sup>aS \<or> \<^sup>0\<lbrakk>turn\<rbrakk>)\<rbrace>
      while (\<^bold>r0 && \<^bold>r1);
      fence;
      \<lbrace>\<^sup>aS\<rbrace> skip;
      fence;
      \<lbrakk>flag0\<rbrakk> := #False
    }
    Q: True
  FNEND"
  apply (unfold fn_valid.simps, intro conjI)

  (* Stability of Q + Wellformedness of R & G *)
  apply (auto simp: step\<^sub>t_def stable_def reflexive_def transitive_def)[4]

  (* Guarantees of each atomic action *)
  apply (clarsimp simp: aux_upd_def step_def glb_def wp\<^sub>r_def st_upd_def)

  (* WP reasoning *)
  apply (simp add: c_and_def test_def)
  apply (intro conjI impI)
  apply (clarsimp simp: stabilize_def st_upd_def glb_def rg_def aux_upd_def)
  apply (clarsimp simp: stabilize_def st_upd_def glb_def rg_def aux_upd_def)
  apply (clarsimp simp: stabilize_def st_upd_def glb_def rg_def aux_upd_def)
  apply (clarsimp simp: stabilize_def st_upd_def glb_def rg_def aux_upd_def)
  apply (metis less_numeral_extra(3))

  (* RIF *)
  apply rif_eval
  apply (clarsimp simp: expand_points_def checks_def, unfold chk_def)
  apply (intro allI conjI impI)
  apply (auto simp: guar_def st_upd_def step_def glb_def aux_upd_def liftg_def)[1]
  apply (rule wp_split[where ?f="\<lambda>a b. b(Glb turn :=\<^sub>s st a (Glb turn), Reg 1 :=\<^sub>s st a (Reg 1))"]; clarsimp simp: step\<^sub>t_def)
  apply (intro conjI impI state_eq; clarsimp simp add: glb_def; metis rg_def)
  by (intro conjI impI state_eq; clarsimp simp add: glb_def)

lemma peterson1:
  "FNBEGIN
    R: (\<^sup>1\<lbrakk>flag1\<rbrakk> \<longrightarrow> \<^sup>2\<^sup>aS \<longrightarrow> \<^sup>1\<^sup>aS) \<and> \<^sup>1\<lbrakk>flag1\<rbrakk> = \<^sup>2\<lbrakk>flag1\<rbrakk> \<and> (\<^sup>2\<lbrakk>turn\<rbrakk> = \<^sup>1\<lbrakk>turn\<rbrakk> \<or> (\<not>\<^sup>1\<lbrakk>turn\<rbrakk> \<and> \<^sup>2\<lbrakk>turn\<rbrakk> \<and> (\<^sup>1\<lbrakk>flag1\<rbrakk> \<longrightarrow> \<not>\<^sup>2\<^sup>aS)))
    G: (\<^sup>1\<lbrakk>flag0\<rbrakk> \<longrightarrow> \<^sup>1\<^sup>aS \<longrightarrow> \<^sup>2\<^sup>aS) \<and> \<^sup>1\<lbrakk>flag0\<rbrakk> = \<^sup>2\<lbrakk>flag0\<rbrakk> \<and> (\<^sup>2\<lbrakk>turn\<rbrakk> = \<^sup>1\<lbrakk>turn\<rbrakk> \<or> (\<^sup>1\<lbrakk>turn\<rbrakk> \<and> \<not>\<^sup>2\<lbrakk>turn\<rbrakk> \<and> (\<^sup>1\<lbrakk>flag0\<rbrakk> \<longrightarrow> \<^sup>2\<^sup>aS)))
    P: True
    {
      \<lbrakk>flag1\<rbrakk> := #True;
      fence;
      \<lbrakk>turn\<rbrakk> := #False :\<^sub>a \<^sup>aS := True;
      fence;
      do
        \<^bold>r(0::nat) := \<lbrakk>flag0\<rbrakk> :\<^sub>a \<^sup>aS := (\<^sup>aS \<and> \<^sup>0\<lbrakk>flag0\<rbrakk>);
        \<^bold>r1 := (!\<lbrakk>turn\<rbrakk>)
      inv \<lbrace>\<^sup>0\<lbrakk>flag1\<rbrakk> \<and> (\<not>\<^sup>0\<lbrakk>turn\<rbrakk> \<or> \<not>\<^sup>aS)\<rbrace>
      while (\<^bold>r0 && \<^bold>r1);
      fence;
      \<lbrace>\<not>\<^sup>aS\<rbrace> skip;
      fence;
      \<lbrakk>flag1\<rbrakk> := #False
    }
    Q: True
  FNEND"
  apply(unfold fn_valid.simps, intro conjI)

  (* Stability of Q + Wellformedness of R & G *)
  apply (auto simp: step\<^sub>t_def stable_def reflexive_def transitive_def)[4]

  (* Guarantees of each atomic action *)
  apply (clarsimp simp: aux_upd_def step_def glb_def wp\<^sub>r_def st_upd_def)

  (* WP reasoning *)
  apply (simp add: c_neg_def c_and_def test_def)
  apply (intro conjI impI)
  apply (clarsimp simp: stabilize_def st_upd_def glb_def rg_def aux_upd_def)+
  apply (metis less_numeral_extra(3))

  (* RIF *)
  apply rif_eval
  apply (clarsimp simp: expand_points_def checks_def, unfold chk_def)
  apply (intro allI conjI impI)
  apply (auto simp: guar_def st_upd_def step_def glb_def aux_upd_def liftg_def)[1]
  apply (rule wp_split[where ?f="\<lambda>a b. b(Glb turn :=\<^sub>s st a (Glb turn), Reg 1 :=\<^sub>s st a (Reg 1))"]; clarsimp simp: c_neg_def step\<^sub>t_def)
  apply (intro conjI impI state_eq; clarsimp simp add: glb_def; metis rg_def)
  by (intro conjI impI state_eq; clarsimp simp add: glb_def)

end


(*Run with
  isabelle jedit -l CTT  CTT_Examples.thy
*)
theory CTT_Examples
imports "CTT.CTT"
begin

schematic_goal "?A type"
  apply (rule form_rls)
  back
   apply (rule form_rls)
  apply (rule form_rls)
  done

schematic_goal "<0, succ(0)> : ?A"
  apply (rule intr_rls)
   apply (rule intr_rls)
  apply (rule intr_rls)
  apply (rule intr_rls)
  done

lemma "<0, succ(0)> : N \<times> N"
  by (rule intr_rls)+

text "typechecking the addition function"

schematic_goal "\<^bold>\<lambda>n. \<^bold>\<lambda>m. rec(n, m, \<lambda>x y. succ(y)) : ?A"
  apply (rule intr_rls form_rls elim_rls | assumption)+
  done

text "This finds the functions fst and snd!"

schematic_goal "A type \<Longrightarrow> ?a : (A \<times> A) \<longrightarrow> A"
  apply (rule intr_rls form_rls | erule elim_rls | assumption)+
  back
  done

text "Double negation of the Excluded Middle"
schematic_goal "A type \<Longrightarrow> ?a : ((A + (A\<longrightarrow>F)) \<longrightarrow> F) \<longrightarrow> F"
  apply intr
  apply (rule ProdE)
   apply assumption
  apply pc
  done

(*Experiment: the proof above in Isar*)
lemma
  assumes "A type" shows "(\<^bold>\<lambda>f. f ` inr(\<^bold>\<lambda>y. f ` inl(y))) : ((A + (A\<longrightarrow>F)) \<longrightarrow> F) \<longrightarrow> F"
proof intr
  fix f
  assume f: "f : A + (A \<longrightarrow> F) \<longrightarrow> F"
  with assms have "inr(\<^bold>\<lambda>y. f ` inl(y)) : A + (A \<longrightarrow> F)"
    by pc
  then show "f ` inr(\<^bold>\<lambda>y. f ` inl(y)) : F"
    by (rule ProdE [OF f])
qed (rule assms)+

text "Binary sums and products"
schematic_goal "\<lbrakk>A type; B type; C type\<rbrakk> \<Longrightarrow> ?a : (A + B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C) \<times> (B \<longrightarrow> C)"
  apply pc
  done

(*A distributive law*)
schematic_goal
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x. x:A \<Longrightarrow> C(x) type"
  shows "?a : (\<Sum>x:A. B(x) + C(x)) \<longrightarrow> (\<Sum>x:A. B(x)) + (\<Sum>x:A. C(x))"
  apply (pc assms)
  done

text "Construction of the currying functional"
schematic_goal
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>z. z: (\<Sum>x:A. B(x)) \<Longrightarrow> C(z) type"
  shows "?a : \<Prod>f: (\<Prod>z : (\<Sum>x:A . B(x)) . C(z)).
                      (\<Prod>x:A . \<Prod>y:B(x) . C(<x,y>))"
  apply (pc assms)
  done

text "Martin-Löf (1984), page 48: axiom of sum-elimination (uncurry)"
schematic_goal
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>z. z: (\<Sum>x:A . B(x)) \<Longrightarrow> C(z) type"
  shows "?a : (\<Prod>x:A . \<Prod>y:B(x) . C(<x,y>))
        \<longrightarrow> (\<Prod>z : (\<Sum>x:A . B(x)) . C(z))"
  apply (pc assms)
  done

text "Basic test of quantifier reasoning"
schematic_goal
  assumes "A type"
    and "B type"
    and "\<And>x y. \<lbrakk>x:A; y:B\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows
    "?a :     (\<Sum>y:B . \<Prod>x:A . C(x,y))
          \<longrightarrow> (\<Prod>x:A . \<Sum>y:B . C(x,y))"
  apply (pc assms)
  done

text "Martin-Löf (1984) pages 36-7: the combinator S"
schematic_goal
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows "?a :    (\<Prod>x:A. \<Prod>y:B(x). C(x,y))
             \<longrightarrow> (\<Prod>f: (\<Prod>x:A. B(x)). \<Prod>x:A. C(x, f`x))"
  apply (pc assms)
  done

text "Martin-Löf (1984) page 58: the axiom of disjunction elimination"
schematic_goal
  assumes "A type"
    and "B type"
    and "\<And>z. z: A+B \<Longrightarrow> C(z) type"
  shows "?a : (\<Prod>x:A. C(inl(x))) \<longrightarrow> (\<Prod>y:B. C(inr(y)))
          \<longrightarrow> (\<Prod>z: A+B. C(z))"
  apply (pc assms)
  done

(*Martin-Löf (1984) page 50*)
text "AXIOM OF CHOICE!  Delicate use of elimination rules"
lemma Axiom_of_Choice:
  assumes "A type"
    and "\<And>x. x:A \<Longrightarrow> B(x) type"
    and "\<And>x y. \<lbrakk>x:A; y:B(x)\<rbrakk> \<Longrightarrow> C(x,y) type"
  shows "(\<^bold>\<lambda>f. <\<^bold>\<lambda>x. fst(f`x), \<^bold>\<lambda>x. snd(f`x)>)
        : (\<Prod>x:A. \<Sum>y:B(x). C(x,y)) \<longrightarrow> (\<Sum>f: (\<Prod>x:A. B(x)). \<Prod>x:A. C(x, f`x))"
proof (intr assms)
  fix f a
  assume f: "f : \<Prod>x:A. Sum(B(x), C(x))" and "a : A"
  then have fa: "f`a : Sum(B(a), C(a))"
    by (rule ProdE)
  then show "fst(f ` a) : B(a)"
    by (rule SumE_fst)
  have "snd(f ` a) : C(a, fst(f ` a))"
    by (rule SumE_snd [OF fa]) (typechk SumE_fst assms \<open>a : A\<close>)
  moreover have "(\<^bold>\<lambda>x. fst(f ` x)) ` a = fst(f ` a) : B(a)"
    by (rule ProdC [OF \<open>a : A\<close>]) (typechk SumE_fst f)
  ultimately show "snd(f`a) : C(a, (\<^bold>\<lambda>x. fst(f ` x)) ` a)"
    by (intro replace_type [OF subst_eqtyparg]) (typechk SumE_fst assms \<open>a : A\<close>)
qed

end


(*<*)
theory Event_Data
  imports
    "HOL-Library.Char_ord"
    Code_Double
    Deriving.Derive
begin
(*>*)

section \<open>Code adaptation for 8-bit strings\<close>

typedef string8 = "UNIV :: char list set" ..

setup_lifting type_definition_string8

lift_definition empty_string :: string8 is "[]" .
lift_definition string8_literal :: "String.literal \<Rightarrow> string8" is String.explode .
lift_definition literal_string8:: "string8 \<Rightarrow> String.literal" is String.Abs_literal .
declare [[coercion string8_literal]]

instantiation string8 :: "{equal, linorder}"
begin

lift_definition equal_string8 :: "string8 \<Rightarrow> string8 \<Rightarrow> bool" is HOL.equal .
lift_definition less_eq_string8 :: "string8 \<Rightarrow> string8 \<Rightarrow> bool" is ord_class.lexordp_eq .
lift_definition less_string8 :: "string8 \<Rightarrow> string8 \<Rightarrow> bool" is ord_class.lexordp .

instance by intro_classes
    (transfer; auto simp: equal_eq lexordp_conv_lexordp_eq lexordp_eq_linear
      intro: lexordp_eq_refl lexordp_eq_trans lexordp_eq_antisym)+

end

lifting_forget string8.lifting

declare [[code drop: literal_string8 string8_literal  "HOL.equal :: string8 \<Rightarrow> _"
      "(\<le>) :: string8 \<Rightarrow> _" "(<) :: string8 \<Rightarrow> _"
      "Code_Evaluation.term_of :: string8 \<Rightarrow> _"]]

code_printing
  type_constructor string8 \<rightharpoonup> (OCaml) "string"
  | constant "HOL.equal :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(=)"
  | constant "(\<le>) :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<=)"
  | constant "(<) :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<)"
  | constant "empty_string :: string8" \<rightharpoonup> (OCaml) "\"\""
  | constant "string8_literal :: String.literal \<Rightarrow> string8" \<rightharpoonup> (OCaml) "id"
  | constant "literal_string8 :: string8 \<Rightarrow> String.literal" \<rightharpoonup> (OCaml) "id"

ML \<open>
structure String8 =
struct
  fun to_term x = @{term Abs_string8} $ HOLogic.mk_string x;
end;
\<close>

code_printing
  type_constructor string8 \<rightharpoonup> (Eval) "string"
  | constant "string8_literal :: String.literal \<Rightarrow> string8" \<rightharpoonup> (Eval) "_"
  | constant "HOL.equal :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (Eval) infixl 6 "="
  | constant "(\<le>) :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (Eval) infixl 6 "<="
  | constant "(<) :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (Eval) infixl 6 "<"
  | constant "Code_Evaluation.term_of :: string8 \<Rightarrow> term" \<rightharpoonup> (Eval) "String8.to'_term"

ML \<open>
structure String8 =
struct
  fun to_term x = @{term Abs_string8} $ HOLogic.mk_string x;
end;
\<close>

code_printing
  type_constructor string8 \<rightharpoonup> (Eval) "string"
  | constant "string8_literal :: String.literal \<Rightarrow> string8" \<rightharpoonup> (Eval) "_"
  | constant "HOL.equal :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (Eval) infixl 6 "="
  | constant "(\<le>) :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (Eval) infixl 6 "<="
  | constant "(<) :: string8 \<Rightarrow> string8 \<Rightarrow> bool" \<rightharpoonup> (Eval) infixl 6 "<"
  | constant "Code_Evaluation.term_of :: string8 \<Rightarrow> term" \<rightharpoonup> (Eval) "String8.to'_term"

derive (eq) ceq string8
derive (linorder) compare string8
derive (compare) ccompare string8

section \<open>Event parameters\<close>

definition div_to_zero :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "div_to_zero x y = (let z = fst (Code_Numeral.divmod_abs x y) in
    if (x < 0) \<noteq> (y < 0) then - z else z)"

definition mod_to_zero :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "mod_to_zero x y = (let z = snd (Code_Numeral.divmod_abs x y) in
    if x < 0 then - z else z)"

lemma "b \<noteq> 0 \<Longrightarrow> div_to_zero a b * b + mod_to_zero a b = a"
  unfolding div_to_zero_def mod_to_zero_def Let_def
  by (auto simp: minus_mod_eq_mult_div[symmetric] div_minus_right mod_minus_right ac_simps)

datatype event_data = EInt integer | EFloat double | EString string8

derive (eq) ceq event_data
derive ccompare event_data

instantiation event_data :: "{ord, plus, minus, uminus, times, divide, modulo}"
begin

fun less_eq_event_data where
  "EInt x \<le> EInt y \<longleftrightarrow> x \<le> y"
| "EFloat x \<le> EFloat y \<longleftrightarrow> x \<le> y"
| "EString x \<le> EString y \<longleftrightarrow> x \<le> y"
| "(_::event_data) \<le> _ \<longleftrightarrow> undefined"

definition less_event_data :: "event_data \<Rightarrow> event_data \<Rightarrow> bool"  where
  "less_event_data x y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"

fun plus_event_data where
  "EInt x + EInt y = EInt (x + y)"
| "EFloat x + EFloat y = EFloat (x + y)"
| "(_::event_data) + _ = undefined"

fun minus_event_data where
  "EInt x - EInt y = EInt (x - y)"
| "EFloat x - EFloat y = EFloat (x - y)"
| "(_::event_data) - _ = undefined"

fun uminus_event_data where
  "- EInt x = EInt (- x)"
| "- EFloat x = EFloat (- x)"
| "- (_::event_data) = undefined"

fun times_event_data where
  "EInt x * EInt y = EInt (x * y)"
| "EFloat x * EFloat y = EFloat (x * y)"
| "(_::event_data) * _ = undefined"

fun divide_event_data where
  "EInt x div EInt y = EInt (div_to_zero x y)"
| "EFloat x div EFloat y = EFloat (x div y)"
| "(_::event_data) div _ = undefined"

fun modulo_event_data where
  "EInt x mod EInt y = EInt (mod_to_zero x y)"
| "(_::event_data) mod _ = undefined"

instance ..

end

lemma infinite_UNIV_event_data:
  "\<not>finite (UNIV :: event_data set)"
proof -
  define f where "f = (\<lambda>k. EInt k)"
  have inj: "inj_on f (UNIV :: integer set)"
    unfolding f_def by (meson event_data.inject(1) injI)
  show ?thesis using finite_imageD[OF _ inj]
    by (meson infinite_UNIV_char_0 infinite_iff_countable_subset top_greatest)
qed

instantiation event_data :: card_UNIV begin
definition "finite_UNIV = Phantom(event_data) False"
definition "card_UNIV = Phantom(event_data) 0"
instance by intro_classes (simp_all add: finite_UNIV_event_data_def card_UNIV_event_data_def infinite_UNIV_event_data)
end

primrec integer_of_event_data :: "event_data \<Rightarrow> integer" where
  "integer_of_event_data (EInt _) = undefined"
| "integer_of_event_data (EFloat x) = integer_of_double x"
| "integer_of_event_data (EString _) = undefined"

primrec double_of_event_data :: "event_data \<Rightarrow> double" where
  "double_of_event_data (EInt x) = double_of_integer x"
| "double_of_event_data (EFloat _) = undefined"
| "double_of_event_data (EString _) = undefined"

primrec double_of_event_data_agg :: "event_data \<Rightarrow> double" where
  "double_of_event_data_agg (EInt x) = double_of_integer x"
| "double_of_event_data_agg (EFloat x) = x"
| "double_of_event_data_agg (EString _) = undefined"

(*<*)
end
(*>*)