section {* The Proof System *}

theory RG_Hoare imports RG_Tran begin

subsection {* Proof System for Component Programs *}

declare Un_subset_iff [simp del] sup.bounded_iff [simp del]

definition stable :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool" where
  "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"

inductive
  rghoare :: "['a com, 'a set, ('a \<times> 'a) set, ('a \<times> 'a) set, 'a set] \<Rightarrow> bool"
    ("\<turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
where
  Basic: "\<lbrakk> pre \<subseteq> {s. f s \<in> post}; {(s,t). s \<in> pre \<and> (t=f s \<or> t=s)} \<subseteq> guar;
            stable pre rely; stable post rely \<rbrakk>
           \<Longrightarrow> \<turnstile> Basic f sat [pre, rely, guar, post]"

| Seq: "\<lbrakk> \<turnstile> P sat [pre, rely, guar, mid]; \<turnstile> Q sat [mid, rely, guar, post] \<rbrakk>
           \<Longrightarrow> \<turnstile> Seq P Q sat [pre, rely, guar, post]"

| Cond: "\<lbrakk> stable pre rely; \<turnstile> P1 sat [pre \<inter> b, rely, guar, post];
           \<turnstile> P2 sat [pre \<inter> -b, rely, guar, post]; \<forall>s. (s,s)\<in>guar \<rbrakk>
          \<Longrightarrow> \<turnstile> Cond b P1 P2 sat [pre, rely, guar, post]"

| While: "\<lbrakk> stable pre rely; (pre \<inter> -b) \<subseteq> post; stable post rely;
            \<turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar \<rbrakk>
          \<Longrightarrow> \<turnstile> While b P sat [pre, rely, guar, post]"

| Await: "\<lbrakk> stable pre rely; stable post rely;
            \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {V}, {(s, t). s = t},
                UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
           \<Longrightarrow> \<turnstile> Await b P sat [pre, rely, guar, post]"

| Conseq: "\<lbrakk> pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
             \<turnstile> P sat [pre', rely', guar', post'] \<rbrakk>
            \<Longrightarrow> \<turnstile> P sat [pre, rely, guar, post]"

definition Pre :: "'a rgformula \<Rightarrow> 'a set" where
  "Pre x \<equiv> fst(snd x)"

definition Post :: "'a rgformula \<Rightarrow> 'a set" where
  "Post x \<equiv> snd(snd(snd(snd x)))"

definition Rely :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set" where
  "Rely x \<equiv> fst(snd(snd x))"

definition Guar :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set" where
  "Guar x \<equiv> fst(snd(snd(snd x)))"

definition Com :: "'a rgformula \<Rightarrow> 'a com" where
  "Com x \<equiv> fst x"

subsection {* Proof System for Parallel Programs *}

type_synonym 'a par_rgformula =
  "('a rgformula) list \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"

inductive
  par_rghoare :: "('a rgformula) list \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
    ("\<turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
where
  Parallel:
  "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j<length xs \<and> j\<noteq>i}. Guar(xs!j)) \<subseteq> Rely(xs!i);
    (\<Union>j\<in>{j. j<length xs}. Guar(xs!j)) \<subseteq> guar;
     pre \<subseteq> (\<Inter>i\<in>{i. i<length xs}. Pre(xs!i));
    (\<Inter>i\<in>{i. i<length xs}. Post(xs!i)) \<subseteq> post;
    \<forall>i<length xs. \<turnstile> Com(xs!i) sat [Pre(xs!i),Rely(xs!i),Guar(xs!i),Post(xs!i)] \<rbrakk>
   \<Longrightarrow>  \<turnstile> xs SAT [pre, rely, guar, post]"

section {* Soundness*}

subsubsection {* Some previous lemmas *}

lemma tl_of_assum_in_assum:
  "(P, s) # (P, t) # xs \<in> assum (pre, rely) \<Longrightarrow> stable pre rely
  \<Longrightarrow> (P, t) # xs \<in> assum (pre, rely)"
apply(simp add:assum_def)
apply clarify
apply(rule conjI)
 apply(erule_tac x=0 in allE)
 apply(simp (no_asm_use)only:stable_def)
 apply(erule allE,erule allE,erule impE,assumption,erule mp)
 apply(simp add:Env)
apply clarify
apply(erule_tac x="Suc i" in allE)
apply simp
done

lemma etran_in_comm:
  "(P, t) # xs \<in> comm(guar, post) \<Longrightarrow> (P, s) # (P, t) # xs \<in> comm(guar, post)"
apply(simp add:comm_def)
apply clarify
apply(case_tac i,simp+)
done

lemma ctran_in_comm:
  "\<lbrakk>(s, s) \<in> guar; (Q, s) # xs \<in> comm(guar, post)\<rbrakk>
  \<Longrightarrow> (P, s) # (Q, s) # xs \<in> comm(guar, post)"
apply(simp add:comm_def)
apply clarify
apply(case_tac i,simp+)
done

lemma takecptn_is_cptn [rule_format, elim!]:
  "\<forall>j. c \<in> cptn \<longrightarrow> take (Suc j) c \<in> cptn"
apply(induct "c")
 apply(force elim: cptn.cases)
apply clarify
apply(case_tac j)
 apply simp
 apply(rule CptnOne)
apply simp
apply(force intro:cptn.intros elim:cptn.cases)
done

lemma dropcptn_is_cptn [rule_format,elim!]:
  "\<forall>j<length c. c \<in> cptn \<longrightarrow> drop j c \<in> cptn"
apply(induct "c")
 apply(force elim: cptn.cases)
apply clarify
apply(case_tac j,simp+)
apply(erule cptn.cases)
  apply simp
 apply force
apply force
done

lemma takepar_cptn_is_par_cptn [rule_format,elim]:
  "\<forall>j. c \<in> par_cptn \<longrightarrow> take (Suc j) c \<in> par_cptn"
apply(induct "c")
 apply(force elim: cptn.cases)
apply clarify
apply(case_tac j,simp)
 apply(rule ParCptnOne)
apply(force intro:par_cptn.intros elim:par_cptn.cases)
done

lemma droppar_cptn_is_par_cptn [rule_format]:
  "\<forall>j<length c. c \<in> par_cptn \<longrightarrow> drop j c \<in> par_cptn"
apply(induct "c")
 apply(force elim: par_cptn.cases)
apply clarify
apply(case_tac j,simp+)
apply(erule par_cptn.cases)
  apply simp
 apply force
apply force
done

lemma tl_of_cptn_is_cptn: "\<lbrakk>x # xs \<in> cptn; xs \<noteq> []\<rbrakk> \<Longrightarrow> xs  \<in> cptn"
apply(subgoal_tac "1 < length (x # xs)")
 apply(drule dropcptn_is_cptn,simp+)
done

lemma not_ctran_None [rule_format]:
  "\<forall>s. (None, s)#xs \<in> cptn \<longrightarrow> (\<forall>i<length xs. ((None, s)#xs)!i -e\<rightarrow> xs!i)"
apply(induct xs,simp+)
apply clarify
apply(erule cptn.cases,simp)
 apply simp
 apply(case_tac i,simp)
  apply(rule Env)
 apply simp
apply(force elim:ctran.cases)
done

lemma cptn_not_empty [simp]:"[] \<notin> cptn"
apply(force elim:cptn.cases)
done

lemma etran_or_ctran [rule_format]:
  "\<forall>m i. x\<in>cptn \<longrightarrow> m \<le> length x
   \<longrightarrow> (\<forall>i. Suc i < m \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i) \<longrightarrow> Suc i < m
   \<longrightarrow> x!i -e\<rightarrow> x!Suc i"
apply(induct x,simp)
apply clarify
apply(erule cptn.cases,simp)
 apply(case_tac i,simp)
  apply(rule Env)
 apply simp
 apply(erule_tac x="m - 1" in allE)
 apply(case_tac m,simp,simp)
 apply(subgoal_tac "(\<forall>i. Suc i < nata \<longrightarrow> (((P, t) # xs) ! i, xs ! i) \<notin> ctran)")
  apply force
 apply clarify
 apply(erule_tac x="Suc ia" in allE,simp)
apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?J j) \<notin> ctran" in allE,simp)
done

lemma etran_or_ctran2 [rule_format]:
  "\<forall>i. Suc i<length x \<longrightarrow> x\<in>cptn \<longrightarrow> (x!i -c\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i)
  \<or> (x!i -e\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i)"
apply(induct x)
 apply simp
apply clarify
apply(erule cptn.cases,simp)
 apply(case_tac i,simp+)
apply(case_tac i,simp)
 apply(force elim:etran.cases)
apply simp
done

lemma etran_or_ctran2_disjI1:
  "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -c\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i"
by(drule etran_or_ctran2,simp_all)

lemma etran_or_ctran2_disjI2:
  "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -e\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i"
by(drule etran_or_ctran2,simp_all)

lemma not_ctran_None2 [rule_format]:
  "\<lbrakk> (None, s) # xs \<in>cptn; i<length xs\<rbrakk> \<Longrightarrow> \<not> ((None, s) # xs) ! i -c\<rightarrow> xs ! i"
apply(frule not_ctran_None,simp)
apply(case_tac i,simp)
 apply(force elim:etranE)
apply simp
apply(rule etran_or_ctran2_disjI2,simp_all)
apply(force intro:tl_of_cptn_is_cptn)
done

lemma Ex_first_occurrence [rule_format]: "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i<m. \<not> P i))"
apply(rule nat_less_induct)
apply clarify
apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
apply auto
done

lemma stability [rule_format]:
  "\<forall>j k. x \<in> cptn \<longrightarrow> stable p rely \<longrightarrow> j\<le>k \<longrightarrow> k<length x \<longrightarrow> snd(x!j)\<in>p  \<longrightarrow>
  (\<forall>i. (Suc i)<length x \<longrightarrow>
          (x!i -e\<rightarrow> x!(Suc i)) \<longrightarrow> (snd(x!i), snd(x!(Suc i))) \<in> rely) \<longrightarrow>
  (\<forall>i. j\<le>i \<and> i<k \<longrightarrow> x!i -e\<rightarrow> x!Suc i) \<longrightarrow> snd(x!k)\<in>p \<and> fst(x!j)=fst(x!k)"
apply(induct x)
 apply clarify
 apply(force elim:cptn.cases)
apply clarify
apply(erule cptn.cases,simp)
 apply simp
 apply(case_tac k,simp,simp)
 apply(case_tac j,simp)
  apply(erule_tac x=0 in allE)
  apply(erule_tac x="nat" and P="\<lambda>j. (0\<le>j) \<longrightarrow> (?J j)" in allE,simp)
  apply(subgoal_tac "t\<in>p")
   apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
    apply clarify
    apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
   apply clarify
   apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
  apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran \<longrightarrow> ?T j" in allE,simp)
  apply(simp(no_asm_use) only:stable_def)
  apply(erule_tac x=s in allE)
  apply(erule_tac x=t in allE)
  apply simp
  apply(erule mp)
  apply(erule mp)
  apply(rule Env)
 apply simp
 apply(erule_tac x="nata" in allE)
 apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
 apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
  apply clarify
  apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
 apply clarify
 apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
apply(case_tac k,simp,simp)
apply(case_tac j)
 apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
 apply(erule etran.cases,simp)
apply(erule_tac x="nata" in allE)
apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((Q, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((Q, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
 apply clarify
 apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
apply clarify
apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
done

subsection {* Soundness of the System for Component Programs *}

subsubsection {* Soundness of the Basic rule *}

lemma unique_ctran_Basic [rule_format]:
  "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s) \<longrightarrow>
  Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
  (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
apply(induct x,simp)
apply simp
apply clarify
apply(erule cptn.cases,simp)
 apply(case_tac i,simp+)
 apply clarify
 apply(case_tac j,simp)
  apply(rule Env)
 apply simp
apply clarify
apply simp
apply(case_tac i)
 apply(case_tac j,simp,simp)
 apply(erule ctran.cases,simp_all)
 apply(force elim: not_ctran_None)
apply(ind_cases "((Some (Basic f), sa), Q, t) \<in> ctran" for sa Q t)
apply simp
apply(drule_tac i=nat in not_ctran_None,simp)
apply(erule etranE,simp)
done

lemma exists_ctran_Basic_None [rule_format]:
  "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s)
  \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
apply(induct x,simp)
apply simp
apply clarify
apply(erule cptn.cases,simp)
 apply(case_tac i,simp,simp)
 apply(erule_tac x=nat in allE,simp)
 apply clarify
 apply(rule_tac x="Suc j" in exI,simp,simp)
apply clarify
apply(case_tac i,simp,simp)
apply(rule_tac x=0 in exI,simp)
done

lemma Basic_sound:
  " \<lbrakk>pre \<subseteq> {s. f s \<in> post}; {(s, t). s \<in> pre \<and> t = f s} \<subseteq> guar;
  stable pre rely; stable post rely\<rbrakk>
  \<Longrightarrow> \<Turnstile> Basic f sat [pre, rely, guar, post]"
apply(unfold com_validity_def)
apply clarify
apply(simp add:comm_def)
apply(rule conjI)
 apply clarify
 apply(simp add:cp_def assum_def)
 apply clarify
 apply(frule_tac j=0 and k=i and p=pre in stability)
       apply simp_all
   apply(erule_tac x=ia in allE,simp)
  apply(erule_tac i=i and f=f in unique_ctran_Basic,simp_all)
 apply(erule subsetD,simp)
 apply(case_tac "x!i")
 apply clarify
 apply(drule_tac s="Some (Basic f)" in sym,simp)
 apply(thin_tac "\<forall>j. ?H j")
 apply(force elim:ctran.cases)
apply clarify
apply(simp add:cp_def)
apply clarify
apply(frule_tac i="length x - 1" and f=f in exists_ctran_Basic_None,simp+)
  apply(case_tac x,simp+)
  apply(rule last_fst_esp,simp add:last_length)
 apply (case_tac x,simp+)
apply(simp add:assum_def)
apply clarify
apply(frule_tac j=0 and k="j" and p=pre in stability)
      apply simp_all
  apply(erule_tac x=i in allE,simp)
 apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
apply(case_tac "x!j")
apply clarify
apply simp
apply(drule_tac s="Some (Basic f)" in sym,simp)
apply(case_tac "x!Suc j",simp)
apply(rule ctran.cases,simp)
apply(simp_all)
apply(drule_tac c=sa in subsetD,simp)
apply clarify
apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
 apply(case_tac x,simp+)
 apply(erule_tac x=i in allE)
apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
  apply arith+
apply(case_tac x)
apply(simp add:last_length)+
done

subsubsection{* Soundness of the Await rule *}

lemma unique_ctran_Await [rule_format]:
  "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s) \<longrightarrow>
  Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
  (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
apply(induct x,simp+)
apply clarify
apply(erule cptn.cases,simp)
 apply(case_tac i,simp+)
 apply clarify
 apply(case_tac j,simp)
  apply(rule Env)
 apply simp
apply clarify
apply simp
apply(case_tac i)
 apply(case_tac j,simp,simp)
 apply(erule ctran.cases,simp_all)
 apply(force elim: not_ctran_None)
apply(ind_cases "((Some (Await b c), sa), Q, t) \<in> ctran" for sa Q t,simp)
apply(drule_tac i=nat in not_ctran_None,simp)
apply(erule etranE,simp)
done

lemma exists_ctran_Await_None [rule_format]:
  "\<forall>s i.  x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s)
  \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
apply(induct x,simp+)
apply clarify
apply(erule cptn.cases,simp)
 apply(case_tac i,simp+)
 apply(erule_tac x=nat in allE,simp)
 apply clarify
 apply(rule_tac x="Suc j" in exI,simp,simp)
apply clarify
apply(case_tac i,simp,simp)
apply(rule_tac x=0 in exI,simp)
done

lemma Star_imp_cptn:
  "(P, s) -c*\<rightarrow> (R, t) \<Longrightarrow> \<exists>l \<in> cp P s. (last l)=(R, t)
  \<and> (\<forall>i. Suc i<length l \<longrightarrow> l!i -c\<rightarrow> l!Suc i)"
apply (erule converse_rtrancl_induct2)
 apply(rule_tac x="[(R,t)]" in bexI)
  apply simp
 apply(simp add:cp_def)
 apply(rule CptnOne)
apply clarify
apply(rule_tac x="(a, b)#l" in bexI)
 apply (rule conjI)
  apply(case_tac l,simp add:cp_def)
  apply(simp add:last_length)
 apply clarify
apply(case_tac i,simp)
apply(simp add:cp_def)
apply force
apply(simp add:cp_def)
 apply(case_tac l)
 apply(force elim:cptn.cases)
apply simp
apply(erule CptnComp)
apply clarify
done

lemma Await_sound:
  "\<lbrakk>stable pre rely; stable post rely;
  \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
                 UNIV, {s. (V, s) \<in> guar} \<inter> post] \<and>
  \<Turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
                 UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
  \<Longrightarrow> \<Turnstile> Await b P sat [pre, rely, guar, post]"
apply(unfold com_validity_def)
apply clarify
apply(simp add:comm_def)
apply(rule conjI)
 apply clarify
 apply(simp add:cp_def assum_def)
 apply clarify
 apply(frule_tac j=0 and k=i and p=pre in stability,simp_all)
   apply(erule_tac x=ia in allE,simp)
  apply(subgoal_tac "x\<in> cp (Some(Await b P)) s")
  apply(erule_tac i=i in unique_ctran_Await,force,simp_all)
  apply(simp add:cp_def)
--{* here starts the different part. *}
 apply(erule ctran.cases,simp_all)
 apply(drule Star_imp_cptn)
 apply clarify
 apply(erule_tac x=sa in allE)
 apply clarify
 apply(erule_tac x=sa in allE)
 apply(drule_tac c=l in subsetD)
  apply (simp add:cp_def)
  apply clarify
  apply(erule_tac x=ia and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
  apply(erule etranE,simp)
 apply simp
apply clarify
apply(simp add:cp_def)
apply clarify
apply(frule_tac i="length x - 1" in exists_ctran_Await_None,force)
  apply (case_tac x,simp+)
 apply(rule last_fst_esp,simp add:last_length)
 apply(case_tac x, simp+)
apply clarify
apply(simp add:assum_def)
apply clarify
apply(frule_tac j=0 and k="j" and p=pre in stability,simp_all)
  apply(erule_tac x=i in allE,simp)
 apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
apply(case_tac "x!j")
apply clarify
apply simp
apply(drule_tac s="Some (Await b P)" in sym,simp)
apply(case_tac "x!Suc j",simp)
apply(rule ctran.cases,simp)
apply(simp_all)
apply(drule Star_imp_cptn)
apply clarify
apply(erule_tac x=sa in allE)
apply clarify
apply(erule_tac x=sa in allE)
apply(drule_tac c=l in subsetD)
 apply (simp add:cp_def)
 apply clarify
 apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
 apply(erule etranE,simp)
apply simp
apply clarify
apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
 apply(case_tac x,simp+)
 apply(erule_tac x=i in allE)
apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
 apply arith+
apply(case_tac x)
apply(simp add:last_length)+
done

subsubsection{* Soundness of the Conditional rule *}

lemma Cond_sound:
  "\<lbrakk> stable pre rely; \<Turnstile> P1 sat [pre \<inter> b, rely, guar, post];
  \<Turnstile> P2 sat [pre \<inter> - b, rely, guar, post]; \<forall>s. (s,s)\<in>guar\<rbrakk>
  \<Longrightarrow> \<Turnstile> (Cond b P1 P2) sat [pre, rely, guar, post]"
apply(unfold com_validity_def)
apply clarify
apply(simp add:cp_def comm_def)
apply(case_tac "\<exists>i. Suc i<length x \<and> x!i -c\<rightarrow> x!Suc i")
 prefer 2
 apply simp
 apply clarify
 apply(frule_tac j="0" and k="length x - 1" and p=pre in stability,simp+)
     apply(case_tac x,simp+)
    apply(simp add:assum_def)
   apply(simp add:assum_def)
  apply(erule_tac m="length x" in etran_or_ctran,simp+)
 apply(case_tac x, (simp add:last_length)+)
apply(erule exE)
apply(drule_tac n=i and P="\<lambda>i. ?H i \<and> (?J i,?I i)\<in> ctran" in Ex_first_occurrence)
apply clarify
apply (simp add:assum_def)
apply(frule_tac j=0 and k="m" and p=pre in stability,simp+)
 apply(erule_tac m="Suc m" in etran_or_ctran,simp+)
apply(erule ctran.cases,simp_all)
 apply(erule_tac x="sa" in allE)
 apply(drule_tac c="drop (Suc m) x" in subsetD)
  apply simp
  apply clarify
 apply simp
 apply clarify
 apply(case_tac "i\<le>m")
  apply(drule le_imp_less_or_eq)
  apply(erule disjE)
   apply(erule_tac x=i in allE, erule impE, assumption)
   apply simp+
 apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
 apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
  apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
   apply(rotate_tac -2)
   apply simp
  apply arith
 apply arith
apply(case_tac "length (drop (Suc m) x)",simp)
apply(erule_tac x="sa" in allE)
back
apply(drule_tac c="drop (Suc m) x" in subsetD,simp)
 apply clarify
apply simp
apply clarify
apply(case_tac "i\<le>m")
 apply(drule le_imp_less_or_eq)
 apply(erule disjE)
  apply(erule_tac x=i in allE, erule impE, assumption)
  apply simp
 apply simp
apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
 apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
  apply(rotate_tac -2)
  apply simp
 apply arith
apply arith
done

subsubsection{* Soundness of the Sequential rule *}

inductive_cases Seq_cases [elim!]: "(Some (Seq P Q), s) -c\<rightarrow> t"

lemma last_lift_not_None: "fst ((lift Q) ((x#xs)!(length xs))) \<noteq> None"
apply(subgoal_tac "length xs<length (x # xs)")
 apply(drule_tac Q=Q in  lift_nth)
 apply(erule ssubst)
 apply (simp add:lift_def)
 apply(case_tac "(x # xs) ! length xs",simp)
apply simp
done

lemma Seq_sound1 [rule_format]:
  "x\<in> cptn_mod \<Longrightarrow> \<forall>s P. x !0=(Some (Seq P Q), s) \<longrightarrow>
  (\<forall>i<length x. fst(x!i)\<noteq>Some Q) \<longrightarrow>
  (\<exists>xs\<in> cp (Some P) s. x=map (lift Q) xs)"
apply(erule cptn_mod.induct)
apply(unfold cp_def)
apply safe
apply simp_all
    apply(simp add:lift_def)
    apply(rule_tac x="[(Some Pa, sa)]" in exI,simp add:CptnOne)
   apply(subgoal_tac "(\<forall>i < Suc (length xs). fst (((Some (Seq Pa Q), t) # xs) ! i) \<noteq> Some Q)")
    apply clarify
    apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # zs" in exI,simp)
    apply(rule conjI,erule CptnEnv)
    apply(simp (no_asm_use) add:lift_def)
   apply clarify
   apply(erule_tac x="Suc i" in allE, simp)
  apply(ind_cases "((Some (Seq Pa Q), sa), None, t) \<in> ctran" for Pa sa t)
 apply(rule_tac x="(Some P, sa) # xs" in exI, simp add:cptn_iff_cptn_mod lift_def)
apply(erule_tac x="length xs" in allE, simp)
apply(simp only:Cons_lift_append)
apply(subgoal_tac "length xs < length ((Some P, sa) # xs)")
 apply(simp only :nth_append length_map last_length nth_map)
 apply(case_tac "last((Some P, sa) # xs)")
 apply(simp add:lift_def)
apply simp
done

lemma Seq_sound2 [rule_format]:
  "x \<in> cptn \<Longrightarrow> \<forall>s P i. x!0=(Some (Seq P Q), s) \<longrightarrow> i<length x
  \<longrightarrow> fst(x!i)=Some Q \<longrightarrow>
  (\<forall>j<i. fst(x!j)\<noteq>(Some Q)) \<longrightarrow>
  (\<exists>xs ys. xs \<in> cp (Some P) s \<and> length xs=Suc i
   \<and> ys \<in> cp (Some Q) (snd(xs !i)) \<and> x=(map (lift Q) xs)@tl ys)"
apply(erule cptn.induct)
apply(unfold cp_def)
apply safe
apply simp_all
 apply(case_tac i,simp+)
 apply(erule allE,erule impE,assumption,simp)
 apply clarify
 apply(subgoal_tac "(\<forall>j < nat. fst (((Some (Seq Pa Q), t) # xs) ! j) \<noteq> Some Q)",clarify)
  prefer 2
  apply force
 apply(case_tac xsa,simp,simp)
 apply(rename_tac list)
 apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # list" in exI,simp)
 apply(rule conjI,erule CptnEnv)
 apply(simp (no_asm_use) add:lift_def)
 apply(rule_tac x=ys in exI,simp)
apply(ind_cases "((Some (Seq Pa Q), sa), t) \<in> ctran" for Pa sa t)
 apply simp
 apply(rule_tac x="(Some Pa, sa)#[(None, ta)]" in exI,simp)
 apply(rule conjI)
  apply(drule_tac xs="[]" in CptnComp,force simp add:CptnOne,simp)
 apply(case_tac i, simp+)
 apply(case_tac nat,simp+)
 apply(rule_tac x="(Some Q,ta)#xs" in exI,simp add:lift_def)
 apply(case_tac nat,simp+)
 apply(force)
apply(case_tac i, simp+)
apply(case_tac nat,simp+)
apply(erule_tac x="Suc nata" in allE,simp)
apply clarify
apply(subgoal_tac "(\<forall>j<Suc nata. fst (((Some (Seq P2 Q), ta) # xs) ! j) \<noteq> Some Q)",clarify)
 prefer 2
 apply clarify
 apply force
apply(rule_tac x="(Some Pa, sa)#(Some P2, ta)#(tl xsa)" in exI,simp)
apply(rule conjI,erule CptnComp)
apply(rule nth_tl_if,force,simp+)
apply(rule_tac x=ys in exI,simp)
apply(rule conjI)
apply(rule nth_tl_if,force,simp+)
 apply(rule tl_zero,simp+)
 apply force
apply(rule conjI,simp add:lift_def)
apply(subgoal_tac "lift Q (Some P2, ta) =(Some (Seq P2 Q), ta)")
 apply(simp add:Cons_lift del:list.map)
 apply(rule nth_tl_if)
   apply force
  apply simp+
apply(simp add:lift_def)
done
(*
lemma last_lift_not_None3: "fst (last (map (lift Q) (x#xs))) \<noteq> None"
apply(simp only:last_length [THEN sym])
apply(subgoal_tac "length xs<length (x # xs)")
 apply(drule_tac Q=Q in  lift_nth)
 apply(erule ssubst)
 apply (simp add:lift_def)
 apply(case_tac "(x # xs) ! length xs",simp)
apply simp
done
*)

lemma last_lift_not_None2: "fst ((lift Q) (last (x#xs))) \<noteq> None"
apply(simp only:last_length [THEN sym])
apply(subgoal_tac "length xs<length (x # xs)")
 apply(drule_tac Q=Q in  lift_nth)
 apply(erule ssubst)
 apply (simp add:lift_def)
 apply(case_tac "(x # xs) ! length xs",simp)
apply simp
done

lemma Seq_sound:
  "\<lbrakk>\<Turnstile> P sat [pre, rely, guar, mid]; \<Turnstile> Q sat [mid, rely, guar, post]\<rbrakk>
  \<Longrightarrow> \<Turnstile> Seq P Q sat [pre, rely, guar, post]"
apply(unfold com_validity_def)
apply clarify
apply(case_tac "\<exists>i<length x. fst(x!i)=Some Q")
 prefer 2
 apply (simp add:cp_def cptn_iff_cptn_mod)
 apply clarify
 apply(frule_tac Seq_sound1,force)
  apply force
 apply clarify
 apply(erule_tac x=s in allE,simp)
 apply(drule_tac c=xs in subsetD,simp add:cp_def cptn_iff_cptn_mod)
  apply(simp add:assum_def)
  apply clarify
  apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
  apply(simp add:snd_lift)
  apply(erule mp)
  apply(force elim:etranE intro:Env simp add:lift_def)
 apply(simp add:comm_def)
 apply(rule conjI)
  apply clarify
  apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
  apply(simp add:snd_lift)
  apply(erule mp)
  apply(case_tac "(xs!i)")
  apply(case_tac "(xs! Suc i)")
  apply(case_tac "fst(xs!i)")
   apply(erule_tac x=i in allE, simp add:lift_def)
  apply(case_tac "fst(xs!Suc i)")
   apply(force simp add:lift_def)
  apply(force simp add:lift_def)
 apply clarify
 apply(case_tac xs,simp add:cp_def)
 apply clarify
 apply (simp del:list.map)
 apply (rename_tac list)
 apply(subgoal_tac "(map (lift Q) ((a, b) # list))\<noteq>[]")
  apply(drule last_conv_nth)
  apply (simp del:list.map)
  apply(simp only:last_lift_not_None)
 apply simp
--{* @{text "\<exists>i<length x. fst (x ! i) = Some Q"} *}
apply(erule exE)
apply(drule_tac n=i and P="\<lambda>i. i < length x \<and> fst (x ! i) = Some Q" in Ex_first_occurrence)
apply clarify
apply (simp add:cp_def)
 apply clarify
 apply(frule_tac i=m in Seq_sound2,force)
  apply simp+
apply clarify
apply(simp add:comm_def)
apply(erule_tac x=s in allE)
apply(drule_tac c=xs in subsetD,simp)
 apply(case_tac "xs=[]",simp)
 apply(simp add:cp_def assum_def nth_append)
 apply clarify
 apply(erule_tac x=i in allE)
  back
 apply(simp add:snd_lift)
 apply(erule mp)
 apply(force elim:etranE intro:Env simp add:lift_def)
apply simp
apply clarify
apply(erule_tac x="snd(xs!m)" in allE)
apply(drule_tac c=ys in subsetD,simp add:cp_def assum_def)
 apply(case_tac "xs\<noteq>[]")
 apply(drule last_conv_nth,simp)
 apply(rule conjI)
  apply(erule mp)
  apply(case_tac "xs!m")
  apply(case_tac "fst(xs!m)",simp)
  apply(simp add:lift_def nth_append)
 apply clarify
 apply(erule_tac x="m+i" in allE)
 back
 back
 apply(case_tac ys,(simp add:nth_append)+)
 apply (case_tac i, (simp add:snd_lift)+)
  apply(erule mp)
  apply(case_tac "xs!m")
  apply(force elim:etran.cases intro:Env simp add:lift_def)
 apply simp
apply simp
apply clarify
apply(rule conjI,clarify)
 apply(case_tac "i<m",simp add:nth_append)
  apply(simp add:snd_lift)
  apply(erule allE, erule impE, assumption, erule mp)
  apply(case_tac "(xs ! i)")
  apply(case_tac "(xs ! Suc i)")
  apply(case_tac "fst(xs ! i)",force simp add:lift_def)
  apply(case_tac "fst(xs ! Suc i)")
   apply (force simp add:lift_def)
  apply (force simp add:lift_def)
 apply(erule_tac x="i-m" in allE)
 back
 back
 apply(subgoal_tac "Suc (i - m) < length ys",simp)
  prefer 2
  apply arith
 apply(simp add:nth_append snd_lift)
 apply(rule conjI,clarify)
  apply(subgoal_tac "i=m")
   prefer 2
   apply arith
  apply clarify
  apply(simp add:cp_def)
  apply(rule tl_zero)
    apply(erule mp)
    apply(case_tac "lift Q (xs!m)",simp add:snd_lift)
    apply(case_tac "xs!m",case_tac "fst(xs!m)",simp add:lift_def snd_lift)
     apply(case_tac ys,simp+)
    apply(simp add:lift_def)
   apply simp
  apply force
 apply clarify
 apply(rule tl_zero)
   apply(rule tl_zero)
     apply (subgoal_tac "i-m=Suc(i-Suc m)")
      apply simp
      apply(erule mp)
      apply(case_tac ys,simp+)
   apply force
  apply arith
 apply force
apply clarify
apply(case_tac "(map (lift Q) xs @ tl ys)\<noteq>[]")
 apply(drule last_conv_nth)
 apply(simp add: snd_lift nth_append)
 apply(rule conjI,clarify)
  apply(case_tac ys,simp+)
 apply clarify
 apply(case_tac ys,simp+)
done

subsubsection{* Soundness of the While rule *}

lemma last_append[rule_format]:
  "\<forall>xs. ys\<noteq>[] \<longrightarrow> ((xs@ys)!(length (xs@ys) - (Suc 0)))=(ys!(length ys - (Suc 0)))"
apply(induct ys)
 apply simp
apply clarify
apply (simp add:nth_append)
done

lemma assum_after_body:
  "\<lbrakk> \<Turnstile> P sat [pre \<inter> b, rely, guar, pre];
  (Some P, s) # xs \<in> cptn_mod; fst (last ((Some P, s) # xs)) = None; s \<in> b;
  (Some (While b P), s) # (Some (Seq P (While b P)), s) #
   map (lift (While b P)) xs @ ys \<in> assum (pre, rely)\<rbrakk>
  \<Longrightarrow> (Some (While b P), snd (last ((Some P, s) # xs))) # ys \<in> assum (pre, rely)"
apply(simp add:assum_def com_validity_def cp_def cptn_iff_cptn_mod)
apply clarify
apply(erule_tac x=s in allE)
apply(drule_tac c="(Some P, s) # xs" in subsetD,simp)
 apply clarify
 apply(erule_tac x="Suc i" in allE)
 apply simp
 apply(simp add:Cons_lift_append nth_append snd_lift del:list.map)
 apply(erule mp)
 apply(erule etranE,simp)
 apply(case_tac "fst(((Some P, s) # xs) ! i)")
  apply(force intro:Env simp add:lift_def)
 apply(force intro:Env simp add:lift_def)
apply(rule conjI)
 apply clarify
 apply(simp add:comm_def last_length)
apply clarify
apply(rule conjI)
 apply(simp add:comm_def)
apply clarify
apply(erule_tac x="Suc(length xs + i)" in allE,simp)
apply(case_tac i, simp add:nth_append Cons_lift_append snd_lift last_conv_nth lift_def split_def)
apply(simp add:Cons_lift_append nth_append snd_lift)
done

lemma While_sound_aux [rule_format]:
  "\<lbrakk> pre \<inter> - b \<subseteq> post; \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s, s) \<in> guar;
   stable pre rely;  stable post rely; x \<in> cptn_mod \<rbrakk>
  \<Longrightarrow>  \<forall>s xs. x=(Some(While b P),s)#xs \<longrightarrow> x\<in>assum(pre, rely) \<longrightarrow> x \<in> comm (guar, post)"
apply(erule cptn_mod.induct)
apply safe
apply (simp_all del:last.simps)
--{* 5 subgoals left *}
apply(simp add:comm_def)
--{* 4 subgoals left *}
apply(rule etran_in_comm)
apply(erule mp)
apply(erule tl_of_assum_in_assum,simp)
--{* While-None *}
apply(ind_cases "((Some (While b P), s), None, t) \<in> ctran" for s t)
apply(simp add:comm_def)
apply(simp add:cptn_iff_cptn_mod [THEN sym])
apply(rule conjI,clarify)
 apply(force simp add:assum_def)
apply clarify
apply(rule conjI, clarify)
 apply(case_tac i,simp,simp)
 apply(force simp add:not_ctran_None2)
apply(subgoal_tac "\<forall>i. Suc i < length ((None, t) # xs) \<longrightarrow> (((None, t) # xs) ! i, ((None, t) # xs) ! Suc i)\<in> etran")
 prefer 2
 apply clarify
 apply(rule_tac m="length ((None, s) # xs)" in etran_or_ctran,simp+)
 apply(erule not_ctran_None2,simp)
 apply simp+
apply(frule_tac j="0" and k="length ((None, s) # xs) - 1" and p=post in stability,simp+)
   apply(force simp add:assum_def subsetD)
  apply(simp add:assum_def)
  apply clarify
  apply(erule_tac x="i" in allE,simp)
  apply(erule_tac x="Suc i" in allE,simp)
 apply simp
apply clarify
apply (simp add:last_length)
--{* WhileOne *}
apply(thin_tac "P = While b P \<longrightarrow> ?Q")
apply(rule ctran_in_comm,simp)
apply(simp add:Cons_lift del:list.map)
apply(simp add:comm_def del:list.map)
apply(rule conjI)
 apply clarify
 apply(case_tac "fst(((Some P, sa) # xs) ! i)")
  apply(case_tac "((Some P, sa) # xs) ! i")
  apply (simp add:lift_def)
  apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
   apply simp
  apply simp
 apply(simp add:snd_lift del:list.map)
 apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
 apply(erule_tac x=sa in allE)
 apply(drule_tac c="(Some P, sa) # xs" in subsetD)
  apply (simp add:assum_def del:list.map)
  apply clarify
  apply(erule_tac x="Suc ia" in allE,simp add:snd_lift del:list.map)
  apply(erule mp)
  apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
   apply(erule etranE,simp add:lift_def)
   apply(rule Env)
  apply(erule etranE,simp add:lift_def)
  apply(rule Env)
 apply (simp add:comm_def del:list.map)
 apply clarify
 apply(erule allE,erule impE,assumption)
 apply(erule mp)
 apply(case_tac "((Some P, sa) # xs) ! i")
 apply(case_tac "xs!i")
 apply(simp add:lift_def)
 apply(case_tac "fst(xs!i)")
  apply force
 apply force
--{* last=None *}
apply clarify
apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
 apply(drule last_conv_nth)
 apply (simp del:list.map)
 apply(simp only:last_lift_not_None)
apply simp
--{* WhileMore *}
apply(thin_tac "P = While b P \<longrightarrow> ?Q")
apply(rule ctran_in_comm,simp del:last.simps)
--{* metiendo la hipotesis antes de dividir la conclusion. *}
apply(subgoal_tac "(Some (While b P), snd (last ((Some P, sa) # xs))) # ys \<in> assum (pre, rely)")
 apply (simp del:last.simps)
 prefer 2
 apply(erule assum_after_body)
  apply (simp del:last.simps)+
--{* lo de antes. *}
apply(simp add:comm_def del:list.map last.simps)
apply(rule conjI)
 apply clarify
 apply(simp only:Cons_lift_append)
 apply(case_tac "i<length xs")
  apply(simp add:nth_append del:list.map last.simps)
  apply(case_tac "fst(((Some P, sa) # xs) ! i)")
   apply(case_tac "((Some P, sa) # xs) ! i")
   apply (simp add:lift_def del:last.simps)
   apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
    apply simp
   apply simp
  apply(simp add:snd_lift del:list.map last.simps)
  apply(thin_tac " \<forall>i. i < length ys \<longrightarrow> ?P i")
  apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
  apply(erule_tac x=sa in allE)
  apply(drule_tac c="(Some P, sa) # xs" in subsetD)
   apply (simp add:assum_def del:list.map last.simps)
   apply clarify
   apply(erule_tac x="Suc ia" in allE,simp add:nth_append snd_lift del:list.map last.simps, erule mp)
   apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
    apply(erule etranE,simp add:lift_def)
    apply(rule Env)
   apply(erule etranE,simp add:lift_def)
   apply(rule Env)
  apply (simp add:comm_def del:list.map)
  apply clarify
  apply(erule allE,erule impE,assumption)
  apply(erule mp)
  apply(case_tac "((Some P, sa) # xs) ! i")
  apply(case_tac "xs!i")
  apply(simp add:lift_def)
  apply(case_tac "fst(xs!i)")
   apply force
 apply force
--{*  @{text "i \<ge> length xs"} *}
apply(subgoal_tac "i-length xs <length ys")
 prefer 2
 apply arith
apply(erule_tac x="i-length xs" in allE,clarify)
apply(case_tac "i=length xs")
 apply (simp add:nth_append snd_lift del:list.map last.simps)
 apply(simp add:last_length del:last.simps)
 apply(erule mp)
 apply(case_tac "last((Some P, sa) # xs)")
 apply(simp add:lift_def del:last.simps)
--{* @{text "i>length xs"} *}
apply(case_tac "i-length xs")
 apply arith
apply(simp add:nth_append del:list.map last.simps)
apply(rotate_tac -3)
apply(subgoal_tac "i- Suc (length xs)=nat")
 prefer 2
 apply arith
apply simp
--{* last=None *}
apply clarify
apply(case_tac ys)
 apply(simp add:Cons_lift del:list.map last.simps)
 apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
  apply(drule last_conv_nth)
  apply (simp del:list.map)
  apply(simp only:last_lift_not_None)
 apply simp
apply(subgoal_tac "((Some (Seq P (While b P)), sa) # map (lift (While b P)) xs @ ys)\<noteq>[]")
 apply(drule last_conv_nth)
 apply (simp del:list.map last.simps)
 apply(simp add:nth_append del:last.simps)
 apply(rename_tac a list)
 apply(subgoal_tac "((Some (While b P), snd (last ((Some P, sa) # xs))) # a # list)\<noteq>[]")
  apply(drule last_conv_nth)
  apply (simp del:list.map last.simps)
 apply simp
apply simp
done

lemma While_sound:
  "\<lbrakk>stable pre rely; pre \<inter> - b \<subseteq> post; stable post rely;
    \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar\<rbrakk>
  \<Longrightarrow> \<Turnstile> While b P sat [pre, rely, guar, post]"
apply(unfold com_validity_def)
apply clarify
apply(erule_tac xs="tl x" in While_sound_aux)
 apply(simp add:com_validity_def)
 apply force
 apply simp_all
apply(simp add:cptn_iff_cptn_mod cp_def)
apply(simp add:cp_def)
apply clarify
apply(rule nth_equalityI)
 apply simp_all
 apply(case_tac x,simp+)
apply clarify
apply(case_tac i,simp+)
apply(case_tac x,simp+)
done

subsubsection{* Soundness of the Rule of Consequence *}

lemma Conseq_sound:
  "\<lbrakk>pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
  \<Turnstile> P sat [pre', rely', guar', post']\<rbrakk>
  \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
apply(simp add:com_validity_def assum_def comm_def)
apply clarify
apply(erule_tac x=s in allE)
apply(drule_tac c=x in subsetD)
 apply force
apply force
done

subsubsection {* Soundness of the system for sequential component programs *}

theorem rgsound:
  "\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
apply(erule rghoare.induct)
 apply(force elim:Basic_sound)
 apply(force elim:Seq_sound)
 apply(force elim:Cond_sound)
 apply(force elim:While_sound)
 apply(force elim:Await_sound)
apply(erule Conseq_sound,simp+)
done

subsection {* Soundness of the System for Parallel Programs *}

definition ParallelCom :: "('a rgformula) list \<Rightarrow> 'a par_com" where
  "ParallelCom Ps \<equiv> map (Some \<circ> fst) Ps"

lemma two:
  "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
     \<subseteq> Rely (xs ! i);
   pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
   \<forall>i<length xs.
   \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
   length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x\<in>par_assum(pre, rely);
  \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
  \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -c\<rightarrow> (clist!i!Suc j)
  \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> Guar(xs!i)"
apply(unfold par_cp_def)
apply (rule ccontr)
--{* By contradiction: *}
apply simp
apply(erule exE)
--{* the first c-tran that does not satisfy the guarantee-condition is from @{text "\<sigma>_i"} at step @{text "m"}. *}
apply(drule_tac n=j and P="\<lambda>j. \<exists>i. ?H i j" in Ex_first_occurrence)
apply(erule exE)
apply clarify
--{* @{text "\<sigma>_i \<in> A(pre, rely_1)"} *}
apply(subgoal_tac "take (Suc (Suc m)) (clist!i) \<in> assum(Pre(xs!i), Rely(xs!i))")
--{* but this contradicts @{text "\<Turnstile> \<sigma>_i sat [pre_i,rely_i,guar_i,post_i]"} *}
 apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
 apply(simp add:com_validity_def)
 apply(erule_tac x=s in allE)
 apply(simp add:cp_def comm_def)
 apply(drule_tac c="take (Suc (Suc m)) (clist ! i)" in subsetD)
  apply simp
  apply (blast intro: takecptn_is_cptn)
 apply simp
 apply clarify
 apply(erule_tac x=m and P="\<lambda>j. ?I j \<and> ?J j \<longrightarrow> ?H j" in allE)
 apply (simp add:conjoin_def same_length_def)
apply(simp add:assum_def)
apply(rule conjI)
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow>  ?I j \<in>cp (?K j) (?J j)" in allE)
 apply(simp add:cp_def par_assum_def)
 apply(drule_tac c="s" in subsetD,simp)
 apply simp
apply clarify
apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?M \<union> UNION (?S j) (?T j) \<subseteq>  (?L j)" in allE)
apply simp
apply(erule subsetD)
apply simp
apply(simp add:conjoin_def compat_label_def)
apply clarify
apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j) \<or> ?Q j" in allE,simp)
--{* each etran in @{text "\<sigma>_1[0\<dots>m]"} corresponds to  *}
apply(erule disjE)
--{* a c-tran in some @{text "\<sigma>_{ib}"}  *}
 apply clarify
 apply(case_tac "i=ib",simp)
  apply(erule etranE,simp)
 apply(erule_tac x="ib" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE)
 apply (erule etranE)
 apply(case_tac "ia=m",simp)
 apply simp
 apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (\<forall> i. ?P i j)" in allE)
 apply(subgoal_tac "ia<m",simp)
  prefer 2
  apply arith
 apply(erule_tac x=ib and P="\<lambda>j. (?I j, ?H j)\<in> ctran \<longrightarrow> (?P i j)" in allE,simp)
 apply(simp add:same_state_def)
 apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
 apply(erule_tac x=ib and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
--{* or an e-tran in @{text "\<sigma>"},
therefore it satisfies @{text "rely \<or> guar_{ib}"} *}
apply (force simp add:par_assum_def same_state_def)
done

lemma three [rule_format]:
  "\<lbrakk> xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
   \<subseteq> Rely (xs ! i);
   pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
   \<forall>i<length xs.
    \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
   length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum(pre, rely);
  \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
  \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -e\<rightarrow> (clist!i!Suc j)
  \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))"
apply(drule two)
 apply simp_all
apply clarify
apply(simp add:conjoin_def compat_label_def)
apply clarify
apply(erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (?J j \<and> (\<exists>i. ?P i j)) \<or> ?I j" in allE,simp)
apply(erule disjE)
 prefer 2
 apply(force simp add:same_state_def par_assum_def)
apply clarify
apply(case_tac "i=ia",simp)
 apply(erule etranE,simp)
apply(erule_tac x="ia" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE,simp)
apply(erule_tac x=j and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
apply(simp add:same_state_def)
apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
done

lemma four:
  "\<lbrakk>xs\<noteq>[]; \<forall>i < length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
    \<subseteq> Rely (xs ! i);
   (\<Union>j\<in>{j. j < length xs}. Guar (xs ! j)) \<subseteq> guar;
   pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
   \<forall>i < length xs.
    \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
   x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely); Suc i < length x;
   x ! i -pc\<rightarrow> x ! Suc i\<rbrakk>
  \<Longrightarrow> (snd (x ! i), snd (x ! Suc i)) \<in> guar"
apply(simp add: ParallelCom_def)
apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
 prefer 2
 apply simp
apply(frule rev_subsetD)
 apply(erule one [THEN equalityD1])
apply(erule subsetD)
apply simp
apply clarify
apply(drule_tac pre=pre and rely=rely and  x=x and s=s and xs=xs and clist=clist in two)
apply(assumption+)
     apply(erule sym)
    apply(simp add:ParallelCom_def)
   apply assumption
  apply(simp add:Com_def)
 apply assumption
apply(simp add:conjoin_def same_program_def)
apply clarify
apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in all_dupE)
apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
apply(erule par_ctranE,simp)
apply(erule_tac x=i and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
apply(rule_tac x=ia in exI)
apply(simp add:same_state_def)
apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE,simp)
apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE)
apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE,simp)
apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
apply(erule mp)
apply(subgoal_tac "r=fst(clist ! ia ! Suc i)",simp)
apply(drule_tac i=ia in list_eq_if)
back
apply simp_all
done

lemma parcptn_not_empty [simp]:"[] \<notin> par_cptn"
apply(force elim:par_cptn.cases)
done

lemma five:
  "\<lbrakk>xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
   \<subseteq> Rely (xs ! i);
   pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
   (\<Inter>i\<in>{i. i < length xs}. Post (xs ! i)) \<subseteq> post;
   \<forall>i < length xs.
    \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
    x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely);
   All_None (fst (last x)) \<rbrakk> \<Longrightarrow> snd (last x) \<in> post"
apply(simp add: ParallelCom_def)
apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
 prefer 2
 apply simp
apply(frule rev_subsetD)
 apply(erule one [THEN equalityD1])
apply(erule subsetD)
apply simp
apply clarify
apply(subgoal_tac "\<forall>i<length clist. clist!i\<in>assum(Pre(xs!i), Rely(xs!i))")
 apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
 apply(simp add:com_validity_def)
 apply(erule_tac x=s in allE)
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I j) \<in> cp (?J j) s" in allE,simp)
 apply(drule_tac c="clist!i" in subsetD)
  apply (force simp add:Com_def)
 apply(simp add:comm_def conjoin_def same_program_def del:last.simps)
 apply clarify
 apply(erule_tac x="length x - 1" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
 apply (simp add:All_None_def same_length_def)
 apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> length(?J j)=(?K j)" in allE)
 apply(subgoal_tac "length x - 1 < length x",simp)
  apply(case_tac "x\<noteq>[]")
   apply(simp add: last_conv_nth)
   apply(erule_tac x="clist!i" in ballE)
    apply(simp add:same_state_def)
    apply(subgoal_tac "clist!i\<noteq>[]")
     apply(simp add: last_conv_nth)
    apply(case_tac x)
     apply (force simp add:par_cp_def)
    apply (force simp add:par_cp_def)
   apply force
  apply (force simp add:par_cp_def)
 apply(case_tac x)
  apply (force simp add:par_cp_def)
 apply (force simp add:par_cp_def)
apply clarify
apply(simp add:assum_def)
apply(rule conjI)
 apply(simp add:conjoin_def same_state_def par_cp_def)
 apply clarify
 apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
 apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
 apply(case_tac x,simp+)
 apply (simp add:par_assum_def)
 apply clarify
 apply(drule_tac c="snd (clist ! ia ! 0)" in subsetD)
 apply assumption
 apply simp
apply clarify
apply(erule_tac x=ia in all_dupE)
apply(rule subsetD, erule mp, assumption)
apply(erule_tac pre=pre and rely=rely and x=x and s=s in  three)
 apply(erule_tac x=ic in allE,erule mp)
 apply simp_all
 apply(simp add:ParallelCom_def)
 apply(force simp add:Com_def)
apply(simp add:conjoin_def same_length_def)
done

lemma ParallelEmpty [rule_format]:
  "\<forall>i s. x \<in> par_cp (ParallelCom []) s \<longrightarrow>
  Suc i < length x \<longrightarrow> (x ! i, x ! Suc i) \<notin> par_ctran"
apply(induct_tac x)
 apply(simp add:par_cp_def ParallelCom_def)
apply clarify
apply(case_tac list,simp,simp)
apply(case_tac i)
 apply(simp add:par_cp_def ParallelCom_def)
 apply(erule par_ctranE,simp)
apply(simp add:par_cp_def ParallelCom_def)
apply clarify
apply(erule par_cptn.cases,simp)
 apply simp
apply(erule par_ctranE)
back
apply simp
done

theorem par_rgsound:
  "\<turnstile> c SAT [pre, rely, guar, post] \<Longrightarrow>
   \<Turnstile> (ParallelCom c) SAT [pre, rely, guar, post]"
apply(erule par_rghoare.induct)
apply(case_tac xs,simp)
 apply(simp add:par_com_validity_def par_comm_def)
 apply clarify
 apply(case_tac "post=UNIV",simp)
  apply clarify
  apply(drule ParallelEmpty)
   apply assumption
  apply simp
 apply clarify
 apply simp
apply(subgoal_tac "xs\<noteq>[]")
 prefer 2
 apply simp
apply(rename_tac a list)
apply(thin_tac "xs = a # list")
apply(simp add:par_com_validity_def par_comm_def)
apply clarify
apply(rule conjI)
 apply clarify
 apply(erule_tac pre=pre and rely=rely and guar=guar and x=x and s=s and xs=xs in four)
        apply(assumption+)
     apply clarify
     apply (erule allE, erule impE, assumption,erule rgsound)
    apply(assumption+)
apply clarify
apply(erule_tac pre=pre and rely=rely and post=post and x=x and s=s and xs=xs in five)
      apply(assumption+)
   apply clarify
   apply (erule allE, erule impE, assumption,erule rgsound)
  apply(assumption+)
done

end


section \<open>Functional Interface\<close>
theory VEBT_Intf_Functional
imports Main
  VEBT_Definitions VEBT_Space
  VEBT_Uniqueness
  VEBT_Member
  VEBT_Insert VEBT_InsertCorrectness
  VEBT_MinMax
  VEBT_Pred VEBT_Succ
  VEBT_Bounds
  VEBT_Delete VEBT_DeleteCorrectness VEBT_DeleteBounds

begin

  subsection \<open>Code Generation Setup\<close>

  subsubsection \<open>Code Equations\<close>
  text \<open>Code generator seems to not support patterns and nat code target\<close>

  context begin
    interpretation VEBT_internal .

  lemma vebt_member_code[code]:
    "vebt_member (Leaf a b) x = (if x = 0 then a else if x=1 then b else False)"
    "vebt_member (Node None t r e) x = False"
    "vebt_member (Node (Some (mi, ma)) deg treeList summary) x =
    (if deg = 0 \<or> deg = Suc 0 then False else (
      if x = mi then True else
      if x = ma then True else
      if x < mi then False else
     if x > ma then False else
      (let
            h = high x (deg div 2);
           l = low x (deg div 2) in
         (if h < length treeList
             then vebt_member (treeList ! h) l
             else False))))"
        apply simp
       apply simp
    proof(goal_cases)
      case 1
      consider "deg = 0"| "deg = Suc 0"
        | n  where "deg = Suc (Suc n)"
        by (meson vebt_buildup.cases)
      then show ?case apply(cases)
        by simp_all
    qed

  lemma vebt_insert_code[code]:
    "vebt_insert (Leaf a b) x = (if x=0 then Leaf True b else if x=1 then Leaf a True else Leaf a b)"
    "vebt_insert (Node info deg treeList summary) x = (
      if deg \<le> 1 then
        (Node info deg treeList summary)
      else ( case info of
        None \<Rightarrow>  (Node (Some (x,x)) deg  treeList summary)
      | Some mima \<Rightarrow> ( case mima of (mi, ma) \<Rightarrow> (
          let
            xn = (if x < mi then mi else x);
            minn = (if x< mi then x else mi);
            l= low xn (deg div 2); h = high xn (deg div 2)
          in (
            if h < length treeList \<and> \<not> (x = mi \<or> x = ma) then
              Node (Some (minn, max xn ma))
                   deg
                   (treeList[h:= vebt_insert (treeList ! h) l])
                   (if minNull (treeList ! h) then  vebt_insert summary h else summary)
            else Node (Some (mi, ma)) deg treeList summary)
      ))))"
      apply simp
     apply simp
  proof(goal_cases)
    case 1
    consider "deg = 0"| "deg = Suc 0"
      | n  where "deg = Suc (Suc n)"
      by (meson vebt_buildup.cases)
    then show ?case apply(cases)
        apply simp+
      apply(cases info)
       apply simp+
      apply(cases "the info")
      apply simp
      by meson

  qed

  lemma vebt_succ_code[code]:
    "vebt_succ (Leaf a b) x = (if b\<and> x = 0 then Some 1 else None)"
    "vebt_succ (Node info  deg treeList summary) x = (if deg \<le> 1 then None else
    (case info of None \<Rightarrow> None |
    (Some mima) \<Rightarrow> (case mima of (mi, ma) \<Rightarrow> (
                   if x < mi then (Some mi)
                   else (let l = low x (deg div 2); h = high x (deg div 2) in(
                        if h < length treeList then
                                let maxlow = vebt_maxt (treeList ! h) in
                                (if maxlow \<noteq> None \<and> (Some l <\<^sub>o  maxlow) then
                                                        Some (2^(deg div 2)) *\<^sub>o Some h +\<^sub>o vebt_succ (treeList ! h) l
                                 else let sc = vebt_succ summary h in
                                 if sc = None then None
                                 else Some (2^(deg div 2)) *\<^sub>o sc +\<^sub>o vebt_mint (treeList ! the sc) )

                         else None))))))"
    apply (cases "(Leaf a b,x)" rule: vebt_succ.cases; simp)
    apply (cases "(Node info  deg treeList summary,x)" rule: vebt_succ.cases; simp add: Let_def)
    done

  lemma vebt_pred_code[code]:
    "vebt_pred (Leaf a b) x = (if x = 0 then None else if x = 1 then
                                      (if a then Some 0 else None) else
                               (if b then Some 1 else if a then Some 0 else None))" and
    "vebt_pred (Node info deg treeList summary) x =(if deg \<le> 1 then None else (
    case info of None \<Rightarrow> None |
    (Some mima) \<Rightarrow> (case mima of (mi, ma) \<Rightarrow> (
                           if x > ma then Some ma
                           else (let l = low x (deg div 2); h = high x (deg div 2) in
                           if h < length treeList then
                                let minlow = vebt_mint (treeList ! h) in
                                (if minlow \<noteq> None \<and> (Some l >\<^sub>o  minlow) then
                                                        Some (2^(deg div 2)) *\<^sub>o Some h +\<^sub>o vebt_pred (treeList ! h) l
                                 else let pr = vebt_pred summary h in
                                 if pr = None then (if x > mi then Some mi else None)
                                 else Some (2^(deg div 2)) *\<^sub>o pr +\<^sub>o vebt_maxt (treeList ! the pr) )
                         else None)))))"
    apply (cases "(Leaf a b,x)" rule: vebt_pred.cases; simp)
    apply (cases "(Node info  deg treeList summary,x)" rule: vebt_pred.cases; simp add: Let_def)
    done

  lemma vebt_delete_code[code]:
    "vebt_delete (Leaf a b) x = (if x = 0 then Leaf False b else if x = 1 then Leaf a False else Leaf a b)"
    "vebt_delete (Node info deg treeList summary) x = (
      case info of
        None \<Rightarrow> (Node info deg treeList summary)
      | Some mima \<Rightarrow> (
          if deg \<le> 1 then (Node info deg treeList summary)
          else (case mima of (mi, ma) \<Rightarrow> (
            if (x < mi \<or> x > ma) then (Node (Some (mi, ma)) deg treeList summary)
            else if (x = mi \<and> x = ma) then (Node None deg treeList summary)
            else let
              xn = (if x = mi then the (vebt_mint summary) * 2^(deg div 2)
                                      + the (vebt_mint (treeList ! the (vebt_mint summary)))
                     else x);
              minn = (if x = mi then xn else mi);
              l = low xn (deg div 2);
              h = high xn (deg div 2)
            in
              if h < length treeList then let
                newnode = vebt_delete (treeList ! h) l;
                newlist = treeList[h:= newnode]
              in
                if minNull newnode then let
                  sn = vebt_delete summary h;
                  maxn =
                    if xn = ma then let
                      maxs = vebt_maxt sn
                      in
                        if maxs = None then minn
                        else 2^(deg div 2) * the maxs + the (vebt_maxt (newlist ! the maxs))
                    else ma
                  in (Node (Some (minn, maxn)) deg newlist sn)
                else let
                  maxn = (if xn = ma then h * 2^(deg div 2) + the( vebt_maxt (newlist ! h))
                                     else ma)
                in (Node (Some (minn, maxn)) deg newlist summary)
              else (Node (Some (mi, ma)) deg treeList summary)
     ))))"
    apply (cases "(Leaf a b,x)" rule: vebt_delete.cases; simp)
    apply (cases "(Node info  deg treeList summary,x)" rule: vebt_delete.cases; simp add: Let_def)
    done
end

lemmas [code] =
  VEBT_internal.high_def VEBT_internal.low_def VEBT_internal.minNull.simps
  VEBT_internal.less.simps VEBT_internal.mul_def VEBT_internal.add_def
  VEBT_internal.option_comp_shift.simps VEBT_internal.option_shift.simps

export_code
  vebt_buildup
  vebt_insert
  vebt_member
  vebt_maxt
  vebt_mint
  vebt_pred
  vebt_succ
  vebt_delete
  checking SML

subsection \<open>Correctness Lemmas\<close>

named_theorems vebt_simps \<open>Simplifier rules for VEBT functional interface\<close>

locale vebt_inst =
  fixes n :: nat
begin

  interpretation VEBT_internal .

subsubsection \<open>Space Bound\<close>
theorem vebt_space_linear_bound:
  fixes t
  defines "u \<equiv> 2^n"
  shows "invar_vebt t n \<Longrightarrow> space t \<le> 12*u"
  by (simp add: space_bound u_def)

subsubsection \<open>Buildup\<close>
lemma invar_vebt_buildup[vebt_simps]: "invar_vebt (vebt_buildup n) n \<longleftrightarrow> n>0"
  by (auto simp add: buildup_gives_valid deg_not_0)

lemma set_vebt_buildup[vebt_simps]: "set_vebt (vebt_buildup i) = {}"
  by (metis VEBT_internal.buildup_gives_empty VEBT_internal.buildup_gives_valid VEBT_internal.set_vebt_set_vebt'_valid neq0_conv invar_vebt.intros(1) vebt_buildup.simps(1))

lemma time_vebt_buildup: "u = 2^n \<Longrightarrow> T\<^sub>b\<^sub>u\<^sub>i\<^sub>l\<^sub>d\<^sub>u\<^sub>p  n \<le> 26 * u"
  using vebt_buildup_bound by simp

subsubsection \<open>Equality\<close>
lemma set_vebt_equal[vebt_simps]: "invar_vebt t\<^sub>1 n \<Longrightarrow> invar_vebt t\<^sub>2 n \<Longrightarrow> t\<^sub>1=t\<^sub>2 \<longleftrightarrow> set_vebt t\<^sub>1 = set_vebt t\<^sub>2"
  by (auto simp: unique_tree)

subsubsection \<open>Member\<close>
lemma set_vebt_member[vebt_simps]: "invar_vebt t n \<Longrightarrow> vebt_member t x \<longleftrightarrow> x\<in>set_vebt t"
  by (rule member_correct)

theorem time_vebt_member: "invar_vebt t n \<Longrightarrow> u =  2^n \<Longrightarrow>  T\<^sub>m\<^sub>e\<^sub>m\<^sub>b\<^sub>e\<^sub>r t x \<le> 30 + 15 * lb (lb u)"
  using member_bound_size_univ by auto

subsubsection \<open>Insert\<close>
theorem invar_vebt_insert[vebt_simps]: "invar_vebt t n \<Longrightarrow> x< 2^n \<Longrightarrow> invar_vebt (vebt_insert t x) n"
  by (simp add: valid_pres_insert)

theorem set_vebt_insert[vebt_simps]: "invar_vebt t n  \<Longrightarrow> x < 2^n  \<Longrightarrow> set_vebt (vebt_insert t x) = set_vebt t \<union> {x}"
  by (meson insert_correct[symmetric])

theorem time_vebt_insert: "invar_vebt t n \<Longrightarrow> u =  2^n \<Longrightarrow>   T\<^sub>i\<^sub>n\<^sub>s\<^sub>e\<^sub>r\<^sub>t t x \<le> 46 + 23 * lb (lb u)"
  by (meson insert_bound_size_univ)

subsubsection \<open>Maximum\<close>
theorem set_vebt_maxt: "invar_vebt t n \<Longrightarrow> vebt_maxt t = Some x \<longleftrightarrow> max_in_set (set_vebt t) x"
  by (metis maxt_sound maxt_corr set_vebt_set_vebt'_valid)

theorem set_vebt_maxt': "invar_vebt t n \<Longrightarrow> vebt_maxt t = Some x \<longleftrightarrow> (x\<in>set_vebt t \<and> (\<forall>y\<in>set_vebt t. x\<ge>y))"
  using set_vebt_maxt unfolding max_in_set_def by blast

lemma set_vebt_maxt''[vebt_simps]:
  "invar_vebt t n \<Longrightarrow> vebt_maxt t = (if set_vebt t = {} then None else Some (Max (set_vebt t)))"
  by (metis Max_ge Max_in VEBT_internal.set_vebt_finite VEBT_internal.set_vebt_set_vebt'_valid empty_iff option.exhaust set_vebt_maxt')

lemma time_vebt_maxt: "T\<^sub>m\<^sub>a\<^sub>x\<^sub>t t \<le>  3"
  by (simp add: maxt_bound)

subsubsection \<open>Minimum\<close>
theorem set_vebt_mint[vebt_simps]: "invar_vebt t n \<Longrightarrow> vebt_mint t = Some x \<longleftrightarrow> min_in_set (set_vebt t) x"
  by (metis VEBT_internal.mint_corr VEBT_internal.mint_sound VEBT_internal.set_vebt_set_vebt'_valid)

theorem set_vebt_mint': "invar_vebt t n \<Longrightarrow> vebt_mint t = Some x \<longleftrightarrow> (x\<in>set_vebt t \<and> (\<forall>y\<in>set_vebt t. x\<le>y))"
  using set_vebt_mint unfolding min_in_set_def by blast

lemma set_vebt_mint''[vebt_simps]:
  "invar_vebt t n \<Longrightarrow> vebt_mint t = (if set_vebt t = {} then None else Some (Min (set_vebt t)))"
  by (metis Min_in Min_le VEBT_internal.set_vebt_finite VEBT_internal.set_vebt_set_vebt'_valid empty_iff option.exhaust set_vebt_mint')

lemma time_vebt_mint: "T\<^sub>m\<^sub>i\<^sub>n\<^sub>t t \<le>  3"
  by (simp add: mint_bound)

subsection \<open>Emptiness determination\<close>
text \<open> A tree is empty if and only if its minimum is None\<close>

lemma vebt_minNull_mint: " minNull t \<longleftrightarrow> vebt_mint t = None"
  by (meson VEBT_internal.minNullmin VEBT_internal.minminNull)

lemma set_vebt_minNull: "invar_vebt t n \<Longrightarrow> minNull t \<longleftrightarrow> set_vebt t = {}"
  by (metis VEBT_internal.minNullmin VEBT_internal.minminNull VEBT_internal.mint_corr_help_empty VEBT_internal.set_vebt_set_vebt'_valid vebt_inst.set_vebt_mint'')

lemma time_vebt_minNull: "T\<^sub>m\<^sub>i\<^sub>n\<^sub>N\<^sub>u\<^sub>l\<^sub>l t \<le> 1"
  using minNull_bound by auto

subsubsection \<open>Successor\<close>
theorem set_vebt_succ: "invar_vebt t n \<Longrightarrow> vebt_succ t x = Some sx \<longleftrightarrow> is_succ_in_set (set_vebt t) x sx"
  by (simp add: succ_corr set_vebt_set_vebt'_valid)

lemma set_vebt_succ'[vebt_simps]: "invar_vebt t n \<Longrightarrow> vebt_succ t x = (if \<exists>  y \<in> set_vebt t. y > x then Some (LEAST y \<in> set_vebt t. y > x) else None)"
  apply (clarsimp;safe)
  subgoal
    apply(clarsimp simp add: succ_correct is_succ_in_set_def Least_le)
    by (metis (no_types, lifting) LeastI_ex)
  subgoal by (meson succ_correct is_succ_in_set_def option.exhaust_sel)
  done

theorem time_vebt_succ:
  fixes t defines "u \<equiv> 2^n"
  shows "invar_vebt t n \<Longrightarrow>   T\<^sub>s\<^sub>u\<^sub>c\<^sub>c t x \<le> 54 + 27 * lb (lb u)"
  using succ_bound_size_univ unfolding u_def by presburger

subsubsection \<open>Predecessor\<close>
theorem set_vebt_pred: "invar_vebt t n \<Longrightarrow> vebt_pred t x = Some px \<longleftrightarrow> is_pred_in_set (set_vebt t) x px"
  by (simp add: pred_corr set_vebt_set_vebt'_valid)

theorem set_vebt_pred'[vebt_simps]: "invar_vebt t n \<Longrightarrow>
  vebt_pred t x = (if \<exists>  y \<in> set_vebt t. y < x then Some (GREATEST y. y \<in> set_vebt t \<and> y < x) else None)"
  apply (clarsimp simp: member_correct pred_empty pred_correct is_pred_in_set_def)
  by (metis (no_types, lifting) GreatestI_nat Greatest_le_nat less_imp_le)

theorem time_vebt_pred:   fixes t defines "u \<equiv> 2^n"
  shows "invar_vebt t n \<Longrightarrow> T\<^sub>p\<^sub>r\<^sub>e\<^sub>d t x \<le> 58 + 29 * lb (lb u)"
  unfolding u_def by (meson pred_bound_size_univ)

subsubsection \<open>Delete\<close>
theorem invar_vebt_delete[vebt_simps]: "invar_vebt t n \<Longrightarrow> invar_vebt (vebt_delete t x) n"
  by (simp add: delete_pres_valid)

theorem set_vebt_delete[vebt_simps]: "invar_vebt t n \<Longrightarrow> set_vebt (vebt_delete t x) = set_vebt t - {x}"
  by (metis delete_correct invar_vebt_delete set_vebt_set_vebt'_valid)

theorem time_vebt_delete:   fixes t defines "u \<equiv> 2^n"
  shows "invar_vebt t n \<Longrightarrow> T\<^sub>d\<^sub>e\<^sub>l\<^sub>e\<^sub>t\<^sub>e  t x \<le> 140 + 70 * lb (lb u)"
  unfolding u_def by (meson delete_bound_size_univ)

end

subsection \<open>Interface Usage Example\<close>

experiment
begin

  definition "test n xs ys \<equiv> let
    t = vebt_buildup n;
    t = foldl vebt_insert t (0#xs);

    f = (\<lambda>x. if vebt_member t x then x else the (vebt_pred t x))
  in
    map f ys"

  context fixes n :: nat begin
    interpretation vebt_inst n .

    lemmas [simp] = vebt_simps

end

  (* TODO: Use uniqueness to define = operation! *)

end


(*  Author:     Bernhard Haeupler

This theory is about of the relative completeness of method comm-ring
method.  As long as the reified atomic polynomials of type 'a pol are
in normal form, the cring method is complete.
*)

section {* Proof of the relative completeness of method comm-ring *}

theory Commutative_Ring_Complete
imports Commutative_Ring
begin

text {* Formalization of normal form *}
fun isnorm :: "'a::comm_ring pol \<Rightarrow> bool"
where
  "isnorm (Pc c) \<longleftrightarrow> True"
| "isnorm (Pinj i (Pc c)) \<longleftrightarrow> False"
| "isnorm (Pinj i (Pinj j Q)) \<longleftrightarrow> False"
| "isnorm (Pinj 0 P) \<longleftrightarrow> False"
| "isnorm (Pinj i (PX Q1 j Q2)) \<longleftrightarrow> isnorm (PX Q1 j Q2)"
| "isnorm (PX P 0 Q) \<longleftrightarrow> False"
| "isnorm (PX (Pc c) i Q) \<longleftrightarrow> c \<noteq> 0 \<and> isnorm Q"
| "isnorm (PX (PX P1 j (Pc c)) i Q) \<longleftrightarrow> c \<noteq> 0 \<and> isnorm (PX P1 j (Pc c)) \<and> isnorm Q"
| "isnorm (PX P i Q) \<longleftrightarrow> isnorm P \<and> isnorm Q"

(* Some helpful lemmas *)
lemma norm_Pinj_0_False: "isnorm (Pinj 0 P) = False"
  by (cases P) auto

lemma norm_PX_0_False: "isnorm (PX (Pc 0) i Q) = False"
  by (cases i) auto

lemma norm_Pinj: "isnorm (Pinj i Q) \<Longrightarrow> isnorm Q"
  by (cases i) (simp add: norm_Pinj_0_False norm_PX_0_False, cases Q, auto)

lemma norm_PX2: "isnorm (PX P i Q) \<Longrightarrow> isnorm Q"
  apply (cases i)
  apply auto
  apply (cases P)
  apply auto
  apply (rename_tac pol2, case_tac pol2)
  apply auto
  done

lemma norm_PX1: "isnorm (PX P i Q) \<Longrightarrow> isnorm P"
  apply (cases i)
  apply auto
  apply (cases P)
  apply auto
  apply (rename_tac pol2, case_tac pol2)
  apply auto
  done

lemma mkPinj_cn: "y \<noteq> 0 \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (mkPinj y Q)"
  apply (auto simp add: mkPinj_def norm_Pinj_0_False split: pol.split)
  apply (rename_tac nat a, case_tac nat, auto simp add: norm_Pinj_0_False)
  apply (rename_tac pol a, case_tac pol, auto)
  apply (case_tac y, auto)
  done

lemma norm_PXtrans:
  assumes A: "isnorm (PX P x Q)"
    and "isnorm Q2"
  shows "isnorm (PX P x Q2)"
proof (cases P)
  case (PX p1 y p2)
  with assms show ?thesis
    apply (cases x)
    apply auto
    apply (cases p2)
    apply auto
    done
next
  case Pc
  with assms show ?thesis by (cases x) auto
next
  case Pinj
  with assms show ?thesis by (cases x) auto
qed

lemma norm_PXtrans2:
  assumes "isnorm (PX P x Q)"
    and "isnorm Q2"
  shows "isnorm (PX P (Suc (n + x)) Q2)"
proof (cases P)
  case (PX p1 y p2)
  with assms show ?thesis
    apply (cases x)
    apply auto
    apply (cases p2)
    apply auto
    done
next
  case Pc
  with assms show ?thesis
    by (cases x) auto
next
  case Pinj
  with assms show ?thesis
    by (cases x) auto
qed

text {* mkPX conserves normalizedness (@{text "_cn"}) *}
lemma mkPX_cn:
  assumes "x \<noteq> 0"
    and "isnorm P"
    and "isnorm Q"
  shows "isnorm (mkPX P x Q)"
proof (cases P)
  case (Pc c)
  with assms show ?thesis
    by (cases x) (auto simp add: mkPinj_cn mkPX_def)
next
  case (Pinj i Q)
  with assms show ?thesis
    by (cases x) (auto simp add: mkPinj_cn mkPX_def)
next
  case (PX P1 y P2)
  with assms have Y0: "y > 0"
    by (cases y) auto
  from assms PX have "isnorm P1" "isnorm P2"
    by (auto simp add: norm_PX1[of P1 y P2] norm_PX2[of P1 y P2])
  from assms PX Y0 show ?thesis
    by (cases x) (auto simp add: mkPX_def norm_PXtrans2[of P1 y _ Q _], cases P2, auto)
qed

text {* add conserves normalizedness *}
lemma add_cn: "isnorm P \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (P \<oplus> Q)"
proof (induct P Q rule: add.induct)
  case (2 c i P2)
  then show ?case
    by (cases P2) (simp_all, cases i, simp_all)
next
  case (3 i P2 c)
  then show ?case
    by (cases P2) (simp_all, cases i, simp_all)
next
  case (4 c P2 i Q2)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 4 show ?case
    by (cases i) (simp, cases P2, auto, rename_tac pol2, case_tac pol2, auto)
next
  case (5 P2 i Q2 c)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 5 show ?case
    by (cases i) (simp, cases P2, auto, rename_tac pol2, case_tac pol2, auto)
next
  case (6 x P2 y Q2)
  then have Y0: "y > 0"
    by (cases y) (auto simp add: norm_Pinj_0_False)
  with 6 have X0: "x > 0"
    by (cases x) (auto simp add: norm_Pinj_0_False)
  have "x < y \<or> x = y \<or> x > y" by arith
  moreover {
    assume "x < y"
    then have "\<exists>d. y = d + x" by arith
    then obtain d where y: "y = d + x" ..
    moreover
    note 6 X0
    moreover
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    moreover
    from 6 `x < y` y have "isnorm (Pinj d Q2)"
      by (cases d, simp, cases Q2, auto)
    ultimately have ?case by (simp add: mkPinj_cn)
  }
  moreover {
    assume "x = y"
    moreover
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    moreover
    note 6 Y0
    ultimately have ?case by (simp add: mkPinj_cn)
  }
  moreover {
    assume "x > y"
    then have "\<exists>d. x = d + y"
      by arith
    then obtain d where x: "x = d + y" ..
    moreover
    note 6 Y0
    moreover
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    moreover
    from 6 `x > y` x have "isnorm (Pinj d P2)"
      by (cases d) (simp, cases P2, auto)
    ultimately have ?case by (simp add: mkPinj_cn)
  }
  ultimately show ?case by blast
next
  case (7 x P2 Q2 y R)
  have "x = 0 \<or> x = 1 \<or> x > 1" by arith
  moreover {
    assume "x = 0"
    with 7 have ?case by (auto simp add: norm_Pinj_0_False)
  }
  moreover {
    assume "x = 1"
    from 7 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 `x = 1` have "isnorm (R \<oplus> P2)" by simp
    with 7 `x = 1` have ?case
      by (simp add: norm_PXtrans[of Q2 y _])
  }
  moreover {
    assume "x > 1" then have "\<exists>d. x=Suc (Suc d)" by arith
    then obtain d where X: "x=Suc (Suc d)" ..
    with 7 have NR: "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 X have "isnorm (Pinj (x - 1) P2)" by (cases P2) auto
    with 7 X NR have "isnorm (R \<oplus> Pinj (x - 1) P2)" by simp
    with `isnorm (PX Q2 y R)` X have ?case
      by (simp add: norm_PXtrans[of Q2 y _])
  }
  ultimately show ?case by blast
next
  case (8 Q2 y R x P2)
  have "x = 0 \<or> x = 1 \<or> x > 1" by arith
  moreover {
    assume "x = 0"
    with 8 have ?case
      by (auto simp add: norm_Pinj_0_False)
  }
  moreover {
    assume "x = 1"
    with 8 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 `x = 1` have "isnorm (R \<oplus> P2)"
      by simp
    with 8 `x = 1` have ?case
      by (simp add: norm_PXtrans[of Q2 y _])
  }
  moreover {
    assume "x > 1"
    then have "\<exists>d. x = Suc (Suc d)" by arith
    then obtain d where X: "x = Suc (Suc d)" ..
    with 8 have NR: "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 X have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 8 `x > 1` NR have "isnorm (R \<oplus> Pinj (x - 1) P2)"
      by simp
    with `isnorm (PX Q2 y R)` X have ?case
      by (simp add: norm_PXtrans[of Q2 y _])
  }
  ultimately show ?case by blast
next
  case (9 P1 x P2 Q1 y Q2)
  then have Y0: "y > 0" by (cases y) auto
  with 9 have X0: "x > 0" by (cases x) auto
  with 9 have NP1: "isnorm P1" and NP2: "isnorm P2"
    by (auto simp add: norm_PX1[of P1 _ P2] norm_PX2[of P1 _ P2])
  with 9 have NQ1: "isnorm Q1" and NQ2: "isnorm Q2"
    by (auto simp add: norm_PX1[of Q1 _ Q2] norm_PX2[of Q1 _ Q2])
  have "y < x \<or> x = y \<or> x < y" by arith
  moreover {
    assume sm1: "y < x"
    then have "\<exists>d. x = d + y" by arith
    then obtain d where sm2: "x = d + y" ..
    note 9 NQ1 NP1 NP2 NQ2 sm1 sm2
    moreover
    have "isnorm (PX P1 d (Pc 0))"
    proof (cases P1)
      case (PX p1 y p2)
      with 9 sm1 sm2 show ?thesis
        by (cases d) (simp, cases p2, auto)
    next
      case Pc
      with 9 sm1 sm2 show ?thesis
        by (cases d) auto
    next
      case Pinj
      with 9 sm1 sm2 show ?thesis
        by (cases d) auto
    qed
    ultimately have "isnorm (P2 \<oplus> Q2)" "isnorm (PX P1 (x - y) (Pc 0) \<oplus> Q1)"
      by auto
    with Y0 sm1 sm2 have ?case
      by (simp add: mkPX_cn)
  }
  moreover {
    assume "x = y"
    with 9 NP1 NP2 NQ1 NQ2 have "isnorm (P2 \<oplus> Q2)" "isnorm (P1 \<oplus> Q1)"
      by auto
    with `x = y` Y0 have ?case
      by (simp add: mkPX_cn)
  }
  moreover {
    assume sm1: "x < y"
    then have "\<exists>d. y = d + x" by arith
    then obtain d where sm2: "y = d + x" ..
    note 9 NQ1 NP1 NP2 NQ2 sm1 sm2
    moreover
    have "isnorm (PX Q1 d (Pc 0))"
    proof (cases Q1)
      case (PX p1 y p2)
      with 9 sm1 sm2 show ?thesis
        by (cases d) (simp, cases p2, auto)
    next
      case Pc
      with 9 sm1 sm2 show ?thesis
        by (cases d) auto
    next
      case Pinj
      with 9 sm1 sm2 show ?thesis
        by (cases d) auto
    qed
    ultimately have "isnorm (P2 \<oplus> Q2)" "isnorm (PX Q1 (y - x) (Pc 0) \<oplus> P1)"
      by auto
    with X0 sm1 sm2 have ?case
      by (simp add: mkPX_cn)
  }
  ultimately show ?case by blast
qed simp

text {* mul concerves normalizedness *}
lemma mul_cn: "isnorm P \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (P \<otimes> Q)"
proof (induct P Q rule: mul.induct)
  case (2 c i P2)
  then show ?case
    by (cases P2) (simp_all, cases i, simp_all add: mkPinj_cn)
next
  case (3 i P2 c)
  then show ?case
    by (cases P2) (simp_all, cases i, simp_all add: mkPinj_cn)
next
  case (4 c P2 i Q2)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 4 show ?case
    by (cases "c = 0") (simp_all, cases "i = 0", simp_all add: mkPX_cn)
next
  case (5 P2 i Q2 c)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 5 show ?case
    by (cases "c = 0") (simp_all, cases "i = 0", simp_all add: mkPX_cn)
next
  case (6 x P2 y Q2)
  have "x < y \<or> x = y \<or> x > y" by arith
  moreover {
    assume "x < y"
    then have "\<exists>d. y = d + x" by arith
    then obtain d where y: "y = d + x" ..
    moreover
    note 6
    moreover
    from 6 have "x > 0"
      by (cases x) (auto simp add: norm_Pinj_0_False)
    moreover
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    moreover
    from 6 `x < y` y have "isnorm (Pinj d Q2)"
      by (cases d) (simp, cases Q2, auto)
    ultimately have ?case by (simp add: mkPinj_cn)
  }
  moreover {
    assume "x = y"
    moreover
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    moreover
    from 6 have "y>0"
      by (cases y) (auto simp add: norm_Pinj_0_False)
    moreover
    note 6
    ultimately have ?case by (simp add: mkPinj_cn)
  }
  moreover {
    assume "x > y"
    then have "\<exists>d. x = d + y" by arith
    then obtain d where x: "x = d + y" ..
    moreover
    note 6
    moreover
    from 6 have "y > 0"
      by (cases y) (auto simp add: norm_Pinj_0_False)
    moreover
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    moreover
    from 6 `x > y` x have "isnorm (Pinj d P2)"
      by (cases d) (simp, cases P2, auto)
    ultimately have ?case by (simp add: mkPinj_cn)
  }
  ultimately show ?case by blast
next
  case (7 x P2 Q2 y R)
  then have Y0: "y > 0" by (cases y) auto
  have "x = 0 \<or> x = 1 \<or> x > 1" by arith
  moreover {
    assume "x = 0"
    with 7 have ?case
      by (auto simp add: norm_Pinj_0_False)
  }
  moreover {
    assume "x = 1"
    from 7 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 `x = 1` have "isnorm (R \<otimes> P2)" "isnorm Q2"
      by (auto simp add: norm_PX1[of Q2 y R])
    with 7 `x = 1` Y0 have ?case
      by (simp add: mkPX_cn)
  }
  moreover {
    assume "x > 1"
    then have "\<exists>d. x = Suc (Suc d)"
      by arith
    then obtain d where X: "x = Suc (Suc d)" ..
    from 7 have NR: "isnorm R" "isnorm Q2"
      by (auto simp add: norm_PX2[of Q2 y R] norm_PX1[of Q2 y R])
    moreover
    from 7 X have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    moreover
    from 7 have "isnorm (Pinj x P2)"
      by (cases P2) auto
    moreover
    note 7 X
    ultimately have "isnorm (R \<otimes> Pinj (x - 1) P2)" "isnorm (Pinj x P2 \<otimes> Q2)"
      by auto
    with Y0 X have ?case
      by (simp add: mkPX_cn)
  }
  ultimately show ?case by blast
next
  case (8 Q2 y R x P2)
  then have Y0: "y > 0"
    by (cases y) auto
  have "x = 0 \<or> x = 1 \<or> x > 1" by arith
  moreover {
    assume "x = 0"
    with 8 have ?case
      by (auto simp add: norm_Pinj_0_False)
  }
  moreover {
    assume "x = 1"
    from 8 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 `x = 1` have "isnorm (R \<otimes> P2)" "isnorm Q2"
      by (auto simp add: norm_PX1[of Q2 y R])
    with 8 `x = 1` Y0 have ?case
      by (simp add: mkPX_cn)
  }
  moreover {
    assume "x > 1"
    then have "\<exists>d. x = Suc (Suc d)" by arith
    then obtain d where X: "x = Suc (Suc d)" ..
    from 8 have NR: "isnorm R" "isnorm Q2"
      by (auto simp add: norm_PX2[of Q2 y R] norm_PX1[of Q2 y R])
    moreover
    from 8 X have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    moreover
    from 8 X have "isnorm (Pinj x P2)"
      by (cases P2) auto
    moreover
    note 8 X
    ultimately have "isnorm (R \<otimes> Pinj (x - 1) P2)" "isnorm (Pinj x P2 \<otimes> Q2)"
      by auto
    with Y0 X have ?case by (simp add: mkPX_cn)
  }
  ultimately show ?case by blast
next
  case (9 P1 x P2 Q1 y Q2)
  from 9 have X0: "x > 0" by (cases x) auto
  from 9 have Y0: "y > 0" by (cases y) auto
  note 9
  moreover
  from 9 have "isnorm P1" "isnorm P2"
    by (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  moreover
  from 9 have "isnorm Q1" "isnorm Q2"
    by (auto simp add: norm_PX1[of Q1 y Q2] norm_PX2[of Q1 y Q2])
  ultimately have "isnorm (P1 \<otimes> Q1)" "isnorm (P2 \<otimes> Q2)"
    "isnorm (P1 \<otimes> mkPinj 1 Q2)" "isnorm (Q1 \<otimes> mkPinj 1 P2)"
    by (auto simp add: mkPinj_cn)
  with 9 X0 Y0 have
    "isnorm (mkPX (P1 \<otimes> Q1) (x + y) (P2 \<otimes> Q2))"
    "isnorm (mkPX (P1 \<otimes> mkPinj (Suc 0) Q2) x (Pc 0))"
    "isnorm (mkPX (Q1 \<otimes> mkPinj (Suc 0) P2) y (Pc 0))"
    by (auto simp add: mkPX_cn)
  then show ?case by (simp add: add_cn)
qed simp

text {* neg conserves normalizedness *}
lemma neg_cn: "isnorm P \<Longrightarrow> isnorm (neg P)"
proof (induct P)
  case (Pinj i P2)
  then have "isnorm P2"
    by (simp add: norm_Pinj[of i P2])
  with Pinj show ?case
    by (cases P2) (auto, cases i, auto)
next
  case (PX P1 x P2) note PX1 = this
  from PX have "isnorm P2" "isnorm P1"
    by (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  with PX show ?case
  proof (cases P1)
    case (PX p1 y p2)
    with PX1 show ?thesis
      by (cases x) (auto, cases p2, auto)
  next
    case Pinj
    with PX1 show ?thesis
      by (cases x) auto
  qed (cases x, auto)
qed simp

text {* sub conserves normalizedness *}
lemma sub_cn: "isnorm p \<Longrightarrow> isnorm q \<Longrightarrow> isnorm (p \<ominus> q)"
  by (simp add: sub_def add_cn neg_cn)

text {* sqr conserves normalizizedness *}
lemma sqr_cn: "isnorm P \<Longrightarrow> isnorm (sqr P)"
proof (induct P)
  case Pc
  then show ?case by simp
next
  case (Pinj i Q)
  then show ?case
    by (cases Q) (auto simp add: mkPX_cn mkPinj_cn, cases i, auto simp add: mkPX_cn mkPinj_cn)
next
  case (PX P1 x P2)
  then have "x + x \<noteq> 0" "isnorm P2" "isnorm P1"
    by (cases x, auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  with PX have "isnorm (mkPX (Pc (1 + 1) \<otimes> P1 \<otimes> mkPinj (Suc 0) P2) x (Pc 0))"
      and "isnorm (mkPX (sqr P1) (x + x) (sqr P2))"
    by (auto simp add: add_cn mkPX_cn mkPinj_cn mul_cn)
  then show ?case
    by (auto simp add: add_cn mkPX_cn mkPinj_cn mul_cn)
qed

text {* pow conserves normalizedness *}
lemma pow_cn: "isnorm P \<Longrightarrow> isnorm (pow n P)"
proof (induct n arbitrary: P rule: less_induct)
  case (less k)
  show ?case
  proof (cases "k = 0")
    case True
    then show ?thesis by simp
  next
    case False
    then have K2: "k div 2 < k" by (cases k) auto
    from less have "isnorm (sqr P)" by (simp add: sqr_cn)
    with less False K2 show ?thesis
      by (cases "even k") (auto simp add: mul_cn elim: evenE oddE)
  qed
qed

end


(* Author: Matthias Brun,   ETH Zürich, 2019 *)
(* Author: Dmitriy Traytel, ETH Zürich, 2019 *)

section \<open>Syntax of $\lambda\bullet$\<close>

(*<*)
theory Syntax
  imports Nominal2_Lemmas
begin
(*>*)

typedecl hash
instantiation hash :: pure
begin
definition permute_hash :: "perm \<Rightarrow> hash \<Rightarrow> hash" where
  "permute_hash \<pi> h = h"
instance proof qed (simp_all add: permute_hash_def)
end

atom_decl var

nominal_datatype "term" =
  Unit |
  Var var |
  Lam x::var t::"term" binds x in t |
  Rec x::var t::"term" binds x in t |
  Inj1 "term" |
  Inj2 "term" |
  Pair "term" "term" |
  Let "term" x::var t::"term" binds x in t |
  App "term" "term" |
  Case "term" "term" "term" |
  Prj1 "term" |
  Prj2 "term" |
  Roll "term" |
  Unroll "term" |
  Auth "term" |
  Unauth "term" |
  Hash hash |
  Hashed hash "term"

atom_decl tvar

nominal_datatype ty =
  One |
  Fun ty ty |
  Sum ty ty |
  Prod ty ty |
  Mu \<alpha>::tvar \<tau>::ty binds \<alpha> in \<tau> |
  Alpha tvar |
  AuthT ty

lemma no_tvars_in_term[simp]: "atom (x :: tvar) \<sharp> (t :: term)"
  by (induct t rule: term.induct) auto

lemma no_vars_in_ty[simp]: "atom (x :: var) \<sharp> (\<tau> :: ty)"
  by (induct \<tau> rule: ty.induct) auto

inductive "value" :: "term \<Rightarrow> bool" where
  "value Unit" |
  "value (Var _)" |
  "value (Lam _ _)" |
  "value (Rec _ _)" |
  "value v \<Longrightarrow> value (Inj1 v)" |
  "value v \<Longrightarrow> value (Inj2 v)" |
  "\<lbrakk> value v\<^sub>1; value v\<^sub>2 \<rbrakk> \<Longrightarrow> value (Pair v\<^sub>1 v\<^sub>2)" |
  "value v \<Longrightarrow> value (Roll v)" |
  "value (Hash _)" |
  "value v \<Longrightarrow> value (Hashed _ v)"

declare value.intros[simp]
declare value.intros[intro]

equivariance "value"

lemma value_inv[simp]:
  "\<not> value (Let e\<^sub>1 x e\<^sub>2)"
  "\<not> value (App v v')"
  "\<not> value (Case v v\<^sub>1 v\<^sub>2)"
  "\<not> value (Prj1 v)"
  "\<not> value (Prj2 v)"
  "\<not> value (Unroll v)"
  "\<not> value (Auth v)"
  "\<not> value (Unauth v)"
  using value.cases by fastforce+

inductive_cases value_Inj1_inv[elim]: "value (Inj1 e)"
inductive_cases value_Inj2_inv[elim]: "value (Inj2 e)"
inductive_cases value_Pair_inv[elim]: "value (Pair e\<^sub>1 e\<^sub>2)"
inductive_cases value_Roll_inv[elim]: "value (Roll e)"
inductive_cases value_Hashed_inv[elim]: "value (Hashed h e)"

abbreviation closed :: "term \<Rightarrow> bool" where
  "closed t \<equiv> (\<forall>x::var. atom x \<sharp> t)"

(*<*)
end
(*>*)


theory PartialQuantales
  imports PartialMonoid Quantale
begin

notation pmult_one ("1'")

text {*
  Quantales with \<Squnion> distributivity
*}

class partial_near_quantale = complete_lattice + partial_semigroup +
  assumes partial_qSup_distr: "\<forall>y \<in> Y. y ## x \<Longrightarrow> \<Squnion> Y \<oplus> x = \<Squnion> ((\<lambda>y. y \<oplus> x) ` Y)"

class partial_pre_quantale = partial_near_quantale +
  assumes partial_qSup_subdistl:  "\<forall>y \<in> Y. x ## y \<Longrightarrow> \<Squnion> ((\<lambda>y. x \<oplus> y) ` Y) \<le> x \<oplus> \<Squnion> Y"

class partial_quantale = partial_pre_quantale +
  assumes partial_qSup_supdistl: "\<forall>y \<in> Y. x ## y \<Longrightarrow> x \<oplus> \<Squnion> Y \<le> \<Squnion> ((\<lambda>y. x \<oplus> y) ` Y)"
begin

lemma partial_qSup_distl: "\<forall>y \<in> Y. x ## y \<Longrightarrow> x \<oplus> \<Squnion> Y = \<Squnion> ((\<lambda>y. x \<oplus> y) ` Y)"
  by (metis antisym_conv partial_qSup_subdistl partial_qSup_supdistl)

end

(* Quantale with different signature, derived from partial mult *)
class near_quantale_pmult = partial_near_quantale + totality
begin
sublocale Sup_pmult!: near_quantale _ _ _ _ _ _ _ _ pmult
  apply (default, metis pmult_assoc totality)
  by (metis partial_qSup_distr totality)
end

class near_quantale_pmult_unital = near_quantale_pmult + partial_monoid
begin
sublocale Sup_pmult!: near_quantale_unital "1'" "op \<oplus>"
  by default (simp_all add: pmult_onel pmult_oner)

end

class pre_quantale_pmult = partial_pre_quantale + totality
begin
subclass near_quantale_pmult ..
sublocale Sup_pmult!: pre_quantale  _ _ _ _ _ _ _ _ pmult
  by default (metis partial_qSup_subdistl totality)
end

class quantale_pmult = partial_quantale + totality
begin
subclass pre_quantale_pmult ..
sublocale Sup_pmult!: quantale _ _ _ _ _ _ _ _ pmult
  by default (metis partial_qSup_supdistl totality)
end

class quantale_pmult_unital = near_quantale_pmult_unital + quantale_pmult
begin
sublocale Sup_pmult!: quantale_unital "1'" "op \<oplus>" ..
end

class comm_quantale_pmult = quantale_pmult + partial_ab_semigroup
class comm_quantale_pmult_unital = quantale_pmult_unital + comm_quantale_pmult
class distrib_quantale_pmult = quantale_pmult + complete_distrib_lattice
class distrib_comm_quantale_pmult_unital = distrib_quantale_pmult + comm_quantale_pmult_unital

end


theory NuHelpMath
  imports Main
begin
text \<open>Supplementary mathematical notions for the \<nu>-system\<close>

notation rel_prod (infixr "\<times>\<^sub>r" 80)
notation pred_prod (infixr "\<times>\<^sub>p" 80)

lemma pair_exists: "Ex P \<longleftrightarrow> (\<exists>a b. P (a,b))" using split_paired_Ex .
lemma pair_forall: "All P \<longleftrightarrow> (\<forall>a b. P (a,b))" using split_paired_All .
lemmas pair_All = split_paired_all

lemma conj_imp: "(P \<and> Q \<Longrightarrow> PROP R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> PROP R)" by rule simp+

end


theory rev
imports Main
        "../data/list"
        "../funcs/append"
        "$HIPSTER_HOME/IsaHipster"

begin

fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
| "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"

hipster rev append
lemma lemma_ab [thy_expl]: "append (rev x4) (rev y4) = rev (append y4 x4)"
by (hipster_induct_schemes rev.simps append.simps)

lemma lemma_ac [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes rev.simps append.simps)

end


(*  Title:       Executable Matrix Operations on Matrices of Arbitrary Dimensions
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Utility Functions and Lemmas\<close>

theory Utility
imports Main
begin

subsection \<open>Miscellaneous\<close>

lemma ballI2[Pure.intro]:
  assumes "\<And>x y. (x, y) \<in> A \<Longrightarrow> P x y"
  shows "\<forall>(x, y)\<in>A. P x y"
  using assms by auto

lemma infinite_imp_elem: "\<not> finite A \<Longrightarrow> \<exists> x. x \<in> A"
  by (cases "A = {}", auto)

lemma infinite_imp_many_elems:
  "infinite A \<Longrightarrow> \<exists> xs. set xs \<subseteq> A \<and> length xs = n \<and> distinct xs"
proof (induct n arbitrary: A)
  case (Suc n)
  from infinite_imp_elem[OF Suc(2)] obtain x where x: "x \<in> A" by auto
  from Suc(2) have "infinite (A - {x})" by auto
  from Suc(1)[OF this] obtain xs where "set xs \<subseteq> A - {x}" and "length xs = n" and "distinct xs" by auto
  with x show ?case by (intro exI[of _ "x # xs"], auto)
qed auto

lemma inf_pigeonhole_principle:
  assumes "\<forall>k::nat. \<exists>i<n::nat. f k i"
  shows "\<exists>i<n. \<forall>k. \<exists>k'\<ge>k. f k' i"
proof -
  have nfin: "~ finite (UNIV :: nat set)" by auto
  have fin: "finite ({i. i < n})" by auto
  from pigeonhole_infinite_rel[OF nfin fin] assms
  obtain i where i: "i < n" and nfin: "\<not> finite {a. f a i}" by auto
  show ?thesis
  proof (intro exI conjI, rule i, intro allI)
    fix k
    have "finite {a. f a i \<and> a < k}" by auto
    with nfin have "\<not> finite ({a. f a i} - {a. f a i \<and> a < k})" by auto
    from infinite_imp_elem[OF this]
    obtain a where "f a i" and "a \<ge> k" by auto
    thus "\<exists> k' \<ge> k. f k' i" by force
  qed
qed

lemma map_upt_Suc: "map f [0 ..< Suc n] = f 0 # map (\<lambda> i. f (Suc i)) [0 ..< n]"
  by (induct n arbitrary: f, auto)

lemma map_upt_add: "map f [0 ..< n + m] = map f [0 ..< n] @ map (\<lambda> i. f (i + n)) [0 ..< m]"
proof (induct n arbitrary: f)
  case (Suc n f)
  have "map f [0 ..< Suc n + m] = map f [0 ..< Suc (n+m)]" by simp
  also have "\<dots> = f 0 # map (\<lambda> i. f (Suc i)) [0 ..< n + m]" unfolding map_upt_Suc ..
  finally show ?case unfolding Suc map_upt_Suc by simp
qed simp

lemma map_upt_split: assumes i: "i < n"
  shows "map f [0 ..< n] = map f [0 ..< i] @ f i # map (\<lambda> j. f (j + Suc i)) [0 ..< n - Suc i]"
proof -
  from i have "n = i + Suc 0 + (n - Suc i)" by arith
  hence id: "[0 ..< n] = [0 ..< i + Suc 0 + (n - Suc i)]" by simp
  show ?thesis unfolding id
    unfolding map_upt_add by auto
qed

lemma all_Suc_conv:
  "(\<forall>i<Suc n. P i) \<longleftrightarrow> P 0 \<and> (\<forall>i<n. P (Suc i))" (is "?l = ?r")
proof
  assume ?l thus ?r by auto
next
  assume ?r show ?l
  proof (intro allI impI)
    fix i
    assume "i < Suc n"
    with \<open>?r\<close> show "P i" by (cases i, auto)
  qed
qed

lemma ex_Suc_conv:
  "(\<exists>i<Suc n. P i) \<longleftrightarrow> P 0 \<or> (\<exists>i<n. P (Suc i))" (is "?l = ?r")
  using all_Suc_conv[of n "\<lambda>i. \<not> P i"] by blast

fun sorted_list_subset :: "'a :: linorder list \<Rightarrow> 'a list \<Rightarrow> 'a option" where
  "sorted_list_subset (a # as) (b # bs) =
    (if a = b then sorted_list_subset as (b # bs)
     else if a > b then sorted_list_subset (a # as) bs
     else Some a)"
| "sorted_list_subset [] _ = None"
| "sorted_list_subset (a # _) [] = Some a"

lemma sorted_list_subset:
  assumes "sorted as" and "sorted bs"
  shows "(sorted_list_subset as bs = None) = (set as \<subseteq> set bs)"
using assms
proof (induct rule: sorted_list_subset.induct)
  case (2 bs)
  thus ?case by auto
next
  case (3 a as)
  thus ?case by auto
next
  case (1 a as b bs)
  from 1(3) have sas: "sorted as" and a: "\<And> a'. a' \<in> set as \<Longrightarrow> a \<le> a'" by (auto)
  from 1(4) have sbs: "sorted bs" and b: "\<And> b'. b' \<in> set bs \<Longrightarrow> b \<le> b'" by (auto)
  show ?case
  proof (cases "a = b")
    case True
    from 1(1)[OF this sas 1(4)] True show ?thesis by auto
  next
    case False note oFalse = this
    show ?thesis
    proof (cases "a > b")
      case True
      with a b have "b \<notin> set as" by force
      with 1(2)[OF False True 1(3) sbs] False True show ?thesis by auto
    next
      case False
      with oFalse have "a < b" by auto
      with a b have "a \<notin> set bs" by force
      with oFalse False show ?thesis by auto
    qed
  qed
qed

lemma zip_nth_conv: "length xs = length ys \<Longrightarrow> zip xs ys = map (\<lambda> i. (xs ! i, ys ! i)) [0 ..< length ys]"
proof (induct xs arbitrary: ys, simp)
  case (Cons x xs)
  then obtain y yys where ys: "ys = y # yys" by (cases ys, auto)
  with Cons have len: "length xs = length yys" by simp
  show ?case unfolding ys
    by (simp del: upt_Suc add: map_upt_Suc, unfold Cons(1)[OF len], simp)
qed

lemma nth_map_conv:
  assumes "length xs = length ys"
    and "\<forall>i<length xs. f (xs ! i) = g (ys ! i)"
  shows "map f xs = map g ys"
using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs) thus ?case
  proof (induct ys)
    case (Cons y ys)
    have "\<forall>i<length xs. f (xs ! i) = g (ys ! i)"
    proof (intro allI impI)
      fix i assume "i < length xs" thus "f (xs ! i) = g (ys ! i)" using Cons(4) by force
    qed
    with Cons show ?case by auto
  qed simp
qed simp

lemma sum_list_0: "\<lbrakk>\<And> x. x \<in> set xs \<Longrightarrow> x = 0\<rbrakk> \<Longrightarrow> sum_list xs = 0"
  by (induct xs, auto)

lemma foldr_foldr_concat: "foldr (foldr f) m a = foldr f (concat m) a"
proof (induct m arbitrary: a)
  case Nil show ?case by simp
next
  case (Cons v m a)
  show ?case
    unfolding concat.simps foldr_Cons o_def Cons
    unfolding foldr_append by simp
qed

lemma sum_list_double_concat:
  fixes f :: "'b \<Rightarrow> 'c \<Rightarrow> 'a :: comm_monoid_add" and g as bs
  shows "sum_list (concat (map (\<lambda> i. map (\<lambda> j. f i j + g i j) as) bs))
      = sum_list (concat (map (\<lambda> i. map (\<lambda> j. f i j) as) bs)) +
        sum_list (concat (map (\<lambda> i. map (\<lambda> j. g i j) as) bs))"
proof (induct bs)
  case Nil thus ?case by simp
next
  case (Cons b bs)
  have id: "(\<Sum>j\<leftarrow>as. f b j + g b j) = sum_list (map (f b) as) + sum_list (map (g b) as)"
    by (induct as, auto simp: ac_simps)
  show ?case unfolding list.map concat.simps sum_list_append
    unfolding Cons
    unfolding id
    by (simp add: ac_simps)
qed

fun max_list :: "nat list \<Rightarrow> nat" where
  "max_list [] = 0"
| "max_list (x # xs) = max x (max_list xs)"

lemma max_list: "x \<in> set xs \<Longrightarrow> x \<le> max_list xs"
  by (induct xs) auto

lemma max_list_mem: "xs \<noteq> [] \<Longrightarrow> max_list xs \<in> set xs"
proof (induct xs)
  case (Cons x xs)
  show ?case
  proof (cases "x \<ge> max_list xs")
    case True
    thus ?thesis by auto
  next
    case False
    hence max: "max_list xs > x" by auto
    hence nil: "xs \<noteq> []" by (cases xs, auto)
    from max have max: "max x (max_list xs) = max_list xs" by auto
    from Cons(1)[OF nil] max show ?thesis by auto
  qed
qed simp

lemma all_less_two: "(\<forall> i < Suc (Suc 0). P i) = (P 0 \<and> P (Suc 0))" (is "?l = ?r")
proof
  assume ?r
  show ?l
  proof(intro allI impI)
    fix i
    assume "i < Suc (Suc 0)"
    hence "i = 0 \<or> i = Suc 0" by auto
    with \<open>?r\<close> show "P i" by auto
  qed
qed auto

text \<open>Induction over a finite set of natural numbers.\<close>
lemma bound_nat_induct[consumes 1]:
  assumes "n \<in> {l..u}" and "P l" and "\<And>n. \<lbrakk>P n; n \<in> {l..<u}\<rbrakk> \<Longrightarrow> P (Suc n)"
  shows "P n"
using assms
proof (induct n)
 case (Suc n) thus ?case by (cases "Suc n = l") auto
qed simp

end