(*  Title:       CCPO_Topology.thy
    Author:      Johannes Hölzl, TU Munich
*)

section \<open>CCPO topologies\<close>

theory CCPO_Topology
imports
  "HOL-Analysis.Extended_Real_Limits"
  "../Coinductive_Nat"
begin

lemma dropWhile_append:
  "dropWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then dropWhile P ys else dropWhile P xs @ ys)"
  by auto

lemma dropWhile_False: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> dropWhile P xs = []"
  by simp

abbreviation (in order) "chain \<equiv> Complete_Partial_Order.chain (\<le>)"

lemma (in linorder) chain_linorder: "chain C"
  by (simp add: chain_def linear)

lemma continuous_add_ereal:
  assumes "0 \<le> t"
  shows "continuous_on {-\<infinity>::ereal <..} (\<lambda>x. t + x)"
proof (subst continuous_on_open_vimage, (intro open_greaterThan allI impI)+)
  fix B :: "ereal set" assume "open B"
  show "open ((\<lambda>x. t + x) -` B \<inter> {- \<infinity><..})"
  proof (cases t)
    case (real t')
    then have *: "(\<lambda>x. t + x) -` B \<inter> {- \<infinity><..} = (\<lambda>x. 1 * x + (-t)) ` (B \<inter> {-\<infinity> <..})"
      apply (simp add: set_eq_iff image_iff Bex_def)
      apply (intro allI iffI)
      apply (rule_tac x= "x + ereal t'" in exI)
      apply (case_tac x)
      apply (auto simp: ac_simps)
      done
    show ?thesis
      unfolding *
      apply (rule ereal_open_affinity_pos)
      using \<open>open B\<close>
      apply (auto simp: real)
      done
  qed (insert \<open>0 \<le> t\<close>, auto)
qed

lemma tendsto_add_ereal:
  "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> (f \<longlongrightarrow> y) F \<Longrightarrow> ((\<lambda>z. x + f z :: ereal) \<longlongrightarrow> x + y) F"
  apply (rule tendsto_compose[where f=f])
  using continuous_add_ereal[where t=x]
  unfolding continuous_on_def
  apply (auto simp add: at_within_open[where S="{- \<infinity> <..}"])
  done

lemma tendsto_LimI: "(f \<longlongrightarrow> y) F \<Longrightarrow> (f \<longlongrightarrow> Lim F f) F"
  by (metis tendsto_Lim tendsto_bot)

subsection \<open>The filter \<open>at'\<close>\<close>

abbreviation (in ccpo) "compact_element \<equiv> ccpo.compact Sup (\<le>)"

lemma tendsto_unique_eventually:
  fixes x x' :: "'a :: t2_space"
  shows "F \<noteq> bot \<Longrightarrow> eventually (\<lambda>x. f x = g x) F \<Longrightarrow> (f \<longlongrightarrow> x) F \<Longrightarrow> (g \<longlongrightarrow> x') F \<Longrightarrow> x = x'"
  by (metis tendsto_unique filterlim_cong)

lemma (in ccpo) ccpo_Sup_upper2: "chain C \<Longrightarrow> x \<in> C \<Longrightarrow> y \<le> x \<Longrightarrow> y \<le> Sup C"
  by (blast intro: ccpo_Sup_upper order_trans)

lemma tendsto_open_vimage: "(\<And>B. open B \<Longrightarrow> open (f -` B)) \<Longrightarrow> f \<midarrow>l\<rightarrow> f l"
  using continuous_on_open_vimage[of UNIV f] continuous_on_def[of UNIV f] by simp

lemma open_vimageI: "(\<And>x. f \<midarrow>x\<rightarrow> f x) \<Longrightarrow> open A \<Longrightarrow> open (f -` A)"
  using continuous_on_open_vimage[of UNIV f] continuous_on_def[of UNIV f] by simp

lemma principal_bot: "principal x = bot \<longleftrightarrow> x = {}"
  by (auto simp: filter_eq_iff eventually_principal)

definition "at' x = (if open {x} then principal {x} else at x)"

lemma at'_bot: "at' x \<noteq> bot"
  by (simp add: at'_def at_eq_bot_iff principal_bot)

lemma tendsto_id_at'[simp, intro]: "((\<lambda>x. x) \<longlongrightarrow> x) (at' x)"
  by (simp add: at'_def topological_tendstoI eventually_principal tendsto_ident_at)

lemma cont_at': "(f \<longlongrightarrow> f x) (at' x) \<longleftrightarrow> f \<midarrow>x\<rightarrow> f x"
  using at_eq_bot_iff[of x] by (auto split: if_split_asm intro!: topological_tendstoI simp: eventually_principal at'_def)

subsection \<open>The type class \<open>ccpo_topology\<close>\<close>

text \<open>Temporarily relax type constraints for @{term "open"}.\<close>
setup \<open>Sign.add_const_constraint
  (@{const_name "open"}, SOME @{typ "'a::open set \<Rightarrow> bool"})\<close>

class ccpo_topology = "open" + ccpo +
  assumes open_ccpo: "open A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"
begin

lemma open_ccpoD:
  assumes "open A" "chain C" "C \<noteq> {}" "Sup C \<in> A"
  shows "\<exists>c\<in>C. \<forall>c'\<in>C. c \<le> c' \<longrightarrow> c' \<in> A"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "\<And>c. c \<in> C \<Longrightarrow> \<exists>c'\<in>C. c \<le> c' \<and> c' \<notin> A"
    by auto
  with \<open>chain C\<close> \<open>C \<noteq> {}\<close> have "chain (C - A)" "C - A \<noteq> {}"
    by (auto intro: chain_Diff)
  moreover have "Sup C = Sup (C - A)"
  proof (safe intro!: antisym ccpo_Sup_least \<open>chain C\<close> chain_Diff)
    fix c assume "c \<in> C"
    with * obtain c' where "c' \<in> C" "c \<le> c'" "c' \<notin> A"
      by auto
    with \<open>c\<in>C\<close> show "c \<le> \<Squnion>(C - A)"
      by (intro ccpo_Sup_upper2 \<open>chain (C - A)\<close>) auto
  qed (auto intro: \<open>chain C\<close> ccpo_Sup_upper)
  ultimately show False
    using \<open>open A\<close> \<open>Sup C \<in> A\<close> by (auto simp: open_ccpo)
qed

lemma open_ccpo_Iic: "open {.. b}"
  by (auto simp: open_ccpo) (metis Int_iff atMost_iff ccpo_Sup_upper empty_iff order_trans)

subclass topological_space
proof
  show "open (UNIV::'a set)"
    unfolding open_ccpo by auto
next
  fix S T :: "'a set" assume "open S" "open T"
  show "open (S \<inter> T)"
    unfolding open_ccpo
  proof (intro allI impI)
    fix C assume C: "chain C" "C \<noteq> {}" and "\<Squnion>C \<in> S \<inter> T"
    with open_ccpoD[OF \<open>open S\<close> C] open_ccpoD[OF \<open>open T\<close> C]
    show "C \<inter> (S \<inter> T) \<noteq> {}"
      unfolding chain_def by blast
  qed
next
  fix K :: "'a set set" assume *: "\<forall>D\<in>K. open D"
  show "open (\<Union>K)"
    unfolding open_ccpo
  proof (intro allI impI)
    fix C assume "chain C" "C \<noteq> {}" "\<Squnion>C \<in> (\<Union>K)"
    with * obtain D where "D \<in> K" "\<Squnion>C \<in> D" "C \<inter> D \<noteq> {}"
      by (auto simp: open_ccpo)
    then show "C \<inter> (\<Union>K) \<noteq> {}"
      by auto
  qed
qed

lemma closed_ccpo: "closed A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> C \<subseteq> A \<longrightarrow> Sup C \<in> A)"
  unfolding closed_def open_ccpo by auto

lemma closed_admissible: "closed {x. P x} \<longleftrightarrow> ccpo.admissible Sup (\<le>) P"
  unfolding closed_ccpo ccpo.admissible_def by auto

lemma open_singletonI_compact: "compact_element x \<Longrightarrow> open {x}"
  using admissible_compact_neq[of Sup "(\<le>)" x]
  by (simp add: closed_admissible[symmetric] open_closed Collect_neg_eq)

lemma closed_Ici: "closed {.. b}"
  by (auto simp: closed_ccpo intro: ccpo_Sup_least)

lemma closed_Iic: "closed {b ..}"
  by (auto simp: closed_ccpo intro: ccpo_Sup_upper2)

text \<open>
  @{class ccpo_topology}s are also @{class t2_space}s.
  This is necessary to have a unique continuous extension.
\<close>

subclass t2_space
proof
  fix x y :: 'a assume "x \<noteq> y"
  show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
  proof cases
    { fix x y assume "x \<noteq> y" "x \<le> y"
      then have "open {..x} \<and> open (- {..x}) \<and> x \<in> {..x} \<and> y \<in> - {..x} \<and> {..x} \<inter> - {..x} = {}"
        by (auto intro: open_ccpo_Iic closed_Ici) }
    moreover assume "x \<le> y \<or> y \<le> x"
    ultimately show ?thesis
      using \<open>x \<noteq> y\<close> by (metis Int_commute)
  next
    assume "\<not> (x \<le> y \<or> y \<le> x)"
    then have "open ({..x} \<inter> - {..y}) \<and> open ({..y} \<inter> - {..x}) \<and>
        x \<in> {..x} \<inter> - {..y} \<and> y \<in> {..y} \<inter> - {..x} \<and> ({..x} \<inter> - {..y}) \<inter> ({..y} \<inter> - {..x}) = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    then show ?thesis by auto
  qed
qed

end

lemma tendsto_le_ccpo:
  fixes f g :: "'a \<Rightarrow> 'b::ccpo_topology"
  assumes F: "\<not> trivial_limit F"
  assumes x: "(f \<longlongrightarrow> x) F" and y: "(g \<longlongrightarrow> y) F"
  assumes ev: "eventually (\<lambda>x. g x \<le> f x) F"
  shows "y \<le> x"
proof (rule ccontr)
  assume "\<not> y \<le> x"

  show False
  proof cases
    assume "x \<le> y"
    with \<open>\<not> y \<le> x\<close>
    have "open {..x}" "open (- {..x})" "x \<in> {..x}" "y \<in> - {..x}" "{..x} \<inter> - {..x} = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    with topological_tendstoD[OF x, of "{..x}"] topological_tendstoD[OF y, of "- {..x}"]
    have "eventually (\<lambda>z. f z \<le> x) F" "eventually (\<lambda>z. \<not> g z \<le> x) F"
      by auto
    with ev have "eventually (\<lambda>x. False) F" by eventually_elim (auto intro: order_trans)
    with F show False by (auto simp: eventually_False)
  next
    assume "\<not> x \<le> y"
    with \<open>\<not> y \<le> x\<close> have "open ({..x} \<inter> - {..y})" "open ({..y} \<inter> - {..x})"
        "x \<in> {..x} \<inter> - {..y}" "y \<in> {..y} \<inter> - {..x}" "({..x} \<inter> - {..y}) \<inter> ({..y} \<inter> - {..x}) = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    with topological_tendstoD[OF x, of "{..x} \<inter> - {..y}"]
         topological_tendstoD[OF y, of "{..y} \<inter> - {..x}"]
    have "eventually (\<lambda>z. f z \<le> x \<and> \<not> f z \<le> y) F" "eventually (\<lambda>z. g z \<le> y \<and> \<not> g z \<le> x) F"
      by auto
    with ev have "eventually (\<lambda>x. False) F" by eventually_elim (auto intro: order_trans)
    with F show False by (auto simp: eventually_False)
  qed
qed

lemma tendsto_ccpoI:
  fixes f :: "'a::ccpo_topology \<Rightarrow> 'b::ccpo_topology"
  shows "(\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> chain (f ` C) \<and> f (Sup C) = Sup (f`C)) \<Longrightarrow> f \<midarrow>x\<rightarrow> f x"
  by (intro tendsto_open_vimage) (auto simp: open_ccpo)

lemma tendsto_mcont:
  assumes mcont: "mcont Sup (\<le>) Sup (\<le>) (f :: 'a :: ccpo_topology \<Rightarrow> 'b :: ccpo_topology)"
  shows "f \<midarrow>l\<rightarrow> f l"
proof (intro tendsto_ccpoI conjI)
  fix C :: "'a set" assume C: "chain C" "C \<noteq> {}"
  show "chain (f`C)"
    using mcont
    by (intro chain_imageI[where le_a="(\<le>)"] C) (simp add: mcont_def monotone_def)
  show "f (\<Squnion>C) = \<Squnion>(f ` C)"
    using mcont C by (simp add: mcont_def cont_def)
qed

subsection \<open>Instances for @{class ccpo_topology}s and continuity theorems\<close>

instantiation set :: (type) ccpo_topology
begin

definition open_set :: "'a set set \<Rightarrow> bool" where
  "open_set A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"

instance
  by intro_classes (simp add: open_set_def)

end

instantiation enat :: ccpo_topology
begin

instance
proof
  fix A :: "enat set"
  show "open A = (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> \<Squnion>C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"
  proof (intro iffI allI impI)
    fix C x assume "open A" "chain C" "C \<noteq> {}" "\<Squnion>C \<in> A"

    show "C \<inter> A \<noteq> {}"
    proof cases
      assume "\<Squnion>C = \<infinity>"
      with \<open>\<Squnion>C \<in> A\<close> \<open>open A\<close> obtain n where "{enat n <..} \<subseteq> A"
        unfolding open_enat_iff by auto
      with \<open>\<Squnion>C = \<infinity>\<close> Sup_eq_top_iff[of C] show ?thesis
        by (auto simp: top_enat_def)
    next
      assume "\<Squnion>C \<noteq> \<infinity>"
      then obtain n where "C \<subseteq> {.. enat n}"
        unfolding Sup_eq_top_iff top_enat_def[symmetric] by (auto simp: not_less top_enat_def)
      moreover have "finite {.. enat n}"
        by (auto intro: finite_enat_bounded)
      ultimately have "finite C"
        by (auto intro: finite_subset)
      from in_chain_finite[OF \<open>chain C\<close> \<open>finite C\<close> \<open>C \<noteq> {}\<close>] \<open>\<Squnion>C \<in> A\<close> show ?thesis
        by auto
    qed
  next
    assume C: "\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> \<Squnion>C \<in> A \<longrightarrow> C \<inter> A \<noteq> {}"
    show "open A"
      unfolding open_enat_iff
    proof safe
      assume "\<infinity> \<in> A"
      { fix C :: "enat set" assume "infinite C"
        then have "\<Squnion>C = \<infinity>"
          by (auto simp: Sup_enat_def)
        with \<open>infinite C\<close> C[THEN spec, of C] \<open>\<infinity> \<in> A\<close> have "C \<inter> A \<noteq> {}"
          by auto }
      note inf_C = this

      show "\<exists>x. {enat x<..} \<subseteq> A"
      proof (rule ccontr)
        assume "\<not> (\<exists>x. {enat x<..} \<subseteq> A)"
        with \<open>\<infinity> \<in> A\<close> have "\<And>x. \<exists>y>x. enat y \<notin> A"
          by (simp add: subset_eq Bex_def) (metis enat.exhaust enat_ord_simps(2))
        then have "infinite {n. enat n \<notin> A}"
          unfolding infinite_nat_iff_unbounded by auto
        then have "infinite (enat ` {n. enat n \<notin> A})"
          by (auto dest!: finite_imageD)
        from inf_C[OF this] show False
          by auto
      qed
    qed
  qed
qed

end

lemmas tendsto_inf2[THEN tendsto_compose, tendsto_intros] =
  tendsto_mcont[OF mcont_inf2]

lemma isCont_inf2[THEN isCont_o2[rotated]]:
  "isCont (\<lambda>x. x \<sqinter> y) (z :: _ :: {ccpo_topology, complete_distrib_lattice})"
  by(simp add: isCont_def tendsto_inf2 tendsto_ident_at)

lemmas tendsto_sup1[THEN tendsto_compose, tendsto_intros] =
  tendsto_mcont[OF mcont_sup1]

lemma isCont_If: "isCont f x \<Longrightarrow> isCont g x \<Longrightarrow> isCont (\<lambda>x. if Q then f x else g x) x"
  by (cases Q) auto

lemma isCont_enat_case: "isCont (f (epred n)) x \<Longrightarrow> isCont g x \<Longrightarrow> isCont (\<lambda>x. co.case_enat (g x) (\<lambda>n. f n x) n) x"
  by (cases n rule: enat_coexhaust) auto

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   Miscellaneous library definitions and lemmas.
*)

chapter "Distinct Proposition"

theory DistinctProp
imports
  "../lib/Lib"
  "~~/src/HOL/Library/Sublist"
begin

text {* distinct\_prop *}

primrec
  distinct_prop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"
where
  "distinct_prop P [] = True"
| "distinct_prop P (x # xs) = ((\<forall>y\<in>set xs. P x y) \<and> distinct_prop P xs)"

lemma distinct_prop_map:
  "distinct_prop P (map f xs)
    = distinct_prop (\<lambda>x y. P (f x) (f y)) xs"
  apply (induct xs)
   apply simp
  apply simp
  done

lemma distinct_prop_append:
  "distinct_prop P (xs @ ys) =
    (distinct_prop P xs \<and> distinct_prop P ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. P x y))"
  apply (induct xs arbitrary: ys)
   apply simp
  apply (simp add: conj_comms ball_Un)
  done

lemma distinct_prop_distinct:
  "\<lbrakk> distinct xs; \<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk>
     \<Longrightarrow> distinct_prop P xs"
  apply (induct xs)
   apply simp
  apply clarsimp
  apply blast
  done

lemma distinct_prop_True [simp]:
  "distinct_prop (\<lambda>x y. True) xs"
  by (induct xs, auto)

end


section "Memory-related theorems"

theory Memory
  imports BitByte
begin

context
  fixes dummy_type :: "'a::len"
begin

primrec read_bytes :: "('a word \<Rightarrow> 8 word) \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> 8word list"
  where "read_bytes m a 0   = []"
  | "read_bytes m a (Suc n) = m (a + of_nat n) # read_bytes m a n"

text \<open>Read bytes from memory. Memory is represented by a term of @{typ "64 word \<Rightarrow> 8 word"}.
      Given an address @{term [show_types] "a::64 word"} and a size @{term n}, retrieve the bytes in
      the order they are stored in memory.\<close>

definition region_addresses :: "'a word \<Rightarrow> nat \<Rightarrow> 'a word set"
  where "region_addresses a si \<equiv> {a' . \<exists> i < si . a' = a + of_nat (si - i - 1)}"

text \<open>The set of addresses belonging to a region starting at address @{term "a::64 word"} of @{term si} bytes.\<close>

definition region_overflow :: "'a word \<Rightarrow> nat \<Rightarrow> bool"
  where "region_overflow a si \<equiv> unat a + si \<ge> 2^LENGTH('a)"

text \<open>An overflow occurs if the address plus the size is greater equal @{term "2^64"}\<close>

definition enclosed :: "'a word \<Rightarrow> nat \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> bool"
  where "enclosed a' si' a si \<equiv> unat a + si < 2^LENGTH('a) \<and> unat a \<le> unat a' \<and> unat a' + si' \<le> unat a + si"

text \<open>A region is enclosed in another if its @{const region_addresses} is a subset of the other.\<close>

definition separate :: "'a word \<Rightarrow> nat \<Rightarrow> 'a word \<Rightarrow> nat \<Rightarrow> bool"
  where "separate a si a' si' \<equiv> si \<noteq>0 \<and> si' \<noteq> 0 \<and> region_addresses a si \<inter> region_addresses a' si' = {}"

text \<open>A region is separate from another if they do not overlap.\<close>

lemma region_addresses_iff: "a' \<in> region_addresses a si \<longleftrightarrow> unat (a' - a) < si"
  apply (auto simp add: region_addresses_def)
   apply (metis diff_Suc_less le_less_trans less_imp_Suc_add take_bit_nat_less_eq_self zero_less_Suc)
  by (smt (z3) add.commute add_Suc_right add_diff_cancel_left' diff_add_cancel less_add_Suc2 less_imp_Suc_add word_unat.Rep_inverse)

lemma notin_region_addresses:
  assumes "x \<notin> region_addresses a si"
  shows "unat x < unat a \<or> unat a + si \<le> unat x"
  by (metis assms add.commute less_diff_conv2 not_le_imp_less region_addresses_iff unat_sub_if')

lemma notin_region_addresses_sub:
  assumes "x \<notin> region_addresses a si"
  shows "unat (x - a') < unat (a - a') \<or> unat (a - a') + si \<le> unat (x - a')"
  using assms notin_region_addresses region_addresses_iff by auto

lemma region_addresses_eq_empty_iff: "region_addresses a si = {} \<longleftrightarrow> si = 0"
  by (metis region_addresses_iff add_diff_cancel_left' ex_in_conv neq0_conv not_less0 unsigned_0)

lemma length_read_bytes:
  shows "length (read_bytes m a si) = si"
  by (induct si,auto)

lemma nth_read_bytes:
assumes "n < si"
shows "read_bytes m a si ! n = m (a + of_nat (si - 1 - n))"
  using assms
  apply (induct si arbitrary: n,auto)
  subgoal for si n
    by(cases n,auto)
  done

text \<open>Writing to memory occurs via function @{const override_on}.
      In case of enclosure, reading bytes from memory overridden on a set of region addresses can
      be simplified to reading bytes from the overwritten memory only.
      In case of separation, reading bytes from overridden memory can be simplified to reading
      from the original memory.\<close>

lemma read_bytes_override_on_enclosed:
assumes "offset' \<le> offset"
    and "si' \<le> si"
    and "unat offset + si' \<le> si + unat offset'"
  shows "read_bytes (override_on m m' (region_addresses (a - offset) si)) (a - offset') si' = read_bytes m' (a - offset') si'"
proof-
  {
    fix i
    assume 1: "i < si'"
    let ?i = "(si + i + unat offset') - unat offset - si'"

    have "i + unat offset' < si' + unat offset"
      using 1 assms(1)
      by unat_arith
    hence 2: "si + i + unat offset' - (unat offset + si') < si"
      using diff_less[of "(si' + unat offset - i) - unat offset'" si] assms(3)
      by auto
    moreover
    have "of_nat (si' - Suc i) - offset' = of_nat (si - Suc ?i) - offset"
      using assms 1 2 by (auto simp add: of_nat_diff)
    ultimately
    have "\<exists> i' < si. of_nat (si' - Suc i) - offset' = of_nat (si - Suc i') - offset"
      by auto
  }
  note 1 = this
  show ?thesis
    apply (rule nth_equalityI)
    using 1
    by (auto simp add: length_read_bytes nth_read_bytes override_on_def region_addresses_def)
qed

lemmas read_bytes_override_on = read_bytes_override_on_enclosed[where offset=0 and offset'=0,simplified]

lemma read_bytes_override_on_enclosed_plus:
  assumes "unat offset + si' \<le> si"
      and "si \<le> 2^LENGTH('a)"
  shows "read_bytes (override_on m m' (region_addresses a si)) (offset+a) si' = read_bytes m' (offset+a) si'"
proof-
  {
    fix i
    have "i < si' \<Longrightarrow> \<exists> i' < si. offset + (of_nat (si' - Suc i)::'a word) = of_nat (si - Suc i')"
      apply (rule exI[of _"si - si' + i - unat offset"])
      using assms by (auto simp add: of_nat_diff)
  }
  note 1 = this
  show ?thesis
    apply (rule nth_equalityI)
    using assms 1
    by (auto simp add: override_on_def length_read_bytes nth_read_bytes region_addresses_def)
qed

lemma read_bytes_override_on_separate:
assumes "separate a si a' si'"
  shows "read_bytes (override_on m m' (region_addresses a si)) a' si' = read_bytes m a' si'"
  apply (rule nth_equalityI)
  using assms
  by (auto simp add: length_read_bytes nth_read_bytes override_on_def separate_def region_addresses_def)

text\<open>Bytes are are written to memory one-by-one, then read by @{const read_bytes} producing a list of bytes.
    That list is concatenated again using @{const word_rcat}. Writing @{term si} bytes of word @{term w} into
    memory, reading the byte-list and concatenating again produces @{term si} bytes of the original word.\<close>

lemma word_rcat_read_bytes_enclosed:
  fixes w :: "'b::len word"
  assumes "LENGTH('b) \<le> 2^LENGTH('a)"
    and "unat offset + si \<le> 2^LENGTH('a)"
  shows "word_rcat (read_bytes (\<lambda>a'. take_byte (unat (a' - a)) w) (a + offset) si) = \<langle>unat offset * 8,(unat offset + si) * 8\<rangle>w"
  apply (rule word_eqI)
  using assms
  apply (auto simp add: test_bit_rcat word_size length_read_bytes rev_nth nth_read_bytes unat_of_nat nth_takebyte unat_word_ariths )
    apply (auto simp add: take_byte_def nth_ucast nth_takebits take_bit_eq_mod split: if_split_asm)[1]
   apply (auto simp add: nth_takebits split: if_split_asm)[1]
  apply (auto simp add: take_byte_def nth_ucast nth_takebits split: if_split_asm)[1]
  by (auto simp add: rev_nth length_read_bytes take_byte_def nth_ucast nth_takebits nth_read_bytes unat_word_ariths unat_of_nat take_bit_eq_mod split: if_split_asm)

lemmas word_rcat_read_bytes = word_rcat_read_bytes_enclosed[where offset=0,simplified]

text \<open>The following theorems allow reasoning over enclosure and separation, for example as linear arithmetic.\<close>

lemma enclosed_spec:
  assumes enclosed: "enclosed a' si' a si"
      and x_in: "x \<in> region_addresses a' si'"
    shows "x \<in> region_addresses a si"
proof -
  from x_in have "unat (x - a') < si'"
    using region_addresses_iff by blast
  with enclosed have "unat (x - a) < si"
    unfolding enclosed_def by (auto simp add: unat_sub_if' split: if_split_asm)
  then show ?thesis
    using region_addresses_iff by blast
qed

lemma address_in_enclosed_region_as_linarith:
  assumes "enclosed a' si' a si"
      and "x \<in> region_addresses a' si'"
    shows "a \<le> x \<and> a' \<le> x \<and> x < a' + of_nat si' \<and> x < a + of_nat si"
  using assms
  by (auto simp add: enclosed_def region_addresses_def word_le_nat_alt word_less_nat_alt unat_of_nat unat_word_ariths unat_sub_if' take_bit_eq_mod)

lemma address_of_enclosed_region_ge:
  assumes "enclosed a' si' a si"
    shows "a' \<ge> a"
  using assms word_le_nat_alt
  by (auto simp add: enclosed_def)

lemma address_in_enclosed_region:
  assumes "enclosed a' si' a si"
      and "x \<in> region_addresses a' si'"
    shows "unat (x - a) \<ge> unat (a' - a) \<and> unat (a' - a) + si' > unat (x - a) \<and> unat (x - a) < si"
  by (smt (z3) address_in_enclosed_region_as_linarith add_diff_cancel_left' address_of_enclosed_region_ge assms(1) assms(2) diff_diff_add enclosed_spec le_iff_add nat_add_left_cancel_less region_addresses_iff unat_sub_if' word_le_minus_mono_left word_unat.Rep_inverse word_unat_less_le)

lemma enclosed_minus_minus:
  fixes a :: "'a word"
  assumes "offset \<ge> offset'"
      and "unat offset - si \<le> unat offset' - si'"
      and "unat offset' \<ge> si'"
      and "unat offset \<ge> si"
      and "a \<ge> offset"
    shows "enclosed (a - offset') si' (a - offset) si"
proof-
  have "unat offset' \<le> unat a"
    using assms(1,5)
    by unat_arith
  thus ?thesis
    using assms
    apply (auto simp add: enclosed_def unat_sub_if_size word_size)
    apply unat_arith
    using diff_le_mono2[of "unat offset - si" "unat offset' - si'" "unat a"]
    apply (auto simp add: enclosed_def unat_sub_if_size word_size)
     by unat_arith+
qed

lemma enclosed_plus:
  fixes a :: "'a word"
  assumes "si' < si"
      and "unat a + si < 2^LENGTH('a)"
    shows "enclosed a si' a si"
  using assms
  by (auto simp add: enclosed_def)

lemma separate_symm[symmetric]: "separate a si a' si' = separate a' si' a si"
  by (metis inf.commute separate_def)

lemma separate_iff: "separate a si a' si' \<longleftrightarrow> si > 0 \<and> si' > 0 \<and> unat (a' - a) \<ge> si \<and> unat (a - a') \<ge> si'"
proof
  assume assm: "separate a si a' si'"
  have "unat (a' - a) \<ge> si" if "separate a si a' si'" for a si a' si'
  proof (rule ccontr)
    assume "\<not> unat (a' - a) \<ge> si"
    then have "a' \<in> region_addresses a si"
      by (simp add: region_addresses_iff)
    moreover from that have "a' \<in> region_addresses a' si'"
      using region_addresses_iff separate_def by auto
    ultimately have "\<not>separate a si a' si'"
      by (meson disjoint_iff separate_def)
    with that show False
      by blast
  qed
  with assm have "unat (a' - a) \<ge> si" and "unat (a - a') \<ge> si'"
    using separate_symm by auto
  with assm show "si > 0 \<and> si' > 0 \<and> unat (a' - a) \<ge> si \<and> unat (a - a') \<ge> si'"
    using separate_def by auto
next
  assume assm: "si > 0 \<and> si' > 0 \<and> unat (a' - a) \<ge> si \<and> unat (a - a') \<ge> si'"
  then have "unat (x - a') \<ge> si'" if "unat (x - a) < si" for x
    using that apply (auto simp add: unat_sub_if' split: if_split_asm)
     apply (meson Nat.le_diff_conv2 add_increasing le_less_trans less_imp_le_nat unsigned_greater_eq unsigned_less)
    by (smt (z3) Nat.le_diff_conv2 add_leD2 le_less_trans linorder_not_less nat_le_linear unat_lt2p)
  then have "region_addresses a si \<inter> region_addresses a' si' = {}"
    by (simp add: region_addresses_iff disjoint_iff leD)
  with assm show "separate a si a' si'"
    by (simp add: separate_def)
qed

lemma separate_as_linarith:
assumes "\<not>region_overflow a si"
    and "\<not>region_overflow a' si'"
  shows "separate a si a' si' \<longleftrightarrow> 0 < si \<and> 0 < si' \<and> (a + of_nat si \<le> a' \<or> a' + of_nat si' \<le> a)"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs then show ?rhs
   by (meson separate_iff le_less le_plus not_le_imp_less word_of_nat_le)
next
  have *: "separate a si a' si'"
    if "si > 0" and "si' > 0" and "a + of_nat si \<le> a'"
      and "\<not>region_overflow a si" and "\<not>region_overflow a' si'"
    for a si a' si'
  proof -
    from that have "unat a + si < 2^LENGTH('a)" and "unat a' + si' < 2^LENGTH('a)"
      by (meson not_le region_overflow_def)+
    have "x < a + of_nat si" if "x \<in> region_addresses a si" for x
      by (smt (z3) Abs_fnat_hom_add \<open>unat a + si < 2 ^ LENGTH('a)\<close> add.commute dual_order.trans le_add1 less_diff_conv2 not_less region_addresses_iff that unat_of_nat_len unat_sub_if' word_less_iff_unsigned word_unat.Rep_inverse)
    moreover have "x \<ge> a'" if "x \<in> region_addresses a' si'" for x
      using address_in_enclosed_region_as_linarith enclosed_def \<open>unat a' + si' < 2 ^ LENGTH('a)\<close> that by blast
    ultimately show ?thesis
      using separate_def that by fastforce
  qed
  assume ?rhs then show ?lhs
    by (meson "*" assms separate_symm)
qed

text \<open>Compute separation in case the addresses and sizes are immediate values.\<close>
lemmas separate_as_linarith_numeral [simp] =
  separate_as_linarith [of "numeral a::'a word" "numeral si" "numeral a'::'a word" "numeral si'"] for a si a' si'
lemmas separate_as_linarith_numeral_1 [simp] =
  separate_as_linarith [of "numeral a::'a word" "numeral si" "numeral a'::'a word" "Suc 0"] for a si a'
lemmas separate_as_linarith_numeral1_ [simp] =
  separate_as_linarith [of "numeral a::'a word" "Suc 0" "numeral a'::'a word" "numeral si'"] for a a' si'
lemmas separate_as_linarith_numeral11 [simp] =
  separate_as_linarith [of "numeral a::'a word" "Suc 0" "numeral a'::'a word" "Suc 0"] for a a'
lemmas region_overflow_numeral[simp] =
  region_overflow_def [of "numeral a::'a word" "numeral si"] for a si
lemmas region_overflow_numeral1[simp] =
  region_overflow_def [of "numeral a::'a word" "Suc 0"] for a

lemma separate_plus_none:
  assumes "si' \<le> unat offset"
      and "0 < si"
      and "0 < si'"
      and "unat offset + si \<le> 2^LENGTH('a)"
    shows "separate (a + offset) si a si'"
  using assms apply (auto simp add: separate_iff)
  by (smt (z3) Nat.diff_diff_right add.commute add_leD1 diff_0 diff_is_0_eq diff_zero not_gr_zero unat_sub_if' unsigned_0)

lemma separate_plus_plus:
  assumes "unat offset + si \<le> unat offset' \<or> unat offset' + si' \<le> unat offset"
      and "0 < si"
      and "0 < si'"
      and "unat offset + si \<le> 2^LENGTH('a)"
      and "unat offset' + si' \<le> 2^LENGTH('a)"
  shows "separate (a + offset) si (a + offset') si'"
  using assms by (auto simp add: separate_iff unat_sub_if')

lemmas unat_minus = unat_sub_if'[of 0,simplified]

lemma separate_minus_minus':
  assumes "si \<noteq> 0"
      and "si' \<noteq> 0"
      and "unat offset \<ge> si"
      and "unat offset' \<ge> si'"
      and "unat offset - si \<ge> unat offset'"
    shows "separate (a - offset) si (a - offset') si'"
  using assms apply (auto simp add: separate_iff)
   apply (metis Nat.le_diff_conv2 add.commute add_leD2 unat_sub_if')
  by (smt (z3) add.commute add_diff_cancel_right' diff_add_cancel diff_le_self diff_less less_le_trans nat_le_linear not_le unat_sub_if')

lemma separate_minus_minus:
  assumes "si \<noteq> 0"
      and "si' \<noteq> 0"
      and "unat offset \<ge> si"
      and "unat offset' \<ge> si'"
      and "unat offset - si \<ge> unat offset' \<or> unat offset' - si' \<ge> unat offset"
    shows "separate (a - offset) si (a - offset') si'"
  by (meson assms separate_minus_minus' separate_symm)

lemma separate_minus_none:
  assumes "si \<noteq> 0"
      and "si' \<noteq> 0"
      and "unat offset \<ge> si"
      and "si' \<le> 2^LENGTH('a) - unat offset"
    shows "separate (a - offset) si a si'"
proof -
  have "0 < si" and "0 < si'"
    using assms(1,2) by blast+
  moreover have "\<not> offset \<le> 0"
    using assms(1) assms(3) by fastforce
  ultimately show ?thesis
    by (smt (z3) add_diff_cancel_left' assms(3,4) diff_diff_eq2 diff_zero le_add_diff_inverse less_or_eq_imp_le separate_iff unat_sub_if' unsigned_0 unsigned_less word_less_eq_iff_unsigned)
qed

lemma separate_plus_none2:
  fixes a :: "'a::len word"
  assumes "si \<le> 1"
      and "0 < si"
      and "0 < si'"
      and "1 + si' \<le> 2^LENGTH('a)"
    shows "separate a si (1 + a) si'"
  using assms by (auto simp add: separate_iff unat_minus)

lemma separate_plus_none3:
  fixes a :: "'a::len word"
  assumes "si \<le> 1"
      and "0 < si"
      and "0 < si'"
      and "1 + si' \<le> 2^LENGTH('a)"
    shows "separate (1 + a) si' a si"
  using assms by (auto simp add: separate_iff unat_minus)

lemma separate_plus_none4:
  fixes a :: "'a::len word"
  assumes "si' \<le> unat offset"
      and "0 < si"
      and "0 < si'"
      and "unat offset + si \<le> 2^LENGTH('a)"
    shows "separate a si' (a + offset) si"
  using assms apply (auto simp add: separate_iff)
  by (smt (z3) Nat.diff_diff_right add.commute add_leD1 diff_0 diff_is_0_eq diff_zero not_gr_zero unat_sub_if' unsigned_0)

text \<open>The following theorems are used during symbolic execution to determine whether two regions are separate.\<close>

named_theorems separate_simps
declare separate_plus_none [separate_simps]
declare separate_plus_plus[separate_simps]
declare separate_minus_none [separate_simps]
declare separate_minus_minus [separate_simps]
declare separate_plus_none2 [separate_simps]
declare separate_plus_none3 [separate_simps]
declare separate_plus_none4 [separate_simps]

end
end


header{* Syntax of Terms and Clauses *}
theory TermsAndClauses
imports Preliminaries
begin

text
{* These are used for both unsorted and many-sorted FOL, the difference being that,
for the latter, the signature will fix a variable typing. *}

text{* Terms: *}

datatype 'fsym trm =
  Var var |
  Fn 'fsym "'fsym trm list"

text{* Atomic formulas (atoms): *}

datatype ('fsym, 'psym) atm =
  Eq "'fsym trm" "'fsym trm" |
  Pr 'psym "'fsym trm list"

text{* Literals: *}

datatype ('fsym, 'psym) lit =
  Pos "('fsym, 'psym) atm" |
  Neg "('fsym, 'psym) atm"

text{* Clauses: *}

type_synonym ('fsym, 'psym) cls = "('fsym, 'psym) lit list"

text{* Problems: *}

type_synonym ('fsym, 'psym) prob = "('fsym, 'psym) cls set"

lemma trm_induct[case_names Var Fn, induct type: trm]:
assumes "\<And> x. \<phi> (Var x)"
and "\<And> f Tl. list_all \<phi> Tl \<Longrightarrow> \<phi> (Fn f Tl)"
shows "\<phi> T"
using assms unfolding list_all_iff by (rule trm.induct) metis

fun vars where
"vars (Var x) = {x}"
|
"vars (Fn f Tl) = \<Union> (vars ` (set Tl))"

fun varsA where
"varsA (Eq T1 T2) = vars T1 \<union> vars T2"
|
"varsA (Pr p Tl) = \<Union> set (map vars Tl)"

fun varsL where
"varsL (Pos at) = varsA at"
|
"varsL (Neg at) = varsA at"

definition "varsC c = \<Union> set (map varsL c)"

definition "varsPB \<Phi> = \<Union> {varsC c | c. c \<in> \<Phi>}"

text{* Substitution: *}

fun subst where
"subst \<pi> (Var x) = \<pi> x"
|
"subst \<pi> (Fn f Tl) = Fn f (map (subst \<pi>) Tl)"

fun substA where
"substA \<pi> (Eq T1 T2) = Eq (subst \<pi> T1) (subst \<pi> T2)"
|
"substA \<pi> (Pr p Tl) = Pr p (map (subst \<pi>) Tl)"

fun substL where
"substL \<pi> (Pos at) = Pos (substA \<pi> at)"
|
"substL \<pi> (Neg at) = Neg (substA \<pi> at)"

definition "substC \<pi> c = map (substL \<pi>) c"

definition "substPB \<pi> \<Phi> = {substC \<pi> c | c. c \<in> \<Phi>}"

lemma subst_cong:
assumes "\<And> x. x \<in> vars T \<Longrightarrow> \<pi>1 x = \<pi>2 x"
shows "subst \<pi>1 T = subst \<pi>2 T"
using assms by (induct T, auto simp add: list_all_iff)

lemma substA_congA:
assumes "\<And> x. x \<in> varsA at \<Longrightarrow> \<pi>1 x = \<pi>2 x"
shows "substA \<pi>1 at = substA \<pi>2 at"
using assms subst_cong[of _ \<pi>1 \<pi>2]
by (cases at, fastforce+)

lemma substL_congL:
assumes "\<And> x. x \<in> varsL l \<Longrightarrow> \<pi>1 x = \<pi>2 x"
shows "substL \<pi>1 l = substL \<pi>2 l"
using assms substA_congA[of _ \<pi>1 \<pi>2] by (cases l, auto)

lemma substC_congC:
assumes "\<And> x. x \<in> varsC c \<Longrightarrow> \<pi>1 x = \<pi>2 x"
shows "substC \<pi>1 c = substC \<pi>2 c"
using substL_congL[of _ \<pi>1 \<pi>2] assms unfolding substC_def varsC_def
by (induct c, auto)

lemma substPB_congPB:
assumes "\<And> x. x \<in> varsPB \<Phi> \<Longrightarrow> \<pi>1 x = \<pi>2 x"
shows "substPB \<pi>1 \<Phi> = substPB \<pi>2 \<Phi>"
using substC_congC[of _ \<pi>1 \<pi>2] assms unfolding substPB_def varsPB_def
by simp_all (metis (lifting) substC_congC)

lemma vars_subst:
"vars (subst \<pi> T) = (\<Union> x \<in> vars T. vars (\<pi> x))"
by (induct T) (auto simp add: list_all_iff)

lemma varsA_substA:
"varsA (substA \<pi> at) = (\<Union> x \<in> varsA at. vars (\<pi> x))"
using vars_subst[of \<pi>] by (cases at, auto)

lemma varsL_substL:
"varsL (substL \<pi> l) = (\<Union> x \<in> varsL l. vars (\<pi> x))"
using varsA_substA[of \<pi>] by (cases l, auto)

lemma varsC_substC:
"varsC (substC \<pi> c) = (\<Union> x \<in> varsC c. vars (\<pi> x))"
apply(induct c) unfolding substC_def varsC_def
  apply fastforce
  unfolding substC_def varsC_def map_map set_map
  unfolding comp_def varsL_substL by blast

lemma varsPB_Un[simp]: "varsPB (\<Phi>1 \<union> \<Phi>2) = varsPB \<Phi>1 \<union> varsPB \<Phi>2"
unfolding varsPB_def by auto

lemma varsC_append[simp]: "varsC (c1 @ c2) = varsC c1 \<union> varsC c2"
unfolding varsC_def by auto

lemma varsPB_sappend[simp]:
assumes 1: "\<Phi>1 \<noteq> {}" and 2: "\<Phi>2 \<noteq> {}"
shows "varsPB (\<Phi>1 @@ \<Phi>2) = varsPB \<Phi>1 \<union> varsPB \<Phi>2"
proof safe
  fix x
  {assume "x \<in> varsPB \<Phi>1"
   then obtain c1 c2 where "x \<in> varsC c1" and "c1 \<in> \<Phi>1" and "c2 \<in> \<Phi>2"
   using 2 unfolding varsPB_def by auto
   thus "x \<in> varsPB (\<Phi>1 @@ \<Phi>2)" unfolding sappend_def varsPB_def by fastforce
  }
  {assume "x \<in> varsPB \<Phi>2"
   then obtain c1 c2 where "x \<in> varsC c2" and "c1 \<in> \<Phi>1" and "c2 \<in> \<Phi>2"
   using 1 unfolding varsPB_def by auto
   thus "x \<in> varsPB (\<Phi>1 @@ \<Phi>2)" unfolding sappend_def varsPB_def by fastforce
  }
qed(unfold varsPB_def sappend_def, fastforce)

lemma varsPB_substPB:
"varsPB (substPB \<pi> \<Phi>) = (\<Union> x \<in> varsPB \<Phi>. vars (\<pi> x))" (is "_ = ?K")
proof safe
  fix x assume "x \<in> varsPB (substPB \<pi> \<Phi>)"
  then obtain c where "c \<in> \<Phi>" and "x \<in> varsC (substC \<pi> c)"
  unfolding varsPB_def substPB_def by auto
  thus "x \<in> ?K" unfolding varsC_substC varsPB_def by auto
next
  fix x y assume "y \<in> varsPB \<Phi>" and x: "x \<in> vars (\<pi> y)"
  then obtain c where c: "c \<in> \<Phi>" and "y \<in> varsC c" unfolding varsPB_def by auto
  hence "x \<in> varsC (substC \<pi> c)" using x unfolding varsC_substC by auto
  thus "x \<in> varsPB (substPB \<pi> \<Phi>)" using c unfolding varsPB_def substPB_def by auto
qed

lemma subst_o:
"subst (subst \<pi>1 o \<pi>2) T = subst \<pi>1 (subst \<pi>2 T)"
apply(induct T) by (auto simp add: list_all_iff)

lemma o_subst:
"subst \<pi>1 o subst \<pi>2 = subst (subst \<pi>1 o \<pi>2)"
apply(rule ext) apply(subst comp_def) unfolding subst_o[symmetric] ..

lemma substA_o:
"substA (subst \<pi>1 o \<pi>2) at = substA \<pi>1 (substA \<pi>2 at)"
using subst_o[of \<pi>1 \<pi>2] by (cases at, auto)

lemma o_substA:
"substA \<pi>1 o substA \<pi>2 = substA (subst \<pi>1 o \<pi>2)"
apply(rule ext) apply(subst comp_def) unfolding substA_o[symmetric] ..

lemma substL_o:
"substL (subst \<pi>1 o \<pi>2) l = substL \<pi>1 (substL \<pi>2 l)"
using substA_o[of \<pi>1 \<pi>2] by (cases l, auto)

lemma o_substL:
"substL \<pi>1 o substL \<pi>2 = substL (subst \<pi>1 o \<pi>2)"
apply(rule ext) apply(subst comp_def) unfolding substL_o[symmetric] ..

lemma substC_o:
"substC (subst \<pi>1 o \<pi>2) c = substC \<pi>1 (substC \<pi>2 c)"
using substL_o[of \<pi>1 \<pi>2] unfolding substC_def by (induct c, auto)

lemma o_substC:
"substC \<pi>1 o substC \<pi>2 = substC (subst \<pi>1 o \<pi>2)"
apply(rule ext) apply(subst comp_def) unfolding substC_o[symmetric] ..

lemma substPB_o:
"substPB (subst \<pi>1 o \<pi>2) \<Phi> = substPB \<pi>1 (substPB \<pi>2 \<Phi>)"
using substC_o[of \<pi>1 \<pi>2] unfolding substPB_def by auto

lemma o_substPB:
"substPB \<pi>1 o substPB \<pi>2 = substPB (subst \<pi>1 o \<pi>2)"
apply(rule ext) apply(subst comp_def) unfolding substPB_o[symmetric] ..

lemma finite_vars: "finite (vars T)"
by(induct T, auto simp add: list_all_iff)

lemma finite_varsA: "finite (varsA at)"
using finite_vars by (cases at, auto)

lemma finite_varsL: "finite (varsL l)"
using finite_varsA by (cases l, auto)

lemma finite_varsC: "finite (varsC c)"
using finite_varsL unfolding varsC_def by (induct c, auto)

lemma finite_varsPB: "finite \<Phi> \<Longrightarrow> finite (varsPB \<Phi>)"
using finite_varsC unfolding varsPB_def by (auto intro!: finite_Union)

end


theory Quantale_Sup
  imports Abstract_Quantales
begin

no_notation
  times (infixl "*" 70) and
  plus (infixl "+" 65)

notation
  sup (infixl "+" 65) and
  inf (infixl "\<sqinter>" 70) and
  Sup ("\<Squnion>_" [900] 900) and
  Inf ("\<Sqinter>_" [900] 900) and
  top ("\<top>") and
  bot ("\<bottom>") and
  times (infixl "\<cdot>" 70)

sublocale complete_lattice \<subseteq> Sup!: abs_complete_lattice Sup
  where [simp]: "abs_complete_lattice.join Sup = op +"
    and [simp]: "abs_complete_lattice.less_eq Sup = op \<le>"
    and [simp]: "abs_complete_lattice.less Sup = op <"
    and [simp]: "abs_complete_lattice.Meet Sup = Inf"
    and [simp]: "abs_complete_lattice.meet Sup = op \<sqinter>"
    and [simp]: "abs_complete_lattice.top Sup = \<top>"
    and [simp]: "abs_complete_lattice.bot Sup = \<bottom>"
proof -
  show "abs_complete_lattice Sup"
    apply unfold_locales
    apply (metis Sup_atLeastAtMost atLeastAtMost_singleton order_refl)
    apply (auto simp: Sup_le_iff intro!: Sup_eqI Sup_least)
    apply (metis (no_types) Sup_upper UnionI)
    by (metis Sup_least le_iff_sup sup.orderE)
  then interpret cl: abs_complete_lattice Sup .
  show "cl.join = op +"
    by (default, default) (simp add: cl.join_def)
  show [simp]: "cl.less_eq = op \<le>"
    apply (default, default)
    by (auto simp add: cl.less_eq_def cl.join_def le_iff_sup)
  show "cl.less = op <"
    apply (default, default)
    by (auto simp add: less_le_not_le cl.less_def)
  show [simp]: "cl.Meet = Inf"
    by default (auto simp add: cl.Meet_def Inf_Sup)
  show "cl.meet = op \<sqinter>"
    by (default, default) (simp add: cl.meet_def)
  show "cl.top = \<top>"
    by (simp add: cl.top_def)
  show "cl.bot = \<bottom>"
    by (simp add: cl.bot_def)
qed

class near_quantale_Sup = complete_lattice + semigroup_mult +
  assumes qSup_distr: "\<Squnion> Y \<cdot> x = \<Squnion> ((\<lambda>y. y \<cdot> x) ` Y)"

class near_quantale_Sup_unital = near_quantale_Sup + monoid_mult

class pre_quantale_Sup = near_quantale_Sup +
  assumes qSup_subdistl: "\<Squnion> ((\<lambda>y. x \<cdot> y) ` Y) \<le> x \<cdot> \<Squnion> Y"

class quantale_Sup = pre_quantale_Sup +
  assumes qSup_supdistl: "x \<cdot> \<Squnion> Y \<le> \<Squnion> ((\<lambda>y. x \<cdot> y) ` Y)"

class quantale_Sup_unital = quantale_Sup + monoid_mult

(* Instantiation of quantales *)

sublocale near_quantale_Sup \<subseteq> Sup!: near_quantale Sup "op \<cdot>"
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  by (unfold_locales, auto) (metis qSup_distr Sup_image_eq)

sublocale near_quantale_Sup_unital \<subseteq> Sup!: near_quantale_unital Sup "op \<cdot>" one
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  by unfold_locales auto

sublocale pre_quantale_Sup \<subseteq> Sup!: pre_quantale Sup "op \<cdot>"
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  apply unfold_locales
  apply (auto intro: Sup_eqI Sup_least)
  by (metis Sup.Sup_image_eq local.Sup.less_eq_def local.qSup_subdistl)

sublocale quantale_Sup \<subseteq> Sup!: quantale Sup "op \<cdot>"
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  apply unfold_locales
  apply (auto intro: Sup_eqI Sup_least)
  by (metis qSup_supdistl le_iff_sup sup_commute Sup.Sup_image_eq)

sublocale quantale_Sup_unital \<subseteq> Sup!: quantale_unital Sup "op \<cdot>" one
  where "abs_complete_lattice.join Sup = op +"
    and "abs_complete_lattice.less_eq Sup = op \<le>"
    and "abs_complete_lattice.less Sup = op <"
    and "abs_complete_lattice.Meet Sup = Inf"
    and "abs_complete_lattice.meet Sup = op \<sqinter>"
    and "abs_complete_lattice.top Sup = \<top>"
    and "abs_complete_lattice.bot Sup = \<bottom>"
  by unfold_locales auto

context near_quantale_Sup begin

lemma qSUP_distr: "(SUP y:Y. f y) \<cdot> x = (SUP y: Y. f y \<cdot> x)"
  by (unfold SUP_def qSup_distr image_image) simp

end

context quantale_Sup begin

lemma qSUP_distl: "x \<cdot> (SUP y:Y. f y) = (SUP y: Y. x \<cdot> f y)"
  by (unfold SUP_def Sup.Join_distl image_image) simp

lemma qSUP_merge_ineq: "\<Squnion> {f x \<cdot> g y | x y. P x \<and> Q y} \<le> \<Squnion> {\<Squnion> {f x \<cdot> g y | x. P x} | y. Q y}"
proof (rule Sup_least, auto)
  fix xa y assume "P xa" "Q y"
  hence "\<exists>u. (\<exists>x. f xa \<cdot> g y = f x \<cdot> g u \<and> P x) \<and> Q u" by blast
  hence "\<exists>u. Q u \<and> f xa \<cdot> g y \<in> {f x \<cdot> g u |x. P x}" by blast
  hence "\<exists>B. (\<exists>y. \<Squnion>B = \<Squnion>{f x \<cdot> g y |x. P x} \<and> Q y) \<and> f xa \<cdot> g y \<in> B" by blast
  hence "\<exists>B. \<Squnion>B \<le> \<Squnion>{\<Squnion>{f x \<cdot> g y |x. P x} |y. Q y} \<and> f xa \<cdot> g y \<in> B"
    using Sup.Join_Collect_upper by (metis (lifting, mono_tags))
  thus "f xa \<cdot> g y \<le> \<Squnion>{\<Squnion>{f x \<cdot> g y |x. P x} |y. Q y}"
    using Sup_le_iff by blast
qed

lemma qSUP_merge: "\<Squnion> {\<Squnion> {f x \<cdot> g y | x. P x} | y. Q y} = \<Squnion> {f x \<cdot> g y | x y. P x \<and> Q y}"
  apply (rule antisym, rule Sup_least, safe)
  by (rule Sup_mono, auto simp add: qSUP_merge_ineq)

lemma Sup_sum_le1: "\<Squnion> {f a b + g a b | a b. P a b} \<le> \<Squnion>{f a b | a b. P a b} + \<Squnion>{g a b | a b. P a b}"
proof (rule Sup_least, safe)
  fix a b assume assm: "P a b"
  have "f a b \<le> \<Squnion>{f a b | a b. P a b}" and "g a b \<le> \<Squnion>{g a b | a b. P a b}"
    apply (rule Sup_upper) using assm apply blast
    apply (rule Sup_upper) using assm by blast
  thus "f a b + g a b \<le> \<Squnion>{f a b |a b. P a b} + \<Squnion>{g a b |a b. P a b}"
    by (metis (lifting, no_types) sup_mono)
qed

lemma Sup_sum_le2: "\<Squnion>{f a b | a b. P a b} + \<Squnion>{g a b | a b. P a b} \<le> \<Squnion> {f a b + g a b | a b. P a b}"
proof (subst Sup_union_distrib[symmetric], rule Sup_least, auto)
  fix a b assume assm: "P a b"
  have "f a b + g a b \<le> \<Squnion> {f a b + g a b | a b. P a b}"
    apply (rule Sup_upper) using assm by blast
  thus "f a b \<le> \<Squnion> {f a b + g a b | a b. P a b}" and "g a b \<le> \<Squnion> {f a b + g a b | a b. P a b}"
    by auto
qed

lemma Sup_sum [iff]: "\<Squnion> {f a b + g a b | a b. P a b} = \<Squnion>{f a b | a b. P a b} + \<Squnion>{g a b | a b. P a b}"
  by (rule antisym) (metis Sup_sum_le1, metis Sup_sum_le2)

lemma Sup_sum_same_set[iff]:" \<Squnion> {a + b | a b. a \<in> A \<and> b \<in> A} = \<Squnion>A + \<Squnion>A"
proof -
  have "\<Squnion> {a + b | a b. a \<in> A \<and> b \<in> A} = \<Squnion>{a | a b. a \<in> A \<and> b \<in> A} + \<Squnion>{b | a b. a \<in> A \<and> b \<in> A}"
    by simp
  also have "... = \<Squnion>A + \<Squnion>A"
    by (rule antisym) (rule sup.mono, (rule Sup_subset_mono, force)+)+
  finally show ?thesis .
qed

end

class comm_quantale_Sup = quantale_Sup + ab_semigroup_mult
class comm_quantale_Sup_unital = comm_quantale_Sup + comm_monoid_mult
begin
subclass quantale_Sup_unital ..
end
class distrib_quantale_Sup = quantale_Sup + complete_distrib_lattice
class distrib_quantale_Sup_unital = distrib_quantale_Sup + quantale_Sup_unital
class distrib_comm_quantale_Sup = comm_quantale_Sup + distrib_quantale_Sup
class distrib_comm_quantale_Sup_unital = comm_quantale_Sup_unital + distrib_quantale_Sup

end


(*  Title:      CTT/Bool.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>The two-element type (booleans and conditionals)\<close>

theory Bool
  imports CTT
begin

definition Bool :: "t"
  where "Bool \<equiv> T+T"

definition true :: "i"
  where "true \<equiv> inl(tt)"

definition false :: "i"
  where "false \<equiv> inr(tt)"

definition cond :: "[i,i,i]\<Rightarrow>i"
  where "cond(a,b,c) \<equiv> when(a, \<lambda>u. b, \<lambda>u. c)"

lemmas bool_defs = Bool_def true_def false_def cond_def

subsection \<open>Derivation of rules for the type \<open>Bool\<close>\<close>

text \<open>Formation rule.\<close>
lemma boolF: "Bool type"
  unfolding bool_defs by typechk

text \<open>Introduction rules for \<open>true\<close>, \<open>false\<close>.\<close>

lemma boolI_true: "true : Bool"
  unfolding bool_defs by typechk

lemma boolI_false: "false : Bool"
  unfolding bool_defs by typechk

text \<open>Elimination rule: typing of \<open>cond\<close>.\<close>
lemma boolE: "\<lbrakk>p:Bool; a : C(true); b : C(false)\<rbrakk> \<Longrightarrow> cond(p,a,b) : C(p)"
  unfolding bool_defs
  apply (typechk; erule TE)
   apply typechk
  done

lemma boolEL: "\<lbrakk>p = q : Bool; a = c : C(true); b = d : C(false)\<rbrakk>
  \<Longrightarrow> cond(p,a,b) = cond(q,c,d) : C(p)"
  unfolding bool_defs
  apply (rule PlusEL)
    apply (erule asm_rl refl_elem [THEN TEL])+
  done

text \<open>Computation rules for \<open>true\<close>, \<open>false\<close>.\<close>

lemma boolC_true: "\<lbrakk>a : C(true); b : C(false)\<rbrakk> \<Longrightarrow> cond(true,a,b) = a : C(true)"
  unfolding bool_defs
  apply (rule comp_rls)
    apply typechk
   apply (erule_tac [!] TE)
   apply typechk
  done

lemma boolC_false: "\<lbrakk>a : C(true); b : C(false)\<rbrakk> \<Longrightarrow> cond(false,a,b) = b : C(false)"
  unfolding bool_defs
  apply (rule comp_rls)
    apply typechk
   apply (erule_tac [!] TE)
   apply typechk
  done

end