section "Semantics and type soundness for System F"

theory SystemF
  imports Main "HOL-Library.FSet"
begin

subsection "Syntax and values"

type_synonym name = nat

datatype ty = TVar nat | TNat | Fun ty ty (infix "\<rightarrow>" 60) | Forall ty

datatype exp = EVar name | ENat nat | ELam ty exp | EApp exp exp
  | EAbs exp  | EInst exp ty | EFix ty exp

datatype val = VNat nat | Fun "(val \<times> val) fset" | Abs "val option" | Wrong

fun val_le :: "val \<Rightarrow> val \<Rightarrow> bool" (infix "\<sqsubseteq>" 52) where
  "(VNat n) \<sqsubseteq> (VNat n') = (n = n')" |
  "(Fun f) \<sqsubseteq> (Fun f') = (fset f \<subseteq> fset f')" |
  "(Abs None) \<sqsubseteq> (Abs None) = True" |
  "Abs (Some v) \<sqsubseteq> Abs (Some v') = v \<sqsubseteq> v'" |
  "Wrong \<sqsubseteq> Wrong = True" |
  "(v::val) \<sqsubseteq> v' = False"

subsection "Set monad"

definition set_bind :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
  "set_bind m f \<equiv> { v. \<exists> v'. v' \<in> m \<and> v \<in> f v' }"
declare set_bind_def[simp]

syntax "_set_bind" :: "[pttrns,'a set,'b] \<Rightarrow> 'c" ("(_ \<leftarrow> _;//_)" 0)
translations "P \<leftarrow> E; F" \<rightleftharpoons> "CONST set_bind E (\<lambda>P. F)"

definition errset_bind :: "val set \<Rightarrow> (val \<Rightarrow> val set) \<Rightarrow> val set" where
  "errset_bind m f \<equiv> { v. \<exists> v'. v' \<in> m \<and> v' \<noteq> Wrong \<and> v \<in> f v' } \<union> {v. v = Wrong \<and> Wrong \<in> m }"
declare errset_bind_def[simp]

syntax "_errset_bind" :: "[pttrns,val set,val] \<Rightarrow> 'c" ("(_ := _;//_)" 0)
translations "P := E; F" \<rightleftharpoons> "CONST errset_bind E (\<lambda>P. F)"

definition return :: "val \<Rightarrow> val set" where
  "return v \<equiv> {v'. v' \<sqsubseteq> v }"
declare return_def[simp]

subsection "Denotational semantics"

type_synonym tyenv = "(val set) list"
type_synonym env = "val list"

inductive iterate :: "(env \<Rightarrow> val set) \<Rightarrow> env \<Rightarrow> val \<Rightarrow> bool" where
  iterate_none[intro!]: "iterate Ee \<rho> (Fun {||})" |
  iterate_again[intro!]: "\<lbrakk> iterate Ee \<rho> f; f' \<in> Ee (f#\<rho>) \<rbrakk> \<Longrightarrow> iterate Ee \<rho> f'"

abbreviation apply_fun :: "val set \<Rightarrow> val set \<Rightarrow> val set" where
  "apply_fun V1 V2 \<equiv> (v1 := V1; v2 := V2;
                       case v1 of Fun f \<Rightarrow>
                          (v2',v3') \<leftarrow> fset f;
                          if v2' \<sqsubseteq> v2 then return v3' else {}
                       | _ \<Rightarrow> return Wrong)"

fun E :: "exp \<Rightarrow> env \<Rightarrow> val set" where
  Enat: "E (ENat n) \<rho> = return (VNat n)" |
  Evar: "E (EVar n) \<rho> = return (\<rho>!n)" |
  Elam: "E (ELam \<tau> e) \<rho> = {v. \<exists> f. v = Fun f \<and> (\<forall> v1 v2'. (v1,v2') \<in> fset f \<longrightarrow>
      (\<exists> v2. v2 \<in> E e (v1#\<rho>) \<and> v2' \<sqsubseteq> v2)) }" |
  Eapp: "E (EApp e1 e2) \<rho> = apply_fun (E e1 \<rho>) (E e2 \<rho>)" |
  Efix: "E (EFix \<tau> e) \<rho> = { v. iterate (E e) \<rho> v }" |
  Eabs: "E (EAbs e) \<rho> = {v. (\<exists> v'. v = Abs (Some v') \<and> v' \<in> E e \<rho>)
                               \<or> (v = Abs None \<and> E e \<rho> = {}) }" |
  Einst: "E (EInst e \<tau>) \<rho> =
       (v := E e \<rho>;
        case v of
          Abs None \<Rightarrow> {}
        | Abs (Some v') \<Rightarrow> return v'
        | _ \<Rightarrow> return Wrong)"

subsection "Types: substitution and semantics"

fun shift :: "nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ty" where
  "shift k c TNat = TNat" |
  "shift k c (TVar n) = (if c \<le> n then TVar (n + k) else TVar n)" |
  "shift k c (\<sigma> \<rightarrow> \<sigma>') = (shift k c \<sigma>) \<rightarrow> (shift k c \<sigma>')" |
  "shift k c (Forall \<sigma>) = Forall (shift k (Suc c) \<sigma>)"

fun subst :: "nat \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty" where
  "subst k \<tau> TNat = TNat" |
  "subst k \<tau> (TVar n) = (if k = n then \<tau>
                         else if k < n then TVar (n - 1)
                         else TVar n)" |
  "subst k \<tau> (\<sigma> \<rightarrow> \<sigma>') = (subst k \<tau> \<sigma>) \<rightarrow> (subst k \<tau> \<sigma>')" |
  "subst k \<tau> (Forall \<sigma>) = Forall (subst (Suc k) (shift (Suc 0) 0 \<tau>) \<sigma>)"

fun T :: "ty \<Rightarrow> tyenv \<Rightarrow> val set" where
 Tnat: "T TNat \<rho> = {v. \<exists> n. v = VNat n }" |
 Tvar: "T (TVar n) \<rho> = (if n < length \<rho> then
                         {v. \<exists> v'. v'\<in>\<rho>!n \<and> v \<sqsubseteq> v' \<and> v \<noteq> Wrong}
                        else {})" |
 Tfun: "T (\<sigma> \<rightarrow> \<tau>) \<rho> = {v. \<exists> f. v = Fun f \<and>
                        (\<forall> v1 v2'.(v1,v2')\<in>fset f \<longrightarrow>
                          v1\<in>T \<sigma> \<rho>\<longrightarrow>(\<exists> v2. v2 \<in> T \<tau> \<rho> \<and> v2' \<sqsubseteq> v2))}" |
 Tall: "T (Forall \<tau>) \<rho> = {v. (\<exists>v'. v = Abs (Some v') \<and> (\<forall> V. v' \<in> T \<tau> (V#\<rho>)))
                           \<or> v = Abs None }"

subsection "Type system"

type_synonym tyctx = "(ty \<times> nat) list \<times> nat"

definition wf_tyvar :: "tyctx \<Rightarrow> nat \<Rightarrow> bool" where
  "wf_tyvar \<Gamma> n \<equiv> n < snd \<Gamma>"
definition push_ty :: "ty \<Rightarrow> tyctx \<Rightarrow> tyctx" where
  "push_ty \<tau> \<Gamma> \<equiv> ((\<tau>,snd \<Gamma>) # fst \<Gamma>, snd \<Gamma>)"
definition push_tyvar :: "tyctx \<Rightarrow> tyctx" where
  "push_tyvar \<Gamma> \<equiv> (fst \<Gamma>, Suc (snd \<Gamma>))"

definition good_ctx :: "tyctx \<Rightarrow> bool" where
  "good_ctx \<Gamma> \<equiv> \<forall> n. n < length (fst \<Gamma>) \<longrightarrow> snd ((fst \<Gamma>) ! n) \<le> snd \<Gamma>"

definition lookup :: "tyctx \<Rightarrow> nat \<Rightarrow> ty option" where
  "lookup \<Gamma> n \<equiv> (if n < length (fst \<Gamma>) then
                    let k = snd \<Gamma> - snd ((fst \<Gamma>)!n) in
                    Some (shift k 0 (fst ((fst \<Gamma>)!n)))
                  else None)"

inductive well_typed :: "tyctx \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [55,55,55] 54) where
  wtnat[intro!]: "\<Gamma> \<turnstile> ENat n : TNat" |
  wtvar[intro!]: "\<lbrakk> lookup \<Gamma> n = Some \<tau> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EVar n : \<tau>" |
  wtapp[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e : \<sigma> \<rightarrow> \<tau>; \<Gamma> \<turnstile> e' : \<sigma> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EApp e e' : \<tau>" |
  wtlam[intro!]: "\<lbrakk> push_ty \<sigma> \<Gamma> \<turnstile> e : \<tau> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> ELam \<sigma> e : \<sigma> \<rightarrow> \<tau>" |
  wtfix[intro!]: "\<lbrakk> push_ty (\<sigma>\<rightarrow>\<tau>) \<Gamma> \<turnstile> e : \<sigma>\<rightarrow>\<tau> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EFix (\<sigma> \<rightarrow> \<tau>) e : \<sigma> \<rightarrow> \<tau>" |
  wtabs[intro!]: "\<lbrakk> push_tyvar \<Gamma> \<turnstile> e : \<tau> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EAbs e : Forall \<tau>" |
  wtinst[intro!]: "\<lbrakk> \<Gamma> \<turnstile> e : Forall \<tau> \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EInst e \<sigma> : (subst 0 \<sigma> \<tau>)"

inductive wfenv :: "env \<Rightarrow> tyenv \<Rightarrow> tyctx \<Rightarrow> bool" ("\<turnstile> _,_ : _" [55,55,55] 54) where
  wfnil[intro!]: "\<turnstile> [],[] : ([],0)" |
  wfvbind[intro!]: "\<lbrakk> \<turnstile> \<rho>,\<eta> : \<Gamma>; v \<in> T \<tau> \<eta> \<rbrakk> \<Longrightarrow> \<turnstile>  (v#\<rho>),\<eta> : push_ty \<tau> \<Gamma>" |
  wftbind[intro!]: "\<lbrakk> \<turnstile> \<rho>,\<eta> : \<Gamma> \<rbrakk> \<Longrightarrow> \<turnstile> \<rho>, (V#\<eta>) : push_tyvar \<Gamma>"

inductive_cases
  wtnat_inv[elim!]: "\<Gamma> \<turnstile> ENat n : \<tau>" and
  wtvar_inv[elim!]: "\<Gamma> \<turnstile> EVar n : \<tau>" and
  wtapp_inv[elim!]: "\<Gamma> \<turnstile> EApp e e' : \<tau>" and
  wtlam_inv[elim!]: "\<Gamma> \<turnstile> ELam \<sigma> e : \<tau>" and
  wtfix_inv[elim!]: "\<Gamma> \<turnstile> EFix \<sigma> e : \<tau>" and
  wtabs_inv[elim!]: "\<Gamma> \<turnstile> EAbs e : \<tau>" and
  wtinst_inv[elim!]: "\<Gamma> \<turnstile> EInst e \<sigma> : \<tau>"

lemma wfenv_good_ctx: "\<turnstile> \<rho>,\<eta> : \<Gamma> \<Longrightarrow> good_ctx \<Gamma>"
proof (induction rule: wfenv.induct)
  case wfnil
  then show ?case by (force simp: good_ctx_def)
next
  case (wfvbind \<rho> \<eta> \<Gamma> v \<tau>)
  then show ?case
    apply (simp add: good_ctx_def push_ty_def) apply (cases \<Gamma>) apply simp
    apply clarify apply (rename_tac n) apply (case_tac n) apply force apply force done
next
  case (wftbind \<rho> \<eta> \<Gamma> V)
  then show ?case
    apply (simp add: good_ctx_def push_tyvar_def) apply (cases \<Gamma>) apply simp
    apply clarify apply (rename_tac n) apply (case_tac n) apply auto done
qed

subsection "Well-typed Programs don't go wrong"

lemma nth_append1[simp]: "n < length \<rho>1 \<Longrightarrow> (\<rho>1@\<rho>2)!n = \<rho>1!n"
proof (induction \<rho>1 arbitrary: \<rho>2 n)
  case Nil
  then show ?case by auto
next
  case (Cons a \<rho>1)
  then show ?case by (cases n) auto
qed

lemma nth_append2[simp]: "n \<ge> length \<rho>1 \<Longrightarrow> (\<rho>1@\<rho>2)!n = \<rho>2!(n - length \<rho>1)"
proof (induction \<rho>1 arbitrary: \<rho>2 n)
  case Nil
  then show ?case by auto
next
  case (Cons a \<rho>1)
  then show ?case by (cases n) auto
qed

lemma shift_append_preserves_T_aux:
  shows "T \<tau> (\<rho>1@\<rho>3) = T (shift (length \<rho>2) (length \<rho>1) \<tau>) (\<rho>1@\<rho>2@\<rho>3)"
proof (induction \<tau> arbitrary: \<rho>1 \<rho>2 \<rho>3)
  case (Forall \<tau>)
  then show ?case
    apply simp
    apply (rule equalityI) apply (rule subsetI) apply (simp only: mem_Collect_eq)
     apply (erule disjE) apply (erule exE) apply (erule conjE) apply (rule disjI1)
      apply (rename_tac x v')
      apply (rule_tac x=v' in exI) apply simp apply clarify
      apply (rename_tac V)
      apply (erule_tac x=V in allE)
      apply (subgoal_tac "T \<tau> ((V#\<rho>1) @ \<rho>3) =
       T (shift (length \<rho>2) (length (V#\<rho>1)) \<tau>) ((V#\<rho>1) @ \<rho>2 @ \<rho>3)")
       prefer 2 apply blast apply force
     apply (rule disjI2) apply force
    apply (rule subsetI) apply (simp only: mem_Collect_eq)
    apply (erule disjE) apply (erule exE) apply (erule conjE) apply (rule disjI1)
     apply (rename_tac x v')
     apply (rule_tac x=v' in exI) apply simp apply clarify
     apply (rename_tac V)
     apply (erule_tac x=V in allE)
     apply (subgoal_tac "T \<tau> ((V#\<rho>1) @ \<rho>3) =
       T (shift (length \<rho>2) (length (V#\<rho>1)) \<tau>) ((V#\<rho>1) @ \<rho>2 @ \<rho>3)")
      prefer 2 apply blast apply force
    apply (rule disjI2) apply force done
qed force+

lemma shift_append_preserves_T: shows "T \<tau> \<rho>3 = T (shift (length \<rho>2) 0 \<tau>) (\<rho>2@\<rho>3)"
    using shift_append_preserves_T_aux[of \<tau> "[]" \<rho>3 \<rho>2] by auto

lemma drop_shift_preserves_T:
  assumes k: "k \<le> length \<rho>" shows "T \<tau> (drop k \<rho>) = T (shift k 0 \<tau>) \<rho>"
proof -
  let ?r2 = "take k \<rho>" and ?r3 = "drop k \<rho>"
  have 1: "T \<tau> (?r3) = T (shift (length ?r2) 0 \<tau>) (?r2@?r3)"
    using shift_append_preserves_T_aux[of \<tau> "[]" ?r3 ?r2] by simp
  have 2: "?r2@?r3 = \<rho>" by simp
  from k have 3: "length ?r2 = k" by simp
  from 1 2 3 show ?thesis by simp
qed

lemma shift_cons_preserves_T: shows "T \<tau> \<rho> = T (shift (Suc 0) 0 \<tau>) (b#\<rho>)"
  using drop_shift_preserves_T[of "Suc 0" "b#\<rho>" \<tau>] by simp

lemma compose_shift: shows "shift (j+k) c \<tau> = shift j c (shift k c \<tau>)"
  by (induction \<tau> arbitrary: j k c) auto

lemma shift_zero_id[simp]: "shift 0 c \<tau> = \<tau>"
  by (induction \<tau> arbitrary: c) auto

lemma lookup_wfenv: assumes r_g: "\<turnstile> \<rho>,\<eta> : \<Gamma>" and ln: "lookup \<Gamma> n = Some \<tau>"
  shows "\<exists> v. \<rho>!n = v \<and> v \<in> T \<tau> \<eta>"
  using r_g ln
proof (induction \<rho> \<eta> \<Gamma> arbitrary: n \<tau> rule: wfenv.induct)
  case wfnil
  then show ?case unfolding lookup_def by force
next
  case (wfvbind \<rho> \<eta> \<Gamma> v \<tau>')
  from wfvbind(2) have vtp: "v \<in> T \<tau>' \<eta>" .
  show ?case
  proof (cases n)
    case 0
    from 0 wfvbind(4) have t: "\<tau> =  shift 0 0 \<tau>'" unfolding lookup_def by (simp add: push_ty_def)
    from 0 vtp t show ?thesis by simp
  next
    case (Suc n')
    let ?G = "push_ty \<tau>' \<Gamma>"
    from wfvbind(4) Suc obtain \<sigma> k where gnp: "(fst \<Gamma>)!n' = (\<sigma>,k)" and t: "\<tau> = shift (snd \<Gamma> - k) 0 \<sigma>"
      and npg: "n' < length (fst \<Gamma>)"
      unfolding lookup_def push_ty_def apply (cases "n' < length (fst \<Gamma>)") apply auto
      apply (cases "fst \<Gamma> ! n'") apply auto done
    from gnp Suc npg t have ln: "lookup \<Gamma> n' = Some \<tau>" unfolding lookup_def by auto
    from wfvbind(3) ln obtain v' where rnp: "\<rho>!n' = v'" and vt: "v' \<in> T \<tau> \<eta>" by blast
    from Suc rnp vt show ?thesis by simp
  qed
next
  case (wftbind \<rho> \<eta> \<Gamma> V)
  let ?a = "fst \<Gamma>" and ?b = "snd \<Gamma>"
  obtain \<sigma> k where s: "\<sigma> = fst (fst \<Gamma> ! n)" and k: "k = snd (fst \<Gamma> ! n)" by auto
  from wftbind(3) s k have t: "\<tau> = shift (Suc ?b - k) 0 \<sigma>" and nl: "n < length (fst \<Gamma>)"
    unfolding push_tyvar_def lookup_def apply auto
     apply (case_tac "n < length (fst \<Gamma>)", auto)+ done
  let ?t = "shift (?b - k) 0 (fst (?a ! n))"
  from wftbind(3) k have ln: "lookup \<Gamma> n = Some ?t"
    unfolding push_tyvar_def lookup_def
    apply (cases \<Gamma>) apply (rename_tac k' G) apply simp apply (case_tac "n < length k'") by auto
  from wftbind(2) ln obtain v' where rn_vp: "\<rho> ! n = v'" and vp_t: "v' \<in> T ?t \<eta>" by blast
  from vp_t have "v' \<in> T (shift (Suc 0) 0 ?t) (V # \<eta>)" using shift_cons_preserves_T by auto
  hence vp_t2: "v' \<in> T (shift (Suc 0 + (?b - k)) 0 (fst (?a!n))) (V # \<eta>)"
    using compose_shift[of "Suc 0" "?b - k" 0 "fst (?a!n)"] by simp
  from wftbind(1) have "good_ctx \<Gamma>" using wfenv_good_ctx by blast
  from this k nl have "?b \<ge> k" unfolding good_ctx_def by auto
  from this have "Suc 0 + (?b - k) = Suc ?b - k" by simp
  from this vp_t2 have vp_t3: "v' \<in> T (shift (Suc ?b - k) 0 (fst (?a!n))) (V # \<eta>)" by simp
  from rn_vp vp_t3 t s show ?case by auto
qed

lemma less_wrong[elim!]: "\<lbrakk> v \<sqsubseteq> Wrong; v = Wrong \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac v) auto

lemma less_nat[elim!]: "\<lbrakk> v \<sqsubseteq> VNat n; v = VNat n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac v) auto

lemma less_fun[elim!]: "\<lbrakk> v \<sqsubseteq> Fun f; \<And> f'. \<lbrakk> v = Fun f'; fset f' \<subseteq> fset f \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac v) auto

lemma less_refl[simp]: "v \<sqsubseteq> v"
proof (induction v)
    case (Abs v')
    then show ?case by (cases v') auto
qed force+

lemma less_trans: fixes v1::val and v2::val and v3::val
  shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v3 \<rbrakk> \<Longrightarrow> v1 \<sqsubseteq> v3"
proof (induction v2 arbitrary: v1 v3)
  case (VNat n)
  then show ?case by (cases v1) auto
next
  case (Fun t)
  then show ?case
    apply (cases v1)
       apply force
      apply simp
      apply (cases v3)
         apply auto done
next
  case (Abs v)
  then show ?case
    apply (cases v1) apply force apply force apply (case_tac v3) apply force apply force
      apply (rename_tac v' v3') apply simp apply (cases v) apply (case_tac v')
        apply force apply force
      apply (case_tac v3') apply force apply simp apply (case_tac v')
       apply force+ done
next
  case Wrong
  then show ?case by auto
qed

lemma T_down_closed: assumes vt: "v \<in> T \<tau> \<eta>" and vp_v: "v' \<sqsubseteq> v"
  shows "v' \<in> T \<tau> \<eta>"
  using vt vp_v
proof (induction \<tau> arbitrary: v v' \<eta>)
  case (TVar x v v' \<eta>)
  then show ?case
    apply simp apply (case_tac "x < length \<eta>")
     apply simp apply clarify
     apply (rule_tac x=v' in exI)
     apply simp apply (rule conjI)
      apply (rule less_trans) apply blast apply blast
     apply (case_tac v')
        apply (case_tac v)
           apply force+
      apply (case_tac v)
         apply force+ done
next
  case TNat
  then show ?case by auto
next
  case (Fun \<tau>1 \<tau>2)
  then show ?case apply simp apply clarify apply (rule_tac x=f' in exI) apply fastforce done
next
  case (Forall \<tau> v v' \<eta>)
  then show ?case
    apply simp apply (erule disjE) apply clarify apply (cases v') apply force apply force
      apply simp apply (rename_tac v'') apply (case_tac v'') apply simp apply simp apply clarify
      apply (erule_tac x=V in allE) apply blast
     apply force
    apply simp
    apply (case_tac v') apply auto done
qed

lemma wrong_not_in_T: "Wrong \<notin> T \<tau> \<eta>"
  by (induction \<tau>) auto

lemma fun_app: assumes vmn: "V \<subseteq> T (m \<rightarrow> n) \<eta>" and v2s: "V' \<subseteq> T m \<eta>"
  shows "apply_fun V V' \<subseteq> T n \<eta>"
  using vmn v2s apply simp apply (rule conjI)
   prefer 2 apply force
  apply clarify
  apply (erule disjE)
   prefer 2 using wrong_not_in_T apply blast
  apply clarify apply (rename_tac v'') apply (case_tac v') apply auto
  apply (rename_tac v1 v2) apply (case_tac "v1 \<sqsubseteq> v''") apply auto
  apply (subgoal_tac "\<forall>v1 v2'.
                (v1, v2') \<in> fset x2 \<longrightarrow> v1 \<in> T m \<eta> \<longrightarrow> (\<exists>v2. v2 \<in> T n \<eta> \<and> v2' \<sqsubseteq> v2)")
   prefer 2 apply blast
  apply (rename_tac v1 v2)
  apply (erule_tac x=v1 in allE) apply (erule_tac x=v2 in allE) apply (erule impE) apply simp
  apply (erule impE) using T_down_closed apply blast
  apply clarify  using T_down_closed apply blast
  done

lemma T_eta: "{v. \<exists>v'. v' \<in> T \<sigma> (\<eta>) \<and> v \<sqsubseteq> v' \<and> v \<noteq> Wrong} = T \<sigma> \<eta>"
  apply auto
   using T_down_closed apply blast
  apply (rename_tac v)
  apply (rule_tac x=v in exI)
  apply simp
  using wrong_not_in_T apply blast done

lemma compositionality: "T \<tau> (\<eta>1 @ (T \<sigma> (\<eta>1@\<eta>2)) # \<eta>2) = T (subst (length \<eta>1) \<sigma> \<tau>) (\<eta>1@\<eta>2)"
proof (induction \<tau> arbitrary: \<sigma> \<eta>1 \<eta>2)
  case (TVar x)
  then show ?case
    apply (case_tac "length \<eta>1 = x") apply simp using T_eta apply blast
    apply (case_tac "length \<eta>1 < x") apply (subgoal_tac "\<exists> x'. x = Suc x'") prefer 2
      apply (cases x)
       apply force+
    done
next
  case TNat
  then show ?case by auto
next
  case (Fun \<tau>1 \<tau>2)
  then show ?case by auto
next
  case (Forall \<tau>)
  show "T (Forall \<tau>) (\<eta>1 @ T \<sigma> (\<eta>1 @ \<eta>2) # \<eta>2) =
        T (subst (length \<eta>1) \<sigma> (Forall \<tau>)) (\<eta>1 @ \<eta>2)"
    apply simp
    apply (rule equalityI) apply (rule subsetI) apply (simp only: mem_Collect_eq)
     apply (erule disjE) prefer 2 apply force apply (erule exE) apply (erule conjE) apply (rule disjI1)
     apply (rule_tac x=v' in exI) apply simp apply clarify
     apply (erule_tac x="V" in allE)
     prefer 2 apply (rule subsetI) apply (simp only: mem_Collect_eq)
     apply (erule disjE) prefer 2 apply force apply (erule exE) apply (erule conjE) apply (rule disjI1)
     apply (rule_tac x=v' in exI) apply simp apply clarify
     apply (erule_tac x="V" in allE)
     defer
  proof -
    fix x v' V
    let ?L1 = "length \<eta>1" and ?R1 = "V#\<eta>1" and ?s = "shift (Suc 0) 0 \<sigma>"
    assume 1: "v' \<in> T \<tau> (V # (\<eta>1 @ T \<sigma> (\<eta>1 @ \<eta>2) # \<eta>2))"
    from 1 have a: "v' \<in> T \<tau> (?R1 @ T \<sigma> (\<eta>1@\<eta>2) # \<eta>2)" by simp

    have b: "T \<sigma> (\<eta>1@\<eta>2) = T ?s (V#(\<eta>1@\<eta>2))" by (rule shift_cons_preserves_T)
    from a b have c: "v' \<in> T \<tau> (?R1 @ T ?s (?R1 @ \<eta>2) # \<eta>2)" by simp
    from Forall[of ?R1 ?s \<eta>2] have 2: "T \<tau> (?R1 @ T ?s (?R1 @ \<eta>2) # \<eta>2) =
                                  T (subst (length ?R1) ?s \<tau>) (?R1 @ \<eta>2)" by simp
    from c 2 show "v' \<in> T (subst (Suc ?L1) ?s \<tau>) (V # (\<eta>1 @ \<eta>2))" by simp
  next
    fix x v' V
    let ?L1 = "length \<eta>1" and ?R1 = "V#\<eta>1" and ?s = "shift (Suc 0) 0 \<sigma>"
    assume 1: "v' \<in> T (subst (Suc (length \<eta>1)) (shift (Suc 0) 0 \<sigma>) \<tau>) (V # \<eta>1 @ \<eta>2)"
    from Forall[of ?R1 ?s \<eta>2] have 2: "T \<tau> (?R1 @ T ?s (?R1 @ \<eta>2) # \<eta>2) =
                                  T (subst (length ?R1) ?s \<tau>) (?R1 @ \<eta>2)" by simp
    from 1 2 have 3: "v' \<in> T \<tau> (?R1 @ T ?s (?R1 @ \<eta>2) # \<eta>2)" by simp
    have b: "T \<sigma> (\<eta>1@\<eta>2) = T ?s (V#(\<eta>1@\<eta>2))" by (rule shift_cons_preserves_T)
    from 3 b have a: "v' \<in> T \<tau> (?R1 @ T \<sigma> (\<eta>1@\<eta>2) # \<eta>2)" by simp
    from this show "v' \<in> T \<tau> (V # \<eta>1 @ T \<sigma> (\<eta>1 @ \<eta>2) # \<eta>2)" by simp
  qed
qed

lemma iterate_sound:
  assumes it: "iterate Ee \<rho> v"
    and IH: "\<forall> v. v \<in> T (\<sigma>\<rightarrow>\<tau>) \<eta> \<longrightarrow> Ee (v#\<rho>) \<subseteq> T (\<sigma>\<rightarrow>\<tau>) \<eta>"
  shows "v \<in> T (\<sigma>\<rightarrow>\<tau>) \<eta>" using it IH
proof (induction rule: iterate.induct)
  case (iterate_none Ee \<rho>)
  then show ?case by auto
next
  case (iterate_again Ee \<rho> f f')
  from iterate_again have f_st: "f \<in> T (\<sigma>\<rightarrow>\<tau>) \<eta>" by blast
  from iterate_again f_st have "Ee (f#\<rho>) \<subseteq> T (\<sigma>\<rightarrow>\<tau>) \<eta>" by blast
  from this iterate_again show ?case by auto
qed

theorem welltyped_dont_go_wrong:
  assumes wte: "\<Gamma> \<turnstile> e : \<tau>" and wfr: "\<turnstile> \<rho>,\<eta> : \<Gamma>"
  shows "E e \<rho> \<subseteq> T \<tau> \<eta>"
  using wte wfr
proof (induction \<Gamma> e \<tau> arbitrary: \<rho> \<eta> rule: well_typed.induct)
  case (wtnat \<Gamma> n \<rho> \<eta>)
  then show ?case by auto
next
  case (wtvar \<Gamma> n \<tau> \<rho> \<eta>)
  from wtvar obtain v where lx: "\<rho> ! n = v" and vt: "v \<in> T \<tau> \<eta>"using lookup_wfenv by blast
  from lx vt show ?case apply auto using T_down_closed[of "\<rho>!n" \<tau> "\<eta>"] by blast
next
  case (wtapp \<Gamma> e \<sigma> \<tau> e' \<rho> \<eta>)
  from wtapp have Ee: "E e \<rho> \<subseteq> T (\<sigma> \<rightarrow> \<tau>) \<eta>" by blast
  from wtapp have Eep: "E e' \<rho> \<subseteq> T \<sigma> \<eta>" by blast
  from Ee Eep show ?case using fun_app by simp
next
  case (wtlam \<sigma> \<Gamma> e \<tau> \<rho> \<eta>)
  show ?case
    apply simp apply (rule subsetI) apply clarify apply (rule_tac x=f in exI) apply simp
    apply clarify apply (erule_tac x=v1 in allE) apply (erule_tac x=v2' in allE) apply clarify
  proof -
    fix f v1 v2' v2
    assume v1_T: "v1 \<in> T \<sigma> \<eta>" and v2_E: "v2 \<in> E e (v1#\<rho>)" and v2p_v2: "v2' \<sqsubseteq> v2"
    let ?r = "v1#\<rho>"
    from wtlam(3) v1_T have 1: "\<turnstile> v1#\<rho>,\<eta> : push_ty \<sigma> \<Gamma>" by blast
    from wtlam(2) 1 have IH: "E e (v1#\<rho>) \<subseteq> T \<tau> \<eta>" by blast
    from IH v2_E have v2_T: "v2 \<in> T \<tau> \<eta>" by blast
    from v2_T have v2_Tb: "v2 \<in> T \<tau> \<eta>" by simp
    from v2_Tb v2p_v2 show "\<exists>v2. v2 \<in> T \<tau> \<eta> \<and> v2' \<sqsubseteq> v2 " by blast
  qed
next
  case (wtfix \<sigma> \<tau> \<Gamma> e \<rho> \<eta>)
  have "\<forall> v. iterate (E e) \<rho> v \<longrightarrow> v \<in> T (\<sigma> \<rightarrow> \<tau>) \<eta>"
  proof clarify
    fix v assume it: "iterate (E e) \<rho> v"
    have 1: " \<forall>v. v \<in> T (\<sigma> \<rightarrow> \<tau>) \<eta> \<longrightarrow> E e (v#\<rho>) \<subseteq> T (\<sigma> \<rightarrow> \<tau>) \<eta>"
    proof clarify
      fix v' v'' assume 2: "v' \<in> T (\<sigma>\<rightarrow>\<tau>) \<eta>" and 3: "v'' \<in> E e (v'#\<rho>)"
      from wtfix(3) 2 have "\<turnstile> (v'#\<rho>),\<eta> : push_ty (\<sigma> \<rightarrow> \<tau>) \<Gamma>" by blast
      from wtfix(2) this have IH: "E e (v'#\<rho>) \<subseteq> T (\<sigma>\<rightarrow>\<tau>) \<eta>" by blast
      from 3 IH have "v'' \<in> T (\<sigma>\<rightarrow>\<tau>)  \<eta>" by blast
      from this show "v'' \<in> T (\<sigma> \<rightarrow> \<tau>) \<eta>" by simp
    qed
    from it 1 show "v \<in> T (\<sigma> \<rightarrow> \<tau>) \<eta>" using iterate_sound[of "E e" \<rho> v \<sigma> \<tau>] by blast
  qed
  from this show ?case by auto
next
  case (wtabs \<Gamma> e \<tau> \<rho> \<eta>)
  show ?case apply simp apply (rule subsetI) apply (simp only: mem_Collect_eq)
    apply (erule disjE) apply (erule exE) apply (erule conjE) apply (rule disjI1)
     apply (rule_tac x=v' in exI) apply simp apply clarify prefer 2 apply (rule disjI2)
     apply force
  proof -
    fix x v' V assume 2: "v' \<in> E e \<rho>"
    from wtabs(3) have 3: " \<turnstile> \<rho>,(V#\<eta>) : push_tyvar \<Gamma>" by blast
    from wtabs(2) 3 have IH: "E e \<rho> \<subseteq> T \<tau> (V#\<eta>)" by blast
    from 2 IH show "v' \<in> T \<tau> (V#\<eta>)" by (case_tac \<rho>) auto
  qed
next
  case (wtinst \<Gamma> e \<tau> \<sigma> \<rho> \<eta>)
  from wtinst(2) wtinst(3) have IH: "E e \<rho> \<subseteq> T (Forall \<tau>) \<eta>" by blast
  show ?case
    apply simp apply (rule conjI)
     apply (rule subsetI) apply (simp only: mem_Collect_eq) apply (erule exE)
     apply (erule conjE)+
  proof -
    fix x v' assume vp_E: "v' \<in> E e \<rho>" and vp_w: "v' \<noteq> Wrong" and
      x: "x \<in> (case v' of Abs None \<Rightarrow> {} | Abs (Some xa) \<Rightarrow> return xa
             | _ \<Rightarrow> {v'. v' \<sqsubseteq> Wrong})"
    from IH vp_E have vp_T: "v' \<in> T (Forall \<tau>) \<eta>" by blast
    from vp_T have "(\<exists>v''. v' = Abs (Some v'') \<and> (\<forall> V. v'' \<in> T \<tau> (V#\<eta>)))
                           \<or> v' = Abs None" by simp
    from this show "x \<in> T (subst 0 \<sigma> \<tau>) \<eta>"
    proof
      assume "\<exists>v''. v' = Abs (Some v'') \<and> (\<forall> V. v'' \<in> T \<tau> (V#\<eta>))"
      from this obtain v'' where vp: "v' = Abs (Some v'')" and
        vpp_T: "\<forall> V. v'' \<in> T \<tau> (V#\<eta>)" by blast
      from vp x have x_vpp: "x \<sqsubseteq> v''" by auto
      let ?V = "T \<sigma> \<eta>"
      from vpp_T have "v'' \<in> T \<tau> (?V#\<eta>)" by blast
      from this have "v'' \<in> T (subst 0 \<sigma> \<tau>) \<eta>" using compositionality[of \<tau> "[]" \<sigma>] by simp
      from this x_vpp show "x \<in> T (subst 0 \<sigma> \<tau>) \<eta>" using T_down_closed by blast
    next
      assume vp: "v' = Abs None"
      from vp x show "x \<in> T (subst 0 \<sigma> \<tau>) \<eta>" by simp
    qed
  next
    from IH show "{v. v = Wrong \<and> Wrong \<in> E e \<rho>} \<subseteq> T (subst 0 \<sigma> \<tau>) \<eta>"
      using wrong_not_in_T by auto
  qed
qed

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: cardinals.thy                                                        *)
(* Author: Frank Zeyda, University of York (UK)                               *)
(******************************************************************************)
(* LAST REVIEWED: 27 March 2014 *)

section \<open> Lightweight Cardinals \<close>

theory Lightweight_Cardinals
imports
  Main "HOL.Real"
  "HOL-Library.Countable_Set"
  "HOL-Cardinals.Cardinals"
  "Z_Toolkit.Infinity" UNIV_TYPE
begin

subsection \<open> Cardinal Order \<close>

definition leq_card :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infix "\<preceq>\<^sub>c" 50) where
"(A \<preceq>\<^sub>c B) \<longleftrightarrow> (\<exists> f . (inj_on f A) \<and> (f ` A) \<subseteq> B)"

definition equal_card :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infix "\<equiv>\<^sub>c" 50) where
"(A \<equiv>\<^sub>c B) \<longleftrightarrow> (A \<preceq>\<^sub>c B) \<and> (B \<preceq>\<^sub>c A)"

definition less_card :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infix "\<prec>\<^sub>c" 50) where
"(A \<prec>\<^sub>c B) \<longleftrightarrow> (A \<preceq>\<^sub>c B) \<and> \<not> (A \<equiv>\<^sub>c B)"

lemmas card_ord_defs =
  leq_card_def
  equal_card_def
  less_card_def

subsection \<open>  Constructors \<close>

definition fin_card :: "nat \<Rightarrow> nat set" ("c\<^sub>f") where
"c\<^sub>f n = {1..n}"

definition type_card :: "'a itself \<Rightarrow> 'a set" ("c\<^sub>\<T>") where
"c\<^sub>\<T> (t :: 'a itself) = UNIV_T('a)"

definition bool_card :: "bool set" ("c\<^sub>\<bool>") where
"c\<^sub>\<bool> = c\<^sub>\<T> TYPE(bool)"

definition nat_card :: "nat set" ("c\<^sub>\<nat>") where
"c\<^sub>\<nat> = c\<^sub>\<T> TYPE(nat)"

definition real_card :: "real set" ("c\<^sub>\<real>") where
"c\<^sub>\<real> = c\<^sub>\<T> TYPE(real)"

lemmas card_defs =
  fin_card_def
  type_card_def
  bool_card_def
  nat_card_def
  real_card_def

subsection \<open> Theorems \<close>

subsubsection \<open> Library Link \<close>

theorem ordLess_lemma :
"(A <o B) \<longleftrightarrow> (A \<le>o B) \<and> \<not> (A =o B)"
apply (metis not_ordLess_ordIso ordLeq_iff_ordLess_or_ordIso)
done

section \<open> Transfer Rules \<close>

theorem leq_card_iff_ordLeq :
"c1 \<preceq>\<^sub>c c2 \<longleftrightarrow> |c1| \<le>o |c2|"
apply (fold card_of_ordLeq)
apply (unfold leq_card_def)
apply (simp)
done

theorem equal_card_iff_ordIso :
"c1 \<equiv>\<^sub>c c2 \<longleftrightarrow> |c1| =o |c2|"
apply (unfold equal_card_def)
apply (unfold leq_card_iff_ordLeq)
apply (unfold ordIso_iff_ordLeq)
apply (rule refl)
done

theorem less_card_iff_ordLess :
"c1 \<prec>\<^sub>c c2 \<longleftrightarrow> |c1| <o |c2|"
apply (unfold less_card_def equal_card_def)
apply (unfold leq_card_iff_ordLeq)
apply (unfold ordLess_lemma ordIso_iff_ordLeq)
apply (rule refl)
done

lemmas card_transfer =
  leq_card_iff_ordLeq
  equal_card_iff_ordIso
  less_card_iff_ordLess

section \<open> Introduction Rules \<close>

theorem leq_card_intro [intro] :
"|c1| \<le>o |c2| \<Longrightarrow> c1 \<preceq>\<^sub>c c2"
apply (simp add: leq_card_iff_ordLeq)
done

theorem equal_card_intro [intro] :
"|c1| =o |c2| \<Longrightarrow> c1 \<equiv>\<^sub>c c2"
apply (simp add: equal_card_iff_ordIso)
done

theorem less_card_intro [intro] :
"|c1| <o |c2| \<Longrightarrow> c1 \<prec>\<^sub>c c2"
apply (simp add: less_card_iff_ordLess)
done

section \<open> Destruction Rules \<close>

theorem leq_card_dest [dest] :
"c1 \<preceq>\<^sub>c c2 \<Longrightarrow> |c1| \<le>o |c2|"
apply (simp add: leq_card_iff_ordLeq)
done

theorem equal_card_dest [dest] :
"c1 \<equiv>\<^sub>c c2 \<Longrightarrow> |c1| =o |c2|"
apply (simp add: equal_card_iff_ordIso)
done

theorem less_card_dest [dest] :
"c1 \<prec>\<^sub>c c2 \<Longrightarrow> |c1| <o |c2|"
apply (simp add: less_card_iff_ordLess)
done

subsubsection \<open> Theorems for @{term "(\<preceq>\<^sub>c)"} \<close>

theorem leq_card_refl :
"(A \<preceq>\<^sub>c A)"
apply (unfold leq_card_def)
apply (rule_tac x = "id" in exI)
apply (simp)
done

theorem leq_card_antisym :
"\<lbrakk>(A \<preceq>\<^sub>c B); (B \<preceq>\<^sub>c A)\<rbrakk> \<Longrightarrow> (A \<equiv>\<^sub>c B)"
apply (unfold equal_card_def)
apply (simp)
done

theorem leq_card_trans :
"\<lbrakk>(A \<preceq>\<^sub>c B); (B \<preceq>\<^sub>c C)\<rbrakk> \<Longrightarrow> (A \<preceq>\<^sub>c C)"
apply (unfold leq_card_def)
apply (clarify)
apply (rename_tac f g)
apply (rule_tac x = "g \<circ> f" in exI)
apply (rule conjI)
\<comment> \<open> Subgoal 1 \<close>
apply (rule comp_inj_on)
apply (assumption)
apply (erule subset_inj_on)
  apply (assumption)
\<comment> \<open> Subgoal 2 \<close>
apply (simp add: image_comp[THEN sym])
apply blast
done

theorem leq_card_linear :
"(A \<preceq>\<^sub>c B) \<or> (B \<preceq>\<^sub>c A)"
apply (unfold leq_card_def)
apply (metis one_set_greater)
done

theorem not_leq_card_dest :
"\<not> (A \<preceq>\<^sub>c B) \<Longrightarrow> (B \<preceq>\<^sub>c A)"
apply (metis leq_card_linear)
done

theorem leq_card_empty :
"{} \<preceq>\<^sub>c C"
apply (unfold leq_card_def)
apply (simp)
done

theorem leq_card_subset :
"A \<subseteq> B \<Longrightarrow> A \<preceq>\<^sub>c B"
apply (unfold leq_card_def)
apply (rule_tac x = "id" in exI)
apply (simp)
done

theorem leq_image_mono :
"A \<preceq>\<^sub>c C \<Longrightarrow> (f ` A) \<preceq>\<^sub>c C"
apply (unfold leq_card_def)
apply (clarify)
apply (rename_tac g)
apply (rule_tac x = "g o (inv_into A f)" in exI)
  apply (rule conjI)
\<comment> \<open> Subgoal 1 \<close>
apply (rule comp_inj_on)
apply (rule inj_on_inv_into)
apply (simp)
apply (erule subset_inj_on)
apply (rule image_subsetI)
apply (erule inv_into_into)
\<comment> \<open> Subgoal 2 \<close>
apply (rule image_subsetI)
apply (unfold comp_def)
apply (metis image_eqI in_mono inv_into_into)
done

subsubsection \<open> Theorems for @{term "(\<equiv>\<^sub>c)"} \<close>

theorem equal_card_bij_betw :
"(A \<equiv>\<^sub>c B) \<longleftrightarrow> (\<exists> f . bij_betw f A B)"
apply (unfold equal_card_def leq_card_def)
apply (safe)
\<comment> \<open> Subgoal 1 \<close>
apply (rename_tac f g)
apply (rule Schroeder_Bernstein)
apply (assumption)+
\<comment> \<open> Subgoal 2 \<close>
apply (unfold bij_betw_def)
apply (rule_tac x = "f" in exI)
apply (clarsimp)
\<comment> \<open> Subgoal 3 \<close>
apply (rule_tac x = "inv_into A f" in exI)
apply (clarsimp)
apply (rule inj_on_inv_into)
apply (simp)
done

theorem equal_card_refl :
"(A \<equiv>\<^sub>c A)"
apply (unfold equal_card_def)
apply (simp add: leq_card_refl)
done

theorem equal_card_sym :
"(A \<equiv>\<^sub>c B) \<longleftrightarrow> (B \<equiv>\<^sub>c A)"
apply (unfold equal_card_def)
apply (safe)
done

theorem equal_card_trans :
"\<lbrakk>(A \<equiv>\<^sub>c B); (B \<equiv>\<^sub>c C)\<rbrakk> \<Longrightarrow> (A \<equiv>\<^sub>c C)"
apply (unfold equal_card_def)
apply (clarsimp)
apply (rule conjI)
apply (erule leq_card_trans)
apply (assumption)
apply (erule leq_card_trans)
apply (assumption)
done

subsubsection \<open> Theorems for @{term "(\<prec>\<^sub>c)"} \<close>

theorem le_imp_leq_card :
"(A \<prec>\<^sub>c B) \<Longrightarrow> (A \<preceq>\<^sub>c B)"
apply (unfold less_card_def)
apply (clarify)
done

theorem le_card_iff :
"(A \<prec>\<^sub>c B) \<longleftrightarrow> \<not> (B \<preceq>\<^sub>c A)"
apply (unfold less_card_def equal_card_def)
apply (metis leq_card_linear)
done

theorem le_card_cases :
"(A \<prec>\<^sub>c B) \<or> (B \<prec>\<^sub>c A) \<or> (A \<equiv>\<^sub>c B)"
apply (simp add: le_card_iff)
apply (simp add: equal_card_def)
done

theorem le_card_trans :
"\<lbrakk>(A \<prec>\<^sub>c B); (B \<prec>\<^sub>c C)\<rbrakk> \<Longrightarrow> (A \<prec>\<^sub>c C)"
apply (simp add: le_card_iff)
apply (metis leq_card_linear leq_card_trans)
done

subsubsection \<open> Theorems for @{term "c\<^sub>f"} \<close>

theorem fin_card_mono :
"n \<le> m \<Longrightarrow> c\<^sub>f n \<preceq>\<^sub>c c\<^sub>f m"
apply (unfold fin_card_def)
apply (unfold leq_card_def)
apply (rule_tac x = "id" in exI)
apply (clarsimp)
done

theorem fin_le_nat_card :
"c\<^sub>f n \<prec>\<^sub>c c\<^sub>\<nat>"
apply (subst le_card_iff)
apply (unfold card_defs)
apply (unfold leq_card_def)
apply (simp add: UNIV_TYPE_def)
apply (clarify)
apply (drule range_inj_infinite)
apply (drule infinite_super)
apply (assumption)
apply (simp)
done

theorem fin_leq_nat_card :
"c\<^sub>f n \<preceq>\<^sub>c c\<^sub>\<nat>"
apply (rule le_imp_leq_card)
apply (rule fin_le_nat_card)
done

subsubsection \<open> Theorems for @{term "c\<^sub>\<bool>"} \<close>

theorem bool_eq_fin_card :
"c\<^sub>\<bool> \<equiv>\<^sub>c c\<^sub>f 2"
apply (unfold equal_card_def leq_card_def)
apply (unfold card_defs)
apply (simp add: UNIV_TYPE_def)
apply (safe)
\<comment> \<open> Subgoal 1 \<close>
apply (rule_tac x = "(\<lambda> b . if b then 1 else 2)" in exI)
apply (rule conjI)
\<comment> \<open> Subgoal 1.1 \<close>
apply (rule injI)
apply (simp only: atomize_imp)
apply (induct_tac x)
apply (induct_tac y)
apply (simp_all)
\<comment> \<open> Subgoal 1.2 \<close>
apply (auto) [1]
\<comment> \<open> Subgoal 2 \<close>
apply (rule_tac x = "(\<lambda> n . n = 1)" in exI)
apply (rule inj_onI)
apply (clarsimp)
apply (case_tac "x = 1")
apply (simp_all)
done

subsubsection \<open> Theorems for @{term "c\<^sub>\<nat>"} \<close>

theorem countable_leq_nat_card :
"countable c \<Longrightarrow> c \<preceq>\<^sub>c c\<^sub>\<nat>"
apply (unfold nat_card_def type_card_def)
apply (unfold UNIV_TYPE_def)
apply (unfold leq_card_def)
apply (simp add: countable_def)
done

theorem infinite_nat_card_leq :
"infinite c \<Longrightarrow> c\<^sub>\<nat> \<preceq>\<^sub>c c"
apply (unfold nat_card_def type_card_def)
apply (unfold UNIV_TYPE_def)
apply (unfold leq_card_def)
apply (erule infinite_countable_subset)
done

theorem countable_infinite_eq_nat_card :
"countable c \<Longrightarrow> infinite c \<Longrightarrow> c \<equiv>\<^sub>c c\<^sub>\<nat>"
apply (drule countable_leq_nat_card)
apply (drule infinite_nat_card_leq)
apply (simp add: equal_card_def)
done

theorem leq_type_card_inj :
"c\<^sub>\<T> TYPE('a) \<preceq>\<^sub>c c\<^sub>\<T> TYPE('b) \<longleftrightarrow> (\<exists> f :: 'a \<Rightarrow> 'b . inj f)"
apply (unfold type_card_def)
apply (unfold UNIV_TYPE_def)
apply (simp add: leq_card_def)
done

theorem eq_type_card_bij :
"c\<^sub>\<T> TYPE('a) \<equiv>\<^sub>c c\<^sub>\<T> TYPE('b) \<longleftrightarrow> (\<exists> f :: 'a \<Rightarrow> 'b . bij f)"
apply (unfold type_card_def)
apply (unfold UNIV_TYPE_def)
apply (simp add: equal_card_bij_betw)
done

theorem countable_infinite_inj_ex :
"countable (c\<^sub>\<T> TYPE('a)) \<Longrightarrow>
 infinite (c\<^sub>\<T> TYPE('b)) \<Longrightarrow>
 (\<exists> f :: 'a \<Rightarrow> 'b . inj f)"
apply (fold leq_type_card_inj)
apply (drule countable_leq_nat_card)
apply (drule infinite_nat_card_leq)
apply (metis leq_card_trans)
done

theorem countable_infinite_bij_ex :
"countable (c\<^sub>\<T> TYPE('a)) \<Longrightarrow> infinite (c\<^sub>\<T> TYPE('a)) \<Longrightarrow>
 countable (c\<^sub>\<T> TYPE('b)) \<Longrightarrow> infinite (c\<^sub>\<T> TYPE('b)) \<Longrightarrow>
 (\<exists> f :: 'a \<Rightarrow> 'b . bij f)"
apply (fold eq_type_card_bij)
apply (drule countable_infinite_eq_nat_card)
apply (assumption)
apply (drule countable_infinite_eq_nat_card)
apply (assumption)
apply (metis equal_card_sym equal_card_trans)
done

theorem countable_type_leq_nat_card [simp] :
"(c :: 'a::countable set) \<preceq>\<^sub>c c\<^sub>\<nat>"
apply (rule countable_leq_nat_card)
apply (rule countableI_type)
done

theorem countable_infinite_type_inj_ex :
"(\<exists> f :: 'a::countable \<Rightarrow> 'b::infinite . inj f)"
apply (rule countable_infinite_inj_ex)
apply (unfold type_card_def)
apply (unfold UNIV_TYPE_def)
apply (simp_all)
done

theorem countable_infinite_type_bij_ex :
"(\<exists> f :: 'a::{countable,infinite} \<Rightarrow> 'b::{countable,infinite} . bij f)"
apply (rule countable_infinite_bij_ex)
apply (unfold type_card_def)
apply (unfold UNIV_TYPE_def)
apply (simp_all)
done

theorem Nats_countable: "\<nat> \<preceq>\<^sub>c c\<^sub>\<T> TYPE(nat)"
  by (metis Nats_def UNIV_TYPE_def leq_card_refl leq_image_mono type_card_def)

text \<open> We construct bijective versions of @{const to_nat} and @{const from_nat} \<close>

definition to_nat_bij :: "'a::{countable, infinite} \<Rightarrow> nat" where
"to_nat_bij = (SOME f. bij f)"

lemma to_nat_bij:
  "bij to_nat_bij"
proof -
  obtain f :: "'a::{countable, infinite} \<Rightarrow> nat" where "bij f"
    using countable_infinite_type_bij_ex by blast
  thus ?thesis
    by (auto simp add: to_nat_bij_def intro: someI[of bij])
qed

definition from_nat_bij :: "nat \<Rightarrow> 'a::{countable, infinite}" where
"from_nat_bij = inv to_nat_bij"

lemma from_nat_bij_inv [simp]: "to_nat_bij (from_nat_bij x) = x"
  by (simp add: bij_is_surj from_nat_bij_def surj_f_inv_f to_nat_bij)

lemma to_nat_bij_inv [simp]: "from_nat_bij (to_nat_bij x) = x"
  by (metis UNIV_I bij_betw_inv_into_left from_nat_bij_def to_nat_bij)
end


(*  Title:      Filtration.thy
    Author:     Mnacho Echenim, Univ. Grenoble Alpes
*)

section \<open>Filtrations\<close>

text \<open>This theory introduces basic notions about filtrations, which permit to define adaptable processes
and predictable processes in the case where the filtration is indexed by natural numbers.\<close>

theory Filtration imports "HOL-Probability.Probability"
begin
subsection \<open>Basic definitions\<close>
class linorder_bot = linorder + bot
instantiation nat::linorder_bot
begin
instance proof qed
end

definition filtration :: "'a measure \<Rightarrow> ('i::linorder_bot \<Rightarrow> 'a measure) \<Rightarrow> bool" where
  "filtration M F \<longleftrightarrow>
    (\<forall>t. subalgebra M (F t))  \<and>
    (\<forall> s t. s \<le> t \<longrightarrow> subalgebra (F t) (F s))"

lemma filtrationI:
  assumes "\<forall>t. subalgebra M (F t)"
  and "\<forall>s t. s \<le> t \<longrightarrow> subalgebra (F t) (F s)"
shows "filtration M F" unfolding filtration_def using assms by simp

lemma filtrationE1:
  assumes "filtration M F"
  shows "subalgebra M (F t)" using assms unfolding filtration_def by simp

lemma filtrationE2:
  assumes "filtration M F"
  shows "s\<le> t \<Longrightarrow> subalgebra (F t) (F s)" using assms unfolding filtration_def by simp

locale filtrated_prob_space = prob_space +
  fixes F
  assumes filtration: "filtration M F"

lemma (in filtrated_prob_space) filtration_space:
  assumes "s \<le> t"
  shows "space (F s) = space (F t)" by (metis filtration filtration_def subalgebra_def)

lemma (in filtrated_prob_space) filtration_measurable:
  assumes "f\<in> measurable (F t) N"
shows "f\<in> measurable M N" unfolding measurable_def
proof
  show "f \<in> space M \<rightarrow> space N \<and> (\<forall>y\<in>sets N. f -` y \<inter> space M \<in> sets M)"
  proof (intro conjI ballI)
    have "space (F t) = space M" using assms filtration unfolding filtration_def subalgebra_def by auto
    thus "f\<in> space M \<rightarrow> space N" using assms unfolding measurable_def by simp
    fix y
    assume "y\<in> sets N"
    hence "f -`y\<inter> space M \<in> sets (F t)" using assms unfolding measurable_def
      using \<open>space (F t) = space M\<close> by auto
    thus "f -`y\<inter> space M \<in> sets M"  using assms filtration unfolding filtration_def subalgebra_def by auto
  qed
qed

lemma (in filtrated_prob_space) increasing_measurable_info:
  assumes "f\<in> measurable (F s) N"
  and "s \<le> t"
  shows "f\<in> measurable (F t) N"
proof (rule measurableI)
  have inc: "sets (F s) \<subseteq> sets (F t)"
    using assms(2) filtration by (simp add: filtration_def subalgebra_def)
  have sp: "space (F s) = space (F t)" by (metis filtration filtration_def subalgebra_def)
  thus "\<And>x. x \<in> space (F t) \<Longrightarrow> f x \<in> space N" using assms by (simp add: measurable_space)
  show "\<And>A. A \<in> sets N \<Longrightarrow> f -` A \<inter> space (F t) \<in> sets (F t)"
  proof -
    fix A
    assume "A\<in> sets N"
    hence "f -` A \<inter> space (F s) \<in> sets (F s)" using assms using measurable_sets by blast
    hence "f -` A \<inter> space (F s) \<in> sets (F t)" using subsetD[of "F s" "F t"] inc by blast
    thus "f -` A \<inter> space (F t) \<in> sets (F t)" using sp by simp
  qed
qed

definition disc_filtr :: "'a measure \<Rightarrow> (nat \<Rightarrow> 'a measure) \<Rightarrow> bool" where
  "disc_filtr M F \<longleftrightarrow>
    (\<forall>n. subalgebra M (F n))  \<and>
    (\<forall> n m. n \<le> m \<longrightarrow> subalgebra (F m) (F n))"

locale disc_filtr_prob_space = prob_space +
  fixes F
  assumes discrete_filtration: "disc_filtr M F"

lemma (in disc_filtr_prob_space) subalgebra_filtration:
  assumes "subalgebra N M"
  and "filtration M F"
shows "filtration N F"
proof (rule filtrationI)
  show "\<forall>s t. s \<le> t \<longrightarrow> subalgebra (F t) (F s)" using assms unfolding filtration_def by simp
  show "\<forall>t. subalgebra N (F t)"
  proof
    fix t
    have "subalgebra M (F t)" using assms unfolding filtration_def by auto
    thus "subalgebra N (F t)" using assms by (metis subalgebra_def subsetCE subsetI)
  qed
qed

sublocale disc_filtr_prob_space \<subseteq>  filtrated_prob_space
proof unfold_locales
  show "filtration M F"
    using  discrete_filtration by (simp add: filtration_def disc_filtr_def)
qed

subsection \<open>Stochastic processes\<close>

text  \<open>Stochastic processes are collections of measurable functions. Those of a particular interest when
there is a filtration are the adapted stochastic processes.\<close>

definition stoch_procs where
  "stoch_procs M N = {X. \<forall>t. (X t) \<in> measurable M N}"

subsubsection \<open>Adapted stochastic processes\<close>

definition adapt_stoch_proc where
  "(adapt_stoch_proc F X N) \<longleftrightarrow> (\<forall>t. (X t) \<in> measurable (F t) N)"

abbreviation "borel_adapt_stoch_proc F X \<equiv> adapt_stoch_proc F X borel"

lemma (in filtrated_prob_space) adapted_is_dsp:
  assumes "adapt_stoch_proc F X N"
  shows "X \<in> stoch_procs M N"
  unfolding  stoch_procs_def
  by (intro CollectI, (meson adapt_stoch_proc_def assms filtration filtration_def measurable_from_subalg))

lemma (in filtrated_prob_space) adapt_stoch_proc_borel_measurable:
  assumes "adapt_stoch_proc F X N"
  shows "\<forall>n. (X n) \<in> measurable M N"
proof
  fix n
  have "X n \<in> measurable (F n) N" using assms unfolding  adapt_stoch_proc_def by simp
  moreover have "subalgebra M (F n)" using filtration unfolding filtration_def by simp
  ultimately show "X n \<in> measurable M N" by (simp add:measurable_from_subalg)
qed

lemma (in filtrated_prob_space) borel_adapt_stoch_proc_borel_measurable:
  assumes "borel_adapt_stoch_proc F X"
  shows "\<forall>n. (X n) \<in> borel_measurable M"
proof
  fix n
  have "X n \<in> borel_measurable (F n)" using assms unfolding  adapt_stoch_proc_def by simp
  moreover have "subalgebra M (F n)" using filtration unfolding filtration_def by simp
  ultimately show "X n \<in> borel_measurable M" by (simp add:measurable_from_subalg)
qed

lemma (in filtrated_prob_space) constant_process_borel_adapted:
  shows "borel_adapt_stoch_proc F (\<lambda> n w. c)"
unfolding  adapt_stoch_proc_def
proof
  fix t
  show "(\<lambda>w. c) \<in> borel_measurable (F t)" using borel_measurable_const by blast
qed

lemma (in filtrated_prob_space) borel_adapt_stoch_proc_add:
  fixes X::"'b \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, topological_monoid_add})"
  assumes "borel_adapt_stoch_proc F X"
  and "borel_adapt_stoch_proc F Y"
shows "borel_adapt_stoch_proc F (\<lambda>t w. X t w + Y t w)" unfolding adapt_stoch_proc_def
proof
  fix t
  have "X t \<in> borel_measurable (F t)" using assms unfolding adapt_stoch_proc_def by simp
  moreover have "Y t \<in> borel_measurable (F t)" using assms unfolding adapt_stoch_proc_def by simp
  ultimately show "(\<lambda>w. X t w + Y t w) \<in> borel_measurable (F t)" by simp
qed

lemma (in filtrated_prob_space) borel_adapt_stoch_proc_sum:
  fixes A::"'d \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, topological_comm_monoid_add})"
  assumes "\<And>i. i\<in> S \<Longrightarrow> borel_adapt_stoch_proc F (A i)"
shows "borel_adapt_stoch_proc F (\<lambda> t w. (\<Sum> i\<in> S. A i t w))" unfolding adapt_stoch_proc_def
proof
  fix t
  have "\<And>i. i\<in> S\<Longrightarrow> A i t \<in> borel_measurable (F t)" using assms unfolding adapt_stoch_proc_def by simp
  thus "(\<lambda> w. (\<Sum> i\<in> S. A i t w)) \<in> borel_measurable (F t)" by (simp add:borel_measurable_sum)
qed

lemma (in filtrated_prob_space) borel_adapt_stoch_proc_times:
  fixes X::"'b \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, real_normed_algebra})"
  assumes "borel_adapt_stoch_proc F X"
  and "borel_adapt_stoch_proc F Y"
shows "borel_adapt_stoch_proc F (\<lambda>t w. X t w * Y t w)" unfolding adapt_stoch_proc_def
proof
  fix t
  have "X t \<in> borel_measurable (F t)" using assms unfolding adapt_stoch_proc_def by simp
  moreover have "Y t \<in> borel_measurable (F t)" using assms unfolding adapt_stoch_proc_def by simp
  ultimately show "(\<lambda>w. X t w * Y t w) \<in> borel_measurable (F t)" by simp
qed

lemma (in filtrated_prob_space) borel_adapt_stoch_proc_prod:
  fixes A::"'d \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, real_normed_field})"
  assumes "\<And>i. i\<in> S \<Longrightarrow> borel_adapt_stoch_proc F (A i)"
shows "borel_adapt_stoch_proc F (\<lambda> t w. (\<Prod> i\<in> S. A i t w))" unfolding adapt_stoch_proc_def
proof
  fix t
  have "\<And>i. i\<in> S\<Longrightarrow> A i t \<in> borel_measurable (F t)" using assms unfolding adapt_stoch_proc_def by simp
  thus "(\<lambda> w. (\<Prod> i\<in> S. A i t w)) \<in> borel_measurable (F t)" by simp
qed

subsubsection \<open>Predictable stochastic processes\<close>

definition predict_stoch_proc where
  "(predict_stoch_proc F X N) \<longleftrightarrow> (X 0 \<in> measurable (F 0) N \<and> (\<forall>n. (X (Suc n)) \<in> measurable (F n) N))"

abbreviation  "borel_predict_stoch_proc F X \<equiv> predict_stoch_proc F X borel"

lemma (in disc_filtr_prob_space) predict_imp_adapt:
  assumes "predict_stoch_proc F X N"
  shows "adapt_stoch_proc F X N" unfolding adapt_stoch_proc_def
proof
  fix n
  show "X n \<in> measurable (F n) N"
  proof (cases "n = 0")
    case True
    thus ?thesis using assms unfolding predict_stoch_proc_def by auto
  next
    case False
    thus ?thesis using assms unfolding predict_stoch_proc_def
      by (metis Suc_n_not_le_n increasing_measurable_info nat_le_linear not0_implies_Suc)
  qed
qed

lemma (in disc_filtr_prob_space) predictable_is_dsp:
  assumes "predict_stoch_proc F X N"
  shows "X \<in> stoch_procs M N"
unfolding  stoch_procs_def
proof
  show "\<forall>n. random_variable N (X n)"
  proof
    fix n
    show "random_variable N (X n)"
    proof (cases "n=0")
      case True
      thus ?thesis using assms unfolding predict_stoch_proc_def
        using filtration filtration_def measurable_from_subalg by blast
    next
      case False
      thus ?thesis using assms unfolding predict_stoch_proc_def
        by (metis filtration filtration_def measurable_from_subalg not0_implies_Suc)
    qed
  qed
qed

lemma (in disc_filtr_prob_space) borel_predict_stoch_proc_borel_measurable:
  assumes "borel_predict_stoch_proc F X"
  shows "\<forall>n. (X n) \<in> borel_measurable M" using assms predictable_is_dsp unfolding stoch_procs_def by auto

lemma (in disc_filtr_prob_space) constant_process_borel_predictable:
  shows "borel_predict_stoch_proc F (\<lambda> n w. c)"
unfolding  predict_stoch_proc_def
proof
  show "(\<lambda>w. c) \<in> borel_measurable (F 0)" using borel_measurable_const by blast
next
  show "\<forall>n. (\<lambda>w. c) \<in> borel_measurable (F n)" using borel_measurable_const by blast
qed

lemma (in disc_filtr_prob_space) borel_predict_stoch_proc_add:
  fixes X::"nat \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, topological_monoid_add})"
  assumes "borel_predict_stoch_proc F X"
  and "borel_predict_stoch_proc F Y"
shows "borel_predict_stoch_proc F (\<lambda>t w. X t w + Y t w)" unfolding predict_stoch_proc_def
proof
  show "(\<lambda>w. X 0 w + Y 0 w) \<in> borel_measurable (F 0)"
    using assms(1) assms(2) borel_measurable_add predict_stoch_proc_def by blast
next
  show "\<forall>n. (\<lambda>w. X (Suc n) w + Y (Suc n) w) \<in> borel_measurable (F n)"
  proof
    fix n
    have "X (Suc n) \<in> borel_measurable (F n)" using assms unfolding predict_stoch_proc_def by simp
    moreover have "Y (Suc n) \<in> borel_measurable (F n)" using assms unfolding predict_stoch_proc_def by simp
    ultimately show "(\<lambda>w. X (Suc n) w + Y (Suc n) w) \<in> borel_measurable (F n)" by simp
  qed
qed

lemma (in disc_filtr_prob_space) borel_predict_stoch_proc_sum:
  fixes A::"'d \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, topological_comm_monoid_add})"
  assumes "\<And>i. i\<in> S \<Longrightarrow> borel_predict_stoch_proc F (A i)"
shows "borel_predict_stoch_proc F (\<lambda> t w. (\<Sum> i\<in> S. A i t w))" unfolding predict_stoch_proc_def
proof
  show "(\<lambda>w. \<Sum>i\<in>S. A i 0 w) \<in> borel_measurable (F 0)"
  proof
    have "\<And>i. i\<in> S\<Longrightarrow> A i 0 \<in> borel_measurable (F 0)" using assms unfolding predict_stoch_proc_def by simp
    thus "(\<lambda> w. (\<Sum> i\<in> S. A i 0 w)) \<in> borel_measurable (F 0)" by (simp add:borel_measurable_sum)
  qed simp
next
  show "\<forall>n. (\<lambda>w. \<Sum>i\<in>S. A i (Suc n) w) \<in> borel_measurable (F n)"
  proof
    fix n
    have "\<And>i. i\<in> S\<Longrightarrow> A i (Suc n) \<in> borel_measurable (F n)" using assms unfolding predict_stoch_proc_def by simp
    thus "(\<lambda> w. (\<Sum> i\<in> S. A i (Suc n) w)) \<in> borel_measurable (F n)" by (simp add:borel_measurable_sum)
  qed
qed

lemma (in disc_filtr_prob_space) borel_predict_stoch_proc_times:
  fixes X::"nat \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, real_normed_algebra})"
  assumes "borel_predict_stoch_proc F X"
  and "borel_predict_stoch_proc F Y"
shows "borel_predict_stoch_proc F (\<lambda>t w. X t w * Y t w)" unfolding predict_stoch_proc_def
proof
  show "(\<lambda>w. X 0 w * Y 0 w) \<in> borel_measurable (F 0)"
  proof -
    have "X 0 \<in> borel_measurable (F 0)" using assms unfolding predict_stoch_proc_def by simp
    moreover have "Y 0 \<in> borel_measurable (F 0)" using assms unfolding predict_stoch_proc_def by simp
    ultimately show "(\<lambda>w. X 0 w * Y 0 w) \<in> borel_measurable (F 0)" by simp
  qed
next
  show "\<forall>n. (\<lambda>w. X (Suc n) w * Y (Suc n) w) \<in> borel_measurable (F n)"
  proof
    fix n
    have "X (Suc n) \<in> borel_measurable (F n)" using assms unfolding predict_stoch_proc_def by simp
    moreover have "Y (Suc n) \<in> borel_measurable (F n)" using assms unfolding predict_stoch_proc_def by simp
    ultimately show "(\<lambda>w. X (Suc n) w * Y (Suc n) w) \<in> borel_measurable (F n)" by simp
  qed
qed

lemma (in disc_filtr_prob_space) borel_predict_stoch_proc_prod:
  fixes A::"'d \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('c::{second_countable_topology, real_normed_field})"
  assumes "\<And>i. i\<in> S \<Longrightarrow> borel_predict_stoch_proc F (A i)"
shows "borel_predict_stoch_proc F (\<lambda> t w. (\<Prod> i\<in> S. A i t w))" unfolding predict_stoch_proc_def
proof
  show "(\<lambda>w. \<Prod>i\<in>S. A i 0 w) \<in> borel_measurable (F 0)"
  proof -
    have "\<And>i. i\<in> S\<Longrightarrow> A i 0 \<in> borel_measurable (F 0)" using assms unfolding predict_stoch_proc_def by simp
    thus "(\<lambda> w. (\<Prod> i\<in> S. A i 0 w)) \<in> borel_measurable (F 0)" by simp
  qed
next
  show "\<forall>n. (\<lambda>w. \<Prod>i\<in>S. A i (Suc n) w) \<in> borel_measurable (F n)"
  proof
    fix n
    have "\<And>i. i\<in> S\<Longrightarrow> A i (Suc n) \<in> borel_measurable (F n)" using assms unfolding predict_stoch_proc_def by simp
    thus "(\<lambda> w. (\<Prod> i\<in> S. A i (Suc n) w)) \<in> borel_measurable (F n)" by simp
  qed
qed

definition (in prob_space) constant_image where
  "constant_image f = (if \<exists> c::'b::{t2_space}. \<forall>x\<in> space M. f x = c then
    SOME c. \<forall>x \<in> space M. f x = c else undefined)"

lemma (in prob_space) constant_imageI:
  assumes "\<exists>c::'b::{t2_space}. \<forall>x\<in> space M. f x = c"
  shows "\<forall>x\<in> space M. f x = (constant_image f)"
proof
  fix x
  assume "x\<in> space M"
  let ?c = "SOME c. \<forall>x\<in> space M. f x = c"
  have "f x = ?c" using \<open>x\<in> space M\<close> someI_ex[of "\<lambda>c. \<forall>x\<in> space M. f x = c"] assms by blast
  thus "f x = (constant_image f)" by (simp add: assms prob_space.constant_image_def prob_space_axioms)
qed

lemma (in prob_space) constant_image_pos:
  assumes "\<forall>x\<in> space M. (0::real) < f x"
  and "\<exists>c::real. \<forall>x\<in> space M. f x = c"
shows "0 < (constant_image f)"
proof -
  {
    fix x
    assume "x\<in> space M"
    hence "0 < f x" using assms by simp
    also have "... = constant_image f" using assms constant_imageI \<open>x\<in> space M\<close> by auto
    finally have ?thesis .
  }
  thus ?thesis using subprob_not_empty by auto
qed

definition open_except where
"open_except x y = (if x = y then {} else SOME A. open A \<and> x\<in> A \<and> y\<notin> A)"

lemma open_exceptI:
  assumes "(x::'b::{t1_space}) \<noteq> y"
  shows "open (open_except x y)" and "x\<in> open_except x y" and  "y\<notin> open_except x y"
proof-
  have ex:"\<exists>U. open U \<and> x \<in> U \<and> y \<notin> U" using \<open>x\<noteq> y\<close> by (simp add:t1_space)
  let ?V = "SOME A. open A \<and> x\<in> A \<and> y\<notin> A"
  have vprop: "open ?V \<and> x \<in> ?V \<and> y \<notin> ?V" using someI_ex[of "\<lambda>U. open U \<and> x \<in> U \<and> y \<notin> U"] ex by blast
  show "open (open_except x y)" by (simp add: open_except_def vprop)
  show "x\<in> open_except x y" by (metis (full_types) open_except_def vprop)
  show "y\<notin> open_except x y" by (metis (full_types) open_except_def vprop)
qed

lemma open_except_set:
  assumes "finite A"
  and "(x::'b::{t1_space}) \<notin> A"
shows "\<exists>U. open U \<and> x\<in> U \<and> U\<inter> A = {}"
proof(intro exI conjI)
  have "\<forall>y\<in> A. x\<noteq> y" using assms by auto
  let ?U = "\<Inter> y \<in> A. open_except x y"
  show "open ?U"
  proof (intro open_INT ballI, (simp add: assms))
    fix y
    assume "y\<in> A"
    show "open (open_except x y)" using \<open>\<forall>y\<in> A. x\<noteq> y\<close> by (simp add: \<open>y \<in> A\<close> open_exceptI)
  qed
  show "x \<in> (\<Inter>y\<in>A. open_except x y)"
  proof
    fix y
    assume "y\<in> A"
    show "x\<in>open_except x y" using \<open>\<forall>y\<in> A. x\<noteq> y\<close> by (simp add: \<open>y \<in> A\<close> open_exceptI)
  qed
  have "\<forall>y\<in>A. y\<notin> ?U" using \<open>\<forall>y\<in> A. x\<noteq> y\<close> open_exceptI(3) by auto
  thus "(\<Inter>y\<in>A. open_except x y) \<inter> A = {}" by auto
qed

definition open_exclude_set where
"open_exclude_set x A = (if (\<exists>U. open U \<and> U\<inter> A = {x}) then SOME U. open U \<and> U \<inter> A = {x} else {})"

lemma open_exclude_setI:
  assumes "\<exists>U. open U \<and> U\<inter> A = {x}"
shows "open (open_exclude_set x A)" and "(open_exclude_set x A) \<inter> A = {x}"
proof -
  let ?V = "SOME U. open U \<and> U \<inter> A = {x}"
  have vprop: "open ?V \<and> ?V \<inter> A = {x}" using someI_ex[of "\<lambda>U. open U \<and> U \<inter> A = {x}"] assms by blast
  show "open (open_exclude_set x A)" by (simp add: open_exclude_set_def vprop)
  show "open_exclude_set x A \<inter> A = {x}" by (metis (mono_tags, lifting) open_exclude_set_def vprop)
qed

lemma open_exclude_finite:
  assumes "finite A"
  and "(x::'b::{t1_space})\<in> A"
shows open_set: "open (open_exclude_set x A)" and inter_x:"(open_exclude_set x A) \<inter> A = {x}"
proof -
  have "\<exists>U. open U \<and> U\<inter> A = {x}"
  proof -
    have "\<exists>U. open U \<and> x\<in> U \<and> U\<inter> (A-{x}) = {}"
    proof (rule open_except_set)
      show "finite (A -{x})" using assms by auto
      show "x\<notin> A -{x}" by simp
    qed
    thus ?thesis using assms by auto
  qed
  thus "open (open_exclude_set x A)" and "(open_exclude_set x A) \<inter> A = {x}" by (auto simp add: open_exclude_setI)
qed

subsection \<open>Initially trivial filtrations\<close>
text \<open>Intuitively, these are filtrations that can be used to denote the fact that there is no information at the start.\<close>

definition init_triv_filt::"'a measure \<Rightarrow> ('i::linorder_bot \<Rightarrow> 'a measure) \<Rightarrow> bool" where
  "init_triv_filt M F \<longleftrightarrow> filtration M F \<and> sets (F bot) = {{}, space M}"

lemma triv_measurable_cst:
  fixes f::"'a\<Rightarrow>'b::{t2_space}"
  assumes "space N = space M"
  and "space M \<noteq> {}"
  and "sets N = {{}, space M}"
  and "f\<in> measurable N borel"
shows "\<exists> c::'b. \<forall>x\<in> space N. f x = c"
proof -
  have "f `(space N) \<noteq> {}" using assms by (simp add: assms)
  hence "\<exists> c. c\<in> f`(space N)" by auto
  from this obtain c where "c\<in> f`(space N)" by auto
  have "\<forall>x \<in> space N. f x = c"
  proof
    fix x
    assume "x\<in> space N"
    show "f x = c"
    proof (rule ccontr)
      assume "f x \<noteq> c"
      hence "(\<exists>U V. open U \<and> open V \<and> (f x) \<in> U \<and> c \<in> V \<and> U \<inter> V = {})" by (simp add: separation_t2)
      from this obtain U and V where "open U" and "open V" and "(f x) \<in> U" and "c \<in> V" and "U \<inter> V = {}" by blast
      have "(f -`V) \<inter> space N = space N"
      proof -
        have "V\<in> sets borel" using \<open>open V\<close> unfolding borel_def by simp
        hence "(f -`V) \<inter> space N \<in> sets N" using assms unfolding measurable_def by simp
        show "(f -`V) \<inter> space N = space N"
        proof (rule ccontr)
          assume "(f -`V) \<inter> space N \<noteq> space N"
          hence "(f -`V) \<inter> space N = {}" using assms \<open>(f -`V) \<inter> space N \<in> sets N\<close> by simp
          thus False using \<open>c\<in>V\<close> using \<open>c \<in> f ` space N\<close> by blast
        qed
      qed
      have "((f-`U)\<inter> space N) \<inter> ((f-`V) \<inter> space N) = {}" using \<open>U\<inter>V = {}\<close> by auto
      moreover have "(f -`U) \<inter> space N \<in> sets N" using assms \<open>open U\<close> unfolding measurable_def by simp
      ultimately have "(f -`U) \<inter> space N = {}" using assms \<open>(f -`V) \<inter> space N = space N\<close> by simp
      thus False using \<open>f x \<in> U\<close> \<open>x \<in> space N\<close> by blast
    qed
  qed
  thus "\<exists> c. \<forall>x\<in> space N. f x = c" by auto
qed

locale trivial_init_filtrated_prob_space = prob_space +
  fixes F
  assumes info_filtration: "init_triv_filt M F"

sublocale trivial_init_filtrated_prob_space \<subseteq> filtrated_prob_space
  using info_filtration unfolding init_triv_filt_def by (unfold_locales, simp)

locale triv_init_disc_filtr_prob_space = prob_space +
  fixes F
  assumes info_disc_filtr: "disc_filtr M F \<and> sets (F bot) = {{}, space M}"

sublocale triv_init_disc_filtr_prob_space \<subseteq> trivial_init_filtrated_prob_space
proof unfold_locales
  show "init_triv_filt M F" using info_disc_filtr bot_nat_def unfolding init_triv_filt_def disc_filtr_def
    by (simp add: filtrationI)

qed

sublocale triv_init_disc_filtr_prob_space \<subseteq> disc_filtr_prob_space
proof unfold_locales
  show "disc_filtr M F" using info_disc_filtr by simp
qed

lemma (in triv_init_disc_filtr_prob_space) adapted_init:
  assumes "borel_adapt_stoch_proc F x"
  shows "\<exists>c. \<forall>w \<in> space M. ((x 0 w)::real) = c"
proof -
  have "space M = space (F 0)" using filtration
    by (simp add: filtration_def subalgebra_def)
  moreover have "\<exists>c. \<forall>w \<in> space (F 0). x 0 w = c"
  proof (rule triv_measurable_cst)
    show "space (F 0) = space M" using \<open>space M = space (F 0)\<close> ..
    show "sets (F 0) = {{}, space M}" using info_disc_filtr
      by (simp add: init_triv_filt_def bot_nat_def)
    show "x 0 \<in> borel_measurable (F 0)" using assms by (simp add: adapt_stoch_proc_def)
    show "space M \<noteq> {}" by (simp add:not_empty)
  qed
  ultimately show ?thesis by simp
qed

subsection \<open>Filtration-equivalent measure spaces\<close>
text \<open>This is a relaxation of the notion of equivalent probability spaces, where equivalence is tested modulo a
filtration. Equivalent measure spaces agree on events that have a zero probability of occurring; here, filtration-equivalent
measure spaces agree on such events when they belong to the filtration under consideration.\<close>

definition filt_equiv where
"filt_equiv F M N \<longleftrightarrow> sets M = sets N \<and> filtration M F  \<and> (\<forall> t A. A \<in> sets (F t) \<longrightarrow> (emeasure M A = 0) \<longleftrightarrow> (emeasure N A = 0))"

lemma filt_equiv_space:
  assumes "filt_equiv F M N"
  shows "space M = space N" using assms unfolding filt_equiv_def
 filtration_def subalgebra_def by (meson sets_eq_imp_space_eq)

lemma filt_equiv_sets:
  assumes "filt_equiv F M N"
  shows "sets M = sets N" using assms unfolding filt_equiv_def by simp

lemma filt_equiv_filtration:
  assumes "filt_equiv F M N"
  shows "filtration N F" using assms unfolding filt_equiv_def filtration_def subalgebra_def
  by (metis sets_eq_imp_space_eq)

lemma (in filtrated_prob_space) AE_borel_eq:
fixes f::"'a\<Rightarrow>real"
assumes "f\<in> borel_measurable (F t)"
and "g\<in> borel_measurable (F t)"
and "AE w in M. f w = g w"
shows "{w\<in> space M. f w \<noteq> g w} \<in> sets (F t) \<and> emeasure M {w\<in> space M. f w \<noteq> g w} = 0"
proof
  show "{w \<in> space M. f w \<noteq> g w} \<in> sets (F t)"
  proof -
    define minus where "minus = (\<lambda>w. (f w) - (g w))"
    have "minus \<in> borel_measurable (F t)" unfolding minus_def using assms by simp
    hence "{w\<in> space (F t). 0 < minus w} \<in> sets (F t)" using borel_measurable_iff_greater by auto
    moreover have "{w\<in> space (F t). minus w < 0} \<in> sets (F t)" using borel_measurable_iff_less
      \<open>minus \<in> borel_measurable (F t)\<close> by auto
    ultimately have "{w\<in> space (F t). 0 < minus w} \<union> {w\<in> space (F t). minus w < 0} \<in> sets (F t)" by simp
    moreover have "{w\<in> space (F t). f w \<noteq> g w} = {w\<in> space (F t). 0 < minus w} \<union> {w\<in> space (F t). minus w < 0}"
    proof
      show "{w \<in> space (F t). f w \<noteq> g w} \<subseteq> {w \<in> space (F t). 0 < minus w} \<union> {w \<in> space (F t). minus w < 0}"
      proof
        fix w
        assume "w \<in> {w \<in> space (F t). f w \<noteq> g w}"
        hence "w\<in> space (F t)" and "f w \<noteq> g w" by auto
        thus "w\<in> {w \<in> space (F t). 0 < minus w} \<union> {w \<in> space (F t). minus w < 0}" unfolding minus_def
          by (cases "f w < g w") auto
      qed
      have "{w \<in> space (F t). 0 < minus w} \<subseteq> {w \<in> space (F t). f w \<noteq> g w}" unfolding minus_def by auto
      moreover have "{w \<in> space (F t). minus w < 0} \<subseteq> {w \<in> space (F t). f w \<noteq> g w}" unfolding minus_def by auto
      ultimately show "{w \<in> space (F t). 0 < minus w} \<union> {w \<in> space (F t). minus w < 0} \<subseteq> {w \<in> space (F t). f w \<noteq> g w}"
        by simp
    qed
    moreover have "space (F t) = space M" using filtration unfolding filtration_def subalgebra_def by simp
    ultimately show ?thesis by simp
  qed
  show "emeasure M {w\<in> space M. f w \<noteq> g w} = 0" by (metis (no_types) AE_iff_measurable assms(3) emeasure_notin_sets)
qed

lemma (in prob_space) filt_equiv_borel_AE_eq:
  fixes f::"'a\<Rightarrow> real"
  assumes "filt_equiv F M N"
and "f\<in> borel_measurable (F t)"
and "g\<in> borel_measurable (F t)"
and "AE w in M. f w = g w"
shows "AE w in N. f w = g w"
proof -
  have set0: "{w\<in> space M. f w \<noteq> g w} \<in> sets (F t) \<and> emeasure M {w\<in> space M. f w \<noteq> g w} = 0"
  proof (rule filtrated_prob_space.AE_borel_eq, (auto simp add: assms))
    show "filtrated_prob_space M F" using assms unfolding filt_equiv_def
      by (simp add: filtrated_prob_space_axioms.intro filtrated_prob_space_def prob_space_axioms)
  qed
  hence "emeasure N {w\<in> space M. f w \<noteq> g w} = 0" using assms unfolding filt_equiv_def by auto
  moreover have "{w\<in> space M. f w \<noteq> g w} \<in> sets N" using set0 assms unfolding filt_equiv_def
    filtration_def subalgebra_def by auto
  ultimately show ?thesis
  proof -
  have "space M = space N"
    by (metis assms(1) filt_equiv_space)
    then have "\<forall>p. almost_everywhere N p \<or> {a \<in> space N. \<not> p a} \<noteq> {a \<in> space N. f a \<noteq> g a}"
      using AE_iff_measurable \<open>emeasure N {w \<in> space M. f w \<noteq> g w} = 0\<close> \<open>{w \<in> space M. f w \<noteq> g w} \<in> sets N\<close>
      by auto
    then show ?thesis
      by metis
  qed
qed

lemma filt_equiv_prob_space_subalgebra:
  assumes "prob_space N"
  and "filt_equiv F M N"
  and "sigma_finite_subalgebra M G"
shows "sigma_finite_subalgebra N G" unfolding sigma_finite_subalgebra_def
proof
  show "subalgebra N G"
    by (metis assms(2) assms(3) filt_equiv_space filt_equiv_def sigma_finite_subalgebra_def subalgebra_def)
  show "sigma_finite_measure (restr_to_subalg N G)" unfolding restr_to_subalg_def
    by (metis \<open>subalgebra N G\<close> assms(1) finite_measure_def finite_measure_restr_to_subalg prob_space_def restr_to_subalg_def)
qed

lemma filt_equiv_measurable:
  assumes "filt_equiv F M N"
  and "f\<in> measurable M P"
shows "f\<in> measurable N P" using assms unfolding filt_equiv_def measurable_def
proof -
  assume a1: "sets M = sets N \<and> Filtration.filtration M F \<and> (\<forall>t A. A \<in> sets (F t) \<longrightarrow> (emeasure M A = 0) = (emeasure N A = 0))"
  assume a2: "f \<in> {f \<in> space M \<rightarrow> space P. \<forall>y\<in>sets P. f -` y \<inter> space M \<in> sets M}"
  have "space N = space M"
    using a1 by (metis (lifting) sets_eq_imp_space_eq)
  then show "f \<in> {f \<in> space N \<rightarrow> space P. \<forall>C\<in>sets P. f -` C \<inter> space N \<in> sets N}"
    using a2 a1 by force
qed

lemma filt_equiv_imp_subalgebra:
  assumes "filt_equiv F M N"
shows "subalgebra N M" unfolding subalgebra_def
  using assms filt_equiv_space filt_equiv_def by blast

end


(*  Title:      HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section {* Definition of finite Cartesian product types. *}

theory Finite_Cartesian_Product
imports
  Euclidean_Space
  L2_Norm
  "~~/src/HOL/Library/Numeral_Type"
begin

subsection {* Finite Cartesian products, with indexing and lambdas. *}

typedef ('a, 'b) vec = "UNIV :: (('b::finite) \<Rightarrow> 'a) set"
  morphisms vec_nth vec_lambda ..

notation
  vec_nth (infixl "$" 90) and
  vec_lambda (binder "\<chi>" 10)

(*
  Translate "'b ^ 'n" into "'b ^ ('n :: finite)". When 'n has already more than
  the finite type class write "vec 'b 'n"
*)

syntax "_finite_vec" :: "type \<Rightarrow> type \<Rightarrow> type" ("(_ ^/ _)" [15, 16] 15)

parse_translation {*
  let
    fun vec t u = Syntax.const @{type_syntax vec} $ t $ u;
    fun finite_vec_tr [t, u] =
      (case Term_Position.strip_positions u of
        v as Free (x, _) =>
          if Lexicon.is_tid x then
            vec t (Syntax.const @{syntax_const "_ofsort"} $ v $
              Syntax.const @{class_syntax finite})
          else vec t u
      | _ => vec t u)
  in
    [(@{syntax_const "_finite_vec"}, K finite_vec_tr)]
  end
*}

lemma vec_eq_iff: "(x = y) \<longleftrightarrow> (\<forall>i. x$i = y$i)"
  by (simp add: vec_nth_inject [symmetric] fun_eq_iff)

lemma vec_lambda_beta [simp]: "vec_lambda g $ i = g i"
  by (simp add: vec_lambda_inverse)

lemma vec_lambda_unique: "(\<forall>i. f$i = g i) \<longleftrightarrow> vec_lambda g = f"
  by (auto simp add: vec_eq_iff)

lemma vec_lambda_eta: "(\<chi> i. (g$i)) = g"
  by (simp add: vec_eq_iff)

subsection {* Group operations and class instances *}

instantiation vec :: (zero, finite) zero
begin
  definition "0 \<equiv> (\<chi> i. 0)"
  instance ..
end

instantiation vec :: (plus, finite) plus
begin
  definition "op + \<equiv> (\<lambda> x y. (\<chi> i. x$i + y$i))"
  instance ..
end

instantiation vec :: (minus, finite) minus
begin
  definition "op - \<equiv> (\<lambda> x y. (\<chi> i. x$i - y$i))"
  instance ..
end

instantiation vec :: (uminus, finite) uminus
begin
  definition "uminus \<equiv> (\<lambda> x. (\<chi> i. - (x$i)))"
  instance ..
end

lemma zero_index [simp]: "0 $ i = 0"
  unfolding zero_vec_def by simp

lemma vector_add_component [simp]: "(x + y)$i = x$i + y$i"
  unfolding plus_vec_def by simp

lemma vector_minus_component [simp]: "(x - y)$i = x$i - y$i"
  unfolding minus_vec_def by simp

lemma vector_uminus_component [simp]: "(- x)$i = - (x$i)"
  unfolding uminus_vec_def by simp

instance vec :: (semigroup_add, finite) semigroup_add
  by default (simp add: vec_eq_iff add.assoc)

instance vec :: (ab_semigroup_add, finite) ab_semigroup_add
  by default (simp add: vec_eq_iff add.commute)

instance vec :: (monoid_add, finite) monoid_add
  by default (simp_all add: vec_eq_iff)

instance vec :: (comm_monoid_add, finite) comm_monoid_add
  by default (simp add: vec_eq_iff)

instance vec :: (cancel_semigroup_add, finite) cancel_semigroup_add
  by default (simp_all add: vec_eq_iff)

instance vec :: (cancel_ab_semigroup_add, finite) cancel_ab_semigroup_add
  by default (simp add: vec_eq_iff)

instance vec :: (cancel_comm_monoid_add, finite) cancel_comm_monoid_add ..

instance vec :: (group_add, finite) group_add
  by default (simp_all add: vec_eq_iff)

instance vec :: (ab_group_add, finite) ab_group_add
  by default (simp_all add: vec_eq_iff)

subsection {* Real vector space *}

instantiation vec :: (real_vector, finite) real_vector
begin

definition "scaleR \<equiv> (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"

lemma vector_scaleR_component [simp]: "(scaleR r x)$i = scaleR r (x$i)"
  unfolding scaleR_vec_def by simp

instance
  by default (simp_all add: vec_eq_iff scaleR_left_distrib scaleR_right_distrib)

end

subsection {* Topological space *}

instantiation vec :: (topological_space, finite) topological_space
begin

definition
  "open (S :: ('a ^ 'b) set) \<longleftrightarrow>
    (\<forall>x\<in>S. \<exists>A. (\<forall>i. open (A i) \<and> x$i \<in> A i) \<and>
      (\<forall>y. (\<forall>i. y$i \<in> A i) \<longrightarrow> y \<in> S))"

instance proof
  show "open (UNIV :: ('a ^ 'b) set)"
    unfolding open_vec_def by auto
next
  fix S T :: "('a ^ 'b) set"
  assume "open S" "open T" thus "open (S \<inter> T)"
    unfolding open_vec_def
    apply clarify
    apply (drule (1) bspec)+
    apply (clarify, rename_tac Sa Ta)
    apply (rule_tac x="\<lambda>i. Sa i \<inter> Ta i" in exI)
    apply (simp add: open_Int)
    done
next
  fix K :: "('a ^ 'b) set set"
  assume "\<forall>S\<in>K. open S" thus "open (\<Union>K)"
    unfolding open_vec_def
    apply clarify
    apply (drule (1) bspec)
    apply (drule (1) bspec)
    apply clarify
    apply (rule_tac x=A in exI)
    apply fast
    done
qed

end

lemma open_vector_box: "\<forall>i. open (S i) \<Longrightarrow> open {x. \<forall>i. x $ i \<in> S i}"
  unfolding open_vec_def by auto

lemma open_vimage_vec_nth: "open S \<Longrightarrow> open ((\<lambda>x. x $ i) -` S)"
  unfolding open_vec_def
  apply clarify
  apply (rule_tac x="\<lambda>k. if k = i then S else UNIV" in exI, simp)
  done

lemma closed_vimage_vec_nth: "closed S \<Longrightarrow> closed ((\<lambda>x. x $ i) -` S)"
  unfolding closed_open vimage_Compl [symmetric]
  by (rule open_vimage_vec_nth)

lemma closed_vector_box: "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
proof -
  have "{x. \<forall>i. x $ i \<in> S i} = (\<Inter>i. (\<lambda>x. x $ i) -` S i)" by auto
  thus "\<forall>i. closed (S i) \<Longrightarrow> closed {x. \<forall>i. x $ i \<in> S i}"
    by (simp add: closed_INT closed_vimage_vec_nth)
qed

lemma tendsto_vec_nth [tendsto_intros]:
  assumes "((\<lambda>x. f x) ---> a) net"
  shows "((\<lambda>x. f x $ i) ---> a $ i) net"
proof (rule topological_tendstoI)
  fix S assume "open S" "a $ i \<in> S"
  then have "open ((\<lambda>y. y $ i) -` S)" "a \<in> ((\<lambda>y. y $ i) -` S)"
    by (simp_all add: open_vimage_vec_nth)
  with assms have "eventually (\<lambda>x. f x \<in> (\<lambda>y. y $ i) -` S) net"
    by (rule topological_tendstoD)
  then show "eventually (\<lambda>x. f x $ i \<in> S) net"
    by simp
qed

lemma isCont_vec_nth [simp]: "isCont f a \<Longrightarrow> isCont (\<lambda>x. f x $ i) a"
  unfolding isCont_def by (rule tendsto_vec_nth)

lemma vec_tendstoI:
  assumes "\<And>i. ((\<lambda>x. f x $ i) ---> a $ i) net"
  shows "((\<lambda>x. f x) ---> a) net"
proof (rule topological_tendstoI)
  fix S assume "open S" and "a \<in> S"
  then obtain A where A: "\<And>i. open (A i)" "\<And>i. a $ i \<in> A i"
    and S: "\<And>y. \<forall>i. y $ i \<in> A i \<Longrightarrow> y \<in> S"
    unfolding open_vec_def by metis
  have "\<And>i. eventually (\<lambda>x. f x $ i \<in> A i) net"
    using assms A by (rule topological_tendstoD)
  hence "eventually (\<lambda>x. \<forall>i. f x $ i \<in> A i) net"
    by (rule eventually_all_finite)
  thus "eventually (\<lambda>x. f x \<in> S) net"
    by (rule eventually_elim1, simp add: S)
qed

lemma tendsto_vec_lambda [tendsto_intros]:
  assumes "\<And>i. ((\<lambda>x. f x i) ---> a i) net"
  shows "((\<lambda>x. \<chi> i. f x i) ---> (\<chi> i. a i)) net"
  using assms by (simp add: vec_tendstoI)

lemma open_image_vec_nth: assumes "open S" shows "open ((\<lambda>x. x $ i) ` S)"
proof (rule openI)
  fix a assume "a \<in> (\<lambda>x. x $ i) ` S"
  then obtain z where "a = z $ i" and "z \<in> S" ..
  then obtain A where A: "\<forall>i. open (A i) \<and> z $ i \<in> A i"
    and S: "\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S"
    using `open S` unfolding open_vec_def by auto
  hence "A i \<subseteq> (\<lambda>x. x $ i) ` S"
    by (clarsimp, rule_tac x="\<chi> j. if j = i then x else z $ j" in image_eqI,
      simp_all)
  hence "open (A i) \<and> a \<in> A i \<and> A i \<subseteq> (\<lambda>x. x $ i) ` S"
    using A `a = z $ i` by simp
  then show "\<exists>T. open T \<and> a \<in> T \<and> T \<subseteq> (\<lambda>x. x $ i) ` S" by - (rule exI)
qed

instance vec :: (perfect_space, finite) perfect_space
proof
  fix x :: "'a ^ 'b" show "\<not> open {x}"
  proof
    assume "open {x}"
    hence "\<forall>i. open ((\<lambda>x. x $ i) ` {x})" by (fast intro: open_image_vec_nth)
    hence "\<forall>i. open {x $ i}" by simp
    thus "False" by (simp add: not_open_singleton)
  qed
qed

subsection {* Metric space *}

instantiation vec :: (metric_space, finite) metric_space
begin

definition
  "dist x y = setL2 (\<lambda>i. dist (x$i) (y$i)) UNIV"

lemma dist_vec_nth_le: "dist (x $ i) (y $ i) \<le> dist x y"
  unfolding dist_vec_def by (rule member_le_setL2) simp_all

instance proof
  fix x y :: "'a ^ 'b"
  show "dist x y = 0 \<longleftrightarrow> x = y"
    unfolding dist_vec_def
    by (simp add: setL2_eq_0_iff vec_eq_iff)
next
  fix x y z :: "'a ^ 'b"
  show "dist x y \<le> dist x z + dist y z"
    unfolding dist_vec_def
    apply (rule order_trans [OF _ setL2_triangle_ineq])
    apply (simp add: setL2_mono dist_triangle2)
    done
next
  fix S :: "('a ^ 'b) set"
  show "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
  proof
    assume "open S" show "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S"
    proof
      fix x assume "x \<in> S"
      obtain A where A: "\<forall>i. open (A i)" "\<forall>i. x $ i \<in> A i"
        and S: "\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S"
        using `open S` and `x \<in> S` unfolding open_vec_def by metis
      have "\<forall>i\<in>UNIV. \<exists>r>0. \<forall>y. dist y (x $ i) < r \<longrightarrow> y \<in> A i"
        using A unfolding open_dist by simp
      hence "\<exists>r. \<forall>i\<in>UNIV. 0 < r i \<and> (\<forall>y. dist y (x $ i) < r i \<longrightarrow> y \<in> A i)"
        by (rule finite_set_choice [OF finite])
      then obtain r where r1: "\<forall>i. 0 < r i"
        and r2: "\<forall>i y. dist y (x $ i) < r i \<longrightarrow> y \<in> A i" by fast
      have "0 < Min (range r) \<and> (\<forall>y. dist y x < Min (range r) \<longrightarrow> y \<in> S)"
        by (simp add: r1 r2 S le_less_trans [OF dist_vec_nth_le])
      thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" ..
    qed
  next
    assume *: "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" show "open S"
    proof (unfold open_vec_def, rule)
      fix x assume "x \<in> S"
      then obtain e where "0 < e" and S: "\<forall>y. dist y x < e \<longrightarrow> y \<in> S"
        using * by fast
      def r \<equiv> "\<lambda>i::'b. e / sqrt (of_nat CARD('b))"
      from `0 < e` have r: "\<forall>i. 0 < r i"
        unfolding r_def by simp_all
      from `0 < e` have e: "e = setL2 r UNIV"
        unfolding r_def by (simp add: setL2_constant)
      def A \<equiv> "\<lambda>i. {y. dist (x $ i) y < r i}"
      have "\<forall>i. open (A i) \<and> x $ i \<in> A i"
        unfolding A_def by (simp add: open_ball r)
      moreover have "\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S"
        by (simp add: A_def S dist_vec_def e setL2_strict_mono dist_commute)
      ultimately show "\<exists>A. (\<forall>i. open (A i) \<and> x $ i \<in> A i) \<and>
        (\<forall>y. (\<forall>i. y $ i \<in> A i) \<longrightarrow> y \<in> S)" by metis
    qed
  qed
qed

end

lemma Cauchy_vec_nth:
  "Cauchy (\<lambda>n. X n) \<Longrightarrow> Cauchy (\<lambda>n. X n $ i)"
  unfolding Cauchy_def by (fast intro: le_less_trans [OF dist_vec_nth_le])

lemma vec_CauchyI:
  fixes X :: "nat \<Rightarrow> 'a::metric_space ^ 'n"
  assumes X: "\<And>i. Cauchy (\<lambda>n. X n $ i)"
  shows "Cauchy (\<lambda>n. X n)"
proof (rule metric_CauchyI)
  fix r :: real assume "0 < r"
  hence "0 < r / of_nat CARD('n)" (is "0 < ?s") by simp
  def N \<equiv> "\<lambda>i. LEAST N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
  def M \<equiv> "Max (range N)"
  have "\<And>i. \<exists>N. \<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m $ i) (X n $ i) < ?s"
    using X `0 < ?s` by (rule metric_CauchyD)
  hence "\<And>i. \<forall>m\<ge>N i. \<forall>n\<ge>N i. dist (X m $ i) (X n $ i) < ?s"
    unfolding N_def by (rule LeastI_ex)
  hence M: "\<And>i. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m $ i) (X n $ i) < ?s"
    unfolding M_def by simp
  {
    fix m n :: nat
    assume "M \<le> m" "M \<le> n"
    have "dist (X m) (X n) = setL2 (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
      unfolding dist_vec_def ..
    also have "\<dots> \<le> setsum (\<lambda>i. dist (X m $ i) (X n $ i)) UNIV"
      by (rule setL2_le_setsum [OF zero_le_dist])
    also have "\<dots> < setsum (\<lambda>i::'n. ?s) UNIV"
      by (rule setsum_strict_mono, simp_all add: M `M \<le> m` `M \<le> n`)
    also have "\<dots> = r"
      by simp
    finally have "dist (X m) (X n) < r" .
  }
  hence "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r"
    by simp
  then show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < r" ..
qed

instance vec :: (complete_space, finite) complete_space
proof
  fix X :: "nat \<Rightarrow> 'a ^ 'b" assume "Cauchy X"
  have "\<And>i. (\<lambda>n. X n $ i) ----> lim (\<lambda>n. X n $ i)"
    using Cauchy_vec_nth [OF `Cauchy X`]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  hence "X ----> vec_lambda (\<lambda>i. lim (\<lambda>n. X n $ i))"
    by (simp add: vec_tendstoI)
  then show "convergent X"
    by (rule convergentI)
qed

subsection {* Normed vector space *}

instantiation vec :: (real_normed_vector, finite) real_normed_vector
begin

definition "norm x = setL2 (\<lambda>i. norm (x$i)) UNIV"

definition "sgn (x::'a^'b) = scaleR (inverse (norm x)) x"

instance proof
  fix a :: real and x y :: "'a ^ 'b"
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_vec_def
    by (simp add: setL2_eq_0_iff vec_eq_iff)
  show "norm (x + y) \<le> norm x + norm y"
    unfolding norm_vec_def
    apply (rule order_trans [OF _ setL2_triangle_ineq])
    apply (simp add: setL2_mono norm_triangle_ineq)
    done
  show "norm (scaleR a x) = \<bar>a\<bar> * norm x"
    unfolding norm_vec_def
    by (simp add: setL2_right_distrib)
  show "sgn x = scaleR (inverse (norm x)) x"
    by (rule sgn_vec_def)
  show "dist x y = norm (x - y)"
    unfolding dist_vec_def norm_vec_def
    by (simp add: dist_norm)
qed

end

lemma norm_nth_le: "norm (x $ i) \<le> norm x"
unfolding norm_vec_def
by (rule member_le_setL2) simp_all

lemma bounded_linear_vec_nth: "bounded_linear (\<lambda>x. x $ i)"
apply default
apply (rule vector_add_component)
apply (rule vector_scaleR_component)
apply (rule_tac x="1" in exI, simp add: norm_nth_le)
done

instance vec :: (banach, finite) banach ..

subsection {* Inner product space *}

instantiation vec :: (real_inner, finite) real_inner
begin

definition "inner x y = setsum (\<lambda>i. inner (x$i) (y$i)) UNIV"

instance proof
  fix r :: real and x y z :: "'a ^ 'b"
  show "inner x y = inner y x"
    unfolding inner_vec_def
    by (simp add: inner_commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_vec_def
    by (simp add: inner_add_left setsum.distrib)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_vec_def
    by (simp add: setsum_right_distrib)
  show "0 \<le> inner x x"
    unfolding inner_vec_def
    by (simp add: setsum_nonneg)
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_vec_def
    by (simp add: vec_eq_iff setsum_nonneg_eq_0_iff)
  show "norm x = sqrt (inner x x)"
    unfolding inner_vec_def norm_vec_def setL2_def
    by (simp add: power2_norm_eq_inner)
qed

end

subsection {* Euclidean space *}

text {* Vectors pointing along a single axis. *}

definition "axis k x = (\<chi> i. if i = k then x else 0)"

lemma axis_nth [simp]: "axis i x $ i = x"
  unfolding axis_def by simp

lemma axis_eq_axis: "axis i x = axis j y \<longleftrightarrow> x = y \<and> i = j \<or> x = 0 \<and> y = 0"
  unfolding axis_def vec_eq_iff by auto

lemma inner_axis_axis:
  "inner (axis i x) (axis j y) = (if i = j then inner x y else 0)"
  unfolding inner_vec_def
  apply (cases "i = j")
  apply clarsimp
  apply (subst setsum.remove [of _ j], simp_all)
  apply (rule setsum.neutral, simp add: axis_def)
  apply (rule setsum.neutral, simp add: axis_def)
  done

lemma setsum_single:
  assumes "finite A" and "k \<in> A" and "f k = y"
  assumes "\<And>i. i \<in> A \<Longrightarrow> i \<noteq> k \<Longrightarrow> f i = 0"
  shows "(\<Sum>i\<in>A. f i) = y"
  apply (subst setsum.remove [OF assms(1,2)])
  apply (simp add: setsum.neutral assms(3,4))
  done

lemma inner_axis: "inner x (axis i y) = inner (x $ i) y"
  unfolding inner_vec_def
  apply (rule_tac k=i in setsum_single)
  apply simp_all
  apply (simp add: axis_def)
  done

instantiation vec :: (euclidean_space, finite) euclidean_space
begin

definition "Basis = (\<Union>i. \<Union>u\<in>Basis. {axis i u})"

instance proof
  show "(Basis :: ('a ^ 'b) set) \<noteq> {}"
    unfolding Basis_vec_def by simp
next
  show "finite (Basis :: ('a ^ 'b) set)"
    unfolding Basis_vec_def by simp
next
  fix u v :: "'a ^ 'b"
  assume "u \<in> Basis" and "v \<in> Basis"
  thus "inner u v = (if u = v then 1 else 0)"
    unfolding Basis_vec_def
    by (auto simp add: inner_axis_axis axis_eq_axis inner_Basis)
next
  fix x :: "'a ^ 'b"
  show "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> x = 0"
    unfolding Basis_vec_def
    by (simp add: inner_axis euclidean_all_zero_iff vec_eq_iff)
qed

lemma DIM_cart[simp]: "DIM('a^'b) = CARD('b) * DIM('a)"
  apply (simp add: Basis_vec_def)
  apply (subst card_UN_disjoint)
     apply simp
    apply simp
   apply (auto simp: axis_eq_axis) [1]
  apply (subst card_UN_disjoint)
     apply (auto simp: axis_eq_axis)
  done

end

end


theory OneThirdRuleDefs
imports "../HOModel"
begin

section {* Verification of the \emph{One-Third Rule} Consensus Algorithm *}

text {*
  We now apply the framework introduced so far to the verification of
  concrete algorithms, starting with algorithm \emph{One-Third Rule},
  which is one of the simplest algorithms presented in~\cite{charron:heardof}.
  Nevertheless, the algorithm has some interesting characteristics:
  it ensures safety (i.e., the Integrity and Agreement) properties in the
  presence of arbitrary benign faults, and if everything works perfectly,
  it terminates in just two rounds. \emph{One-Third Rule} is an uncoordinated
  algorithm tolerating benign faults, hence SHO or coordinator sets do not
  play a role in its definition.
*}

subsection {* Model of the Algorithm *}

text {*
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable @{text "'proc"}
  of the generic HO model.
*}

typedecl Proc -- {* the set of processes *}
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"

text {*
  The state of each process consists of two fields: @{text x} holds
  the current value proposed by the process and @{text decide} the
  value (if any, hence the option type) it has decided.
*}

record 'val pstate =
  x :: "'val"
  decide :: "'val option"

text {*
  The initial value of field @{text x} is unconstrained, but no decision
  has been taken initially.
*}

definition OTR_initState where
  "OTR_initState p st \<equiv> decide st = None"

text {*
  Given a vector @{text msgs} of values (possibly null) received from
  each process, @{term "HOV msgs v"} denotes the set of processes from
  which value @{text v} was received.
*}

definition HOV :: "(Proc \<Rightarrow> 'val option) \<Rightarrow> 'val \<Rightarrow> Proc set" where
  "HOV msgs v \<equiv> { q . msgs q = Some v }"

text {*
  @{term "MFR msgs v"} (``most frequently received'') holds for
  vector @{text msgs} if no value has been received more frequently
  than @{text v}.

  Some such value always exists, since there is only a finite set of
  processes and thus a finite set of possible cardinalities of the
  sets @{term "HOV msgs v"}.
*}

definition MFR :: "(Proc \<Rightarrow> 'val option) \<Rightarrow> 'val \<Rightarrow> bool" where
  "MFR msgs v \<equiv> \<forall>w. card (HOV msgs w) \<le> card (HOV msgs v)"

lemma MFR_exists: "\<exists>v. MFR msgs v"
proof -
  let ?cards = "{ card (HOV msgs v) | v . True }"
  let ?mfr = "Max ?cards"
  have "\<forall>v. card (HOV msgs v) \<le> N" by (auto intro: card_mono)
  hence "?cards \<subseteq> { 0 .. N }" by auto
  hence fin: "finite ?cards" by (metis atLeast0AtMost finite_atMost finite_subset)
  hence "?mfr \<in> ?cards" by (rule Max_in) auto
  then obtain v where v: "?mfr = card (HOV msgs v)" by auto
  have "MFR msgs v"
  proof (auto simp: MFR_def)
    fix w
    from fin have "card (HOV msgs w) \<le> ?mfr" by (rule Max_ge) auto
    thus "card (HOV msgs w) \<le> card (HOV msgs v)" by (unfold v)
  qed
  thus ?thesis ..
qed

text {*
  Also, if a process has heard from at least one other process,
  the most frequently received values are among the received messages.
*}

lemma MFR_in_msgs:
  assumes HO:"HOs m p \<noteq> {}"
      and v: "MFR (HOrcvdMsgs OTR_M m p (HOs m p) (rho m)) v"
             (is "MFR ?msgs v")
  shows "\<exists>q \<in> HOs m p. v = the (?msgs q)"
proof -
  from HO obtain q where q: "q \<in> HOs m p"
    by auto
  with v have "HOV ?msgs (the (?msgs q)) \<noteq> {}"
    by (auto simp: HOV_def HOrcvdMsgs_def)
  hence HOp: "0 < card (HOV ?msgs (the (?msgs q)))"
    by auto
  also from v have "\<dots> \<le> card (HOV ?msgs v)"
    by (simp add: MFR_def)
  finally have "HOV ?msgs v \<noteq> {}"
    by auto
  thus ?thesis
    by (auto simp: HOV_def HOrcvdMsgs_def)
qed

text {*
  @{term "TwoThirds msgs v"} holds if value @{text v} has been
  received from more than $2/3$ of all processes.
*}

definition TwoThirds where
  "TwoThirds msgs v \<equiv> (2*N) div 3 < card (HOV msgs v)"

text {*
  The next-state relation of algorithm \emph{One-Third Rule} for every process
  is defined as follows:
  if the process has received values from more than $2/3$ of all processes,
  the @{text x} field is set to the smallest among the most frequently received
  values, and the process decides value $v$ if it received $v$ from more than
  $2/3$ of all processes. If @{text p} hasn't heard from more than $2/3$ of
  all processes, the state remains unchanged.
  (Note that @{text Some} is the constructor of the option datatype, whereas
  @{text "\<some>"} is Hilbert's choice operator.)
  We require the type of values to be linearly ordered so that the minimum
  is guaranteed to be well-defined.
*}

definition OTR_nextState where
  "OTR_nextState r p (st::('val::linorder) pstate) msgs st' \<equiv>
   if (2*N) div 3 < card {q. msgs q \<noteq> None}
   then st' = \<lparr> x = Min {v . MFR msgs v},
          decide = (if (\<exists>v. TwoThirds msgs v)
                    then Some (\<some>v. TwoThirds msgs v)
                    else decide st) \<rparr>
   else st' = st"

text {*
  The message sending function is very simple: at every round, every process
  sends its current proposal (field @{text x} of its local state) to all
  processes.
*}

definition OTR_sendMsg where
  "OTR_sendMsg r p q st \<equiv> x st"

subsection {* Communication Predicate for \emph{One-Third Rule} *}

text {*
  We now define the communication predicate for the \emph{One-Third Rule}
  algorithm to be correct.
  It requires that, infinitely often, there is a round where all processes
  receive messages from the same set @{text "\<Pi>"} of processes where @{text "\<Pi>"}
  contains more than two thirds of all processes.
  The ``per-round'' part of the communication predicate is trivial.
*}

definition OTR_commPerRd where
  "OTR_commPerRd HOrs \<equiv> True"

definition OTR_commGlobal where
  "OTR_commGlobal HOs \<equiv>
    \<forall>r. \<exists>r0 \<Pi>. r0 \<ge> r \<and> (\<forall>p. HOs r0 p = \<Pi>) \<and> card \<Pi> > (2*N) div 3"

subsection {* The \emph{One-Third Rule} Heard-Of Machine *}

text {*
  We now define the HO machine for the \emph{One-Third Rule} algorithm
  by assembling the algorithm definition and its communication-predicate.
  Because this is an uncoordinated algorithm, the @{text crd} arguments
  of the initial- and next-state predicates are unused.
*}

definition OTR_HOMachine where
  "OTR_HOMachine =
    \<lparr> CinitState =  (\<lambda> p st crd. OTR_initState p st),
     sendMsg =  OTR_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. OTR_nextState r p st msgs st'),
     HOcommPerRd = OTR_commPerRd,
     HOcommGlobal = OTR_commGlobal \<rparr>"

abbreviation "OTR_M \<equiv> OTR_HOMachine::(Proc, 'val::linorder pstate, 'val) HOMachine"

end


theory Variable
  imports Main
begin

datatype var = V nat

primrec fresh' :: "var set \<Rightarrow> nat \<Rightarrow> nat" where
  "fresh' xs 0 = 0"
| "fresh' xs (Suc x) = (if V (Suc x) \<in> xs then fresh' (xs - {V (Suc x)}) x else Suc x)"

definition fresh :: "var set \<Rightarrow> var" where
  "fresh xs = V (fresh' xs (card xs))"

abbreviation extend_set :: "var set \<Rightarrow> var set" where
  "extend_set vs \<equiv> insert (fresh vs) vs"

lemma [simp]: "finite xs \<Longrightarrow> fresh' xs x \<noteq> Suc x"
proof -
  assume "finite xs"
  hence "fresh' xs x < Suc x" by simp
  thus ?thesis by simp
qed

lemma [simp]: "finite xs \<Longrightarrow> x = card xs \<Longrightarrow> V (fresh' xs x) \<notin> xs"
proof (induction x arbitrary: xs)
  case (Suc x)
  moreover hence "finite (xs - {V (Suc x)})" by simp
  moreover from Suc have "V (Suc x) \<in> xs \<Longrightarrow> x = card (xs - {V (Suc x)})" by simp
  ultimately have "V (Suc x) \<in> xs \<Longrightarrow> V (fresh' (xs - {V (Suc x)}) x) \<notin> xs - {V (Suc x)}" by metis
  moreover from Suc(2) have "fresh' (xs - {V (Suc x)}) x \<noteq> Suc x" by simp
  ultimately show ?case by simp
qed simp_all

lemma fresh_is_fresh [simp]: "finite xs \<Longrightarrow> fresh xs \<notin> xs"
  by (simp add: fresh_def)

end