(*  Title:      HOL/HOLCF/Library/Sum_Cpo.thy
    Author:     Brian Huffman
*)

section {* The cpo of disjoint sums *}

theory Sum_Cpo
imports HOLCF
begin

subsection {* Ordering on sum type *}

instantiation sum :: (below, below) below
begin

definition below_sum_def:
  "x \<sqsubseteq> y \<equiv> case x of
         Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
         Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"

instance ..
end

lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y \<longleftrightarrow> x \<sqsubseteq> y"
unfolding below_sum_def by simp

lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y \<longleftrightarrow> x \<sqsubseteq> y"
unfolding below_sum_def by simp

lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
unfolding below_sum_def by simp

lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
unfolding below_sum_def by simp

lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
by simp

lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
by simp

lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (cases x, simp_all)

lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (cases x, simp_all)

lemmas sum_below_elims = Inl_belowE Inr_belowE

lemma sum_below_cases:
  "\<lbrakk>x \<sqsubseteq> y;
    \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
    \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
      \<Longrightarrow> R"
by (cases x, safe elim!: sum_below_elims, auto)

subsection {* Sum type is a complete partial order *}

instance sum :: (po, po) po
proof
  fix x :: "'a + 'b"
  show "x \<sqsubseteq> x"
    by (induct x, simp_all)
next
  fix x y :: "'a + 'b"
  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
    by (induct x, auto elim!: sum_below_elims intro: below_antisym)
next
  fix x y z :: "'a + 'b"
  assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    by (induct x, auto elim!: sum_below_elims intro: below_trans)
qed

lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
by (rule monofunI, erule sum_below_cases, simp_all)

lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
by (rule monofunI, erule sum_below_cases, simp_all)

lemma sum_chain_cases:
  assumes Y: "chain Y"
  assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
  assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
  shows "R"
 apply (cases "Y 0")
  apply (rule A)
   apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
  apply (rule ext)
  apply (cut_tac j=i in chain_mono [OF Y le0], simp)
  apply (erule Inl_belowE, simp)
 apply (rule B)
  apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
 apply (rule ext)
 apply (cut_tac j=i in chain_mono [OF Y le0], simp)
 apply (erule Inr_belowE, simp)
done

lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
 apply (rule is_lubI)
  apply (rule ub_rangeI)
  apply (simp add: is_lub_rangeD1)
 apply (frule ub_rangeD [where i=arbitrary])
 apply (erule Inl_belowE, simp)
 apply (erule is_lubD2)
 apply (rule ub_rangeI)
 apply (drule ub_rangeD, simp)
done

lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
 apply (rule is_lubI)
  apply (rule ub_rangeI)
  apply (simp add: is_lub_rangeD1)
 apply (frule ub_rangeD [where i=arbitrary])
 apply (erule Inr_belowE, simp)
 apply (erule is_lubD2)
 apply (rule ub_rangeI)
 apply (drule ub_rangeD, simp)
done

instance sum :: (cpo, cpo) cpo
 apply intro_classes
 apply (erule sum_chain_cases, safe)
  apply (rule exI)
  apply (rule is_lub_Inl)
  apply (erule cpo_lubI)
 apply (rule exI)
 apply (rule is_lub_Inr)
 apply (erule cpo_lubI)
done

subsection {* Continuity of \emph{Inl}, \emph{Inr}, and case function *}

lemma cont_Inl: "cont Inl"
by (intro contI is_lub_Inl cpo_lubI)

lemma cont_Inr: "cont Inr"
by (intro contI is_lub_Inr cpo_lubI)

lemmas cont2cont_Inl [simp, cont2cont] = cont_compose [OF cont_Inl]
lemmas cont2cont_Inr [simp, cont2cont] = cont_compose [OF cont_Inr]

lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]

lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]

lemma cont_case_sum1:
  assumes f: "\<And>a. cont (\<lambda>x. f x a)"
  assumes g: "\<And>b. cont (\<lambda>x. g x b)"
  shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
by (induct y, simp add: f, simp add: g)

lemma cont_case_sum2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (case_sum f g)"
apply (rule contI)
apply (erule sum_chain_cases)
apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
done

lemma cont2cont_case_sum:
  assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
  assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
  assumes h: "cont (\<lambda>x. h x)"
  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
apply (rule cont_apply [OF h])
apply (rule cont_case_sum2 [OF f2 g2])
apply (rule cont_case_sum1 [OF f1 g1])
done

lemma cont2cont_case_sum' [simp, cont2cont]:
  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
  assumes h: "cont (\<lambda>x. h x)"
  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
using assms by (simp add: cont2cont_case_sum prod_cont_iff)

text {* Continuity of map function. *}

lemma map_sum_eq: "map_sum f g = case_sum (\<lambda>a. Inl (f a)) (\<lambda>b. Inr (g b))"
by (rule ext, case_tac x, simp_all)

lemma cont2cont_map_sum [simp, cont2cont]:
  assumes f: "cont (\<lambda>(x, y). f x y)"
  assumes g: "cont (\<lambda>(x, y). g x y)"
  assumes h: "cont (\<lambda>x. h x)"
  shows "cont (\<lambda>x. map_sum (\<lambda>y. f x y) (\<lambda>y. g x y) (h x))"
using assms by (simp add: map_sum_eq prod_cont_iff)

subsection {* Compactness and chain-finiteness *}

lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
apply (rule compactI2)
apply (erule sum_chain_cases, safe)
apply (simp add: lub_Inl)
apply (erule (2) compactD2)
apply (simp add: lub_Inr)
done

lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
apply (rule compactI2)
apply (erule sum_chain_cases, safe)
apply (simp add: lub_Inl)
apply (simp add: lub_Inr)
apply (erule (2) compactD2)
done

lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
unfolding compact_def
by (drule adm_subst [OF cont_Inl], simp)

lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
unfolding compact_def
by (drule adm_subst [OF cont_Inr], simp)

lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
by (safe elim!: compact_Inl compact_Inl_rev)

lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
by (safe elim!: compact_Inr compact_Inr_rev)

instance sum :: (chfin, chfin) chfin
apply intro_classes
apply (erule compact_imp_max_in_chain)
apply (case_tac "\<Squnion>i. Y i", simp_all)
done

instance sum :: (discrete_cpo, discrete_cpo) discrete_cpo
by intro_classes (simp add: below_sum_def split: sum.split)

subsection {* Using sum types with fixrec *}

definition
  "match_Inl = (\<Lambda> x k. case x of Inl a \<Rightarrow> k\<cdot>a | Inr b \<Rightarrow> Fixrec.fail)"

definition
  "match_Inr = (\<Lambda> x k. case x of Inl a \<Rightarrow> Fixrec.fail | Inr b \<Rightarrow> k\<cdot>b)"

lemma match_Inl_simps [simp]:
  "match_Inl\<cdot>(Inl a)\<cdot>k = k\<cdot>a"
  "match_Inl\<cdot>(Inr b)\<cdot>k = Fixrec.fail"
unfolding match_Inl_def by simp_all

lemma match_Inr_simps [simp]:
  "match_Inr\<cdot>(Inl a)\<cdot>k = Fixrec.fail"
  "match_Inr\<cdot>(Inr b)\<cdot>k = k\<cdot>b"
unfolding match_Inr_def by simp_all

setup {*
  Fixrec.add_matchers
    [ (@{const_name Inl}, @{const_name match_Inl}),
      (@{const_name Inr}, @{const_name match_Inr}) ]
*}

subsection {* Disjoint sum is a predomain *}

definition
  "encode_sum_u =
    (\<Lambda>(up\<cdot>x). case x of Inl a \<Rightarrow> sinl\<cdot>(up\<cdot>a) | Inr b \<Rightarrow> sinr\<cdot>(up\<cdot>b))"

definition
  "decode_sum_u = sscase\<cdot>(\<Lambda>(up\<cdot>a). up\<cdot>(Inl a))\<cdot>(\<Lambda>(up\<cdot>b). up\<cdot>(Inr b))"

lemma decode_encode_sum_u [simp]: "decode_sum_u\<cdot>(encode_sum_u\<cdot>x) = x"
unfolding decode_sum_u_def encode_sum_u_def
by (case_tac x, simp, rename_tac y, case_tac y, simp_all)

lemma encode_decode_sum_u [simp]: "encode_sum_u\<cdot>(decode_sum_u\<cdot>x) = x"
unfolding decode_sum_u_def encode_sum_u_def
apply (case_tac x, simp)
apply (rename_tac a, case_tac a, simp, simp)
apply (rename_tac b, case_tac b, simp, simp)
done

text {* A deflation combinator for making unpointed types *}

definition udefl :: "udom defl \<rightarrow> udom u defl"
  where "udefl = defl_fun1 (strictify\<cdot>up) (fup\<cdot>ID) ID"

lemma ep_pair_strictify_up:
  "ep_pair (strictify\<cdot>up) (fup\<cdot>ID)"
apply (rule ep_pair.intro)
apply (simp add: strictify_conv_if)
apply (case_tac y, simp, simp add: strictify_conv_if)
done

lemma cast_udefl:
  "cast\<cdot>(udefl\<cdot>t) = strictify\<cdot>up oo cast\<cdot>t oo fup\<cdot>ID"
unfolding udefl_def by (simp add: cast_defl_fun1 ep_pair_strictify_up)

definition sum_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
  where "sum_liftdefl = (\<Lambda> a b. udefl\<cdot>(ssum_defl\<cdot>(u_liftdefl\<cdot>a)\<cdot>(u_liftdefl\<cdot>b)))"

lemma u_emb_bottom: "u_emb\<cdot>\<bottom> = \<bottom>"
by (rule pcpo_ep_pair.e_strict [unfolded pcpo_ep_pair_def, OF ep_pair_u])

(*
definition sum_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
  where "sum_liftdefl = defl_fun2 (u_map\<cdot>emb oo strictify\<cdot>up)
    (fup\<cdot>ID oo u_map\<cdot>prj) ssum_map"
*)

instantiation sum :: (predomain, predomain) predomain
begin

definition
  "liftemb = (strictify\<cdot>up oo ssum_emb) oo
    (ssum_map\<cdot>(u_emb oo liftemb)\<cdot>(u_emb oo liftemb) oo encode_sum_u)"

definition
  "liftprj = (decode_sum_u oo ssum_map\<cdot>(liftprj oo u_prj)\<cdot>(liftprj oo u_prj))
    oo (ssum_prj oo fup\<cdot>ID)"

definition
  "liftdefl (t::('a + 'b) itself) = sum_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"

instance proof
  show "ep_pair liftemb (liftprj :: udom u \<rightarrow> ('a + 'b) u)"
    unfolding liftemb_sum_def liftprj_sum_def
    by (intro ep_pair_comp ep_pair_ssum_map ep_pair_u predomain_ep
      ep_pair_ssum ep_pair_strictify_up, simp add: ep_pair.intro)
  show "cast\<cdot>LIFTDEFL('a + 'b) = liftemb oo (liftprj :: udom u \<rightarrow> ('a + 'b) u)"
    unfolding liftemb_sum_def liftprj_sum_def liftdefl_sum_def
    by (simp add: sum_liftdefl_def cast_udefl cast_ssum_defl cast_u_liftdefl
      cast_liftdefl cfcomp1 ssum_map_map u_emb_bottom)
qed

end

subsection {* Configuring domain package to work with sum type *}

lemma liftdefl_sum [domain_defl_simps]:
  "LIFTDEFL('a::predomain + 'b::predomain) =
    sum_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"
by (rule liftdefl_sum_def)

abbreviation map_sum'
  where "map_sum' f g \<equiv> Abs_cfun (map_sum (Rep_cfun f) (Rep_cfun g))"

lemma map_sum_ID [domain_map_ID]: "map_sum' ID ID = ID"
by (simp add: ID_def cfun_eq_iff map_sum.identity id_def)

lemma deflation_map_sum [domain_deflation]:
  "\<lbrakk>deflation d1; deflation d2\<rbrakk> \<Longrightarrow> deflation (map_sum' d1 d2)"
apply default
apply (induct_tac x, simp_all add: deflation.idem)
apply (induct_tac x, simp_all add: deflation.below)
done

lemma encode_sum_u_map_sum:
  "encode_sum_u\<cdot>(u_map\<cdot>(map_sum' f g)\<cdot>(decode_sum_u\<cdot>x))
    = ssum_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>g)\<cdot>x"
apply (induct x, simp add: decode_sum_u_def encode_sum_u_def)
apply (case_tac x, simp, simp add: decode_sum_u_def encode_sum_u_def)
apply (case_tac y, simp, simp add: decode_sum_u_def encode_sum_u_def)
done

lemma isodefl_sum [domain_isodefl]:
  fixes d :: "'a::predomain \<rightarrow> 'a"
  assumes "isodefl' d1 t1" and "isodefl' d2 t2"
  shows "isodefl' (map_sum' d1 d2) (sum_liftdefl\<cdot>t1\<cdot>t2)"
using assms unfolding isodefl'_def liftemb_sum_def liftprj_sum_def
apply (simp add: sum_liftdefl_def cast_udefl cast_ssum_defl cast_u_liftdefl)
apply (simp add: cfcomp1 encode_sum_u_map_sum)
apply (simp add: ssum_map_map u_emb_bottom)
done

setup {*
  Domain_Take_Proofs.add_rec_type (@{type_name "sum"}, [true, true])
*}

end


section \<open>Implementation\<close>
theory Affine_Code
  imports
    Affine_Approximation
    Intersection
begin

text \<open>Implementing partial deviations as sorted lists of coefficients.\<close>

subsection \<open>Reverse Sorted, Distinct Association Lists\<close>

typedef (overloaded) ('a, 'b) slist =
  "{xs::('a::linorder \<times> 'b) list. distinct (map fst xs) \<and> sorted (rev (map fst xs))}"
  by (auto intro!: exI[where x="[]"])

setup_lifting type_definition_slist

lift_definition map_of_slist::"(nat, 'a::zero) slist \<Rightarrow> nat \<Rightarrow> 'a option" is map_of .

lemma finite_dom_map_of_slist[intro, simp]: "finite (dom (map_of_slist xs))"
  by transfer (auto simp: finite_dom_map_of)

abbreviation "the_default a x \<equiv> (case x of None \<Rightarrow> a | Some b \<Rightarrow> b)"

definition "Pdevs_raw xs i = the_default 0 (map_of xs i)"

lemma nonzeros_Pdevs_raw_subset: "{i. Pdevs_raw xs i \<noteq> 0} \<subseteq> dom (map_of xs)"
  unfolding Pdevs_raw_def[abs_def]
  by transfer (auto simp: Pdevs_raw_def split: option.split_asm)

lift_definition Pdevs::"(nat, 'a::zero) slist \<Rightarrow> 'a pdevs"
  is Pdevs_raw
  by (rule finite_subset[OF nonzeros_Pdevs_raw_subset]) (simp add: finite_dom_map_of)

code_datatype Pdevs

subsection \<open>Degree\<close>

primrec degree_list::"(nat \<times> 'a::zero) list \<Rightarrow> nat" where
  "degree_list [] = 0"
| "degree_list (x#xs) = (if snd x = 0 then degree_list xs else Suc (fst x))"

lift_definition degree_slist::"(nat, 'a::zero) slist \<Rightarrow> nat" is degree_list .

lemma degree_list_eq_zeroD:
  assumes "degree_list xs = 0"
  shows "the_default 0 (map_of xs i) = 0"
  using assms
  by (induct xs) (auto simp: Pdevs_raw_def sorted_append split: if_split_asm)

lemma degree_slist_eq_zeroD: "degree_slist xs = 0 \<Longrightarrow> degree (Pdevs xs) = 0"
  unfolding degree_eq_Suc_max
  by transfer (auto dest: degree_list_eq_zeroD simp: Pdevs_raw_def)

lemma degree_slist_eq_SucD: "degree_slist xs = Suc n \<Longrightarrow> pdevs_apply (Pdevs xs) n \<noteq> 0"
proof (transfer, goal_cases)
  case (1 xs n)
  thus ?case
    by (induct xs)
      (auto simp: Pdevs_raw_def sorted_append map_of_eq_None_iff[symmetric]
        split: if_split_asm option.split_asm)
qed

lemma degree_slist_zero:
  "degree_slist xs = n \<Longrightarrow> n \<le> j \<Longrightarrow> pdevs_apply (Pdevs xs) j = 0"
proof (transfer, goal_cases)
  case (1 xs n j)
  thus ?case
    by (induct xs)
      (auto simp: Pdevs_raw_def sorted_append split: if_split_asm option.split)
qed

lemma compute_degree[code]: "degree (Pdevs xs) = degree_slist xs"
  by (cases "degree_slist xs")
    (auto dest: degree_slist_eq_zeroD degree_slist_eq_SucD intro!: degree_eqI degree_slist_zero)

subsection \<open>Auxiliary Definitions\<close>

fun binop where
  "binop f z1 z2 [] [] = []"
| "binop f z1 z2 ((i, x)#xs) [] = (i, f x z2) # binop f z1 z2 xs []"
| "binop f z1 z2 [] ((i, y)#ys) = (i, f z1 y) # binop f z1 z2 [] ys"
| "binop f z1 z2 ((i, x)#xs) ((j, y)#ys) =
    (if (i = j)     then (i, f x y) # binop f z1 z2 xs ys
    else if (i > j) then (i, f x z2) # binop f z1 z2 xs ((j, y)#ys)
    else                 (j, f z1 y) # binop f z1 z2 ((i, x)#xs) ys)"

lemma set_binop_elemD1:
  "(a, b) \<in> set (binop f z1 z2 xs ys) \<Longrightarrow> (a \<in> set (map fst xs) \<or> a \<in> set (map fst ys))"
  by (induct f z1 z2 xs ys rule: binop.induct) (auto split: if_split_asm)

lemma set_binop_elemD2:
  "(a, b) \<in> set (binop f z1 z2 xs ys) \<Longrightarrow>
    (\<exists>x\<in>set (map snd xs). b = f x z2) \<or>
    (\<exists>y\<in>set (map snd ys). b = f z1 y) \<or>
    (\<exists>x\<in>set (map snd xs). \<exists>y\<in>set (map snd ys). b = f x y)"
  by (induct f z1 z2 xs ys rule: binop.induct) (auto split: if_split_asm)

abbreviation "rsorted\<equiv>\<lambda>x. sorted (rev x)"

lemma rsorted_binop:
  fixes xs::"('a::linorder * 'b) list" and ys::"('a::linorder * 'c) list"
  assumes "rsorted ((map fst xs))"
  assumes "rsorted ((map fst ys))"
  shows "rsorted ((map fst (binop f z1 z2 xs ys)))"
  using assms
  by (induct f z1 z2 xs ys rule: binop.induct) (force simp: sorted_append dest!: set_binop_elemD1)+

lemma distinct_binop:
  fixes xs::"('a::linorder * 'b) list" and ys::"('a::linorder * 'c) list"
  assumes "distinct (map fst xs)"
  assumes "distinct (map fst ys)"
  assumes "rsorted ((map fst xs))"
  assumes "rsorted ((map fst ys))"
  shows "distinct (map fst (binop f z1 z2 xs ys))"
  using assms
  by (induct f z1 z2 xs ys rule: binop.induct)
    (force dest!: set_binop_elemD1 simp: sorted_append)+

lemma binop_plus:
  fixes b::"(nat * 'a::euclidean_space) list"
  shows
    "(\<Sum>(i, y)\<leftarrow>binop (+) 0 0 b ba. e i *\<^sub>R y) = (\<Sum>(i, y)\<leftarrow>b. e i *\<^sub>R y) + (\<Sum>(i, y)\<leftarrow>ba. e i *\<^sub>R y)"
  by (induct "(+) ::'a\<Rightarrow>_" "0::'a" "0::'a" b ba rule: binop.induct)
    (auto simp: algebra_simps)

lemma binop_compose:
  "binop (\<lambda>x y. f (g x y)) z1 z2 xs ys = map (apsnd f) (binop g z1 z2 xs ys)"
  by (induct "\<lambda>x y. f (g x y)" z1 z2 xs ys rule: binop.induct) auto

lemma linear_cmul_left[intro, simp]: "linear ((*) x::real \<Rightarrow> _)"
  by (auto intro!: linearI simp: algebra_simps)

lemma length_merge_sorted_eq:
  "length (binop f z1 z2 xs ys) = length (binop g y1 y2 xs ys)"
  by (induction f z1 z2 xs ys rule: binop.induct) auto

subsection \<open>Pointswise Addition\<close>

lift_definition add_slist::"(nat, 'a::{plus, zero}) slist \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist" is
  "\<lambda>xs ys. binop (+) 0 0 xs ys"
  by (auto simp: intro!: distinct_binop rsorted_binop)

lemma map_of_binop[simp]: "rsorted (map fst xs) \<Longrightarrow> rsorted (map fst ys) \<Longrightarrow>
  distinct (map fst xs) \<Longrightarrow> distinct (map fst ys) \<Longrightarrow>
  map_of (binop f z1 z2 xs ys) i =
  (case map_of xs i of
    Some x \<Rightarrow> Some (f x (case map_of ys i of Some x \<Rightarrow> x | None \<Rightarrow> z2))
  | None \<Rightarrow> (case map_of ys i of Some y \<Rightarrow> Some (f z1 y) | None \<Rightarrow> None))"
  by (induct f z1 z2 xs ys rule: binop.induct)
    (auto split: option.split option.split_asm simp: sorted_append)

lemma pdevs_apply_Pdevs_add_slist[simp]:
  fixes xs ys::"(nat, 'a::monoid_add) slist"
  shows "pdevs_apply (Pdevs (add_slist xs ys)) i =
    pdevs_apply (Pdevs xs) i + pdevs_apply (Pdevs ys) i"
  by (transfer) (auto simp: Pdevs_raw_def split: option.split)

lemma compute_add_pdevs[code]: "add_pdevs (Pdevs xs) (Pdevs ys) = Pdevs (add_slist xs ys)"
  by (rule pdevs_eqI) simp

subsection \<open>prod of pdevs\<close>

lift_definition prod_slist::"(nat, 'a::zero) slist \<Rightarrow> (nat, 'b::zero) slist \<Rightarrow> (nat, ('a \<times> 'b)) slist" is
  "\<lambda>xs ys. binop Pair 0 0 xs ys"
  by (auto simp: intro!: distinct_binop rsorted_binop)

lemma pdevs_apply_Pdevs_prod_slist[simp]:
  "pdevs_apply (Pdevs (prod_slist xs ys)) i = (pdevs_apply (Pdevs xs) i, pdevs_apply (Pdevs ys) i)"
  by transfer (auto simp: Pdevs_raw_def zero_prod_def split: option.splits)

lemma compute_prod_of_pdevs[code]: "prod_of_pdevs (Pdevs xs) (Pdevs ys) = Pdevs (prod_slist xs ys)"
  by (rule pdevs_eqI) simp

subsection \<open>Set of Coefficients\<close>

lift_definition set_slist::"(nat, 'a::real_vector) slist \<Rightarrow> (nat * 'a) set" is set .

lemma finite_set_slist[intro, simp]: "finite (set_slist xs)"
  by transfer simp

subsection \<open>Domain\<close>

lift_definition list_of_slist::"('a::linorder, 'b::zero) slist \<Rightarrow> ('a * 'b) list"
  is "\<lambda>xs. filter (\<lambda>x. snd x \<noteq> 0) xs" .

lemma compute_pdevs_domain[code]: "pdevs_domain (Pdevs xs) = set (map fst (list_of_slist xs))"
  unfolding pdevs_domain_def
  by transfer (force simp: Pdevs_raw_def split: option.split_asm)

lemma sort_rev_eq_sort: "distinct xs \<Longrightarrow> sort (rev xs) = sort xs"
  by (rule sorted_distinct_set_unique) auto

lemma compute_list_of_pdevs[code]: "list_of_pdevs (Pdevs xs) = list_of_slist xs"
proof -
  have "list_of_pdevs (Pdevs xs) =
    map (\<lambda>i. (i, pdevs_apply (Pdevs xs) i)) (rev (sorted_list_of_set (pdevs_domain (Pdevs xs))))"
    by (simp add: list_of_pdevs_def)
  also have "(sorted_list_of_set (pdevs_domain (Pdevs xs))) = rev (map fst (list_of_slist xs))"
    unfolding compute_pdevs_domain sorted_list_of_set_sort_remdups
  proof (transfer, goal_cases)
    case prems: (1 xs)
    hence distinct: "distinct (map fst [x\<leftarrow>xs . snd x \<noteq> 0])"
      by (auto simp: filter_map distinct_map intro: subset_inj_on)
    with prems show ?case
      using sort_rev_eq_sort[symmetric, OF distinct]
      by (auto simp: rev_map rev_filter distinct_map distinct_remdups_id
        intro!: sorted_sort_id sorted_filter)
  qed
  also
  have "map (\<lambda>i. (i, pdevs_apply (Pdevs xs) i)) (rev \<dots>) = list_of_slist xs"
  proof (transfer, goal_cases)
    case (1 xs)
    thus ?case
      unfolding Pdevs_raw_def o_def rev_rev_ident map_map
      by (subst map_cong[where g="\<lambda>x. x"]) (auto simp: map_filter_map_filter)
  qed
  finally show ?thesis .
qed

lift_definition slist_of_pdevs::"'a pdevs \<Rightarrow> (nat, 'a::real_vector) slist" is list_of_pdevs
  by (auto simp: list_of_pdevs_def rev_map rev_filter
    filter_map o_def distinct_map image_def
    intro!: distinct_filter sorted_filter[of "\<lambda>x. x", simplified])

subsection \<open>Application\<close>

lift_definition slist_apply::"('a::linorder, 'b::zero) slist \<Rightarrow> 'a \<Rightarrow> 'b" is
  "\<lambda>xs i. the_default 0 (map_of xs i)" .

lemma compute_pdevs_apply[code]: "pdevs_apply (Pdevs x) i = slist_apply x i"
  by transfer (auto simp: Pdevs_raw_def)

subsection \<open>Total Deviation\<close>

lift_definition tdev_slist::"(nat, 'a::ordered_euclidean_space) slist \<Rightarrow> 'a" is
  "sum_list o map (abs o snd)" .

lemma tdev_slist_sum: "tdev_slist xs = sum (abs \<circ> snd) (set_slist xs)"
  by transfer (auto simp: distinct_map sum_list_distinct_conv_sum_set[symmetric] o_def)

lemma pdevs_apply_set_slist: "x \<in> set_slist xs \<Longrightarrow> snd x = pdevs_apply (Pdevs xs) (fst x)"
  by transfer (auto simp: Pdevs_raw_def)

lemma
  tdev_list_eq_zeroI:
  shows "(\<And>i. pdevs_apply (Pdevs xs) i = 0) \<Longrightarrow> tdev_slist xs = 0"
  unfolding tdev_slist_sum
  by (auto simp: pdevs_apply_set_slist)

lemma inj_on_fst_set_slist: "inj_on fst (set_slist xs)"
  by transfer (simp add: distinct_map)

lemma pdevs_apply_Pdevs_eq_0:
  "pdevs_apply (Pdevs xs) i = 0 \<longleftrightarrow> ((\<forall>x. (i, x) \<in> set_slist xs \<longrightarrow> x = 0))"
  by transfer (safe, auto simp: Pdevs_raw_def split: option.split)

lemma compute_tdev[code]: "tdev (Pdevs xs) = tdev_slist xs"
proof -
  have "tdev (Pdevs xs) = (\<Sum>i<degree (Pdevs xs). \<bar>pdevs_apply (Pdevs xs) i\<bar>)"
    by (simp add: tdev_def)
  also have "\<dots> =
    (\<Sum>i <degree (Pdevs xs).
      if pdevs_apply (Pdevs xs) i = 0 then 0 else \<bar>pdevs_apply (Pdevs xs) i\<bar>)"
    by (auto intro!: sum.cong)
  also have "\<dots> =
    (\<Sum>i\<in>{0..<degree (Pdevs xs)} \<inter> {x. pdevs_apply (Pdevs xs) x \<noteq> 0}.
      \<bar>pdevs_apply (Pdevs xs) i\<bar>)"
    by (auto simp: sum.If_cases Collect_neg_eq atLeast0LessThan)
  also have "\<dots> = (\<Sum>x\<in>fst ` set_slist xs. \<bar>pdevs_apply (Pdevs xs) x\<bar>)"
    by (rule sum.mono_neutral_cong_left)
      (force simp: pdevs_apply_Pdevs_eq_0 intro!: imageI degree_gt)+
  also have "\<dots> = (\<Sum>x\<in>set_slist xs. \<bar>pdevs_apply (Pdevs xs) (fst x)\<bar>)"
    by (rule sum.reindex_cong[of fst]) (auto simp: inj_on_fst_set_slist)
  also have "\<dots> = tdev_slist xs"
    by (simp add: tdev_slist_sum pdevs_apply_set_slist)
  finally show ?thesis .
qed

subsection \<open>Minkowski Sum\<close>

lemma dropWhile_rsorted_eq_filter:
  "rsorted (map fst xs) \<Longrightarrow> dropWhile (\<lambda>(i, x). i \<ge> (m::nat)) xs = filter (\<lambda>(i, x). i < m) xs"
  (is "_ \<Longrightarrow> ?lhs xs = ?rhs xs")
proof (induct xs)
  case (Cons x xs)
  hence "?rhs (x#xs) = ?lhs (x#xs)"
    by (auto simp: sorted_append filter_id_conv intro: sym)
  thus ?case ..
qed simp

lift_definition msum_slist::"nat \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist"
  is "\<lambda>m xs ys. map (apfst (\<lambda>n. n + m)) ys @ dropWhile (\<lambda>(i, x). i \<ge> m) xs"
proof (safe, goal_cases)
  case (1 n l1 l2)
  then have "set (dropWhile (\<lambda>(i, x). n \<le> i) l1) \<subseteq> set l1"
    by (simp add: set_dropWhileD subrelI)
  with 1 show ?case
    by (auto simp add: distinct_map add.commute [of _ n] intro!: comp_inj_on intro: subset_inj_on)
      (simp add: dropWhile_rsorted_eq_filter)
next
  case prems: (2 n l1 l2)
  hence "sorted (map ((\<lambda>na. na + n) \<circ> fst) (rev l2))"
    by(simp add: sorted_iff_nth_mono rev_map)
  with prems show ?case
    by (auto simp: sorted_append dropWhile_rsorted_eq_filter rev_map rev_filter sorted_filter)
qed

lemma slist_apply_msum_slist:
  "slist_apply (msum_slist m xs ys) i =
    (if i < m then slist_apply xs i else slist_apply ys (i - m))"
proof (transfer, goal_cases)
  case prems: (1 m xs ys i)
  thus ?case
  proof (cases "i \<in> dom (map_of (map (\<lambda>(x, y). (x + m, y)) ys))")
    case False
    have "\<And>a. i < m \<Longrightarrow> i \<notin> fst ` {x \<in> set xs. case x of (i, x) \<Rightarrow> i < m} \<Longrightarrow> (i, a) \<notin> set xs"
      "\<And>a. i \<notin> fst ` set xs \<Longrightarrow> (i, a) \<notin> set xs"
      "\<And>a. m \<le> i \<Longrightarrow> i \<notin> fst ` (\<lambda>(x, y). (x + m, y)) ` set ys \<Longrightarrow> (i - m, a) \<notin> set ys"
       by force+
    thus ?thesis
      using prems False
      by (auto simp add: dropWhile_rsorted_eq_filter map_of_eq_None_iff distinct_map_fst_snd_eqD
        split: option.split dest!: map_of_SomeD)
  qed (force simp: map_of_eq_None_iff distinct_map_fst_snd_eqD
    split: option.split
    dest!: map_of_SomeD)
qed

lemma pdevs_apply_msum_slist:
  "pdevs_apply (Pdevs (msum_slist m xs ys)) i =
    (if i < m then pdevs_apply (Pdevs xs) i else pdevs_apply (Pdevs ys) (i - m))"
  by (auto simp: compute_pdevs_apply slist_apply_msum_slist)

lemma compute_msum_pdevs[code]: "msum_pdevs m (Pdevs xs) (Pdevs ys) = Pdevs (msum_slist m xs ys)"
  by (rule pdevs_eqI) (auto simp: pdevs_apply_msum_slist pdevs_apply_msum_pdevs)

subsection \<open>Unary Operations\<close>

lift_definition map_slist::"('a \<Rightarrow> 'b) \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'b) slist" is "\<lambda>f. map (apsnd f)"
  by simp

lemma pdevs_apply_map_slist:
  "f 0 = 0 \<Longrightarrow> pdevs_apply (Pdevs (map_slist f xs)) i = f (pdevs_apply (Pdevs xs) i)"
  by transfer
    (force simp: Pdevs_raw_def map_of_eq_None_iff distinct_map_fst_snd_eqD image_def
      split: option.split dest: distinct_map_fst_snd_eqD)

lemma compute_scaleR_pdves[code]: "scaleR_pdevs r (Pdevs xs) = Pdevs (map_slist (\<lambda>x. r *\<^sub>R x) xs)"
  and compute_pdevs_scaleR[code]: "pdevs_scaleR (Pdevs rs) x = Pdevs (map_slist (\<lambda>r. r *\<^sub>R x) rs)"
  and compute_uminus_pdevs[code]: "uminus_pdevs (Pdevs xs) = Pdevs (map_slist (\<lambda>x. - x) xs)"
  and compute_abs_pdevs[code]: "abs_pdevs (Pdevs xs) = Pdevs (map_slist abs xs)"
  and compute_pdevs_inner[code]: "pdevs_inner (Pdevs xs) b = Pdevs (map_slist (\<lambda>x. x \<bullet> b) xs)"
  and compute_pdevs_inner2[code]:
    "pdevs_inner2 (Pdevs xs) b c = Pdevs (map_slist (\<lambda>x. (x \<bullet> b, x \<bullet> c)) xs)"
  and compute_inner_scaleR_pdevs[code]:
    "inner_scaleR_pdevs x (Pdevs ys) = Pdevs (map_slist (\<lambda>y. (x \<bullet> y) *\<^sub>R y) ys)"
  and compute_trunc_pdevs[code]:
    "trunc_pdevs p (Pdevs xs) = Pdevs (map_slist (\<lambda>x. eucl_truncate_down p x) xs)"
  and compute_trunc_err_pdevs[code]:
    "trunc_err_pdevs p (Pdevs xs) = Pdevs (map_slist (\<lambda>x. eucl_truncate_down p x - x) xs)"
  by (auto intro!: pdevs_eqI simp: pdevs_apply_map_slist zero_prod_def abs_pdevs_def)

subsection \<open>Filter\<close>

lift_definition filter_slist::"(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist"
  is "\<lambda>P xs. filter (\<lambda>(i, x). (P i x)) xs"
  by (auto simp: o_def filter_map distinct_map rev_map rev_filter sorted_filter
    intro: subset_inj_on)

lemma slist_apply_filter_slist: "slist_apply (filter_slist P xs) i =
  (if P i (slist_apply xs i) then slist_apply xs i else 0)"
  by transfer (force simp: Pdevs_raw_def o_def map_of_eq_None_iff distinct_map_fst_snd_eqD
    dest: map_of_SomeD distinct_map_fst_snd_eqD split: option.split)

lemma pdevs_apply_filter_slist: "pdevs_apply (Pdevs (filter_slist P xs)) i =
  (if P i (pdevs_apply (Pdevs xs) i) then pdevs_apply (Pdevs xs) i else 0)"
  by (simp add: compute_pdevs_apply slist_apply_filter_slist)

lemma compute_filter_pdevs[code]: "filter_pdevs P (Pdevs xs) = Pdevs (filter_slist P xs)"
  by (auto simp: pdevs_apply_filter_slist intro!: pdevs_eqI)

subsection \<open>Constant\<close>

lift_definition zero_slist::"(nat, 'a) slist" is "[]" by simp

lemma compute_zero_pdevs[code]: "zero_pdevs = Pdevs (zero_slist)"
  by transfer (auto simp: Pdevs_raw_def)

lift_definition One_slist::"(nat, 'a::executable_euclidean_space) slist"
  is "rev (zip [0..<length (Basis_list::'a list)] (Basis_list::'a list))"
  by (simp add: zip_rev[symmetric])

lemma
  map_of_rev_zip_upto_length_eq_nth:
  assumes "i < length B" "d = length B"
  shows "(map_of (rev (zip [0..<d] B)) i) = Some (B ! i)"
proof -
  have "length (rev [0..<length B]) = length (rev B)"
    by simp
  from map_of_zip_is_Some[OF this, of i] assms
  obtain y where y: "map_of (zip (rev [0..<length B]) (rev B)) i = Some y"
    by (auto simp: zip_rev)
  hence "y = B ! i"
    by (auto simp: in_set_zip rev_nth)
  with y show ?thesis
    by (simp add: zip_rev assms)
qed

lemma
  map_of_rev_zip_upto_length_eq_None:
  assumes "\<not>i < length B"
  assumes "d = length B"
  shows "(map_of (rev (zip [0..<d] B)) i) = None"
  using assms
  by (auto simp: map_of_eq_None_iff in_set_zip)

lemma pdevs_apply_One_slist:
  "pdevs_apply (Pdevs One_slist) i =
    (if i < length (Basis_list::'a::executable_euclidean_space list)
    then (Basis_list::'a list) ! i
    else 0)"
  by transfer (auto simp: Pdevs_raw_def map_of_rev_zip_upto_length_eq_nth map_of_rev_zip_upto_length_eq_None
      in_set_zip split: option.split)

lemma compute_One_pdevs[code]: "One_pdevs = Pdevs One_slist"
  by (rule pdevs_eqI) (simp add: pdevs_apply_One_slist)

lift_definition coord_slist::"nat \<Rightarrow> (nat, real) slist" is "\<lambda>i. [(i, 1)]" by simp

lemma compute_coord_pdevs[code]: "coord_pdevs i = Pdevs (coord_slist i)"
  by transfer (auto simp: Pdevs_raw_def)

subsection \<open>Update\<close>

primrec update_list::"nat \<Rightarrow> 'a \<Rightarrow> (nat * 'a) list \<Rightarrow> (nat * 'a) list"
  where
  "update_list n x [] = [(n, x)]"
| "update_list n x (y#ys) =
    (if n > fst y then (n, x)#y#ys
    else if n = fst y then (n, x)#ys
    else y#(update_list n x ys))"

lemma map_of_update_list[simp]: "map_of (update_list n x ys) = (map_of ys)(n:=Some x)"
  by (induct ys) auto

lemma in_set_update_listD:
  assumes "y \<in> set (update_list n x ys)"
  shows "y = (n, x) \<or> (y \<in> set ys)"
  using assms
  by (induct ys) (auto split: if_split_asm)

lemma in_set_update_listI:
  "y = (n, x) \<or> (fst y \<noteq> n \<and> y \<in> set ys) \<Longrightarrow> y \<in> set (update_list n x ys)"
  by (induct ys) (auto split: if_split_asm)

lemma in_set_update_list: "(n, x) \<in> set (update_list n x xs)"
  by (induct xs) simp_all

lemma overwrite_update_list: "(a, b) \<in> set xs \<Longrightarrow> (a, b) \<notin> set (update_list n x xs) \<Longrightarrow> a = n"
  by (induct xs) (auto split: if_split_asm)

lemma insert_update_list:
  "distinct (map fst xs) \<Longrightarrow> rsorted (map fst xs) \<Longrightarrow> (a, b) \<in> set (update_list a x xs) \<Longrightarrow> b = x"
  by (induct xs) (force split: if_split_asm simp: sorted_append)+

lemma set_update_list_eq: "distinct (map fst xs) \<Longrightarrow> rsorted (map fst xs) \<Longrightarrow>
    set (update_list n x xs) = insert (n, x) (set xs - {x. fst x = n})"
  by (auto intro!: in_set_update_listI dest: in_set_update_listD simp: insert_update_list)

lift_definition update_slist::"nat \<Rightarrow> 'a \<Rightarrow> (nat, 'a) slist \<Rightarrow> (nat, 'a) slist" is update_list
proof goal_cases
  case (1 n a l)
  thus ?case
    by (induct l) (force simp: sorted_append distinct_map not_less dest!: in_set_update_listD)+
qed

lemma pdevs_apply_update_slist: "pdevs_apply (Pdevs (update_slist n x xs)) i =
  (if i = n then x else pdevs_apply (Pdevs xs) i)"
  by transfer (auto simp: Pdevs_raw_def)

lemma compute_pdev_upd[code]: "pdev_upd (Pdevs xs) n x = Pdevs (update_slist n x xs)"
  by (rule pdevs_eqI) (auto simp: pdevs_apply_update_slist)

subsection \<open>Approximate Total Deviation\<close>

lift_definition fold_slist::"('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (nat, 'a::zero) slist \<Rightarrow> 'b \<Rightarrow> 'b"
  is "\<lambda>f xs z. fold (f o snd) (filter (\<lambda>x. snd x \<noteq> 0) xs) z" .

lemma Pdevs_raw_Cons:
  "Pdevs_raw ((a, b) # xs) = (\<lambda>i. if i = a then b else Pdevs_raw xs i)"
  by (auto simp: Pdevs_raw_def map_of_eq_None_iff
    dest!: map_of_SomeD
    split: option.split)

lemma zeros_aux: "- (\<lambda>i. if i = a then b else Pdevs_raw xs i) -` {0} \<subseteq>
  - Pdevs_raw xs -` {0} \<union> {a}"
  by auto

lemma compute_tdev'[code]:
  "tdev' p (Pdevs xs) = fold_slist (\<lambda>a b. eucl_truncate_up p (\<bar>a\<bar> + b)) xs 0"
  unfolding tdev'_def sum_list'_def compute_list_of_pdevs
  by transfer (auto simp: o_def fold_map)

subsection \<open>Equality\<close>

lemma slist_apply_list_of_slist_eq: "slist_apply a i = the_default 0 (map_of (list_of_slist a) i)"
  by (transfer)
    (force split: option.split simp: map_of_eq_None_iff distinct_map_fst_snd_eqD
      dest!: map_of_SomeD)

lemma compute_equal_pdevs[code]:
  "equal_class.equal (Pdevs a) (Pdevs b) \<longleftrightarrow> (list_of_slist a) = (list_of_slist b)"
  by (auto intro!: pdevs_eqI simp: equal_pdevs_def compute_pdevs_apply slist_apply_list_of_slist_eq
    compute_list_of_pdevs[symmetric])

subsection \<open>From List of Generators\<close>

lift_definition slist_of_list::"'a::zero list \<Rightarrow> (nat, 'a) slist"
  is "\<lambda>xs. rev (zip [0..<length xs] xs)"
  by (auto simp: rev_map[symmetric] )

lemma slist_apply_slist_of_list:
  "slist_apply (slist_of_list xs) i = (if i < length xs then xs ! i else 0)"
  by transfer (auto simp: in_set_zip map_of_rev_zip_upto_length_eq_nth map_of_rev_zip_upto_length_eq_None)

lemma compute_pdevs_of_list[code]: "pdevs_of_list xs = Pdevs (slist_of_list xs)"
  by (rule pdevs_eqI)
    (auto simp: compute_pdevs_apply slist_apply_slist_of_list pdevs_apply_pdevs_of_list)

text \<open>abstraction function which can be used in code equations\<close>

lift_definition abs_slist_if::"('a::linorder\<times>'b) list \<Rightarrow> ('a, 'b) slist"
  is "\<lambda>list. if distinct (map fst list) \<and> rsorted (map fst list) then list else []"
  by auto

definition "slist = Abs_slist"

lemma [code_post]: "Abs_slist = slist"
  by (simp add: slist_def)

abbreviation "pdevs \<equiv> (\<lambda>x. Pdevs (slist x))"

lift_definition nlex_slist::"(nat, point) slist \<Rightarrow> (nat, point) slist" is
  "map (\<lambda>(i, x). (i, if lex 0 x then - x else x))"
  by (auto simp: o_def split_beta')

lemma Pdevs_raw_map: "f 0 = 0 \<Longrightarrow> Pdevs_raw (map (\<lambda>(i, x). (i, f x)) xs) i = f (Pdevs_raw xs i)"
  by (auto simp: Pdevs_raw_def map_of_map split: option.split)

lemma compute_nlex_pdevs[code]: "nlex_pdevs (Pdevs x) = Pdevs (nlex_slist x)"
  by transfer (auto simp: Pdevs_raw_map)

end


(*
 * Copyright Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*<*)
theory Guide
  imports Word_Lib_Sumo Machine_Word_32 Machine_Word_64
begin

context semiring_bit_operations
begin

lemma bit_eq_iff:
  \<open>a = b \<longleftrightarrow> (\<forall>n. 2 ^ n \<noteq> 0 \<longrightarrow> bit a n \<longleftrightarrow> bit b n)\<close>
  using bit_eq_iff [of a b] by (simp add: possible_bit_def)

end

notation (output)  Generic_set_bit.set_bit (\<open>Generic'_set'_bit.set'_bit\<close>)

hide_const (open) Generic_set_bit.set_bit

no_notation bit  (infixl \<open>!!\<close> 100)

(*>*)
section \<open>A short overview over bit operations and word types\<close>

subsection \<open>Key principles\<close>

text \<open>
  When formalizing bit operations, it is tempting to represent
  bit values as explicit lists over a binary type. This however
  is a bad idea, mainly due to the inherent ambiguities in
  representation concerning repeating leading bits.

  Hence this approach avoids such explicit lists altogether
  following an algebraic path:

    \<^item> Bit values are represented by numeric types: idealized
      unbounded bit values can be represented by type \<^typ>\<open>int\<close>,
      bounded bit values by quotient types over \<^typ>\<open>int\<close>, aka \<^typ>\<open>'a word\<close>.

    \<^item> (A special case are idealized unbounded bit values ending
      in @{term [source] 0} which can be represented by type \<^typ>\<open>nat\<close> but
      only support a restricted set of operations).

  The fundamental principles are developed in theory \<^theory>\<open>HOL.Bit_Operations\<close>
  (which is part of \<^theory>\<open>Main\<close>):

    \<^item> Multiplication by \<^term>\<open>2 :: int\<close> is a bit shift to the left and

    \<^item> Division by \<^term>\<open>2 :: int\<close> is a bit shift to the right.

    \<^item> Concerning bounded bit values, iterated shifts to the left
    may result in eliminating all bits by shifting them all
    beyond the boundary.  The property \<^prop>\<open>(2 :: int) ^ n \<noteq> 0\<close>
    represents that \<^term>\<open>n\<close> is \<^emph>\<open>not\<close> beyond that boundary.

    \<^item> The projection on a single bit is then @{thm [mode=iff] bit_iff_odd [where ?'a = int, no_vars]}.

    \<^item> This leads to the most fundamental properties of bit values:

      \<^item> Equality rule: @{thm [display, mode=iff] bit_eq_iff [where ?'a = int, no_vars]}

      \<^item> Induction rule: @{thm [display, mode=iff] bits_induct [where ?'a = int, no_vars]}

    \<^item> Characteristic properties @{prop [source] \<open>bit (f x) n \<longleftrightarrow> P x n\<close>}
      are available in fact collection \<^text>\<open>bit_simps\<close>.

  On top of this, the following generic operations are provided:

    \<^item> Singleton \<^term>\<open>n\<close>th bit: \<^term>\<open>(2 :: int) ^ n\<close>

    \<^item> Bit mask upto bit \<^term>\<open>n\<close>: @{thm mask_eq_exp_minus_1 [where ?'a = int, no_vars]}

    \<^item> Left shift: @{thm push_bit_eq_mult [where ?'a = int, no_vars]}

    \<^item> Right shift: @{thm drop_bit_eq_div [where ?'a = int, no_vars]}

    \<^item> Truncation: @{thm take_bit_eq_mod [where ?'a = int, no_vars]}

    \<^item> Bitwise negation: @{thm [mode=iff] bit_not_iff_eq [where ?'a = int, no_vars]}

    \<^item> Bitwise conjunction: @{thm [mode=iff] bit_and_iff [where ?'a = int, no_vars]}

    \<^item> Bitwise disjunction: @{thm [mode=iff] bit_or_iff [where ?'a = int, no_vars]}

    \<^item> Bitwise exclusive disjunction: @{thm [mode=iff] bit_xor_iff [where ?'a = int, no_vars]}

    \<^item> Setting a single bit: @{thm set_bit_def [where ?'a = int, no_vars]}

    \<^item> Unsetting a single bit: @{thm unset_bit_def [where ?'a = int, no_vars]}

    \<^item> Flipping a single bit: @{thm flip_bit_def [where ?'a = int, no_vars]}

    \<^item> Signed truncation, or modulus centered around \<^term>\<open>0::int\<close>:
        @{thm [display] signed_take_bit_def [where ?'a = int, no_vars]}

    \<^item> (Bounded) conversion from and to a list of bits:
        @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}

  Bit concatenation on \<^typ>\<open>int\<close> as given by
    @{thm [display] concat_bit_def [no_vars]}
  appears quite
  technical but is the logical foundation for the quite natural bit concatenation
  on \<^typ>\<open>'a word\<close> (see below).
\<close>

subsection \<open>Core word theory\<close>

text \<open>
  Proper word types are introduced in theory \<^theory>\<open>HOL-Library.Word\<close>, with
  the following specific operations:

    \<^item> Standard arithmetic:
        @{term \<open>(+) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
        @{term \<open>uminus :: 'a::len word \<Rightarrow> 'a word\<close>},
        @{term \<open>(-) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
        @{term \<open>(*) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
        @{term \<open>0 :: 'a::len word\<close>}, @{term \<open>1 :: 'a::len word\<close>}, numerals etc.

    \<^item> Standard bit operations: see above.

    \<^item> Conversion with unsigned interpretation of words:

        \<^item> @{term [source] \<open>unsigned :: 'a::len word \<Rightarrow> 'b::semiring_1\<close>}

        \<^item> Important special cases as abbreviations:

            \<^item> @{term [source] \<open>unat :: 'a::len word \<Rightarrow> nat\<close>}

            \<^item> @{term [source] \<open>uint :: 'a::len word \<Rightarrow> int\<close>}

            \<^item> @{term [source] \<open>ucast :: 'a::len word \<Rightarrow> 'b::len word\<close>}

    \<^item> Conversion with signed interpretation of words:

        \<^item> @{term [source] \<open>signed :: 'a::len word \<Rightarrow> 'b::ring_1\<close>}

        \<^item> Important special cases as abbreviations:

            \<^item> @{term [source] \<open>sint :: 'a::len word \<Rightarrow> int\<close>}

            \<^item> @{term [source] \<open>scast :: 'a::len word \<Rightarrow> 'b::len word\<close>}

    \<^item> Operations with unsigned interpretation of words:

        \<^item> @{thm [mode=iff] word_le_nat_alt [no_vars]}

        \<^item> @{thm [mode=iff] word_less_nat_alt [no_vars]}

        \<^item> @{thm unat_div_distrib [no_vars]}

        \<^item> @{thm unat_drop_bit_eq [no_vars]}

        \<^item> @{thm unat_mod_distrib [no_vars]}

        \<^item> @{thm [mode=iff] udvd_iff_dvd [no_vars]}

    \<^item> Operations with signed interpretation of words:

        \<^item> @{thm [mode=iff] word_sle_eq [no_vars]}

        \<^item> @{thm [mode=iff] word_sless_alt [no_vars]}

        \<^item> @{thm sint_signed_drop_bit_eq [no_vars]}

    \<^item> Rotation and reversal:

        \<^item> @{term [source] \<open>word_rotl :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

        \<^item> @{term [source] \<open>word_rotr :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

        \<^item> @{term [source] \<open>word_roti :: int \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}

        \<^item> @{term [source] \<open>word_reverse :: 'a::len word \<Rightarrow> 'a word\<close>}

    \<^item> Concatenation: @{term [source, display] \<open>word_cat :: 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'c::len word\<close>}

  For proofs about words the following default strategies are applicable:

    \<^item> Using bit extensionality (facts \<^text>\<open>bit_eq_iff\<close>, \<^text>\<open>bit_word_eqI\<close>; fact
      collection \<^text>\<open>bit_simps\<close>).

    \<^item> Using the @{method transfer} method.
\<close>

subsection \<open>More library theories\<close>

text \<open>
  Note: currently, most theories listed here are hardly separate
  entities since they import each other in various ways.
  Always inspect them to understand what you pull in if you
  want to import one.

    \<^descr>[Syntax]

      \<^descr>[\<^theory>\<open>Word_Lib.Syntax_Bundles\<close>]
        Bundles to provide alternative syntax for various bit operations.

      \<^descr>[\<^theory>\<open>Word_Lib.Hex_Words\<close>]
        Printing word numerals as hexadecimal numerals.

      \<^descr>[\<^theory>\<open>Word_Lib.Type_Syntax\<close>]
        Pretty type-sensitive syntax for cast operations.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_Syntax\<close>]
        Specific ASCII syntax for prominent bit operations on word.

    \<^descr>[Proof tools]

      \<^descr>[\<^theory>\<open>Word_Lib.Norm_Words\<close>]
        Rewriting word numerals to normal forms.

      \<^descr>[\<^theory>\<open>Word_Lib.Bitwise\<close>]
        Method @{method word_bitwise} decomposes word equalities and inequalities into bit propositions.

      \<^descr>[\<^theory>\<open>Word_Lib.Bitwise_Signed\<close>]
        Method @{method word_bitwise_signed} decomposes word equalities and inequalities into bit propositions.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_EqI\<close>]
        Method @{method word_eqI_solve} decomposes word equalities and inequalities into bit propositions.

    \<^descr>[Operations]

      \<^descr>[\<^theory>\<open>Word_Lib.Signed_Division_Word\<close>]

        Signed division on word:

          \<^item> @{term [source] \<open>(sdiv) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}

          \<^item> @{term [source] \<open>(smod) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}

      \<^descr>[\<^theory>\<open>Word_Lib.Aligned\<close>] \

          \<^item> @{thm [mode=iff] is_aligned_iff_udvd [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Least_significant_bit\<close>]

        The least significant bit as an alias:
        @{thm [mode=iff] lsb_odd [where ?'a = int, no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Most_significant_bit\<close>]

        The most significant bit:

          \<^item> @{thm [mode=iff] msb_int_def [of k]}

          \<^item> @{thm [mode=iff] word_msb_sint [no_vars]}

          \<^item> @{thm [mode=iff] msb_word_iff_sless_0 [no_vars]}

          \<^item> @{thm [mode=iff] msb_word_iff_bit [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Bit_Shifts_Infix_Syntax\<close>]

        Bit shifts decorated with infix syntax:

          \<^item> @{thm Bit_Shifts_Infix_Syntax.shiftl_def [no_vars]}

          \<^item> @{thm Bit_Shifts_Infix_Syntax.shiftr_def [no_vars]}

          \<^item> @{thm Bit_Shifts_Infix_Syntax.sshiftr_def [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Next_and_Prev\<close>] \

          \<^item> @{thm word_next_unfold [no_vars]}

          \<^item> @{thm word_prev_unfold [no_vars]}

      \<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]

        More on explicit enumeration of word types.

      \<^descr>[\<^theory>\<open>Word_Lib.More_Word_Operations\<close>]

        Even more operations on word.

    \<^descr>[Types]

      \<^descr>[\<^theory>\<open>Word_Lib.Signed_Words\<close>]

          Formal tagging of word types with a \<^text>\<open>signed\<close> marker.

    \<^descr>[Lemmas]

      \<^descr>[\<^theory>\<open>Word_Lib.More_Word\<close>]

          More lemmas on words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>]

          More lemmas on words, covering many other theories mentioned here.

    \<^descr>[Words of popular lengths].

      \<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>]

          for 8-bit words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>]

          for 16-bit words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>]

          for 32-bit words.

      \<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>]

          for 64-bit words. This theory is not part of  \<^text>\<open>Word_Lib_Sumo\<close>, because it shadows
          names from \<^theory>\<open>Word_Lib.Word_32\<close>. They can be used together, but then will have
          to use qualified names in applications.

      \<^descr>[\<^theory>\<open>Word_Lib.Machine_Word_32\<close> and \<^theory>\<open>Word_Lib.Machine_Word_64\<close>]

          provide lemmas for 32-bit words and 64-bit words under the same name,
          which can help to organize applications relying on some form
          of genericity.
\<close>

subsection \<open>More library sessions\<close>

text \<open>
  \<^descr>[\<^text>\<open>Native_Word\<close>] Makes machine words and machine arithmetic available for code generation.
  It provides a common abstraction that hides the differences between the different target languages.
  The code generator maps these operations to the APIs of the target languages.
\<close>

subsection \<open>Legacy theories\<close>

text \<open>
  The following theories contain material which has been
  factored out since it is not recommended to use it in
  new applications, mostly because matters can be expressed
  succinctly using already existing operations.

  This section gives some indication how to migrate away
  from those theories.  However theorem coverage may still
  be terse in some cases.

  \<^descr>[\<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>]

    An entry point importing any relevant theory in that session.  Intended
    for backward compatibility: start importing this theory when
    migrating applications to Isabelle2021, and later sort out
    what you really need. You may need to include
   \<^theory>\<open>Word_Lib.Word_64\<close> separately.

  \<^descr>[\<^theory>\<open>Word_Lib.Generic_set_bit\<close>]

    Kind of an alias: @{thm set_bit_eq [no_vars]}

  \<^descr>[\<^theory>\<open>Word_Lib.Typedef_Morphisms\<close>]

    A low-level extension to HOL typedef providing
    conversions along type morphisms.  The @{method transfer} method
    seems to be sufficient for most applications though.

  \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension\<close>]

    Comprehension syntax for bit values over predicates
    \<^typ>\<open>nat \<Rightarrow> bool\<close>, for \<^typ>\<open>'a::len word\<close>; straightforward
    alternatives exist.

  \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension_Int\<close>]

    Comprehension syntax for bit values over predicates
    \<^typ>\<open>nat \<Rightarrow> bool\<close>, for \<^typ>\<open>int\<close>; inherently non-computational.

  \<^descr>[\<^theory>\<open>Word_Lib.Reversed_Bit_Lists\<close>]

    Representation of bit values as explicit list in
    \<^emph>\<open>reversed\<close> order.

    This should rarely be necessary: the \<^const>\<open>bit\<close> projection
    should be sufficient in most cases.  In case explicit lists
    are needed, existing operations can be used:

    @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}

  \<^descr>[\<^theory>\<open>Word_Lib.Many_More\<close>]

    Collection of operations and theorems which are kept for backward
    compatibility and not used in other theories in session \<^text>\<open>Word_Lib\<close>.
    They are used in applications of \<^text>\<open>Word_Lib\<close>, but should be migrated to there.
\<close>

section \<open>Changelog\<close>

text \<open>
  \<^descr>[Changes since AFP 2022] ~

    \<^item> Theory \<^text>\<open>Word_Lib.Ancient_Numeral\<close> has been removed from session.

    \<^item> Bit comprehension syntax for \<^typ>\<open>int\<close> moved to separate theory
      \<^theory>\<open>Word_Lib.Bit_Comprehension_Int\<close>.

  \<^descr>[Changes since AFP 2021] ~

    \<^item> Theory \<^text>\<open>Word_Lib.Ancient_Numeral\<close> is not part of \<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>
      any longer.

    \<^item> Infix syntax for \<^term>\<open>(AND)\<close>, \<^term>\<open>(OR)\<close>, \<^term>\<open>(XOR)\<close> organized in
      syntax bundle \<^bundle>\<open>bit_operations_syntax\<close>.

    \<^item> Abbreviation \<^abbrev>\<open>max_word\<close> moved from distribution into theory
      \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.

    \<^item> Operation \<^const>\<open>test_bit\<close> replaced by input abbreviation \<^abbrev>\<open>test_bit\<close>.

    \<^item> Abbreviations \<^abbrev>\<open>bin_nth\<close>, \<^abbrev>\<open>bin_last\<close>, \<^abbrev>\<open>bin_rest\<close>,
      \<^abbrev>\<open>bintrunc\<close>, \<^abbrev>\<open>sbintrunc\<close>, \<^abbrev>\<open>norm_sint\<close>,
      \<^abbrev>\<open>bin_cat\<close> moved into theory \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.

    \<^item> Operations \<^abbrev>\<open>bshiftr1\<close>,
      \<^abbrev>\<open>setBit\<close>, \<^abbrev>\<open>clearBit\<close> moved from distribution into theory
      \<^theory>\<open>Word_Lib.Legacy_Aliases\<close> and replaced by input abbreviations.

    \<^item> Operations \<^const>\<open>shiftl1\<close>, \<^const>\<open>shiftr1\<close>, \<^const>\<open>sshiftr1\<close>
      moved here from distribution.

    \<^item> Operation \<^const>\<open>complement\<close> replaced by input abbreviation \<^abbrev>\<open>complement\<close>.
\<close>

(*<*)
end
(*>*)


theory Proj_Code
  imports "Containers.Containers"
begin

definition images :: "('a \<times> 'b) set \<Rightarrow> ('a \<times> 'b set) set" where
  "images X = (\<lambda>a. (a, {b. (a, b) \<in> X})) ` fst ` X"

lemma images_iff_proj: "(a, B) \<in> images X \<longleftrightarrow> B \<noteq> {} \<and> Equiv_Relations.proj X a = B"
  by (force simp: Equiv_Relations.proj_def images_def)

lemma proj_empty_iff: "Equiv_Relations.proj X a = {} \<longleftrightarrow> a \<notin> fst ` X"
  using image_iff
  by (fastforce simp: Equiv_Relations.proj_def Image_def)

lemma proj_iff_images: "B \<noteq> {} \<Longrightarrow> Equiv_Relations.proj X a = B \<longleftrightarrow> (a, B) \<in> images X"
  by (auto simp: images_iff_proj)

lemma proj_iff_images': "Equiv_Relations.proj X a = B \<longleftrightarrow>
  (if B = {} then a \<notin> fst ` X else (a, B) \<in> images X)"
  by (auto simp: proj_empty_iff proj_iff_images)

lemma fst_imagesI: "(a, b) \<in> X \<Longrightarrow> a \<in> fst ` images X"
  by (auto simp: images_def) (metis (mono_tags, lifting) fstI image_iff)

definition flatten :: "('a \<times> 'b set) set \<Rightarrow> ('a \<times> 'b) set" where
  "flatten X = \<Union>((\<lambda>(a, B). (\<lambda>b. (a, b)) ` B) ` X)"

lemma flatten_empty[simp]: "flatten {} = {}"
  by (auto simp: flatten_def)

lemma images_flatten:
  assumes "\<And>a. (a, {}) \<notin> X" "\<And>a B B'. (a, B) \<in> X \<Longrightarrow> (a, B') \<in> X \<Longrightarrow> B = B'"
  shows "images (flatten X) = X"
proof (rule set_eqI, rule iffI)
  fix aB
  assume aB_X: "aB \<in> X"
  obtain a B where aB_def: "aB = (a, B)"
    by fastforce
  obtain b where "b \<in> B"
    using assms(1) aB_X
    by (fastforce simp: aB_def)
  then have b_def: "(a, b) \<in> flatten X"
    using aB_X
    by (auto simp: aB_def flatten_def)
  show "aB \<in> images (flatten X)"
    using b_def assms(2)[OF aB_X[unfolded aB_def]]
    by (auto simp: aB_def images_iff_proj Equiv_Relations.proj_def flatten_def)
next
  fix aB
  assume aB_X: "aB \<in> images (flatten X)"
  obtain a B where aB_def: "aB = (a, B)"
    by fastforce
  obtain B' where B'_def: "(a, B') \<in> X" "\<And>b. (a, b) \<in> flatten X \<longleftrightarrow> b \<in> B"
    using aB_X
    by (auto simp: flatten_def aB_def images_iff_proj Equiv_Relations.proj_def)
  have "B = B'"
  proof (rule set_eqI, rule iffI)
    fix b
    assume "b \<in> B"
    then have "(a, b) \<in> flatten X"
      using B'_def(2)
      by auto
    then obtain B'' where B''_def: "(a, B'') \<in> X" "b \<in> B''"
      by (auto simp: flatten_def)
    show "b \<in> B'"
      using assms(2)[OF B'_def(1) B''_def(1)] B''_def(2)
      by auto
  next
    fix b'
    assume "b' \<in> B'"
    then show "b' \<in> B"
      using B'_def
      by (auto simp: flatten_def)
  qed
  then show "aB \<in> X"
    using B'_def(1)
    by (auto simp: aB_def)
qed

context ord
begin

definition add_to_rbt :: "'a \<times> 'b \<Rightarrow> ('a, 'b set) rbt \<Rightarrow> ('a, 'b set) rbt" where
  "add_to_rbt = (\<lambda>(a, b) t. case rbt_lookup t a of None \<Rightarrow> rbt_insert a {b} t
  | Some X \<Rightarrow> rbt_insert a (X \<union> {b}) t)"

definition rbt_set_to_rbt :: "('a \<times> 'b, unit) rbt \<Rightarrow> ('a, 'b set) rbt" where
  "rbt_set_to_rbt t = RBT_Impl.fold (\<lambda>ab _. add_to_rbt ab) t RBT_Impl.Empty"

end

context linorder
begin

lemma is_rbt_add_to_rbt: "is_rbt t \<Longrightarrow> is_rbt (add_to_rbt ab t)"
  by (auto simp: add_to_rbt_def split: prod.splits option.splits)

lemma is_rbt_fold_add_to_rbt:
  "is_rbt t' \<Longrightarrow> is_rbt (RBT_Impl.fold (\<lambda>ab _. add_to_rbt ab) t t')"
  by (induction t arbitrary: t') (auto 0 0 simp: is_rbt_add_to_rbt)

lemma is_rbt_rbt_set_to_rbt: "is_rbt (rbt_set_to_rbt t)"
  using is_rbt_fold_add_to_rbt Empty_is_rbt
  by (fastforce simp: rbt_set_to_rbt_def)

lemma rbt_insert_entries_None: "is_rbt t \<Longrightarrow> rbt_lookup t k = None \<Longrightarrow>
  set (RBT_Impl.entries (rbt_insert k v t)) = set (RBT_Impl.entries t) \<union> {(k, v)}"
  by (auto simp: rbt_lookup_in_tree[symmetric] rbt_lookup_rbt_insert split: if_splits)

lemma rbt_insert_entries_Some: "is_rbt t \<Longrightarrow> rbt_lookup t k = Some v' \<Longrightarrow>
  set (RBT_Impl.entries (rbt_insert k v t)) = set (RBT_Impl.entries t) - {(k, v')} \<union> {(k, v)}"
  by (auto simp: rbt_lookup_in_tree[symmetric] rbt_lookup_rbt_insert split: if_splits)

lemma flatten_add_to_rbt: assumes "is_rbt t"
  shows "flatten (set (RBT_Impl.entries (add_to_rbt ab t))) =
    {ab} \<union> flatten (set (RBT_Impl.entries t))"
proof -
  obtain a b where ab_def: "ab = (a, b)"
    by fastforce
  show ?thesis
  proof (cases "rbt_lookup t a")
    case None
    show ?thesis
      by (auto simp: add_to_rbt_def ab_def None flatten_def rbt_insert_entries_None[OF assms None])
  next
    case (Some B)
    show ?thesis
      by (auto simp: add_to_rbt_def ab_def Some flatten_def rbt_insert_entries_Some[OF assms Some]
          split: prod.splits)
         (meson assms Some image_iff is_rbt_rbt_sorted rbt_lookup_in_tree)
  qed
qed

lemma nonempty_add_to_rbt: "is_rbt t \<Longrightarrow> (a, {}) \<notin> set (RBT_Impl.entries t) \<Longrightarrow>
    (a, {}) \<notin> set (RBT_Impl.entries (add_to_rbt ab t))"
  by (auto simp: add_to_rbt_def rbt_insert_entries_None split: prod.splits option.splits)
     (smt insert_not_empty is_rbt_rbt_sorted rbt_insert_rbt_sorted rbt_lookup_in_tree
      rbt_lookup_rbt_insert map_upd_Some_unfold)

lemma flatten_fold_add_to_rbt: "is_rbt t' \<Longrightarrow> (a, {}) \<notin> set (RBT_Impl.entries t') \<Longrightarrow>
  flatten (set (RBT_Impl.entries (RBT_Impl.fold (\<lambda>ab _. add_to_rbt ab) t t'))) =
  set (RBT_Impl.keys t) \<union> flatten (set (RBT_Impl.entries t')) \<and>
  (a, {}) \<notin> set (RBT_Impl.entries (RBT_Impl.fold (\<lambda>ab _. add_to_rbt ab) t t'))"
proof (induction t arbitrary: t')
  case (Branch c t1 ab v t2)
  show ?case
    by (auto simp: Branch(1)[OF Branch(3,4)]
        flatten_add_to_rbt[OF is_rbt_fold_add_to_rbt[OF Branch(3)]]
        Branch(2)[OF is_rbt_add_to_rbt[OF is_rbt_fold_add_to_rbt[OF Branch(3)]],
        OF nonempty_add_to_rbt[OF is_rbt_fold_add_to_rbt[OF Branch(3)], of a t1]])
qed auto

lemma flatten_rbt_set_to_mapping: "flatten (set (RBT_Impl.entries (rbt_set_to_rbt t))) =
  set (RBT_Impl.keys t)"
  by (auto simp: rbt_set_to_rbt_def flatten_fold_add_to_rbt)

lemma nonempty_rbt_set_to_mapping: "(a, {}) \<notin> set (RBT_Impl.entries (rbt_set_to_rbt t))"
  by (auto simp: rbt_set_to_rbt_def flatten_fold_add_to_rbt)

lemma images_rbt_set_to_mapping:
  "images (set (RBT_Impl.keys t)) = set (RBT_Impl.entries (rbt_set_to_rbt t))"
proof -
  have "images (flatten (set (RBT_Impl.entries (rbt_set_to_rbt t)))) =
    set (RBT_Impl.entries (rbt_set_to_rbt t))"
    by (rule images_flatten)
       (auto simp: is_rbt_rbt_set_to_rbt rbt_sorted_entries_right_unique
        nonempty_rbt_set_to_mapping)
  then show ?thesis
    unfolding flatten_rbt_set_to_mapping[of t]
    by simp
qed

lemma proj_rbt_set_to_mapping:
  "Equiv_Relations.proj (set (RBT_Impl.keys t)) a =
  (case map_of (RBT_Impl.entries (rbt_set_to_rbt t)) a of None \<Rightarrow> {} | Some X \<Rightarrow> X)"
  by (auto simp: proj_iff_images' split: option.splits)
     (auto simp: images_rbt_set_to_mapping[symmetric] images_iff_proj
      map_of_eq_None_iff dest: map_of_SomeD intro: fst_imagesI)

end

context
  fixes c :: "'a comparator"
begin

definition add_to_rbt_comp :: "'a \<times> 'b \<Rightarrow> ('a, 'b set) rbt \<Rightarrow> ('a, 'b set) rbt" where
  "add_to_rbt_comp = (\<lambda>(a, b) t. case rbt_comp_lookup c t a of None \<Rightarrow> rbt_comp_insert c a {b} t
  | Some X \<Rightarrow> rbt_comp_insert c a (X \<union> {b}) t)"

definition rbt_set_to_rbt_comp :: "('a \<times> 'b, unit) rbt \<Rightarrow> ('a, 'b set) rbt" where
  "rbt_set_to_rbt_comp t = RBT_Impl.fold (\<lambda>ab _. add_to_rbt_comp ab) t RBT_Impl.Empty"

context
  assumes c: "comparator c"
begin

lemma add_to_rbt_comp: "add_to_rbt_comp = ord.add_to_rbt (lt_of_comp c)"
  unfolding add_to_rbt_comp_def ord.add_to_rbt_def rbt_comp_lookup[OF c] rbt_comp_insert[OF c]
  by simp

lemma rbt_set_to_rbt_comp: "rbt_set_to_rbt_comp = ord.rbt_set_to_rbt (lt_of_comp c)"
  unfolding rbt_set_to_rbt_comp_def ord.rbt_set_to_rbt_def add_to_rbt_comp
  by simp

end

end

lemma rbt_comp_lookup_map_of:
  fixes t :: "('a :: ccompare, 'b) rbt"
  assumes "ID ccompare = (Some c :: 'a comparator option)"
    and "ord.is_rbt (lt_of_comp c) t"
  shows "rbt_comp_lookup c t = map_of (RBT_Impl.entries t)"
proof -
  have c: "comparator (c :: 'a comparator)"
    using ID_ccompare'[OF assms(1)] .
  show ?thesis
    using linorder.map_of_entries[OF comparator.linorder[OF c]] assms(2)
    unfolding rbt_comp_lookup[OF c] ord.is_rbt_def
    by fastforce
qed

lemma dom_rbt_comp_lookup:
  fixes t :: "('a :: ccompare, 'b) rbt"
  assumes "ID ccompare = (Some c :: 'a comparator option)"
    and "ord.is_rbt (lt_of_comp c) t"
  shows "dom (rbt_comp_lookup c t) = set (RBT_Impl.keys t)"
proof -
  have c: "comparator (c :: 'a comparator)"
    using ID_ccompare'[OF assms(1)] .
  show ?thesis
    using linorder.rbt_lookup_keys[OF comparator.linorder[OF c]] assms(2)
    unfolding rbt_comp_lookup[OF c] ord.is_rbt_def
    by auto
qed

lemma comparator_prod:
  assumes "ID ccompare = (Some ccomp :: 'a :: ccompare comparator option)"
    "ID ccompare = (Some ccomp :: 'b :: ccompare comparator option)"
  shows "ID ccompare = (Some ccomp :: ('a \<times> 'b) comparator option)"
  using assms
  by (auto simp: ccompare_prod_def ID_Some split: option.splits)

lemma comparator_set:
  assumes "ID ccompare = (Some ccomp :: 'a :: ccompare comparator option)"
  shows "ID ccompare = (Some ccomp :: 'a set comparator option)"
  using assms
  by (auto simp: ccompare_set_def ID_Some)
     (metis (no_types, lifting) ID_code map_option_is_None option.collapse option.simps(3))

lemma dom_map_of_map: "distinct xs \<Longrightarrow> dom (map_of (map (\<lambda>x. (x, ())) xs)) = set xs"
  by (induction xs) auto

lemma distinct_map_fstD: "distinct (map fst xs) \<Longrightarrow> distinct xs"
  by (induction xs) auto

context linorder
begin

lemma rbt_bulkload_keys: "distinct xs \<Longrightarrow>
  set (RBT_Impl.keys (rbt_bulkload (map (\<lambda>x. (x, ())) xs))) = set xs"
  by (simp add: rbt_lookup_keys[symmetric] rbt_lookup_rbt_bulkload dom_map_of_map)

end

definition mapping_to_set :: "('a :: ccompare, 'b :: ccompare set) rbt \<Rightarrow>
  ('a \<times> 'b set) set_rbt" where
  "mapping_to_set t = RBT_Mapping2.bulkload (map (\<lambda>x. (x, ())) (RBT_Impl.entries t))"

lemma ccomps:
  assumes "ID ccompare = (Some c :: 'a :: ccompare comparator option)"
    "ID ccompare = (Some c' :: 'b :: ccompare comparator option)"
  shows "ID ccompare = (Some ccomp :: ('a \<times> 'b) comparator option)"
    "ID ccompare = (Some ccomp :: ('a \<times> 'b set) comparator option)"
  subgoal
    using comparator_prod assms
    by force
  subgoal
    using comparator_prod comparator_set assms
    by (metis option.collapse option.simps(3))
  done

lemma proj_code[code]:
  fixes t :: "('a :: ccompare \<times> 'b :: ccompare) set_rbt"
  shows "Equiv_Relations.proj (RBT_set t) = (case ID CCOMPARE('a) of None \<Rightarrow>
    Code.abort (STR ''proj: ccompare = None'') (\<lambda>_. Equiv_Relations.proj (RBT_set t))
  | Some c \<Rightarrow> (case ID CCOMPARE('b) of None \<Rightarrow>
    Code.abort (STR ''proj: ccompare = None'') (\<lambda>_. Equiv_Relations.proj (RBT_set t))
  | Some _ \<Rightarrow> let m = rbt_set_to_rbt_comp c (RBT_Mapping2.impl_of t) in
    (\<lambda>a. (case rbt_comp_lookup c m a of None \<Rightarrow> {} | Some X \<Rightarrow> X))))"
proof -
  {
    fix t c c'
    assume assms: "ord.is_rbt cless (t :: ('a \<times> 'b, unit) rbt) \<or>
      ID ccompare = (None :: ('a \<times> 'b) comparator option)"
      "ID ccompare = (Some c :: 'a comparator option)"
      "ID ccompare = (Some c' :: 'b comparator option)"
    note cab_ID_ccomp = ccomps(1)[OF assms(2,3)]
    have is_rbt_t: "ord.is_rbt cless t"
      using cab_ID_ccomp mapping_comparator assms(1)
      by auto
    have c: "comparator (c :: 'a comparator)"
      using ID_ccompare'[OF assms(2)] .
    note c_class = comparator.linorder[OF c]
    have rbt_comp_lookup: "rbt_comp_lookup c (rbt_set_to_rbt_comp c t) =
      map_of (RBT_Impl.entries (ord.rbt_set_to_rbt (lt_of_comp c) t))"
      unfolding rbt_comp_lookup_map_of[OF assms(2) linorder.is_rbt_rbt_set_to_rbt[OF c_class]]
        rbt_set_to_rbt_comp[OF c]
      by (rule refl)
    note linorder.proj_rbt_set_to_mapping[OF comparator.linorder[OF c], of t, folded rbt_comp_lookup]
      dom_rbt_comp_lookup[OF cab_ID_ccomp is_rbt_t]
  }
  note rw = this
  show ?thesis
    unfolding RBT_set_def
    using rw
    by transfer (auto split: option.splits)
qed

lemma images_code[code]:
  fixes t :: "('a :: ccompare \<times> 'b :: ccompare) set_rbt"
  shows "images (RBT_set t) = (case ID CCOMPARE('a) of None \<Rightarrow>
    Code.abort (STR ''images: ccompare = None'') (\<lambda>_. images (RBT_set t))
    | Some c \<Rightarrow> (case ID CCOMPARE('b) of None \<Rightarrow>
    Code.abort (STR ''images: ccompare = None'') (\<lambda>_. images (RBT_set t))
    | Some _ \<Rightarrow> RBT_set (mapping_to_set (rbt_set_to_rbt_comp c (RBT_Mapping2.impl_of t)))))"
proof -
  {
    fix t c c'
    assume assms: "ord.is_rbt cless (t :: ('a \<times> 'b, unit) rbt) \<or>
      ID ccompare = (None :: ('a \<times> 'b) comparator option)"
      "ID ccompare = (Some c :: 'a comparator option)"
      "ID ccompare = (Some c' :: 'b comparator option)"
    note cab_ID_ccomp = ccomps(1)[OF assms(2,3)]
    note cab_set_ID_ccomp = ccomps(2)[OF assms(2,3)]
    have is_rbt_t: "ord.is_rbt cless t"
      using cab_ID_ccomp mapping_comparator assms(1)
      by auto
    have c: "comparator (c :: 'a comparator)"
      using ID_ccompare'[OF assms(2)] .
    have cab_set_ccomp: "comparator (ccomp :: ('a \<times> 'b set) comparator)"
      using ID_ccompare'[OF cab_set_ID_ccomp] .
    note c_class = comparator.linorder[OF c]
    note cab_set_class = comparator.linorder[OF cab_set_ccomp]
    have distinct: "distinct (RBT_Impl.entries (ord.rbt_set_to_rbt (lt_of_comp c) t))"
      using linorder.distinct_entries[OF c_class, of "ord.rbt_set_to_rbt (lt_of_comp c) t"]
        linorder.is_rbt_rbt_set_to_rbt[OF c_class, of t]
      by (auto simp: ord.is_rbt_def dest: distinct_map_fstD)
    have "images (dom (rbt_comp_lookup ccomp t)) = dom (rbt_comp_lookup ccomp
      (rbt_comp_bulkload ccomp (map (\<lambda>x. (x, ())) (RBT_Impl.entries (rbt_set_to_rbt_comp c t)))))"
      by (simp add: dom_rbt_comp_lookup[OF cab_ID_ccomp is_rbt_t]
          linorder.images_rbt_set_to_mapping[OF c_class]
          rbt_set_to_rbt_comp[OF c] rbt_comp_bulkload[OF cab_set_ccomp]
          dom_rbt_comp_lookup[OF cab_set_ID_ccomp linorder.rbt_bulkload_is_rbt[OF cab_set_class]]
          linorder.rbt_bulkload_keys[OF cab_set_class distinct])
  }
  then show ?thesis
    unfolding RBT_set_def mapping_to_set_def
    by transfer (simp split: option.splits)
qed

end


(*<*)
(*
   Title: FR.thy  (FlexRay: Verification)
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
header {* FlexRay: Verification *}

theory  FR_proof
imports FR
begin

subsection {* Properties of the function Send *}

lemma Send_L1:
assumes "Send return send get activation"
       and "send t  \<noteq> []"
shows  "(activation t) \<noteq> []"
using assms by (simp add: Send_def, auto)

lemma Send_L2:
assumes "Send return send get activation"
       and "(activation t)  \<noteq> []"
       and "return t \<noteq> []"
shows  "(send t) \<noteq> []"
using assms  by (simp add: Send_def)

subsection {* Properties of the component Scheduler *}

lemma Scheduler_L1:
assumes h1:"Scheduler C activation"
        and h2:"(activation t) \<noteq> []"
shows "(t mod (cycleLength C)) mem (schedule C)"
using assms
proof -
   { assume  a1:"\<not> t mod cycleLength C mem schedule C"
      from h1 have
      "if t mod cycleLength C mem schedule C
       then activation t = [t mod cycleLength C]
       else activation t = []"
         by (simp add: Scheduler_def Let_def)
     from a1 and this have "activation t = []" by simp
     from this and h2 have sg3:"False" by simp
   } from this have  sg4:"(t mod (cycleLength C)) mem (schedule C)" by blast
  from this show ?thesis by simp
qed

lemma Scheduler_L2:
assumes "Scheduler C activation"
       and "\<not> (t mod cycleLength C) mem (schedule C)"
shows "activation t = []"
using assms by (simp add: Scheduler_def Let_def)

lemma Scheduler_L3:
assumes "Scheduler C activation"
       and "(t mod cycleLength C) mem (schedule C)"
shows "activation t \<noteq> []"
using assms by (simp add: Scheduler_def Let_def)

lemma Scheduler_L4:
assumes "Scheduler C activation"
       and "(t mod cycleLength C) mem (schedule C)"
shows "activation t = [t mod cycleLength C]"
using assms by (simp add: Scheduler_def Let_def)

lemma correct_DisjointSchedules1:
assumes h1:"DisjointSchedules n nC"
       and h2:"IdenticCycleLength n nC"
       and h3:"(t mod cycleLength (nC i)) mem schedule (nC i)"
       and h4:"i < n"
       and h5:"j < n"
       and h6:"i \<noteq> j"
shows "\<not> (t mod cycleLength (nC j) mem schedule (nC j))"
proof -
  from h1 and h4 and h5 and h6 have sg1:"disjoint (schedule (nC i)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from h2 and h4 and h5 have sg2:"cycleLength (nC i) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from sg1 and h3 have sg3:"\<not> (t mod (cycleLength (nC i))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg2 and sg3 show ?thesis by simp
qed

subsection {* Disjoint Frames *}

lemma disjointFrame_L1:
assumes h1:"DisjointSchedules n nC"
       and h2:"IdenticCycleLength n nC"
       and h3:"\<forall> i < n. FlexRayController (nReturn i) rcv
                      (nC i) (nStore i) (nSend i) (nGet i)"
       and h4:"nSend i t \<noteq> []"
       and h5:"i < n"
       and h6:"j < n"
       and h7:"i \<noteq> j"
shows "nSend j t = []"
proof -
  from h3 and h5 have sg1:
   "FlexRayController (nReturn i) rcv (nC i) (nStore i) (nSend i) (nGet i)"
    by auto
  from h3 and h6 have sg2:
   "FlexRayController (nReturn j) rcv (nC j) (nStore j) (nSend j) (nGet j)"
    by auto
  from sg1 obtain activation1 where
     a1:"Scheduler (nC i) activation1" and
     a2:"BusInterface activation1 (nReturn i) rcv (nStore i) (nSend i) (nGet i)"
     by (simp add: FlexRayController_def, auto)
  from sg2 obtain activation2 where
     a3:"Scheduler (nC j) activation2" and
     a4:"BusInterface activation2 (nReturn j) rcv (nStore j) (nSend j) (nGet j)"
     by (simp add: FlexRayController_def, auto)
  from h1 and h5 and h6 and h7 have sg3:"disjoint (schedule (nC i)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from a2 have  sg4a:"Send (nReturn i) (nSend i) (nGet i) activation1"
     by (simp add:  BusInterface_def)
  from sg4a and h4 have sg5:"activation1 t  \<noteq> []" by (simp add: Send_L1)
  from a1 and sg5 have sg6:"(t mod (cycleLength (nC i))) mem (schedule (nC i))"
     by (simp add: Scheduler_L1)
  from h2 and h5 and h6 have sg7:"cycleLength (nC i) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from sg3 and sg6 have sg8:"\<not> (t mod (cycleLength (nC i))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg8 and sg7 have sg9:"\<not> (t mod (cycleLength (nC j))) mem (schedule (nC j))"
    by simp
  from sg9 and a3 have sg10:"activation2 t = []" by (simp add: Scheduler_L2)
  from a4 have sg11:"Send (nReturn j) (nSend j) (nGet j) activation2"
     by (simp add:  BusInterface_def)
  from sg11 and sg10 show ?thesis by (simp add: Send_def)
qed

lemma disjointFrame_L2:
assumes "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "\<forall> i < n. FlexRayController (nReturn i) rcv
                      (nC i) (nStore i) (nSend i) (nGet i)"
shows "inf_disj n nSend"
using assms
  apply (simp add: inf_disj_def, clarify)
  by (rule disjointFrame_L1, auto)

lemma disjointFrame_L3:
assumes h1:"DisjointSchedules n nC"
     and h2:"IdenticCycleLength n nC"
     and h3:"\<forall> i < n. FlexRayController (nReturn i) rcv
                      (nC i) (nStore i) (nSend i) (nGet i)"
    and h4:"t mod cycleLength (nC i) mem schedule (nC i)"
    and h5:"i < n"
    and h6:"j < n"
    and h7:"i \<noteq> j"
shows "nSend j t = []"
proof -
  from h2 and h5 and h6 have sg1:"cycleLength (nC i) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from h1 and h5 and h6 and h7 have sg2:"disjoint (schedule (nC i)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from sg2 and h4 have sg3:"\<not> (t mod (cycleLength (nC i))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg1 and sg3 have sg4:"\<not> (t mod (cycleLength (nC j))) mem (schedule (nC j))"
    by simp
  from h3 and h6 have sg5:
   "FlexRayController (nReturn j) rcv (nC j) (nStore j) (nSend j) (nGet j)"
    by auto
  from sg5 obtain activation2 where
     a1:"Scheduler (nC j) activation2" and
     a2:"BusInterface activation2 (nReturn j) rcv (nStore j) (nSend j) (nGet j)"
     by (simp add: FlexRayController_def, auto)
  from sg4 and a1 have sg6:"activation2 t = []" by (simp add: Scheduler_L2)
  from a2 have sg7:"Send (nReturn j) (nSend j) (nGet j) activation2"
     by (simp add:  BusInterface_def)
  from sg7 and sg6 show ?thesis by (simp add: Send_def)
qed

subsection {* Properties of the sheaf of channels nSend *}

lemma fr_Send1:
assumes frc:"FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
        and h1:"\<not> (t mod cycleLength (nC i) mem schedule (nC i))"
 shows      "(nSend i) t = []"
proof -
  from frc obtain activation where
    a1:"Scheduler (nC i) activation"  and
    a2:"BusInterface activation (nReturn i) recv (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayController_def, auto)
  from a1 and h1 have sg1:"activation t = []" by (simp add: Scheduler_L2)
  from a2 have sg2:"Send (nReturn i) (nSend i) (nGet i) activation"
    by (simp add: BusInterface_def)
  from sg2 and sg1 show ?thesis by (simp add: Send_def)
qed

lemma fr_Send2:
 assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"DisjointSchedules n nC"
     and h3:"IdenticCycleLength n nC"
     and h4:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h5:"k < n"
 shows "nSend k t = nReturn k t"
proof -
 from h1 and h5 have sg1:
   "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
  from sg1 obtain activation where
     a1:"Scheduler (nC k) activation" and
     a2:"BusInterface activation (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
  from a1 and h4 have sg3:"activation t \<noteq> []" by (simp add: Scheduler_L3)
  from a2 have  sg4:"Send (nReturn k) (nSend k) (nGet k) activation"
     by (simp add:  BusInterface_def)
  from sg4 and sg3 show ?thesis by (simp add: Send_def)
qed

lemma fr_Send3:
 assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and "DisjointSchedules n nC"
     and "IdenticCycleLength n nC"
     and "t mod cycleLength (nC k) mem schedule (nC k)"
     and "k < n"
     and "nReturn k t \<noteq> []"
 shows "nSend k t \<noteq> []"
using assms by (simp add: fr_Send2)

lemma fr_Send4:
 assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and "DisjointSchedules n nC"
     and "IdenticCycleLength n nC"
     and "t mod cycleLength (nC k) mem schedule (nC k)"
     and "k < n"
     and "nReturn k t \<noteq> []"
 shows "\<exists>k. k < n \<longrightarrow> nSend k t \<noteq> []"
using assms
by (metis  fr_Send3)

lemma fr_Send5:
 assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"DisjointSchedules n nC"
     and h3:"IdenticCycleLength n nC"
     and h4:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h5:"k < n"
     and h6:"nReturn k t \<noteq> []"
     and h7:"\<forall>k<n. nSend k t = []"
 shows "False"
proof -
  from h1 and h2 and h3 and h4 and h5 and h6 have sg1:"nSend k t \<noteq> []"
    by (simp add: fr_Send2)
  from h7 and h5 have sg2:"nSend k t = []" by blast
  from sg1 and sg2 show ?thesis by simp
qed

lemma fr_Send6:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
       and "nReturn k t \<noteq> []"
shows "\<exists>k<n. nSend k t \<noteq> []"
using assms
by (metis fr_Send3)

lemma fr_Send7:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
       and "j < n"
       and "nReturn k t = []"
shows "nSend j t = []"
using assms
by (metis (full_types) disjointFrame_L3 fr_Send2)

lemma fr_Send8:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
       and "nReturn k t = []"
shows "\<not> (\<exists>k<n. nSend k t \<noteq> [])"
using assms by (auto, simp add: fr_Send7)

lemma fr_nC_Send:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "k < n"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
shows "\<forall>j. j < n \<and> j \<noteq> k \<longrightarrow> (nSend j) t = []"
using assms by (clarify, simp add: disjointFrame_L3)

lemma length_nSend:
assumes h1:"BusInterface activation (nReturn i) recv (nStore i) (nSend i) (nGet i)"
       and h2:"\<forall>t. length (nReturn i t) \<le> Suc 0"
shows   "length (nSend i t) \<le> Suc 0"
proof -
  from h1 have sg1:"Send (nReturn i) (nSend i) (nGet i) activation"
    by (simp add: BusInterface_def)
  from sg1 have sg2:
   "if activation t = [] then nGet i t = [] \<and> nSend i t = []
    else nGet i t = activation t \<and> nSend i t = nReturn i t"
    by (simp add: Send_def)
  show ?thesis
  proof (cases "activation t = []")
    assume a1:"activation t = []"
    from sg2 and a1 show ?thesis by simp
  next
    assume a2:"activation t \<noteq> []"
    from h2 have sg3:"length (nReturn i t) \<le> Suc 0" by auto
    from sg2 and a2 and sg3 show ?thesis by simp
  qed
qed

lemma msg_nSend:
assumes "BusInterface activation (nReturn i) recv (nStore i) (nSend i) (nGet i)"
       and "msg (Suc 0) (nReturn i)"
shows "msg (Suc 0) (nSend i)"
using assms by (simp add: msg_def, clarify, simp add: length_nSend)

lemma Broadcast_nSend_empty1:
assumes h1:"Broadcast n nSend recv"
       and h2:"\<forall>k<n. nSend k t = []"
shows      "recv t = []"
using assms
by (metis Broadcast_def)

subsection {* Properties of the sheaf of channels  nGet *}

lemma fr_nGet1a:
assumes h1:"FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
       and h2:"t mod cycleLength (nC k) mem schedule (nC k)"
shows "nGet k t = [t mod cycleLength (nC k)]"
proof -
  from h1  obtain activation1 where
     a1:"Scheduler (nC k) activation1" and
     a2:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
   from a2 have sg1:"Send (nReturn k) (nSend k) (nGet k) activation1"
     by (simp add: BusInterface_def)
   from sg1 have sg2:
    "if activation1 t = [] then nGet k t = [] \<and> nSend k t = []
     else nGet k t = activation1 t \<and> nSend k t = nReturn k t"
     by (simp add: Send_def)
  from a1 and h2 have sg3:"activation1 t = [t mod cycleLength (nC k)]"
     by (simp add: Scheduler_L4)
  from sg2 and sg3 show ?thesis  by simp
qed

lemma fr_nGet1:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "t mod cycleLength (nC k) mem schedule (nC k)"
       and "k < n"
shows "nGet k t = [t mod cycleLength (nC k)]"
using assms
by (metis  fr_nGet1a)

lemma fr_nGet2:
assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"\<not> (t mod cycleLength (nC k) mem schedule (nC k))"
     and h3:"k < n"
 shows "nGet k t = []"
proof -
  from h1 and h3 have sg1:
    "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
  from sg1 and h2 show ?thesis by (rule fr_nGet2a)
qed

lemma length_nGet1:
 assumes "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
 shows    "length (nGet k t) \<le> Suc 0"
proof (cases "t mod cycleLength (nC k) mem schedule (nC k)")
  assume "t mod cycleLength (nC k) mem schedule (nC k)"
  from assms and this have "nGet k t = [t mod cycleLength (nC k)]"
    by (rule fr_nGet1a)
  then show ?thesis by auto
next
  assume "\<not> (t mod cycleLength (nC k) mem schedule (nC k))"
  from assms and this have "nGet k t = []" by (rule fr_nGet2a)
  then show ?thesis by auto
qed

lemma msg_nGet1:
 assumes "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
 shows    "msg (Suc 0) (nGet k)"
using assms
by (simp add: msg_def, auto, rule length_nGet1)

lemma msg_nGet2:
assumes "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "k < n"
shows "msg (Suc 0) (nGet k)"
using assms
by (metis msg_nGet1)

subsection {* Properties of the sheaf of channels nStore *}

lemma fr_nStore_nReturn1:
 assumes h0:"Broadcast n nSend recv"
     and h1:"inf_disj n nSend"
     and h2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h6:"k < n"
     and h7:"j < n"
     and h8:"j \<noteq> k"
 shows  "nStore j t = nReturn k t"
proof -
  from h2 and h6 have sg1:
    "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
  from h2 and h7 have sg2:
    "FlexRayController (nReturn j) recv (nC j) (nStore j) (nSend j) (nGet j)"
    by auto
   from sg1 obtain activation1 where
     a1:"Scheduler (nC k) activation1" and
     a2:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
  from sg2 obtain activation2 where
     a3:"Scheduler (nC j) activation2" and
     a4:"BusInterface activation2 (nReturn j) recv (nStore j) (nSend j) (nGet j)"
     by (simp add: FlexRayController_def, auto)
  from a4 have sg3:"Receive recv (nStore j) activation2"
     by (simp add: BusInterface_def)
  from this have sg4:
   "if activation2 t = [] then nStore j t = recv t else nStore j t = []"
    by (simp add: Receive_def)
  from a1 and h5 have sg5:"activation1 t \<noteq> []"
     by (simp add: Scheduler_L3)
 from h4 and h6 and h7 have sg6:"cycleLength (nC k) = cycleLength (nC j)"
    by (metis IdenticCycleLength_def)
  from h3 and h6 and h7 and h8 have sg7:"disjoint (schedule (nC k)) (schedule (nC j))"
    by (simp add: DisjointSchedules_def)
  from sg7 and h5 have sg8:"\<not> (t mod (cycleLength (nC k))) mem (schedule (nC j))"
    by (simp add: mem_notdisjoint2)
  from sg6 and sg8 have sg9:"\<not> (t mod (cycleLength (nC j))) mem (schedule (nC j))"
    by simp
  from sg9 and a3 have sg10:"activation2 t = []" by (simp add: Scheduler_L2)
  from sg10 and sg4 have sg11:"nStore j t = recv t" by simp
  from h0 have sg15:
   "if \<exists>k<n. nSend k t \<noteq> []
    then recv t = nSend (SOME k. k < n \<and> nSend k t \<noteq> []) t
    else recv t = []"
    by (simp add: Broadcast_def)
  show ?thesis
  proof (cases "nReturn k t = []")
    assume a5: "nReturn k t = []"
    from h2 and h3 and h4 and h5 and h6 and a5 have sg16:"\<not> (\<exists>k<n. nSend k t \<noteq> [])"
      by (simp add: fr_Send8)
    from sg16 and sg15 have sg17:"recv t = []" by simp
    from sg11 and sg17 have sg18:"nStore j t = []" by simp
    from this and a5 show ?thesis by simp
  next
    assume a6:"nReturn k t \<noteq> []"
    from h2 and h3 and h4 and h5 and h6 and a6 have sg19:"\<exists>k<n. nSend k t \<noteq> []"
      by (simp add: fr_Send6)
    from h2 and h3 and h4 and h5 and h6 and a6 have sg20:"nSend k t \<noteq> []"
      by (simp add: fr_Send3)
    from h1 and sg20 and h6 have sg21:"(SOME k. k < n \<and> nSend k t \<noteq> []) = k"
      by (simp add: inf_disj_index)
    from sg15 and sg19 have sg22:"recv t = nSend (SOME k. k < n \<and> nSend k t \<noteq> []) t"
      by simp
    from sg22 and sg21 have sg23:"recv t = nSend k t" by simp
    from h2 and h3 and h4 and h5 and h6 have sg24:"nSend k t =  nReturn k t"
      by (simp add: fr_Send2)
    from sg11 and sg23 and sg24 show ?thesis by simp
  qed
qed

lemma fr_nStore_nReturn2:
 assumes h1:"Cable n nSend recv"
     and h2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"t mod cycleLength (nC k) mem schedule (nC k)"
     and h6:"k < n"
     and h7:"j < n"
     and h8:"j \<noteq> k"
 shows  "nStore j t = nReturn k t"
proof -
  from h1 have sg1:"inf_disj n nSend \<longrightarrow> Broadcast n nSend recv"
    by (simp add: Cable_def)
  from  h3 and h4 and h2 have sg2:"inf_disj n nSend"
    by (simp add: disjointFrame_L2)
  from sg1 and sg2 have sg3:"Broadcast n nSend recv" by simp
  from sg3 and sg2 and assms show ?thesis  by (simp add: fr_nStore_nReturn1)
qed

lemma fr_nStore_empty1:
 assumes h1:"Cable n nSend recv"
     and h2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"(t mod cycleLength (nC k) mem schedule (nC k))"
     and h6:"k < n"
 shows  "nStore k t = []"
proof -
  from h2 and h6 have sg1:
    "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
    by auto
   from sg1 obtain activation1 where
     a1:"Scheduler (nC k) activation1" and
     a2:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
     by (simp add: FlexRayController_def, auto)
  from a2 have sg2:"Receive recv (nStore k) activation1"
     by (simp add: BusInterface_def)
  from this have sg3:
   "if activation1 t = [] then nStore k t = recv t else nStore k t = []"
    by (simp add: Receive_def)
  from a1 and h5 have sg4:"activation1 t \<noteq> []"
     by (simp add: Scheduler_L3)
 from sg3 and sg4 show ?thesis by simp
qed

lemma fr_nStore_nReturn3:
 assumes "Cable n nSend recv"
     and "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and "DisjointSchedules n nC"
     and "IdenticCycleLength n nC"
     and "t mod cycleLength (nC k) mem schedule (nC k)"
     and "k < n"
 shows  "\<forall>j. j < n \<and> j \<noteq> k \<longrightarrow> nStore j t = nReturn k t"
using assms
by (clarify, simp add: fr_nStore_nReturn2)

lemma length_nStore:
 assumes h1:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
     and h2:"DisjointSchedules n nC"
     and h3:"IdenticCycleLength n nC"
     and h4:"inf_disj n nSend"
     and h5:"i < n"
     and h6:"\<forall> i<n. msg (Suc 0) (nReturn i)"
     and h7:"Broadcast n nSend recv"
 shows "length (nStore i t) \<le> Suc 0"
proof -
  from h7 have sg1:
   "if \<exists>k<n. nSend k t \<noteq> []
    then recv t = nSend (SOME k. k < n \<and> nSend k t \<noteq> []) t
    else recv t = []"
   by (simp add: Broadcast_def)
  show ?thesis
  proof (cases "\<exists>k<n. nSend k t \<noteq> []")
    assume "\<exists>k<n. nSend k t \<noteq> []"
    from this obtain k where a2:"k<n" and a3:"nSend k t \<noteq> []"  by auto
    from h1 and a2 have
      "FlexRayController (nReturn k) recv (nC k) (nStore k) (nSend k) (nGet k)"
      by auto
    then obtain activation1 where
      a4:"Scheduler (nC k) activation1" and
      a5:"BusInterface activation1 (nReturn k) recv (nStore k) (nSend k) (nGet k)"
      by (simp add: FlexRayController_def, auto)
    from a5 have sg5:"Send (nReturn k) (nSend k) (nGet k) activation1"
      by (simp add:  BusInterface_def)
    from a5 have sg6:"Receive recv (nStore k) activation1"
      by (simp add: BusInterface_def)
    from sg5 and a3 have sg7:"(activation1 t) \<noteq> []" by (simp add: Send_L1)
    from sg6 have sg8:
     "if activation1 t = []
      then nStore k t = recv t else nStore k t = []"
      by (simp add: Receive_def)
    from sg8 and sg7 have sg9:"nStore k t = []" by simp
    from a4 and sg7 have sg10:"(t mod (cycleLength (nC k))) mem (schedule (nC k))"
      by (simp add: Scheduler_L1)
    show ?thesis
    proof (cases "i = k")
      assume  "i = k"
      from sg9 and this show ?thesis by simp
    next
      assume "i \<noteq> k"
      from h7 and h4 and h1 and h2 and h3 and sg10 and a2 and h5 and this have sg11:
       "nStore i t = nReturn k t"
        by (simp add: fr_nStore_nReturn1)
      from h6 and a2 have sg12:"msg (Suc 0) (nReturn k)" by auto
      from a2 and h6 have sg13:"length (nReturn k t) \<le> Suc 0"
        by (simp add: msg_def)
      from sg11 and sg13  show ?thesis by simp
    qed
  next
    assume "\<not> (\<exists>k<n. nSend k t \<noteq> [])"
    from h7 and this have sg14:"recv t = []" by (simp add: Broadcast_nSend_empty1)
    from h1 and h5 have
      "FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
      by auto
   then obtain activation2 where
      a11:"Scheduler (nC i) activation2" and
      a12:"BusInterface activation2 (nReturn i) recv (nStore i) (nSend i) (nGet i)"
      by (simp add: FlexRayController_def, auto)
    from a12 have "Receive recv (nStore i) activation2"
      by (simp add: BusInterface_def)
    then have sg17:
     "if activation2 t = []
      then nStore i t = recv t else nStore i t = []"
      by (simp add: Receive_def)
    show ?thesis
    proof (cases "activation2 t = []")
      assume aa3:"activation2 t = []"
      from sg17 and aa3 and sg14 have "nStore i t = []" by simp
      then show ?thesis by simp
    next
      assume aa4:"activation2 t \<noteq> []"
      from sg17 and aa4 have "nStore i t = []" by simp
      then show ?thesis by simp
    qed
  qed
qed

lemma msg_nStore:
assumes " \<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
       and "inf_disj n nSend"
       and "i < n"
       and "\<forall> i<n. msg (Suc 0) (nReturn i)"
       and "Cable n nSend recv"
shows "msg (Suc 0) (nStore i)"
using assms
  apply (simp (no_asm) add: msg_def, simp add: Cable_def, clarify)
  by (simp add: length_nStore)

subsection {* Refinement Properties *}

lemma fr_refinement_FrameTransmission:
assumes "Cable n nSend recv"
       and "\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
       and "DisjointSchedules n nC"
       and "IdenticCycleLength n nC"
shows "FrameTransmission n nStore nReturn nGet nC"
using assms
  apply (simp add: FrameTransmission_def Let_def, auto)
  apply (simp add: fr_nGet1)
  by (simp add: fr_nStore_nReturn3)

lemma FlexRayArch_CorrectSheaf:
 assumes "FlexRayArch n nReturn nC nStore nGet"
 shows    "CorrectSheaf n"
using assms by (simp add: FlexRayArch_def)

lemma FlexRayArch_FrameTransmission:
 assumes h1:"FlexRayArch n nReturn nC nStore nGet"
     and h2:"\<forall>i<n. msg (Suc 0) (nReturn i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
 shows      "FrameTransmission n nStore nReturn nGet nC"
proof -
  from assms obtain nSend recv where
    a1:"Cable n nSend recv" and
    a2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayArch_def  FlexRayArchitecture_def, auto)
  from a1 and a2 and h3 and h4 show ?thesis
    by (rule fr_refinement_FrameTransmission)
qed

lemma FlexRayArch_nGet:
 assumes h1:"FlexRayArch n nReturn nC nStore nGet"
     and h2:"\<forall>i<n. msg (Suc 0) (nReturn i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"i < n"
 shows      "msg (Suc 0) (nGet i)"
proof -
 from assms obtain nSend recv where
    a1:"Cable n nSend recv" and
    a2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayArch_def  FlexRayArchitecture_def, auto)
  from a2 and h5 show ?thesis by (rule msg_nGet2)
qed

lemma FlexRayArch_nStore:
 assumes h1:"FlexRayArch n nReturn nC nStore nGet"
     and h2:"\<forall>i<n. msg (Suc 0) (nReturn i)"
     and h3:"DisjointSchedules n nC"
     and h4:"IdenticCycleLength n nC"
     and h5:"i < n"
 shows      "msg (Suc 0) (nStore i)"
proof -
 from assms obtain nSend recv where
    a1:"Cable n nSend recv" and
    a2:"\<forall>i<n. FlexRayController (nReturn i) recv (nC i) (nStore i) (nSend i) (nGet i)"
    by (simp add: FlexRayArch_def  FlexRayArchitecture_def, auto)
  from h3 and h4 and a2 have sg1:"inf_disj n nSend" by (simp add: disjointFrame_L2)
  from a2 and h3 and h4 and sg1 and h5 and h2 and a1  show ?thesis
    by (rule msg_nStore)
qed

theorem main_fr_refinement:
 assumes "FlexRayArch n nReturn nC nStore nGet"
 shows     "FlexRay n nReturn nC nStore nGet"
using assms
  by (simp add: FlexRay_def
                FlexRayArch_CorrectSheaf
                FlexRayArch_FrameTransmission
                FlexRayArch_nGet
                FlexRayArch_nStore)

end