section\<open>Predicates and relations\<close>

theory Relations
imports Var
begin
default_sort type

text \<open>Unifying Theories of Programming (UTP) is a semantic framework based on
an alphabetized relational calculus. An alphabetized predicate is a pair (alphabet, predicate)
where the free variables appearing in the predicate are all in the alphabet.\<close>

text \<open>An alphabetized relation is an alphabetized predicate where the alphabet is
composed of input (undecorated) and output (dashed) variables. In this case the
predicate describes a relation between input and output variables.\<close>

subsection\<open>Definitions\<close>

text \<open>In this section, the definitions of predicates, relations and
standard operators are given.\<close>

type_synonym '\<alpha> "alphabet"  = "'\<alpha>"
type_synonym '\<alpha> predicate = "'\<alpha> alphabet \<Rightarrow> bool"

definition  true::"'\<alpha> predicate"
where "true \<equiv> \<lambda>A. True"

definition  false::"'\<alpha> predicate"
where "false \<equiv> \<lambda>A. False"

definition  not::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate" ("\<not> _" [40] 40)
where "\<not> P  \<equiv> \<lambda>A. \<not> (P A)"

definition  conj::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<and>" 35)
where "P \<and> Q \<equiv> \<lambda>A. P A \<and> Q A"

definition disj::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<or>" 30)
where "P \<or> Q \<equiv> \<lambda>A. P A \<or> Q A"

definition impl::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<longrightarrow>" 25)
where "P \<longrightarrow> Q \<equiv> \<lambda>A. P A \<longrightarrow> Q A"

definition iff::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<longleftrightarrow>" 25)
where "P \<longleftrightarrow> Q \<equiv> \<lambda>A. P A \<longleftrightarrow> Q A"

definition ex::"['\<beta> \<Rightarrow>'\<alpha> predicate] \<Rightarrow> '\<alpha> predicate" (binder "\<^bold>\<exists>" 10)
where "\<^bold>\<exists>x. P x \<equiv> \<lambda>A. \<exists> x. (P x) A"

definition all::"['\<beta> \<Rightarrow>'\<alpha> predicate] \<Rightarrow> '\<alpha> predicate" (binder "\<^bold>\<forall>" 10)
where "\<^bold>\<forall>x. P x \<equiv> \<lambda> A. \<forall>x. (P x) A"

type_synonym '\<alpha> condition = "('\<alpha> \<times> '\<alpha>) \<Rightarrow> bool"
type_synonym '\<alpha> relation  = "('\<alpha> \<times> '\<alpha>) \<Rightarrow> bool"

definition cond::"'\<alpha> relation \<Rightarrow> '\<alpha> condition \<Rightarrow> '\<alpha> relation \<Rightarrow> '\<alpha> relation"
                                                          ("(3_ \<triangleleft> _ \<triangleright> / _)" [14,0,15] 14)
where " (P \<triangleleft> b \<triangleright> Q) \<equiv> (b \<and> P) \<or> ((\<not> b) \<and> Q)"

definition comp::"(('\<alpha> \<times> '\<beta>) \<Rightarrow> bool) \<Rightarrow> (('\<beta> \<times> '\<gamma>) \<Rightarrow> bool) \<Rightarrow> ('\<alpha> \<times> '\<gamma>) \<Rightarrow> bool"
                                                                          (infixr ";;" 25)
where "P ;; Q \<equiv> \<lambda>r. r : ({p. P p} O {q. Q q})"

definition Assign::"('a, 'b) var \<Rightarrow> 'a \<Rightarrow> 'b relation"
  where "Assign x a \<equiv> \<lambda>(A, A'). A' = (assign x a) A"

syntax
  "_assignment" :: "id \<Rightarrow> 'a \<Rightarrow> 'b relation"  ("_ :== _")
translations
  "y :== vv"   => "CONST Assign (VAR y) vv"

abbreviation (input) closure::"'\<alpha> predicate \<Rightarrow> bool" ("[_]")
where "[ P ] \<equiv> \<forall> A. P A"

abbreviation (input) ndet::"'\<alpha> relation \<Rightarrow> '\<alpha> relation \<Rightarrow> '\<alpha> relation" ("(_ \<sqinter> _)")
where "P \<sqinter> Q \<equiv> P \<or> Q"

abbreviation (input) join::"'\<alpha> relation \<Rightarrow> '\<alpha> relation \<Rightarrow> '\<alpha> relation" ("(_ \<squnion> _)")
where "P \<squnion> Q \<equiv> P \<and> Q"

abbreviation (input) ndetS::"'\<alpha> relation set \<Rightarrow> '\<alpha> relation" ("(\<Sqinter> _)")
where "\<Sqinter> S \<equiv> \<lambda>A. A \<in> \<Union>{{p. P p} | P. P \<in> S}"

abbreviation (input) conjS::"'\<alpha> relation set \<Rightarrow> '\<alpha> relation" ("(\<Squnion> _)")
where "\<Squnion> S \<equiv> \<lambda>A. A \<in> \<Inter>{{p. P p} | P. P \<in> S}"

abbreviation (input) skip_r::"'\<alpha> relation" ("\<Pi>r")
where "\<Pi>r \<equiv> \<lambda> (A, A') . A = A'"

abbreviation (input) Bot::"'\<alpha> relation"
where "Bot \<equiv> true"

abbreviation (input) Top::"'\<alpha> relation"
where "Top \<equiv> false"

lemmas utp_defs = true_def false_def conj_def disj_def not_def impl_def iff_def
                  ex_def all_def cond_def comp_def Assign_def

subsection \<open>Proofs\<close>

text \<open>All useful proved lemmas over predicates and relations are presented here.
First, we introduce the most important lemmas that will be used by automatic tools to simplify
proofs. In the second part, other lemmas are proved using these basic ones.\<close>

subsubsection \<open>Setup of automated tools\<close>

lemma true_intro: "true x" by (simp add: utp_defs)
lemma false_elim: "false x \<Longrightarrow> C" by (simp add: utp_defs)

lemma not_intro: "(P x \<Longrightarrow> false x) \<Longrightarrow> (\<not> P) x" by (auto simp add: utp_defs)
lemma not_elim: "(\<not> P) x \<Longrightarrow> P x \<Longrightarrow> C" by (auto simp add: utp_defs)
lemma not_dest: "(\<not> P) x \<Longrightarrow> \<not> P x" by (auto simp add: utp_defs)

lemma conj_intro: "P x \<Longrightarrow> Q x \<Longrightarrow> (P \<and> Q) x" by (auto simp add: utp_defs)
lemma conj_elim: "(P \<and> Q) x \<Longrightarrow> (P x \<Longrightarrow> Q x \<Longrightarrow> C) \<Longrightarrow> C" by (auto simp add: utp_defs)

lemma disj_introC: "(\<not> Q x \<Longrightarrow> P x) \<Longrightarrow> (P \<or> Q) x" by (auto simp add: utp_defs)
lemma disj_elim: "(P \<or> Q) x \<Longrightarrow> (P x \<Longrightarrow> C) \<Longrightarrow> (Q x \<Longrightarrow> C) \<Longrightarrow> C" by (auto simp add: utp_defs)

lemma impl_intro: "(P x \<Longrightarrow> Q x) \<Longrightarrow> (P \<longrightarrow> Q) x" by (auto simp add: utp_defs)
lemma impl_elimC: "(P \<longrightarrow> Q) x \<Longrightarrow> (\<not> P x \<Longrightarrow> R) \<Longrightarrow> (Q x \<Longrightarrow> R) \<Longrightarrow> R " by (auto simp add: utp_defs)

lemma iff_intro: "(P x \<Longrightarrow> Q x) \<Longrightarrow> (Q x \<Longrightarrow> P x) \<Longrightarrow> (P \<longleftrightarrow> Q) x" by (auto simp add: utp_defs)
lemma iff_elimC:
"(P \<longleftrightarrow> Q) x \<Longrightarrow> (P x \<Longrightarrow> Q x \<Longrightarrow> R) \<Longrightarrow> (\<not> P x \<Longrightarrow> \<not> Q x \<Longrightarrow> R) \<Longrightarrow> R" by (auto simp add: utp_defs)

lemma all_intro: "(\<And>a. P a x) \<Longrightarrow> (\<^bold>\<forall>a. P a) x" by (auto simp add: utp_defs)
lemma all_elim: "(\<^bold>\<forall>a. P a) x \<Longrightarrow> (P a x \<Longrightarrow> R) \<Longrightarrow> R" by (auto simp add: utp_defs)

lemma ex_intro: "P a x \<Longrightarrow> (\<^bold>\<exists>a. P a) x" by (auto simp add: utp_defs)
lemma ex_elim: "(\<^bold>\<exists>a. P a) x \<Longrightarrow> (\<And>a. P a x \<Longrightarrow> Q) \<Longrightarrow> Q" by (auto simp add: utp_defs)

lemma comp_intro: "P (a, b) \<Longrightarrow> Q (b, c) \<Longrightarrow> (P ;; Q) (a, c)"
  by (auto simp add: comp_def)

lemma comp_elim:
"(P ;; Q) ac \<Longrightarrow> (\<And>a b c. ac = (a, c) \<Longrightarrow> P (a, b) \<Longrightarrow> Q (b, c) \<Longrightarrow> C) \<Longrightarrow> C"
  by (auto simp add: comp_def)

declare not_def [simp]

declare iff_intro [intro!]
  and not_intro [intro!]
  and impl_intro [intro!]
  and disj_introC [intro!]
  and conj_intro [intro!]
  and true_intro [intro!]
  and comp_intro [intro]

declare not_dest [dest!]
  and iff_elimC [elim!]
  and false_elim [elim!]
  and impl_elimC [elim!]
  and disj_elim [elim!]
  and conj_elim [elim!]
  and comp_elim [elim!]
  and true_elim [elim!]

declare all_intro [intro!] and ex_intro [intro]
declare ex_elim [elim!] and all_elim [elim]

lemmas relation_rules = iff_intro not_intro impl_intro disj_introC conj_intro true_intro
                        comp_intro not_dest iff_elimC false_elim impl_elimC all_elim
                        disj_elim conj_elim comp_elim all_intro ex_intro ex_elim

lemma split_cond:
"A ((P \<triangleleft> b \<triangleright> Q) x) = ((b x \<longrightarrow> A (P x)) \<and> (\<not> b x \<longrightarrow> A (Q x)))"
  by (cases "b x") (auto simp add: utp_defs)

lemma split_cond_asm:
"A ((P \<triangleleft> b \<triangleright> Q) x) = (\<not> ((b x \<and> \<not> A (P x)) \<or> (\<not> b x \<and> \<not> A (Q x))))"
  by (cases "b x") (auto simp add: utp_defs)

lemmas cond_splits = split_cond split_cond_asm

subsubsection \<open>Misc lemmas\<close>

lemma cond_idem:"(P \<triangleleft> b \<triangleright> P) = P"
  by (rule ext) (auto split: cond_splits)

lemma cond_symm:"(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft> \<not> b \<triangleright> P)"
  by (rule ext) (auto split: cond_splits)

lemma cond_assoc: "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_unit_T:"(P \<triangleleft> true \<triangleright> Q) = P"
  by (rule ext) (auto split: cond_splits)

lemma cond_unit_F:"(P \<triangleleft> false \<triangleright> Q) = Q"
  by (rule ext) (auto split: cond_splits)

lemma cond_L6: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)"
  by (rule ext) (auto split: cond_splits)

lemma cond_L7: "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)"
  by (rule ext) (auto split: cond_splits)

lemma cond_and_distr: "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))"
  by (rule ext) (auto split: cond_splits)

lemma cond_imp_distr:
"((P \<longrightarrow> Q) \<triangleleft> b \<triangleright> (R \<longrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<longrightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by (rule ext) (auto split: cond_splits)

lemma cond_eq_distr:
"((P \<longleftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<longleftrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<longleftrightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by (rule ext) (auto split: cond_splits)

lemma comp_assoc: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)"
  by (rule ext) blast

lemma conj_comp:
"(\<And> a b c. P (a, b) = P (a, c)) \<Longrightarrow> (P \<and> (Q ;; R)) = ((P \<and> Q) ;; R)"
  by (rule ext) blast

lemma comp_cond_left_distr:
  assumes "\<And>x y z. b (x, y) = b (x, z)"
  shows "((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  using assms by (auto simp: fun_eq_iff utp_defs)

lemma ndet_symm: "(P::'a relation) \<sqinter> Q = Q \<sqinter> P"
  by (rule ext) blast

lemma ndet_idemp: "P \<sqinter> P = P"
  by (rule ext) blast

lemma ndet_distr: "P \<sqinter> (Q \<sqinter> R) = (P \<sqinter> Q) \<sqinter> (P \<sqinter> R)"
  by (rule ext) blast

lemma cond_ndet_distr: "(P \<triangleleft> b \<triangleright> (Q \<sqinter> R)) = ((P \<triangleleft> b \<triangleright> Q) \<sqinter> (P \<triangleleft> b \<triangleright> R))"
  by (rule ext) (auto split: cond_splits)

lemma ndet_cond_distr: "(P \<sqinter> (Q \<triangleleft> b \<triangleright> R)) = ((P \<sqinter> Q) \<triangleleft> b \<triangleright> (P \<sqinter> R))"
  by (rule ext) (auto split: cond_splits)

lemma comp_ndet_l_distr: "((P \<sqinter> Q) ;; R) = ((P ;; R) \<sqinter> (Q ;; R))"
  by (auto simp: fun_eq_iff utp_defs)

lemma comp_ndet_r_distr: "(P ;; (Q \<sqinter> R)) = ((P ;; Q) \<sqinter> (P ;; R))"
  by (auto simp: fun_eq_iff utp_defs)

lemma l2_5_1_A: "\<forall>X \<in> S. [X \<longrightarrow> (\<Sqinter> S)]"
  by blast

lemma l2_5_1_B: "(\<forall> X \<in> S. [X \<longrightarrow> P]) \<longrightarrow> [(\<Sqinter> S) \<longrightarrow> P]"
  by blast

lemma l2_5_1: "[(\<Sqinter> S) \<longrightarrow> P] \<longleftrightarrow> (\<forall> X \<in> S. [X \<longrightarrow> P])"
  by blast

lemma empty_disj: "\<Sqinter> {} = Top"
  by (rule ext) blast

lemma l2_5_1_2: "[P \<longrightarrow> (\<Squnion> S)] \<longleftrightarrow> (\<forall> X \<in> S. [P \<longrightarrow> X])"
  by blast

lemma empty_conj: "\<Squnion> {} = Bot"
  by (rule ext) blast

lemma l2_5_2: "((\<Squnion> S) \<sqinter> Q) = (\<Squnion>{P \<sqinter> Q | P. P\<in>S})"
  by (rule ext) blast

lemma l2_5_3: "((\<Sqinter> S) \<squnion> Q) = (\<Sqinter>{P \<squnion> Q | P. P \<in> S})"
  by (rule ext) blast

lemma l2_5_4: "((\<Sqinter> S) ;; Q) = (\<Sqinter>{P ;; Q | P. P \<in> S})"
  by (rule ext) blast

lemma l2_5_5: "(Q ;; (\<Sqinter> S)) = (\<Sqinter>{Q ;; P | P. P \<in> S})"
  by (rule ext) blast

lemma all_idem :"(\<^bold>\<forall>b. \<^bold>\<forall>a. P a) = (\<^bold>\<forall>a. P a)"
  by (simp add: all_def)

lemma comp_unit_R [simp]: "(P ;; \<Pi>r) = P"
  by (auto simp: fun_eq_iff utp_defs)

lemma comp_unit_L [simp]: "(\<Pi>r ;; P) = P"
  by (auto simp: fun_eq_iff utp_defs)

lemmas comp_unit_simps = comp_unit_R comp_unit_L

lemma not_cond: "(\<not>(P \<triangleleft> b \<triangleright> Q)) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))"
  by (rule ext) (auto split: cond_splits)

lemma cond_conj_not_distr:
"((P \<triangleleft> b \<triangleright> Q) \<and> \<not>(R \<triangleleft> b \<triangleright> S)) = ((P \<and> \<not>R) \<triangleleft> b \<triangleright> (Q \<and> \<not>S))"
  by (rule ext) (auto split: cond_splits)

lemma imp_cond_distr: "(R \<longrightarrow> (P \<triangleleft> b \<triangleright> Q)) = ((R \<longrightarrow> P) \<triangleleft> b \<triangleright> (R \<longrightarrow> Q))"
  by (rule ext) (auto split: cond_splits)

lemma cond_imp_dist: "((P \<triangleleft> b \<triangleright> Q) \<longrightarrow> R) = ((P \<longrightarrow> R) \<triangleleft> b \<triangleright> (Q \<longrightarrow> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_conj_distr: "((P \<triangleleft> b \<triangleright> Q) \<and> R) = ((P \<and> R) \<triangleleft> b \<triangleright> (Q \<and> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_disj_distr: "((P \<triangleleft> b \<triangleright> Q) \<or> R) = ((P \<or> R) \<triangleleft> b \<triangleright> (Q \<or> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_know_b: "(b \<and> (P \<triangleleft> b \<triangleright> Q)) = (b \<and> P)"
  by (rule ext) (auto split: cond_splits)

lemma cond_know_nb: "((\<not> (b)) \<and> (P \<triangleleft> b \<triangleright> Q)) = ((\<not> (b)) \<and> Q)"
  by (rule ext) (auto split: cond_splits)

lemma cond_ass_if: "(P \<triangleleft> b \<triangleright> Q) = (((b) \<and> P \<triangleleft> b \<triangleright> Q))"
  by (rule ext) (auto split: cond_splits)

lemma cond_ass_else: "(P \<triangleleft> b \<triangleright> Q) = (P \<triangleleft> b \<triangleright> ((\<not>b) \<and> Q))"
  by (rule ext) (auto split: cond_splits)

lemma not_true_eq_false: "(\<not> true) = false"
  by (rule ext) blast

lemma not_false_eq_true: "(\<not> false) = true"
  by (rule ext) blast

lemma conj_idem: "((P::'\<alpha> predicate) \<and> P) = P"
  by (rule ext) blast

lemma disj_idem: "((P::'\<alpha> predicate) \<or> P) = P"
  by (rule ext) blast

lemma conj_comm: "((P::'\<alpha> predicate) \<and> Q) = (Q \<and> P)"
  by (rule ext) blast

lemma disj_comm: "((P::'\<alpha> predicate) \<or> Q) = (Q \<or> P)"
  by (rule ext) blast

lemma conj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> predicate) \<and> Q) = (R \<and> Q)"
  by (rule ext) blast

lemma conj_assoc:"(((P::'\<alpha> predicate) \<and> Q) \<and> S) = (P \<and> (Q \<and> S))"
  by (rule ext) blast

lemma disj_assoc:"(((P::'\<alpha> predicate) \<or> Q) \<or> S) = (P \<or> (Q \<or> S))"
  by (rule ext) blast

lemma conj_disj_abs:"((P::'\<alpha> predicate) \<and> (P \<or> Q)) = P"
  by (rule ext) blast

lemma disj_conj_abs:"((P::'\<alpha> predicate) \<or> (P \<and> Q)) = P"
  by (rule ext) blast

lemma conj_disj_distr:"((P::'\<alpha> predicate) \<and> (Q \<or> R)) = ((P \<and> Q) \<or> (P \<and> R))"
  by (rule ext) blast

lemma disj_conj_dsitr:"((P::'\<alpha> predicate) \<or> (Q \<and> R)) = ((P \<or> Q) \<and> (P \<or> R))"
  by (rule ext) blast

lemma true_conj_id:"(P \<and> true) = P"
  by (rule ext) blast

lemma true_dsij_zero:"(P \<or> true) = true"
  by (rule ext) blast

lemma true_conj_zero:"(P \<and> false) = false"
  by (rule ext) blast

lemma true_dsij_id:"(P \<or> false) = P"
  by (rule ext) blast

lemma imp_vacuous: "(false \<longrightarrow> u) = true"
  by (rule ext) blast

lemma p_and_not_p: "(P \<and> \<not> P) = false"
  by (rule ext) blast

lemma conj_disj_not_abs: "((P::'\<alpha> predicate) \<and> ((\<not>P) \<or> Q)) = (P \<and> Q)"
  by (rule ext) blast

lemma p_or_not_p: "(P \<or> \<not> P) = true"
  by (rule ext) blast

lemma double_negation: "(\<not> \<not> (P::'\<alpha> predicate)) = P"
  by (rule ext) blast

lemma not_conj_deMorgans: "(\<not> ((P::'\<alpha> predicate) \<and> Q)) = ((\<not> P) \<or> (\<not> Q))"
  by (rule ext) blast

lemma not_disj_deMorgans: "(\<not> ((P::'\<alpha> predicate) \<or> Q)) = ((\<not> P) \<and> (\<not> Q))"
  by (rule ext) blast

lemma p_imp_p: "(P \<longrightarrow> P) = true"
  by (rule ext) blast

lemma imp_imp: "((P::'\<alpha> predicate) \<longrightarrow> (Q \<longrightarrow> R)) = ((P \<and> Q) \<longrightarrow> R)"
  by (rule ext) blast

lemma imp_trans: "((P \<longrightarrow> Q) \<and> (Q \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> R) = true"
  by (rule ext) blast

lemma p_equiv_p: "(P \<longleftrightarrow> P) = true"
  by (rule ext) blast

lemma equiv_eq: "((((P::'\<alpha> predicate) \<and> Q) \<or> (\<not>P \<and> \<not>Q)) = true) \<longleftrightarrow> (P = Q)"
  by (auto simp add: fun_eq_iff utp_defs)

lemma equiv_eq1: "(((P::'\<alpha> predicate) \<longleftrightarrow> Q) = true) \<longleftrightarrow> (P = Q)"
  by (auto simp add: fun_eq_iff utp_defs)

lemma cond_subst: "b = c \<Longrightarrow> (P \<triangleleft> b \<triangleright> Q) = (P \<triangleleft> c \<triangleright> Q)"
  by simp

lemma ex_disj_distr: "((\<^bold>\<exists>x. P x) \<or> (\<^bold>\<exists>x. Q x)) = (\<^bold>\<exists>x. (P x \<or> Q x))"
  by (rule ext) blast

lemma all_disj_distr: "((\<^bold>\<forall>x. P x) \<or> (\<^bold>\<forall>x. Q)) = (\<^bold>\<forall>x. (P x \<or> Q))"
  by (rule ext) blast

lemma all_conj_distr: "((\<^bold>\<forall>x. P x) \<and> (\<^bold>\<forall>x. Q x)) = (\<^bold>\<forall>x. (P x \<and> Q x))"
  by (rule ext) blast

lemma all_triv: "(\<^bold>\<forall>x. P) = P"
  by (rule ext) blast

lemma closure_true: "[true]"
  by blast

lemma closure_p_eq_true: "[P] \<longleftrightarrow> (P = true)"
  by (simp add: fun_eq_iff utp_defs)

lemma closure_equiv_eq: "[P \<longleftrightarrow> Q] \<longleftrightarrow> (P = Q)"
  by (simp add: fun_eq_iff utp_defs)

lemma closure_conj_distr: "([P] \<and> [Q]) = [P \<and> Q]"
  by blast

lemma closure_imp_distr: "[P \<longrightarrow> Q] \<longrightarrow> [P] \<longrightarrow> [Q]"
  by blast

lemma true_iff[simp]: "(P \<longleftrightarrow> true) = P"
  by blast

lemma true_imp[simp]: "(true \<longrightarrow> P) = P"
  by blast

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_MSortTDSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function msorttd :: "int list => int list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = (op div) (length (cons2 y (cons2 x2 x3))) 2
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "ordered (msorttd xs)"
  oops

end


section \<open> Derivatives of UTP Expressions \<close>

theory utp_hyprog_deriv
  imports utp_hyprog_prelim
begin

text \<open> We provide functions for specifying differentiability and taking derivatives of UTP expressions.
  The expressions have a hybrid state space, and so we only require differentiability of the
  continuous variable vector. The remainder of the state space is left unchanged by differentiation. \<close>

subsection \<open> Differentiability \<close>

lift_definition uexpr_differentiable_when ::
  "('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr \<Rightarrow> (bool, 'c, 's) hyexpr \<Rightarrow> bool" ("differentiable\<^sub>e _ when _" [0, 100] 100)
is "\<lambda> f d. \<forall> s. d s \<longrightarrow> (\<lambda> x. f (put\<^bsub>cvec\<^esub> s x)) differentiable (at (get\<^bsub>cvec\<^esub> s))" .

utp_lift_notation uexpr_differentiable_when (0)

abbreviation uexpr_differentiable ::
  "('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr \<Rightarrow> bool" ("differentiable\<^sub>e")
  where "differentiable\<^sub>e f \<equiv> differentiable\<^sub>e f when true"

translations "differentiable\<^sub>e f" <= "differentiable\<^sub>e f when true"

declare uexpr_differentiable_when_def [upred_defs]

update_uexpr_rep_eq_thms

lemma udifferentiable_consts [closure]:
  "differentiable\<^sub>e 0" "differentiable\<^sub>e 1" "differentiable\<^sub>e (numeral n)" "differentiable\<^sub>e \<guillemotleft>k\<guillemotright>"
  by (rel_simp)+

lemma udifferentiable_var [closure]:
  assumes "cont_lens x"
  shows "differentiable\<^sub>e (utp_expr.var (x ;\<^sub>L \<^bold>c))"
  by (rel_simp, simp add: assms bounded_linear_imp_differentiable)

lemma udifferentiable_pr_var [closure]:
  assumes "cont_lens x"
  shows "differentiable\<^sub>e (utp_expr.var (pr_var (x ;\<^sub>L \<^bold>c)))"
  by (rel_simp, simp add: assms bounded_linear_imp_differentiable)

lemma udifferentiable_plus [closure]:
  "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> differentiable\<^sub>e (e + f)"
  by (rel_simp)

lemma udifferentiable_uminus [closure]:
  "\<lbrakk> differentiable\<^sub>e e \<rbrakk> \<Longrightarrow> differentiable\<^sub>e (- e)"
  by (rel_simp)

lemma udifferentiable_minus [closure]:
  "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> differentiable\<^sub>e (e - f)"
  by (rel_simp)

lemma udifferentiable_mult [closure]:
  fixes e f :: "('a::{ordered_euclidean_space, real_normed_algebra}, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> differentiable\<^sub>e (e * f)"
  by (rel_simp)

lemma udifferentiable_divide [closure]:
  fixes e f :: "('a::{ordered_euclidean_space, real_normed_field}, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> differentiable\<^sub>e (e / f) when (\<not> f = 0)"
  by (rel_simp)

lemma udifferentiable_scaleR [closure]:
  fixes e :: "('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e n; differentiable\<^sub>e e \<rbrakk> \<Longrightarrow> differentiable\<^sub>e \<^U>(n *\<^sub>R e)"
  by (rel_simp)

lemma udifferentiable_inner [closure]:
  fixes e :: "('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e n; differentiable\<^sub>e e \<rbrakk> \<Longrightarrow> differentiable\<^sub>e \<^U>(n \<bullet> e)"
  by (rel_simp)

lemma udifferentiable_power [closure]:
  fixes e :: "('a::{ordered_euclidean_space, real_normed_field}, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow> differentiable\<^sub>e (e ^ n)"
  by (rel_simp)

lemma udifferentiable_norm [closure]:
  fixes e :: "('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow> differentiable\<^sub>e \<^U>(norm e) when (\<not> e = 0)"
  by (rel_simp, metis differentiable_compose differentiable_norm_at)

lemma udifferentiable_sin [closure]:
  fixes e :: "(real, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow> differentiable\<^sub>e U(sin e)"
  using differentiable_compose field_differentiable_imp_differentiable field_differentiable_within_sin
  by (rel_blast)

lemma udifferentiable_cos [closure]:
  fixes e :: "(real, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow> differentiable\<^sub>e U(cos e)"
  using differentiable_compose field_differentiable_imp_differentiable field_differentiable_within_cos
  by (rel_blast)

lemma udifferentiable_vector_2 [closure]:
  fixes e :: "(real, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> differentiable\<^sub>e U(\<^bold>[[e, f]\<^bold>])"
  apply (rel_simp)
  apply (rule differentiable_Mat)
  apply (rename_tac c m i j)
  apply (case_tac "j = 0")
   apply (simp_all)
  done

subsection \<open> Differentiation \<close>

text \<open> For convenience in the use of ODEs, we differentiate with respect to a known context of
  derivative for the variables. This means we don't have to deal with symbolic variable derivatives
  and so the state space is unchanged by differentiation. \<close>

lift_definition lie_deriv ::
  "'c usubst \<Rightarrow> ('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr \<Rightarrow> ('a, 'c, 's) hyexpr" ("\<L>\<^bsub>_\<^esub>")
is "\<lambda> \<sigma> f s. frechet_derivative (\<lambda> x. f (put\<^bsub>cvec\<^esub> s x)) (at (get\<^bsub>cvec\<^esub> s)) (\<sigma> (get\<^bsub>cvec\<^esub> s))" .

update_uexpr_rep_eq_thms

utp_const lie_deriv

named_theorems uderiv

lemma uderiv_zero [uderiv]: "\<L>\<^bsub>F'\<^esub> 0 = 0"
  by (rel_simp)

lemma uderiv_one [uderiv]: "\<L>\<^bsub>F'\<^esub> 1 = 0"
  by (rel_simp)

lemma uderiv_numeral [uderiv]: "\<L>\<^bsub>F'\<^esub> (numeral n) = 0"
  by (rel_simp)

lemma uderiv_lit [uderiv]: "\<L>\<^bsub>F'\<^esub> (\<guillemotleft>v\<guillemotright>) = 0"
  by (rel_simp)

lemma uderiv_plus [uderiv]:
  "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> \<L>\<^bsub>F'\<^esub> (e + f) = (\<L>\<^bsub>F'\<^esub> e + \<L>\<^bsub>F'\<^esub> f)"
  by (rel_simp, simp add: frechet_derivative_plus)

lemma uderiv_uminus [uderiv]:
  "differentiable\<^sub>e e \<Longrightarrow> \<L>\<^bsub>F'\<^esub> (- e) = - (\<L>\<^bsub>F'\<^esub> e)"
  by (rel_simp, simp add: frechet_derivative_uminus)

lemma uderiv_minus [uderiv]:
  "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow> \<L>\<^bsub>F'\<^esub> (e - f) = (\<L>\<^bsub>F'\<^esub> e) - (\<L>\<^bsub>F'\<^esub> f)"
  by (rel_simp, simp add: frechet_derivative_minus)

lemma uderiv_mult [uderiv]:
  fixes e f :: "('a::{ordered_euclidean_space, real_normed_algebra}, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> (e * f) = (e * \<L>\<^bsub>F'\<^esub> f + \<L>\<^bsub>F'\<^esub> e * f)"
  by (rel_simp, simp add: frechet_derivative_mult)

lemma uderiv_scaleR [uderiv]:
  fixes f :: "('a::{ordered_euclidean_space}, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> \<^U>(e *\<^sub>R f) = \<^U>(e *\<^sub>R \<L>\<^bsub>F'\<^esub> f + \<L>\<^bsub>F'\<^esub> e *\<^sub>R f)"
  by (rel_simp, simp add: frechet_derivative_scaleR)

lemma uderiv_inner [uderiv]:
  fixes f :: "('a::ordered_euclidean_space, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> \<^U>(e \<bullet> f) = \<^U>(e \<bullet> \<L>\<^bsub>F'\<^esub> f + \<L>\<^bsub>F'\<^esub> e \<bullet> f)"
  by (rel_simp, simp add: frechet_derivative_inner)

lemma uderiv_power [uderiv]:
  fixes e :: "('a::{ordered_euclidean_space, real_normed_field}, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> (e ^ n) = of_nat n * \<L>\<^bsub>F'\<^esub> e * e ^ (n - 1)"
  by (rel_simp, simp add: frechet_derivative_power ueval)

lemma uderiv_cos [uderiv]:
  fixes e :: "(real, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> U(cos e) = U(\<L>\<^bsub>F'\<^esub> e * - sin e)"
  by (rel_simp, simp add: frechet_derivative_cos)

lemma uderiv_sin [uderiv]:
  fixes e :: "(real, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "differentiable\<^sub>e e \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> U(sin e) = U(\<L>\<^bsub>F'\<^esub> e * cos e)"
  by (rel_simp, simp add: frechet_derivative_sin)

lemma uderiv_vector_2 [uderiv]:
  fixes e :: "(real, 'c::ordered_euclidean_space, 's) hyexpr"
  shows "\<lbrakk> differentiable\<^sub>e e; differentiable\<^sub>e f \<rbrakk> \<Longrightarrow>  \<L>\<^bsub>F'\<^esub> U(\<^bold>[[e, f]\<^bold>]) = U(\<^bold>[[\<L>\<^bsub>F'\<^esub> e, \<L>\<^bsub>F'\<^esub> f]\<^bold>])"
  apply (rel_simp)
  apply (subst frechet_derivative_Mat)
   apply (rename_tac c m i j)
   apply (case_tac "j = 0")
    apply (simp)
   apply (simp)
  apply (simp add: deriv_mat_def abs_mat_def comp_def upt_rec)
  done

text \<open> The derivative of a variable represented by a bounded linear lens into the continuous state
  space uses the said lens to obtain the derivative from the context @{term F'}. \<close>

lemma uderiv_var:
  assumes "cont_lens x"
  shows "\<L>\<^bsub>F'\<^esub> (utp_expr.var (x ;\<^sub>L \<^bold>c)) = \<langle>F'\<rangle>\<^sub>s x \<oplus>\<^sub>p cvec"
  by (rel_simp)
     (metis assms bounded_linear_imp_has_derivative cont_lens.bounded_linear_get frechet_derivative_at)

lemma uderiv_pr_var [uderiv]:
  assumes "cont_lens x"
  shows "(\<L>\<^bsub>F'\<^esub> &\<^bold>c:x) = \<langle>F'\<rangle>\<^sub>s x \<oplus>\<^sub>p \<^bold>c"
  using assms by (simp add: pr_var_def uderiv_var)

text \<open> Example \<close>

lemma
  fixes x :: "real \<Longrightarrow> real"
  assumes "cont_lens x"
  shows "\<L>\<^bsub>[x \<mapsto>\<^sub>s &x]\<^esub> (2*&\<^bold>c:x) = 2*&\<^bold>c:x"
  by (simp add: uderiv usubst closure assms alpha, rel_simp)

end


theory list_PairEvens
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun pairs :: "'t list => (('t, 't) Pair2) list" where
"pairs (Nil2) = Nil2"
| "pairs (Cons2 y (Nil2)) = Nil2"
| "pairs (Cons2 y (Cons2 y2 xs)) = Cons2 (Pair y y2) (pairs xs)"

fun map2 :: "('t2 => 't) => 't2 list => 't list" where
"map2 f (Nil2) = Nil2"
| "map2 f (Cons2 y z) = Cons2 (f y) (map2 f z)"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun fst :: "('a, 'b) Pair2 => 'a" where
"fst (Pair y z) = y"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (Nil2) = Nil2"
| "evens (Cons2 y xs) = Cons2 y (odds xs)"
| "odds (Nil2) = Nil2"
| "odds (Cons2 y xs) = evens xs"
by pat_completeness auto

fun even :: "Nat => bool" where
"even (Z) = True"
| "even (S (Z)) = False"
| "even (S (S z)) = even z"

(*hipster pairs map2 length fst evens odds even *)

theorem x0 :
  "!! (xs :: 'b list) .
     (even (length xs)) ==>
       ((map2 (% (x :: ('b, 'b) Pair2) => fst x) (pairs xs)) =
          (evens xs))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory CSLSemantics imports Main Real Log Ln Taylor -- "the imports taken from Complex_Main"
begin

(* A Remark on deep embeddings:

The key-point is how binders and bound or free variables are represented.

In different papers there are different approaches:

*** Proving the Completeness Theorem within Isabelle/HOL (2004):
Variables are integers, binders use a deBruijn-Index style without mentioning the bound variable
(least variable is bound by a binder, e.g., All (All ((Var 1) = 2*(Var 2))) = !x. !y. y=2*x)

*** Implementing Z in Isabelle (1995):
Z is deeply embedded in a logic based on Isabelle/Pure (not HOL!).

Looks for me rather shallow than deep (apparently Jigsaw is a deeper embedding,
simulating also the substitution machinery, see p.18(371)).

From p.3(356):
"Variable binding is expressed using higher-order abstract syntax.
This enables us to express inference rules involving substitution
for bound variables in such a way that the usual side conditions are automatically respected.
Thus, for instance, the inference rule ForallIntro: P ==> forall x. P
with the side condition that x does not occur free in the assumptions, can be formalized
in Isabelle as:
!! x. Trueprop(P(x)) ==> Trueprop(forall(%x.P(x))) .
"

* A simple setting to reason about

program: "y := x ^ 2"

program-property to prove: "y >= 0"

*)

(**********************  Toy development 1  **********************)

types State = "int => real"

datatype Term = Const int | Num real | Mult Term Term | Add Term Term

fun iTerm :: "State => Term => real" where
"iTerm _ (Num r) = r" |
"iTerm s (Mult t u) = (iTerm s t) * (iTerm s u)" |
"iTerm s (Add t u) = (iTerm s t) + (iTerm s u)" |
"iTerm s (Const i) = s i"

datatype Command = Assign int Term | Seq Command Command

fun iCommand :: "State => Command => State" where
"iCommand s (Assign i t) = (%x . if x = i then iTerm s t else s x)" |
"iCommand s (Seq c1 c2) = (let s' = iCommand s c1 in iCommand s' c2)"

datatype ProgCond = Ge Term Term | Gt Term Term

fun iProgCond :: "State => ProgCond => bool" where
"iProgCond s (Ge t u) = (iTerm s t >= iTerm s u)" |
"iProgCond s (Gt t u) = (iTerm s t > iTerm s u)"

constdefs c1 :: Command -- "The command for  y := x * x"
         "c1 == Assign 2 (Mult (Const 1) (Const 1))"

constdefs p1 :: ProgCond -- "The property for  y >= 0"
         "p1 == Ge (Const 2) (Num 0)"

lemma soundProg:
  "!! s :: State .
   let s' = iCommand s c1
   in iProgCond s' p1"

apply (subst Let_def, subst c1_def, subst p1_def)
apply (simp only: iCommand.simps)
apply (simp only: iProgCond.simps)
apply (simp only: iTerm.simps)
apply (simp only: if_P)
by simp
(*

by (simp add: c1_def p1_def iCommand.simps iProgCond.simps)
*)

constdefs c2 :: Command -- "The command for  x := x * x"
         "c2 == Assign 1 (Mult (Const 1) (Const 1))"

constdefs p2 :: ProgCond -- "The property for  x >= 0"
         "p2 == Ge (Const 1) (Num 0)"

lemma soundProg2:
  "!! s :: State .
   let s' = iCommand s c2
   in iProgCond s' p2"
by (simp add: c2_def p2_def iCommand.simps iProgCond.simps)

constdefs c3 :: Command -- "The command for  x := 0; x := x + 1"
         "c3 == Seq (Assign 1 (Num 0)) (Assign 1 (Add (Const 1) (Num 1)))"

constdefs p3 :: ProgCond -- "The property for  x > 0"
         "p3 == Gt (Const 1) (Num 0)"

lemma soundProg3:
  "!! s :: State .
   let s' = iCommand s c3
   in iProgCond s' p3"

apply (subst Let_def, subst c3_def, subst p3_def)
apply (simp only: iCommand.simps)
apply (subst Let_def)
apply (simp only: iProgCond.simps)
apply (simp only: iTerm.simps)
by (simp only: if_P)

lemma soundProgExplicit:
  "!! (s :: State) (x :: real) (y :: real).
   let s' = (%z . if z = 1 then x else if z = 2 then y else s z);
       s'' = iCommand s' c1
   in iProgCond s'' p1"

apply (simp only: Let_def c1_def p1_def iCommand.simps iProgCond.simps iTerm.simps if_P)
by simp

(**********************  Toy development with Assignment store  **********************)

fun dependsOn :: "Term => int set" where
"dependsOn (Num n) = {}" |
"dependsOn (Mult t u) = dependsOn t Un dependsOn u" |
"dependsOn (Add t u) = dependsOn t Un dependsOn u" |
"dependsOn (Const i) = {i}"

types ConstantTermAssignments = "int ~=> Term"

constdefs
  -- "flat dependency for the given constant when lookuped in the CTA"
  dependsOnWithCTALookup :: "ConstantTermAssignments => int => int set"
 "dependsOnWithCTALookup f i == (case f i of
                            Some t => dependsOn t |
                            _ => {})"

  -- "flat dependency relation, not transitive by construction"
  depOrder1 :: "ConstantTermAssignments => (int*int) set"
 "depOrder1 f == {(x, y) | x y . y: dependsOnWithCTALookup f x}"

  -- "transitive closure of depOrder1"
  depOrder :: "ConstantTermAssignments => (int*int) set"
 "depOrder f == (depOrder1 f)^+"

  -- "set of constants the current term (recursively) depends on"
  dependsOnWithCTA :: "ConstantTermAssignments => Term => int set"
 "dependsOnWithCTA f t == Image (depOrder f) (dependsOn t)"

-- "An AssignmentStore is a finite ConstantTermAssignments without cycles"
constdefs AS_set :: "ConstantTermAssignments set"
         "AS_set == {f. let ord = depOrder f in wf ord & finite ord}"

lemma emptyAS_has_empty_dep_order : "depOrder empty == {}"
  by (simp add: depOrder1_def depOrder_def dependsOnWithCTALookup_def)

lemma emptyAS_in_AS': "empty : AS_set"
  by (simp add: emptyAS_has_empty_dep_order AS_set_def)

typedef (AS) AssignmentStore = AS_set
  morphisms asCTA toAS
  by (rule exI[of _ empty], simp only: emptyAS_in_AS')

lemma emptyAS_in_AS: "empty : AS"
  by (simp add: emptyAS_in_AS' AS_def)

function fullexpand :: "AssignmentStore => Term => Term" where
"fullexpand _ (Num r) = Num r" |
"fullexpand as (Mult t u) = Mult (fullexpand as t) (fullexpand as u)" |
"fullexpand as (Add t u) = Add (fullexpand as t) (fullexpand as u)" |
"fullexpand as (Const i) = (case (asCTA as) i of
                              Some y => fullexpand as y
                            | None => Const i)"
  by (auto, case_tac "b", auto)

(*
 fullexpand is total essentially because the lookup in the
 Const-case is terminating because of the wellfoundness of "as" and
 the recursion on the structure of Term also terminates
 *)
lemma fullexpand_is_total : "!! as t . fullexpand_dom (as, t)"
  sorry

(* arg_cong and fun_cong are the crucial axioms
lemma T1:
  assumes H0: "f x = g"
  shows "!!i. f x i = g i"
by (rule arg_cong, simp add: H0)
by (rule fun_cong, simp add: H0)
*)

lemma "!!t . fullexpand (toAS empty) t = t"
proof (induct_tac "t", auto)
  fix i
  have H0: "asCTA (toAS empty) = empty"
    by (simp only: emptyAS_in_AS toAS_inverse)
  have H1: "asCTA (toAS empty) i = empty i"
    by (rule arg_cong, simp add: H0)
  have H2: "asCTA (toAS empty) i = None" by (simp only: H1)
  hence "(case (asCTA (toAS empty) i) of Some y => fullexpand (toAS empty) y | None => Const i) = Const i" by simp
  thus "fullexpand (toAS empty) (Const i) = Const i"
    by(simp add: fullexpand_is_total fullexpand.psimps)
next
  fix r
  show "fullexpand (toAS empty) (Num r) = Num r"
    by (simp add: fullexpand_is_total fullexpand.psimps)
next
  fix t1 t2
  assume "fullexpand (toAS empty) t1 = t1" and "fullexpand (toAS empty) t2 = t2"
  thus "fullexpand (toAS empty) (Mult t1 t2) = (Mult t1 t2)"
    by (simp add: fullexpand_is_total fullexpand.psimps)
next
  fix t1 t2
  assume "fullexpand (toAS empty) t1 = t1" and "fullexpand (toAS empty) t2 = t2"
  thus "fullexpand (toAS empty) (Add t1 t2) = (Add t1 t2)"
    by (simp add: fullexpand_is_total fullexpand.psimps)
qed

nonterminals
  updbinds2 updbind2
syntax
  "_updbind2" :: "['a, 'a] => updbind2"             ("(2_ ::=/ _)")
  ""         :: "updbind2 => updbinds2"             ("_")
  "_updbinds2":: "[updbind2, updbinds2] => updbinds2" ("_,/ _")
  "_Update2"  :: "['a, updbinds2] => 'a"            ("_/'((_)')" [1000,0] 900)

translations
  "_Update2 f (_updbinds2 b bs)"  == "_Update2 (_Update2 f b) bs"
  "f(x::=y)"                     == "toAS ((asCTA f)(x |-> y))"

-- "If we encounter a cycle in an assignment we return None"
fun iProg :: "AssignmentStore => Command ~=> AssignmentStore" where
   "iProg as (Assign i t) = (let t' = fullexpand as t
                             in if i : dependsOn t then None else Some (as(i ::= t')))" |
   "iProg as (Seq c c') = (case iProg as c of
                             Some as' => iProg as' c'
                           | None => None)"

(**********************  Respectful States  **********************)

constdefs respectsAS :: "State => AssignmentStore => bool" (infixl "resp" 50)
         "s resp as == !x t . (asCTA as) x = Some t --> s x = iTerm s t"

theorem State_AssertionStore_interpretation_respect_preserving:
  "[|s resp as; iProg as p = Some as'|] ==> (iCommand s p) resp as'"
  sorry

theorem iTerm_invariant_under_full_expansion:
  "s resp as ==> !t. iTerm s t = iTerm s (fullexpand as t)"
proof-
  fix s as
  assume H0: "s resp as"
  show ?thesis
    apply (rule allI, induct_tac "t")
    apply(simp add: fullexpand_is_total fullexpand.psimps)
    apply (case_tac "asCTA as int")
    proof-
      fix i
      assume H1: "asCTA as i = None"
      hence H2: "(case (asCTA as) i of
                   Some y => fullexpand as y
                 | None => Const i)=Const i" (is "?cc = ?ci")
	by simp
      have "s i = iTerm s (Const i)" by simp
      also have "... = iTerm s ?cc" by (simp add: H2)

      -- "TODO: show macht probleme!"
      finally show "s i = iTerm s ?cc"

(*
      show " s i =
           iTerm s
            (option_case (Const i)
              (fullexpand as) (asCTA as i))"

*)

(**********************  Test stuff  **********************)

-- "just for testing"

lemma "!!v x y z. (empty(v |-> x)) y = Some z ==> y = v & z = x"
  by (case_tac "y=v", simp+)

-- "TODO: ins wiki stellen"
lemma "(EX y. ALL x. P x y) --> (ALL x. EX y. P x y)"
  apply rule
  apply rule
  apply (erule exE)
  (* Geht nicht: x als gebundene Variable kann nicht referenziert werden
  apply (drule spec[where x=x])
    *)
  apply (drule_tac x=x in spec)
  apply (erule exI)
  done

term The
term Some
term "THE x. False"
ML {* @{term "THE x. False"} *}
ML {* the_context() *}
-- "old command print_syntax, what is the new one?"
ML {* print_syntax (theory "Main") *}


(*
  File:     KD_Tree.thy
  Author:   Martin Rau, TU München
*)

section "Definition of the \<open>k\<close>-d Tree"

theory KD_Tree
imports
  Complex_Main
  "HOL-Analysis.Finite_Cartesian_Product"
  "HOL-Analysis.Topology_Euclidean_Space"
begin

text \<open>
  A \<open>k\<close>-d tree is a space-partitioning data structure for organizing points in a \<open>k\<close>-dimensional space.
  In principle the \<open>k\<close>-d tree is a binary tree. The leafs hold the \<open>k\<close>-dimensional points and the nodes
  contain left and right subtrees as well as a discriminator \<open>v\<close> at a particular axis \<open>k\<close>.
  Every node divides the space into two parts by splitting along a hyperplane.
  Consider a node \<open>n\<close> with associated discriminator \<open>v\<close> at axis \<open>k\<close>.
  All points in the left subtree must have a value at axis \<open>k\<close> that is less than or
  equal to \<open>v\<close> and all points in the right subtree must have a value at axis \<open>k\<close> that is
  greater than \<open>v\<close>.

  Deviations from the papers:

  The chosen tree representation is taken from @{cite "DBLP:journals/toms/FriedmanBF77"} with one minor
  adjustment. Originally the leafs hold buckets of points of size \<open>b\<close>. This representation fixes the
  bucket size to \<open>b = 1\<close>, a single point per Leaf. This is only a minor adjustment since the paper
  proves that \<open>b = 1\<close> is the optimal bucket size for minimizing the running time of the nearest neighbor
  algorithm @{cite "DBLP:journals/toms/FriedmanBF77"}, only simplifies building the optimized
  \<open>k\<close>-d trees @{cite "DBLP:journals/toms/FriedmanBF77"} and has little influence on the
  search algorithm @{cite "DBLP:journals/cacm/Bentley75"}.
\<close>

type_synonym 'k point = "(real, 'k) vec"

lemma dist_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "dist p\<^sub>0 p\<^sub>1 = sqrt (\<Sum>k \<in> UNIV. (p\<^sub>0$k - p\<^sub>1$k)\<^sup>2)"
  unfolding dist_vec_def L2_set_def dist_real_def by simp

datatype 'k kdt =
  Leaf "'k point"
| Node 'k real "'k kdt" "'k kdt"

subsection \<open>Definition of the \<open>k\<close>-d Tree Invariant and Related Functions\<close>

fun set_kdt :: "'k kdt \<Rightarrow> ('k point) set" where
  "set_kdt (Leaf p) = { p }"
| "set_kdt (Node _ _ l r) = set_kdt l \<union> set_kdt r"

definition spread :: "('k::finite) \<Rightarrow> 'k point set \<Rightarrow> real" where
  "spread k P = (if P = {} then 0 else let V = (\<lambda>p. p$k) ` P in Max V - Min V)"

definition widest_spread_axis :: "('k::finite) \<Rightarrow> 'k set \<Rightarrow> 'k point set \<Rightarrow> bool" where
  "widest_spread_axis k K ps \<longleftrightarrow> (\<forall>k' \<in> K. spread k' ps \<le> spread k ps)"

fun invar :: "('k::finite) kdt \<Rightarrow> bool" where
  "invar (Leaf p) \<longleftrightarrow> True"
| "invar (Node k v l r) \<longleftrightarrow> (\<forall>p \<in> set_kdt l. p$k \<le> v) \<and> (\<forall>p \<in> set_kdt r. v < p$k) \<and>
    widest_spread_axis k UNIV (set_kdt l \<union> set_kdt r) \<and> invar l \<and> invar r"

fun size_kdt :: "'k kdt \<Rightarrow> nat" where
  "size_kdt (Leaf _) = 1"
| "size_kdt (Node _ _ l r) = size_kdt l + size_kdt r"

fun height :: "'k kdt \<Rightarrow> nat" where
  "height (Leaf _) = 0"
| "height (Node _ _ l r) = max (height l) (height r) + 1"

fun min_height :: "'k kdt \<Rightarrow> nat" where
  "min_height (Leaf _) = 0"
| "min_height (Node _ _ l r) = min (min_height l) (min_height r) + 1"

definition balanced :: "'k kdt \<Rightarrow> bool" where
  "balanced kdt \<longleftrightarrow> height kdt - min_height kdt \<le> 1"

fun complete :: "'k kdt \<Rightarrow> bool" where
  "complete (Leaf _) = True"
| "complete (Node _ _ l r) \<longleftrightarrow> complete l \<and> complete r \<and> height l = height r"

lemma invar_r:
  "invar (Node k v l r) \<Longrightarrow> invar r"
  by simp

lemma invar_l_le_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt l. p$k \<le> v"
  by simp

lemma invar_r_ge_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt r. v < p$k"
  by simp

lemma invar_set:
  "set_kdt (Node k v l r) = set_kdt l \<union> set_kdt r"
  by simp

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree\<close> to \<open>k\<close>-d Tree\<close>

lemma size_ge0[simp]:
  "0 < size_kdt kdt"
  by (induction kdt) auto

lemma eq_size_1[simp]:
  "size_kdt kdt = 1 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  apply (induction kdt)
  apply (auto)
  using size_ge0 nat_less_le apply blast+
  done

lemma eq_1_size[simp]:
  "1 = size_kdt kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  using eq_size_1 by metis

lemma neq_Leaf_iff:
  "(\<nexists>p. kdt = Leaf p) = (\<exists>k v l r. kdt = Node k v l r)"
  by (cases kdt) auto

lemma eq_height_0[simp]:
  "height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_height[simp]:
  "0 = height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_min_height_0[simp]:
  "min_height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_min_height[simp]:
  "0 = min_height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma size_height:
  "size_kdt kdt \<le> 2 ^ height kdt"
proof(induction kdt)
  case (Node k v l r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node k v l r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

lemma min_height_le_height:
  "min_height kdt \<le> height kdt"
  by (induction kdt) auto

lemma min_height_size:
  "2 ^ min_height kdt \<le> size_kdt kdt"
proof(induction kdt)
  case (Node k v l r)
  have "(2::nat) ^ min_height (Node k v l r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size_kdt (Node k v l r)" using Node.IH by simp
  finally show ?case .
qed simp

lemma complete_iff_height:
  "complete kdt \<longleftrightarrow> (min_height kdt = height kdt)"
  apply (induction kdt)
  apply simp
  apply (simp add: min_def max_def)
  by (metis le_antisym le_trans min_height_le_height)

lemma size_if_complete:
  "complete kdt \<Longrightarrow> size_kdt kdt = 2 ^ height kdt"
  by (induction kdt) auto

lemma complete_if_size_height:
  "size_kdt kdt = 2 ^ height kdt \<Longrightarrow> complete kdt"
proof (induction "height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
  have 3: "\<not> height l < h"
  proof
    assume 0: "height l < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ h + 2 ^ height r" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 2 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  have 4: "\<not> height r < h"
  proof
    assume 0: "height r < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ height l + 2 ^ h" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 1 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
  hence "size_kdt l = 2 ^ height l" "size_kdt r = 2 ^ height r"
    using Suc(3) size_height[of l] size_height[of r] by (auto)
  with * Suc(1) show ?case by simp
qed

lemma complete_if_size_min_height:
  "size_kdt kdt = 2 ^ min_height kdt \<Longrightarrow> complete kdt"
proof (induct "min_height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "h \<le> min_height l" and 2: "h \<le> min_height r" using Suc(2) by (auto)
  have 3: "\<not> h < min_height l"
  proof
    assume 0: "h < min_height l"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height l > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height r \<ge> 2 ^ h" using 2 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  have 4: "\<not> h < min_height r"
  proof
    assume 0: "h < min_height r"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height r > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height l \<ge> 2 ^ h" using 1 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  from 1 2 3 4 have *: "min_height l = h" "min_height r = h" by linarith+
  hence "size_kdt l = 2 ^ min_height l" "size_kdt r = 2 ^ min_height r"
    using Suc(3) min_height_size[of l] min_height_size[of r] by (auto)
  with * Suc(1) show ?case
    by (simp add: complete_iff_height)
qed

lemma complete_iff_size:
  "complete kdt \<longleftrightarrow> size_kdt kdt = 2 ^ height kdt"
  using complete_if_size_height size_if_complete by blast

lemma size_height_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> size_kdt kdt < 2 ^ height kdt"
  by (meson antisym_conv complete_iff_size not_le size_height)

lemma min_height_size_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> 2 ^ min_height kdt < size_kdt kdt"
  by (metis complete_if_size_min_height le_less min_height_size)

lemma balanced_subtreeL:
  "balanced (Node k v l r) \<Longrightarrow> balanced l"
  by (simp add: balanced_def)

lemma balanced_subtreeR:
  "balanced (Node k v l r) \<Longrightarrow> balanced r"
  by (simp add: balanced_def)

lemma balanced_optimal:
  assumes "balanced kdt" "size_kdt kdt \<le> size_kdt kdt'"
  shows "height kdt \<le> height kdt'"
proof (cases "complete kdt")
  case True
  have "(2::nat) ^ height kdt \<le> 2 ^ height kdt'"
  proof -
    have "2 ^ height kdt = size_kdt kdt"
      using True by (simp add: complete_iff_height size_if_complete)
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'" by (rule size_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height kdt < 2 ^ height kdt'"
  proof -
    have "(2::nat) ^ min_height kdt < size_kdt kdt"
      by(rule min_height_size_if_incomplete[OF False])
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'"  by(rule size_height)
    finally have "(2::nat) ^ min_height kdt < (2::nat) ^ height kdt'" .
    thus ?thesis .
  qed
  hence *: "min_height kdt < height kdt'" by simp
  have "min_height kdt + 1 = height kdt"
    using min_height_le_height[of kdt] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree_Real\<close> to \<open>k\<close>-d Tree\<close>

lemma size_height_log:
  "log 2 (size_kdt kdt) \<le> height kdt"
  by (simp add: log2_of_power_le size_height)

lemma min_height_size_log:
  "min_height kdt \<le> log 2 (size_kdt kdt)"
  by (simp add: le_log2_of_power min_height_size)

lemma size_log_if_complete:
  "complete kdt \<Longrightarrow> height kdt = log 2 (size_kdt kdt)"
  using complete_iff_size log2_of_power_eq by blast

lemma min_height_size_log_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> min_height kdt < log 2 (size_kdt kdt)"
  by (simp add: less_log2_of_power min_height_size_if_incomplete)

lemma min_height_balanced:
  assumes "balanced kdt"
  shows "min_height kdt = nat(floor(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ min_height kdt"
    by (simp add: complete_iff_height size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete kdt"
  hence "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt < 2 ^ (min_height kdt + 1)"
    by (metis * size_height_if_incomplete)
  hence "log 2 (size_kdt kdt) < min_height kdt + 1"
    using log2_of_power_less size_ge0 by blast
  thus ?thesis using min_height_size_log[of kdt] by linarith
qed

lemma height_balanced:
  assumes "balanced kdt"
  shows "height kdt = nat(ceiling(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ height kdt"
    by (simp add: size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis
    by linarith
next
  assume *: "\<not> complete kdt"
  hence **: "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt \<le> 2 ^ (min_height kdt + 1)" by (metis size_height)
  from  log2_of_power_le[OF this size_ge0] min_height_size_log_if_incomplete[OF *] **
  show ?thesis by linarith
qed

lemma balanced_Node_if_wbal1:
  assumes "balanced l" "balanced r" "size_kdt l = size_kdt r + 1"
  shows "balanced (Node k v l r)"
proof -
  from assms(3) have [simp]: "size_kdt l = size_kdt r + 1" by simp
  have "nat \<lceil>log 2 (1 + size_kdt r)\<rceil> \<ge> nat \<lceil>log 2 (size_kdt r)\<rceil>"
    by(rule nat_mono[OF ceiling_mono]) simp
  hence 1: "height(Node k v l r) = nat \<lceil>log 2 (1 + size_kdt r)\<rceil> + 1"
    using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
    by (simp del: nat_ceiling_le_eq add: max_def)
  have "nat \<lfloor>log 2 (1 + size_kdt r)\<rfloor> \<ge> nat \<lfloor>log 2 (size_kdt r)\<rfloor>"
    by(rule nat_mono[OF floor_mono]) simp
  hence 2: "min_height(Node k v l r) = nat \<lfloor>log 2 (size_kdt r)\<rfloor> + 1"
    using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
    by (simp)
  have "size_kdt r \<ge> 1" by (simp add: Suc_leI)
  then obtain i where i: "2 ^ i \<le> size_kdt r" "size_kdt r < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 "size_kdt r"] by auto
  hence i1: "2 ^ i < size_kdt r + 1" "size_kdt r + 1 \<le> 2 ^ (i + 1)" by auto
  from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
  show ?thesis by(simp add:balanced_def)
qed

lemma balanced_sym:
  "balanced (Node k v l r) \<Longrightarrow> balanced (Node k' v' r l)"
  by (auto simp: balanced_def)

lemma balanced_Node_if_wbal2:
  assumes "balanced l" "balanced r" "abs(int(size_kdt l) - int(size_kdt r)) \<le> 1"
  shows "balanced (Node k v l r)"
proof -
  have "size_kdt l = size_kdt r \<or> (size_kdt l = size_kdt r + 1 \<or> size_kdt r = size_kdt l + 1)" (is "?A \<or> ?B")
    using assms(3) by linarith
  thus ?thesis
  proof
    assume "?A"
    thus ?thesis using assms(1,2)
      apply(simp add: balanced_def min_def max_def)
      by (metis assms(1,2) balanced_optimal le_antisym le_less)
  next
    assume "?B"
    thus ?thesis
      by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
  qed
qed

end


(*  Title:      HOL/Probability/Stream_Space.thy
    Author:     Johannes Hölzl, TU München *)

theory Stream_Space
imports
  Infinite_Product_Measure
  "~~/src/HOL/Library/Stream"
  "~~/src/HOL/Library/Linear_Temporal_Logic_on_Streams"
begin

lemma stream_eq_Stream_iff: "s = x ## t \<longleftrightarrow> (shd s = x \<and> stl s = t)"
  by (cases s) simp

lemma Stream_snth: "(x ## s) !! n = (case n of 0 \<Rightarrow> x | Suc n \<Rightarrow> s !! n)"
  by (cases n) simp_all

definition to_stream :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a stream" where
  "to_stream X = smap X nats"

lemma to_stream_nat_case: "to_stream (case_nat x X) = x ## to_stream X"
  unfolding to_stream_def
  by (subst siterate.ctr) (simp add: smap_siterate[symmetric] stream.map_comp comp_def)

lemma to_stream_in_streams: "to_stream X \<in> streams S \<longleftrightarrow> (\<forall>n. X n \<in> S)"
  by (simp add: to_stream_def streams_iff_snth)

definition stream_space :: "'a measure \<Rightarrow> 'a stream measure" where
  "stream_space M =
    distr (\<Pi>\<^sub>M i\<in>UNIV. M) (vimage_algebra (streams (space M)) snth (\<Pi>\<^sub>M i\<in>UNIV. M)) to_stream"

lemma space_stream_space: "space (stream_space M) = streams (space M)"
  by (simp add: stream_space_def)

lemma streams_stream_space[intro]: "streams (space M) \<in> sets (stream_space M)"
  using sets.top[of "stream_space M"] by (simp add: space_stream_space)

lemma stream_space_Stream:
  "x ## \<omega> \<in> space (stream_space M) \<longleftrightarrow> x \<in> space M \<and> \<omega> \<in> space (stream_space M)"
  by (simp add: space_stream_space streams_Stream)

lemma stream_space_eq_distr: "stream_space M = distr (\<Pi>\<^sub>M i\<in>UNIV. M) (stream_space M) to_stream"
  unfolding stream_space_def by (rule distr_cong) auto

lemma sets_stream_space_cong[measurable_cong]:
  "sets M = sets N \<Longrightarrow> sets (stream_space M) = sets (stream_space N)"
  using sets_eq_imp_space_eq[of M N] by (simp add: stream_space_def vimage_algebra_def cong: sets_PiM_cong)

lemma measurable_snth_PiM: "(\<lambda>\<omega> n. \<omega> !! n) \<in> measurable (stream_space M) (\<Pi>\<^sub>M i\<in>UNIV. M)"
  by (auto intro!: measurable_vimage_algebra1
           simp: space_PiM streams_iff_sset sset_range image_subset_iff stream_space_def)

lemma measurable_snth[measurable]: "(\<lambda>\<omega>. \<omega> !! n) \<in> measurable (stream_space M) M"
  using measurable_snth_PiM measurable_component_singleton by (rule measurable_compose) simp

lemma measurable_shd[measurable]: "shd \<in> measurable (stream_space M) M"
  using measurable_snth[of 0] by simp

lemma measurable_stream_space2:
  assumes f_snth: "\<And>n. (\<lambda>x. f x !! n) \<in> measurable N M"
  shows "f \<in> measurable N (stream_space M)"
  unfolding stream_space_def measurable_distr_eq2
proof (rule measurable_vimage_algebra2)
  show "f \<in> space N \<rightarrow> streams (space M)"
    using f_snth[THEN measurable_space] by (auto simp add: streams_iff_sset sset_range)
  show "(\<lambda>x. op !! (f x)) \<in> measurable N (Pi\<^sub>M UNIV (\<lambda>i. M))"
  proof (rule measurable_PiM_single')
    show "(\<lambda>x. op !! (f x)) \<in> space N \<rightarrow> UNIV \<rightarrow>\<^sub>E space M"
      using f_snth[THEN measurable_space] by auto
  qed (rule f_snth)
qed

lemma measurable_stream_coinduct[consumes 1, case_names shd stl, coinduct set: measurable]:
  assumes "F f"
  assumes h: "\<And>f. F f \<Longrightarrow> (\<lambda>x. shd (f x)) \<in> measurable N M"
  assumes t: "\<And>f. F f \<Longrightarrow> F (\<lambda>x. stl (f x))"
  shows "f \<in> measurable N (stream_space M)"
proof (rule measurable_stream_space2)
  fix n show "(\<lambda>x. f x !! n) \<in> measurable N M"
    using \<open>F f\<close> by (induction n arbitrary: f) (auto intro: h t)
qed

lemma measurable_sdrop[measurable]: "sdrop n \<in> measurable (stream_space M) (stream_space M)"
  by (rule measurable_stream_space2) (simp add: sdrop_snth)

lemma measurable_stl[measurable]: "(\<lambda>\<omega>. stl \<omega>) \<in> measurable (stream_space M) (stream_space M)"
  by (rule measurable_stream_space2) (simp del: snth.simps add: snth.simps[symmetric])

lemma measurable_to_stream[measurable]: "to_stream \<in> measurable (\<Pi>\<^sub>M i\<in>UNIV. M) (stream_space M)"
  by (rule measurable_stream_space2) (simp add: to_stream_def)

lemma measurable_Stream[measurable (raw)]:
  assumes f[measurable]: "f \<in> measurable N M"
  assumes g[measurable]: "g \<in> measurable N (stream_space M)"
  shows "(\<lambda>x. f x ## g x) \<in> measurable N (stream_space M)"
  by (rule measurable_stream_space2) (simp add: Stream_snth)

lemma measurable_smap[measurable]:
  assumes X[measurable]: "X \<in> measurable N M"
  shows "smap X \<in> measurable (stream_space N) (stream_space M)"
  by (rule measurable_stream_space2) simp

lemma measurable_stake[measurable]:
  "stake i \<in> measurable (stream_space (count_space UNIV)) (count_space (UNIV :: 'a::countable list set))"
  by (induct i) auto

lemma measurable_shift[measurable]:
  assumes f: "f \<in> measurable N (stream_space M)"
  assumes [measurable]: "g \<in> measurable N (stream_space M)"
  shows "(\<lambda>x. stake n (f x) @- g x) \<in> measurable N (stream_space M)"
  using f by (induction n arbitrary: f) simp_all

lemma measurable_case_stream_replace[measurable (raw)]:
  "(\<lambda>x. f x (shd (g x)) (stl (g x))) \<in> measurable M N \<Longrightarrow> (\<lambda>x. case_stream (f x) (g x)) \<in> measurable M N"
  unfolding stream.case_eq_if .

lemma measurable_ev_at[measurable]:
  assumes [measurable]: "Measurable.pred (stream_space M) P"
  shows "Measurable.pred (stream_space M) (ev_at P n)"
  by (induction n) auto

lemma measurable_alw[measurable]:
  "Measurable.pred (stream_space M) P \<Longrightarrow> Measurable.pred (stream_space M) (alw P)"
  unfolding alw_def
  by (coinduction rule: measurable_gfp_coinduct) (auto simp: inf_continuous_def)

lemma measurable_ev[measurable]:
  "Measurable.pred (stream_space M) P \<Longrightarrow> Measurable.pred (stream_space M) (ev P)"
  unfolding ev_def
  by (coinduction rule: measurable_lfp_coinduct) (auto simp: sup_continuous_def)

lemma measurable_until:
  assumes [measurable]: "Measurable.pred (stream_space M) \<phi>" "Measurable.pred (stream_space M) \<psi>"
  shows "Measurable.pred (stream_space M) (\<phi> until \<psi>)"
  unfolding UNTIL_def
  by (coinduction rule: measurable_gfp_coinduct) (simp_all add: inf_continuous_def fun_eq_iff)

lemma measurable_holds [measurable]: "Measurable.pred M P \<Longrightarrow> Measurable.pred (stream_space M) (holds P)"
  unfolding holds.simps[abs_def]
  by (rule measurable_compose[OF measurable_shd]) simp

lemma measurable_hld[measurable]: assumes [measurable]: "t \<in> sets M" shows "Measurable.pred (stream_space M) (HLD t)"
  unfolding HLD_def by measurable

lemma measurable_nxt[measurable (raw)]:
  "Measurable.pred (stream_space M) P \<Longrightarrow> Measurable.pred (stream_space M) (nxt P)"
  unfolding nxt.simps[abs_def] by simp

lemma measurable_suntil[measurable]:
  assumes [measurable]: "Measurable.pred (stream_space M) Q" "Measurable.pred (stream_space M) P"
  shows "Measurable.pred (stream_space M) (Q suntil P)"
  unfolding suntil_def by (coinduction rule: measurable_lfp_coinduct) (auto simp: sup_continuous_def)

lemma measurable_szip:
  "(\<lambda>(\<omega>1, \<omega>2). szip \<omega>1 \<omega>2) \<in> measurable (stream_space M \<Otimes>\<^sub>M stream_space N) (stream_space (M \<Otimes>\<^sub>M N))"
proof (rule measurable_stream_space2)
  fix n
  have "(\<lambda>x. (case x of (\<omega>1, \<omega>2) \<Rightarrow> szip \<omega>1 \<omega>2) !! n) = (\<lambda>(\<omega>1, \<omega>2). (\<omega>1 !! n, \<omega>2 !! n))"
    by auto
  also have "\<dots> \<in> measurable (stream_space M \<Otimes>\<^sub>M stream_space N) (M \<Otimes>\<^sub>M N)"
    by measurable
  finally show "(\<lambda>x. (case x of (\<omega>1, \<omega>2) \<Rightarrow> szip \<omega>1 \<omega>2) !! n) \<in> measurable (stream_space M \<Otimes>\<^sub>M stream_space N) (M \<Otimes>\<^sub>M N)"
    .
qed

lemma (in prob_space) prob_space_stream_space: "prob_space (stream_space M)"
proof -
  interpret product_prob_space "\<lambda>_. M" UNIV ..
  show ?thesis
    by (subst stream_space_eq_distr) (auto intro!: P.prob_space_distr)
qed

lemma (in prob_space) nn_integral_stream_space:
  assumes [measurable]: "f \<in> borel_measurable (stream_space M)"
  shows "(\<integral>\<^sup>+X. f X \<partial>stream_space M) = (\<integral>\<^sup>+x. (\<integral>\<^sup>+X. f (x ## X) \<partial>stream_space M) \<partial>M)"
proof -
  interpret S: sequence_space M ..
  interpret P: pair_sigma_finite M "\<Pi>\<^sub>M i::nat\<in>UNIV. M" ..

  have "(\<integral>\<^sup>+X. f X \<partial>stream_space M) = (\<integral>\<^sup>+X. f (to_stream X) \<partial>S.S)"
    by (subst stream_space_eq_distr) (simp add: nn_integral_distr)
  also have "\<dots> = (\<integral>\<^sup>+X. f (to_stream ((\<lambda>(s, \<omega>). case_nat s \<omega>) X)) \<partial>(M \<Otimes>\<^sub>M S.S))"
    by (subst S.PiM_iter[symmetric]) (simp add: nn_integral_distr)
  also have "\<dots> = (\<integral>\<^sup>+x. \<integral>\<^sup>+X. f (to_stream ((\<lambda>(s, \<omega>). case_nat s \<omega>) (x, X))) \<partial>S.S \<partial>M)"
    by (subst S.nn_integral_fst) simp_all
  also have "\<dots> = (\<integral>\<^sup>+x. \<integral>\<^sup>+X. f (x ## to_stream X) \<partial>S.S \<partial>M)"
    by (auto intro!: nn_integral_cong simp: to_stream_nat_case)
  also have "\<dots> = (\<integral>\<^sup>+x. \<integral>\<^sup>+X. f (x ## X) \<partial>stream_space M \<partial>M)"
    by (subst stream_space_eq_distr)
       (simp add: nn_integral_distr cong: nn_integral_cong)
  finally show ?thesis .
qed

lemma (in prob_space) emeasure_stream_space:
  assumes X[measurable]: "X \<in> sets (stream_space M)"
  shows "emeasure (stream_space M) X = (\<integral>\<^sup>+t. emeasure (stream_space M) {x\<in>space (stream_space M). t ## x \<in> X } \<partial>M)"
proof -
  have eq: "\<And>x xs. xs \<in> space (stream_space M) \<Longrightarrow> x \<in> space M \<Longrightarrow>
      indicator X (x ## xs) = indicator {xs\<in>space (stream_space M). x ## xs \<in> X } xs"
    by (auto split: split_indicator)
  show ?thesis
    using nn_integral_stream_space[of "indicator X"]
    apply (auto intro!: nn_integral_cong)
    apply (subst nn_integral_cong)
    apply (rule eq)
    apply simp_all
    done
qed

lemma (in prob_space) prob_stream_space:
  assumes P[measurable]: "{x\<in>space (stream_space M). P x} \<in> sets (stream_space M)"
  shows "\<P>(x in stream_space M. P x) = (\<integral>\<^sup>+t. \<P>(x in stream_space M. P (t ## x)) \<partial>M)"
proof -
  interpret S: prob_space "stream_space M"
    by (rule prob_space_stream_space)
  show ?thesis
    unfolding S.emeasure_eq_measure[symmetric]
    by (subst emeasure_stream_space) (auto simp: stream_space_Stream intro!: nn_integral_cong)
qed

lemma (in prob_space) AE_stream_space:
  assumes [measurable]: "Measurable.pred (stream_space M) P"
  shows "(AE X in stream_space M. P X) = (AE x in M. AE X in stream_space M. P (x ## X))"
proof -
  interpret stream: prob_space "stream_space M"
    by (rule prob_space_stream_space)

  have eq: "\<And>x X. indicator {x. \<not> P x} (x ## X) = indicator {X. \<not> P (x ## X)} X"
    by (auto split: split_indicator)
  show ?thesis
    apply (subst AE_iff_nn_integral, simp)
    apply (subst nn_integral_stream_space, simp)
    apply (subst eq)
    apply (subst nn_integral_0_iff_AE, simp)
    apply (simp add: AE_iff_nn_integral[symmetric])
    done
qed

lemma (in prob_space) AE_stream_all:
  assumes [measurable]: "Measurable.pred M P" and P: "AE x in M. P x"
  shows "AE x in stream_space M. stream_all P x"
proof -
  { fix n have "AE x in stream_space M. P (x !! n)"
    proof (induct n)
      case 0 with P show ?case
        by (subst AE_stream_space) (auto elim!: eventually_mono)
    next
      case (Suc n) then show ?case
        by (subst AE_stream_space) auto
    qed }
  then show ?thesis
    unfolding stream_all_def by (simp add: AE_all_countable)
qed

lemma streams_sets:
  assumes X[measurable]: "X \<in> sets M" shows "streams X \<in> sets (stream_space M)"
proof -
  have "streams X = {x\<in>space (stream_space M). x \<in> streams X}"
    using streams_mono[OF _ sets.sets_into_space[OF X]] by (auto simp: space_stream_space)
  also have "\<dots> = {x\<in>space (stream_space M). gfp (\<lambda>p x. shd x \<in> X \<and> p (stl x)) x}"
    apply (simp add: set_eq_iff streams_def streamsp_def)
    apply (intro allI conj_cong refl arg_cong2[where f=gfp] ext)
    apply (case_tac xa)
    apply auto
    done
  also have "\<dots> \<in> sets (stream_space M)"
    apply (intro predE)
    apply (coinduction rule: measurable_gfp_coinduct)
    apply (auto simp: inf_continuous_def)
    done
  finally show ?thesis .
qed

lemma sets_stream_space_in_sets:
  assumes space: "space N = streams (space M)"
  assumes sets: "\<And>i. (\<lambda>x. x !! i) \<in> measurable N M"
  shows "sets (stream_space M) \<subseteq> sets N"
  unfolding stream_space_def sets_distr
  by (auto intro!: sets_image_in_sets measurable_Sup2 measurable_vimage_algebra2 del: subsetI equalityI
           simp add: sets_PiM_eq_proj snth_in space sets cong: measurable_cong_sets)

lemma sets_stream_space_eq: "sets (stream_space M) =
    sets (SUP i:UNIV. vimage_algebra (streams (space M)) (\<lambda>s. s !! i) M)"
  by (auto intro!: sets_stream_space_in_sets sets_Sup_in_sets sets_image_in_sets
                   measurable_Sup1 snth_in measurable_vimage_algebra1 del: subsetI
           simp: space_Sup_eq_UN space_stream_space)

lemma sets_restrict_stream_space:
  assumes S[measurable]: "S \<in> sets M"
  shows "sets (restrict_space (stream_space M) (streams S)) = sets (stream_space (restrict_space M S))"
  using  S[THEN sets.sets_into_space]
  apply (subst restrict_space_eq_vimage_algebra)
  apply (simp add: space_stream_space streams_mono2)
  apply (subst vimage_algebra_cong[OF refl refl sets_stream_space_eq])
  apply (subst sets_stream_space_eq)
  apply (subst sets_vimage_Sup_eq[where Y="streams (space M)"])
  apply simp
  apply auto []
  apply (auto intro: streams_mono) []
  apply auto []
  apply (simp add: image_image space_restrict_space)
  apply (simp add: vimage_algebra_cong[OF refl refl restrict_space_eq_vimage_algebra])
  apply (subst (1 2) vimage_algebra_vimage_algebra_eq)
  apply (auto simp: streams_mono snth_in )
  done

primrec sstart :: "'a set \<Rightarrow> 'a list \<Rightarrow> 'a stream set" where
  "sstart S [] = streams S"
| [simp del]: "sstart S (x # xs) = op ## x ` sstart S xs"

lemma in_sstart[simp]: "s \<in> sstart S (x # xs) \<longleftrightarrow> shd s = x \<and> stl s \<in> sstart S xs"
  by (cases s) (auto simp: sstart.simps(2))

lemma sstart_in_streams: "xs \<in> lists S \<Longrightarrow> sstart S xs \<subseteq> streams S"
  by (induction xs) (auto simp: sstart.simps(2))

lemma sstart_eq: "x \<in> streams S \<Longrightarrow> x \<in> sstart S xs = (\<forall>i<length xs. x !! i = xs ! i)"
  by (induction xs arbitrary: x) (auto simp: nth_Cons streams_stl split: nat.splits)

lemma sstart_sets: "sstart S xs \<in> sets (stream_space (count_space UNIV))"
proof (induction xs)
  case (Cons x xs)
  note Cons[measurable]
  have "sstart S (x # xs) =
    {s\<in>space (stream_space (count_space UNIV)). shd s = x \<and> stl s \<in> sstart S xs}"
    by (simp add: set_eq_iff space_stream_space)
  also have "\<dots> \<in> sets (stream_space (count_space UNIV))"
    by measurable
  finally show ?case .
qed (simp add: streams_sets)

lemma sigma_sets_singletons:
  assumes "countable S"
  shows "sigma_sets S ((\<lambda>s. {s})`S) = Pow S"
proof safe
  interpret sigma_algebra S "sigma_sets S ((\<lambda>s. {s})`S)"
    by (rule sigma_algebra_sigma_sets) auto
  fix A assume "A \<subseteq> S"
  with assms have "(\<Union>a\<in>A. {a}) \<in> sigma_sets S ((\<lambda>s. {s})`S)"
    by (intro countable_UN') (auto dest: countable_subset)
  then show "A \<in> sigma_sets S ((\<lambda>s. {s})`S)"
    by simp
qed (auto dest: sigma_sets_into_sp[rotated])

lemma sets_count_space_eq_sigma:
  "countable S \<Longrightarrow> sets (count_space S) = sets (sigma S ((\<lambda>s. {s})`S))"
  by (subst sets_measure_of) (auto simp: sigma_sets_singletons)

lemma sets_stream_space_sstart:
  assumes S[simp]: "countable S"
  shows "sets (stream_space (count_space S)) = sets (sigma (streams S) (sstart S`lists S \<union> {{}}))"
proof
  have [simp]: "sstart S ` lists S \<subseteq> Pow (streams S)"
    by (simp add: image_subset_iff sstart_in_streams)

  let ?S = "sigma (streams S) (sstart S ` lists S \<union> {{}})"
  { fix i a assume "a \<in> S"
    { fix x have "(x !! i = a \<and> x \<in> streams S) \<longleftrightarrow> (\<exists>xs\<in>lists S. length xs = i \<and> x \<in> sstart S (xs @ [a]))"
      proof (induction i arbitrary: x)
        case (Suc i) from this[of "stl x"] show ?case
          by (simp add: length_Suc_conv Bex_def ex_simps[symmetric] del: ex_simps)
             (metis stream.collapse streams_Stream)
      qed (insert \<open>a \<in> S\<close>, auto intro: streams_stl in_streams) }
    then have "(\<lambda>x. x !! i) -` {a} \<inter> streams S = (\<Union>xs\<in>{xs\<in>lists S. length xs = i}. sstart S (xs @ [a]))"
      by (auto simp add: set_eq_iff)
    also have "\<dots> \<in> sets ?S"
      using \<open>a\<in>S\<close> by (intro sets.countable_UN') (auto intro!: sigma_sets.Basic image_eqI)
    finally have " (\<lambda>x. x !! i) -` {a} \<inter> streams S \<in> sets ?S" . }
  then show "sets (stream_space (count_space S)) \<subseteq> sets (sigma (streams S) (sstart S`lists S \<union> {{}}))"
    by (intro sets_stream_space_in_sets) (auto simp: measurable_count_space_eq_countable snth_in)

  have "sigma_sets (space (stream_space (count_space S))) (sstart S`lists S \<union> {{}}) \<subseteq> sets (stream_space (count_space S))"
  proof (safe intro!: sets.sigma_sets_subset)
    fix xs assume "\<forall>x\<in>set xs. x \<in> S"
    then have "sstart S xs = {x\<in>space (stream_space (count_space S)). \<forall>i<length xs. x !! i = xs ! i}"
      by (induction xs)
         (auto simp: space_stream_space nth_Cons split: nat.split intro: in_streams streams_stl)
    also have "\<dots> \<in> sets (stream_space (count_space S))"
      by measurable
    finally show "sstart S xs \<in> sets (stream_space (count_space S))" .
  qed
  then show "sets (sigma (streams S) (sstart S`lists S \<union> {{}})) \<subseteq> sets (stream_space (count_space S))"
    by (simp add: space_stream_space)
qed

lemma Int_stable_sstart: "Int_stable (sstart S`lists S \<union> {{}})"
proof -
  { fix xs ys assume "xs \<in> lists S" "ys \<in> lists S"
    then have "sstart S xs \<inter> sstart S ys \<in> sstart S ` lists S \<union> {{}}"
    proof (induction xs ys rule: list_induct2')
      case (4 x xs y ys)
      show ?case
      proof cases
        assume "x = y"
        then have "sstart S (x # xs) \<inter> sstart S (y # ys) = op ## x ` (sstart S xs \<inter> sstart S ys)"
          by (auto simp: image_iff intro!: stream.collapse[symmetric])
        also have "\<dots> \<in> sstart S ` lists S \<union> {{}}"
          using 4 by (auto simp: sstart.simps(2)[symmetric] del: in_listsD)
        finally show ?case .
      qed auto
    qed (simp_all add: sstart_in_streams inf.absorb1 inf.absorb2 image_eqI[where x="[]"]) }
  then show ?thesis
    by (auto simp: Int_stable_def)
qed

lemma stream_space_eq_sstart:
  assumes S[simp]: "countable S"
  assumes P: "prob_space M" "prob_space N"
  assumes ae: "AE x in M. x \<in> streams S" "AE x in N. x \<in> streams S"
  assumes sets_M: "sets M = sets (stream_space (count_space UNIV))"
  assumes sets_N: "sets N = sets (stream_space (count_space UNIV))"
  assumes *: "\<And>xs. xs \<noteq> [] \<Longrightarrow> xs \<in> lists S \<Longrightarrow> emeasure M (sstart S xs) = emeasure N (sstart S xs)"
  shows "M = N"
proof (rule measure_eqI_restrict_generator[OF Int_stable_sstart])
  have [simp]: "sstart S ` lists S \<subseteq> Pow (streams S)"
    by (simp add: image_subset_iff sstart_in_streams)

  interpret M: prob_space M by fact

  show "sstart S ` lists S \<union> {{}} \<subseteq> Pow (streams S)"
    by (auto dest: sstart_in_streams del: in_listsD)

  { fix M :: "'a stream measure" assume M: "sets M = sets (stream_space (count_space UNIV))"
    have "sets (restrict_space M (streams S)) = sigma_sets (streams S) (sstart S ` lists S \<union> {{}})"
      by (subst sets_restrict_space_cong[OF M])
         (simp add: sets_restrict_stream_space restrict_count_space sets_stream_space_sstart) }
  from this[OF sets_M] this[OF sets_N]
  show "sets (restrict_space M (streams S)) = sigma_sets (streams S) (sstart S ` lists S \<union> {{}})"
       "sets (restrict_space N (streams S)) = sigma_sets (streams S) (sstart S ` lists S \<union> {{}})"
    by auto
  show "{streams S} \<subseteq> sstart S ` lists S \<union> {{}}"
    "\<Union>{streams S} = streams S" "\<And>s. s \<in> {streams S} \<Longrightarrow> emeasure M s \<noteq> \<infinity>"
    using M.emeasure_space_1 space_stream_space[of "count_space S"] sets_eq_imp_space_eq[OF sets_M]
    by (auto simp add: image_eqI[where x="[]"])
  show "sets M = sets N"
    by (simp add: sets_M sets_N)
next
  fix X assume "X \<in> sstart S ` lists S \<union> {{}}"
  then obtain xs where "X = {} \<or> (xs \<in> lists S \<and> X = sstart S xs)"
    by auto
  moreover have "emeasure M (streams S) = 1"
    using ae by (intro prob_space.emeasure_eq_1_AE[OF P(1)]) (auto simp: sets_M streams_sets)
  moreover have "emeasure N (streams S) = 1"
    using ae by (intro prob_space.emeasure_eq_1_AE[OF P(2)]) (auto simp: sets_N streams_sets)
  ultimately show "emeasure M X = emeasure N X"
    using P[THEN prob_space.emeasure_space_1]
    by (cases "xs = []") (auto simp: * space_stream_space del: in_listsD)
qed (auto simp: * ae sets_M del: in_listsD intro!: streams_sets)

lemma sets_sstart[measurable]: "sstart \<Omega> xs \<in> sets (stream_space (count_space UNIV))"
proof (induction xs)
  case (Cons x xs)
  note this[measurable]
  have "sstart \<Omega> (x # xs) = {\<omega>\<in>space (stream_space (count_space UNIV)). \<omega> \<in> sstart \<Omega> (x # xs)}"
    by (auto simp: space_stream_space)
  also have "\<dots> \<in> sets (stream_space (count_space UNIV))"
    unfolding in_sstart by measurable
  finally show ?case .
qed (auto intro!: streams_sets)

primrec scylinder :: "'a set \<Rightarrow> 'a set list \<Rightarrow> 'a stream set"
where
  "scylinder S [] = streams S"
| "scylinder S (A # As) = {\<omega>\<in>streams S. shd \<omega> \<in> A \<and> stl \<omega> \<in> scylinder S As}"

lemma scylinder_streams: "scylinder S xs \<subseteq> streams S"
  by (induction xs) auto

lemma sets_scylinder: "(\<forall>x\<in>set xs. x \<in> sets S) \<Longrightarrow> scylinder (space S) xs \<in> sets (stream_space S)"
  by (induction xs) (auto simp: space_stream_space[symmetric])

lemma stream_space_eq_scylinder:
  assumes P: "prob_space M" "prob_space N"
  assumes "Int_stable G" and S: "sets S = sets (sigma (space S) G)"
    and C: "countable C" "C \<subseteq> G" "\<Union>C = space S" and G: "G \<subseteq> Pow (space S)"
  assumes sets_M: "sets M = sets (stream_space S)"
  assumes sets_N: "sets N = sets (stream_space S)"
  assumes *: "\<And>xs. xs \<noteq> [] \<Longrightarrow> xs \<in> lists G \<Longrightarrow> emeasure M (scylinder (space S) xs) = emeasure N (scylinder (space S) xs)"
  shows "M = N"
proof (rule measure_eqI_generator_eq)
  interpret M: prob_space M by fact
  interpret N: prob_space N by fact

  let ?G = "scylinder (space S) ` lists G"
  show sc_Pow: "?G \<subseteq> Pow (streams (space S))"
    using scylinder_streams by auto

  have "sets (stream_space S) = sets (sigma (streams (space S)) ?G)"
    (is "?S = sets ?R")
  proof (rule antisym)
    let ?V = "\<lambda>i. vimage_algebra (streams (space S)) (\<lambda>s. s !! i) S"
    show "?S \<subseteq> sets ?R"
      unfolding sets_stream_space_eq
    proof (safe intro!: sets_Sup_in_sets del: subsetI equalityI)
      fix i :: nat
      show "space (?V i) = space ?R"
        using scylinder_streams by (subst space_measure_of) (auto simp: )
      { fix A assume "A \<in> G"
        then have "scylinder (space S) (replicate i (space S) @ [A]) = (\<lambda>s. s !! i) -` A \<inter> streams (space S)"
          by (induction i) (auto simp add: streams_shd streams_stl cong: conj_cong)
        also have "scylinder (space S) (replicate i (space S) @ [A]) = (\<Union>xs\<in>{xs\<in>lists C. length xs = i}. scylinder (space S) (xs @ [A]))"
          apply (induction i)
          apply auto []
          apply (simp add: length_Suc_conv set_eq_iff ex_simps(1,2)[symmetric] cong: conj_cong del: ex_simps(1,2))
          apply rule
          subgoal for i x
            apply (cases x)
            apply (subst (2) C(3)[symmetric])
            apply (simp del: ex_simps(1,2) add: ex_simps(1,2)[symmetric] ac_simps Bex_def)
            apply auto
            done
          done
        finally have "(\<lambda>s. s !! i) -` A \<inter> streams (space S) = (\<Union>xs\<in>{xs\<in>lists C. length xs = i}. scylinder (space S) (xs @ [A]))"
          ..
        also have "\<dots> \<in> ?R"
          using C(2) \<open>A\<in>G\<close>
          by (intro sets.countable_UN' countable_Collect countable_lists C)
             (auto intro!: in_measure_of[OF sc_Pow] imageI)
        finally have "(\<lambda>s. s !! i) -` A \<inter> streams (space S) \<in> ?R" . }
      then show "sets (?V i) \<subseteq> ?R"
        apply (subst vimage_algebra_cong[OF refl refl S])
        apply (subst vimage_algebra_sigma[OF G])
        apply (simp add: streams_iff_snth) []
        apply (subst sigma_le_sets)
        apply auto
        done
    qed
    have "G \<subseteq> sets S"
      unfolding S using G by auto
    with C(2) show "sets ?R \<subseteq> ?S"
      unfolding sigma_le_sets[OF sc_Pow] by (auto intro!: sets_scylinder)
  qed
  then show "sets M = sigma_sets (streams (space S)) (scylinder (space S) ` lists G)"
    "sets N = sigma_sets (streams (space S)) (scylinder (space S) ` lists G)"
    unfolding sets_M sets_N by (simp_all add: sc_Pow)

  show "Int_stable ?G"
  proof (rule Int_stableI_image)
    fix xs ys assume "xs \<in> lists G" "ys \<in> lists G"
    then show "\<exists>zs\<in>lists G. scylinder (space S) xs \<inter> scylinder (space S) ys = scylinder (space S) zs"
    proof (induction xs arbitrary: ys)
      case Nil then show ?case
        by (auto simp add: Int_absorb1 scylinder_streams)
    next
      case xs: (Cons x xs)
      show ?case
      proof (cases ys)
        case Nil with xs.hyps show ?thesis
          by (auto simp add: Int_absorb2 scylinder_streams intro!: bexI[of _ "x#xs"])
      next
        case ys: (Cons y ys')
        with xs.IH[of ys'] xs.prems obtain zs where
          "zs \<in> lists G" and eq: "scylinder (space S) xs \<inter> scylinder (space S) ys' = scylinder (space S) zs"
          by auto
        show ?thesis
        proof (intro bexI[of _ "(x \<inter> y)#zs"])
          show "x \<inter> y # zs \<in> lists G"
            using \<open>zs\<in>lists G\<close> \<open>x\<in>G\<close> \<open>ys\<in>lists G\<close> ys \<open>Int_stable G\<close>[THEN Int_stableD, of x y] by auto
          show "scylinder (space S) (x # xs) \<inter> scylinder (space S) ys = scylinder (space S) (x \<inter> y # zs)"
            by (auto simp add: eq[symmetric] ys)
        qed
      qed
    qed
  qed

  show "range (\<lambda>_::nat. streams (space S)) \<subseteq> scylinder (space S) ` lists G"
    "(\<Union>i. streams (space S)) = streams (space S)"
    "emeasure M (streams (space S)) \<noteq> \<infinity>"
    by (auto intro!: image_eqI[of _ _ "[]"])

  fix X assume "X \<in> scylinder (space S) ` lists G"
  then obtain xs where xs: "xs \<in> lists G" and eq: "X = scylinder (space S) xs"
    by auto
  then show "emeasure M X = emeasure N X"
  proof (cases "xs = []")
    assume "xs = []" then show ?thesis
      unfolding eq
      using sets_M[THEN sets_eq_imp_space_eq] sets_N[THEN sets_eq_imp_space_eq]
         M.emeasure_space_1 N.emeasure_space_1
      by (simp add: space_stream_space[symmetric])
  next
    assume "xs \<noteq> []" with xs show ?thesis
      unfolding eq by (intro *)
  qed
qed

lemma stream_space_coinduct:
  fixes R :: "'a stream measure \<Rightarrow> 'a stream measure \<Rightarrow> bool"
  assumes "R A B"
  assumes R: "\<And>A B. R A B \<Longrightarrow> \<exists>K\<in>space (prob_algebra M).
    \<exists>A'\<in>M \<rightarrow>\<^sub>M prob_algebra (stream_space M). \<exists>B'\<in>M \<rightarrow>\<^sub>M prob_algebra (stream_space M).
    (AE y in K. R (A' y) (B' y) \<or> A' y = B' y) \<and>
    A = do { y \<leftarrow> K; \<omega> \<leftarrow> A' y; return (stream_space M) (y ## \<omega>) } \<and>
    B = do { y \<leftarrow> K; \<omega> \<leftarrow> B' y; return (stream_space M) (y ## \<omega>) }"
  shows "A = B"
proof (rule stream_space_eq_scylinder)
  let ?step = "\<lambda>K L. do { y \<leftarrow> K; \<omega> \<leftarrow> L y; return (stream_space M) (y ## \<omega>) }"
  { fix K A A' assume K: "K \<in> space (prob_algebra M)"
      and A'[measurable]: "A' \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)" and A_eq: "A = ?step K A'"
    have ps: "prob_space A"
      unfolding A_eq by (rule prob_space_bind'[OF K]) measurable
    have "sets A = sets (stream_space M)"
      unfolding A_eq by (rule sets_bind'[OF K]) measurable
    note ps this }
  note ** = this

  { fix A B assume "R A B"
    obtain K A' B' where K: "K \<in> space (prob_algebra M)"
      and A': "A' \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)" "A = ?step K A'"
      and B': "B' \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)" "B = ?step K B'"
      using R[OF \<open>R A B\<close>] by blast
    have "prob_space A" "prob_space B" "sets A = sets (stream_space M)" "sets B = sets (stream_space M)"
      using **[OF K A'] **[OF K B'] by auto }
  note R_D = this

  show "prob_space A" "prob_space B" "sets A = sets (stream_space M)" "sets B = sets (stream_space M)"
    using R_D[OF \<open>R A B\<close>] by auto

  show "Int_stable (sets M)" "sets M = sets (sigma (space M) (sets M))" "countable {space M}"
    "{space M} \<subseteq> sets M" "\<Union>{space M} = space M" "sets M \<subseteq> Pow (space M)"
    using sets.space_closed[of M] by (auto simp: Int_stable_def)

  { fix A As L K assume K[measurable]: "K \<in> space (prob_algebra M)" and A: "A \<in> sets M" "As \<in> lists (sets M)"
      and L[measurable]: "L \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)"
    from A have [measurable]: "\<forall>x\<in>set (A # As). x \<in> sets M" "\<forall>x\<in>set As. x \<in> sets M"
      by auto
    have [simp]: "space K = space M" "sets K = sets M"
      using K by (auto simp: space_prob_algebra intro!: sets_eq_imp_space_eq)
    have [simp]: "x \<in> space M \<Longrightarrow> sets (L x) = sets (stream_space M)" for x
      using measurable_space[OF L] by (auto simp: space_prob_algebra)
    note sets_scylinder[measurable]
    have *: "indicator (scylinder (space M) (A # As)) (x ## \<omega>) =
        (indicator A x * indicator (scylinder (space M) As) \<omega> :: ennreal)" for \<omega> x
      using scylinder_streams[of "space M" As] \<open>A \<in> sets M\<close>[THEN sets.sets_into_space]
      by (auto split: split_indicator)
    have "emeasure (?step K L) (scylinder (space M) (A # As)) = (\<integral>\<^sup>+y. L y (scylinder (space M) As) * indicator A y \<partial>K)"
      apply (subst emeasure_bind_prob_algebra[OF K])
      apply measurable
      apply (rule nn_integral_cong)
      apply (subst emeasure_bind_prob_algebra[OF L[THEN measurable_space]])
      apply (simp_all add: ac_simps * nn_integral_cmult_indicator del: scylinder.simps)
      apply measurable
      done }
  note emeasure_step = this

  fix Xs assume "Xs \<in> lists (sets M)"
  from this \<open>R A B\<close> show "emeasure A (scylinder (space M) Xs) = emeasure B (scylinder (space M) Xs)"
  proof (induction Xs arbitrary: A B)
    case (Cons X Xs)
    obtain K A' B' where K: "K \<in> space (prob_algebra M)"
      and A'[measurable]: "A' \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)" and A: "A = ?step K A'"
      and B'[measurable]: "B' \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)" and B: "B = ?step K B'"
      and AE_R: "AE x in K. R (A' x) (B' x) \<or> A' x = B' x"
      using R[OF \<open>R A B\<close>] by blast

    show ?case
      unfolding A B emeasure_step[OF K Cons.hyps A'] emeasure_step[OF K Cons.hyps B']
      apply (rule nn_integral_cong_AE)
      using AE_R by eventually_elim (auto simp add: Cons.IH)
  next
    case Nil
    note R_D[OF this]
    from this(1,2)[THEN prob_space.emeasure_space_1] this(3,4)[THEN sets_eq_imp_space_eq]
    show ?case
      by (simp add: space_stream_space)
  qed
qed

end


theory Chapter9_1
imports "~~/src/HOL/IMP/Types"
begin

text{*
\section*{Chapter 9}

\exercise
Reformulate the inductive predicates \ @{prop"\<Gamma> \<turnstile> a : \<tau>"},
\ @{prop"\<Gamma> \<turnstile> (b::bexp)"} \
and \ \mbox{@{prop"\<Gamma> \<turnstile> (c::com)"}} \ as three recursive functions
*}

fun atype :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty option" where
  "atype \<Gamma> (Ic i) = Some Ity"
| "atype \<Gamma> (Rc i) = Some Rty"
| "atype \<Gamma> (V x) = Some (\<Gamma> x)"
| "atype \<Gamma> (Plus a\<^sub>1 a\<^sub>2) = (if (atype \<Gamma> a\<^sub>1) = (atype \<Gamma> a\<^sub>2) then atype \<Gamma> a\<^sub>1 else None)"

fun bok :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" where
  "bok \<Gamma> (Bc v) = True"
| "bok \<Gamma> (Not b) = bok \<Gamma> b"
| "bok \<Gamma> (And b\<^sub>1 b\<^sub>2) = (bok \<Gamma> b\<^sub>1 \<and> bok \<Gamma> b\<^sub>2)"
| "bok \<Gamma> (Less a\<^sub>1 a\<^sub>2) = (if (atype \<Gamma> a\<^sub>1) = (atype \<Gamma> a\<^sub>2) then (\<exists>a. atype \<Gamma> a\<^sub>1 = Some a) else False)"

fun cok :: "tyenv \<Rightarrow> com \<Rightarrow> bool" where
  "cok \<Gamma> SKIP = True"
| "cok \<Gamma> (x ::= a) = (Some (\<Gamma> x) = atype \<Gamma> a)"
| "cok \<Gamma> (c\<^sub>1;; c\<^sub>2) = (cok \<Gamma> c\<^sub>1 \<and> cok \<Gamma> c\<^sub>2)"
| "cok \<Gamma> (IF b THEN t ELSE e) = (bok \<Gamma> b \<and> cok \<Gamma> t \<and> cok \<Gamma> e)"
| "cok \<Gamma> (WHILE b DO c) = (bok \<Gamma> b \<and> cok \<Gamma> c)"

text{* and prove *}

lemma atyping_atype: "(\<Gamma> \<turnstile> a : \<tau>) = (atype \<Gamma> a = Some \<tau>)"
by (induction a; auto)

lemma btyping_bok: "(\<Gamma> \<turnstile> b) = bok \<Gamma> b"
by (induction b; auto simp add: atyping_atype)

lemma ctyping_cok: "(\<Gamma> \<turnstile> c) = cok \<Gamma> c"
by (induction c; auto simp add: atyping_atype btyping_bok)

text{*
\endexercise

\exercise
Modify the evaluation and typing of @{typ aexp} by allowing @{typ int}s to be coerced
to @{typ real}s with the predefined coercion function
\noquotes{@{term[source] "int_to_real :: int \<Rightarrow> real"}} where necessary.
Now every @{typ aexp} has a value. Define an evaluation function:
*}

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (Ic i) s = (Iv i)"
| "aval (Rc r) s = (Rv r)"
| "aval (V x) s = s x"
| "aval (Plus a\<^sub>1 a\<^sub>2) s =
    (case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
      (Iv i\<^sub>1, Iv i\<^sub>2) \<Rightarrow> Iv (i\<^sub>1 + i\<^sub>2)
    | (Rv r\<^sub>1, Rv r\<^sub>2) \<Rightarrow> Rv (r\<^sub>1 + r\<^sub>2)
    | (Rv r, Iv i) \<Rightarrow> Rv (r + i)
    | (Iv i, Rv r) \<Rightarrow> Rv (i + r))"

text{*
Similarly, every @{typ aexp} has a type.
Define a function that computes the type of an @{typ aexp}
*}

fun atyp :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty" where
  "atyp \<Gamma> (Ic i) = Ity"
| "atyp \<Gamma> (Rc r) = Rty"
| "atyp \<Gamma> (V x) = \<Gamma> x"
| "atyp \<Gamma> (Plus a\<^sub>1 a\<^sub>2) = (case (atyp \<Gamma> a\<^sub>1, atyp \<Gamma> a\<^sub>2) of
    (Ity, Ity) \<Rightarrow> Ity
  | (Rty, Rty) \<Rightarrow> Rty
  | (Rty, Ity) \<Rightarrow> Rty
  | (Ity, Rty) \<Rightarrow> Rty)"

text{* and prove that it computes the correct type: *}

lemma
atyp_plus:
fixes \<Gamma> s a1 a2
assumes "atyp \<Gamma> a1 = type (aval a1 s)"
    and "atyp \<Gamma> a2 = type (aval a2 s)"
    and "\<forall>x. type (s x) = \<Gamma> x"
shows "(case type (aval a1 s) of Ity \<Rightarrow> case type (aval a2 s) of Ity \<Rightarrow> Ity | Rty \<Rightarrow> Rty
                  | Rty \<Rightarrow> case type (aval a2 s) of Ity \<Rightarrow> Rty | _ \<Rightarrow> Rty) =
                 type (case aval a1 s of Iv i\<^sub>1 \<Rightarrow> case aval a2 s of Iv i\<^sub>2 \<Rightarrow> Iv (i\<^sub>1 + i\<^sub>2) | Rv r \<Rightarrow> Rv (real_of_int i\<^sub>1 + r)
                       | Rv r\<^sub>1 \<Rightarrow> case aval a2 s of Iv i \<Rightarrow> Rv (r\<^sub>1 + real_of_int i) | Rv r\<^sub>2 \<Rightarrow> Rv (r\<^sub>1 + r\<^sub>2))"
by (smt ty.exhaust ty.simps(3) ty.simps(4) type_eq_Ity type_eq_Rty val.simps(5) val.simps(6))

lemma  "\<Gamma> \<turnstile> s \<Longrightarrow>  atyp \<Gamma> a = type (aval a s)"
by (induction a; auto simp add: styping_def atyp_plus)

text{*
Note that Isabelle inserts the coercion @{typ real} automatically.
For example, if you write @{term "Rv(i+r)"} where @{text"i::  int"} and
@{text "r :: real"} then it becomes @{term "Rv(real i + x)"}.
\endexercise
\bigskip

For the following two exercises copy theory @{theory Types} and modify it as required.

\begin{exercise}
Add a @{text REPEAT} loop (see Exercise~\ref{exe:IMP:REPEAT}) to the typed version of IMP
and update the type soundness proof.
\end{exercise}

\begin{exercise}
Modify the typed version of IMP as follows. Values are now either integers or booleans.
Thus variables can have boolean values too. Merge the two expressions types
@{typ aexp} and @{typ bexp} into one new type @{text exp} of expressions
that has the constructors of both types (of course without real constants).
Combine @{const taval} and @{const tbval} into one evaluation predicate
@{text "eval :: exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}. Similarly combine the two typing predicates
into one: @{text "\<Gamma> \<turnstile> e : \<tau>"} where @{text "e :: exp"} and the IMP-type @{text \<tau>} can
be one of @{text Ity} or @{text Bty}.
Adjust the small-step semantics and the type soundness proof.
\end{exercise}
*}

end