theory Decentralised_Model imports
  CryptHOL.CryptHOL
begin

type_synonym ('token_pub', 'token_sec') token = "('token_pub' \<times> 'token_sec')"

type_synonym ('user', 'query_out') query = "'user' \<Rightarrow> 'query_out'"

type_synonym ('store_non_sens_attrs', 'store_sens_attrs') govt_store_data = "'store_non_sens_attrs' set \<times> 'store_sens_attrs' set"

locale decentralised_id =
  fixes reg :: "'user \<Rightarrow> (('token_pub, 'token_sec) token \<times> ('store_non_sens_attrs, 'store_sens_attrs) govt_store_data) spmf"
    and auth :: "('token_pub, 'token_sec) token \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> 'query_out spmf"
    and valid_user :: "'user \<Rightarrow> bool"
    and valid_query :: "('user, 'query_out) query \<Rightarrow> bool"
  assumes lossless_reg: "lossless_spmf (reg user)"
begin

definition correct_game :: "'user \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> bool spmf"
  where
    "correct_game user query = do {
      (token, govt_output) \<leftarrow> reg user;
      result \<leftarrow> auth token query;
      return_spmf (result = query user)}"

definition "correct \<longleftrightarrow> (\<forall> user query. valid_user user \<longrightarrow> valid_query query
                            \<longrightarrow> spmf (correct_game user query) True = 1)"

primrec sens_attrs_hiding_game :: "((('user \<times> 'user) \<times> 'state) spmf \<times> ('state \<Rightarrow> 'store_sens_attrs set \<Rightarrow> bool spmf)) \<Rightarrow> bool spmf"
  where
    "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b \<leftarrow> coin_spmf;
      (card, (non_sens_attrs, sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"

definition "sens_attrs_hiding_advantage \ = \<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar>"

definition "perfect_sens_attrs_hiding \ \<longleftrightarrow> sens_attrs_hiding_advantage \ = 0"

lemma no_sens_attrs_imp_perfect_sens_attrs_hiding:
  assumes "\<forall> user token store_non_sens_attr store_sens_attr. (token, store_non_sens_attr, store_sens_attr) \<in> set_spmf (reg user) \<longrightarrow> store_sens_attr = {}"
  shows "perfect_sens_attrs_hiding \"
proof-
  note [simp] = Let_def split_def
  have "\<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar> = 0"
  proof-
    obtain \1 and \2 where \ [simp]: "\ = (\1, \2)" by(cases \)
    have "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (card, (store_non_sens_attrs, store_sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> store_sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: sens_attrs_hiding_game_def)
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (card, (store_non_sens_attrs, store_sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> {};
      return_spmf (b' = b)} ELSE coin_spmf"
      apply auto
      apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
      using assms by blast
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b' \<leftarrow> \2 \<sigma> {};
      map_spmf((=) b') coin_spmf} ELSE coin_spmf"
      including monad_normalisation
      by(simp add: bind_spmf_const lossless_reg lossless_weight_spmfD map_spmf_conv_bind_spmf)
    also have "... = coin_spmf"
      by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
    ultimately show ?thesis
      by(simp add: spmf_of_set)
  qed
  thus ?thesis
    by(simp add: perfect_sens_attrs_hiding_def sens_attrs_hiding_advantage_def)
qed

primrec token_sec_hiding_game :: "((('user \<times> 'user) \<times> 'state) spmf) \<times> ('state \<Rightarrow> 'token_sec \<Rightarrow> bool spmf) \<Rightarrow> bool spmf"
  where
    "token_sec_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      b \<leftarrow> coin_spmf;
      ((token_pubb, token_secb), govt_storeb) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> token_secb;
      return_spmf (b' = b)} ELSE coin_spmf"

definition "token_sec_hiding_advantage \ = \<bar>spmf (token_sec_hiding_game \) True - 1/2\<bar>"

definition "perfect_token_sec_hiding \ \<longleftrightarrow> token_sec_hiding_advantage \ = 0"

end

end


(*<*)
\<comment>\<open> ********************************************************************
 * Project         : AGM Theory
 * Version         : 1.0
 *
 * Authors         : Valentin Fouillard, Safouan Taha, Frederic Boulanger
                     and Nicolas Sabouret
 *
 * This file       : AGM logics
 *
 * Copyright (c) 2021 Université Paris Saclay, France
 *
 ******************************************************************************\<close>

theory AGM_Logic

imports Main

begin
(*>*)

section \<open>Introduction\<close>

text\<open>
The 1985 paper by Carlos Alchourrón, Peter Gärdenfors,
and David Makinson (AGM), ``On the Logic of Theory Change: Partial Meet
Contraction and Revision Functions'' \<^cite>\<open>"alchourron1985logic"\<close> launches a large and
rapidly growing literature that employs formal models and logics to handle changing beliefs of a rational agent
and to take into account new piece of information observed by this agent.
In 2011, a review book titled "AGM 25 Years: Twenty-Five Years of Research in Belief Change"
was edited to summarize the first twenty five years of works based on AGM
\<^cite>\<open>"Ferme2011"\<close>.

According to Google Scholar, the original AGM paper was cited 4000 times!
This AFP entry is HOL-based and it is a faithful formalization of the logic operators (e.g. contraction, revision, remainder \dots )
axiomatized in the AGM paper. It also contains the proofs of all the theorems stated in the paper that show how these operators combine.
Both proofs of Harper and Levi identities are established.
\<close>

text\<open>A belief state can be considered as a consistent set of beliefs (logical propositions) closed under logical reasoning.
Belief changes represent the operations that apply on a belief state to remove some of it and/or to add new beliefs (propositions).
In the latter case, it is possible that other beliefs are affected by these changes (to preserve consistency for example).
AGM define several postulates to guarantee that such operations preserve consistency meaning that the agent keeps rational.
Three kinds of operators are defined :
\<^item> The contraction @{text \<open>\<div>\<close>} : where a proposition is removed from a belief set
\<^item> The expansion @{text \<open>\<oplus>\<close>} : where a proposition is added to a belief set
\<^item> The revision @{text \<open>\<^bold>*\<close>} : where a proposition is added to a belief set such that the belief set remains consistent
\<close>

text\<open>In this AFP entry, there are three theory files:
\<^enum> The AGM Logic file contains a classification of logics used in the AGM framework.
\<^enum> The AGM Remainder defines a important operator used in the AGM framework.
\<^enum> The AGM Contraction file contains the postulates of the AGM contraction and its relation with the meet contraction.
\<^enum> The AGM Revision file contains the postulates of the AGM revision and its relation with the meet revision.
\<close>

section \<open>Logics\<close>

text\<open>The AGM framework depends on the underlying logic used to express beliefs. AGM requires at least a Tarskian propositional calculus.
If this logic is also supra-classical and/or compact, new properties are established and the main theorems of AGM are strengthened.
To model AGM it is therefore important to start by formalizing this underlying logic and its various extensions.
We opted for a deep embedding in HOL which required the redefinition of all the logical operators and an axiomatization of their rules.
This is certainly not efficient in terms of proof but it gives a total control of our formalization and an assurance
that the logic used has no hidden properties depending on the Isabelle/HOL implementation.
We use the Isabelle \<^emph>\<open>locales\<close> feature and we take advantage of the inheritance/extension mechanisms between locales.\<close>

subsection \<open>Tarskian Logic\<close>

text \<open>
The first locale formalizes a Tarskian logic based on the famous Tarski's consequence operator: @{term \<open>Cn(A)\<close>}
which gives the set of all propositions (\<^bold>\<open>closure\<close>) that can be inferred from the set of propositions @{term \<open>A\<close>},
Exactly as it is classically axiomatized in the literature, three assumptions of the locale define the consequence operator.
\<close>
locale Tarskian_logic =
fixes Cn::\<open>'a set \<Rightarrow> 'a set\<close>
assumes monotonicity_L:     \<open>A \<subseteq> B \<Longrightarrow> Cn(A) \<subseteq> Cn(B)\<close>
    and inclusion_L:        \<open>A \<subseteq> Cn(A)\<close>
    and transitivity_L:     \<open>Cn(Cn(A)) \<subseteq> Cn(A)\<close>

\<comment> \<open>
  Short notation for ``@{term \<open>\<phi>\<close>} can be inferred from the propositions in @{term \<open>A\<close>}''.
\<close>
fixes infer::\<open>'a set \<Rightarrow> 'a \<Rightarrow> bool\<close>  (infix \<open>\<turnstile>\<close> 50)
defines \<open>A \<turnstile> \<phi> \<equiv> \<phi> \<in> Cn(A)\<close>

\<comment> \<open>
  @{term \<open>\<phi>\<close>} is valid (a tautology) if it can be inferred from nothing.
\<close>
fixes valid::\<open>'a \<Rightarrow> bool\<close>            (\<open>\<tturnstile>\<close>)
defines \<open>\<tturnstile> \<phi> \<equiv> {} \<turnstile> \<phi>\<close>

\<comment> \<open>
  @{term \<open>A \<oplus> \<phi>\<close>} is all that can be infered from  @{term \<open>A\<close>} and  @{term \<open>\<phi>\<close>}.
\<close>
fixes expansion::\<open>'a set \<Rightarrow> 'a \<Rightarrow> 'a set\<close> (infix \<open>\<oplus>\<close> 57)
defines \<open>A \<oplus> \<phi> \<equiv> Cn(A \<union> {\<phi>})\<close>

begin

lemma idempotency_L: \<open>Cn(Cn(A)) = Cn(A)\<close>
  by (simp add: inclusion_L transitivity_L subset_antisym)

lemma assumption_L: \<open>\<phi> \<in> A \<Longrightarrow> A \<turnstile> \<phi>\<close>
  using inclusion_L infer_def by blast

lemma validD_L: \<open>\<tturnstile> \<phi> \<Longrightarrow> \<phi> \<in> Cn(A)\<close>
  using monotonicity_L valid_def infer_def by fastforce

lemma valid_expansion: \<open>K = Cn(A) \<Longrightarrow> \<tturnstile> \<phi> \<Longrightarrow> K \<oplus> \<phi> = K\<close>
  by (simp add: idempotency_L insert_absorb validD_L valid_def expansion_def)

lemma transitivity2_L:
  assumes \<open>\<forall>\<phi> \<in> B. A \<turnstile> \<phi>\<close>
      and \<open>B \<turnstile> \<psi>\<close>
    shows \<open>A \<turnstile> \<psi>\<close>
proof -
  from assms(1) have \<open>B \<subseteq> Cn(A)\<close> by (simp add: infer_def subsetI)
  hence \<open>Cn(B) \<subseteq> Cn(A)\<close>  using idempotency_L monotonicity_L by blast
  moreover from assms(2) have \<open>\<psi> \<in> Cn(B)\<close> by (simp add: infer_def)
  ultimately show ?thesis using infer_def by blast
qed

lemma Cn_same: \<open>(Cn(A) = Cn(B)) \<longleftrightarrow> (\<forall>C. A \<subseteq> Cn(C) \<longleftrightarrow> B \<subseteq> Cn(C))\<close>
proof
  { assume h:\<open>Cn(A) = Cn(B)\<close>
    from h have \<open>\<forall>\<phi> \<in> B. A \<turnstile> \<phi>\<close>
      by (simp add: Tarskian_logic.assumption_L Tarskian_logic_axioms infer_def)
    moreover from h[symmetric] have \<open>\<forall>\<phi> \<in> A. B \<turnstile> \<phi>\<close>
      by (simp add: Tarskian_logic.assumption_L Tarskian_logic_axioms infer_def)
    ultimately have \<open>\<forall>C. A \<subseteq> Cn(C) \<longleftrightarrow> B \<subseteq> Cn(C)\<close>
      using h idempotency_L inclusion_L monotonicity_L by blast
  } thus \<open>Cn(A) = Cn(B) \<Longrightarrow> \<forall>C. (A \<subseteq> Cn(C)) = (B \<subseteq> Cn(C))\<close> .
next
  { assume h:\<open>\<forall>C. (A \<subseteq> Cn(C)) = (B \<subseteq> Cn(C))\<close>
    from h have \<open>(A \<subseteq> Cn(A)) = (B \<subseteq> Cn(A))\<close> and \<open>(A \<subseteq> Cn(B)) = (B \<subseteq> Cn(B))\<close> by simp+
    hence \<open>B \<subseteq> Cn(A)\<close> and \<open>A \<subseteq> Cn(B)\<close> by (simp add: inclusion_L)+
    hence \<open>Cn(A) = Cn(B)\<close>
      using idempotency_L monotonicity_L by blast
  } thus \<open>(\<forall>C. (A \<subseteq> Cn(C)) = (B \<subseteq> Cn(C))) \<Longrightarrow> Cn(A) = Cn(B)\<close> .
qed

\<comment> \<open>
The closure of the union of two consequence closures.
\<close>
lemma Cn_union: \<open>Cn(Cn(A) \<union> Cn(B)) = Cn(A \<union> B)\<close>
proof
  have \<open>Cn(Cn(A) \<union> Cn(B)) \<subseteq> Cn(Cn (A \<union> B))\<close> by (simp add: monotonicity_L)
  thus \<open>Cn(Cn(A) \<union> Cn(B)) \<subseteq> Cn(A \<union> B)\<close> by (simp add: idempotency_L)
next
  have \<open>(A \<union> B) \<subseteq> (Cn(A) \<union> Cn(B))\<close> using inclusion_L by blast
  thus \<open>Cn(A \<union> B) \<subseteq> Cn(Cn(A) \<union> Cn(B))\<close> by (simp add: monotonicity_L)
qed

\<comment> \<open>
The closure of an infinite union of consequence closures.
\<close>
lemma Cn_Union: \<open>Cn(\<Union>{Cn(B)|B. P B}) = Cn(\<Union>{B. P B})\<close> (is \<open>?A = ?B\<close>)
proof
  have \<open>?A \<subseteq> Cn ?B\<close>
    apply(rule monotonicity_L, rule Union_least, auto)
    by (metis Sup_upper in_mono mem_Collect_eq monotonicity_L)
  then show \<open>?A \<subseteq> ?B\<close>
    by (simp add: idempotency_L)
next
  show \<open>?B \<subseteq> ?A\<close>
    by (metis (mono_tags, lifting) Union_subsetI inclusion_L mem_Collect_eq monotonicity_L)
qed

\<comment> \<open>
The intersection of two closures is closed.
\<close>
lemma Cn_inter: \<open>K = Cn(A) \<inter> Cn(B) \<Longrightarrow> K = Cn(K)\<close>
proof -
  { fix K assume h:\<open>K = Cn(A) \<inter> Cn(B)\<close>
    from h have \<open>K \<subseteq> Cn(A)\<close> and \<open>K \<subseteq> Cn(B)\<close> by simp+
    hence \<open>Cn(K) \<subseteq> Cn(A)\<close> and \<open>Cn(K) \<subseteq> Cn(B)\<close> using idempotency_L monotonicity_L by blast+
    hence \<open>Cn(K) \<subseteq> Cn(A) \<inter> Cn(B)\<close> by simp
    with h have \<open>K = Cn(K)\<close> by (simp add: inclusion_L subset_antisym)
  } thus \<open>K = Cn(A) \<inter> Cn(B) \<Longrightarrow> K = Cn(K)\<close> .
qed

\<comment> \<open>
An infinite intersection of closures is closed.
\<close>
lemma Cn_Inter: \<open>K = \<Inter>{Cn(B)|B. P B} \<Longrightarrow> K = Cn(K)\<close>
proof -
  { fix K assume h:\<open>K = \<Inter>{Cn(B)|B. P B}\<close>
    from h have \<open>\<forall>B. P B \<longrightarrow> K \<subseteq> Cn(B)\<close> by blast
    hence \<open>\<forall>B. P B \<longrightarrow> Cn(K) \<subseteq> Cn(B)\<close> using idempotency_L monotonicity_L by blast
    hence \<open>Cn(K) \<subseteq> \<Inter>{Cn(B)|B. P B}\<close> by blast
    with h have \<open>K = Cn(K)\<close> by (simp add: inclusion_L subset_antisym)
  } thus \<open>K = \<Inter>{Cn(B)|B. P B} \<Longrightarrow> K = Cn(K)\<close> .
qed

end

subsection \<open>Supraclassical Logic\<close>

text \<open>
A Tarskian logic has only one abstract operator catching the notion of consequence. A basic case of such a logic is a \<^bold>\<open>Supraclassical\<close> logic that
is a logic with all classical propositional operators (e.g. conjunction (\<open>\<and>\<close>), implication(\<open>\<longrightarrow>\<close>), negation (\<open>\<not>\<close>) \dots ) together with their classical semantics.

We define a new locale. In order to distinguish the propositional operators of our supraclassical logic from those of Isabelle/HOL, we use dots (e.g. \<open>.\<and>.\<close> stands for conjunction).
We axiomatize the introduction and elimination rules of each operator as it is commonly established in the classical literature. As explained before,
we give priority to a complete control of our logic instead of an efficient shallow embedding in Isabelle/HOL.
\<close>

locale Supraclassical_logic = Tarskian_logic +

fixes true_PL::   \<open>'a\<close>             (\<open>\<top>\<close>)
  and false_PL::  \<open>'a\<close>             (\<open>\<bottom>\<close>)
  and imp_PL::    \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<longrightarrow>.\<close> 55)
  and not_PL::    \<open>'a \<Rightarrow> 'a\<close>       (\<open>.\<not>\<close>)
  and conj_PL::   \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<and>.\<close> 55)
  and disj_PL::   \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<or>.\<close> 55)
  and equiv_PL::  \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<longleftrightarrow>.\<close> 55)

assumes true_PL:     \<open>A \<turnstile> \<top>\<close>

    and false_PL:    \<open>{\<bottom>} \<turnstile> p\<close>

    and impI_PL:     \<open>A \<union> {p} \<turnstile> q \<Longrightarrow> A \<turnstile> (p .\<longrightarrow>. q)\<close>
    and mp_PL:       \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> p \<Longrightarrow> A \<turnstile> q\<close>

    and notI_PL:     \<open>A \<turnstile> p .\<longrightarrow>. \<bottom> \<Longrightarrow> A \<turnstile> .\<not> p\<close>
    and notE_PL:     \<open>A \<turnstile> .\<not> p \<Longrightarrow> A \<turnstile> (p .\<longrightarrow>. \<bottom>)\<close>

    and conjI_PL:    \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> q \<Longrightarrow> A \<turnstile> (p .\<and>. q)\<close>
    and conjE1_PL:   \<open>A \<turnstile> p .\<and>. q \<Longrightarrow> A \<turnstile> p\<close>
    and conjE2_PL:   \<open>A \<turnstile> p .\<and>. q \<Longrightarrow> A \<turnstile> q\<close>

    and disjI1_PL:   \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> (p .\<or>. q)\<close>
    and disjI2_PL:   \<open>A \<turnstile> q \<Longrightarrow> A \<turnstile> (p .\<or>. q)\<close>
    and disjE_PL:    \<open>A \<turnstile> p .\<or>. q \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> q.\<longrightarrow>. r \<Longrightarrow> A \<turnstile> r\<close>

    and equivI_PL:   \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> q .\<longrightarrow>. p \<Longrightarrow> A \<turnstile> (p .\<longleftrightarrow>. q)\<close>
    and equivE1_PL:  \<open>A \<turnstile> p .\<longleftrightarrow>. q \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. q\<close>
    and equivE2_PL:  \<open>A \<turnstile> p .\<longleftrightarrow>. q \<Longrightarrow> A \<turnstile> q .\<longrightarrow>. p\<close>

\<comment> \<open>non intuitionistic rules\<close>
    and absurd_PL:   \<open>A \<turnstile> .\<not> (.\<not> p) \<Longrightarrow> A \<turnstile> p\<close>
    and ex_mid_PL:   \<open>A \<turnstile> p .\<or>. (.\<not> p)\<close>

begin

text \<open>In the following, we will first retrieve the classical logic operators semantics coming from previous introduction and elimination rules\<close>

lemma non_consistency:
  assumes \<open>A \<turnstile> .\<not> p\<close>
      and \<open>A \<turnstile> p\<close>
    shows \<open>A \<turnstile> q\<close>
  by (metis assms(1) assms(2) false_PL mp_PL notE_PL singleton_iff transitivity2_L)

\<comment> \<open>this direct result brings directly many remarkable properties of implication (i.e. transitivity)\<close>
lemma imp_PL: \<open>A \<turnstile> p .\<longrightarrow>. q \<longleftrightarrow> A \<union> {p} \<turnstile> q\<close>
  apply (intro iffI impI_PL)
   apply(rule mp_PL[where p=p], meson UnI1 assumption_L transitivity2_L)
  using assumption_L by auto

lemma not_PL: \<open>A \<turnstile> .\<not> p \<longleftrightarrow> A \<union> {p} \<turnstile> \<bottom>\<close>
  using notE_PL notI_PL imp_PL by blast

\<comment> \<open>Classical logic result\<close>
lemma notnot_PL: \<open>A \<turnstile> .\<not> (.\<not> p) \<longleftrightarrow> A \<turnstile> p\<close>
  apply(rule iffI, simp add:absurd_PL)
  by (meson mp_PL notE_PL Un_upper1 Un_upper2 assumption_L infer_def monotonicity_L not_PL singletonI subsetD)

lemma conj_PL: \<open>A \<turnstile> p .\<and>. q \<longleftrightarrow> (A \<turnstile> p \<and> A \<turnstile> q)\<close>
  using conjE1_PL conjE2_PL conjI_PL by blast

lemma disj_PL: \<open>A \<turnstile> p .\<or>. q \<longleftrightarrow> A \<union> {.\<not> p} \<turnstile> q\<close>
proof
  assume a:\<open>A \<turnstile> p .\<or>. q\<close>
  have b:\<open>A \<turnstile> p .\<longrightarrow>. (.\<not> p .\<longrightarrow>. q)\<close>
    by (intro impI_PL) (meson Un_iff assumption_L insertI1 non_consistency)
  have c:\<open>A \<turnstile> q .\<longrightarrow>. (.\<not> p .\<longrightarrow>. q)\<close>
    by (simp add: assumption_L impI_PL)
  from a b c have \<open>A \<turnstile> .\<not> p .\<longrightarrow>. q\<close>
    by (erule_tac disjE_PL) simp_all
  then show \<open>A \<union> {.\<not> p} \<turnstile> q\<close>
    using imp_PL by blast
next
  assume a:\<open>A \<union> {.\<not> p} \<turnstile> q\<close>
  hence b:\<open>A \<turnstile> .\<not> p .\<longrightarrow>. q\<close> by (simp add: impI_PL)
  then show \<open>A \<turnstile> p .\<or>. q\<close>
    apply(rule_tac disjE_PL[OF ex_mid_PL, of A p \<open>p .\<or>. q\<close>])
    by (auto simp add: assumption_L disjI2_PL disjI1_PL impI_PL imp_PL)
qed

lemma equiv_PL:\<open>A \<turnstile> p .\<longleftrightarrow>. q \<longleftrightarrow> (A \<union> {p} \<turnstile> q \<and> A \<union> {q} \<turnstile> p)\<close>
  using imp_PL equivE1_PL equivE2_PL equivI_PL by blast

corollary valid_imp_PL:  \<open>\<tturnstile> (p .\<longrightarrow>. q) = ({p} \<turnstile> q)\<close>
      and valid_not_PL:  \<open>\<tturnstile> (.\<not> p) = ({p} \<turnstile> \<bottom>)\<close>
      and valid_conj_PL: \<open>\<tturnstile> (p .\<and>. q) = (\<tturnstile> p \<and> \<tturnstile> q)\<close>
      and valid_disj_PL: \<open>\<tturnstile> (p .\<or>. q) = ({.\<not> p} \<turnstile> q)\<close>
      and valid_equiv_PL:\<open>\<tturnstile> (p .\<longleftrightarrow>. q) = ({p} \<turnstile> q \<and> {q} \<turnstile> p)\<close>
  using imp_PL not_PL conj_PL disj_PL equiv_PL valid_def by auto

text\<open>Second, we will combine each logical operator with the consequence operator \<open>Cn\<close>: it is a trick to profit from set theory to get many essential
lemmas without complex inferences\<close>
declare infer_def[simp]

lemma nonemptyCn: \<open>Cn(A) \<noteq> {}\<close>
  using true_PL by auto

lemma Cn_true: \<open>Cn({\<top>}) = Cn({})\<close>
  using Cn_same true_PL by auto

lemma Cn_false: \<open>Cn({\<bottom>}) = UNIV\<close>
  using false_PL by auto

lemma Cn_imp:     \<open>A \<turnstile> (p .\<longrightarrow>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn(A \<union> {p})\<close>
  and Cn_imp_bis: \<open>A \<turnstile> (p .\<longrightarrow>. q) \<longleftrightarrow> Cn(A \<union> {q}) \<subseteq> Cn(A \<union> {p})\<close>
  using Cn_same imp_PL idempotency_L inclusion_L infer_def subset_insertI by force+

lemma Cn_not: \<open>A \<turnstile> .\<not> p \<longleftrightarrow> Cn(A \<union> {p}) = UNIV\<close>
  using Cn_false Cn_imp notE_PL not_PL by fastforce

lemma Cn_conj: \<open>A \<turnstile> (p .\<and>. q) \<longleftrightarrow> Cn({p}) \<union> Cn({q}) \<subseteq> Cn(A)\<close>
  apply(intro iffI conjI_PL, frule conjE1_PL, frule conjE2_PL)
  using Cn_same Un_insert_right bot.extremum idempotency_L inclusion_L by auto

lemma Cn_conj_bis: \<open>Cn({p .\<and>. q}) = Cn({p, q})\<close>
  by (unfold Cn_same)
     (meson Supraclassical_logic.conj_PL Supraclassical_logic_axioms insert_subset)

lemma Cn_disj:     \<open>A \<turnstile> (p .\<or>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn(A \<union> {.\<not> p})\<close>
  and Cn_disj_bis: \<open>A \<turnstile> (p .\<or>. q) \<longleftrightarrow> Cn(A \<union> {q}) \<subseteq> Cn(A \<union> {.\<not> p})\<close>
  using disj_PL Cn_same imp_PL idempotency_L inclusion_L infer_def subset_insertI by force+

lemma Cn_equiv: \<open>A \<turnstile> (p .\<longleftrightarrow>. q) \<longleftrightarrow> Cn(A \<union> {p}) = Cn(A \<union> {q})\<close>
  by (metis Cn_imp_bis equivE1_PL equivE2_PL equivI_PL set_eq_subset)

corollary valid_nonemptyCn: \<open>Cn({}) \<noteq> {}\<close>
      and valid_Cn_imp:     \<open>\<tturnstile> (p .\<longrightarrow>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn({p})\<close>
      and valid_Cn_not:     \<open>\<tturnstile> (.\<not> p) \<longleftrightarrow> Cn({p}) = UNIV\<close>
      and valid_Cn_conj:    \<open>\<tturnstile> (p .\<and>. q) \<longleftrightarrow> Cn({p}) \<union> Cn({q}) \<subseteq> Cn({})\<close>
      and valid_Cn_disj:    \<open>\<tturnstile> (p .\<or>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn({.\<not> p})\<close>
      and valid_Cn_equiv:   \<open>\<tturnstile> (p .\<longleftrightarrow>. q) \<longleftrightarrow> Cn({p}) = Cn({q})\<close>
  using nonemptyCn Cn_imp Cn_not Cn_conj Cn_disj Cn_equiv valid_def by auto

\<comment> \<open>Finally, we group additional lemmas that were essential in further proofs\<close>
lemma consistency: \<open>Cn({p}) \<inter> Cn({.\<not> p}) = Cn({})\<close>
proof
  { fix q
    assume \<open>{p} \<turnstile> q\<close> and \<open>{.\<not> p} \<turnstile> q\<close>
    hence "{} \<turnstile> p .\<longrightarrow>. q" and "{} \<turnstile> (.\<not> p) .\<longrightarrow>. q"
      using impI_PL by auto
    hence \<open>{} \<turnstile> q\<close>
      using ex_mid_PL by (rule_tac disjE_PL[where p=p and q=\<open>.\<not> p\<close>]) blast
  }
  then show \<open>Cn({p}) \<inter> Cn({.\<not> p}) \<subseteq> Cn({})\<close> by (simp add: subset_iff)
next
  show \<open>Cn({}) \<subseteq> Cn({p}) \<inter> Cn({.\<not> p})\<close> by (simp add: monotonicity_L)
qed

lemma Cn_notnot: \<open>Cn({.\<not> (.\<not> \<phi>)}) = Cn({\<phi>})\<close>
  by (metis (no_types, opaque_lifting) notnot_PL valid_Cn_equiv valid_equiv_PL)

lemma conj_com: \<open>A \<turnstile> p .\<and>. q \<longleftrightarrow> A \<turnstile> q .\<and>. p\<close>
  using conj_PL by auto

lemma conj_com_Cn: \<open>Cn({p .\<and>. q}) = Cn({q .\<and>. p})\<close>
  by (simp add: Cn_conj_bis insert_commute)

lemma disj_com: \<open>A \<turnstile> p .\<or>. q \<longleftrightarrow> A \<turnstile> q .\<or>. p\<close>
proof -
  { fix p q
    have \<open>A \<turnstile> p .\<or>. q \<Longrightarrow> A \<turnstile> q .\<or>. p\<close>
      apply(erule disjE_PL)
      using assumption_L disjI2_PL disjI1_PL impI_PL by auto
  }
  then show ?thesis by auto
qed

lemma disj_com_Cn: \<open>Cn({p .\<or>. q}) = Cn({q .\<or>. p})\<close>
  unfolding Cn_same using disj_com by simp

lemma imp_contrapos: \<open>A \<turnstile> p .\<longrightarrow>. q \<longleftrightarrow> A \<turnstile> .\<not> q .\<longrightarrow>. .\<not> p\<close>
  by (metis Cn_not Un_insert_left Un_insert_right imp_PL notnot_PL)

lemma equiv_negation: \<open>A \<turnstile> p .\<longleftrightarrow>. q \<longleftrightarrow> A \<turnstile> .\<not> p .\<longleftrightarrow>. .\<not> q\<close>
  using equivE1_PL equivE2_PL equivI_PL imp_contrapos by blast

lemma imp_trans: \<open>A \<turnstile> p .\<longrightarrow>.q \<Longrightarrow> A \<turnstile> q .\<longrightarrow>.r \<Longrightarrow> A \<turnstile> p .\<longrightarrow>.r\<close>
  using Cn_imp_bis by auto

lemma imp_recovery0: \<open>A \<turnstile> p .\<or>. (p .\<longrightarrow>. q)\<close>
  apply(subst disj_PL, subst imp_contrapos)
  using assumption_L impI_PL by auto

lemma imp_recovery1: \<open>A \<union> {p .\<longrightarrow>. q} \<turnstile> p \<Longrightarrow> A \<turnstile> p\<close>
  using disjE_PL[OF imp_recovery0, of A p p q] assumption_L imp_PL by auto

lemma imp_recovery2: \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> (q .\<longrightarrow>. p) .\<longrightarrow>. p \<Longrightarrow> A \<turnstile> q\<close>
  using imp_PL imp_recovery1 imp_trans by blast

lemma impI2: \<open>A \<turnstile> q \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. q\<close>
  by (meson assumption_L impI_PL in_mono sup_ge1 transitivity2_L)

lemma conj_equiv: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> ((p .\<and>. q) .\<longleftrightarrow>. q)\<close>
  by (metis Un_insert_right assumption_L conjE2_PL conjI_PL equiv_PL impI2 imp_PL insertI1 sup_bot.right_neutral)

lemma conj_imp: \<open>A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r \<longleftrightarrow> A \<turnstile> p .\<longrightarrow>. (q .\<longrightarrow>. r)\<close>
proof
  assume "A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r"
  then have "Cn (A \<union> {r}) \<subseteq> Cn (A \<union> {p, q})"
    by (metis (no_types) Cn_conj_bis Cn_imp_bis Cn_union Un_insert_right sup_bot.right_neutral)
  then show \<open>A \<turnstile> p .\<longrightarrow>. (q .\<longrightarrow>. r)\<close>
    by (metis Un_insert_right impI_PL inclusion_L infer_def insert_commute insert_subset subset_eq sup_bot.right_neutral)
next
   assume "A \<turnstile> p .\<longrightarrow>. (q .\<longrightarrow>. r)"
  then have "A \<union> {p} \<union> {q} \<turnstile> r"
    using imp_PL by auto
  then show "A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r"
    by (metis (full_types) Cn_conj_bis Cn_union impI_PL infer_def insert_is_Un sup_assoc)
qed

lemma conj_not_impE_PL: \<open>A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> (p .\<and>. .\<not> q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. r\<close>
  by (meson conj_imp disjE_PL ex_mid_PL imp_PL)

lemma disj_notE_PL: \<open>A \<turnstile> q \<Longrightarrow> A \<turnstile> p .\<or>. .\<not> q \<Longrightarrow> A \<turnstile> p\<close>
  using Cn_imp Cn_imp_bis Cn_not disjE_PL notnot_PL by blast

lemma disj_not_impE_PL: \<open>A \<turnstile> (p .\<or>. q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> (p .\<or>. .\<not> q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> r\<close>
  by (metis Un_insert_right disjE_PL disj_PL disj_com ex_mid_PL insert_commute sup_bot.right_neutral)

lemma imp_conj: \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> r .\<longrightarrow>. s \<Longrightarrow> A \<turnstile> (p .\<and>. r) .\<longrightarrow>. (q .\<and>. s)\<close>
  apply(intro impI_PL conjI_PL, unfold imp_PL[symmetric])
  by (meson assumption_L conjE1_PL conjE2_PL imp_trans infer_def insertI1 validD_L valid_imp_PL)+

lemma conj_overlap: \<open>A \<turnstile> (p .\<and>. q) \<longleftrightarrow> A \<turnstile> (p .\<and>. ((.\<not> p) .\<or>. q))\<close>
  by (meson conj_PL disjI2_PL disj_com disj_notE_PL)

lemma morgan: \<open>A \<turnstile> .\<not> (p .\<and>. q) \<longleftrightarrow> A \<turnstile> (.\<not> p) .\<or>. (.\<not> q)\<close>
  by (meson conj_imp disj_PL disj_com imp_PL imp_contrapos notE_PL notI_PL)

lemma conj_superexpansion1: \<open>A \<turnstile> .\<not> (p .\<and>. q) .\<and>. .\<not> p \<longleftrightarrow> A \<turnstile> .\<not> p\<close>
  using conj_PL disjI1_PL morgan by auto

lemma conj_superexpansion2: \<open>A \<turnstile> (p .\<or>. q) .\<and>. p \<longleftrightarrow> A \<turnstile> p\<close>
  using conj_PL disjI1_PL by auto

end

subsection \<open>Compact Logic\<close>
text\<open>If the logic is compact, which means that any result is based on a finite set of hypothesis\<close>
locale Compact_logic = Tarskian_logic +
  assumes compactness_L: \<open>A \<turnstile> \<phi> \<Longrightarrow> (\<exists>A'. A'\<subseteq> A \<and> finite A' \<and> A'\<turnstile> \<phi>)\<close>

begin

text \<open>Very important lemma preparing the application of the Zorn's lemma. It states that in a compact logic, we can not deduce \<open>\<phi>\<close>
if we accumulate an infinity of hypothesis groups which locally do not deduce phi\<close>
lemma chain_closure: \<open>\<not> \<tturnstile> \<phi> \<Longrightarrow> subset.chain {B. \<not> B \<turnstile> \<phi>} C \<Longrightarrow> \<not> \<Union>C \<turnstile> \<phi>\<close>
proof
  assume a:\<open>subset.chain {B. \<not> B \<turnstile> \<phi>} C\<close> and b:\<open>\<not> \<tturnstile> \<phi>\<close> and \<open>\<Union> C \<turnstile> \<phi>\<close>
  then obtain A' where c:\<open>A'\<subseteq> \<Union> C\<close> and d:\<open>finite A'\<close>  and e:\<open>A' \<turnstile> \<phi>\<close> using compactness_L by blast
  define f where f:\<open>f \<equiv> \<lambda>a. SOME B. B \<in> C \<and> a \<in> B\<close>
  have g:\<open>finite (f ` A')\<close> using f d by simp
  have h:\<open>(f ` A') \<subseteq> C\<close>
    unfolding f by auto (metis (mono_tags, lifting) Union_iff c someI_ex subset_eq)
  have i:\<open>subset.chain {B. \<not> B \<turnstile> \<phi>} (f ` A')\<close> using a h
    using a h by (meson subsetD subset_chain_def subset_trans)
  have \<open>A' \<noteq> {} \<Longrightarrow> \<Union> (f ` A') \<in> {B. \<not> B \<turnstile> \<phi>}\<close> using g i
    by (meson Union_in_chain image_is_empty subset_chain_def subset_eq)
  hence j:\<open>A' \<noteq> {} \<Longrightarrow> \<not> \<Union>(f ` A') \<turnstile> \<phi>\<close> by simp
  have \<open>A' \<subseteq> \<Union>(f ` A')\<close>
    unfolding f by auto (metis (no_types, lifting) Union_iff c someI_ex subset_iff)
  with j e b show False
    by (metis infer_def monotonicity_L subsetD valid_def)
qed

end

end


(*  Title:      HOL/Imperative_HOL/ex/Imperative_Reverse.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>An imperative in-place reversal on arrays\<close>

theory Imperative_Reverse
imports Subarray "~~/src/HOL/Imperative_HOL/Imperative_HOL"
begin

fun swap :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "swap a i j = do {
     x \<leftarrow> Array.nth a i;
     y \<leftarrow> Array.nth a j;
     Array.upd i y a;
     Array.upd j x a;
     return ()
   }"

fun rev :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "rev a i j = (if (i < j) then do {
     swap a i j;
     rev a (i + 1) (j - 1)
   }
   else return ())"

declare swap.simps [simp del] rev.simps [simp del]

lemma swap_pointwise: assumes "effect (swap a i j) h h' r"
  shows "Array.get h' a ! k = (if k = i then Array.get h a ! j
      else if k = j then Array.get h a ! i
      else Array.get h a ! k)"
using assms unfolding swap.simps
by (elim effect_elims)
 (auto simp: length_def)

lemma rev_pointwise: assumes "effect (rev a i j) h h' r"
  shows "Array.get h' a ! k = (if k < i then Array.get h a ! k
      else if j < k then Array.get h a ! k
      else Array.get h a ! (j - (k - i)))" (is "?P a i j h h'")
using assms proof (induct a i j arbitrary: h h' rule: rev.induct)
  case (1 a i j h h'')
  thus ?case
  proof (cases "i < j")
    case True
    with 1[unfolded rev.simps[of a i j]]
    obtain h' where
      swp: "effect (swap a i j) h h' ()"
      and rev: "effect (rev a (i + 1) (j - 1)) h' h'' ()"
      by (auto elim: effect_elims)
    from rev 1 True
    have eq: "?P a (i + 1) (j - 1) h' h''" by auto

    have "k < i \<or> i = k \<or> (i < k \<and> k < j) \<or> j = k \<or> j < k" by arith
    with True show ?thesis
      by (elim disjE) (auto simp: eq swap_pointwise[OF swp])
  next
    case False
    with 1[unfolded rev.simps[of a i j]]
    show ?thesis
      by (cases "k = j") (auto elim: effect_elims)
  qed
qed

lemma rev_length:
  assumes "effect (rev a i j) h h' r"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a i j arbitrary: h h' rule: rev.induct)
  case (1 a i j h h'')
  thus ?case
  proof (cases "i < j")
    case True
    with 1[unfolded rev.simps[of a i j]]
    obtain h' where
      swp: "effect (swap a i j) h h' ()"
      and rev: "effect (rev a (i + 1) (j - 1)) h' h'' ()"
      by (auto elim: effect_elims)
    from swp rev 1 True show ?thesis
      unfolding swap.simps
      by (elim effect_elims) fastforce
  next
    case False
    with 1[unfolded rev.simps[of a i j]]
    show ?thesis
      by (auto elim: effect_elims)
  qed
qed

lemma rev2_rev': assumes "effect (rev a i j) h h' u"
  assumes "j < Array.length h a"
  shows "subarray i (j + 1) a h' = List.rev (subarray i (j + 1) a h)"
proof -
  {
    fix k
    assume "k < Suc j - i"
    with rev_pointwise[OF assms(1)] have "Array.get h' a ! (i + k) = Array.get h a ! (j - k)"
      by auto
  }
  with assms(2) rev_length[OF assms(1)] show ?thesis
  unfolding subarray_def Array.length_def
  by (auto simp add: length_sublist' rev_nth min_def nth_sublist' intro!: nth_equalityI)
qed

lemma rev2_rev:
  assumes "effect (rev a 0 (Array.length h a - 1)) h h' u"
  shows "Array.get h' a = List.rev (Array.get h a)"
  using rev2_rev'[OF assms] rev_length[OF assms] assms
    by (cases "Array.length h a = 0", auto simp add: Array.length_def
      subarray_def rev.simps[where j=0] elim!: effect_elims)
  (drule sym[of "List.length (Array.get h a)"], simp)

definition "example = (Array.make 10 id \<bind> (\<lambda>a. rev a 0 9))"

export_code example checking SML SML_imp OCaml? OCaml_imp? Haskell? Scala Scala_imp

end


theory Sulzmann
  imports "Lexer"
begin

section {* Bit-Encodings *}

datatype bit = Z | S

fun
  code :: "val \<Rightarrow> bit list"
where
  "code Void = []"
| "code (Char c) = []"
| "code (Left v) = Z # (code v)"
| "code (Right v) = S # (code v)"
| "code (Seq v1 v2) = (code v1) @ (code v2)"
| "code (Stars []) = [S]"
| "code (Stars (v # vs)) =  (Z # code v) @ code (Stars vs)"

fun
  Stars_add :: "val \<Rightarrow> val \<Rightarrow> val"
where
  "Stars_add v (Stars vs) = Stars (v # vs)"

function
  decode' :: "bit list \<Rightarrow> rexp \<Rightarrow> (val * bit list)"
where
  "decode' ds ZERO = (Void, [])"
| "decode' ds ONE = (Void, ds)"
| "decode' ds (CHAR d) = (Char d, ds)"
| "decode' [] (ALT r1 r2) = (Void, [])"
| "decode' (Z # ds) (ALT r1 r2) = (let (v, ds') = decode' ds r1 in (Left v, ds'))"
| "decode' (S # ds) (ALT r1 r2) = (let (v, ds') = decode' ds r2 in (Right v, ds'))"
| "decode' ds (SEQ r1 r2) = (let (v1, ds') = decode' ds r1 in
                             let (v2, ds'') = decode' ds' r2 in (Seq v1 v2, ds''))"
| "decode' [] (STAR r) = (Void, [])"
| "decode' (S # ds) (STAR r) = (Stars [], ds)"
| "decode' (Z # ds) (STAR r) = (let (v, ds') = decode' ds r in
                                    let (vs, ds'') = decode' ds' (STAR r)
                                    in (Stars_add v vs, ds''))"
by pat_completeness auto

lemma decode'_smaller:
  assumes "decode'_dom (ds, r)"
  shows "length (snd (decode' ds r)) \<le> length ds"
using assms
apply(induct ds r)
apply(auto simp add: decode'.psimps split: prod.split)
using dual_order.trans apply blast
by (meson dual_order.trans le_SucI)

termination "decode'"
apply(relation "inv_image (measure(%cs. size cs) <*lex*> measure(%s. size s)) (%(ds,r). (r,ds))")
apply(auto dest!: decode'_smaller)
by (metis less_Suc_eq_le snd_conv)

definition
  decode :: "bit list \<Rightarrow> rexp \<Rightarrow> val option"
where
  "decode ds r \<equiv> (let (v, ds') = decode' ds r
                  in (if ds' = [] then Some v else None))"

lemma decode'_code_Stars:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> (\<forall>x. decode' (code v @ x) r = (v, x)) \<and> flat v \<noteq> []"
  shows "decode' (code (Stars vs) @ ds) (STAR r) = (Stars vs, ds)"
  using assms
  apply(induct vs)
  apply(auto)
  done

lemma decode'_code:
  assumes "\<Turnstile> v : r"
  shows "decode' ((code v) @ ds) r = (v, ds)"
using assms
  apply(induct v r arbitrary: ds)
  apply(auto)
  using decode'_code_Stars by blast

lemma decode_code:
  assumes "\<Turnstile> v : r"
  shows "decode (code v) r = Some v"
  using assms unfolding decode_def
  by (smt append_Nil2 decode'_code old.prod.case)

datatype arexp =
  AZERO
| AONE "bit list"
| ACHAR "bit list" char
| ASEQ "bit list" arexp arexp
| AALT "bit list" arexp arexp
| ASTAR "bit list" arexp

fun fuse :: "bit list \<Rightarrow> arexp \<Rightarrow> arexp" where
  "fuse bs AZERO = AZERO"
| "fuse bs (AONE cs) = AONE (bs @ cs)"
| "fuse bs (ACHAR cs c) = ACHAR (bs @ cs) c"
| "fuse bs (AALT cs r1 r2) = AALT (bs @ cs) r1 r2"
| "fuse bs (ASEQ cs r1 r2) = ASEQ (bs @ cs) r1 r2"
| "fuse bs (ASTAR cs r) = ASTAR (bs @ cs) r"

fun intern :: "rexp \<Rightarrow> arexp" where
  "intern ZERO = AZERO"
| "intern ONE = AONE []"
| "intern (CHAR c) = ACHAR [] c"
| "intern (ALT r1 r2) = AALT [] (fuse [Z] (intern r1))
                                     (fuse [S]  (intern r2))"
| "intern (SEQ r1 r2) = ASEQ [] (intern r1) (intern r2)"
| "intern (STAR r) = ASTAR [] (intern r)"

fun retrieve :: "arexp \<Rightarrow> val \<Rightarrow> bit list" where
  "retrieve (AONE bs) Void = bs"
| "retrieve (ACHAR bs c) (Char d) = bs"
| "retrieve (AALT bs r1 r2) (Left v) = bs @ retrieve r1 v"
| "retrieve (AALT bs r1 r2) (Right v) = bs @ retrieve r2 v"
| "retrieve (ASEQ bs r1 r2) (Seq v1 v2) = bs @ retrieve r1 v1 @ retrieve r2 v2"
| "retrieve (ASTAR bs r) (Stars []) = bs @ [S]"
| "retrieve (ASTAR bs r) (Stars (v#vs)) =
     bs @ [Z] @ retrieve r v @ retrieve (ASTAR [] r) (Stars vs)"

fun
  erase :: "arexp \<Rightarrow> rexp"
where
  "erase AZERO = ZERO"
| "erase (AONE _) = ONE"
| "erase (ACHAR _ c) = CHAR c"
| "erase (AALT _ r1 r2) = ALT (erase r1) (erase r2)"
| "erase (ASEQ _ r1 r2) = SEQ (erase r1) (erase r2)"
| "erase (ASTAR _ r) = STAR (erase r)"

fun
 bnullable :: "arexp \<Rightarrow> bool"
where
  "bnullable (AZERO) = False"
| "bnullable (AONE bs) = True"
| "bnullable (ACHAR bs c) = False"
| "bnullable (AALT bs r1 r2) = (bnullable r1 \<or> bnullable r2)"
| "bnullable (ASEQ bs r1 r2) = (bnullable r1 \<and> bnullable r2)"
| "bnullable (ASTAR bs r) = True"

fun
  bmkeps :: "arexp \<Rightarrow> bit list"
where
  "bmkeps(AONE bs) = bs"
| "bmkeps(ASEQ bs r1 r2) = bs @ (bmkeps r1) @ (bmkeps r2)"
| "bmkeps(AALT bs r1 r2) = (if bnullable(r1) then bs @ (bmkeps r1) else bs @ (bmkeps r2))"
| "bmkeps(ASTAR bs r) = bs @ [S]"

fun
 bder :: "char \<Rightarrow> arexp \<Rightarrow> arexp"
where
  "bder c (AZERO) = AZERO"
| "bder c (AONE bs) = AZERO"
| "bder c (ACHAR bs d) = (if c = d then AONE bs else AZERO)"
| "bder c (AALT bs r1 r2) = AALT bs (bder c r1) (bder c r2)"
| "bder c (ASEQ bs r1 r2) =
     (if bnullable r1
      then AALT bs (ASEQ [] (bder c r1) r2) (fuse (bmkeps r1) (bder c r2))
      else ASEQ bs (bder c r1) r2)"
| "bder c (ASTAR bs r) = ASEQ bs (fuse [Z] (bder c r)) (ASTAR [] r)"

fun
  bders :: "arexp \<Rightarrow> string \<Rightarrow> arexp"
where
  "bders r [] = r"
| "bders r (c#s) = bders (bder c r) s"

lemma bders_append:
  "bders r (s1 @ s2) = bders (bders r s1) s2"
  apply(induct s1 arbitrary: r s2)
  apply(simp_all)
  done

lemma bnullable_correctness:
  shows "nullable (erase r) = bnullable r"
  apply(induct r)
  apply(simp_all)
  done

lemma erase_fuse:
  shows "erase (fuse bs r) = erase r"
  apply(induct r)
  apply(simp_all)
  done

lemma erase_intern[simp]:
  shows "erase (intern r) = r"
  apply(induct r)
  apply(simp_all add: erase_fuse)
  done

lemma erase_bder[simp]:
  shows "erase (bder a r) = der a (erase r)"
  apply(induct r)
  apply(simp_all add: erase_fuse bnullable_correctness)
  done

lemma erase_bders[simp]:
  shows "erase (bders r s) = ders s (erase r)"
  apply(induct s arbitrary: r )
  apply(simp_all)
  done

lemma retrieve_encode_STARS:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> code v = retrieve (intern r) v"
  shows "code (Stars vs) = retrieve (ASTAR [] (intern r)) (Stars vs)"
  using assms
  apply(induct vs)
  apply(simp_all)
  done

lemma retrieve_fuse2:
  assumes "\<Turnstile> v : (erase r)"
  shows "retrieve (fuse bs r) v = bs @ retrieve r v"
  using assms
  apply(induct r arbitrary: v bs)
  using retrieve_encode_STARS
  apply(auto elim!: Prf_elims)
  apply(case_tac vs)
  apply(simp)
  apply(simp)
  done

lemma retrieve_fuse:
  assumes "\<Turnstile> v : r"
  shows "retrieve (fuse bs (intern r)) v = bs @ retrieve (intern r) v"
  using assms
  by (simp_all add: retrieve_fuse2)

lemma retrieve_code:
  assumes "\<Turnstile> v : r"
  shows "code v = retrieve (intern r) v"
  using assms
  apply(induct v r)
  apply(simp_all add: retrieve_fuse retrieve_encode_STARS)
  done

lemma bmkeps_retrieve:
  assumes "nullable (erase r)"
  shows "bmkeps r = retrieve r (mkeps (erase r))"
  using assms
  apply(induct r)
  apply(auto simp add: bnullable_correctness)
  done

lemma bder_retrieve:
  assumes "\<Turnstile> v : der c (erase r)"
  shows "retrieve (bder c r) v = retrieve r (injval (erase r) c v)"
  using assms
  apply(induct r arbitrary: v)
  apply(auto elim!: Prf_elims simp add: retrieve_fuse2 bnullable_correctness bmkeps_retrieve)
  done

lemma MAIN_decode:
  assumes "\<Turnstile> v : ders s r"
  shows "Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r"
  using assms
proof (induct s arbitrary: v rule: rev_induct)
  case Nil
  have "\<Turnstile> v : ders [] r" by fact
  then have "\<Turnstile> v : r" by simp
  then have "Some v = decode (retrieve (intern r) v) r"
    using decode_code retrieve_code by auto
  then show "Some (flex r id [] v) = decode (retrieve (bders (intern r) []) v) r"
    by simp
next
  case (snoc c s v)
  have IH: "\<And>v. \<Turnstile> v : ders s r \<Longrightarrow>
     Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r" by fact
  have asm: "\<Turnstile> v : ders (s @ [c]) r" by fact
  then have asm2: "\<Turnstile> injval (ders s r) c v : ders s r"
    by(simp add: Prf_injval ders_append)
  have "Some (flex r id (s @ [c]) v) = Some (flex r id s (injval (ders s r) c v))"
    by (simp add: flex_append)
  also have "... = decode (retrieve (bders (intern r) s) (injval (ders s r) c v)) r"
    using asm2 IH by simp
  also have "... = decode (retrieve (bder c (bders (intern r) s)) v) r"
    using asm by(simp_all add: bder_retrieve ders_append)
  finally show "Some (flex r id (s @ [c]) v) =
                 decode (retrieve (bders (intern r) (s @ [c])) v) r" by (simp add: bders_append)
qed

definition blexer where
 "blexer r s \<equiv> if bnullable (bders (intern r) s) then
                decode (bmkeps (bders (intern r) s)) r else None"

lemma blexer_correctness:
  shows "blexer r s = lexer r s"
proof -
  { define bds where "bds \<equiv> bders (intern r) s"
    define ds  where "ds \<equiv> ders s r"
    assume asm: "nullable ds"
    have era: "erase bds = ds"
      unfolding ds_def bds_def by simp
    have mke: "\<Turnstile> mkeps ds : ds"
      using asm by (simp add: mkeps_nullable)
    have "decode (bmkeps bds) r = decode (retrieve bds (mkeps ds)) r"
      using bmkeps_retrieve
      using asm era by (simp add: bmkeps_retrieve)
    also have "... =  Some (flex r id s (mkeps ds))"
      using mke by (simp_all add: MAIN_decode ds_def bds_def)
    finally have "decode (bmkeps bds) r = Some (flex r id s (mkeps ds))"
      unfolding bds_def ds_def .
  }
  then show "blexer r s = lexer r s"
    unfolding blexer_def lexer_flex
    by(auto simp add: bnullable_correctness[symmetric])
qed

unused_thms

end


(*  Title:   Pair_QuasiBorel_Measure.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection \<open>Binary Product Measure\<close>

theory Pair_QuasiBorel_Measure
  imports "Monad_QuasiBorel"
begin

subsubsection \<open> Binary Product Measure\<close>
text \<open> Special case of \<^cite>\<open>"Heunen_2017"\<close> Proposition 23 where $\Omega = \mathbb{R}\times \mathbb{R}$ and $X = X \times Y$.
      Let $[\alpha,\mu ] \in P(X)$ and $[\beta ,\nu] \in P(Y)$. $\alpha\times\beta$ is the $\alpha$ in Proposition 23. \<close>
definition qbs_prob_pair_measure_t :: "['a qbs_prob_t, 'b qbs_prob_t] \<Rightarrow> ('a \<times> 'b) qbs_prob_t" where
"qbs_prob_pair_measure_t p q  \<equiv> (let (X,\<alpha>,\<mu>) = p;
                                     (Y,\<beta>,\<nu>) = q in
                                 (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f))"

lift_definition qbs_prob_pair_measure :: "['a qbs_prob_space, 'b qbs_prob_space] \<Rightarrow> ('a \<times> 'b) qbs_prob_space" (infix "\<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s" 80)
is qbs_prob_pair_measure_t
  unfolding qbs_prob_pair_measure_t_def
proof auto
  fix X X' :: "'a quasi_borel"
  fix Y Y' :: "'b quasi_borel"
  fix \<alpha> \<alpha>' \<mu> \<mu>' \<beta> \<beta>' \<nu> \<nu>'
  assume h:"qbs_prob_eq (X,\<alpha>,\<mu>) (X',\<alpha>',\<mu>')"
           "qbs_prob_eq (Y,\<beta>,\<nu>) (Y',\<beta>',\<nu>')"
  then have 1: "X = X'" "Y = Y'"
    by(auto simp: qbs_prob_eq_def)
  interpret pqp1: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(1)[OF h(1)] qbs_prob_eq_dest(1)[OF h(2)])
  interpret pqp2: pair_qbs_probs X' \<alpha>' \<mu>' Y' \<beta>' \<nu>'
    by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(2)[OF h(1)] qbs_prob_eq_dest(2)[OF h(2)])
  interpret pqp: pair_qbs_prob "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<beta> \<circ> real_real.g" "distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f" "X' \<Otimes>\<^sub>Q Y'" "map_prod \<alpha>' \<beta>' \<circ> real_real.g" "distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f"
    by(auto intro!: qbs_probI pqp1.P.prob_space_distr pqp2.P.prob_space_distr simp: pair_qbs_prob_def)

  show "qbs_prob_eq (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (X' \<Otimes>\<^sub>Q Y', map_prod \<alpha>' \<beta>' \<circ> real_real.g, distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f)"
  proof(rule pqp.qbs_prob_space_eq_inverse(1))
    show "qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)
           = qbs_prob_space (X' \<Otimes>\<^sub>Q Y', map_prod \<alpha>' \<beta>' \<circ> real_real.g, distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)))"
        by(simp add: pqp1.qbs_bind_return_pq)
      also have "... = qbs_prob_space (X', \<alpha>', \<mu>') \<bind> (\<lambda>x. qbs_prob_space (Y', \<beta>', \<nu>') \<bind> (\<lambda>y. qbs_return (X' \<Otimes>\<^sub>Q Y') (x, y)))"
        using h by(simp add: qbs_prob_space_eq 1)
      also have "... = ?rhs"
        by(simp add: pqp2.qbs_bind_return_pq)
      finally show ?thesis .
    qed
  qed
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_computation:
  "(qbs_prob_space (X,\<alpha>,\<mu>)) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s (qbs_prob_space (Y,\<beta>,\<nu>)) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g , distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
  "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
  by(simp_all add: qbs_prob_pair_measure.abs_eq qbs_prob_pair_measure_t_def qbs_bind_return_pq)

lemma qbs_prob_pair_measure_qbs:
  "qbs_prob_space_qbs (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) = qbs_prob_space_qbs p \<Otimes>\<^sub>Q qbs_prob_space_qbs q"
  by(transfer,simp add: qbs_prob_pair_measure_t_def Let_def prod.case_eq_if)

lemma(in pair_qbs_probs) qbs_prob_pair_measure_measure:
    shows "qbs_prob_measure (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) = distr (\<mu> \<Otimes>\<^sub>M \<nu>) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<beta>)"
  by(simp add: qbs_prob_pair_measure_computation distr_distr comp_assoc)

lemma qbs_prob_pair_measure_morphism:
 "case_prod qbs_prob_pair_measure \<in> monadP_qbs X \<Otimes>\<^sub>Q monadP_qbs Y \<rightarrow>\<^sub>Q monadP_qbs (X \<Otimes>\<^sub>Q Y)"
proof(rule pair_qbs_morphismI)
  fix \<beta>x \<beta>y
  assume h: "\<beta>x \<in> qbs_Mx (monadP_qbs X)" " \<beta>y \<in> qbs_Mx (monadP_qbs Y)"
  then obtain \<alpha>x \<alpha>y gx gy where ha:
   "\<alpha>x \<in> qbs_Mx X" "gx \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel" "\<beta>x = (\<lambda>r. qbs_prob_space (X, \<alpha>x, gx r))"
   "\<alpha>y \<in> qbs_Mx Y" "gy \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel" "\<beta>y = (\<lambda>r. qbs_prob_space (Y, \<alpha>y, gy r))"
    using rep_monadP_qbs_MPx[of \<beta>x X] rep_monadP_qbs_MPx[of \<beta>y Y] by auto
  note [measurable] = ha(2,5)
  have "(\<lambda>(x, y). x \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s y) \<circ> (\<lambda>r. (\<beta>x r, \<beta>y r)) = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha>x \<alpha>y \<circ> real_real.g, distr (gx r \<Otimes>\<^sub>M gy r) real_borel real_real.f))"
    apply standard
    using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.qbs_prob_pair_measure_computation[of X \<alpha>x _ Y \<alpha>y]
    by (auto simp: ha pair_qbs_probs_def)
  also have "... \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q Y))"
    using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.ab_g_in_Mx[of X \<alpha>x _ Y \<alpha>y]
    by(auto intro!: bexI[where x="map_prod \<alpha>x \<alpha>y \<circ> real_real.g"] bexI[where x="\<lambda>r. distr (gx r \<Otimes>\<^sub>M gy r) real_borel real_real.f"]
         simp: monadP_qbs_MPx_def in_MPx_def pair_qbs_probs_def)
  finally show "(\<lambda>(x, y). x \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s y) \<circ> (\<lambda>r. (\<beta>x r, \<beta>y r)) \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q Y))" .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_nnintegral:
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  shows "(\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>))) = (\<integral>\<^sup>+ z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sup>+ x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) x \<partial>distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
    by(simp add: qbs_prob_ennintegral_def[OF assms] qbs_prob_pair_measure_computation)
  also have "... = (\<integral>\<^sup>+ x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) (real_real.f x) \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using assms by(intro nn_integral_distr) auto
  also have "... = ?rhs" by simp
  finally show ?thesis .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integral:
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    shows "(\<integral>\<^sub>Q z. f z \<partial>(qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>))) = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
          (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) x \<partial>distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
    by(simp add: qbs_prob_integral_def[OF assms] qbs_prob_pair_measure_computation)
  also have "... = (\<integral> x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) (real_real.f x) \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using assms by(intro integral_distr) auto
  also have "... = ?rhs" by simp
  finally show ?thesis .
qed

lemma qbs_prob_pair_measure_eq_bind:
  assumes "p \<in> monadP_qbs_Px X"
      and "q \<in> monadP_qbs_Px Y"
    shows "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q = p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))"
proof -
  obtain \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def hp hq)
  show ?thesis
    by(simp add: hp(1) hq(1) pqp.qbs_prob_pair_measure_computation(1) pqp.qbs_bind_return_pq(1))
qed

subsubsection \<open>Fubini Theorem\<close>
lemma qbs_prob_ennintegral_Fubini_fst:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
      and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. f (x,y) \<partial>q \<partial>p) = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(2)] curry_preserves_morphisms[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]
                qbs_morphism_Pair1'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
                assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
  have "?rhs = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))))"
    by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)])
  also have "... = (\<integral>\<^sup>+\<^sub>Q x. qbs_prob_ennintegral (q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) f \<partial>p)"
    by(auto intro!: qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
  also have "... =  (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. qbs_prob_ennintegral (qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)) f \<partial>q \<partial>p)"
    by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
  also have "... = ?lhs"
    using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
  finally show ?thesis by simp
qed

lemma qbs_prob_ennintegral_Fubini_snd:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
      and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. f (x,y) \<partial>p \<partial>q) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs X",simplified,OF assms(1)] curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]]
                qbs_morphism_Pair2'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
                assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
  have "?rhs = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))))"
    by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)] qbs_bind_return_rotate[OF assms(1,2)])
  also have "... = (\<integral>\<^sup>+\<^sub>Q y. qbs_prob_ennintegral (p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) f \<partial>q)"
    by(auto intro!: qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
  also have "... =  (\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. qbs_prob_ennintegral (qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)) f \<partial>p \<partial>q)"
    by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
  also have "... = ?lhs"
    using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
  finally show ?thesis by simp
qed

lemma qbs_prob_ennintegral_indep1:
  assumes "p \<in> monadP_qbs_Px X"
      and "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>p)"
          (is "?lhs = _")
proof -
 obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  have "?lhs = (\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. f x \<partial>p \<partial>q)"
    using qbs_prob_ennintegral_Fubini_snd[OF assms(1) qbs_prob.qbs_prob_space_in_Px[OF hq(2)] qbs_morphism_fst''[OF assms(2)]]
    by(simp add: hq(1))
  thus ?thesis
    by(simp add: qbs_prob_ennintegral_const)
qed

lemma qbs_prob_ennintegral_indep2:
  assumes "q \<in> monadP_qbs_Px Y"
      and "f \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q z. f (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q y. f y \<partial>q)"
          (is "?lhs = _")
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  have "?lhs = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. f y \<partial>q \<partial>p)"
    using qbs_prob_ennintegral_Fubini_fst[OF qbs_prob.qbs_prob_space_in_Px[OF hp(2)] assms(1) qbs_morphism_snd''[OF assms(2)]]
    by(simp add: hp(1))
  thus ?thesis
    by(simp add: qbs_prob_ennintegral_const)
qed

lemma qbs_ennintegral_indep_mult:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
          "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q z. f (fst z) * g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>p) * (\<integral>\<^sup>+\<^sub>Q y. g y \<partial>q)"
          (is "?lhs = ?rhs")
proof -
  have h:"(\<lambda>z. f (fst z) * g (snd z)) \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    using assms(4,3)
    by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)

  have "?lhs = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y .f x * g y \<partial>q \<partial>p)"
    using qbs_prob_ennintegral_Fubini_fst[OF assms(1,2) h] by simp
  also have "... = (\<integral>\<^sup>+\<^sub>Q x. f x * \<integral>\<^sup>+\<^sub>Q y . g y \<partial>q \<partial>p)"
    using qbs_prob_ennintegral_cmult[of q,OF _ assms(4)] assms(2)
    by(simp add: monadP_qbs_Px_def)
  also have "... = ?rhs"
    using qbs_prob_ennintegral_cmult[of p,OF _ assms(3)] assms(1)
    by(simp add: ab_semigroup_mult_class.mult.commute[where b="qbs_prob_ennintegral q g"] monadP_qbs_Px_def)
  finally show ?thesis .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable:
  assumes "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) f"
    shows "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
          "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> (map_prod \<alpha> \<beta>))"
proof -
  show "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF qbs_prob_pair_measure_qbs assms]
    by simp
next
  have 1:"integrable (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g))"
    using assms[simplified qbs_prob_pair_measure_computation] qbs_integrable_def[of f]
    by simp
  have "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (\<lambda>x. (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (real_real.f x))"
    by(intro integrable_distr[OF _ 1]) simp
  thus "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
    by(simp add: comp_def)
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable':
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
      and "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> (map_prod \<alpha> \<beta>))"
    shows "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) f"
proof -
  have "integrable (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) = integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (\<lambda>x. (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (real_real.f x))"
    by(intro integrable_distr_eq) (use assms(1) in auto)
  thus ?thesis
    using assms qbs_integrable_def
    by(simp add: comp_def qbs_prob_pair_measure_computation)
qed

lemma qbs_integrable_pair_swap:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  shows "qbs_integrable (q \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s p) (\<lambda>(x,y). f (y,x))"
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def hp hq)
  interpret pqp2: pair_qbs_probs Y \<beta> \<nu> X \<alpha> \<mu>
    by(simp add: pair_qbs_probs_def hp hq)

  have "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
       "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
    by(auto simp: pqp.qbs_prob_pair_measure_integrable[OF assms[simplified hp(1) hq(1)]])
  from qbs_morphism_pair_swap[OF this(1)] pqp.integrable_product_swap[OF this(2)]
  have "(\<lambda>(x,y). f (y,x)) \<in> Y \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
        "integrable (\<nu> \<Otimes>\<^sub>M \<mu>) ((\<lambda>(x,y). f (y,x)) \<circ> map_prod \<beta> \<alpha>)"
    by(simp_all add: map_prod_def comp_def split_beta')
  from pqp2.qbs_prob_pair_measure_integrable' [OF this]
  show ?thesis by(simp add: hp(1) hq(1))
qed

lemma qbs_integrable_pair1:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
          "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
          "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f (x,y)\<bar> \<partial>q)"
      and "\<And>x. x \<in> qbs_space X \<Longrightarrow> qbs_integrable q (\<lambda>y. f (x,y))"
    shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
proof -
  obtain \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def hp hq)

  have "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
  proof(rule pqp.Fubini_integrable)
    show "f \<circ> map_prod \<alpha> \<beta> \<in> borel_measurable (\<mu> \<Otimes>\<^sub>M \<nu>)"
      using assms(3) by auto
  next
    have "(\<lambda>x. LINT y|\<nu>. norm ((f \<circ> map_prod \<alpha> \<beta>) (x, y))) = (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f (x,y)\<bar> \<partial>q) \<circ> \<alpha>"
      apply standard subgoal for x
        using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx,of x] assms(3)]
        by(auto intro!: pqp.qp2.qbs_prob_integral_def[symmetric] simp: hq(1))
      done
    moreover have "integrable \<mu> ..."
      using assms(4) pqp.qp1.qbs_integrable_def
      by (simp add: hp(1))
    ultimately show "integrable \<mu> (\<lambda>x. LINT y|\<nu>. norm ((f \<circ> map_prod \<alpha> \<beta>) (x, y)))"
      by simp
  next
    have "\<And>x. integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
    proof-
      fix x
      have "(\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y)) = (\<lambda>y. f (\<alpha> x,y)) \<circ> \<beta>"
        by auto
      moreover have "qbs_integrable (qbs_prob_space (Y, \<beta>, \<nu>)) (\<lambda>y. f (\<alpha> x, y))"
        by(auto intro!: assms(5)[simplified hq(1)] simp: qbs_Mx_to_X)
      ultimately show "integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
        by(simp add: pqp.qp2.qbs_integrable_def)
    qed
    thus "AE x in \<mu>. integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
      by simp
  qed
  thus ?thesis
    using pqp.qbs_prob_pair_measure_integrable'[OF assms(3)]
    by(simp add: hp(1) hq(1))
qed

lemma qbs_integrable_pair2:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
          "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
          "qbs_integrable q (\<lambda>y. \<integral>\<^sub>Q x. \<bar>f (x,y)\<bar> \<partial>p)"
      and "\<And>y. y \<in> qbs_space Y \<Longrightarrow> qbs_integrable p (\<lambda>x. f (x,y))"
    shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  using qbs_integrable_pair_swap[OF qbs_integrable_pair1[OF assms(2,1) qbs_morphism_pair_swap[OF assms(3)],simplified,OF assms(4,5)]]
  by simp

lemma qbs_integrable_fst:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  shows "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. f (x,y) \<partial>q)"
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  show "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q)"
  proof(auto simp add: pqp.qp1.qbs_integrable_def hp(1))
    show "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<in> borel_measurable (qbs_to_measure X)"
      using qbs_morphism_integral_fst[OF h0(2,3)] by auto
  next
    have "integrable \<mu> (\<lambda>x. LINT y|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
      by(intro pqp.integrable_fst') (rule pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]])
    moreover have "\<And>x. ((\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>) x = LINT y|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y)"
     by(auto intro!: pqp.qp2.qbs_prob_integral_def qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)] simp: hq)
    ultimately show "integrable \<mu> ((\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>)"
      using Bochner_Integration.integrable_cong[of \<mu> \<mu> "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>" " (\<lambda>x. LINT y|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"]
      by simp
  qed
qed

lemma qbs_integrable_snd:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  shows "qbs_integrable q (\<lambda>y. \<integral>\<^sub>Q x. f (x,y) \<partial>p)"
  using qbs_integrable_fst[OF qbs_integrable_pair_swap[OF assms]]
  by simp

lemma qbs_integrable_indep_mult:
  assumes "qbs_integrable p f"
      and "qbs_integrable q g"
    shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. f (fst x) * g (snd x))"
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q" "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms(1)] qbs_integrable_morphism[OF _ assms(2)]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  show ?thesis
  proof(rule qbs_integrable_pair1[OF h0(1,2)],simp_all add: assms(2))
    show "(\<lambda>z. f (fst z) * g (snd z)) \<in>  X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
      using h0(3,4) by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)
  next
    show "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f x * g y\<bar> \<partial>q)"
      by(auto intro!: qbs_integrable_mult[OF qbs_integrable_abs[OF assms(1)]]
           simp only: idom_abs_sgn_class.abs_mult qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="\<integral>\<^sub>Q y. \<bar>g y\<bar> \<partial>q"])
  qed
qed

lemma qbs_integrable_indep1:
  assumes "qbs_integrable p f"
  shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. f (fst x))"
  using qbs_integrable_indep_mult[OF assms qbs_integrable_const[of q 1]]
  by simp

lemma qbs_integrable_indep2:
  assumes "qbs_integrable q g"
  shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. g (snd x))"
  using qbs_integrable_pair_swap[OF qbs_integrable_indep1[OF assms],of p]
  by(simp add: split_beta')

lemma qbs_prob_integral_Fubini_fst:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
    shows "(\<integral>\<^sub>Q x. \<integral>\<^sub>Q y. f (x,y) \<partial>q \<partial>p) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  have "?lhs = (\<integral> x. \<integral>\<^sub>Q y. f (\<alpha> x, y) \<partial>q \<partial>\<mu>)"
    using qbs_morphism_integral_fst[OF h0(2) h0(3)]
    by(auto intro!: pqp.qp1.qbs_prob_integral_def simp: hp(1))
  also have "... = (\<integral>x. \<integral>y. f (\<alpha> x, \<beta> y) \<partial>\<nu> \<partial>\<mu>)"
    using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)]
    by(auto intro!: Bochner_Integration.integral_cong pqp.qp2.qbs_prob_integral_def
              simp: hq(1))
  also have "... = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using pqp.integral_fst'[OF pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]]
    by(simp add: map_prod_def comp_def)
  also have "... = ?rhs"
    by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
  finally show ?thesis .
qed

lemma qbs_prob_integral_Fubini_snd:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
    shows "(\<integral>\<^sub>Q y. \<integral>\<^sub>Q x. f (x,y) \<partial>p \<partial>q) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  have "?lhs = (\<integral> y. \<integral>\<^sub>Q x. f (x,\<beta> y) \<partial>p \<partial>\<nu>)"
    using qbs_morphism_integral_snd[OF h0(1) h0(3)]
    by(auto intro!: pqp.qp2.qbs_prob_integral_def simp: hq(1))
  also have "... = (\<integral>y. \<integral>x. f (\<alpha> x, \<beta> y) \<partial>\<mu> \<partial>\<nu>)"
    using qbs_morphism_Pair2'[OF qbs_Mx_to_X(2)[OF pqp.qp2.in_Mx] h0(3)]
    by(auto intro!: Bochner_Integration.integral_cong pqp.qp1.qbs_prob_integral_def
              simp: hp(1))
  also have "... = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using pqp.integral_snd[of "curry (f \<circ> map_prod \<alpha> \<beta>)"] pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]
    by(simp add: map_prod_def comp_def split_beta')
  also have "... = ?rhs"
    by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
  finally show ?thesis .
qed

lemma qbs_prob_integral_indep1:
  assumes "qbs_integrable p f"
  shows "(\<integral>\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q x. f x \<partial>p)"
  using qbs_prob_integral_Fubini_snd[OF qbs_integrable_indep1[OF assms],of q]
  by(simp add: qbs_prob_integral_const)

lemma qbs_prob_integral_indep2:
  assumes "qbs_integrable q g"
  shows "(\<integral>\<^sub>Q z. g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q y. g y \<partial>q)"
  using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep2[OF assms],of p]
  by(simp add: qbs_prob_integral_const)

lemma qbs_prob_integral_indep_mult:
  assumes "qbs_integrable p f"
      and "qbs_integrable q g"
    shows "(\<integral>\<^sub>Q z. f (fst z) * g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q x. f x \<partial>p) * (\<integral>\<^sub>Q y. g y \<partial>q)"
          (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sub>Q x. \<integral>\<^sub>Q y. f x * g y \<partial>q \<partial>p)"
    using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep_mult[OF assms]]
    by simp
  also have "... = (\<integral>\<^sub>Q x. f x * (\<integral>\<^sub>Q y.  g y \<partial>q) \<partial>p)"
    by(simp add: qbs_prob_integral_cmult)
  also have "... = ?rhs"
    by(simp add: qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="\<integral>\<^sub>Q y.  g y \<partial>q"])
  finally show ?thesis .
qed

lemma qbs_prob_var_indep_plus:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (f z)\<^sup>2)"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (g z)\<^sup>2)"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (f z) * (g z))"
      and "(\<integral>\<^sub>Q z. f z * g z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * (\<integral>\<^sub>Q z. g z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
    shows "qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. f z + g z) = qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f + qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"
  unfolding qbs_prob_var_def
proof -
  show "(\<integral>\<^sub>Q z. (f z + g z - \<integral>\<^sub>Q w. f w + g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q z. (f z - qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f)\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) + (\<integral>\<^sub>Q z. (g z - qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g)\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = (\<integral>\<^sub>Q z. ((f z - (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))) + (g z - (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))))\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
      by(simp add: qbs_prob_integral_add[OF assms(1,3)] add_diff_add)
    also have "... = (\<integral>\<^sub>Q z. (f z - (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))\<^sup>2 + (g z - (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))\<^sup>2 + (2 * f z * g z - 2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * g z - (2 * f z * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) - 2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
      by(simp add: comm_semiring_1_class.power2_sum comm_semiring_1_cancel_class.left_diff_distrib' ring_class.right_diff_distrib)
    also have "... = ?rhs"
      using qbs_prob_integral_add[OF qbs_integrable_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]] qbs_integrable_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]]]
            qbs_prob_integral_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]]
            qbs_prob_integral_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]]
            qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]]
            qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]
            qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" 2 "\<lambda>z. f z * g z",simplified assms(6) comm_semiring_1_class.semiring_normalization_rules(18)]
            qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))" g]
            qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))" f,simplified semigroup_mult_class.mult.assoc[of 2 "\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of 2 _ "\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"]]
            qbs_prob_integral_const[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]
      by simp
    finally show ?thesis .
  qed
qed

lemma qbs_prob_var_indep_plus':
  assumes "qbs_integrable p f"
          "qbs_integrable p (\<lambda>x. (f x)\<^sup>2)"
          "qbs_integrable q g"
      and "qbs_integrable q (\<lambda>x. (g x)\<^sup>2)"
    shows "qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. f (fst z) + g (snd z)) = qbs_prob_var p f + qbs_prob_var q g"
  using qbs_prob_var_indep_plus[OF qbs_integrable_indep1[OF assms(1)] qbs_integrable_indep1[OF assms(2)] qbs_integrable_indep2[OF assms(3)] qbs_integrable_indep2[OF assms(4)] qbs_integrable_indep_mult[OF assms(1) assms(3)] qbs_prob_integral_indep_mult[OF assms(1) assms(3),simplified  qbs_prob_integral_indep1[OF assms(1),of q,symmetric] qbs_prob_integral_indep2[OF assms(3),of p,symmetric]]]
        qbs_prob_integral_indep1[OF qbs_integrable_sq[OF assms(1,2)],of q "\<integral>\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"] qbs_prob_integral_indep2[OF qbs_integrable_sq[OF assms(3,4)],of p "\<integral>\<^sub>Q z. g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"]
  by(simp add: qbs_prob_var_def qbs_prob_integral_indep1[OF assms(1)] qbs_prob_integral_indep2[OF assms(3)])

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Examples
  imports Main
begin
hide_const Nil Cons
hide_type list
(*>*)

text {*
This section only presents briefly the most used constructions in the formalizations described in
this thesis. It is not expected from the reader to fully understand the proofs presented in this
report; it is sufficient to recognize key concepts such as induction and case analysis.

The theorem proving community is subdivided in two groups: automatic theorem proving (ATP) and
interactive theorem proving (ITP). Each has its own set of goals, motivations, methodologies,
tools and terminology. In ATP, one must formulate its context and equations in some logical
formalism and ask the theorem prover to find a proof. The limiting factor is the algorithm used by
the tool. Examples of such provers include SPASS, Vampire and Z3. In ITP, one must also formulate
its context and equations in some logical formalism, although usually a more expressive one, but
must also give instructions guiding the prover. The term proof assistant is sometime used to
highlight this collaboration between the human and the machine. Here, the limiting factor is the
ability of the human to guide its tool. Examples of interactive theorem provers include Agda, Coq
and Isabelle. Isabelle is a generic interactive theorem prover for implementing logical formalisms
and Isabelle/HOL is its specialization to a formalism called higher order logic.

An Isabelle theory file serves as the basic unit of encapsulation of formalizations and reusable
libraries. It is analogous to modules in programming languages. Every definition and theorem
developed must belong to a theory and can be made accessible to other theories by importing them.

Types and function definitions serve to describe entities and how to operate on them. They work in a
very similar way to their counterpart in functional programming languages. A new type is introduced
with the \texttt{datatype} command, followed by the name of the type and the different constructors
separated by a \texttt{|}. Following is the standard definition of the type of parametric
lists:\footnote{Prefixing an element with a descriptive name, as done for the arguments of the
@{text Cons} constructor, is a common pattern in Isabelle/HOL. The syntax is always
\texttt{name : element}.}
*}

datatype 'a list = Nil | Cons (head: 'a) (tail: "'a list")

text {*
The datatype consists of two constructors. The first one, @{const Nil}, is used to represent the
empty list while the second one, @{const Cons}, is used to add an element in front of an existing
list. Using those two primitives, a list can be created by successive application of the @{const
Cons} constructor (e.g. @{term [source] "Cons 1 (Cons 2 (Cons 3 Nil))"}). The \emph{'a} in front
of the name is a placeholder for a concrete type that must be provide later (e.g. the type of the
previous example could be @{typ "nat list"}).

Function definitions can take many forms in Isabelle/HOL. A primitively recursive function is
introduced with the \texttt{primrec} command and defined by pattern matching over its arguments.
Each pattern match entry must then provide the value to which the function evaluates. Following is a
definition of a higher order function (i.e. a function that takes a function as argument) that
checks if all the elements of a list are ordered with respect to a binary predicate provided as an
argument:
*}

primrec ordered :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "ordered p Nil = True" |
  "ordered p (Cons x xs) = (case xs of
     Nil \<Rightarrow> True |
     Cons y ys \<Rightarrow> p x y \<and> ordered p xs)"

text {*
An alternative way in which this function could be defined is inductively. Introduced with the
\texttt{inductive} command, it allows to express Boolean functions by providing an inductive
definition of when the function should evaluate to true, leaving all the other cases to false. The
definition consists of base cases and possibly many inductive cases. Following is the same function
defined inductively:\footnote{Here, a descriptive name have been given to each rule. The base
cases are @{text empty_list} and @{text singleton_list} while the inductive case is @{text
arbitrary_list}.}
*}

inductive ordered' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  empty_list:
    "ordered' p Nil" |
  singleton_list:
    "ordered' p (Cons x Nil)" |
  arbitrary_list:
    "p x1 x2 \<Longrightarrow> ordered' p (Cons x2 xs) \<Longrightarrow> ordered' p (Cons x1 (Cons x2 xs))"

text {*
Theorems, also named lemmas, are true facts involving the defined elements. They could be compared
to the assertions used in programming languages. The main difference is that asserts are validate by
evaluating the expression while theorems are validated by a formal proof. This is the point where
the analogy with programming languages stops since this concept is unique to theorem provers. In
Isabelle/HOL, a proof can take two forms: a low level sequence of \texttt{apply} steps or higher
level structured definition. Following is an example of a lemma that proves, using the low level
style, that the list of increasing natural numbers are ordered with respect to the usual comparison
operation:
*}

(* changed apply style proof for Isar one line proof*)
lemma "ordered (\<lambda>x (y :: nat). x < y) (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))"
  by (simp add: ordered.simps)

text {*
This proof is easily checked by a computer but very hard to read for a human. For this reason, the
alternative structured Isar proof language was designed to allow the writing of more human-friendly
proofs. Following is a theorem showing that, whenever the @{const ordered} function returns true for
a given predicate and list, the @{const ordered'} function will also return true:\footnote{In
Isabelle, every unbound term is implicitly universally quantified:
$n + 1 > n \: \equiv \: (\forall n. \ n + 1 > n)$.}
*}

lemma primrec_imp_inductive:
  "ordered f xs \<Longrightarrow> ordered' f xs"
proof (induction xs rule: list.induct)
  case Nil
  thus ?case by (auto intro: ordered'.intros)
next
  case (Cons y ys)
  thus ?case by (cases ys rule: list.exhaust) (auto intro: ordered'.intros)
qed

text {*
This proof is still easily checked by a computer but is also more readable for a human. It is easy
to see that the proof works by induction on the list @{term xs}, that the base case (@{const Nil})
is first proved and that in the inductive case (@{const Cons}), a cases analysis of the values the
argument @{term ys} can take is performed.

For a more comprehensive introduction to Isabelle/HOL, the reader is encourage to start with the
first part of the book \emph{Concrete Semantics} \cite{nipkow-klein-2014-concrete-semantics} and
continue, for a deeper understanding, with the more exhaustive tutorial
\cite{nipkow-et-al-2014-tutorial} distributed with the system.
*}

(*<*)
end
(*>*)