theory BananasSafety
imports BananasDynamics
begin

(* canonical values *)

lemma canonical_unit: "\<Gamma> \<turnstile> v : \<one> \<Longrightarrow> v = UnitV"
  by (cases \<Gamma> v \<one> rule: typecheck\<^sub>v.cases) simp_all

lemma canonical_prod: "\<Gamma> \<turnstile> v : t\<^sub>1 \<otimes> t\<^sub>2 \<Longrightarrow> \<exists>v\<^sub>1 v\<^sub>2. (\<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>1) \<and> (\<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>2) \<and> v = PairV v\<^sub>1 v\<^sub>2"
  by (cases \<Gamma> v "t\<^sub>1 \<otimes> t\<^sub>2" rule: typecheck\<^sub>v.cases) simp_all

lemma canonical_sum: "\<Gamma> \<turnstile> v : t\<^sub>1 \<oplus> t\<^sub>2 \<Longrightarrow>
    \<exists>v'. ((\<Gamma> \<turnstile> v' : t\<^sub>1) \<and> v = InlV v') \<or> ((\<Gamma> \<turnstile> v' : t\<^sub>2) \<and> v = InrV v')"
  by (cases \<Gamma> v "t\<^sub>1 \<oplus> t\<^sub>2" rule: typecheck\<^sub>v.cases) simp_all

lemma canonical_arrow: "\<Gamma> \<turnstile> v : t\<^sub>1 \<hookrightarrow> t\<^sub>2 \<Longrightarrow> \<exists>e. (\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2) \<and> v = FunV e"
  by (cases \<Gamma> v "t\<^sub>1 \<hookrightarrow> t\<^sub>2" rule: typecheck\<^sub>v.cases) simp_all

lemma canonical_mu: "\<Gamma> \<turnstile> v : \<mu> F \<Longrightarrow>
    \<exists>v' n. (\<Gamma> \<turnstile> v' : \<mu> F \<star> F) \<and> v = InjV n v' \<and> var\<^sub>t_type \<Gamma> n = Some F"
  by (cases \<Gamma> v "\<mu> F" rule: typecheck\<^sub>v.cases) simp_all

(* environment lemmas *)

lemma [simp]: "combine\<^sub>d \<Lambda> empty_dynamic = \<Lambda>"
  by (simp add: combine\<^sub>d_def empty_dynamic_def)

lemma [simp]: "combine\<^sub>d (combine\<^sub>d \<Lambda>\<^sub>1 \<Lambda>\<^sub>2) \<Lambda>\<^sub>3 = combine\<^sub>d \<Lambda>\<^sub>1 (combine\<^sub>d \<Lambda>\<^sub>2 \<Lambda>\<^sub>3)"
  by (simp add: combine\<^sub>d_def empty_dynamic_def)

lemma [simp]: "\<lparr>var\<^sub>e_bind = var\<^sub>e_bind \<Lambda>(x \<mapsto> e), var\<^sub>t_bind = var\<^sub>t_bind \<Lambda>\<rparr> = extend\<^sub>e\<^sub>d x e \<Lambda>"
  by (simp add: extend\<^sub>e\<^sub>d_def)

lemma tce_right_inject_helper [simp]: "typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e', var\<^sub>t_type = [x \<mapsto> F]\<rparr>
  \<Gamma>\<^sub>e' (assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts) \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow> y \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow>
    F = foldr op \<Oplus> (Fs @ [ctor_funct ts'']) F' \<Longrightarrow>
      typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e'(y \<mapsto> (ctor_type ts', \<mu> F)), var\<^sub>t_type = [x \<mapsto> F]\<rparr>
        (\<Gamma>\<^sub>e'(y \<mapsto> (ctor_type ts', \<mu> F)))
          (assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts(y \<mapsto> \<succ>\<^bsub>x\<^esub> \<cdot> right_inject (length Fs)))"
  proof (unfold typecheck_env\<^sub>e_def, rule, simp, rule, rule, rule, rule)
    fix z t\<^sub>1 t\<^sub>2
    assume "dom \<Gamma>\<^sub>e' = dom (assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts) \<and>
       (\<forall>xa t\<^sub>1 t\<^sub>2. \<Gamma>\<^sub>e' xa = Some (t\<^sub>1, t\<^sub>2) \<longrightarrow>
          (\<exists>e. assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts xa = Some e \<and>
            \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e', var\<^sub>t_type = [x \<mapsto> F]\<rparr> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2))"
       and "x \<notin> domain\<^sub>s \<Gamma>"
       and "y \<notin> domain\<^sub>s \<Gamma>"
       and "F = foldr op \<Oplus> (Fs @ [BananasStatics.ctor_funct ts'']) F'"
       and "(\<Gamma>\<^sub>e'(y \<mapsto> (BananasStatics.ctor_type ts', \<mu> F))) z = Some (t\<^sub>1, t\<^sub>2)"
    thus "\<exists>e. (assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts(y \<mapsto> \<succ>\<^bsub>x\<^esub> \<cdot> right_inject (length Fs))) z =
      Some e \<and> \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e'(y \<mapsto> (BananasStatics.ctor_type ts', \<mu> F)), var\<^sub>t_type = [x \<mapsto> F]\<rparr> \<turnstile>
        e : t\<^sub>1 \<rightarrow> t\<^sub>2"
      proof (cases "z = y")
      case True
        thus ?thesis by simp
      next case False
        thus ?thesis by simp
      qed
  qed

lemma [simp]: "typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts = Some F \<Longrightarrow>
  typecheck\<^sub>c\<^sub>e \<Gamma> (foldr (op \<Oplus>) Fs F) cts \<Gamma>\<^sub>e \<Longrightarrow>
    x \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow> fst ` set cts \<inter> domain\<^sub>s \<Gamma> = {} \<Longrightarrow>
      typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e, var\<^sub>t_type = [x \<mapsto> foldr (op \<Oplus>) Fs F]\<rparr> \<Gamma>\<^sub>e
        (assemble_context\<^sub>c\<^sub>e x (length Fs) cts)"
  proof (induction x "length Fs" cts arbitrary: \<Gamma>\<^sub>e F Fs rule: assemble_context\<^sub>c\<^sub>e.induct)
  case 1
    thus ?case using typecheck_env\<^sub>e_def by fastforce
  next case (2 x y ts cts)
    then obtain \<Gamma>\<^sub>e' ts' where G: "\<Gamma>\<^sub>e = \<Gamma>\<^sub>e'(y \<mapsto> (ctor_type ts', \<mu> (foldr (op \<Oplus>) Fs F))) \<and>
      typecheck\<^sub>c\<^sub>e \<Gamma> (foldr (op \<Oplus>) Fs F) cts \<Gamma>\<^sub>e' \<and>
        those (map (map_option \<mu> o var\<^sub>t_type \<Gamma>) ts) = Some ts'" by fastforce
    from 2 obtain ts'' F' where F: "those (map (typecheck\<^sub>c\<^sub>t_arg \<Gamma> x) ts) = Some ts'' \<and>
      typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts = Some F' \<and> ctor_funct ts'' \<Oplus> F' = F" by (metis unfold_tc_cts)
    let ?F = "foldr op \<Oplus> (Fs @ [ctor_funct ts'']) F'"
    from F G have Y: "typecheck\<^sub>c\<^sub>e \<Gamma> ?F  cts \<Gamma>\<^sub>e'" by simp
    have X: "Suc (length Fs) = length (Fs @ [ctor_funct ts''])" by simp
    from 2 have "fst ` set cts \<inter> domain\<^sub>s \<Gamma> = {}" by simp
    with 2 F X Y have "typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e', var\<^sub>t_type = [x \<mapsto> ?F]\<rparr>
      \<Gamma>\<^sub>e' (assemble_context\<^sub>c\<^sub>e x (length (Fs @ [ctor_funct ts''])) cts)" by blast
    hence "typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e', var\<^sub>t_type = [x \<mapsto> ?F]\<rparr>
      \<Gamma>\<^sub>e' (assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts)" by simp
    moreover from 2 have "x \<notin> domain\<^sub>s \<Gamma>" by simp
    moreover from 2 have "y \<notin> domain\<^sub>s \<Gamma>" by simp
    ultimately have "typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e'(y \<mapsto> (ctor_type ts', \<mu> ?F)),
      var\<^sub>t_type = [x \<mapsto> ?F ]\<rparr> (\<Gamma>\<^sub>e'(y \<mapsto> (ctor_type ts', \<mu> ?F)))
        (assemble_context\<^sub>c\<^sub>e x (Suc (length Fs)) cts(y \<mapsto> \<succ>\<^bsub>x\<^esub> \<cdot> right_inject (length Fs)))"
      by (metis tce_right_inject_helper)
    with G F show ?case by simp
  qed

lemma [simp]: "typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts = Some F \<Longrightarrow> typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow>
  fst ` set cts \<inter> domain\<^sub>s \<Gamma> = {} \<Longrightarrow>
    typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e, var\<^sub>t_type = [x \<mapsto> F]\<rparr> \<Gamma>\<^sub>e (assemble_context\<^sub>c\<^sub>e x 0 cts)"
  proof -
    assume "typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts = Some F"
       and "x \<notin> domain\<^sub>s \<Gamma>"
       and "fst ` set cts \<inter> domain\<^sub>s \<Gamma> = {}"
    hence "\<And>fs. typecheck\<^sub>c\<^sub>e \<Gamma> (foldr (op \<Oplus>) fs F) cts \<Gamma>\<^sub>e \<Longrightarrow>
      typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e, var\<^sub>t_type = [x \<mapsto> foldr (op \<Oplus>) fs F]\<rparr> \<Gamma>\<^sub>e
        (assemble_context\<^sub>c\<^sub>e x (length fs) cts)" by simp
    hence "typecheck\<^sub>c\<^sub>e \<Gamma> (foldr (op \<Oplus>) [] F) cts \<Gamma>\<^sub>e \<Longrightarrow>
      typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e, var\<^sub>t_type = [x \<mapsto> foldr (op \<Oplus>) [] F]\<rparr> \<Gamma>\<^sub>e
        (assemble_context\<^sub>c\<^sub>e x (length []) cts)" by fastforce
    moreover assume "typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e"
    ultimately show "typecheck_env\<^sub>e \<lparr>var\<^sub>e_type = \<Gamma>\<^sub>e, var\<^sub>t_type = [x \<mapsto> F]\<rparr> \<Gamma>\<^sub>e
      (assemble_context\<^sub>c\<^sub>e x 0 cts)" by simp
  qed

lemma [simp]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda> \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow>
    extend\<^sub>e\<^sub>s x (t\<^sub>1, t\<^sub>2) \<Gamma> \<tturnstile> extend\<^sub>e\<^sub>d x e \<Lambda>"
  using typecheck_environment_def typecheck_env\<^sub>e_def by fastforce

lemma [simp]: "typecheck\<^sub>d\<^sub>t \<Gamma>\<^sub>1 x cts \<Gamma>\<^sub>2 \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma>\<^sub>1 \<Longrightarrow> fst ` set cts \<inter> domain\<^sub>s \<Gamma>\<^sub>1 = {} \<Longrightarrow>
    \<Gamma>\<^sub>2 \<tturnstile> \<lparr>var\<^sub>e_bind = assemble_context\<^sub>c\<^sub>e x 0 cts, var\<^sub>t_bind = [x \<mapsto> the (typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma>\<^sub>1 x cts)]\<rparr>"
  by (induction \<Gamma>\<^sub>1 x cts \<Gamma>\<^sub>2 rule: typecheck\<^sub>d\<^sub>t.induct) (simp_all add: typecheck_environment_def)

lemma [simp]: "typecheck_env\<^sub>e \<Gamma>\<^sub>1 (var\<^sub>e_type \<Gamma>\<^sub>1) (var\<^sub>e_bind \<Lambda>\<^sub>1) \<Longrightarrow>
  typecheck_env\<^sub>e \<Gamma>\<^sub>2 (var\<^sub>e_type \<Gamma>\<^sub>2) (var\<^sub>e_bind \<Lambda>\<^sub>2) \<Longrightarrow> domain\<^sub>s \<Gamma>\<^sub>1 \<inter> domain\<^sub>s \<Gamma>\<^sub>2 = {} \<Longrightarrow>
    typecheck_env\<^sub>e (combine\<^sub>s \<Gamma>\<^sub>1 \<Gamma>\<^sub>2) (var\<^sub>e_type (combine\<^sub>s \<Gamma>\<^sub>1 \<Gamma>\<^sub>2)) (var\<^sub>e_bind (combine\<^sub>d \<Lambda>\<^sub>1 \<Lambda>\<^sub>2))"
  apply (simp add: typecheck_env\<^sub>e_def)
  by simp

lemma [simp]: "var\<^sub>t_type \<Gamma>\<^sub>1 = var\<^sub>t_bind \<Lambda>\<^sub>1 \<Longrightarrow> var\<^sub>t_type \<Gamma>\<^sub>2 = var\<^sub>t_bind \<Lambda>\<^sub>2 \<Longrightarrow>
    var\<^sub>t_type (combine\<^sub>s \<Gamma>\<^sub>1 \<Gamma>\<^sub>2) = var\<^sub>t_bind (combine\<^sub>d \<Lambda>\<^sub>1 \<Lambda>\<^sub>2)"
  by (simp add: combine\<^sub>s_def combine\<^sub>d_def)

lemma [simp]: "\<Gamma>\<^sub>1 \<tturnstile> \<Lambda>\<^sub>1 \<Longrightarrow> \<Gamma>\<^sub>2 \<tturnstile> \<Lambda>\<^sub>2 \<Longrightarrow> domain\<^sub>s \<Gamma>\<^sub>1 \<inter> domain\<^sub>s \<Gamma>\<^sub>2 = {} \<Longrightarrow>
    combine\<^sub>s \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<tturnstile> combine\<^sub>d \<Lambda>\<^sub>1 \<Lambda>\<^sub>2"
  by (simp add: typecheck_environment_def)

lemma [simp]: "typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e \<Longrightarrow> dom \<Gamma>\<^sub>e = fst ` set cts"
  by (induction \<Gamma> F cts \<Gamma>\<^sub>e rule: typecheck\<^sub>c\<^sub>e.induct) (auto simp add: Map.dom_if)

lemma [simp]: "typecheck\<^sub>d\<^sub>t \<Gamma>\<^sub>1 x cts \<Gamma>\<^sub>2 \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma>\<^sub>1 \<Longrightarrow> fst ` set cts \<inter> domain\<^sub>s \<Gamma>\<^sub>1 = {} \<Longrightarrow>
    domain\<^sub>s \<Gamma>\<^sub>1 \<inter> domain\<^sub>s \<Gamma>\<^sub>2 = {}"
  by (induction \<Gamma>\<^sub>1 x cts \<Gamma>\<^sub>2 rule: typecheck\<^sub>d\<^sub>t.induct) (auto simp add: domain\<^sub>s_def)

lemma [simp]: "\<Gamma>\<^sub>1 \<Turnstile> \<delta> : \<Gamma>\<^sub>2 \<Longrightarrow> \<Gamma>\<^sub>1 \<tturnstile> \<Lambda> \<Longrightarrow> binders\<^sub>d \<delta> \<inter> domain\<^sub>s \<Gamma>\<^sub>1 = {} \<Longrightarrow>
    \<Gamma>\<^sub>2 \<tturnstile> combine\<^sub>d \<Lambda> (assemble_context' \<Gamma>\<^sub>1 \<delta>)"
  proof (induction \<Gamma>\<^sub>1 \<delta> \<Gamma>\<^sub>2 rule: typecheck_decl.induct)
  case tcd_type
    thus ?case by simp
  qed (simp_all add: combine\<^sub>d_def empty_dynamic_def)

lemma tc_defs_parts [simp]: "\<Gamma> \<Turnstile> \<Delta> :: \<Gamma>' \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda> \<Longrightarrow>
    \<exists>\<Lambda>'. assemble_context \<Gamma> \<Delta> \<Lambda>' \<and> \<Gamma>' \<tturnstile> combine\<^sub>d \<Lambda> \<Lambda>'"
  proof (induction \<Gamma> \<Delta> \<Gamma>' arbitrary: \<Lambda> rule: typecheck_decls.induct)
  case (tcd_nil \<Gamma>)
    hence "assemble_context \<Gamma> [] empty_dynamic \<and> \<Gamma> \<tturnstile> combine\<^sub>d \<Lambda> empty_dynamic" by simp
    thus ?case by fastforce
  next case (tcd_cons \<Gamma>\<^sub>1 \<delta> \<Gamma>\<^sub>2 \<Delta> \<Gamma>\<^sub>3)
    hence "\<Gamma>\<^sub>2 \<tturnstile> combine\<^sub>d \<Lambda> (assemble_context' \<Gamma>\<^sub>1 \<delta>)" by fastforce
    with tcd_cons obtain \<Lambda>\<^sub>3 where "assemble_context \<Gamma>\<^sub>2 \<Delta> \<Lambda>\<^sub>3 \<and> \<Gamma>\<^sub>3 \<tturnstile>
      combine\<^sub>d (combine\<^sub>d \<Lambda> (assemble_context' \<Gamma>\<^sub>1 \<delta>)) \<Lambda>\<^sub>3" by fastforce
    moreover with tcd_cons have "assemble_context \<Gamma>\<^sub>1 (\<delta> # \<Delta>) (combine\<^sub>d (assemble_context' \<Gamma>\<^sub>1 \<delta>) \<Lambda>\<^sub>3)"
      by simp
    ultimately show ?case by fastforce
  qed

lemma [simp]: "empty_static \<tturnstile> empty_dynamic"
  by (simp add: typecheck_environment_def empty_static_def empty_dynamic_def typecheck_env\<^sub>e_def)

lemma [simp]: "empty_static \<Turnstile> \<Delta> :: \<Gamma> \<Longrightarrow>  \<exists>\<Lambda>. assemble_context empty_static \<Delta> \<Lambda> \<and> \<Gamma> \<tturnstile> \<Lambda>"
  proof -
    assume "empty_static \<Turnstile> \<Delta> :: \<Gamma>"
    moreover have "empty_static \<tturnstile> empty_dynamic" by simp
    ultimately obtain \<Lambda> where "assemble_context empty_static \<Delta> \<Lambda> \<and> \<Gamma> \<tturnstile> combine\<^sub>d empty_dynamic \<Lambda>"
      by (metis tc_defs_parts)
    thus ?thesis by auto
  qed

lemma assemble_defs_parts [simp]: "\<Gamma> \<Turnstile> \<Delta> :: \<Gamma>' \<Longrightarrow> assemble_context \<Gamma> \<Delta> \<Lambda>' \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda> \<Longrightarrow>
    \<Gamma>' \<tturnstile> combine\<^sub>d \<Lambda> \<Lambda>'"
  proof (induction \<Gamma> \<Delta> \<Gamma>' arbitrary: \<Lambda> \<Lambda>' rule: typecheck_decls.induct)
  case (tcd_cons \<Gamma>\<^sub>1 \<delta> \<Gamma>\<^sub>2 \<Delta> \<Gamma>\<^sub>3)
    moreover then obtain \<Gamma>\<^sub>2' \<Lambda>\<^sub>2 where G: "(\<Gamma>\<^sub>1 \<Turnstile> \<delta> : \<Gamma>\<^sub>2') \<and> assemble_context \<Gamma>\<^sub>2' \<Delta> \<Lambda>\<^sub>2 \<and>
      \<Lambda>' = combine\<^sub>d (assemble_context' \<Gamma>\<^sub>1 \<delta>) \<Lambda>\<^sub>2" by auto
    moreover with tcd_cons have "\<Gamma>\<^sub>2 = \<Gamma>\<^sub>2'" by auto
    moreover from tcd_cons have "\<Gamma>\<^sub>2 \<tturnstile> combine\<^sub>d \<Lambda> (assemble_context' \<Gamma>\<^sub>1 \<delta>)" by simp
    ultimately have "\<Gamma>\<^sub>3 \<tturnstile> combine\<^sub>d (combine\<^sub>d \<Lambda> (assemble_context' \<Gamma>\<^sub>1 \<delta>)) \<Lambda>\<^sub>2" by blast
    with G show ?case by simp
  qed fastforce+

lemma [simp]: "assemble_context empty_static \<Delta> \<Lambda> \<Longrightarrow> empty_static \<Turnstile> \<Delta> :: \<Gamma> \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda>"
  proof -
    assume "empty_static \<Turnstile> \<Delta> :: \<Gamma>"
       and "assemble_context empty_static \<Delta> \<Lambda>"
    moreover have "empty_static \<tturnstile> empty_dynamic" by simp
    ultimately have "\<Gamma> \<tturnstile> combine\<^sub>d empty_dynamic \<Lambda>" by (metis assemble_defs_parts)
    thus ?thesis by simp
  qed

(* progress *)

theorem expr_progress [simp]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> v : t\<^sub>1 \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda> \<Longrightarrow> e \<noteq> \<epsilon> \<Longrightarrow>
    \<exists>e' v'. \<Lambda> \<turnstile> e \<cdot> v \<leadsto> e' \<cdot> v'"
    and "\<Gamma> \<turnstile> v : t\<^sub>1 \<Longrightarrow> True"
  proof (induction \<Gamma> e t\<^sub>1 t\<^sub>2 arbitrary: v rule: typecheck\<^sub>e_typecheck\<^sub>v.inducts)
  case (tc_con \<Gamma> v\<^sub>2 t\<^sub>2 t\<^sub>1)
    have "\<Lambda> \<turnstile> \<kappa> v\<^sub>2 \<cdot> v \<leadsto> \<epsilon> \<cdot> v\<^sub>2" by simp
    thus ?case by fastforce
  next case (tc_comp \<Gamma> f t\<^sub>2 t\<^sub>3 g)
    thus ?case
      proof (cases "g = \<epsilon>")
      case True
        hence "\<Lambda> \<turnstile> (f \<cdot> g) \<cdot> v \<leadsto> f \<cdot> v" by simp
        thus ?thesis by fastforce
      next case False
        with tc_comp obtain g' v' where "\<Lambda> \<turnstile> g \<cdot> v \<leadsto> g' \<cdot> v'" by blast
        with tc_comp have "\<Lambda> \<turnstile> (f \<cdot> g) \<cdot> v \<leadsto> (f \<cdot> g') \<cdot> v'" by simp
        thus ?thesis by fastforce
      qed
  next case tc_fst
    then obtain v\<^sub>1 v\<^sub>2 where "v = PairV v\<^sub>1 v\<^sub>2" using canonical_prod by blast
    hence "\<Lambda> \<turnstile> \<pi>\<^sub>1 \<cdot> v \<leadsto> \<epsilon> \<cdot> v\<^sub>1" by simp
    thus ?case by fastforce
  next case tc_snd
    then obtain v\<^sub>1 v\<^sub>2 where "v = PairV v\<^sub>1 v\<^sub>2" using canonical_prod by blast
    hence "\<Lambda> \<turnstile> \<pi>\<^sub>2 \<cdot> v \<leadsto> \<epsilon> \<cdot> v\<^sub>2" by simp
    thus ?case by fastforce
  next case tc_tup
    hence "\<Lambda> \<turnstile> \<Theta> \<cdot> v \<leadsto> \<epsilon> \<cdot> PairV v v" by simp
    thus ?case by fastforce
  next case (tc_pair \<Gamma> f\<^sub>1 t\<^sub>1 t\<^sub>2 f\<^sub>2)
    then obtain v\<^sub>1 v\<^sub>2 where V: "v = PairV v\<^sub>1 v\<^sub>2" using canonical_prod by blast
    thus ?case
      proof (cases "f\<^sub>1 = \<epsilon>")
      case True note T = True
        thus ?thesis
          proof (cases "f\<^sub>2 = \<epsilon>")
          case True
            have "\<Lambda> \<turnstile> \<epsilon> \<parallel> \<epsilon> \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<cdot> PairV v\<^sub>1 v\<^sub>2" by simp
            with T True V show ?thesis by fastforce
          next case False
            with tc_pair V obtain f\<^sub>2' v\<^sub>2' where "\<Lambda> \<turnstile> f\<^sub>2 \<cdot> v\<^sub>2 \<leadsto> f\<^sub>2' \<cdot> v\<^sub>2'" by blast
            hence "\<Lambda> \<turnstile> \<epsilon> \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<parallel> f\<^sub>2' \<cdot> PairV v\<^sub>1 v\<^sub>2'" by simp
            with True V show ?thesis by fastforce
          qed
      next case False
        with tc_pair V obtain f\<^sub>1' v\<^sub>1' where "\<Lambda> \<turnstile> f\<^sub>1 \<cdot> v\<^sub>1 \<leadsto> f\<^sub>1' \<cdot> v\<^sub>1'" by blast
        hence "\<Lambda> \<turnstile> f\<^sub>1 \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> f\<^sub>1' \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1' v\<^sub>2" by simp
        with V show ?thesis by fastforce
      qed
  next case tc_inl
    hence "\<Lambda> \<turnstile> \<iota>\<^sub>l \<cdot> v \<leadsto> \<epsilon> \<cdot> InlV v" by simp
    thus ?case by fastforce
  next case tc_inr
    hence "\<Lambda> \<turnstile> \<iota>\<^sub>r \<cdot> v \<leadsto> \<epsilon> \<cdot> InrV v" by simp
    thus ?case by fastforce
  next case tc_str
    then obtain v' where V: "v = InlV v' \<or> v = InrV v'" using canonical_sum by blast
    thus ?case
      proof (cases "v = InlV v'")
      case True
        hence "\<Lambda> \<turnstile> \<Xi> \<cdot> v \<leadsto> \<epsilon> \<cdot> v'" by simp
        thus ?thesis by fastforce
      next case False
        with V have "\<Lambda> \<turnstile> \<Xi> \<cdot> v \<leadsto> \<epsilon> \<cdot> v'" by simp
        thus ?thesis by fastforce
      qed
  next case (tc_case \<Gamma> f\<^sub>l t\<^sub>1 t\<^sub>3 f\<^sub>r)
    then obtain v' where V: "v = InlV v' \<or> v = InrV v'" using canonical_sum by blast
    thus ?case
      proof (cases "v = InlV v'")
      case True
        hence "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> v \<leadsto> (\<iota>\<^sub>l \<cdot> f\<^sub>l) \<cdot> v'" by simp
        thus ?thesis by fastforce
      next case False
        with V have "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> v \<leadsto> (\<iota>\<^sub>r \<cdot> f\<^sub>r) \<cdot> v'" by simp
        thus ?thesis by fastforce
      qed
  next case tc_dst
    then obtain v\<^sub>1 v\<^sub>2 where V: "v = PairV (InlV v\<^sub>1) v\<^sub>2 \<or> v = PairV (InrV v\<^sub>1) v\<^sub>2"
      using canonical_prod canonical_sum by blast
    thus ?case
      proof (cases "v = PairV (InlV v\<^sub>1) v\<^sub>2")
      case True
        hence "\<Lambda> \<turnstile> \<rhd> \<cdot> v \<leadsto> \<epsilon> \<cdot> InlV (PairV v\<^sub>1 v\<^sub>2)" by simp
        thus ?thesis by fastforce
      next case False
        with V have "\<Lambda> \<turnstile> \<rhd> \<cdot> v \<leadsto> \<epsilon> \<cdot> InrV (PairV v\<^sub>1 v\<^sub>2)" by simp
        thus ?thesis by fastforce
      qed
  next case tc_app
    then obtain e v' where V: "v = PairV (FunV e) v'" using canonical_prod canonical_arrow by blast
    moreover hence "\<Lambda> \<turnstile> $ \<cdot> v \<leadsto> e \<cdot> v'" by simp
    ultimately show ?case by fastforce
  next case (tc_arr \<Gamma> f t\<^sub>1 t\<^sub>2 g)
    then obtain e where "v = FunV e" using canonical_arrow by blast
    moreover hence "\<Lambda> \<turnstile> g \<leftarrow> f \<cdot> FunV e \<leadsto> \<epsilon> \<cdot> FunV (g \<cdot> e \<cdot> f)" by simp
    ultimately show ?case by fastforce
  next case (tc_inj \<Gamma> n)
    hence "\<Lambda> \<turnstile> \<succ>\<^bsub>n\<^esub> \<cdot> v \<leadsto> \<epsilon> \<cdot> InjV n v" by simp
    thus ?case by fastforce
  next case (tc_outj \<Gamma> n F)
    then obtain v' m where "v = InjV m v' \<and> var\<^sub>t_type \<Gamma> m = Some F" using canonical_mu by blast
    moreover hence "\<Lambda> \<turnstile> \<prec>\<^bsub>n\<^esub> \<cdot> v \<leadsto> \<epsilon> \<cdot> v'" by simp
    ultimately show ?case by fastforce
  next case (tc_cata \<Gamma> n F f t)
    hence "var\<^sub>t_bind \<Lambda> n = Some F" by (simp add: typecheck_environment_def)
    hence "\<Lambda> \<turnstile> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<cdot> v \<leadsto> (f \<cdot> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<bullet> F \<cdot> \<prec>\<^bsub>n\<^esub>) \<cdot> v" by simp
    thus ?case by fastforce
  next case (tc_ana \<Gamma> n F f t)
    hence "var\<^sub>t_bind \<Lambda> n = Some F" by (simp add: typecheck_environment_def)
    hence "\<Lambda> \<turnstile> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> \<cdot> v \<leadsto> (\<succ>\<^bsub>n\<^esub> \<cdot> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> \<bullet> F \<cdot> f) \<cdot> v" by simp
    thus ?case by fastforce
  next case (tc_var \<Gamma> x t\<^sub>1 t\<^sub>2)
    then obtain e where "var\<^sub>e_bind \<Lambda> x = Some e \<and> \<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2"
      using typecheck_environment_def typecheck_env\<^sub>e_def by fastforce
    hence "\<Lambda> \<turnstile> Var x \<cdot> v \<leadsto> e \<cdot> v" by simp
    thus ?case by fastforce
  qed simp_all

theorem progress [simp]: "\<Pi> \<TTurnstile> \<Gamma> \<rightarrow> t \<Longrightarrow> is_completed \<Pi> \<or> (\<exists>\<Pi>'. \<Pi> \<leadsto> \<Pi>')"
  proof (induction \<Pi> \<Gamma> t rule: typecheck_prog.induct)
  case (tcp_prog \<Delta> \<Gamma> e t\<^sub>1 t\<^sub>2 v)
    moreover have "empty_static \<tturnstile> empty_dynamic" by simp
    ultimately obtain \<Lambda> where L: "assemble_context empty_static \<Delta> \<Lambda> \<and> \<Gamma> \<tturnstile> \<Lambda>" by fastforce
    thus ?case
      proof (cases "e = \<epsilon>")
      case False
        with tcp_prog L obtain e' v' where "\<Lambda> \<turnstile> e \<cdot> v \<leadsto> e' \<cdot> v'" by fastforce
        with L have "Prog \<Delta> e v \<leadsto> Prog \<Delta> e' v'" by fastforce
        thus ?thesis by fastforce
      qed simp_all
  qed

(* preservation *)

lemma [simp]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> e \<bullet> F : t\<^sub>1 \<star> F \<rightarrow> t\<^sub>2 \<star> F"
  by (induction e F rule: apply_functor_expr.induct) simp_all

theorem expr_preservation [simp]: "\<Lambda> \<turnstile> e \<cdot> v \<leadsto> e' \<cdot> v' \<Longrightarrow> \<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> v : t\<^sub>1 \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda> \<Longrightarrow> \<exists>t\<^sub>3. (\<Gamma> \<turnstile> e' : t\<^sub>3 \<rightarrow> t\<^sub>2) \<and> (\<Gamma> \<turnstile> v' : t\<^sub>3)"
  proof (induction \<Lambda> e v e' v' arbitrary: t\<^sub>1 t\<^sub>2 rule: evaluate.induct)
  case (ev_con \<Lambda> v\<^sub>1 v\<^sub>2)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_comp1 \<Lambda> g v g' v' f)
    moreover then obtain t\<^sub>3 where "(\<Gamma> \<turnstile> f : t\<^sub>3 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> g : t\<^sub>1 \<rightarrow> t\<^sub>3" by fastforce
    ultimately obtain t\<^sub>4 where "(\<Gamma> \<turnstile> f \<cdot> g' : t\<^sub>4 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v' : t\<^sub>4" by fastforce
    thus ?case by fastforce
  next case (ev_fst \<Lambda> v\<^sub>1 v\<^sub>2)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_snd \<Lambda> v\<^sub>1 v\<^sub>2)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_pair1 \<Lambda> f\<^sub>1 v\<^sub>1 f\<^sub>1' v\<^sub>1' f\<^sub>2 v\<^sub>2)
    then obtain t\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 t\<^sub>2\<^sub>1 t\<^sub>2\<^sub>2 t\<^sub>1\<^sub>1' where T: "(\<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>1\<^sub>1) \<and> (\<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>1\<^sub>2) \<and>
      (\<Gamma> \<turnstile> f\<^sub>1 : t\<^sub>1\<^sub>1 \<rightarrow> t\<^sub>2\<^sub>1) \<and> (\<Gamma> \<turnstile> f\<^sub>2 : t\<^sub>1\<^sub>2 \<rightarrow> t\<^sub>2\<^sub>2) \<and> t\<^sub>1 = t\<^sub>1\<^sub>1 \<otimes> t\<^sub>1\<^sub>2 \<and> t\<^sub>2 = t\<^sub>2\<^sub>1 \<otimes> t\<^sub>2\<^sub>2 \<and>
        (\<Gamma> \<turnstile> f\<^sub>1' : t\<^sub>1\<^sub>1' \<rightarrow> t\<^sub>2\<^sub>1) \<and> \<Gamma> \<turnstile> v\<^sub>1' : t\<^sub>1\<^sub>1'" by fastforce
    hence "(\<Gamma> \<turnstile> f\<^sub>1' \<parallel> f\<^sub>2 : t\<^sub>1\<^sub>1' \<otimes> t\<^sub>1\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> PairV v\<^sub>1' v\<^sub>2 : t\<^sub>1\<^sub>1' \<otimes> t\<^sub>1\<^sub>2" by simp
    thus ?case by fastforce
  next case (ev_pair2 \<Lambda> f\<^sub>2 v\<^sub>2 f\<^sub>2' v\<^sub>2' v\<^sub>1)
    then obtain t\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 t\<^sub>2\<^sub>2 t\<^sub>1\<^sub>2' where T: "(\<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>1\<^sub>1) \<and> (\<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>1\<^sub>2) \<and>
      (\<Gamma> \<turnstile> f\<^sub>2 : t\<^sub>1\<^sub>2 \<rightarrow> t\<^sub>2\<^sub>2) \<and> t\<^sub>1 = t\<^sub>1\<^sub>1 \<otimes> t\<^sub>1\<^sub>2 \<and> t\<^sub>2 = t\<^sub>1\<^sub>1 \<otimes> t\<^sub>2\<^sub>2 \<and> (\<Gamma> \<turnstile> f\<^sub>2' : t\<^sub>1\<^sub>2' \<rightarrow> t\<^sub>2\<^sub>2) \<and>
        \<Gamma> \<turnstile> v\<^sub>2' : t\<^sub>1\<^sub>2'" by fastforce
    hence "(\<Gamma> \<turnstile> \<epsilon> \<parallel> f\<^sub>2' : t\<^sub>1\<^sub>1 \<otimes> t\<^sub>1\<^sub>2' \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> PairV v\<^sub>1 v\<^sub>2' : t\<^sub>1\<^sub>1 \<otimes> t\<^sub>1\<^sub>2'" by simp
    thus ?case by fastforce
  next case (ev_pair3 \<Lambda> v\<^sub>1 v\<^sub>2)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>1 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> PairV v\<^sub>1 v\<^sub>2 : t\<^sub>1" by fastforce
    thus ?case by fastforce
  next case (ev_tup \<Lambda> v)
    hence "t\<^sub>2 = t\<^sub>1 \<otimes> t\<^sub>1" by fastforce
    moreover from ev_tup have "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>1 \<otimes> t\<^sub>1 \<rightarrow> t\<^sub>1 \<otimes> t\<^sub>1) \<and> \<Gamma> \<turnstile> PairV v v : t\<^sub>1 \<otimes> t\<^sub>1"
      by simp
    ultimately show ?case by fastforce
  next case (ev_inl \<Lambda> v)
    moreover then obtain t\<^sub>3 where "t\<^sub>2 = t\<^sub>1 \<oplus> t\<^sub>3" by fastforce
    ultimately have "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>1 \<oplus> t\<^sub>3 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> InlV v : t\<^sub>1 \<oplus> t\<^sub>3" by simp
    thus ?case by fastforce
  next case (ev_inr \<Lambda> v)
    moreover then obtain t\<^sub>3 where "t\<^sub>2 = t\<^sub>3 \<oplus> t\<^sub>1" by fastforce
    ultimately have "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>3 \<oplus> t\<^sub>1 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> InrV v : t\<^sub>3 \<oplus> t\<^sub>1" by simp
    thus ?case by fastforce
  next case (ev_strl \<Lambda> v)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_strr \<Lambda> v)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_csl \<Lambda> f\<^sub>l f\<^sub>r v)
    then obtain t\<^sub>1\<^sub>l t\<^sub>1\<^sub>r t\<^sub>2\<^sub>l t\<^sub>2\<^sub>r where V: "(\<Gamma> \<turnstile> f\<^sub>l : t\<^sub>1\<^sub>l \<rightarrow> t\<^sub>2\<^sub>l) \<and> (\<Gamma> \<turnstile> f\<^sub>r : t\<^sub>1\<^sub>r \<rightarrow> t\<^sub>2\<^sub>r) \<and>
      (\<Gamma> \<turnstile> v : t\<^sub>1\<^sub>l) \<and> t\<^sub>1 = t\<^sub>1\<^sub>l \<oplus> t\<^sub>1\<^sub>r \<and> t\<^sub>2 = t\<^sub>2\<^sub>l \<oplus> t\<^sub>2\<^sub>r" by fastforce
    hence "\<Gamma> \<turnstile> \<iota>\<^sub>l \<cdot> f\<^sub>l : t\<^sub>1\<^sub>l \<rightarrow> t\<^sub>2\<^sub>l \<oplus> t\<^sub>2\<^sub>r" by (metis tc_inl tc_comp)
    with V show ?case by fastforce
  next case (ev_csr \<Lambda> f\<^sub>l f\<^sub>r v)
    then obtain t\<^sub>1\<^sub>l t\<^sub>1\<^sub>r t\<^sub>2\<^sub>l t\<^sub>2\<^sub>r where V: "(\<Gamma> \<turnstile> f\<^sub>l : t\<^sub>1\<^sub>l \<rightarrow> t\<^sub>2\<^sub>l) \<and> (\<Gamma> \<turnstile> f\<^sub>r : t\<^sub>1\<^sub>r \<rightarrow> t\<^sub>2\<^sub>r) \<and>
      (\<Gamma> \<turnstile> v : t\<^sub>1\<^sub>r) \<and> t\<^sub>1 = t\<^sub>1\<^sub>l \<oplus> t\<^sub>1\<^sub>r \<and> t\<^sub>2 = t\<^sub>2\<^sub>l \<oplus> t\<^sub>2\<^sub>r" by fastforce
    hence "\<Gamma> \<turnstile> \<iota>\<^sub>r \<cdot> f\<^sub>r : t\<^sub>1\<^sub>r \<rightarrow> t\<^sub>2\<^sub>l \<oplus> t\<^sub>2\<^sub>r" by (metis tc_inr tc_comp)
    with V show ?case by fastforce
  next case (ev_dstl \<Lambda> v\<^sub>1 v\<^sub>2)
    then obtain t\<^sub>3 t\<^sub>4 t\<^sub>5 where "(\<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>3) \<and> (\<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>5) \<and> t\<^sub>1 = (t\<^sub>3 \<oplus> t\<^sub>4) \<otimes> t\<^sub>5 \<and>
      t\<^sub>2 = t\<^sub>3 \<otimes> t\<^sub>5 \<oplus> t\<^sub>4 \<otimes> t\<^sub>5" by fastforce
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> InlV (PairV v\<^sub>1 v\<^sub>2) : t\<^sub>2" by simp
    thus ?case by fastforce
  next case (ev_dstr \<Lambda> v\<^sub>1 v\<^sub>2)
    then obtain t\<^sub>3 t\<^sub>4 t\<^sub>5 where "(\<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>4) \<and> (\<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>5) \<and> t\<^sub>1 = (t\<^sub>3 \<oplus> t\<^sub>4) \<otimes> t\<^sub>5 \<and>
      t\<^sub>2 = t\<^sub>3 \<otimes> t\<^sub>5 \<oplus> t\<^sub>4 \<otimes> t\<^sub>5" by fastforce
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> InrV (PairV v\<^sub>1 v\<^sub>2) : t\<^sub>2" by simp
    thus ?case by fastforce
  next case (ev_arr \<Lambda> g f e)
    then obtain t\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 t\<^sub>2\<^sub>1 t\<^sub>2\<^sub>2 where "(\<Gamma> \<turnstile> f : t\<^sub>2\<^sub>1 \<rightarrow> t\<^sub>1\<^sub>1) \<and> (\<Gamma> \<turnstile> g : t\<^sub>1\<^sub>2 \<rightarrow> t\<^sub>2\<^sub>2) \<and>
      (\<Gamma> \<turnstile> e : t\<^sub>1\<^sub>1 \<rightarrow> t\<^sub>1\<^sub>2) \<and> t\<^sub>1 = t\<^sub>1\<^sub>1 \<hookrightarrow> t\<^sub>1\<^sub>2 \<and> t\<^sub>2 = t\<^sub>2\<^sub>1 \<hookrightarrow> t\<^sub>2\<^sub>2" by fastforce
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2\<^sub>1 \<hookrightarrow> t\<^sub>2\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> FunV (g \<cdot> e \<cdot> f) : t\<^sub>2\<^sub>1 \<hookrightarrow> t\<^sub>2\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_inj \<Lambda> F v)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> InjV F v : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_outj \<Lambda> m F v)
    hence "(\<Gamma> \<turnstile> \<epsilon> : t\<^sub>2 \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v : t\<^sub>2" by fastforce
    thus ?case by fastforce
  next case (ev_cata \<Lambda> n F f v)
    hence V: "(\<Gamma> \<turnstile> f : t\<^sub>2 \<star> F \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v : \<mu> F" using typecheck_environment_def by fastforce
    moreover from ev_cata have "\<Gamma> \<turnstile> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<bullet> F : \<mu> F \<star> F \<rightarrow> t\<^sub>2 \<star> F"
      using typecheck_environment_def by fastforce
    moreover from ev_cata have "\<Gamma> \<turnstile> \<prec>\<^bsub>n\<^esub> : \<mu> F \<rightarrow> \<mu> F \<star> F" using typecheck_environment_def by simp
    ultimately have "\<Gamma> \<turnstile> f \<cdot> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<bullet> F \<cdot> \<prec>\<^bsub>n\<^esub> : \<mu> F \<rightarrow> t\<^sub>2" by (metis tc_comp)
    with V have "(\<Gamma> \<turnstile> f \<cdot> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<bullet> F \<cdot> \<prec>\<^bsub>n\<^esub> : \<mu> F \<rightarrow> t\<^sub>2) \<and> \<Gamma> \<turnstile> v : \<mu> F" by simp
    thus ?case by fastforce
  next case (ev_ana \<Lambda> n F f v)
    moreover hence V: "(\<Gamma> \<turnstile> f : t\<^sub>1 \<rightarrow> t\<^sub>1 \<star> F) \<and> (\<Gamma> \<turnstile> v : t\<^sub>1) \<and> t\<^sub>2 = \<mu> F"
      using typecheck_environment_def by fastforce
    ultimately have "\<Gamma> \<turnstile> \<succ>\<^bsub>n\<^esub> : t\<^sub>2 \<star> F \<rightarrow> t\<^sub>2" using typecheck_environment_def by simp
    moreover from ev_ana have "\<Gamma> \<turnstile> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> \<bullet> F : t\<^sub>1 \<star> F \<rightarrow> t\<^sub>2 \<star> F" by simp
    moreover from V have "\<Gamma> \<turnstile> f : t\<^sub>1 \<rightarrow> t\<^sub>1 \<star> F" by simp
    ultimately have "\<Gamma> \<turnstile> \<succ>\<^bsub>n\<^esub> \<cdot> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> \<bullet> F \<cdot> f : t\<^sub>1 \<rightarrow> t\<^sub>2" by simp
    with V show ?case by fastforce
  next case (ev_var \<Lambda> x e v)
    hence "var\<^sub>e_type \<Gamma> x = Some (t\<^sub>1, t\<^sub>2)" by fastforce
    with ev_var obtain e' where "var\<^sub>e_bind \<Lambda> x = Some e' \<and> \<Gamma> \<turnstile> e' : t\<^sub>1 \<rightarrow> t\<^sub>2"
      using typecheck_environment_def typecheck_env\<^sub>e_def by fastforce
    with ev_var show ?case by fastforce
  qed fastforce+

theorem preservation [simp]: "\<Pi> \<leadsto> \<Pi>' \<Longrightarrow> \<Pi> \<TTurnstile> \<Gamma> \<rightarrow> t \<Longrightarrow> \<Pi>' \<TTurnstile> \<Gamma> \<rightarrow> t"
  proof (induction \<Pi> \<Pi>' rule: evaluate_prog.induct)
  case (ev_prog \<Delta> \<Lambda> e v e' v')
    moreover then obtain t\<^sub>1 where T: "(empty_static \<Turnstile> \<Delta> :: \<Gamma>) \<and> (\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t) \<and> \<Gamma> \<turnstile> v : t\<^sub>1"
      by blast
    ultimately obtain t\<^sub>2 where "(\<Gamma> \<turnstile> e' : t\<^sub>2 \<rightarrow> t) \<and> (\<Gamma> \<turnstile> v' : t\<^sub>2)" by fastforce
    with T show ?case by fastforce
  qed

end


header {* Hoare-Triples *}
theory Hoare_Triple
imports Run Assertions
begin

text {* In this theory, we define Hoare-Triples, which are our basic tool
  for specifying properties of Imperative HOL programs.*}

subsection {* Definition *}

text {* Analyze the heap before and after executing a command, to add
  the allocated addresses to the covered address range. *}
definition new_addrs :: "heap \<Rightarrow> addr set \<Rightarrow> heap \<Rightarrow> addr set" where
  "new_addrs h as h' = as \<union> {a. lim h \<le> a \<and> a < lim h'}"

lemma new_addr_refl[simp]: "new_addrs h as h = as"
  unfolding new_addrs_def by auto

text {*
  Apart from correctness of the program wrt. the pre- and post condition,
  a Hoare-triple also encodes some well-formedness conditions of the command:
  The command must not change addresses outside the address range of the
  precondition, and it must not decrease the heap limit.

  Note that we do not require that the command only reads from heap locations
  inside the precondition's address range, as this condition would be quite
  complicated to express with the heap model of Imperative/HOL, and is not
  necessary in our formalization of partial heaps, that always contain the
  information for all addresses.
*}
definition hoare_triple
  :: "assn \<Rightarrow> 'a Heap \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("<_>/ _/ <_>")
  where
  "<P> c <Q> \<equiv> \<forall>h as \<sigma> r. (h,as)\<Turnstile>P \<and> run c (Some h) \<sigma> r
  \<longrightarrow> (let h'=the_state \<sigma>; as'=new_addrs h as h' in
    \<not>is_exn \<sigma> \<and> (h',as')\<Turnstile>Q r \<and> relH ({a . a<lim h \<and> a\<notin>as}) h h'
    \<and> lim h \<le> lim h')"

lemma hoare_tripleD:
  fixes h h' as as' \<sigma> r
  assumes "<P> c <Q>"
  assumes "(h,as)\<Turnstile>P"
  assumes "run c (Some h) \<sigma> r"
  defines "h'\<equiv>the_state \<sigma>" and "as'\<equiv>new_addrs h as h'"
  shows "\<not>is_exn \<sigma>"
  and "(h',as')\<Turnstile>Q r"
  and "relH ({a . a<lim h \<and> a\<notin>as}) h h'"
  and "lim h \<le> lim h'"
  using assms
  unfolding hoare_triple_def h'_def as'_def
  by (auto simp: Let_def)

text {* For garbage-collected languages, specifications usually allow for some
  arbitrary heap parts in the postcondition. The following abbreviation defines
  a handy shortcut notation for such specifications. *}
abbreviation hoare_triple'
  :: "assn \<Rightarrow> 'r Heap \<Rightarrow> ('r \<Rightarrow> assn) \<Rightarrow> bool" ("<_> _ <_>\<^sub>t")
  where "<P> c <Q>\<^sub>t \<equiv> <P> c <\<lambda>r. Q r * true>"

subsection {* Rules *}
text {*
  In this section, we provide a set of rules to prove Hoare-Triples correct.
*}
subsubsection {* Basic Rules *}

lemma frame_rule:
  assumes A: "<P> c <Q>"
  shows "<P*R> c <\<lambda>x. Q x * R>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI)
  apply (elim conjE)
  apply (intro conjI)
proof -
  fix h as
  assume "(h,as) \<Turnstile> P * R"
  then obtain as1 as2 where [simp]: "as=as1\<union>as2" and DJ: "as1\<inter>as2={}"
    and M1: "(h,as1)\<Turnstile>P" and M2: "(h,as2)\<Turnstile>R"
    unfolding times_assn_def
    by (auto simp: Abs_assn_inverse)

  fix \<sigma> r
  assume RUN: "run c (Some h) \<sigma> r"
  from hoare_tripleD(1)[OF A M1 RUN] show "\<not> is_exn \<sigma>" .
  from hoare_tripleD(4)[OF A M1 RUN]
  show "lim h \<le> lim (the_state \<sigma>)" .

  from hoare_tripleD(3)[OF A M1 RUN] have
    RH1: "relH {a. a < lim h \<and> a \<notin> as1} h (the_state \<sigma>)" .
  moreover have "{a. a < lim h \<and> a \<notin> as} \<subseteq> {a. a < lim h \<and> a \<notin> as1}"
    by auto
  ultimately show "relH {a. a < lim h \<and> a \<notin> as} h (the_state \<sigma>)"
    by (blast intro: relH_subset)

  from hoare_tripleD(2)[OF A M1 RUN] have
    "(the_state \<sigma>, new_addrs h as1 (the_state \<sigma>)) \<Turnstile> Q r" .
  moreover have DJN: "new_addrs h as1 (the_state \<sigma>) \<inter> as2 = {}"
    using DJ models_in_range[OF M2]
    by (auto simp: in_range.simps new_addrs_def)
  moreover have "as2 \<subseteq> {a. a < lim h \<and> a \<notin> as1}"
    using DJ models_in_range[OF M2]
    by (auto simp: in_range.simps)
  hence "relH as2 h (the_state \<sigma>)" using RH1
    by (blast intro: relH_subset)
  with M2 have "(the_state \<sigma>, as2)\<Turnstile>R"
    by (metis mem_Collect_eq Rep_assn
      proper_iff relH_in_rangeI(2))
  moreover have "new_addrs h as (the_state \<sigma>)
    = new_addrs h as1 (the_state \<sigma>) \<union> as2"
    by (auto simp: new_addrs_def)
  ultimately show
    "(the_state \<sigma>, new_addrs h as (the_state \<sigma>)) \<Turnstile> Q r * R"
    unfolding times_assn_def
    apply (simp add: Abs_assn_inverse)
    apply blast
    done
qed

lemma cons_rule:
  assumes CPRE: "P \<Longrightarrow>\<^sub>A P'"
  assumes CPOST: "\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x"
  assumes R: "<P'> c <Q>"
  shows "<P> c <Q'>"
  unfolding hoare_triple_def Let_def
  using hoare_tripleD[OF R entailsD[OF CPRE]] entailsD[OF CPOST]
  by blast

lemmas cons_pre_rule = cons_rule[OF _ ent_refl]
lemmas cons_post_rule = cons_rule[OF ent_refl, rotated]

lemma false_rule[simp, intro!]: "<false> c <Q>"
  unfolding hoare_triple_def by simp

lemma norm_pre_ex_rule:
  assumes A: "\<And>x. <P x> f <Q>"
  shows "<\<exists>\<^sub>Ax. P x> f <Q>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI, elim conjE mod_exE)
  using hoare_tripleD[OF A]
  by blast

lemma norm_pre_pure_iff[simp]:
  "<P*\<up>b> f <Q> \<longleftrightarrow> (b \<longrightarrow> <P> f <Q>)"
  unfolding hoare_triple_def Let_def
  by auto

lemma norm_pre_pure_iff_sng[simp]:
  "<\<up>b> f <Q> \<longleftrightarrow> (b \<longrightarrow> <emp> f <Q>)"
  using norm_pre_pure_iff[where P=emp]
  by simp

lemma norm_pre_pure_rule1:
  "\<lbrakk>b \<Longrightarrow> <P> f <Q>\<rbrakk> \<Longrightarrow> <P*\<up>b> f <Q>" by simp

lemma norm_pre_pure_rule2:
  "\<lbrakk> b \<Longrightarrow> <emp> f <Q> \<rbrakk> \<Longrightarrow> <\<up>b> f <Q>" by simp

lemmas norm_pre_pure_rule = norm_pre_pure_rule1 norm_pre_pure_rule2

subsubsection {* Rules for Atomic Commands*}
lemma ref_rule:
  "<emp> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>"
  unfolding one_assn_def sngr_assn_def hoare_triple_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (intro allI impI)
  apply (elim conjE run_elims)
  apply simp
  apply (auto
    simp: new_addrs_def Ref.alloc_def Let_def
    Ref.set_def Ref.get_def relH_def in_range.simps)
  done

lemma lookup_rule:
  "<p \<mapsto>\<^sub>r x> !p <\<lambda>r. p \<mapsto>\<^sub>r x * \<up>(r = x)>"
  unfolding hoare_triple_def sngr_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto elim: run_elims simp add: relH_refl in_range.simps new_addrs_def)
  done

lemma update_rule:
  "<p \<mapsto>\<^sub>r y> p := x <\<lambda>r. p \<mapsto>\<^sub>r x>"
  unfolding hoare_triple_def sngr_assn_def
  apply (auto elim!: run_update
    simp: Let_def Abs_assn_inverse new_addrs_def in_range.simps
    intro!: relH_set_ref)
  done

lemma update_wp_rule:
  "<r \<mapsto>\<^sub>r y * ((r \<mapsto>\<^sub>r x) -* (Q ()))> r := x <Q>"
  apply (rule cons_post_rule)
  apply (rule frame_rule[OF update_rule[where p=r and x=x],
    where R="((r \<mapsto>\<^sub>r x) -* (Q ()))"])
  apply (rule ent_trans)
  apply (rule ent_mp)
  by simp

lemma new_rule:
  "<emp> Array.new n x <\<lambda>r. r \<mapsto>\<^sub>a replicate n x>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps
  )
  done

lemma of_list_rule: "<emp> Array.of_list xs <\<lambda>r. r \<mapsto>\<^sub>a xs>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps
  )
  done

lemma length_rule:
  "<a \<mapsto>\<^sub>a xs> Array.len a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = length xs)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def
  )
  done

text {* Note that the Boolean expression is placed at meta level and not
  inside the precondition. This makes frame inference simpler.*}
lemma nth_rule:
  "\<lbrakk>i < length xs\<rbrakk> \<Longrightarrow> <a \<mapsto>\<^sub>a xs> Array.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs ! i)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def
  )
  done

lemma upd_rule:
  "\<lbrakk>i < length xs\<rbrakk> \<Longrightarrow>
  <a \<mapsto>\<^sub>a xs>
  Array.upd i x a
  <\<lambda>r. (a \<mapsto>\<^sub>a (list_update xs i x)) * \<up>(r = a)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def Array.update_def comp_def
  )
  done

lemma freeze_rule:
  "<a \<mapsto>\<^sub>a xs> Array.freeze a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def Array.update_def
  )
  done

lemma return_wp_rule:
  "<Q x> return x <Q>"
  unfolding hoare_triple_def Let_def
  apply (auto elim!: run_elims)
  apply (rule relH_refl)
  apply (simp add: in_range.simps)
  done

lemma return_sp_rule:
  "<P> return x <\<lambda>r. P * \<up>(r = x)>"
  unfolding hoare_triple_def Let_def
  apply (simp add: Abs_assn_inverse)
  apply (auto elim!: run_elims intro!: relH_refl intro: models_in_range)
  apply (simp add: in_range.simps)
  done

lemma raise_iff:
  "<P> raise s <Q> \<longleftrightarrow> P = false"
  unfolding hoare_triple_def Let_def
  apply (rule iffI)
  apply (unfold bot_assn_def) []
  apply rule
  apply (auto simp add: run_raise_iff) []

  apply (auto simp add: run_raise_iff) []
  done

lemma raise_rule: "<false> raise s <Q>"
  by (simp add: raise_iff)

subsubsection {* Rules for Composed Commands *}
lemma bind_rule:
  assumes T1: "<P> f <R>"
  assumes T2: "\<And>x. <R x> g x <Q>"
  shows "<P> bind f g <Q>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI)
  apply (elim conjE run_elims)
  apply (intro conjI)
proof -
  fix h as \<sigma>'' r'' \<sigma>' r'
  assume M: "(h,as) \<Turnstile> P"
    and R1: "run f (Some h) \<sigma>' r'"
    and R2: "run (g r') \<sigma>' \<sigma>'' r''"

  from hoare_tripleD[OF T1 M R1] have NO_E: "\<not> is_exn \<sigma>'"
    and M': "(the_state \<sigma>', new_addrs h as (the_state \<sigma>')) \<Turnstile> R r'"
    and RH': "relH {a. a < lim h \<and> a \<notin> as} h (the_state \<sigma>')"
    and LIM: "lim h \<le> lim (the_state \<sigma>')"
    by auto

  from NO_E have [simp]: "Some (the_state \<sigma>') = \<sigma>'" by (cases \<sigma>') auto

  from hoare_tripleD[OF T2 M', simplified, OF R2] have
    NO_E'': "\<not> is_exn \<sigma>''"
    and M'': "(the_state \<sigma>'',
      new_addrs (the_state \<sigma>')
        (new_addrs h as (the_state \<sigma>')) (the_state \<sigma>''))
      \<Turnstile> Q r''"
    and RH'':
    "relH
      {a. a < lim (the_state \<sigma>')
        \<and> a \<notin> new_addrs h as (the_state \<sigma>')
      }
      (the_state \<sigma>') (the_state \<sigma>'')"
    and LIM': "lim (the_state \<sigma>') \<le> lim (the_state \<sigma>'')" by auto

  show "\<not> is_exn \<sigma>''" by fact

  have
    "new_addrs
      (the_state \<sigma>')
      (new_addrs h as (the_state \<sigma>'))
      (the_state \<sigma>'')
    = new_addrs h as (the_state \<sigma>'')"
    using LIM LIM'
    by (auto simp add: new_addrs_def)
  with M'' show
    "(the_state \<sigma>'', new_addrs h as (the_state \<sigma>'')) \<Turnstile> Q r''"
    by simp

  note RH'
  also have "relH {a. a < lim h \<and> a \<notin> as} (the_state \<sigma>') (the_state \<sigma>'')"
    apply (rule relH_subset[OF RH''])
    using LIM LIM'
    by (auto simp: new_addrs_def)
  finally show "relH {a. a < lim h \<and> a \<notin> as} h (the_state \<sigma>'')" .

  note LIM
  also note LIM'
  finally show "lim h \<le> lim (the_state \<sigma>'')" .
qed

lemma if_rule:
  assumes  "b \<Longrightarrow> <P> f <Q>"
  assumes  "\<not>b \<Longrightarrow> <P> g <Q>"
  shows "<P> if b then f else g <Q>"
  using assms by auto

lemma if_rule_split:
  assumes  B: "b \<Longrightarrow> <P> f <Q1>"
  assumes  NB: "\<not>b \<Longrightarrow> <P> g <Q2>"
  assumes M: "\<And>x. (Q1 x * \<up>b) \<or>\<^sub>A (Q2 x * \<up>(\<not>b)) \<Longrightarrow>\<^sub>A Q x"
  shows "<P> if b then f else g <Q>"
  apply (cases b)
  apply simp_all
  apply (rule cons_post_rule)
  apply (erule B)
  apply (rule ent_trans[OF _ ent_disjI1[OF M]])
  apply simp

  apply (rule cons_post_rule)
  apply (erule NB)
  apply (rule ent_trans[OF _ ent_disjI2[OF M]])
  apply simp
  done

lemma split_rule:
  assumes P: "<P> c <R>"
  assumes Q: "<Q> c <R>"
  shows "<P \<or>\<^sub>A Q> c <R>"
  unfolding hoare_triple_def
  apply (intro allI impI)
  apply (elim conjE)
  apply simp
  apply (erule disjE)
  using hoare_tripleD[OF P] apply simp
  using hoare_tripleD[OF Q] apply simp
  done

lemmas decon_split_if = if_rule_split split_rule
  -- "Use with care: Complete splitting of if statements"

lemma case_prod_rule:
  "(\<And>a b. x = (a, b) \<Longrightarrow> <P> f a b <Q>) \<Longrightarrow> <P> case x of (a, b) \<Rightarrow> f a b <Q>"
  by (auto split: prod.split)

lemma case_list_rule:
  "\<lbrakk> l=[] \<Longrightarrow> <P> fn <Q>; \<And>x xs. l=x#xs \<Longrightarrow> <P> fc x xs <Q> \<rbrakk> \<Longrightarrow>
  <P> case_list fn fc l <Q>"
  by (auto split: list.split)

lemma case_option_rule:
  "\<lbrakk> v=None \<Longrightarrow> <P> fn <Q>; \<And>x. v=Some x \<Longrightarrow> <P> fs x <Q> \<rbrakk>
  \<Longrightarrow> <P> case_option fn fs v <Q>"
  by (auto split: option.split)

lemma case_sum_rule:
  "\<lbrakk> \<And>x. v=Inl x \<Longrightarrow> <P> fl x <Q>;
     \<And>x. v=Inr x \<Longrightarrow> <P> fr x <Q> \<rbrakk>
  \<Longrightarrow> <P> case_sum fl fr v <Q>"
  by (auto split: sum.split)

lemma let_rule: "(\<And>x. x = t \<Longrightarrow> <P> f x <Q>) \<Longrightarrow> <P> Let t f <Q>"
  by (auto)

end


(*  Title:      ZF/Constructible/WFrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section{*Relativized Well-Founded Recursion*}

theory WFrec imports Wellorderings begin

subsection{*General Lemmas*}

(*Many of these might be useful in WF.thy*)

lemma apply_recfun2:
    "[| is_recfun(r,a,H,f); <x,i>:f |] ==> i = H(x, restrict(f,r-``{x}))"
apply (frule apply_recfun)
 apply (blast dest: is_recfun_type fun_is_rel)
apply (simp add: function_apply_equality [OF _ is_recfun_imp_function])
done

text{*Expresses @{text is_recfun} as a recursion equation*}
lemma is_recfun_iff_equation:
     "is_recfun(r,a,H,f) \<longleftrightarrow>
           f \<in> r -`` {a} \<rightarrow> range(f) &
           (\<forall>x \<in> r-``{a}. f`x = H(x, restrict(f, r-``{x})))"
apply (rule iffI)
 apply (simp add: is_recfun_type apply_recfun Ball_def vimage_singleton_iff,
        clarify)
apply (simp add: is_recfun_def)
apply (rule fun_extension)
  apply assumption
 apply (fast intro: lam_type, simp)
done

lemma is_recfun_imp_in_r: "[|is_recfun(r,a,H,f); \<langle>x,i\<rangle> \<in> f|] ==> \<langle>x, a\<rangle> \<in> r"
by (blast dest: is_recfun_type fun_is_rel)

lemma trans_Int_eq:
      "[| trans(r); <y,x> \<in> r |] ==> r -`` {x} \<inter> r -`` {y} = r -`` {y}"
by (blast intro: transD)

lemma is_recfun_restrict_idem:
     "is_recfun(r,a,H,f) ==> restrict(f, r -`` {a}) = f"
apply (drule is_recfun_type)
apply (auto simp add: Pi_iff subset_Sigma_imp_relation restrict_idem)
done

lemma is_recfun_cong_lemma:
  "[| is_recfun(r,a,H,f); r = r'; a = a'; f = f';
      !!x g. [| <x,a'> \<in> r'; relation(g); domain(g) \<subseteq> r' -``{x} |]
             ==> H(x,g) = H'(x,g) |]
   ==> is_recfun(r',a',H',f')"
apply (simp add: is_recfun_def)
apply (erule trans)
apply (rule lam_cong)
apply (simp_all add: vimage_singleton_iff Int_lower2)
done

text{*For @{text is_recfun} we need only pay attention to functions
      whose domains are initial segments of @{term r}.*}
lemma is_recfun_cong:
  "[| r = r'; a = a'; f = f';
      !!x g. [| <x,a'> \<in> r'; relation(g); domain(g) \<subseteq> r' -``{x} |]
             ==> H(x,g) = H'(x,g) |]
   ==> is_recfun(r,a,H,f) \<longleftrightarrow> is_recfun(r',a',H',f')"
apply (rule iffI)
txt{*Messy: fast and blast don't work for some reason*}
apply (erule is_recfun_cong_lemma, auto)
apply (erule is_recfun_cong_lemma)
apply (blast intro: sym)+
done

subsection{*Reworking of the Recursion Theory Within @{term M}*}

lemma (in M_basic) is_recfun_separation':
    "[| f \<in> r -`` {a} \<rightarrow> range(f); g \<in> r -`` {b} \<rightarrow> range(g);
        M(r); M(f); M(g); M(a); M(b) |]
     ==> separation(M, \<lambda>x. \<not> (\<langle>x, a\<rangle> \<in> r \<longrightarrow> \<langle>x, b\<rangle> \<in> r \<longrightarrow> f ` x = g ` x))"
apply (insert is_recfun_separation [of r f g a b])
apply (simp add: vimage_singleton_iff)
done

text{*Stated using @{term "trans(r)"} rather than
      @{term "transitive_rel(M,A,r)"} because the latter rewrites to
      the former anyway, by @{text transitive_rel_abs}.
      As always, theorems should be expressed in simplified form.
      The last three M-premises are redundant because of @{term "M(r)"},
      but without them we'd have to undertake
      more work to set up the induction formula.*}
lemma (in M_basic) is_recfun_equal [rule_format]:
    "[|is_recfun(r,a,H,f);  is_recfun(r,b,H,g);
       wellfounded(M,r);  trans(r);
       M(f); M(g); M(r); M(x); M(a); M(b) |]
     ==> <x,a> \<in> r \<longrightarrow> <x,b> \<in> r \<longrightarrow> f`x=g`x"
apply (frule_tac f=f in is_recfun_type)
apply (frule_tac f=g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wellfounded_induct, assumption+)
txt{*Separation to justify the induction*}
 apply (blast intro: is_recfun_separation')
txt{*Now the inductive argument itself*}
apply clarify
apply (erule ssubst)+
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rename_tac x1)
apply (rule_tac t="%z. H(x1,z)" in subst_context)
apply (subgoal_tac "\<forall>y \<in> r-``{x1}. \<forall>z. <y,z>\<in>f \<longleftrightarrow> <y,z>\<in>g")
 apply (blast intro: transD)
apply (simp add: apply_iff)
apply (blast intro: transD sym)
done

lemma (in M_basic) is_recfun_cut:
    "[|is_recfun(r,a,H,f);  is_recfun(r,b,H,g);
       wellfounded(M,r); trans(r);
       M(f); M(g); M(r); <b,a> \<in> r |]
      ==> restrict(f, r-``{b}) = g"
apply (frule_tac f=f in is_recfun_type)
apply (rule fun_extension)
apply (blast intro: transD restrict_type2)
apply (erule is_recfun_type, simp)
apply (blast intro: is_recfun_equal transD dest: transM)
done

lemma (in M_basic) is_recfun_functional:
     "[|is_recfun(r,a,H,f);  is_recfun(r,a,H,g);
       wellfounded(M,r); trans(r); M(f); M(g); M(r) |] ==> f=g"
apply (rule fun_extension)
apply (erule is_recfun_type)+
apply (blast intro!: is_recfun_equal dest: transM)
done

text{*Tells us that @{text is_recfun} can (in principle) be relativized.*}
lemma (in M_basic) is_recfun_relativize:
  "[| M(r); M(f); \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
   ==> is_recfun(r,a,H,f) \<longleftrightarrow>
       (\<forall>z[M]. z \<in> f \<longleftrightarrow>
        (\<exists>x[M]. <x,a> \<in> r & z = <x, H(x, restrict(f, r-``{x}))>))"
apply (simp add: is_recfun_def lam_def)
apply (safe intro!: equalityI)
   apply (drule equalityD1 [THEN subsetD], assumption)
   apply (blast dest: pair_components_in_M)
  apply (blast elim!: equalityE dest: pair_components_in_M)
 apply (frule transM, assumption)
 apply simp
 apply blast
apply (subgoal_tac "is_function(M,f)")
 txt{*We use @{term "is_function"} rather than @{term "function"} because
      the subgoal's easier to prove with relativized quantifiers!*}
 prefer 2 apply (simp add: is_function_def)
apply (frule pair_components_in_M, assumption)
apply (simp add: is_recfun_imp_function function_restrictI)
done

lemma (in M_basic) is_recfun_restrict:
     "[| wellfounded(M,r); trans(r); is_recfun(r,x,H,f); \<langle>y,x\<rangle> \<in> r;
       M(r); M(f);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
       ==> is_recfun(r, y, H, restrict(f, r -`` {y}))"
apply (frule pair_components_in_M, assumption, clarify)
apply (simp (no_asm_simp) add: is_recfun_relativize restrict_iff
           trans_Int_eq)
apply safe
  apply (simp_all add: vimage_singleton_iff is_recfun_type [THEN apply_iff])
  apply (frule_tac x=xa in pair_components_in_M, assumption)
  apply (frule_tac x=xa in apply_recfun, blast intro: transD)
  apply (simp add: is_recfun_type [THEN apply_iff]
                   is_recfun_imp_function function_restrictI)
apply (blast intro: apply_recfun dest: transD)
done

lemma (in M_basic) restrict_Y_lemma:
   "[| wellfounded(M,r); trans(r); M(r);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));  M(Y);
       \<forall>b[M].
           b \<in> Y \<longleftrightarrow>
           (\<exists>x[M]. <x,a1> \<in> r &
            (\<exists>y[M]. b = \<langle>x,y\<rangle> & (\<exists>g[M]. is_recfun(r,x,H,g) \<and> y = H(x,g))));
          \<langle>x,a1\<rangle> \<in> r; is_recfun(r,x,H,f); M(f) |]
       ==> restrict(Y, r -`` {x}) = f"
apply (subgoal_tac "\<forall>y \<in> r-``{x}. \<forall>z. <y,z>:Y \<longleftrightarrow> <y,z>:f")
 apply (simp (no_asm_simp) add: restrict_def)
 apply (thin_tac "rall(M,?P)")+  --{*essential for efficiency*}
 apply (frule is_recfun_type [THEN fun_is_rel], blast)
apply (frule pair_components_in_M, assumption, clarify)
apply (rule iffI)
 apply (frule_tac y="<y,z>" in transM, assumption)
 apply (clarsimp simp add: vimage_singleton_iff is_recfun_type [THEN apply_iff]
                           apply_recfun is_recfun_cut)
txt{*Opposite inclusion: something in f, show in Y*}
apply (frule_tac y="<y,z>" in transM, assumption)
apply (simp add: vimage_singleton_iff)
apply (rule conjI)
 apply (blast dest: transD)
apply (rule_tac x="restrict(f, r -`` {y})" in rexI)
apply (simp_all add: is_recfun_restrict
                     apply_recfun is_recfun_type [THEN apply_iff])
done

text{*For typical applications of Replacement for recursive definitions*}
lemma (in M_basic) univalent_is_recfun:
     "[|wellfounded(M,r); trans(r); M(r)|]
      ==> univalent (M, A, \<lambda>x p.
              \<exists>y[M]. p = \<langle>x,y\<rangle> & (\<exists>f[M]. is_recfun(r,x,H,f) & y = H(x,f)))"
apply (simp add: univalent_def)
apply (blast dest: is_recfun_functional)
done

text{*Proof of the inductive step for @{text exists_is_recfun}, since
      we must prove two versions.*}
lemma (in M_basic) exists_is_recfun_indstep:
    "[|\<forall>y. \<langle>y, a1\<rangle> \<in> r \<longrightarrow> (\<exists>f[M]. is_recfun(r, y, H, f));
       wellfounded(M,r); trans(r); M(r); M(a1);
       strong_replacement(M, \<lambda>x z.
              \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) & is_recfun(r,x,H,g) & y = H(x,g));
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
      ==> \<exists>f[M]. is_recfun(r,a1,H,f)"
apply (drule_tac A="r-``{a1}" in strong_replacementD)
  apply blast
 txt{*Discharge the "univalent" obligation of Replacement*}
 apply (simp add: univalent_is_recfun)
txt{*Show that the constructed object satisfies @{text is_recfun}*}
apply clarify
apply (rule_tac x=Y in rexI)
txt{*Unfold only the top-level occurrence of @{term is_recfun}*}
apply (simp (no_asm_simp) add: is_recfun_relativize [of concl: _ a1])
txt{*The big iff-formula defining @{term Y} is now redundant*}
apply safe
 apply (simp add: vimage_singleton_iff restrict_Y_lemma [of r H _ a1])
txt{*one more case*}
apply (simp (no_asm_simp) add: Bex_def vimage_singleton_iff)
apply (drule_tac x1=x in spec [THEN mp], assumption, clarify)
apply (rename_tac f)
apply (rule_tac x=f in rexI)
apply (simp_all add: restrict_Y_lemma [of r H])
txt{*FIXME: should not be needed!*}
apply (subst restrict_Y_lemma [of r H])
apply (simp add: vimage_singleton_iff)+
apply blast+
done

text{*Relativized version, when we have the (currently weaker) premise
      @{term "wellfounded(M,r)"}*}
lemma (in M_basic) wellfounded_exists_is_recfun:
    "[|wellfounded(M,r);  trans(r);
       separation(M, \<lambda>x. ~ (\<exists>f[M]. is_recfun(r, x, H, f)));
       strong_replacement(M, \<lambda>x z.
          \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) & is_recfun(r,x,H,g) & y = H(x,g));
       M(r);  M(a);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> \<exists>f[M]. is_recfun(r,a,H,f)"
apply (rule wellfounded_induct, assumption+, clarify)
apply (rule exists_is_recfun_indstep, assumption+)
done

lemma (in M_basic) wf_exists_is_recfun [rule_format]:
    "[|wf(r);  trans(r);  M(r);
       strong_replacement(M, \<lambda>x z.
         \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) & is_recfun(r,x,H,g) & y = H(x,g));
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(a) \<longrightarrow> (\<exists>f[M]. is_recfun(r,a,H,f))"
apply (rule wf_induct, assumption+)
apply (frule wf_imp_relativized)
apply (intro impI)
apply (rule exists_is_recfun_indstep)
      apply (blast dest: transM del: rev_rallE, assumption+)
done

subsection{*Relativization of the ZF Predicate @{term is_recfun}*}

definition
  M_is_recfun :: "[i=>o, [i,i,i]=>o, i, i, i] => o" where
   "M_is_recfun(M,MH,r,a,f) ==
     \<forall>z[M]. z \<in> f \<longleftrightarrow>
            (\<exists>x[M]. \<exists>y[M]. \<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M]. \<exists>f_r_sx[M].
               pair(M,x,y,z) & pair(M,x,a,xa) & upair(M,x,x,sx) &
               pre_image(M,r,sx,r_sx) & restriction(M,f,r_sx,f_r_sx) &
               xa \<in> r & MH(x, f_r_sx, y))"

definition
  is_wfrec :: "[i=>o, [i,i,i]=>o, i, i, i] => o" where
   "is_wfrec(M,MH,r,a,z) ==
      \<exists>f[M]. M_is_recfun(M,MH,r,a,f) & MH(a,f,z)"

definition
  wfrec_replacement :: "[i=>o, [i,i,i]=>o, i] => o" where
   "wfrec_replacement(M,MH,r) ==
        strong_replacement(M,
             \<lambda>x z. \<exists>y[M]. pair(M,x,y,z) & is_wfrec(M,MH,r,x,y))"

lemma (in M_basic) is_recfun_abs:
     "[| \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));  M(r); M(a); M(f);
         relation2(M,MH,H) |]
      ==> M_is_recfun(M,MH,r,a,f) \<longleftrightarrow> is_recfun(r,a,H,f)"
apply (simp add: M_is_recfun_def relation2_def is_recfun_relativize)
apply (rule rall_cong)
apply (blast dest: transM)
done

lemma M_is_recfun_cong [cong]:
     "[| r = r'; a = a'; f = f';
       !!x g y. [| M(x); M(g); M(y) |] ==> MH(x,g,y) \<longleftrightarrow> MH'(x,g,y) |]
      ==> M_is_recfun(M,MH,r,a,f) \<longleftrightarrow> M_is_recfun(M,MH',r',a',f')"
by (simp add: M_is_recfun_def)

lemma (in M_basic) is_wfrec_abs:
     "[| \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
         relation2(M,MH,H);  M(r); M(a); M(z) |]
      ==> is_wfrec(M,MH,r,a,z) \<longleftrightarrow>
          (\<exists>g[M]. is_recfun(r,a,H,g) & z = H(a,g))"
by (simp add: is_wfrec_def relation2_def is_recfun_abs)

text{*Relating @{term wfrec_replacement} to native constructs*}
lemma (in M_basic) wfrec_replacement':
  "[|wfrec_replacement(M,MH,r);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
     relation2(M,MH,H);  M(r)|]
   ==> strong_replacement(M, \<lambda>x z. \<exists>y[M].
                pair(M,x,y,z) & (\<exists>g[M]. is_recfun(r,x,H,g) & y = H(x,g)))"
by (simp add: wfrec_replacement_def is_wfrec_abs)

lemma wfrec_replacement_cong [cong]:
     "[| !!x y z. [| M(x); M(y); M(z) |] ==> MH(x,y,z) \<longleftrightarrow> MH'(x,y,z);
         r=r' |]
      ==> wfrec_replacement(M, %x y. MH(x,y), r) \<longleftrightarrow>
          wfrec_replacement(M, %x y. MH'(x,y), r')"
by (simp add: is_wfrec_def wfrec_replacement_def)

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory WHATWHERE_Security
imports "../Strong_Security/Types"
begin

locale WHATWHERE =
fixes SR :: "('exp, 'id, 'val, 'com) TLSteps"
and E :: "('exp, 'id, 'val) Evalfunction"
and pp :: "'com \<Rightarrow> nat"
and DA :: "('id, 'd::order) DomainAssignment"
and lH :: "('d::order, 'exp) lHatches"

begin

-- "define when two states are indistinguishable for an observer on domain d"
definition d_equal :: "'d::order \<Rightarrow> ('id, 'val) State
  \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"d_equal d m m' \<equiv> \<forall>x. ((DA x) \<le> d \<longrightarrow> (m x) = (m' x))"

abbreviation d_equal' :: "('id, 'val) State
  \<Rightarrow> 'd::order \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ =\<^bsub>_\<^esub> _)" )
where
"m =\<^bsub>d\<^esub> m' \<equiv> d_equal d m m'"

-- "transitivity of d-equality"
lemma d_equal_trans:
"\<lbrakk> m =\<^bsub>d\<^esub> m'; m' =\<^bsub>d\<^esub> m'' \<rbrakk> \<Longrightarrow> m =\<^bsub>d\<^esub> m''"
by (simp add: d_equal_def)

abbreviation SRabbr :: "('exp, 'id, 'val, 'com) TLSteps_curry"
("(1\<langle>_,/_\<rangle>) \<rightarrow>\<lhd>_\<rhd>/ (1\<langle>_,/_\<rangle>)" [0,0,0,0,0] 81)
where
"\<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle> \<equiv> ((c,m),\<alpha>,(p,m')) \<in> SR"

--"function for obtaining the unique memory (state) after one step for a command and a memory (state)"
definition NextMem :: "'com \<Rightarrow> ('id, 'val) State \<Rightarrow> ('id, 'val) State"
( "\<lbrakk>_\<rbrakk>'(_')" )
where
"\<lbrakk>c\<rbrakk>(m) \<equiv> (THE m'. (\<exists>p \<alpha>. \<langle>c,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>))"

--"function getting all escape hatches for some location"
definition htchLoc :: "nat \<Rightarrow> ('d, 'exp) Hatches"
where
"htchLoc \<iota> \<equiv> {(d,e). (d,e,\<iota>) \<in> lH}"

--"function for getting all escape hatches for some set of locations"
definition htchLocSet :: "nat set \<Rightarrow> ('d, 'exp) Hatches"
where
"htchLocSet PP \<equiv> \<Union>{h. (\<exists>\<iota> \<in> PP. h = htchLoc \<iota>)}"

--"predicate for (d,H)-equality"
definition dH_equal :: "'d \<Rightarrow> ('d, 'exp) Hatches
  \<Rightarrow> ('id, 'val) State \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"dH_equal d H m m' \<equiv> (m =\<^bsub>d\<^esub> m' \<and>
  (\<forall>(d',e) \<in> H. (d' \<le> d \<longrightarrow> (E e m = E e m'))))"

abbreviation dH_equal' :: "('id, 'val) State \<Rightarrow> 'd \<Rightarrow> ('d, 'exp) Hatches
  \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ \<sim>\<^bsub>_,_\<^esub> _)" )
where
"m \<sim>\<^bsub>d,H\<^esub> m' \<equiv> dH_equal d H m m'"

--"predicate indicating that a command is not a d-declassification command"
definition NDC :: "'d \<Rightarrow> 'com \<Rightarrow> bool"
where
"NDC d c \<equiv> (\<forall>m m'. m =\<^bsub>d\<^esub> m' \<longrightarrow> \<lbrakk>c\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>c\<rbrakk>(m'))"

--"predicate indicating an 'immediate d-declassification command' for a set of escape hatches"
definition IDC :: "'d \<Rightarrow> 'com \<Rightarrow> ('d, 'exp) Hatches \<Rightarrow> bool"
where
"IDC d c H \<equiv> (\<exists>m m'. m =\<^bsub>d\<^esub> m' \<and>
  (\<not> \<lbrakk>c\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>c\<rbrakk>(m')))
  \<and> (\<forall>m m'. m \<sim>\<^bsub>d,H\<^esub> m' \<longrightarrow> \<lbrakk>c\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>c\<rbrakk>(m') )"

definition stepResultsinR :: "'com ProgramState \<Rightarrow> 'com ProgramState
  \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"stepResultsinR p p' R \<equiv> (p = None \<and> p' = None) \<or>
  (\<exists>c c'. (p = Some c \<and> p' = Some c' \<and> ([c],[c']) \<in> R))"

definition dhequality_alternative ::  "'d \<Rightarrow> nat set \<Rightarrow> nat
  \<Rightarrow> ('id, 'val) State \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"dhequality_alternative d PP \<iota> m m' \<equiv> m \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m' \<or>
            (\<not> (htchLoc \<iota>) \<subseteq> (htchLocSet PP))"

definition Strong_dlHPP_Bisimulation :: "'d \<Rightarrow> nat set
  \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"Strong_dlHPP_Bisimulation d PP R \<equiv>
  (sym R) \<and> (trans R) \<and>
  (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V.
    ((NDC d (V!i)) \<or>
     (IDC d (V!i) (htchLoc (pp (V!i)))))) \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' m2 \<alpha> p.
    ( \<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle> \<and> m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1')
    \<longrightarrow> (\<exists>p' \<alpha>' m2'. ( \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        (stepResultsinR p p' R) \<and> (\<alpha>,\<alpha>') \<in> R \<and>
        (dhequality_alternative d PP (pp (V!i)) m2 m2'))))"

-- "predicate to define when a program is strongly secure"
definition WHATWHERE_Secure :: "'com list \<Rightarrow> bool"
where
"WHATWHERE_Secure V \<equiv> (\<forall>d PP.
  (\<exists>R. Strong_dlHPP_Bisimulation d PP R \<and> (V,V) \<in> R))"

-- "auxiliary lemma to obtain central strong (d,lH,PP)-Bisimulation property as Lemma
 in meta logic (allows instantiating all the variables manually if necessary)"
lemma strongdlHPPB_aux:
 "\<And>V V' m1 m1' m2 p i \<alpha>. \<lbrakk> Strong_dlHPP_Bisimulation d PP R;
  i < length V; (V,V') \<in> R;
  \<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>; m1 \<sim>\<^bsub>d,(htchLocSet PP)\<^esub> m1' \<rbrakk>
 \<Longrightarrow> (\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle>
  \<and> stepResultsinR p p' R \<and> (\<alpha>,\<alpha>') \<in> R \<and>
  (dhequality_alternative d PP (pp (V!i)) m2 m2'))"
  by (simp add: Strong_dlHPP_Bisimulation_def, fastforce)

-- "auxiliary lemma to obtain 'NDC or IDC' from strong (d,lH,PP)-Bisimulation as lemma
  in meta logic allowing instantiation of the variables"
lemma strongdlHPPB_NDCIDCaux:
"\<And>V V' i. \<lbrakk>Strong_dlHPP_Bisimulation d PP R;
  (V,V') \<in> R; i < length V \<rbrakk>
        \<Longrightarrow> (NDC d (V!i) \<or> IDC d (V!i) (htchLoc (pp (V!i))))"
  by (simp add: Strong_dlHPP_Bisimulation_def, auto)

lemma WHATWHERE_empty:
"WHATWHERE_Secure []"
  by (simp add: WHATWHERE_Secure_def, auto,
  rule_tac x="{([],[])}" in exI,
  simp add: Strong_dlHPP_Bisimulation_def sym_def trans_def)

end

end


theory Document
  imports Main
begin

section \<open>Some section\<close>

subsection \<open>Some subsection\<close>

subsection \<open>Some subsubsection\<close>

subsubsection \<open>Some subsubsubsection\<close>

paragraph \<open>A paragraph.\<close>

text \<open>Informal bla bla.\<close>

definition "foo = True"  \<comment> \<open>side remark on \<^const>\<open>foo\<close>\<close>

definition "bar = False"  \<comment> \<open>side remark on \<^const>\<open>bar\<close>\<close>

lemma foo unfolding foo_def ..

paragraph \<open>Another paragraph.\<close>

text \<open>See also \<^cite>\<open>\<open>\S3\<close> in "isabelle-system"\<close>.\<close>

section \<open>Formal proof of Cantor's theorem\<close>

text_raw \<open>\isakeeptag{proof}\<close>
text \<open>
  Cantor's Theorem states that there is no surjection from
  a set to its powerset.  The proof works by diagonalization.  E.g.\ see
  \<^item> \<^url>\<open>http://mathworld.wolfram.com/CantorDiagonalMethod.html\<close>
  \<^item> \<^url>\<open>https://en.wikipedia.org/wiki/Cantor's_diagonal_argument\<close>
\<close>

theorem Cantor: "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a set" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "{x. x \<notin> f x}"
  from * obtain a where "?D = f a" by blast
  moreover have "a \<in> ?D \<longleftrightarrow> a \<notin> f a" by blast
  ultimately show False by blast
qed

subsection \<open>Lorem ipsum dolor\<close>

text \<open>
  Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec id ipsum
  sapien. Vivamus malesuada enim nibh, a tristique nisi sodales ac. Praesent
  ut sem consectetur, interdum tellus ac, sodales nulla. Quisque vel diam at
  risus tempus tempor eget a tortor. Suspendisse potenti. Nulla erat lacus,
  dignissim sed volutpat nec, feugiat non leo. Nunc blandit et justo sed
  venenatis. Donec scelerisque placerat magna, et congue nulla convallis vel.
  Cras tristique dolor consequat dolor tristique rutrum. Suspendisse ultrices
  sem nibh, et suscipit felis ultricies at. Aliquam venenatis est vel nulla
  efficitur ornare. Lorem ipsum dolor sit amet, consectetur adipiscing elit.
\<close>

end


theory Differential_Axioms2
imports
  Differential_Axioms
begin

text \<open>TODO: add to \<open>Differential_Axioms\<close>?\<close>

subsection \<open>Definitions\<close>

\<comment> \<open>
< {c&q(||)} > (f(||)>=0&p(||)) ->
f(||)<=0 ->
<{c&q(||)}>
  (
    f(||)=0 &
    <c&q(||)}>(f(||)>=0&p(||))
  )
\<close>
definition IVTaxiom :: formula
  where "IVTaxiom =
  (let
    c = OVar Ix All;
    q = Pc Ix;
    f = state_fun Ix;
    p = Pc Iy
  in
  (\<langle> EvolveODE c q \<rangle> (p && f \<^bold>\<ge> \<^bold>0)) \<rightarrow> (\<^bold>0 \<^bold>\<ge> f \<rightarrow>
  (\<langle> EvolveODE c q \<rangle> (f \<^bold>= \<^bold>0 && \<langle>EvolveODE c q\<rangle> (f \<^bold>\<ge> \<^bold>0 && p)))))"

\<comment> \<open>
differential conditional cut

 [{c&r(||)}](p(||)->q(||))<-(([{c&r(||)&p(||)}]q(||)) & ([{c&r(||)}](!p(||)->[{c&r(||)}]!p(||))))

e.g., (40) in  \<^url>\<open>https://arxiv.org/abs/1903.00153v1\<close>
\<close>
definition DCCaxiom :: formula
  where "DCCaxiom =
  (let
    c = OVar Ix All;
    p = Pc Ix;
    q = Pc Iy;
    r = Pc Iz
  in
  (([[EvolveODE c (r && p)]] q) && [[EvolveODE c r]] (!p \<rightarrow> [[EvolveODE c r]] !p))
  \<rightarrow>
  [[ EvolveODE c r ]] (p \<rightarrow> q))"

subsection \<open>Proofs\<close>

lemma FVT_state_fun: "FVT (state_fun f) = range Inl"
  by (auto simp: state_fun_def)

lemma fst_mk_v_vec_nth:
  "fst (mk_v I a b c) $ i =
    (if i \<in> ODE_vars I a then c $ i else fst b $ i)"
  by (auto simp: mk_v_concrete)

lemma continuous_on_sterm_compose[continuous_intros]:
  "continuous_on S (\<lambda>x. sterm_sem I f (g x))" if "continuous_on S g" "is_interp I" "dfree f"
  using continuous_on_compose2[OF sterm_continuous[OF that(2,3)] that(1)] by auto

lemma continuous_on_fst_mk_v[continuous_intros]:
  "continuous_on S (\<lambda>x. fst (mk_v I a b (f x)))" if "continuous_on S f"
  apply (auto simp: mk_v_concrete intro!: continuous_intros split: if_splits)
  subgoal for i
    by (cases "(Inl i::ident+ident) \<in> Inl ` ODE_vars I a \<or> Inl i \<in> Inr ` ODE_vars I a")
      (auto simp: that)
  done

lemma ident_expose_Ix: "ident_expose Ix = Inr (SSENT, ident_cons (CHR ''x'') ident_empty)"
  by transfer (simp add: max_str SSENT_def SSENTINEL_def)

lemma ilength_Ix[simp]: "ilength Ix = 2"
  by transfer simp

lemma dsafe_state_fun_Ix[simp]: "dsafe (state_fun Ix)"
  by (auto simp: state_fun_def ident_expose_Ix max_str)

lemma dfree_state_fun_Ix[simp]: "dfree (state_fun Ix)"
  by (auto simp: state_fun_def ident_expose_Ix max_str)

lemma ident_expose_Iy: "ident_expose Iy = Inr (SSENT, ident_cons (CHR ''y'') ident_empty)"
  by transfer (simp add: max_str SSENT_def SSENTINEL_def)

lemma ilength_Iy[simp]: "ilength Iy = 2"
  by transfer simp

lemma dsafe_Iy: "dsafe (state_fun Iy)"
  by (auto simp: state_fun_def ident_expose_Iy max_str)

lemma dfree_state_fun_Iy[simp]: "dfree (state_fun Iy)"
  by (auto simp: state_fun_def ident_expose_Iy max_str)

lemma ident_expose_Iz: "ident_expose Iz = Inr (SSENT, ident_cons (CHR ''z'') ident_empty)"
  by transfer (simp add: max_str SSENT_def SSENTINEL_def)

lemma ilength_Iz[simp]: "ilength Iz = 2"
  by transfer simp

lemma dsafe_Iz: "dsafe (state_fun Iz)"
  by (auto simp: state_fun_def ident_expose_Iz max_str)

lemma dfree_state_fun_Iz[simp]: "dfree (state_fun Iz)"
  by (auto simp: state_fun_def ident_expose_Iz max_str)

lemma IVT_valid:"valid IVTaxiom"
  unfolding IVTaxiom_def
proof (clarsimp simp add: Let_def valid_def)
  fix I::interp and sol' x_t x_t' sol t
  let ?ode = "(\<lambda>a b. \<chi> i. if i \<in> ODEBV I Ix None then ODEs I Ix None b $ i else 0)"
  assume H: "is_interp I"
    "mk_v I (OVar Ix None) (sol 0, sol') (sol t) \<in> Contexts I Iy UNIV"
    "0 \<le> dterm_sem I (state_fun Ix) (mk_v I (OVar Ix None) (sol 0, sol') (sol t))"
    "(x_t, x_t') = mk_v I (OVar Ix None) (sol 0, sol') (sol t)"
    "0 \<le> t"
    "(sol solves_ode ?ode) {0..t} {x. mk_v I (OVar Ix None) (sol 0, sol') x \<in> Contexts I Ix UNIV}"
    "dterm_sem I (state_fun Ix) (sol 0, sol') \<le> 0"
  note ode = \<open>(_ solves_ode _) _ _\<close>
  have sol_cont: "continuous_on {0..t} sol"
    by (rule solves_ode_continuous_on[OF ode])
  have sol_const: "sol s $ i = sol 0 $ i" if "0 \<le> s" "s \<le> t" "i \<notin> ODEBV I Ix None" for s i
    by (rule constant_when_zero[OF refl ode]) (use that in auto)
  define f where "f = dterm_sem I (state_fun Ix)"
  have f_sterm: "f x = sterm_sem I (state_fun Ix) (fst x)" for x
    by (auto simp: f_def state_fun_def)
  define phi where "phi t = mk_v I (OVar Ix None) (sol 0, sol') (sol t)" for t
  have fst_phi: "fst (phi s) = sol s" if "0 \<le> s" "s \<le> t" for s
    by (auto simp: phi_def mk_v_concrete vec_eq_iff intro!: sol_const[symmetric] that)
  have continuous_on_fst_phi: "continuous_on {0..t} (\<lambda>x. fst (phi x))"
    unfolding phi_def
    using sol_cont
    by (rule continuous_on_fst_mk_v)
  have "\<exists>x\<ge>0. x \<le> t \<and> (f \<circ> phi) x = 0"
  proof (rule IVT')
    have "dterm_sem I (state_fun Ix) (sol 0, sol') =
      dterm_sem I (state_fun Ix) (mk_v I (OVar Ix None) (sol 0, sol') (sol 0))"
      by (rule coincidence_dterm)
        (auto simp: FVT_state_fun Vagree_def fst_mk_v_vec_nth)
    then show "(f \<circ> phi) 0 \<le> 0"
      using H
      by (auto simp: phi_def f_def)
    show "0 \<le> (f \<circ> phi) t"
      using H
      by (auto simp: f_def phi_def)
    show "0 \<le> t" by fact
    show "continuous_on {0..t} (f \<circ> phi)"
      by (auto simp: f_sterm o_def  intro!: H continuous_on_sterm_compose continuous_on_fst_phi)
  qed
  then obtain s where s: "s\<ge>0" "s \<le> t" "(f \<circ> phi) s = 0"
    by metis
  have *: "(sol solves_ode ?ode) {0..s} {x. mk_v I (OVar Ix None) (sol 0, sol') x \<in> Contexts I Ix UNIV}"
    using \<open>(_ solves_ode _) _ _\<close>
    by (rule solves_ode_subset) (use \<open>s \<le> t\<close> in auto)
  have **: "f (phi s) = 0"
    using s by auto
  from H have ***: "0 \<le> dterm_sem I (state_fun Ix) (phi t)"
    by (auto simp: phi_def)
  have 4: "fst (phi s) = sol s"
    using H(2) sol_const[OF \<open>0 \<le> s\<close> \<open>s \<le> t\<close>]
    by (auto simp: phi_def vec_eq_iff fst_mk_v_vec_nth)
  have 5: "mk_v I (OVar Ix None) (sol s, snd (phi s)) (sol t) =
      mk_v I (OVar Ix None) (phi s) (fst (phi t))"
    using \<open>0 \<le> t\<close> \<open>0 \<le> s\<close> \<open>s \<le> t\<close>
    by (auto simp: mk_v_concrete vec_eq_iff fst_phi)
  have mk_v_shift: "mk_v I (OVar Ix None) (sol 0, sol') = mk_v I (OVar Ix None) (sol s, snd (phi s))"
    using \<open>0 \<le> s\<close> \<open>s \<le> t\<close>
    by (auto simp: phi_def mk_v_concrete vec_eq_iff fun_eq_iff intro!: sol_const[symmetric])
  have 6: "((\<lambda>t. fst (phi (s + t))) solves_ode ?ode) {0..t - s}
     {x. mk_v I (OVar Ix None) (sol s, snd (phi s)) x \<in> Contexts I Ix UNIV}"
  proof -
    from shift_autonomous_solution[OF H(6) refl, of s]
    have "((\<lambda>t. sol (s + t)) solves_ode ?ode) ((\<lambda>t. t - s) ` {0..t})
      {x. mk_v I (OVar Ix None) (sol 0, sol') x \<in> Contexts I Ix UNIV}"
      unfolding add.commute[of s] .
    also have "((\<lambda>t. t - s) ` {0..t}) = {-s .. t - s}" by auto
    finally have "((\<lambda>t. sol (s + t)) solves_ode ?ode) {- s..t - s}
      {x. mk_v I (OVar Ix None) (sol 0, sol') x \<in> Contexts I Ix UNIV}" .
    then have "((\<lambda>t. sol (s + t)) solves_ode ?ode) {0..t - s}
      {x. mk_v I (OVar Ix None) (sol s, snd (phi s)) x \<in> Contexts I Ix UNIV}"
      unfolding mk_v_shift
      by (rule solves_ode_on_subset) (use \<open>0 \<le> s\<close> in auto)
    then show ?thesis
      apply (subst solves_ode_cong[OF _ _ refl refl])
        apply (subst fst_phi)
      subgoal using \<open>0 \<le> s\<close> by auto
      subgoal by auto
        apply (rule refl)
       apply (rule refl)
      by auto
  qed
  have 7: "phi t \<in> Contexts I Iy UNIV"
    using H by (auto simp: phi_def)
  show "\<exists>a ba.
          (\<exists>sola.
              sol 0 = sola 0 \<and>
              (\<exists>t. (a, ba) = mk_v I (OVar Ix None) (sola 0, sol') (sola t) \<and>
                   0 \<le> t \<and>
                   (sola solves_ode ?ode) {0..t}
                    {x. mk_v I (OVar Ix None) (sola 0, sol') x \<in> Contexts I Ix UNIV})) \<and>
          dterm_sem I (state_fun Ix) (a, ba) = 0 \<and>
          (\<exists>aa b.
              (\<exists>sol. a = sol 0 \<and>
                     (\<exists>t. (aa, b) = mk_v I (OVar Ix None) (sol 0, ba) (sol t) \<and>
                          0 \<le> t \<and>
                          (sol solves_ode ?ode) {0..t}
                           {x. mk_v I (OVar Ix None) (sol 0, ba) x \<in> Contexts I Ix UNIV})) \<and>
              0 \<le> dterm_sem I (state_fun Ix) (aa, b) \<and> (aa, b) \<in> Contexts I Iy UNIV)"
    apply (rule exI[where x="fst (phi s)"])
    apply (rule exI[where x="snd (phi s)"])
    apply safe
      apply (rule exI[where x="sol"])
    apply safe
      apply (rule exI[where x="s"])
    subgoal using * \<open>0 \<le> s\<close> by (auto simp: phi_def)
    subgoal using ** by (auto simp: f_def)
    apply (rule exI[where x="fst (mk_v I (OVar Ix None) (sol s, snd (phi s)) (sol t))"])
    apply (rule exI[where x="snd (mk_v I (OVar Ix None) (sol s, snd (phi s)) (sol t))"])
    apply safe
      apply (rule exI[where x="\<lambda>t. fst (phi (s + t))"])
      apply safe
    subgoal by auto
      apply (rule exI[where x="t - s"])
    subgoal
      using \<open>0 \<le> s\<close>  \<open>s \<le> t\<close> 6
      by (auto simp: 5 fst_phi cong: solves_ode_cong)
    subgoal
      using ***
      by (auto simp flip: mk_v_shift phi_def)
    subgoal
      using 7
      by (auto simp flip: mk_v_shift phi_def)
    done
qed

lemma DCC_valid:"valid DCCaxiom"
proof -
  define c where "c = OVar Ix All"
  define p where "p = Pc Ix"
  define q where "q = Pc Iy"
  define r where "r = Pc Iz"
  have "valid ((([[EvolveODE c (r && p)]]q) && ([[EvolveODE c r]]! p \<rightarrow> [[EvolveODE c r]]! p)) \<rightarrow> ([[EvolveODE c r]](p \<rightarrow> q)))"
    unfolding valid_def fml_sem.simps impl_sem Int_iff
  proof safe
    fix I :: interp
      and x0 :: "simple_state"
      and x0' :: "simple_state"
    assume I: "is_interp I"
      and H1: "(x0, x0') \<in> fml_sem I ([[EvolveODE c (r && p)]]q)"
      and H2: "(x0, x0') \<in> fml_sem I ([[EvolveODE c r]]! p \<rightarrow> [[EvolveODE c r]]! p)"
    show "(x0, x0') \<in> fml_sem I ([[EvolveODE c r]]p \<rightarrow> q)"
    proof clarsimp
      fix x :: simple_state
        and x' :: simple_state
        and sol :: "real \<Rightarrow> simple_state"
        and t :: real
      let ?x = "\<lambda>s. mk_v I c (sol (0::real), x0') (sol s)"
      assume "x0 = sol (0::real)"
        and x: "(x, x') = mk_v I c (sol (0::real), x0') (sol t)"
        and "(0::real) \<le> t"
        and sol: "(sol solves_ode (\<lambda>a. ODE_sem I c)) {0..t} {x. mk_v I c (sol 0, x0') x \<in> fml_sem I r}"
        and sol_t_p: "?x t \<in> fml_sem I p"
      have xt_r: "((x0, x0'), ?x t) \<in> prog_sem I (EvolveODE c r)"
        using x sol sol_t_p \<open>x0 = sol 0\<close> \<open>0 \<le> t\<close>
        by auto
      have "?x s \<in> fml_sem I p" if "0 \<le> s" "s \<le> t" for s
      proof (rule ccontr)
        assume not_p: "?x s \<notin> fml_sem I p"
        have s_r: "((x0, x0'), ?x s) \<in> prog_sem I (EvolveODE c r)"
          using \<open>0 \<le> s\<close> \<open>s \<le> t\<close> \<open>x0 = sol 0\<close>
          by (auto simp: intro!: exI[where x=sol] exI[where x=s] solves_ode_subset[OF sol])
        from H2[unfolded box_sem mem_Collect_eq, rule_format, OF s_r]
        have "?x s \<in> fml_sem I (! p \<rightarrow> [[EvolveODE c r]]! p)" .
        then have s_not_p: "?x s \<in> fml_sem I ([[EvolveODE c r]]! p)" using not_p by auto
        have s_t: "(?x s, ?x t) \<in> prog_sem I (EvolveODE c r)"
        proof -
          have mk_v_eq: "mk_v I c (?x s) = mk_v I c (sol 0, x0')"
            by (auto simp: mk_v_concrete vec_eq_iff)
          have "((\<lambda>t. sol (s + t)) solves_ode (\<lambda>a. ODE_sem I c)) {0..t - s} {x. mk_v I c (sol 0, x0') x \<in> fml_sem I r}"
            using shift_autonomous_solution[OF sol, of s] \<open>0 \<le> s\<close> \<open>s \<le> t\<close>
            by (auto simp: add.commute intro: solves_ode_subset)
          moreover have "sol s = fst (mk_v I c (sol 0, x0') (sol s))"
            using \<open>0 \<le> s\<close> \<open>s \<le> t\<close> I
            by (auto simp: mk_v_concrete vec_eq_iff
                intro!: constant_when_zero[of sol 0, OF refl sol] ODE_unbound_zero)
          ultimately show ?thesis
            using \<open>0 \<le> s\<close> \<open>s \<le> t\<close>
            unfolding prog_sem.simps mem_Collect_eq mk_v_eq
            by (auto simp add: mk_v_eq intro!: exI[where x="\<lambda>tt. sol (s + tt)"] exI[where x="t - s"])
        qed
        from s_not_p[unfolded box_sem mem_Collect_eq, rule_format, OF s_t]
        have "?x t \<notin> fml_sem I p" by simp
        then show False using sol_t_p ..
      qed
      then have "(sol solves_ode (\<lambda>a. ODE_sem I c)) {0..t}
      {x. mk_v I c (sol 0, x0') x \<in> fml_sem I r \<and> mk_v I c (sol 0, x0') x \<in> fml_sem I p}"
        using sol
        by (auto simp: solves_ode_def)
      then have "((x0, x0'), ?x t) \<in> prog_sem I (EvolveODE c (r && p))"
        using \<open>x0 = sol 0\<close> \<open>0 \<le> t\<close> sol
        by (auto intro!: exI[where x=sol] exI[where x=t])
      from H1[unfolded box_sem mem_Collect_eq, rule_format, OF this]
      show "mk_v I c (sol (0::real), x0') (sol t) \<in> fml_sem I q" .
    qed
  qed
  then show ?thesis
    unfolding DCCaxiom_def Let_def c_def p_def q_def r_def.
qed

end