section \<open> Imperative Programming in Designs \<close>

theory utp_des_prog
  imports utp_des_tactics
begin

subsection \<open> Assignment \<close>

definition assigns_d :: "'\<alpha> usubst \<Rightarrow> '\<alpha> hrel_des" ("\<langle>_\<rangle>\<^sub>D") where
[upred_defs]: "assigns_d \<sigma> = (true \<turnstile>\<^sub>r assigns_r \<sigma>)"

syntax
  "_assignmentd" :: "svids \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr ":=\<^sub>D" 62)

translations
  "_assignmentd xs vs" => "CONST assigns_d (_mk_usubst (id\<^sub>s) xs vs)"
  "_assignmentd x v" <= "CONST assigns_d (CONST subst_upd (id\<^sub>s) x v)"
  "_assignmentd x v" <= "_assignmentd (_spvar x) v"
  "x,y :=\<^sub>D u,v" <= "CONST assigns_d (CONST subst_upd (CONST subst_upd (id\<^sub>s) (CONST pr_var x) u) (CONST pr_var y) v)"

lemma assigns_d_is_H1_H2 [closure]: "\<langle>\<sigma>\<rangle>\<^sub>D is \<^bold>H"
  by (simp add: assigns_d_def rdesign_is_H1_H2)

lemma assigns_d_H1_H3 [closure]: "\<langle>\<sigma>\<rangle>\<^sub>D is \<^bold>N"
  by (metis H1_rdesign H3_ndesign Healthy_def' aext_true assigns_d_def ndesign_def)

text \<open> Designs are closed under substitutions on state variables only (via lifting) \<close>

lemma state_subst_H1_H2_closed [closure]:
  "P is \<^bold>H \<Longrightarrow> \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> P is \<^bold>H"
  by (metis H1_H2_eq_rdesign Healthy_if rdesign_is_H1_H2 state_subst_design)

lemma assigns_d_ndes_def [ndes_simp]:
  "\<langle>\<sigma>\<rangle>\<^sub>D = (true \<turnstile>\<^sub>n \<langle>\<sigma>\<rangle>\<^sub>a)"
  by (rel_auto)

lemma assigns_d_id [simp]: "\<langle>id\<^sub>s\<rangle>\<^sub>D = II\<^sub>D"
  by (rel_auto)

lemma assign_d_left_comp:
  "(\<langle>f\<rangle>\<^sub>D ;; (P \<turnstile>\<^sub>r Q)) = (\<lceil>f\<rceil>\<^sub>s \<dagger> P \<turnstile>\<^sub>r \<lceil>f\<rceil>\<^sub>s \<dagger> Q)"
  by (simp add: assigns_d_def rdesign_composition assigns_r_comp subst_not)

lemma assign_d_right_comp:
  "((P \<turnstile>\<^sub>r Q) ;; \<langle>f\<rangle>\<^sub>D) = ((\<not> ((\<not> P) ;; true)) \<turnstile>\<^sub>r (Q ;; \<langle>f\<rangle>\<^sub>a))"
  by (simp add: assigns_d_def rdesign_composition)

lemma assigns_d_comp:
  "(\<langle>f\<rangle>\<^sub>D ;; \<langle>g\<rangle>\<^sub>D) = \<langle>g \<circ>\<^sub>s f\<rangle>\<^sub>D"
  by (simp add: assigns_d_def rdesign_composition assigns_comp)

lemma assigns_d_comp_ext:
  assumes "P is \<^bold>H"
  shows "(\<langle>\<sigma>\<rangle>\<^sub>D ;; P) = \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> P"
proof -
  have "\<langle>\<sigma>\<rangle>\<^sub>D ;; P = \<langle>\<sigma>\<rangle>\<^sub>D ;; (pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P))"
    by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def' assms)
  also have "... = \<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> pre\<^sub>D(P) \<turnstile>\<^sub>r \<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> post\<^sub>D(P)"
    by (simp add: assign_d_left_comp)
  also have "... = \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> (pre\<^sub>D(P) \<turnstile>\<^sub>r post\<^sub>D(P))"
    by (rel_auto)
  also have "... = \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> P"
    by (metis H1_H2_commute H1_H2_is_rdesign H2_idem Healthy_def' assms)
  finally show ?thesis by (simp_all add: closure assms)
qed

text \<open> Normal designs are closed under substitutions on state variables only \<close>

lemma state_subst_H1_H3_closed [closure]:
  "P is \<^bold>N \<Longrightarrow> \<lceil>\<sigma> \<oplus>\<^sub>s \<Sigma>\<^sub>D\<rceil>\<^sub>s \<dagger> P is \<^bold>N"
  by (metis H1_H2_eq_rdesign H1_H3_impl_H2 Healthy_if assign_d_left_comp assigns_d_H1_H3 seq_r_H1_H3_closed state_subst_design)

lemma H4_assigns_d: "\<langle>\<sigma>\<rangle>\<^sub>D is H4"
proof -
  have "(\<langle>\<sigma>\<rangle>\<^sub>D ;; (false \<turnstile>\<^sub>r true\<^sub>h)) = (false \<turnstile>\<^sub>r true)"
    by (simp add: assigns_d_def rdesign_composition assigns_r_feasible)
  moreover have "... = true"
    by (rel_auto)
  ultimately show ?thesis
    using is_H4_alt_def by auto
qed

subsection \<open> Guarded Commands \<close>

definition GrdCommD :: "'\<alpha> upred \<Rightarrow> ('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" where
[upred_defs]: "GrdCommD b P = P \<triangleleft> b \<triangleright>\<^sub>D \<top>\<^sub>D"

syntax "_GrdCommD" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_ \<rightarrow>\<^sub>D _" [60, 61] 61)
translations "_GrdCommD b P" == "CONST GrdCommD b P"

lemma GrdCommD_ndes_simp [ndes_simp]:
  "b \<rightarrow>\<^sub>D (p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2) = ((b \<Rightarrow> p\<^sub>1) \<turnstile>\<^sub>n (\<lceil>b\<rceil>\<^sub>< \<and> P\<^sub>2))"
  by (rel_auto)

lemma GrdCommD_H1_H3_closed [closure]: "P is \<^bold>N \<Longrightarrow> b \<rightarrow>\<^sub>D P is \<^bold>N"
  by (simp add: GrdCommD_def closure)

lemma GrdCommD_true [simp]: "true \<rightarrow>\<^sub>D P = P"
  by (rel_auto)

lemma GrdCommD_false [simp]: "false \<rightarrow>\<^sub>D P = \<top>\<^sub>D"
  by (rel_auto)

lemma GrdCommD_abort [simp]: "b \<rightarrow>\<^sub>D true = ((\<not> b) \<turnstile>\<^sub>n false)"
  by (rel_auto)

subsection \<open> Frames and Extensions \<close>

definition des_frame :: "('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> '\<beta> hrel_des \<Rightarrow> '\<beta> hrel_des" where
[upred_defs]: "des_frame x P = frame (ok +\<^sub>L x ;\<^sub>L \<Sigma>\<^sub>D) P"

definition des_frame_ext :: "('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> '\<alpha> hrel_des \<Rightarrow> '\<beta> hrel_des" where
[upred_defs]: "des_frame_ext a P = des_frame a (rel_aext P (lmap\<^sub>D a))"

syntax
  "_des_frame"     :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sub>D" [99,0] 100)
  "_des_frame_ext" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sub>D\<^sup>+" [99,0] 100)

translations
  "_des_frame x P" => "CONST des_frame x P"
  "_des_frame (_salphaset (_salphamk x)) P" <= "CONST des_frame x P"
  "_des_frame_ext x P" => "CONST des_frame_ext x P"
  "_des_frame_ext (_salphaset (_salphamk x)) P" <= "CONST des_frame_ext x P"

lemma lmapD_rel_aext_ndes [ndes_simp]:
  "(p \<turnstile>\<^sub>n Q) \<oplus>\<^sub>r lmap\<^sub>D[a] = (p \<oplus>\<^sub>p a \<turnstile>\<^sub>n Q \<oplus>\<^sub>r a)"
  by (rel_auto)

subsection \<open> Alternation \<close>

consts
  ualtern       :: "'a set \<Rightarrow> ('a \<Rightarrow> 'p) \<Rightarrow> ('a \<Rightarrow> 'r) \<Rightarrow> 'r \<Rightarrow> 'r"
  ualtern_list  :: "('a \<times> 'r) list \<Rightarrow> 'r \<Rightarrow> 'r"

definition AlternateD :: "'a set \<Rightarrow> ('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('\<alpha>, '\<beta>) rel_des) \<Rightarrow> ('\<alpha>, '\<beta>) rel_des \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" where
[upred_defs, ndes_simp]:
"AlternateD A g P Q = (\<Sqinter> i\<in>A \<bullet> g(i) \<rightarrow>\<^sub>D P(i)) \<sqinter> ((\<And> i\<in>A \<bullet> \<not> g(i)) \<rightarrow>\<^sub>D Q)"

text \<open> This lemma shows that our generalised alternation is the same operator as Marcel Oliveira's
  definition of alternation when the else branch is abort. \<close>

lemma AlternateD_abort_alternate:
  assumes "\<And> i. P(i) is \<^bold>N"
  shows
  "AlternateD A g P \<bottom>\<^sub>D =
  ((\<Or> i\<in>A \<bullet> g(i)) \<and> (\<And> i\<in>A \<bullet> g(i) \<Rightarrow> \<lfloor>pre\<^sub>D(P i)\<rfloor>\<^sub><)) \<turnstile>\<^sub>n (\<Or> i\<in>A \<bullet> \<lceil>g(i)\<rceil>\<^sub>< \<and> post\<^sub>D(P i))"
proof (cases "A = {}")
  case False
  have "AlternateD A g P \<bottom>\<^sub>D =
        (\<Sqinter> i\<in>A \<bullet> g(i) \<rightarrow>\<^sub>D (\<lfloor>pre\<^sub>D(P i)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P i))) \<sqinter> ((\<And> i\<in>A \<bullet> \<not> g(i)) \<rightarrow>\<^sub>D (false \<turnstile>\<^sub>n true))"
    by (simp add: AlternateD_def ndesign_form bot_d_ndes_def assms)
  also have "... = ((\<Or> i\<in>A \<bullet> g(i)) \<and> (\<And> i\<in>A \<bullet> g(i) \<Rightarrow> \<lfloor>pre\<^sub>D(P i)\<rfloor>\<^sub><)) \<turnstile>\<^sub>n (\<Or> i\<in>A \<bullet> \<lceil>g(i)\<rceil>\<^sub>< \<and> post\<^sub>D(P i))"
    by (simp add: ndes_simp False, rel_auto)
  finally show ?thesis by simp
next
  case True
  thus ?thesis
    by (simp add: AlternateD_def, rel_auto)
qed

definition AlternateD_list :: "('\<alpha> upred \<times> ('\<alpha>, '\<beta>) rel_des) list \<Rightarrow> ('\<alpha>, '\<beta>) rel_des  \<Rightarrow> ('\<alpha>, '\<beta>) rel_des" where
[upred_defs, ndes_simp]:
"AlternateD_list xs P =
  AlternateD {0..<length xs} (\<lambda> i. map fst xs ! i) (\<lambda> i. map snd xs ! i) P"

adhoc_overloading
  ualtern AlternateD and
  ualtern_list AlternateD_list

nonterminal gcomm and gcomms

syntax
  "_altind_els"   :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("if _\<in>_ \<bullet> _ \<rightarrow> _ else _ fi")
  "_altind"       :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("if _\<in>_ \<bullet> _ \<rightarrow> _ fi")
  "_gcomm"        :: "logic \<Rightarrow> logic \<Rightarrow> gcomm" ("_ \<rightarrow> _" [60, 60] 61)
  "_gcomm_nil"    :: "gcomm \<Rightarrow> gcomms" ("_")
  "_gcomm_cons"   :: "gcomm \<Rightarrow> gcomms \<Rightarrow> gcomms" ("_ |/ _" [60, 61] 61)
  "_gcomm_show"   :: "logic \<Rightarrow> logic"
  "_altgcomm_els" :: "gcomms \<Rightarrow> logic \<Rightarrow> logic" ("if/ _ /else _ /fi")
  "_altgcomm"     :: "gcomms \<Rightarrow> logic" ("if/ _ /fi")

translations
  "_altind_els x A g P Q" => "CONST ualtern A (\<lambda> x. g) (\<lambda> x. P) Q"
  "_altind_els x A g P Q" <= "CONST ualtern A (\<lambda> x. g) (\<lambda> x'. P) Q"
  "_altind x A g P" => "CONST ualtern A (\<lambda> x. g) (\<lambda> x. P) (CONST Orderings.top)"
  "_altind x A g P" <= "CONST ualtern A (\<lambda> x. g) (\<lambda> x'. P) (CONST Orderings.top)"
  "_altgcomm cs" => "CONST ualtern_list cs (CONST Orderings.top)"
  "_altgcomm (_gcomm_show cs)" <= "CONST ualtern_list cs (CONST Orderings.top)"
  "_altgcomm_els cs P" => "CONST ualtern_list cs P"
  "_altgcomm_els (_gcomm_show cs) P" <= "CONST ualtern_list cs P"

  "_gcomm g P" => "(g, P)"
  "_gcomm g P" <= "_gcomm_show (g, P)"
  "_gcomm_cons c cs" => "c # cs"
  "_gcomm_cons (_gcomm_show c) (_gcomm_show (d # cs))" <= "_gcomm_show (c # d # cs)"
  "_gcomm_nil c" => "[c]"
  "_gcomm_nil (_gcomm_show c)" <= "_gcomm_show [c]"

lemma AlternateD_H1_H3_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is \<^bold>N" "Q is \<^bold>N"
  shows "if i\<in>A \<bullet> g(i) \<rightarrow> P(i) else Q fi is \<^bold>N"
proof (cases "A = {}")
  case True
  then show ?thesis
    by (simp add: AlternateD_def closure false_upred_def assms)
next
  case False
  then show ?thesis
    by (simp add: AlternateD_def closure assms)
qed

lemma AltD_ndes_simp [ndes_simp]:
  "if i\<in>A \<bullet> g(i) \<rightarrow> (P\<^sub>1(i) \<turnstile>\<^sub>n P\<^sub>2(i)) else Q\<^sub>1 \<turnstile>\<^sub>n Q\<^sub>2 fi
   = ((\<And> i \<in> A \<bullet> g i \<Rightarrow> P\<^sub>1 i) \<and> ((\<And> i \<in> A \<bullet> \<not> g i) \<Rightarrow> Q\<^sub>1)) \<turnstile>\<^sub>n
     ((\<Or> i \<in> A \<bullet> \<lceil>g i\<rceil>\<^sub>< \<and> P\<^sub>2 i) \<or> (\<And> i \<in> A \<bullet> \<not> \<lceil>g i\<rceil>\<^sub><) \<and> Q\<^sub>2)"
proof (cases "A = {}")
  case True
  then show ?thesis by (simp add: AlternateD_def)
next
  case False
  then show ?thesis
    by (simp add: ndes_simp, rel_auto)
qed

declare UINF_upto_expand_first [ndes_simp]
declare UINF_Suc_shift [ndes_simp]
declare USUP_upto_expand_first [ndes_simp]
declare USUP_Suc_shift [ndes_simp]
declare true_upred_def [THEN sym, ndes_simp]

lemma AlternateD_mono_refine:
  assumes "\<And> i. P i \<sqsubseteq> Q i" "R \<sqsubseteq> S"
  shows "(if i\<in>A \<bullet> g(i) \<rightarrow> P(i) else R fi) \<sqsubseteq> (if i\<in>A \<bullet> g(i) \<rightarrow> Q(i) else S fi)"
  using assms by (rel_auto, meson)

lemma Monotonic_AlternateD [closure]:
  "\<lbrakk> \<And> i. Monotonic (F i); Monotonic G \<rbrakk> \<Longrightarrow> Monotonic (\<lambda> X. if i\<in>A \<bullet> g(i) \<rightarrow> F i X else G(X) fi)"
  by (rel_auto, meson)

lemma AlternateD_eq:
  assumes "A = B" "\<And> i. i\<in>A \<Longrightarrow> g(i) = h(i)" "\<And> i. i\<in>A \<Longrightarrow> P(i) = Q(i)" "R = S"
  shows "if i\<in>A \<bullet> g(i) \<rightarrow> P(i) else R fi = if i\<in>B \<bullet> h(i) \<rightarrow> Q(i) else S fi"
  by (insert assms, rel_blast)

lemma AlternateD_empty:
  "if i\<in>{} \<bullet> g(i) \<rightarrow> P(i) else Q fi = Q"
  by (rel_auto)

lemma AlternateD_true_singleton:
  assumes "P is \<^bold>N"
  shows "if true \<rightarrow> P fi = P"
  by (ndes_eq cls: assms)

lemma AlernateD_no_ind:
  assumes "A \<noteq> {}" "P is \<^bold>N" "Q is \<^bold>N"
  shows "if i\<in>A \<bullet> b \<rightarrow> P else Q fi = if b \<rightarrow> P else Q fi"
  by (ndes_eq cls: assms)

lemma AlernateD_singleton:
  assumes "P k is \<^bold>N" "Q is \<^bold>N"
  shows "if i\<in>{k} \<bullet> b(i) \<rightarrow> P(i) else Q fi = if b(k) \<rightarrow> P(k) else Q fi" (is "?lhs = ?rhs")
proof -
  have "?lhs = if i\<in>{k} \<bullet> b(k) \<rightarrow> P(k) else Q fi"
    by (auto intro: AlternateD_eq simp add: assms ndesign_form)
  also have "... = ?rhs"
    by (simp add: AlernateD_no_ind assms closure)
  finally show ?thesis .
qed

lemma AlternateD_commute:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "if g\<^sub>1 \<rightarrow> P | g\<^sub>2 \<rightarrow> Q fi = if g\<^sub>2 \<rightarrow> Q | g\<^sub>1 \<rightarrow> P fi"
  by (ndes_eq cls:assms)

lemma AlternateD_dcond:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "if g \<rightarrow> P else Q fi = P \<triangleleft> g \<triangleright>\<^sub>D Q"
  by (ndes_eq cls:assms)

lemma AlternateD_cover:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "if g \<rightarrow> P else Q fi = if g \<rightarrow> P | (\<not> g) \<rightarrow> Q fi"
  by (ndes_eq cls: assms)

lemma UINF_ndes_expand:
  assumes "\<And> i. i\<in>A \<Longrightarrow> P(i) is \<^bold>N"
  shows "(\<Sqinter> i \<in> A \<bullet> \<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i))) = (\<Sqinter> i \<in> A \<bullet> P(i))"
  by (rule UINF_cong, simp add: assms ndesign_form)

lemma USUP_ndes_expand:
  assumes "\<And> i. i\<in>A \<Longrightarrow> P(i) is \<^bold>N"
  shows "(\<Squnion> i \<in> A \<bullet> \<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i))) = (\<Squnion> i \<in> A \<bullet> P(i))"
  by (rule USUP_cong, simp add: assms ndesign_form)

lemma AlternateD_ndes_expand:
  assumes "\<And> i. i\<in>A \<Longrightarrow> P(i) is \<^bold>N" "Q is \<^bold>N"
  shows "if i\<in>A \<bullet> g(i) \<rightarrow> P(i) else Q fi =
         if i\<in>A \<bullet> g(i) \<rightarrow> (\<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i))) else \<lfloor>pre\<^sub>D(Q)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(Q) fi"
  apply (simp add: AlternateD_def)
  apply (subst UINF_ndes_expand[THEN sym])
   apply (simp add: assms closure)
  apply (ndes_simp cls: assms)
  apply (rel_auto)
  done

lemma AlternateD_ndes_expand':
  assumes "\<And> i. i\<in>A \<Longrightarrow> P(i) is \<^bold>N"
  shows "if i\<in>A \<bullet> g(i) \<rightarrow> P(i) fi = if i\<in>A \<bullet> g(i) \<rightarrow> (\<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i))) fi"
  apply (simp add: AlternateD_def)
  apply (subst UINF_ndes_expand[THEN sym])
   apply (simp add: assms closure)
  apply (ndes_simp cls: assms)
  apply (rel_auto)
  done

lemma ndesign_ind_form:
  assumes "\<And> i. P(i) is \<^bold>N"
  shows "(\<lambda> i. \<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i))) = P"
  by (simp add: assms ndesign_form)

lemma AlternateD_insert:
  assumes "\<And> i. i\<in>(insert x A) \<Longrightarrow> P(i) is \<^bold>N" "Q is \<^bold>N"
  shows "if i\<in>(insert x A) \<bullet> g(i) \<rightarrow> P(i) else Q fi =
         if g(x) \<rightarrow> P(x) |
            (\<Or> i\<in>A \<bullet> g(i)) \<rightarrow> if i\<in>A \<bullet> g(i) \<rightarrow> P(i) fi
            else Q
         fi" (is "?lhs = ?rhs")
proof -
  have "?lhs = if i\<in>(insert x A) \<bullet> g(i) \<rightarrow> (\<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i))) else (\<lfloor>pre\<^sub>D(Q)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(Q)) fi"
    using AlternateD_ndes_expand assms(1) assms(2) by blast
  also
  have "... =
         if g(x) \<rightarrow> (\<lfloor>pre\<^sub>D(P(x))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(x))) |
            (\<Or> i\<in>A \<bullet> g(i)) \<rightarrow> if i\<in>A \<bullet> g(i) \<rightarrow> \<lfloor>pre\<^sub>D(P(i))\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(P(i)) fi
            else \<lfloor>pre\<^sub>D(Q)\<rfloor>\<^sub>< \<turnstile>\<^sub>n post\<^sub>D(Q)
         fi"
    by (ndes_simp cls:assms, rel_auto)
  also have "... = ?rhs"
    by (simp add: AlternateD_ndes_expand' ndesign_form assms)
  finally show ?thesis .
qed

subsection \<open> Iteration \<close>

theorem ndesign_iteration_wlp [ndes_simp]:
  "(p \<turnstile>\<^sub>n Q) ;; (p \<turnstile>\<^sub>n Q) \<^bold>^ n = ((\<And> i\<in>{0..n} \<bullet> (Q \<^bold>^ i) wlp p) \<turnstile>\<^sub>n Q \<^bold>^ Suc n)"
proof (induct n)
  case 0
  then show ?case by (rel_auto)
next
  case (Suc n) note hyp = this
  have "(p \<turnstile>\<^sub>n Q) ;; (p \<turnstile>\<^sub>n Q) \<^bold>^ Suc n = (p \<turnstile>\<^sub>n Q) ;; (p \<turnstile>\<^sub>n Q) ;; (p \<turnstile>\<^sub>n Q) \<^bold>^ n"
    by (simp add: upred_semiring.power_Suc)
  also have "... = (p \<turnstile>\<^sub>n Q) ;; ((\<Squnion> i \<in> {0..n} \<bullet> Q \<^bold>^ i wlp p) \<turnstile>\<^sub>n Q \<^bold>^ Suc n)"
    by (simp add: hyp)
  also have "... = (p \<and> Q wlp (\<Squnion> i \<in> {0..n} \<bullet> Q \<^bold>^ i wlp p)) \<turnstile>\<^sub>n (Q ;; Q) ;; Q \<^bold>^ n"
    by (simp add: upred_semiring.power_Suc ndesign_composition_wp seqr_assoc)
  also have "... = (p \<and> U(\<forall> i \<in> {0..\<guillemotleft>n\<guillemotright>}. Q \<^bold>^ Suc i wlp p)) \<turnstile>\<^sub>n (Q ;; Q) ;; Q \<^bold>^ n"
    by (simp add: upred_semiring.power_Suc wp, rel_simp)
  also have "... = (p \<and> (\<Squnion> i \<in> {0..n}. Q \<^bold>^ Suc i wlp p)) \<turnstile>\<^sub>n (Q ;; Q) ;; Q \<^bold>^ n"
    by (rel_auto)
  also have "... = (p \<and> (\<Squnion> i \<in> {1..Suc n}. Q \<^bold>^ i wlp p)) \<turnstile>\<^sub>n (Q ;; Q) ;; Q \<^bold>^ n"
    by (metis (no_types, lifting) One_nat_def image_Suc_atLeastAtMost image_cong image_image)
  also have "... = (Q \<^bold>^ 0 wlp p \<and> (\<Squnion> i \<in> {1..Suc n}. Q \<^bold>^ i wlp p)) \<turnstile>\<^sub>n (Q ;; Q) ;; Q \<^bold>^ n"
    by (simp add: wp)
  also have "... = ((\<Squnion> i \<in> {0..Suc n}. Q \<^bold>^ i wlp p)) \<turnstile>\<^sub>n (Q ;; Q) ;; Q \<^bold>^ n"
    by (simp add: atMost_Suc_eq_insert_0 atLeast0AtMost conj_upred_def image_Suc_atMost)
  also have "... = (\<Squnion> i \<in> {0..Suc n} \<bullet> Q \<^bold>^ i wlp p) \<turnstile>\<^sub>n Q \<^bold>^ Suc (Suc n)"
    by (simp add: upred_semiring.power_Suc USUP_as_Inf_image upred_semiring.mult_assoc)
  finally show ?case .
qed

text \<open> Overloadable Syntax \<close>

consts
  uiterate       :: "'a set \<Rightarrow> ('a \<Rightarrow> 'p) \<Rightarrow> ('a \<Rightarrow> 'r) \<Rightarrow> 'r"
  uiterate_list  :: "('a \<times> 'r) list \<Rightarrow> 'r"

syntax
  "_iterind"       :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("do _\<in>_ \<bullet> _ \<rightarrow> _ od")
  "_itergcomm"     :: "gcomms \<Rightarrow> logic" ("do _ od")

translations
  "_iterind x A g P" => "CONST uiterate A (\<lambda> x. g) (\<lambda> x. P)"
  "_iterind x A g P" <= "CONST uiterate A (\<lambda> x. g) (\<lambda> x'. P)"
  "_itergcomm cs" => "CONST uiterate_list cs"
  "_itergcomm (_gcomm_show cs)" <= "CONST uiterate_list cs"

definition IterateD :: "'a set \<Rightarrow> ('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> '\<alpha> hrel_des) \<Rightarrow> '\<alpha> hrel_des" where
[upred_defs, ndes_simp]:
"IterateD A g P = (\<mu>\<^sub>N X \<bullet> if i\<in>A \<bullet> g(i) \<rightarrow> P(i) ;; X else II\<^sub>D fi)"

definition IterateD_list :: "('\<alpha> upred \<times> '\<alpha> hrel_des) list \<Rightarrow> '\<alpha> hrel_des" where
[upred_defs, ndes_simp]:
"IterateD_list xs = IterateD {0..<length xs} (\<lambda> i. fst (nth xs i)) (\<lambda> i. snd (nth xs i))"

adhoc_overloading
  uiterate IterateD and
  uiterate_list IterateD_list

lemma IterateD_H1_H3_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is \<^bold>N"
  shows "do i\<in>A \<bullet> g(i) \<rightarrow> P(i) od is \<^bold>N"
proof (cases "A = {}")
  case True
  then show ?thesis
    by (simp add: IterateD_def closure assms)
next
  case False
  then show ?thesis
    by (simp add: IterateD_def closure assms)
qed

lemma IterateD_empty:
  "do i\<in>{} \<bullet> g(i) \<rightarrow> P(i) od = II\<^sub>D"
  by (simp add: IterateD_def AlternateD_empty ndes_theory.LFP_const skip_d_is_H1_H3)

lemma IterateD_list_single_expand:
  "do b \<rightarrow> P od = (\<^bold>\<mu>\<^bsub>NDES\<^esub> X \<bullet> if b \<rightarrow> P ;; X else II\<^sub>D fi)"
oops

lemma IterateD_singleton:
  assumes "P is \<^bold>N"
  shows "do b \<rightarrow> P od = do i\<in>{0} \<bullet> b \<rightarrow> P od"
  apply (simp add: IterateD_list_def IterateD_def AlernateD_singleton assms)
  apply (subst AlernateD_singleton)
  apply (simp)
  apply (rel_auto)
oops

lemma IterateD_mono_refine:
  assumes
    "\<And> i. P i is \<^bold>N" "\<And> i. Q i is \<^bold>N"
    "\<And> i. P i \<sqsubseteq> Q i"
  shows "(do i\<in>A \<bullet> g(i) \<rightarrow> P(i) od) \<sqsubseteq> (do i\<in>A \<bullet> g(i) \<rightarrow> Q(i) od)"
  apply (simp add: IterateD_def ndes_theory.utp_lfp_def)
  apply (subst ndes_theory.utp_lfp_def)
  apply (simp_all add: closure assms)
  apply (subst ndes_theory.utp_lfp_def)
  apply (simp_all add: closure assms)
  apply (rule gfp_mono)
  apply (rule AlternateD_mono_refine)
  apply (simp_all add: closure seqr_mono assms)
done

lemma IterateD_single_refine:
  assumes
    "P is \<^bold>N" "Q is \<^bold>N" "P \<sqsubseteq> Q"
  shows "(do g \<rightarrow> P od) \<sqsubseteq> (do g \<rightarrow> Q od)"
oops

lemma IterateD_refine_intro:
  fixes V :: "(nat, 'a) uexpr"
  assumes "vwb_lens w"
  shows
  "I \<turnstile>\<^sub>n (w:[\<lceil>I \<and> \<not> (\<Or> i\<in>A \<bullet> g(i))\<rceil>\<^sub>>]) \<sqsubseteq>
   do i\<in>A \<bullet> g(i) \<rightarrow> (I \<and> g(i)) \<turnstile>\<^sub>n (w:[\<lceil>I\<rceil>\<^sub>> \<and> \<lceil>V\<rceil>\<^sub>> <\<^sub>u \<lceil>V\<rceil>\<^sub><]) od"
proof (cases "A = {}")
  case True
  with assms show ?thesis
    by (simp add: IterateD_empty, rel_auto)
next
  case False
  then show ?thesis
  using assms
    apply (simp add: IterateD_def)
    apply (rule ndesign_mu_wf_refine_intro[where e=V and R="{(x, y). x < y}"])
    apply (simp_all add: wf closure)
    apply (simp add: ndes_simp unrest)
    apply (rule ndesign_refine_intro)
    apply (rel_auto)
    apply (rel_auto)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
  done
qed

lemma IterateD_single_refine_intro:
  fixes V :: "(nat, 'a) uexpr"
  assumes "vwb_lens w"
  shows
  "I \<turnstile>\<^sub>n (w:[\<lceil>I \<and> \<not> g\<rceil>\<^sub>>]) \<sqsubseteq>
   do g \<rightarrow> ((I \<and> g) \<turnstile>\<^sub>n (w:[\<lceil>I\<rceil>\<^sub>> \<and> \<lceil>V\<rceil>\<^sub>> <\<^sub>u \<lceil>V\<rceil>\<^sub><])) od"
  apply (rule order_trans)
  defer
   apply (rule IterateD_refine_intro[of w "{0}" "\<lambda> i. g" I V, simplified, OF assms(1)])
  oops

subsection \<open> Let and Local Variables \<close>

definition LetD :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a \<Rightarrow> '\<alpha> hrel_des) \<Rightarrow> '\<alpha> hrel_des" where
[upred_defs]: "LetD v P = (P x)\<lbrakk>x \<rightarrow> \<lceil>v\<rceil>\<^sub>D\<^sub><\<rbrakk>"

syntax
  "_LetD"       :: "[letbinds, 'a] \<Rightarrow> 'a"                ("(let\<^sub>D (_)/ in (_))" [0, 10] 10)

translations
  "_LetD (_binds b bs) e"  \<rightleftharpoons> "_LetD b (_LetD bs e)"
  "let\<^sub>D x = a in e"        \<rightleftharpoons> "CONST LetD a (\<lambda>x. e)"

lemma LetD_ndes_simp [ndes_simp]:
  "LetD v (\<lambda> x. p(x) \<turnstile>\<^sub>n Q(x)) = (p(x)\<lbrakk>x \<rightarrow> v\<rbrakk>) \<turnstile>\<^sub>n (Q(x)\<lbrakk>x \<rightarrow> \<lceil>v\<rceil>\<^sub><\<rbrakk>)"
  by (rel_auto)

lemma LetD_H1_H3_closed [closure]:
  "\<lbrakk> \<And> x. P(x) is \<^bold>N \<rbrakk> \<Longrightarrow> LetD v P is \<^bold>N"
  by (rel_auto)

end


(*  Title:      HOL/Library/Code_Abstract_Nat.thy
    Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
*)

section {* Avoidance of pattern matching on natural numbers *}

theory Code_Abstract_Nat
imports Main
begin

text {*
  When natural numbers are implemented in another than the
  conventional inductive @{term "0::nat"}/@{term Suc} representation,
  it is necessary to avoid all pattern matching on natural numbers
  altogether.  This is accomplished by this theory (up to a certain
  extent).
*}

subsection {* Case analysis *}

text {*
  Case analysis on natural numbers is rephrased using a conditional
  expression:
*}

lemma [code, code_unfold]:
  "case_nat = (\<lambda>f g n. if n = 0 then f else g (n - 1))"
  by (auto simp add: fun_eq_iff dest!: gr0_implies_Suc)

subsection {* Preprocessors *}

text {*
  The term @{term "Suc n"} is no longer a valid pattern.  Therefore,
  all occurrences of this term in a position where a pattern is
  expected (i.e.~on the left-hand side of a code equation) must be
  eliminated.  This can be accomplished -- as far as possible -- by
  applying the following transformation rule:
*}

lemma Suc_if_eq:
  assumes "\<And>n. f (Suc n) \<equiv> h n"
  assumes "f 0 \<equiv> g"
  shows "f n \<equiv> if n = 0 then g else h (n - 1)"
  by (rule eq_reflection) (cases n, insert assms, simp_all)

text {*
  The rule above is built into a preprocessor that is plugged into
  the code generator.
*}

setup {*
let

val Suc_if_eq = Thm.incr_indexes 1 @{thm Suc_if_eq};

fun remove_suc ctxt thms =
  let
    val thy = Proof_Context.theory_of ctxt;
    val vname = singleton (Name.variant_list (map fst
      (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
    val cv = cterm_of thy (Var ((vname, 0), HOLogic.natT));
    val lhs_of = snd o Thm.dest_comb o fst o Thm.dest_comb o cprop_of;
    val rhs_of = snd o Thm.dest_comb o cprop_of;
    fun find_vars ct = (case term_of ct of
        (Const (@{const_name Suc}, _) $ Var _) => [(cv, snd (Thm.dest_comb ct))]
      | _ $ _ =>
        let val (ct1, ct2) = Thm.dest_comb ct
        in
          map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
          map (apfst (Thm.apply ct1)) (find_vars ct2)
        end
      | _ => []);
    val eqs = maps
      (fn thm => map (pair thm) (find_vars (lhs_of thm))) thms;
    fun mk_thms (thm, (ct, cv')) =
      let
        val thm' =
          Thm.implies_elim
           (Conv.fconv_rule (Thm.beta_conversion true)
             (Drule.instantiate'
               [SOME (ctyp_of_term ct)] [SOME (Thm.lambda cv ct),
                 SOME (Thm.lambda cv' (rhs_of thm)), NONE, SOME cv']
               Suc_if_eq)) (Thm.forall_intr cv' thm)
      in
        case map_filter (fn thm'' =>
            SOME (thm'', singleton
              (Variable.trade (K (fn [thm'''] => [thm''' RS thm']))
                (Variable.declare_thm thm'' ctxt)) thm'')
          handle THM _ => NONE) thms of
            [] => NONE
          | thmps =>
              let val (thms1, thms2) = split_list thmps
              in SOME (subtract Thm.eq_thm (thm :: thms1) thms @ thms2) end
      end
  in get_first mk_thms eqs end;

fun eqn_suc_base_preproc ctxt thms =
  let
    val dest = fst o Logic.dest_equals o prop_of;
    val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
  in
    if forall (can dest) thms andalso exists (contains_suc o dest) thms
      then thms |> perhaps_loop (remove_suc ctxt) |> (Option.map o map) Drule.zero_var_indexes
       else NONE
  end;

val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;

in

  Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)

end;
*}

end


theory Term5
imports "../Nominal2_Atoms" "../Nominal2_Eqvt" "../Nominal2_Supp" "../Abs" "../Perm" "../Fv" "../Rsp"
begin

atom_decl name

datatype rtrm5 =
  rVr5 "name"
| rAp5 "rtrm5" "rtrm5"
| rLt5 "rlts" "rtrm5" --"bind (bv5 lts) in (rtrm5)"
and rlts =
  rLnil
| rLcons "name" "rtrm5" "rlts"

primrec
  rbv5
where
  "rbv5 rLnil = {}"
| "rbv5 (rLcons n t ltl) = {atom n} \<union> (rbv5 ltl)"

setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Term5.rtrm5") 2 *}
print_theorems

local_setup {* snd o define_fv_alpha (Datatype.the_info @{theory} "Term5.rtrm5")
  [[[], [], [(SOME (@{term rbv5}, true), 0, 1)]], [[], []]] [(@{term rbv5}, 1, [[], [(0,NONE), (2,SOME @{term rbv5})]])] *}
print_theorems

notation
  alpha_rtrm5 ("_ \<approx>5 _" [100, 100] 100) and
  alpha_rlts ("_ \<approx>l _" [100, 100] 100)
thm alpha_rtrm5_alpha_rlts_alpha_rbv5.intros

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha5_inj}, []), (build_rel_inj @{thms alpha_rtrm5_alpha_rlts_alpha_rbv5.intros} @{thms rtrm5.distinct rtrm5.inject rlts.distinct rlts.inject} @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} ctxt)) ctxt)) *}
thm alpha5_inj

lemma rbv5_eqvt[eqvt]:
  "pi \<bullet> (rbv5 x) = rbv5 (pi \<bullet> x)"
  apply (induct x)
  apply (simp_all add: eqvts atom_eqvt)
  done

lemma fv_rtrm5_rlts_eqvt[eqvt]:
  "pi \<bullet> (fv_rtrm5 x) = fv_rtrm5 (pi \<bullet> x)"
  "pi \<bullet> (fv_rlts l) = fv_rlts (pi \<bullet> l)"
  apply (induct x and l)
  apply (simp_all add: eqvts atom_eqvt)
  done

(*lemma alpha5_eqvt:
  "(xa \<approx>5 y \<longrightarrow> (p \<bullet> xa) \<approx>5 (p \<bullet> y)) \<and>
  (xb \<approx>l ya \<longrightarrow> (p \<bullet> xb) \<approx>l (p \<bullet> ya)) \<and>
  (alpha_rbv5 b c \<longrightarrow> alpha_rbv5 (p \<bullet> b) (p \<bullet> c))"
apply (tactic {* alpha_eqvt_tac @{thm alpha_rtrm5_alpha_rlts_alpha_rbv5.induct} @{thms alpha5_inj permute_rtrm5_permute_rlts.simps} @{context} 1 *})
done*)

local_setup {*
(fn ctxt => snd (Local_Theory.note ((@{binding alpha5_eqvt}, []),
build_alpha_eqvts [@{term alpha_rtrm5}, @{term alpha_rlts}, @{term alpha_rbv5}] (fn _ => alpha_eqvt_tac  @{thm alpha_rtrm5_alpha_rlts_alpha_rbv5.induct} @{thms alpha5_inj permute_rtrm5_permute_rlts.simps} ctxt 1) ctxt) ctxt)) *}
print_theorems

lemma alpha5_reflp:
"y \<approx>5 y \<and> (x \<approx>l x \<and> alpha_rbv5 x x)"
apply (rule rtrm5_rlts.induct)
apply (simp_all add: alpha5_inj)
apply (rule_tac x="0::perm" in exI)
apply (simp add: eqvts alpha_gen fresh_star_def fresh_zero_perm)
done

lemma alpha5_symp:
"(a \<approx>5 b \<longrightarrow> b \<approx>5 a) \<and>
(x \<approx>l y \<longrightarrow> y \<approx>l x) \<and>
(alpha_rbv5 x y \<longrightarrow> alpha_rbv5 y x)"
apply (rule alpha_rtrm5_alpha_rlts_alpha_rbv5.induct)
apply (simp_all add: alpha5_inj)
apply (erule exE)
apply (rule_tac x="-pi" in exI)
apply (rule alpha_gen_sym)
apply (simp_all add: alphas)
apply (case_tac x)
apply (case_tac y)
apply (simp add: alpha5_eqvt)
apply clarify
apply simp
done

lemma alpha5_symp1:
"(a \<approx>5 b \<longrightarrow> b \<approx>5 a) \<and>
(x \<approx>l y \<longrightarrow> y \<approx>l x) \<and>
(alpha_rbv5 x y \<longrightarrow> alpha_rbv5 y x)"
apply (rule alpha_rtrm5_alpha_rlts_alpha_rbv5.induct)
apply (simp_all add: alpha5_inj)
apply (erule exE)
apply (rule_tac x="- pi" in exI)
apply (simp add: alpha_gen)
  apply(simp add: fresh_star_def fresh_minus_perm)
apply clarify
apply (rule conjI)
apply (rotate_tac 3)
apply (frule_tac p="- pi" in alpha5_eqvt(2))
apply simp
apply (rule conjI)
apply (rotate_tac 5)
apply (frule_tac p="- pi" in alpha5_eqvt(1))
apply simp
apply (rotate_tac 6)
apply simp
apply (drule_tac p1="- pi" in permute_eq_iff[symmetric,THEN iffD1])
apply (simp)
done

thm alpha_gen_sym[no_vars]
thm alpha_gen_compose_sym[no_vars]

lemma tt:
  "\<lbrakk>R (- p \<bullet> x) y \<Longrightarrow> R (p \<bullet> y) x; (bs, x) \<approx>gen R f (- p) (cs, y)\<rbrakk> \<Longrightarrow> (cs, y) \<approx>gen R f p (bs, x)"
  unfolding alphas
  unfolding fresh_star_def
  by (auto simp add:  fresh_minus_perm)

lemma alpha5_symp2:
  shows "a \<approx>5 b \<Longrightarrow> b \<approx>5 a"
  and   "x \<approx>l y \<Longrightarrow> y \<approx>l x"
  and   "alpha_rbv5 x y \<Longrightarrow> alpha_rbv5 y x"
apply(induct rule:  alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts)
(* non-binding case *)
apply(simp add: alpha5_inj)
(* non-binding case *)
apply(simp add: alpha5_inj)
(* binding case *)
apply(simp add: alpha5_inj)
apply(erule exE)
apply(rule_tac x="- pi" in exI)
apply(rule tt)
apply(simp add: alphas)
apply(erule conjE)+
apply(drule_tac p="- pi" in alpha5_eqvt(2))
apply(drule_tac p="- pi" in alpha5_eqvt(2))
apply(drule_tac p="- pi" in alpha5_eqvt(1))
apply(drule_tac p="- pi" in alpha5_eqvt(1))
apply(simp)
apply(simp add: alphas)
apply(erule conjE)+
apply metis
(* non-binding case *)
apply(simp add: alpha5_inj)
(* non-binding case *)
apply(simp add: alpha5_inj)
(* non-binding case *)
apply(simp add: alpha5_inj)
(* non-binding case *)
apply(simp add: alpha5_inj)
done

lemma alpha5_transp:
"(a \<approx>5 b \<longrightarrow> (\<forall>c. b \<approx>5 c \<longrightarrow> a \<approx>5 c)) \<and>
(x \<approx>l y \<longrightarrow> (\<forall>z. y \<approx>l z \<longrightarrow> x \<approx>l z)) \<and>
(alpha_rbv5 k l \<longrightarrow> (\<forall>m. alpha_rbv5 l m \<longrightarrow> alpha_rbv5 k m))"
(*apply (tactic {* transp_tac @{context} @{thm alpha_rtrm5_alpha_rlts_alpha_rbv5.induct} @{thms alpha5_inj} @{thms rtrm5.distinct rtrm5.inject rlts.distinct rlts.inject} [] @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{thms alpha5_eqvt} 1 *})*)
apply (rule alpha_rtrm5_alpha_rlts_alpha_rbv5.induct)
apply (rule_tac [!] allI)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
defer
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (tactic {* (imp_elim_tac @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases} @{context}) 1 *})
apply (simp_all add: alpha5_inj)
apply (tactic {* eetac @{thm exi_sum} @{context} 1 *})
(* HERE *)
(*
apply(rule alpha_gen_trans)
thm alpha_gen_trans
defer
apply (simp add: alpha_gen)
apply clarify
apply(simp add: fresh_star_plus)
apply (rule conjI)
apply (erule_tac x="- pi \<bullet> rltsaa" in allE)
apply (rotate_tac 5)
apply (drule_tac p="- pi" in alpha5_eqvt(2))
apply simp
apply (drule_tac p="pi" in alpha5_eqvt(2))
apply simp
apply (erule_tac x="- pi \<bullet> rtrm5aa" in allE)
apply (rotate_tac 7)
apply (drule_tac p="- pi" in alpha5_eqvt(1))
apply simp
apply (rotate_tac 3)
apply (drule_tac p="pi" in alpha5_eqvt(1))
apply simp
done
*)
sorry

lemma alpha5_equivp:
  "equivp alpha_rtrm5"
  "equivp alpha_rlts"
  unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
  apply (simp_all only: alpha5_reflp)
  apply (meson alpha5_symp alpha5_transp)
  apply (meson alpha5_symp alpha5_transp)
  done

quotient_type
  trm5 = rtrm5 / alpha_rtrm5
and
  lts = rlts / alpha_rlts
  by (auto intro: alpha5_equivp)

local_setup {*
(fn ctxt => ctxt
 |> snd o (Quotient_Def.quotient_lift_const ("Vr5", @{term rVr5}))
 |> snd o (Quotient_Def.quotient_lift_const ("Ap5", @{term rAp5}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lt5", @{term rLt5}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lnil", @{term rLnil}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lcons", @{term rLcons}))
 |> snd o (Quotient_Def.quotient_lift_const ("fv_trm5", @{term fv_rtrm5}))
 |> snd o (Quotient_Def.quotient_lift_const ("fv_lts", @{term fv_rlts}))
 |> snd o (Quotient_Def.quotient_lift_const ("bv5", @{term rbv5}))
 |> snd o (Quotient_Def.quotient_lift_const ("alpha_bv5", @{term alpha_rbv5})))
*}
print_theorems

lemma alpha5_rfv:
  "(t \<approx>5 s \<Longrightarrow> fv_rtrm5 t = fv_rtrm5 s)"
  "(l \<approx>l m \<Longrightarrow> fv_rlts l = fv_rlts m)"
  "(alpha_rbv5 b c \<Longrightarrow> True)"
  apply(induct rule: alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts)
  apply(simp_all add: eqvts)
  apply(simp add: alpha_gen)
  apply(clarify)
  apply blast
done

lemma bv_list_rsp:
  shows "x \<approx>l y \<Longrightarrow> rbv5 x = rbv5 y"
  apply(induct rule: alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts(2))
  apply(simp_all)
  apply(clarify)
  apply simp
  done

local_setup {* snd o Local_Theory.note ((@{binding alpha_dis}, []), (flat (map (distinct_rel @{context} @{thms alpha_rtrm5.cases alpha_rlts.cases alpha_rbv5.cases}) [(@{thms rtrm5.distinct}, @{term alpha_rtrm5}), (@{thms rlts.distinct}, @{term alpha_rlts}), (@{thms rlts.distinct}, @{term alpha_rbv5})]))) *}
print_theorems

local_setup {* snd o Local_Theory.note ((@{binding alpha_bn_rsp}, []), prove_alpha_bn_rsp [@{term alpha_rtrm5}, @{term alpha_rlts}] @{thms alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts} @{thms rtrm5.exhaust rlts.exhaust} @{thms alpha5_inj alpha_dis} @{thms alpha5_equivp} @{context} (@{term alpha_rbv5}, 1)) *}
thm alpha_bn_rsp

lemma [quot_respect]:
  "(alpha_rlts ===> op =) fv_rlts fv_rlts"
  "(alpha_rtrm5 ===> op =) fv_rtrm5 fv_rtrm5"
  "(alpha_rlts ===> op =) rbv5 rbv5"
  "(op = ===> alpha_rtrm5) rVr5 rVr5"
  "(alpha_rtrm5 ===> alpha_rtrm5 ===> alpha_rtrm5) rAp5 rAp5"
  "(alpha_rlts ===> alpha_rtrm5 ===> alpha_rtrm5) rLt5 rLt5"
  "(op = ===> alpha_rtrm5 ===> alpha_rlts ===> alpha_rlts) rLcons rLcons"
  "(op = ===> alpha_rtrm5 ===> alpha_rtrm5) permute permute"
  "(op = ===> alpha_rlts ===> alpha_rlts) permute permute"
  "(alpha_rlts ===> alpha_rlts ===> op =) alpha_rbv5 alpha_rbv5"
  apply (simp_all add: alpha5_inj alpha5_rfv alpha5_eqvt bv_list_rsp alpha_bn_rsp)
  apply (clarify)
  apply (rule_tac x="0" in exI)
  apply (simp add: fresh_star_def fresh_zero_perm alpha_gen alpha5_rfv)
done

lemma
  shows "(alpha_rlts ===> op =) rbv5 rbv5"
  by (simp add: bv_list_rsp)

lemmas trm5_lts_inducts = rtrm5_rlts.inducts[quot_lifted]

instantiation trm5 and lts :: pt
begin

quotient_definition
  "permute_trm5 :: perm \<Rightarrow> trm5 \<Rightarrow> trm5"
is
  "permute :: perm \<Rightarrow> rtrm5 \<Rightarrow> rtrm5"

quotient_definition
  "permute_lts :: perm \<Rightarrow> lts \<Rightarrow> lts"
is
  "permute :: perm \<Rightarrow> rlts \<Rightarrow> rlts"

instance by default
  (simp_all add: permute_rtrm5_permute_rlts_zero[quot_lifted] permute_rtrm5_permute_rlts_append[quot_lifted])

end

lemmas permute_trm5_lts = permute_rtrm5_permute_rlts.simps[quot_lifted]
lemmas bv5[simp] = rbv5.simps[quot_lifted]
lemmas fv_trm5_lts[simp] = fv_rtrm5_fv_rlts.simps[quot_lifted]
lemmas alpha5_INJ = alpha5_inj[unfolded alpha_gen2, unfolded alpha_gen, quot_lifted, folded alpha_gen2, folded alpha_gen]
lemmas alpha5_DIS = alpha_dis[quot_lifted]

end


section\<open>Auxiliary renamings for Separation\<close>
theory Separation_Rename
  imports
    Interface
begin

no_notation Aleph (\<open>\<aleph>_\<close> [90] 90)

lemmas apply_fun = apply_iff[THEN iffD1]

lemma nth_concat : "[p,t] \<in> list(A) \<Longrightarrow> env\<in> list(A) \<Longrightarrow> nth(1 +\<^sub>\<omega> length(env),[p]@ env @ [t]) = t"
  by(auto simp add:nth_append)

lemma nth_concat2 : "env\<in> list(A) \<Longrightarrow> nth(length(env),env @ [p,t]) = p"
  by(auto simp add:nth_append)

lemma nth_concat3 : "env\<in> list(A) \<Longrightarrow> u = nth(succ(length(env)), env @ [pi, u])"
  by(auto simp add:nth_append)

definition
  sep_var :: "i \<Rightarrow> i" where
  "sep_var(n) \<equiv> {\<langle>0,1\<rangle>,\<langle>1,3\<rangle>,\<langle>2,4\<rangle>,\<langle>3,5\<rangle>,\<langle>4,0\<rangle>,\<langle>5+\<^sub>\<omega>n,6\<rangle>,\<langle>6+\<^sub>\<omega>n,2\<rangle>}"

definition
  sep_env :: "i \<Rightarrow> i" where
  "sep_env(n) \<equiv> \<lambda> i \<in> (5+\<^sub>\<omega>n)-5 . i+\<^sub>\<omega>2"

definition weak :: "[i, i] \<Rightarrow> i" where
  "weak(n,m) \<equiv> {i+\<^sub>\<omega>m . i \<in> n}"

lemma weakD :
  assumes "n \<in> nat" "k\<in>nat" "x \<in> weak(n,k)"
  shows "\<exists> i \<in> n . x = i+\<^sub>\<omega>k"
  using assms unfolding weak_def by blast

lemma weak_equal :
  assumes "n\<in>nat" "m\<in>nat"
  shows "weak(n,m) = (m+\<^sub>\<omega>n) - m"
proof -
  have "weak(n,m)\<subseteq>(m+\<^sub>\<omega>n)-m"
  proof(intro subsetI)
    fix x
    assume "x\<in>weak(n,m)"
    with assms
    obtain i where
      "i\<in>n" "x=i+\<^sub>\<omega>m"
      using weakD by blast
    then
    have "m\<le>i+\<^sub>\<omega>m" "i<n"
      using add_le_self2[of m i] \<open>m\<in>nat\<close> \<open>n\<in>nat\<close> ltI[OF \<open>i\<in>n\<close>] by simp_all
    then
    have "\<not>i+\<^sub>\<omega>m<m"
      using not_lt_iff_le in_n_in_nat[OF \<open>n\<in>nat\<close> \<open>i\<in>n\<close>] \<open>m\<in>nat\<close> by simp
    with \<open>x=i+\<^sub>\<omega>m\<close>
    have "x\<notin>m"
      using ltI \<open>m\<in>nat\<close> by auto
    moreover
    from assms \<open>x=i+\<^sub>\<omega>m\<close> \<open>i<n\<close>
    have "x<m+\<^sub>\<omega>n"
      using add_lt_mono1[OF \<open>i<n\<close> \<open>n\<in>nat\<close>] by simp
    ultimately
    show "x\<in>(m+\<^sub>\<omega>n)-m"
      using ltD DiffI by simp
  qed
  moreover
  have "(m+\<^sub>\<omega>n)-m\<subseteq>weak(n,m)"
  proof (intro subsetI)
    fix x
    assume "x\<in>(m+\<^sub>\<omega>n)-m"
    then
    have "x\<in>m+\<^sub>\<omega>n" "x\<notin>m"
      using DiffD1[of x "n+\<^sub>\<omega>m" m] DiffD2[of x "n+\<^sub>\<omega>m" m] by simp_all
    then
    have "x<m+\<^sub>\<omega>n" "x\<in>nat"
      using ltI in_n_in_nat[OF add_type[of m n]] by simp_all
    then
    obtain i where
      "m+\<^sub>\<omega>n = succ(x+\<^sub>\<omega>i)"
      using less_iff_succ_add[OF \<open>x\<in>nat\<close>,of "m+\<^sub>\<omega>n"] add_type by auto
    then
    have "x+\<^sub>\<omega>i<m+\<^sub>\<omega>n" using succ_le_iff by simp
    with \<open>x\<notin>m\<close>
    have "\<not>x<m" using ltD by blast
    with \<open>m\<in>nat\<close> \<open>x\<in>nat\<close>
    have "m\<le>x" using not_lt_iff_le by simp
    with \<open>x<m+\<^sub>\<omega>n\<close>  \<open>n\<in>nat\<close>
    have "x-\<^sub>\<omega>m<m+\<^sub>\<omega>n-\<^sub>\<omega>m"
      using diff_mono[OF \<open>x\<in>nat\<close> _ \<open>m\<in>nat\<close>] by simp
    have "m+\<^sub>\<omega>n-\<^sub>\<omega>m =  n" using diff_cancel2 \<open>m\<in>nat\<close> \<open>n\<in>nat\<close> by simp
    with \<open>x-\<^sub>\<omega>m<m+\<^sub>\<omega>n-\<^sub>\<omega>m\<close> \<open>x\<in>nat\<close>
    have "x-\<^sub>\<omega>m \<in> n" "x=x-\<^sub>\<omega>m+\<^sub>\<omega>m"
      using ltD add_diff_inverse2[OF \<open>m\<le>x\<close>] by simp_all
    then
    show "x\<in>weak(n,m)"
      unfolding weak_def by auto
  qed
  ultimately
  show ?thesis by auto
qed

lemma weak_zero:
  shows "weak(0,n) = 0"
  unfolding weak_def by simp

lemma weakening_diff :
  assumes "n \<in> nat"
  shows "weak(n,7) - weak(n,5) \<subseteq> {5+\<^sub>\<omega>n, 6+\<^sub>\<omega>n}"
  unfolding weak_def using assms
proof(auto)
  {
    fix i
    assume "i\<in>n" "succ(succ(natify(i)))\<noteq>n" "\<forall>w\<in>n. succ(succ(natify(i))) \<noteq> natify(w)"
    then
    have "i<n"
      using ltI \<open>n\<in>nat\<close> by simp
    from \<open>n\<in>nat\<close> \<open>i\<in>n\<close> \<open>succ(succ(natify(i)))\<noteq>n\<close>
    have "i\<in>nat" "succ(succ(i))\<noteq>n" using in_n_in_nat by simp_all
    from \<open>i<n\<close>
    have "succ(i)\<le>n" using succ_leI by simp
    with \<open>n\<in>nat\<close>
    consider (a) "succ(i) = n" | (b) "succ(i) < n"
      using leD by auto
    then have "succ(i) = n"
    proof cases
      case a
      then show ?thesis .
    next
      case b
      then
      have "succ(succ(i))\<le>n" using succ_leI by simp
      with \<open>n\<in>nat\<close>
      consider (a) "succ(succ(i)) = n" | (b) "succ(succ(i)) < n"
        using leD by auto
      then have "succ(i) = n"
      proof cases
        case a
        with \<open>succ(succ(i))\<noteq>n\<close> show ?thesis by blast
      next
        case b
        then
        have "succ(succ(i))\<in>n" using ltD by simp
        with \<open>i\<in>nat\<close>
        have "succ(succ(natify(i))) \<noteq> natify(succ(succ(i)))"
          using  \<open>\<forall>w\<in>n. succ(succ(natify(i))) \<noteq> natify(w)\<close> by auto
        then
        have "False" using \<open>i\<in>nat\<close> by auto
        then show ?thesis by blast
      qed
      then show ?thesis .
    qed
    with \<open>i\<in>nat\<close> have "succ(natify(i)) = n" by simp
  }
  then
  show "n \<in> nat \<Longrightarrow>
    succ(succ(natify(y))) \<noteq> n \<Longrightarrow>
    \<forall>x\<in>n. succ(succ(natify(y))) \<noteq> natify(x) \<Longrightarrow>
    y \<in> n \<Longrightarrow> succ(natify(y)) = n" for y
    by blast
qed

lemma in_add_del :
  assumes "x\<in>j+\<^sub>\<omega>n" "n\<in>nat" "j\<in>nat"
  shows "x < j \<or> x \<in> weak(n,j)"
proof (cases "x<j")
  case True
  then show ?thesis ..
next
  case False
  have "x\<in>nat" "j+\<^sub>\<omega>n\<in>nat"
    using in_n_in_nat[OF _ \<open>x\<in>j+\<^sub>\<omega>n\<close>] assms by simp_all
  then
  have "j \<le> x" "x < j+\<^sub>\<omega>n"
    using not_lt_iff_le False \<open>j\<in>nat\<close> \<open>n\<in>nat\<close> ltI[OF \<open>x\<in>j+\<^sub>\<omega>n\<close>] by auto
  then
  have "x-\<^sub>\<omega>j < (j +\<^sub>\<omega> n) -\<^sub>\<omega> j" "x = j +\<^sub>\<omega> (x -\<^sub>\<omega>j)"
    using diff_mono \<open>x\<in>nat\<close> \<open>j+\<^sub>\<omega>n\<in>nat\<close> \<open>j\<in>nat\<close> \<open>n\<in>nat\<close>
      add_diff_inverse[OF \<open>j\<le>x\<close>] by simp_all
  then
  have "x-\<^sub>\<omega>j < n" "x = (x -\<^sub>\<omega>j ) +\<^sub>\<omega> j"
    using diff_add_inverse \<open>n\<in>nat\<close> add_commute by simp_all
  then
  have "x-\<^sub>\<omega>j \<in>n" using ltD by simp
  then
  have "x \<in> weak(n,j)"
    unfolding weak_def
    using \<open>x= (x-\<^sub>\<omega>j) +\<^sub>\<omega>j\<close> RepFunI[OF \<open>x-\<^sub>\<omega>j\<in>n\<close>] add_commute by force
  then show ?thesis  ..
qed

lemma sep_env_action:
  assumes
    "[t,p,u,P,leq,o,pi] \<in> list(M)"
    "env \<in> list(M)"
  shows "\<forall> i . i \<in> weak(length(env),5) \<longrightarrow>
      nth(sep_env(length(env))`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
proof -
  from assms
  have A: "5+\<^sub>\<omega>length(env)\<in>nat" "[p, P, leq, o, t] \<in>list(M)"
    by simp_all
  let ?f="sep_env(length(env))"
  have EQ: "weak(length(env),5) = 5+\<^sub>\<omega>length(env) - 5"
    using weak_equal length_type[OF \<open>env\<in>list(M)\<close>] by simp
  let ?tgt="[t,p,u,P,leq,o,pi]@env"
  let ?src="[p,P,leq,o,t] @ env @ [pi,u]"
  have "nth(?f`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
    if "i \<in> (5+\<^sub>\<omega>length(env)-5)" for i
  proof -
    from that
    have 2: "i \<in> 5+\<^sub>\<omega>length(env)"  "i \<notin> 5" "i \<in> nat" "i-\<^sub>\<omega>5\<in>nat" "i+\<^sub>\<omega>2\<in>nat"
      using in_n_in_nat[OF \<open>5+\<^sub>\<omega>length(env)\<in>nat\<close>] by simp_all
    then
    have 3: "\<not> i < 5" using ltD by force
    then
    have "5 \<le> i" "2 \<le> 5"
      using  not_lt_iff_le \<open>i\<in>nat\<close> by simp_all
    then have "2 \<le> i" using le_trans[OF \<open>2\<le>5\<close>] by simp
    from A \<open>i \<in> 5+\<^sub>\<omega>length(env)\<close>
    have "i < 5+\<^sub>\<omega>length(env)" using ltI by simp
    with \<open>i\<in>nat\<close> \<open>2\<le>i\<close> A
    have C:"i+\<^sub>\<omega>2 < 7+\<^sub>\<omega>length(env)"  by simp
    with that
    have B: "?f`i = i+\<^sub>\<omega>2" unfolding sep_env_def by simp
    from 3 assms(1) \<open>i\<in>nat\<close>
    have "\<not> i+\<^sub>\<omega>2 < 7" using not_lt_iff_le add_le_mono by simp
    from \<open>i < 5+\<^sub>\<omega>length(env)\<close> 3 \<open>i\<in>nat\<close>
    have "i-\<^sub>\<omega>5 < 5+\<^sub>\<omega>length(env) -\<^sub>\<omega> 5"
      using diff_mono[of i "5+\<^sub>\<omega>length(env)" 5,OF _ _ _ \<open>i < 5+\<^sub>\<omega>length(env)\<close>]
        not_lt_iff_le[THEN iffD1] by force
    with assms(2)
    have "i-\<^sub>\<omega>5 < length(env)" using diff_add_inverse length_type by simp
    have "nth(i,?src) =nth(i-\<^sub>\<omega>5,env@[pi,u])"
      using nth_append[OF A(2) \<open>i\<in>nat\<close>] 3 by simp
    also
    have "... = nth(i-\<^sub>\<omega>5, env)"
      using nth_append[OF \<open>env \<in>list(M)\<close> \<open>i-\<^sub>\<omega>5\<in>nat\<close>] \<open>i-\<^sub>\<omega>5 < length(env)\<close> by simp
    also
    have "... = nth(i+\<^sub>\<omega>2, ?tgt)"
      using nth_append[OF assms(1) \<open>i+\<^sub>\<omega>2\<in>nat\<close>] \<open>\<not> i+\<^sub>\<omega>2 <7\<close> by simp
    ultimately
    have "nth(i,?src) = nth(?f`i,?tgt)"
      using B by simp
    then show ?thesis using that by simp
  qed
  then show ?thesis using EQ by force
qed

lemma sep_env_type :
  assumes "n \<in> nat"
  shows "sep_env(n) : (5+\<^sub>\<omega>n)-5 \<rightarrow> (7+\<^sub>\<omega>n)-7"
proof -
  let ?h="sep_env(n)"
  from \<open>n\<in>nat\<close>
  have "(5+\<^sub>\<omega>n)+\<^sub>\<omega>2 = 7+\<^sub>\<omega>n" "7+\<^sub>\<omega>n\<in>nat" "5+\<^sub>\<omega>n\<in>nat" by simp_all
  have
    D: "sep_env(n)`x \<in> (7+\<^sub>\<omega>n)-7" if "x \<in> (5+\<^sub>\<omega>n)-5" for x
  proof -
    from \<open>x\<in>5+\<^sub>\<omega>n-5\<close>
    have "?h`x = x+\<^sub>\<omega>2" "x<5+\<^sub>\<omega>n" "x\<in>nat"
      unfolding sep_env_def using ltI in_n_in_nat[OF \<open>5+\<^sub>\<omega>n\<in>nat\<close>] by simp_all
    then
    have "x+\<^sub>\<omega>2 < 7+\<^sub>\<omega>n" by simp
    then
    have "x+\<^sub>\<omega>2 \<in> 7+\<^sub>\<omega>n" using ltD by simp
    from \<open>x\<in>5+\<^sub>\<omega>n-5\<close>
    have "x\<notin>5" by simp
    then have "\<not>x<5" using ltD by blast
    then have "5\<le>x" using not_lt_iff_le \<open>x\<in>nat\<close> by simp
    then have "7\<le>x+\<^sub>\<omega>2" using add_le_mono \<open>x\<in>nat\<close> by simp
    then have "\<not>x+\<^sub>\<omega>2<7" using not_lt_iff_le \<open>x\<in>nat\<close> by simp
    then have "x+\<^sub>\<omega>2 \<notin> 7" using ltI \<open>x\<in>nat\<close> by force
    with \<open>x+\<^sub>\<omega>2 \<in> 7+\<^sub>\<omega>n\<close> show ?thesis using  \<open>?h`x = x+\<^sub>\<omega>2\<close> DiffI by simp
  qed
  then show ?thesis unfolding sep_env_def using lam_type by simp
qed

lemma sep_var_fin_type :
  assumes "n \<in> nat"
  shows "sep_var(n) : 7+\<^sub>\<omega>n  -||> 7+\<^sub>\<omega>n"
  unfolding sep_var_def
  using consI ltD emptyI by force

lemma sep_var_domain :
  assumes "n \<in> nat"
  shows "domain(sep_var(n)) =  7+\<^sub>\<omega>n - weak(n,5)"
proof -
  let ?A="weak(n,5)"
  have A:"domain(sep_var(n)) \<subseteq> (7+\<^sub>\<omega>n)"
    unfolding sep_var_def
    by(auto simp add: le_natE)
  have C: "x=5+\<^sub>\<omega>n \<or> x=6+\<^sub>\<omega>n \<or> x \<le> 4" if "x\<in>domain(sep_var(n))" for x
    using that unfolding sep_var_def by auto
  have D : "x<n+\<^sub>\<omega>7" if "x\<in>7+\<^sub>\<omega>n" for x
    using that \<open>n\<in>nat\<close> ltI by simp
  have "\<not> 5+\<^sub>\<omega>n < 5+\<^sub>\<omega>n" using \<open>n\<in>nat\<close>  lt_irrefl[of _ False] by force
  have "\<not> 6+\<^sub>\<omega>n < 5+\<^sub>\<omega>n" using \<open>n\<in>nat\<close> by force
  have R: "x < 5+\<^sub>\<omega>n" if "x\<in>?A" for x
  proof -
    from that
    obtain i where
      "i<n" "x=5+\<^sub>\<omega>i"
      unfolding weak_def
      using ltI \<open>n\<in>nat\<close> RepFun_iff by force
    with \<open>n\<in>nat\<close>
    have "5+\<^sub>\<omega>i < 5+\<^sub>\<omega>n" using add_lt_mono2 by simp
    with \<open>x=5+\<^sub>\<omega>i\<close>
    show "x < 5+\<^sub>\<omega>n" by simp
  qed
  then
  have 1:"x\<notin>?A" if "\<not>x <5+\<^sub>\<omega>n" for x using that by blast
  have "5+\<^sub>\<omega>n \<notin> ?A" "6+\<^sub>\<omega>n\<notin>?A"
  proof -
    show "5+\<^sub>\<omega>n \<notin> ?A" using 1 \<open>\<not>5+\<^sub>\<omega>n<5+\<^sub>\<omega>n\<close> by blast
    with 1 show "6+\<^sub>\<omega>n \<notin> ?A" using  \<open>\<not>6+\<^sub>\<omega>n<5+\<^sub>\<omega>n\<close> by blast
  qed
  then
  have E:"x\<notin>?A" if "x\<in>domain(sep_var(n))" for x
    unfolding weak_def
    using C that by force
  then
  have F: "domain(sep_var(n)) \<subseteq> 7+\<^sub>\<omega>n - ?A" using A by auto
  from assms
  have "x<7 \<or> x\<in>weak(n,7)" if "x\<in>7+\<^sub>\<omega>n" for x
    using in_add_del[OF \<open>x\<in>7+\<^sub>\<omega>n\<close>] by simp
  moreover
  {
    fix x
    assume asm:"x\<in>7+\<^sub>\<omega>n"  "x\<notin>?A"  "x\<in>weak(n,7)"
    then
    have "x\<in>domain(sep_var(n))"
    proof -
      from \<open>n\<in>nat\<close>
      have "weak(n,7)-weak(n,5)\<subseteq>{n+\<^sub>\<omega>5,n+\<^sub>\<omega>6}"
        using weakening_diff by simp
      with  \<open>x\<notin>?A\<close> asm
      have "x\<in>{n+\<^sub>\<omega>5,n+\<^sub>\<omega>6}" using  subsetD DiffI by blast
      then
      show ?thesis unfolding sep_var_def by simp
    qed
  }
  moreover
  {
    fix x
    assume asm:"x\<in>7+\<^sub>\<omega>n"  "x\<notin>?A" "x<7"
    then have "x\<in>domain(sep_var(n))"
    proof (cases "2 \<le> n")
      case True
      moreover
      have "0<n" using  leD[OF \<open>n\<in>nat\<close> \<open>2\<le>n\<close>] lt_imp_0_lt by auto
      ultimately
      have "x<5"
        using \<open>x<7\<close> \<open>x\<notin>?A\<close> \<open>n\<in>nat\<close> in_n_in_nat
        unfolding weak_def
        by (clarsimp simp add:not_lt_iff_le, auto simp add:lt_def)
      then
      show ?thesis unfolding sep_var_def
        by (clarsimp simp add:not_lt_iff_le, auto simp add:lt_def)
    next
      case False
      then
      show ?thesis
      proof (cases "n=0")
        case True
        then show ?thesis
          unfolding sep_var_def using ltD asm \<open>n\<in>nat\<close> by auto
      next
        case False
        then
        have "n < 2" using  \<open>n\<in>nat\<close> not_lt_iff_le \<open>\<not> 2 \<le> n\<close>  by force
        then
        have "\<not> n <1" using \<open>n\<noteq>0\<close> by simp
        then
        have "n=1" using not_lt_iff_le \<open>n<2\<close> le_iff by auto
        then show ?thesis
          using \<open>x\<notin>?A\<close>
          unfolding weak_def sep_var_def
          using ltD asm \<open>n\<in>nat\<close> by force
      qed
    qed
  }
  ultimately
  have "w\<in>domain(sep_var(n))" if "w\<in> 7+\<^sub>\<omega>n - ?A" for w
    using that by blast
  then
  have "7+\<^sub>\<omega>n - ?A \<subseteq> domain(sep_var(n))" by blast
  with F
  show ?thesis by auto
qed

lemma sep_var_type :
  assumes "n \<in> nat"
  shows "sep_var(n) : (7+\<^sub>\<omega>n)-weak(n,5) \<rightarrow> 7+\<^sub>\<omega>n"
  using FiniteFun_is_fun[OF sep_var_fin_type[OF \<open>n\<in>nat\<close>]]
    sep_var_domain[OF \<open>n\<in>nat\<close>] by simp

lemma sep_var_action :
  assumes
    "[t,p,u,P,leq,o,pi] \<in> list(M)"
    "env \<in> list(M)"
  shows "\<forall> i . i \<in> (7+\<^sub>\<omega>length(env)) - weak(length(env),5) \<longrightarrow>
    nth(sep_var(length(env))`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
  using assms
proof (subst sep_var_domain[OF length_type[OF \<open>env\<in>list(M)\<close>],symmetric],auto)
  fix i y
  assume "\<langle>i, y\<rangle> \<in> sep_var(length(env))"
  with assms
  show "nth(sep_var(length(env)) ` i,
               Cons(t, Cons(p, Cons(u, Cons(P, Cons(leq, Cons(o, Cons(pi, env)))))))) =
           nth(i, Cons(p, Cons(P, Cons(leq, Cons(o, Cons(t, env @ [pi, u]))))))"
    using apply_fun[OF sep_var_type] assms
    unfolding sep_var_def
    using nth_concat2[OF \<open>env\<in>list(M)\<close>]  nth_concat3[OF \<open>env\<in>list(M)\<close>,symmetric]
    by force
qed

definition
  rensep :: "i \<Rightarrow> i" where
  "rensep(n) \<equiv> union_fun(sep_var(n),sep_env(n),7+\<^sub>\<omega>n-weak(n,5),weak(n,5))"

lemma rensep_aux :
  assumes "n\<in>nat"
  shows "(7+\<^sub>\<omega>n-weak(n,5)) \<union> weak(n,5) = 7+\<^sub>\<omega>n" "7+\<^sub>\<omega>n \<union> ( 7 +\<^sub>\<omega> n - 7) = 7+\<^sub>\<omega>n"
proof -
  from \<open>n\<in>nat\<close>
  have "weak(n,5) = n+\<^sub>\<omega>5-5"
    using weak_equal by simp
  with  \<open>n\<in>nat\<close>
  show "(7+\<^sub>\<omega>n-weak(n,5)) \<union> weak(n,5) = 7+\<^sub>\<omega>n" "7+\<^sub>\<omega>n \<union> ( 7 +\<^sub>\<omega> n - 7) = 7+\<^sub>\<omega>n"
    using Diff_partition le_imp_subset by auto
qed

lemma rensep_type :
  assumes "n\<in>nat"
  shows "rensep(n) \<in> 7+\<^sub>\<omega>n \<rightarrow> 7+\<^sub>\<omega>n"
proof -
  from \<open>n\<in>nat\<close>
  have "rensep(n) \<in> (7+\<^sub>\<omega>n-weak(n,5)) \<union> weak(n,5) \<rightarrow> 7+\<^sub>\<omega>n \<union> (7+\<^sub>\<omega>n - 7)"
    unfolding rensep_def
    using union_fun_type  sep_var_type \<open>n\<in>nat\<close> sep_env_type weak_equal
    by force
  then
  show ?thesis using rensep_aux \<open>n\<in>nat\<close> by auto
qed

lemma rensep_action :
  assumes "[t,p,u,P,leq,o,pi] @ env \<in> list(M)"
  shows "\<forall> i . i < 7+\<^sub>\<omega>length(env) \<longrightarrow> nth(rensep(length(env))`i,[t,p,u,P,leq,o,pi]@env) = nth(i,[p,P,leq,o,t] @ env @ [pi,u])"
proof -
  let ?tgt="[t,p,u,P,leq,o,pi]@env"
  let ?src="[p,P,leq,o,t] @ env @ [pi,u]"
  let ?m="7 +\<^sub>\<omega> length(env) - weak(length(env),5)"
  let ?p="weak(length(env),5)"
  let ?f="sep_var(length(env))"
  let ?g="sep_env(length(env))"
  let ?n="length(env)"
  from assms
  have 1 : "[t,p,u,P,leq,o,pi] \<in> list(M)" " env \<in> list(M)"
    "?src \<in> list(M)" "?tgt \<in> list(M)"
    "7+\<^sub>\<omega>?n = (7+\<^sub>\<omega>?n-weak(?n,5)) \<union> weak(?n,5)"
    " length(?src) = (7+\<^sub>\<omega>?n-weak(?n,5)) \<union> weak(?n,5)"
    using Diff_partition le_imp_subset rensep_aux by auto
  then
  have "nth(i, ?src) = nth(union_fun(?f, ?g, ?m, ?p) ` i, ?tgt)" if "i < 7+\<^sub>\<omega>length(env)" for i
  proof -
    from \<open>i<7+\<^sub>\<omega>?n\<close>
    have "i \<in> (7+\<^sub>\<omega>?n-weak(?n,5)) \<union> weak(?n,5)"
      using ltD by simp
    then show ?thesis
      unfolding rensep_def using
        union_fun_action[OF \<open>?src\<in>list(M)\<close> \<open>?tgt\<in>list(M)\<close> \<open>length(?src) = (7+\<^sub>\<omega>?n-weak(?n,5)) \<union> weak(?n,5)\<close>
          sep_var_action[OF \<open>[t,p,u,P,leq,o,pi] \<in> list(M)\<close> \<open>env\<in>list(M)\<close>]
          sep_env_action[OF \<open>[t,p,u,P,leq,o,pi] \<in> list(M)\<close> \<open>env\<in>list(M)\<close>]
          ] that
      by simp
  qed
  then show ?thesis unfolding rensep_def by simp
qed

definition sep_ren :: "[i,i] \<Rightarrow> i" where
  "sep_ren(n,\<phi>) \<equiv> ren(\<phi>)`(7+\<^sub>\<omega>n)`(7+\<^sub>\<omega>n)`rensep(n)"

lemma arity_rensep: assumes "\<phi>\<in>formula" "env \<in> list(M)"
  "arity(\<phi>) \<le> 7+\<^sub>\<omega>length(env)"
shows "arity(sep_ren(length(env),\<phi>)) \<le> 7+\<^sub>\<omega>length(env)"
  unfolding sep_ren_def
  using arity_ren rensep_type assms
  by simp

lemma type_rensep [TC]:
  assumes "\<phi>\<in>formula" "env\<in>list(M)"
  shows "sep_ren(length(env),\<phi>) \<in> formula"
  unfolding sep_ren_def
  using ren_tc rensep_type assms
  by simp

lemma sepren_action:
  assumes "arity(\<phi>) \<le> 7 +\<^sub>\<omega> length(env)"
    "[t,p,u,P,leq,o,pi] \<in> list(M)"
    "env\<in>list(M)"
    "\<phi>\<in>formula"
  shows "sats(M, sep_ren(length(env),\<phi>),[t,p,u,P,leq,o,pi] @ env) \<longleftrightarrow> sats(M, \<phi>,[p,P,leq,o,t] @ env @ [pi,u])"
proof -
  from assms
  have 1: "[t, p, u, P, leq, o, pi] @ env \<in> list(M)"
    by simp_all
  then
  have 2: "[p,P,leq,o,t] @ env @ [pi,u] \<in> list(M)"
    using app_type by simp
  show ?thesis
    unfolding sep_ren_def
    using sats_iff_sats_ren[OF \<open>\<phi>\<in>formula\<close>
        add_type[of 7 "length(env)"]
        add_type[of 7 "length(env)"]
        2 1
        rensep_type[OF length_type[OF \<open>env\<in>list(M)\<close>]]
        \<open>arity(\<phi>) \<le> 7 +\<^sub>\<omega> length(env)\<close>]
      rensep_action[OF 1,rule_format,symmetric]
    by simp
qed

end


(*  Title:      HOL/Library/Code_Target_Numeral_Float.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Preprocessor setup for floats implemented by target language numerals\<close>

theory Code_Target_Numeral_Float
imports Float Code_Target_Numeral
begin

lemma numeral_float_computation_unfold [code_computation_unfold]:
  \<open>numeral k = Float (int_of_integer (Code_Numeral.positive k)) 0\<close>
  \<open>- numeral k = Float (int_of_integer (Code_Numeral.negative k)) 0\<close>
  by (simp_all add: Float.compute_float_numeral Float.compute_float_neg_numeral)

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Soft types for HOL\<close>
theory Soft_Types_HOL
  imports
    HOL.HOL
    Implicit_Arguments
    "HOL-Eisbach.Eisbach"
  keywords
    "opaque" :: thy_decl and
    "soft_type_translation" :: thy_goal_stmt and
    "print_opaque_terms" "print_types" :: diag
begin

text \<open>This theory introduces a generic notion of soft types based on HOL
predicates. It contains the basic definitions and technical tool setup.\<close>

text \<open>Remove conflicting HOL-specific syntax.\<close>

bundle HOL_ascii_syntax
begin
notation (ASCII)
  Not ("~ _" [40] 40) and
  conj (infixr "&" 35) and
  disj (infixr "|" 30) and
  implies (infixr "-->" 25) and
  not_equal (infixl "~=" 50)
syntax "_Let" :: "[letbinds, 'a] \<Rightarrow> 'a" ("(let (_)/ in (_))" 10)
end
bundle no_HOL_ascii_syntax
begin
no_notation (ASCII)
  Not ("~ _" [40] 40) and
  conj (infixr "&" 35) and
  disj (infixr "|" 30) and
  implies (infixr "-->" 25) and
  not_equal (infixl "~=" 50)
no_syntax "_Let" :: "[letbinds, 'a] \<Rightarrow> 'a" ("(let (_)/ in (_))" 10)
end

unbundle no_HOL_ascii_syntax

subsection \<open>Basic type judgments\<close>

text \<open>Soft types are "just" predicates wrapped up in a constructor.\<close>

typedecl 'a type

axiomatization
  type :: \<open>('a \<Rightarrow> bool) \<Rightarrow> 'a type\<close> and
  adj :: \<open>('a \<Rightarrow> bool) \<Rightarrow> 'a type \<Rightarrow> 'a type\<close>  and
  has_type :: \<open>'a \<Rightarrow> 'a type \<Rightarrow> bool\<close>
where
  meaning_of_adj: "has_type x (adj P T) \<equiv> P x \<and> has_type x T" and
  meaning_of_type: "has_type x (type P) \<equiv> P x"

bundle soft_type_base_syntax
begin notation adj (infixr "\<sqdot>" \<comment>\<open>\<sqdot>\<close> 56) and has_type (infix ":" 45) end
bundle no_soft_type_base_syntax
begin no_notation adj (infixr "\<sqdot>" \<comment>\<open>\<sqdot>\<close> 56) and has_type (infix ":" 45) end

unbundle soft_type_base_syntax

abbreviation (input) "type_pred T x \<equiv> x : T"

lemma has_typeI: "P x \<Longrightarrow> x : type P"
  unfolding meaning_of_type by assumption

lemma has_typeD: "x : type P \<Longrightarrow> P x"
  unfolding meaning_of_type by assumption

lemma has_typeE:
  assumes "x : type P"
  obtains "P x"
  using assms unfolding meaning_of_type by auto

lemma has_adjI: "\<lbrakk>P x; x : T\<rbrakk> \<Longrightarrow> x : P \<sqdot> T"
  unfolding meaning_of_adj by auto

lemma
  has_adjD1: "x : P \<sqdot> T \<Longrightarrow> P x" and
  has_adjD2: "x : P \<sqdot> T \<Longrightarrow> x : T"
  unfolding meaning_of_adj by auto

lemma has_adjE:
  "\<lbrakk>x: P \<sqdot> T; \<lbrakk>P x; x : T\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding meaning_of_adj by auto

subsection \<open>Type-Bounded quantifiers\<close>

definition tball :: "'a type \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "tball A P \<equiv> (\<forall>x. x : A \<longrightarrow> P x)"

definition tbex :: "'a type \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "tbex A P \<equiv> (\<exists>x. x : A \<and> P x)"

bundle soft_types_bounded_quantifiers_syntax
begin
syntax
  "_tball"  :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close> ("(2\<forall>_ : _./ _)" 10)
  "_tball2" :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close>
  "_tbex"   :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close> ("(2\<exists>_ : _./ _)" 10)
  "_tbex2"  :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close>
end
bundle no_soft_types_bounded_quantifiers_syntax
begin
no_syntax
  "_tball"  :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close> ("(2\<forall>_ : _./ _)" 10)
  "_tball2" :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close>
  "_tbex"   :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close> ("(2\<exists>_ : _./ _)" 10)
  "_tbex2"  :: \<open>[idts, 'a type, bool] \<Rightarrow> bool\<close>
end
unbundle soft_types_bounded_quantifiers_syntax

translations
  "\<forall>x xs : A. P" \<rightharpoonup> "CONST tball A (\<lambda>x. _tball2 xs A P)"
  "_tball2 x A P" \<rightharpoonup> "\<forall>x : A. P"
  "\<forall>x : A. P" \<rightleftharpoons> "CONST tball A (\<lambda>x. P)"

  "\<exists>x xs : A. P" \<rightharpoonup> "CONST tbex A (\<lambda>x. _tbex2 xs A P)"
  "_tbex2 x A P" \<rightharpoonup> "\<exists>x : A. P"
  "\<exists>x : A. P" \<rightleftharpoons> "CONST tbex A (\<lambda>x. P)"

text\<open>Setup of one point rules.\<close>

simproc_setup defined_bex ("\<exists>x : A. P x \<and> Q x") =
  \<open>fn _ => Quantifier1.rearrange_Bex
    (fn ctxt => unfold_tac ctxt @{thms tbex_def})\<close>

simproc_setup defined_ball ("\<forall>x : A. P x \<longrightarrow> Q x") =
  \<open>fn _ => Quantifier1.rearrange_Ball
    (fn ctxt => unfold_tac ctxt @{thms tball_def})\<close>

lemma tballI [intro!]: "(\<And>x. x : A \<Longrightarrow> P x) \<Longrightarrow> \<forall>x : A. P x"
  unfolding tball_def by auto

lemma tballE [elim!]:
  assumes "\<forall>x : A. P x"
  obtains "\<And>x. x : A \<Longrightarrow> P x"
  using assms unfolding tball_def by auto

lemma tballD [elim]: "\<lbrakk>\<forall>x : A. P x; x : A\<rbrakk> \<Longrightarrow> P x"
  unfolding tball_def by auto

lemma tball_iff_ex_has_type [simp]: "(\<forall>x : A. P) \<longleftrightarrow> ((\<exists>x. x : A) \<longrightarrow> P)"
  by (simp add: tball_def)

lemma tball_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x : A' \<Longrightarrow> P x \<longleftrightarrow> P' x\<rbrakk> \<Longrightarrow> (\<forall>x : A. P x) \<longleftrightarrow> (\<forall>x : A'. P' x)"
  by (simp add: tball_def)

lemma tball_or_iff_tball_or [simp]: "(\<forall>x : A. P x \<or> Q) \<longleftrightarrow> ((\<forall>x : A. P x) \<or> Q)"
  by auto

lemma tball_or_iff_or_tball [simp]: "(\<forall>x : A. P \<or> Q x) \<longleftrightarrow> (P \<or> (\<forall>x : A. Q x))"
  by auto

lemma tball_imp_iff_imp_tball [simp]: "(\<forall>x : A. P \<longrightarrow> Q x) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x : A. Q x))"
  by auto

lemma atomize_tball: "(\<And>x. x : A \<Longrightarrow> P x) \<equiv> Trueprop (\<forall>x : A. P x)"
  by (simp only: tball_def atomize_all atomize_imp)

declare atomize_tball[symmetric, rulify]
declare atomize_tball[symmetric, defn]

lemma tbexI [intro]: "\<lbrakk>x : A; P x\<rbrakk> \<Longrightarrow> \<exists>x : A. P x"
  unfolding tbex_def by auto

lemma tbexE [elim!]:
  assumes "\<exists>x : A. P x"
  obtains x where "x : A" and "P x"
  using assms unfolding tbex_def by auto

lemma tbex_iff_ex_and [simp]: "(\<exists>x : A. P) \<longleftrightarrow> ((\<exists>x. x : A) \<and> P)"
  unfolding tbex_def by simp

lemma tbex_cong [cong]:
  "\<lbrakk>A = A'; \<And>x. x : A' \<Longrightarrow> P x \<longleftrightarrow> P' x\<rbrakk> \<Longrightarrow> (\<exists>x : A. P x) \<longleftrightarrow> (\<exists>x : A'. P' x)"
  unfolding tbex_def by (simp cong: conj_cong)

lemma tbex_and_iff_tbex_and [simp]: "(\<exists>x : A. P x \<and> Q) \<longleftrightarrow> ((\<exists>x : A. P x) \<and> Q)"
  by auto

lemma tbex_and_iff_or_tbex [simp]: "(\<exists>x : A. P \<and> Q x) \<longleftrightarrow> (P \<and> (\<exists>x : A. Q x))"
  by auto

lemma tball_imp_iff_tbex_imp [simp]: "(\<forall>x : A. P x \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x : A. P x) \<longrightarrow> Q)"
  by auto

lemma not_tball_iff_tbex_not [simp]: "(\<not>(\<forall>x : A. P x)) \<longleftrightarrow> (\<exists>x : A. \<not>P x)"
  by auto

lemma not_tbex_iff_tball_not [simp]: "(\<not>(\<exists>x : A. P x)) \<longleftrightarrow> (\<forall>x : A. \<not>P x)"
  by auto

subsection \<open>Low-level soft type methods\<close>

(*FUTURE: Dedicated keyword setup for soft type declarations should go here*)

text \<open>Unfold all type information to work only in the underlying theory:\<close>

named_theorems typedef \<comment>\<open>soft type definitions\<close>
named_theorems type_intro \<comment>\<open>soft type introduction rules\<close>
  (*FUTURE: This should be kept for typechecking, so only introduction rules
    whose premises and conclusion are type judgments should be declared*)

method unfold_types =
  (rule type_intro
  |simp_all only: typedef meaning_of_type meaning_of_adj tball_def tbex_def)+

subsection \<open>Dependent Function/Pi-Types (\<Pi>-Types)\<close>

text \<open>Dependent function soft type for HOL lambda terms.\<close>

definition Dep_fun_type :: "'a type \<Rightarrow> ('a \<Rightarrow> 'b type) \<Rightarrow> ('a \<Rightarrow> 'b) type"
  where [typedef]: "Dep_fun_type A B \<equiv> type (\<lambda>f. \<forall>x : A. f x : B x)"

abbreviation "Fun_type A B \<equiv> Dep_fun_type A (\<lambda>_. B)"

bundle soft_types_functions_syntax
begin
syntax
  "_functions_telescope" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<Rightarrow>" 50)
end
bundle no_soft_types_functions_syntax
begin
no_syntax
  "_functions_telescope" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<Rightarrow>" 50)
end
unbundle soft_types_functions_syntax

translations
  "(x y : A) \<Rightarrow> B" \<rightharpoonup> "(x : A)(y : A) \<Rightarrow> B"
  "(x : A) args \<Rightarrow> B" \<rightleftharpoons> "(x : A) \<Rightarrow> args \<Rightarrow> B"
  "(x : A) \<Rightarrow> B" \<rightleftharpoons> "CONST Dep_fun_type A (\<lambda>x. B)"
  "A \<Rightarrow> B" \<rightleftharpoons> "CONST Fun_type A B"

lemma Dep_fun_typeI [type_intro]:
  "(\<And>x. x : A \<Longrightarrow> f x : B x) \<Longrightarrow> f : (x : A) \<Rightarrow> B x"
  unfolding Dep_fun_type_def meaning_of_type by auto

lemma Dep_fun_typeE:
  "\<lbrakk>f : (x : A) \<Rightarrow> B x; x : A\<rbrakk> \<Longrightarrow> f x : B x"
  unfolding Dep_fun_type_def meaning_of_type by auto

lemma Dep_fun_contravariant_dom:
  "\<lbrakk>f : (x : A) \<Rightarrow> B x; \<And>x. x : A' \<Longrightarrow> x : A\<rbrakk> \<Longrightarrow> f : (x : A') \<Rightarrow> B x"
  unfolding Dep_fun_type_def meaning_of_type by auto

lemma Dep_fun_covariant_codom:
  assumes "f : (x : A) \<Rightarrow> B x"
  and "\<And>x. x : A \<Longrightarrow> f x : B x \<Longrightarrow> f x : B' x"
  shows "f : (x : A) \<Rightarrow> B' x"
  using assms unfolding Dep_fun_type_def meaning_of_type by auto

subsection \<open>Intersection and Union Types\<close>

definition [typedef]: "Int_type A B \<equiv> type (\<lambda>x. x : A \<and> x : B)"

bundle soft_type_Int_type_syntax
begin notation Int_type (infixl "&" 55) end
bundle no_soft_type_Int_type_syntax
begin no_notation Int_type (infixl "&" 55) end

unbundle soft_type_Int_type_syntax

lemma
  Int_typeI [type_intro]: "x : A \<Longrightarrow> x : B \<Longrightarrow> x : A & B" and
  Int_typeD1: "x : A & B \<Longrightarrow> x : A" and
  Int_typeD2: "x : A & B \<Longrightarrow> x : B" and
  Int_type_covariant_left: "x : A & B \<Longrightarrow> (x : A \<Longrightarrow> x : A') \<Longrightarrow> x : A' & B" and
  Int_type_covariant_right: "x : A & B \<Longrightarrow> (x : B \<Longrightarrow> x : B') \<Longrightarrow> x : A & B'"
  by unfold_types

lemma Int_typeE:
  assumes "x : A & B"
  obtains "x : A" "x : B"
  using assms unfolding Int_type_def by unfold_types

definition [typedef]: "Union_type A B \<equiv> type (\<lambda>x. x : A \<or> x : B)"

bundle soft_type_Union_type_syntax
begin notation Union_type (infixl "\<bar>" 55) end
bundle no_soft_type_Union_type_syntax
begin no_notation Union_type (infixl "\<bar>" 55) end

unbundle soft_type_Union_type_syntax

lemma
  Union_type_leftI: "x : A \<Longrightarrow> x : A \<bar> B" and
  Union_type_rightI: "x : B \<Longrightarrow> x : A \<bar> B" and
  Union_typeD: "x : A \<bar> B \<Longrightarrow> x : A \<or> x : B" and
  Union_type_covariant_left: "x : A \<bar> B \<Longrightarrow> (x : A \<Longrightarrow> x : A') \<Longrightarrow> x : A' \<bar> B" and
  Union_type_covariant_right: "x : A \<bar> B \<Longrightarrow> (x : B \<Longrightarrow> x : B') \<Longrightarrow> x : A \<bar> B'"
  by unfold_types auto

lemma Union_typeE:
  assumes "x : A \<bar> B"
  obtains (left) "x : A" | (right) "x : B"
  using assms by (auto dest: Union_typeD)

subsection \<open>The Any type\<close>

text \<open>Used, for example, to reflect rigid types back into the soft type system.\<close>

definition Any_type :: "'a type" ("Any")
  where [typedef]: "Any \<equiv> type (\<lambda>_. True)"

lemma Any_typeI [type_intro]: "x : Any"
  by unfold_types

abbreviation Bool_type :: "bool type" ("Bool")
  where "Bool \<equiv> Any"

lemma tball_Any_iff_ball [simp]: "(\<forall>x : Any. P x) \<longleftrightarrow> (\<forall>x. P x)"
  by (auto intro: Any_typeI)

lemma tbex_Any_iff_ex [simp]: "(\<exists>x : Any. P x) \<longleftrightarrow> (\<exists>x. P x)"
  by (auto intro: Any_typeI)

subsection \<open>Type annotations\<close>

definition with_type :: "'a \<Rightarrow> 'a type \<Rightarrow> 'a"
  where "with_type x A \<equiv> x"

bundle soft_type_with_type_syntax
begin notation with_type (infixl ":>" 50) end
bundle no_soft_type_with_type_syntax
begin no_notation with_type (infixl ":>" 50) end

unbundle soft_type_with_type_syntax

text \<open>
\<^term>\<open>x :> A\<close> annotates \<^term>\<open>x\<close> with type \<^term>\<open>A\<close>, and is used by automated
tools to represent additional typing information in a term.
\<close>

subsection \<open>Tooling and automation\<close>

declare atomize_conjL [symmetric, rulify]
  \<comment>\<open>Used in normalization of type judgments.\<close>

named_theorems type_simp \<comment>\<open>For type elaboration\<close>
named_theorems type_instance \<comment>\<open>For type class reasoning\<close>

named_theorems derivation_rules
named_theorems backderivation_rules
(* named_theorems subtype_rules *) \<comment>\<open>Unused, for now\<close>

text \<open>
@{thm derivation_rules}, @{thm backderivation_rules} \<open>(*and @{thm subtype_rules}*)\<close>
should only be inspected and not assigned to directly; use the \<open>derive\<close>,
\<open>backward_derive\<close> \<open>(*and \<open>subtype\<close>*)\<close> attributes instead.
\<close>

(* Enable this when debugging exceptions:
declare [[ML_debugger, ML_exception_debugger]]
*)

ML_file \<open>soft_type.ML\<close>
ML_file \<open>soft_type_context.ML\<close>
ML_file \<open>derivation.ML\<close>

subsubsection \<open>Type derivation\<close>

method_setup raw_discharge_type =
  \<open>Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Scan.repeat Args.term) []
    >> (fn add_tms => fn ctxt => SIMPLE_METHOD (
      HEADGOAL (Derivation.raw_discharge_type_tac [] add_tms ctxt)))\<close>

method_setup discharge_types =
  \<open>Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Scan.repeat Args.term) []
    >> (fn add_tms => fn ctxt => SIMPLE_METHOD (
      REPEAT1 (CHANGED (ALLGOALS (TRY o (
        Derivation.full_discharge_types_tac [] add_tms ctxt))))))\<close>

ML \<open>
val soft_type_simp_solver =
  let
    fun solver ctxt i =
      (if Config.get ctxt Derivation.debug
      then print_tac ctxt ("type derivation called on subgoal " ^ string_of_int i)
      else all_tac)
      THEN
      (SUBGOAL (fn (_, j) =>
        Derivation.full_discharge_types_tac (Simplifier.prems_of ctxt) [] ctxt j)) i
  in
    map_theory_simpset (fn ctxt => ctxt
      addSolver (mk_solver "discharge_types" solver))
  end
\<close>

setup \<open>soft_type_simp_solver\<close>

ML_file \<open>unification.ML\<close>
ML_file \<open>type_classes.ML\<close>
ML_file \<open>elaboration.ML\<close>
ML_file \<open>isar_integration.ML\<close>

setup \<open>Isar_Integration.setup\<close>

declare with_type_def [type_simp]

subsection \<open>Basic declarations\<close>

declare Any_typeI [type]
declare Dep_fun_typeI [backward_derive]
declare Dep_fun_typeE [derive]

lemma eq_type [type]: "(=) : A \<Rightarrow> A \<Rightarrow> Bool"
  by discharge_types

lemma imp_type [type]: "(\<longrightarrow>) : Bool \<Rightarrow> Bool \<Rightarrow> Bool"
  by discharge_types

lemma const_fun_type [derive]: "c : C \<Longrightarrow> (\<lambda>a. c) : A \<Rightarrow> C"
  by discharge_types

lemma id_type [type]: "(\<lambda>x. x) : A \<Rightarrow> A"
  by discharge_types

lemma if_type [type]: "If : Bool \<Rightarrow> A \<Rightarrow> A \<Rightarrow> A"
  by unfold_types auto

end


theory WordArrayMono
  imports
    WordArrayValue
    Cogent.Mono
    MonoHelper
begin

section "Word Array Methods"

subsection "wordarray_length"

lemma (in WordArrayValue) vwa_length_monoexpr_correct:
  "\<And>v v'.
       vwa_length (rename_val rename' (monoval v)) v'
       \<Longrightarrow> \<exists>v''. v' = rename_val rename' (monoval v'') \<and> vwa_length v v''"
  apply (clarsimp simp: vwa_length_def)
  apply (case_tac v; clarsimp)
  done

subsection "wordarray_get"

lemma (in WordArrayValue) vwa_get_monoexpr_correct:
  "\<And>v v'.
       vwa_get (rename_val rename' (monoval v)) v'
       \<Longrightarrow> \<exists>v''. v' = rename_val rename' (monoval v'') \<and> vwa_get v v''"
  apply (clarsimp simp: vwa_get_def)
  apply (case_tac v; clarsimp)
  apply (rename_tac z za zb)
  apply (case_tac z; clarsimp)
  apply (case_tac za; clarsimp)
  apply (clarsimp split: if_splits)
   apply (rule_tac x = "xs ! unat i" in exI)
   apply (clarsimp simp: no_vfuns_rename_monoval)
   apply fastforce
  apply (rule_tac x = zb in exI)
  apply (clarsimp simp: no_vfuns_rename_monoval)
  apply (rule exI, rule exI, rule_tac x = i in exI, intro exI conjI impI; simp?)
  apply (clarsimp simp: rename_monoval_no_vfuns)
  done

subsection "wordarray_put"

lemma (in WordArrayValue) vwa_put_monoexpr_correct:
  "\<And>v v'.
       vwa_put (rename_val rename' (monoval v)) v'
       \<Longrightarrow> \<exists>v''. v' = rename_val rename' (monoval v'') \<and> vwa_put v v''"
  apply (clarsimp simp: vwa_put_def)
  apply (case_tac v; clarsimp)
  apply (rename_tac z za zb)
  apply (case_tac z; clarsimp)
  apply (case_tac za; clarsimp)
  apply (clarsimp simp: rename_monoval_no_vfuns[THEN no_vfuns_rename_monoval] rename_monoval_no_vfuns)
  done

subsection "wordarray_get_opt"

lemma (in WordArrayValue) vwa_get_opt_monoexpr_correct:
  "\<And>v v'.
       vwa_get_opt (rename_val rename' (monoval v)) v'
       \<Longrightarrow> \<exists>v''. v' = rename_val rename' (monoval v'') \<and> vwa_get_opt v v''"
  apply (clarsimp simp: vwa_get_opt_def)
  apply (case_tac v; clarsimp)
  apply (rename_tac v' t xs i z za)
  apply (case_tac z; clarsimp)
  apply (case_tac za; clarsimp)
  apply (clarsimp split: if_splits)
   apply (rule_tac x = " VSum ''Something'' (xs ! unat i)" in exI)
   apply (clarsimp simp: no_vfuns_rename_monoval)
   apply fastforce
  apply (rule_tac x = "VSum ''Nothing'' VUnit" in exI)
  apply (clarsimp simp: no_vfuns_rename_monoval)
  apply (rule exI, rule exI, rule_tac x = i in exI, intro exI conjI impI; simp?)
  done

end


theory Impl_List_Playground_ChairNetwork
imports "../TopoS_Impl"
begin

text\<open>An example of our chair network [simplified]\<close>

text\<open>Our access control view on the network\<close>
  definition ChairNetwork_empty :: "string list_graph" where
    "ChairNetwork_empty \<equiv> \<lparr> nodesL = [''WebSrv'', ''FilesSrv'', ''PrinterBW'',
                                ''PrinterColor'', ''Students'',
                                ''Employees'', ''EReachable'',
                                ''Internet''],
                      edgesL = [] \<rparr>"

  lemma "wf_list_graph ChairNetwork_empty" by eval

subsection\<open>Our security requirements\<close>
  subsubsection\<open>We have a server with confidential data\<close>
    definition ConfidentialChairData::"(string SecurityInvariant)" where
      "ConfidentialChairData \<equiv> new_configured_list_SecurityInvariant SINVAR_BLPtrusted_impl.SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = [''FilesSrv'' \<mapsto> \<lparr> security_level = 1, trusted = False \<rparr>,
                             ''Employees'' \<mapsto> \<lparr> security_level = 0, trusted = True \<rparr>,
                             ''EReachable'' \<mapsto> \<lparr> security_level = 0, trusted = True \<rparr>]
          \<rparr> ''confidential data''"

  (*
  subsubsection{*We have a hierarchical printing policy*}
    definition "PrintingHierarchy_nodes=[''Employees''\<mapsto> DN (''ColorPrinting''--Leaf, 0),
                           ''PrinterColor''\<mapsto> DN (''ColorPrinting''--''Printer''--Leaf, 0),
                           ''Students''\<mapsto> DN (''ColorPrinting''--''BwPrinting''--Leaf, 0),
                           ''PrinterBW''\<mapsto> DN (''ColorPrinting''--''BwPrinting''--''Printer''--Leaf, 0)]"
    definition "PrintingHierarchy_tree=Department ''ColorPrinting'' [
              Department ''Printer'' [],
              Department ''BwPrinting'' [
                  Department ''Printer'' []]]"
    definition PrintingHierarchy::"string SecurityInvariant" where
      "PrintingHierarchy \<equiv> new_configured_list_SecurityInvariant SINVAR_DomainHierarchyNG_impl.SINVAR_LIB_DomainHierarchyNG \<lparr>
        node_properties = PrintingHierarchy_nodes
        \<rparr>"  *)
  subsubsection\<open>The color printer is only accessibly by employees, The black.white printer by employees and students\<close>
    definition "PrintingACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''PrinterColor'' \<mapsto> Master [''Employees'', ''EReachable''],
                             ''PrinterBW'' \<mapsto> Master [''Employees'', ''EReachable'', ''Students''],
                             ''Employees'' \<mapsto> Care,
                             ''EReachable'' \<mapsto> Care,
                             ''Students'' \<mapsto> Care]
          \<rparr> ''printing ACL''"

  subsubsection\<open>Printers are information sinks\<close>
    definition "PrintingSink \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_Sink \<lparr>
          node_properties = [''PrinterColor'' \<mapsto> Sink,
                             ''PrinterBW'' \<mapsto> Sink]
          \<rparr> ''printing sink''"

  subsubsection\<open>Students may access each other but are not accessible from the outside\<close>
    definition "StudentSubnet \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = [''Students'' \<mapsto> Member, ''Employees'' \<mapsto> Member, ''EReachable'' \<mapsto> InboundGateway]
          \<rparr> ''student subnet''"

  subsubsection\<open>The files server is only accessibly by employees\<close>
    definition "FilesSrvACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''FilesSrv'' \<mapsto> Master [''Employees'', ''EReachable''],
                             ''Employees'' \<mapsto> Care,
                             ''EReachable'' \<mapsto> Care]
          \<rparr> ''file srv acl''"

  subsubsection\<open>emplyees are reachable from the Internet\<close>
    (*nothing to do here*)

lemma "implc_sinvar ConfidentialChairData ChairNetwork_empty" by eval
lemma "implc_sinvar PrintingACL ChairNetwork_empty" by eval
lemma "implc_sinvar PrintingSink ChairNetwork_empty" by eval
lemma "implc_sinvar StudentSubnet ChairNetwork_empty" by eval
lemma "implc_sinvar FilesSrvACL ChairNetwork_empty" by eval

definition "ChairSecurityRequirements = [ConfidentialChairData, PrintingACL, PrintingSink, StudentSubnet, FilesSrvACL]"

value "implc_get_offending_flows ChairSecurityRequirements ChairNetwork_empty"
value "generate_valid_topology ChairSecurityRequirements ChairNetwork_empty"

value "List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty)"

definition "ChairNetwork = generate_valid_topology ChairSecurityRequirements
      \<lparr>nodesL = nodesL ChairNetwork_empty, edgesL = List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty) \<rparr>"

lemma "all_security_requirements_fulfilled ChairSecurityRequirements ChairNetwork" by eval

value "ChairNetwork"

ML_val\<open>
visualize_graph @{context} @{term "ChairSecurityRequirements"} @{term "ChairNetwork"};
\<close>

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory longlong
imports "CParser.CTranslation"
begin

external_file "longlong.c"
install_C_file "longlong.c"

ML \<open>NameGeneration.return_var_name (Absyn.Signed Absyn.LongLong)\<close>

context longlong
begin

thm f_body_def
thm shifts1_body_def
thm shifts2_body_def

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
  by simp

lemma "(scast :: 16 word \<Rightarrow> 8 word) 32768 = 0"
  by simp

lemma "(scast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
  by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 65535 = 255"
  by simp

lemma "(ucast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp
lemma "(scast :: 16 word \<Rightarrow> 8 word) 32767 = 255" by simp

lemma "(scast :: 8 word \<Rightarrow> 16 word) 255 = 65535" by simp
lemma "(ucast :: 8 word \<Rightarrow> 16 word) 255 = 255" by simp

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL callg() \<lbrace> \<acute>ret__int = 0 \<rbrace>"
  by vcg (simp add: mask_def)

thm literals_body_def

lemma literals_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL literals() \<lbrace> \<acute>ret__int = 31 \<rbrace>"
  by vcg simp

end (* context *)

end (* theory *)