(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

section \<open>Definition of Subobjects\<close>

theory SubObj
imports ClassRel
begin

subsection \<open>General definitions\<close>

type_synonym
  subobj = "cname  \<times> path"

definition mdc :: "subobj \<Rightarrow> cname" where
  "mdc S = fst S"

definition ldc :: "subobj \<Rightarrow> cname" where
  "ldc S = last (snd S)"

lemma mdc_tuple [simp]: "mdc (C,Cs) = C"
by(simp add:mdc_def)

lemma ldc_tuple [simp]: "ldc (C,Cs) = last Cs"
by(simp add:ldc_def)

subsection \<open>Subobjects according to Rossie-Friedman\<close>

fun is_subobj :: "prog \<Rightarrow> subobj \<Rightarrow> bool" \<comment> \<open>legal subobject to class hierarchie\<close> where
  "is_subobj P (C, []) \<longleftrightarrow> False"
| "is_subobj P (C, [D]) \<longleftrightarrow> (is_class P C \<and> C = D)
                                \<or> (\<exists> X. P \<turnstile> C \<preceq>\<^sup>* X \<and> P \<turnstile> X \<prec>\<^sub>S D)"
| "is_subobj P (C, D # E # Xs) = (let Ys=butlast (D # E # Xs);
                                      Y=last (D # E # Xs);
                                      X=last Ys
                                in is_subobj P (C, Ys) \<and> P \<turnstile> X \<prec>\<^sub>R Y)"

lemma subobj_aux_rev:
assumes 1:"is_subobj P ((C,C'#rev Cs@[C'']))"
shows "is_subobj P ((C,C'#rev Cs))"
proof -
  obtain Cs' where Cs':"Cs' = rev Cs" by simp
  hence rev:"Cs'@[C''] = rev Cs@[C'']" by simp
  from this obtain D Ds where DDs:"Cs'@[C''] = D#Ds" by (cases Cs') auto
  with 1 rev have subo:"is_subobj P ((C,C'#D#Ds))" by simp
  from DDs have "butlast (C'#D#Ds) = C'#Cs'" by (cases Cs') auto
  with subo have "is_subobj P ((C,C'#Cs'))" by simp
  with Cs' show ?thesis by simp
qed

lemma subobj_aux:
assumes 1:"is_subobj P ((C,C'#Cs@[C'']))"
shows "is_subobj P ((C,C'#Cs))"
proof -
  from 1 obtain Cs' where Cs':"Cs' = rev Cs" by simp
  with 1 have "is_subobj P ((C,C'#rev Cs'@[C'']))" by simp
  hence "is_subobj P ((C,C'#rev Cs'))" by (rule subobj_aux_rev)
  with Cs' show ?thesis by simp
qed

lemma isSubobj_isClass:
assumes 1:"is_subobj P (R)"
shows "is_class P (mdc R)"

proof -
  obtain C' Cs' where R:"R = (C',Cs')" by(cases R) auto
  with 1 have ne:"Cs' \<noteq> []" by (cases Cs') auto
  from this obtain C'' Cs'' where C''Cs'':"Cs' = C''#Cs''" by (cases Cs') auto
  from this obtain Ds where "Ds = rev Cs''" by simp
  with 1 R C''Cs'' have subo1:"is_subobj P ((C',C''#rev Ds))" by simp
  with R show ?thesis
    by (induct Ds,auto simp:mdc_def split:if_split_asm dest:subobj_aux,
      auto elim:converse_rtranclE dest!:subclsS_subcls1 elim:subcls1_class)
qed

lemma isSubobjs_subclsR_rev:
assumes 1:"is_subobj P ((C,Cs@[D,D']@(rev Cs')))"
shows "P \<turnstile> D \<prec>\<^sub>R D'"
using 1
proof (induct Cs')
  case Nil
  from this obtain Cs' X Y Xs where Cs'1:"Cs' = Cs@[D,D']"
    and "X = hd(Cs@[D,D'])" and "Y = hd(tl(Cs@[D,D']))"
    and "Xs =  tl(tl(Cs@[D,D']))" by simp
  hence Cs'2:"Cs' = X#Y#Xs" by (cases Cs) auto
  from Cs'1 have last:"last Cs' = D'" by simp
  from Cs'1 have butlast:"last(butlast Cs') = D" by (simp add:butlast_tail)
  from Nil Cs'1 Cs'2 have "is_subobj P ((C,X#Y#Xs))" by simp
  with last butlast Cs'2 show ?case by simp
next
  case (Cons C'' Cs'')
  have IH:"is_subobj P ( (C, Cs @ [D, D'] @ rev Cs'')) \<Longrightarrow> P \<turnstile> D \<prec>\<^sub>R D'" by fact
  from Cons obtain Cs' X Y Xs where Cs'1:"Cs' = Cs@[D,D']@(rev (C''#Cs''))"
    and "X = hd(Cs@[D,D']@(rev (C''#Cs'')))"
    and "Y = hd(tl(Cs@[D,D']@(rev (C''#Cs''))))"
    and "Xs =  tl(tl(Cs@[D,D']@(rev (C''#Cs''))))" by simp
  hence Cs'2:"Cs' = X#Y#Xs" by (cases Cs) auto
  from Cons Cs'1 Cs'2 have "is_subobj P ((C,X#Y#Xs))" by simp
  hence sub:"is_subobj P ((C,butlast (X#Y#Xs)))" by simp
  from Cs'1 obtain E Es where Cs'3:"Cs' = Es@[E]" by (cases Cs') auto
  with Cs'1 have butlast:"Es = Cs@[D,D']@(rev Cs'')" by simp
  from Cs'3 have "butlast Cs' = Es" by simp
  with butlast have "butlast Cs' = Cs@[D,D']@(rev Cs'')" by simp
  with Cs'2 sub have "is_subobj P ((C,Cs@[D,D']@(rev Cs'')))"
    by simp
  with IH show ?case by simp
qed

lemma isSubobjs_subclsR:
assumes 1:"is_subobj P ((C,Cs@[D,D']@Cs'))"
shows "P \<turnstile> D \<prec>\<^sub>R D'"

proof -
  from 1 obtain Cs'' where "Cs'' = rev Cs'" by simp
  with 1 have "is_subobj P ((C,Cs@[D,D']@(rev Cs'')))" by simp
  thus ?thesis by (rule isSubobjs_subclsR_rev)
qed

lemma mdc_leq_ldc_aux:
assumes 1:"is_subobj P ((C,C'#rev Cs'))"
shows "P \<turnstile> C \<preceq>\<^sup>* last (C'#rev Cs')"
using 1
proof (induct Cs')
  case Nil
  from 1 have "is_class P C"
    by (drule_tac R="(C,C'#rev Cs')" in isSubobj_isClass, simp add:mdc_def)
  with Nil show ?case
    proof (cases "C=C'")
      case True
      thus ?thesis by simp
    next
      case False
      with Nil show ?thesis
        by (auto dest!:subclsS_subcls1)
    qed
  next
    case (Cons C'' Cs'')
    have IH:"is_subobj P ( (C, C' # rev Cs'')) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* last (C' # rev Cs'')"
      and subo:"is_subobj P ( (C, C' # rev (C'' # Cs'')))" by fact+
    hence "is_subobj P ( (C, C' # rev Cs''))" by (simp add:subobj_aux_rev)
    with IH have rel:"P \<turnstile> C \<preceq>\<^sup>* last (C' # rev Cs'')" by simp
    from subo obtain D Ds where DDs:"C' # rev Cs'' = Ds@[D]"
      by (cases Cs'') auto
    hence " C' # rev (C'' # Cs'') = Ds@[D,C'']" by simp
    with subo have "is_subobj P ((C,Ds@[D,C'']))" by (cases Ds) auto
    hence "P \<turnstile> D \<prec>\<^sub>R C''" by (rule_tac Cs'="[]" in isSubobjs_subclsR) simp
    hence rel1:"P \<turnstile> D \<prec>\<^sup>1 C''" by (rule subclsR_subcls1)
    from DDs have "D = last (C' # rev Cs'')" by simp
    with rel1 have lastrel1:"P \<turnstile> last (C' # rev Cs'') \<prec>\<^sup>1 C''" by simp
    with rel have "P \<turnstile> C \<preceq>\<^sup>* C''"
      by(rule_tac b="last (C' # rev Cs'')" in rtrancl_into_rtrancl) simp
    thus ?case by simp
qed

lemma mdc_leq_ldc:
assumes 1:"is_subobj P (R)"
shows "P \<turnstile> mdc R \<preceq>\<^sup>* ldc R"

proof -
  from 1 obtain C Cs where R:"R = (C,Cs)" by (cases R) auto
  with 1 have ne:"Cs \<noteq> []" by (cases Cs) auto
  from this obtain C' Cs' where Cs:"Cs = C'#Cs'" by (cases Cs) auto
  from this obtain Cs'' where Cs':"Cs'' = rev Cs'" by simp
  with R Cs 1 have "is_subobj P ((C,C'#rev Cs''))" by simp
  hence rel:"P \<turnstile> C \<preceq>\<^sup>* last (C'#rev Cs'')" by (rule mdc_leq_ldc_aux)
  from R Cs Cs' have ldc:"last (C'#rev Cs'') = ldc R" by(simp add:ldc_def)
  from R have "mdc R = C" by(simp add:mdc_def)
  with ldc rel show ?thesis by simp
qed

text\<open>Next three lemmas show subobject property as presented in literature\<close>

lemma class_isSubobj:
  "is_class P C \<Longrightarrow> is_subobj P ((C,[C]))"
by simp

lemma repSubobj_isSubobj:
assumes 1:"is_subobj P ((C,Xs@[X]))" and 2:"P \<turnstile> X \<prec>\<^sub>R Y"
shows "is_subobj P ((C,Xs@[X,Y]))"

using 1
proof -
  obtain Cs D E Cs' where Cs1:"Cs = Xs@[X,Y]" and  "D = hd(Xs@[X,Y])"
    and "E = hd(tl(Xs@[X,Y]))" and "Cs' = tl(tl(Xs@[X,Y]))"by simp
  hence Cs2:"Cs = D#E#Cs'" by (cases Xs) auto
  with 1 Cs1 have subobj_butlast:"is_subobj P ((C,butlast(D#E#Cs')))"
    by (simp add:butlast_tail)
  with 2 Cs1 Cs2 have "P \<turnstile> (last(butlast(D#E#Cs'))) \<prec>\<^sub>R last(D#E#Cs')"
    by (simp add:butlast_tail)
  with subobj_butlast have "is_subobj P ((C,(D#E#Cs')))" by simp
  with Cs1 Cs2 show ?thesis by simp
qed

lemma shSubobj_isSubobj:
assumes 1:  "is_subobj P ((C,Xs@[X]))" and 2:"P \<turnstile> X \<prec>\<^sub>S Y"
shows "is_subobj P ((C,[Y]))"

using 1
proof -
  from 1 have classC:"is_class P C"
    by (drule_tac R="(C,Xs@[X])" in isSubobj_isClass, simp add:mdc_def)
  from 1 have "P \<turnstile> C \<preceq>\<^sup>* X"
    by (drule_tac R="(C,Xs@[X])" in mdc_leq_ldc, simp add:mdc_def ldc_def)
  with classC 2 show ?thesis by fastforce
qed

text\<open>Auxiliary lemmas\<close>

lemma build_rec_isSubobj_rev:
assumes 1:"is_subobj P ((D,D#rev Cs))" and 2:" P \<turnstile> C \<prec>\<^sub>R D"
shows "is_subobj P ((C,C#D#rev Cs))"
using 1
proof (induct Cs)
  case Nil
  from 2 have "is_class P C" by (auto dest:subclsRD simp add:is_class_def)
  with 1 2 show ?case by simp
next
  case (Cons C' Cs')
  have suboD:"is_subobj P ((D,D#rev (C'#Cs')))"
    and IH:"is_subobj P ((D,D#rev Cs')) \<Longrightarrow> is_subobj P ((C,C#D#rev Cs'))" by fact+
  obtain E Es where E:"E = hd (rev (C'#Cs'))" and Es:"Es = tl (rev (C'#Cs'))"
    by simp
  with E have E_Es:"rev (C'#Cs') = E#Es" by simp
  with E Es have butlast:"butlast (D#E#Es) = D#rev Cs'" by simp
  from E_Es suboD have suboDE:"is_subobj P ((D,D#E#Es))" by simp
  hence "is_subobj P ((D,butlast (D#E#Es)))" by simp
  with butlast have "is_subobj P ((D,D#rev Cs'))" by simp
  with IH have suboCD:"is_subobj P ( (C, C#D#rev Cs'))" by simp
  from suboDE obtain Xs X Y Xs' where Xs':"Xs' = D#E#Es"
    and bb:"Xs = butlast (butlast (D#E#Es))"
    and lb:"X = last(butlast (D#E#Es))" and l:"Y = last (D#E#Es)" by simp
  from this obtain Xs'' where Xs'':"Xs'' = Xs@[X]" by simp
  with bb lb have "Xs'' = butlast (D#E#Es)" by simp
  with l have "D#E#Es = Xs''@[Y]" by simp
  with Xs'' have "D#E#Es = Xs@[X]@[Y]" by simp
  with suboDE have "is_subobj P ((D,Xs@[X,Y]))" by simp
  hence subR:"P \<turnstile> X \<prec>\<^sub>R Y"  by(rule_tac Cs="Xs" and Cs'="[]" in isSubobjs_subclsR) simp
  from E_Es Es have "last (D#E#Es) = C'" by simp
  with subR lb l butlast have "P \<turnstile> last(D#rev Cs') \<prec>\<^sub>R C'"
    by (auto split:if_split_asm)
  with suboCD show ?case by simp
qed

lemma build_rec_isSubobj:
assumes 1:"is_subobj P ((D,D#Cs))" and 2:" P \<turnstile> C \<prec>\<^sub>R D"
shows "is_subobj P ((C,C#D#Cs))"

proof -
  obtain Cs' where Cs':"Cs' = rev Cs" by simp
  with 1 have "is_subobj P ((D,D#rev Cs'))" by simp
  with 2 have "is_subobj P ((C,C#D#rev Cs'))"
    by - (rule build_rec_isSubobj_rev)
  with Cs' show ?thesis by simp
qed

lemma isSubobj_isSubobj_isSubobj_rev:
assumes 1:"is_subobj P ((C,[D]))" and 2:"is_subobj P ((D,D#(rev Cs)))"
shows "is_subobj P ((C,D#(rev Cs)))"
using 2
proof (induct Cs)
 case Nil
 with 1 show ?case by simp
next
  case (Cons C' Cs')
  have IH:"is_subobj P ((D,D#rev Cs')) \<Longrightarrow> is_subobj P ((C,D#rev Cs'))"
    and "is_subobj P ((D,D#rev (C'#Cs')))" by fact+
  hence suboD:"is_subobj P ((D,D#rev Cs'@[C']))" by simp
  hence "is_subobj P ((D,D#rev Cs'))" by (rule subobj_aux_rev)
  with IH have suboC:"is_subobj P ((C,D#rev Cs'))" by simp
  obtain C'' where C'': "C'' = last (D # rev Cs')" by simp
  moreover have "D # rev Cs' = butlast (D # rev Cs') @ [last (D # rev Cs')]"
    by (rule append_butlast_last_id [symmetric]) simp
  ultimately have butlast: "D # rev Cs' = butlast (D  #rev Cs') @ [C'']"
    by simp
  hence butlast2:"D#rev Cs'@[C'] = butlast(D#rev Cs')@[C'']@[C']" by simp
  with suboD have "is_subobj P ((D,butlast(D#rev Cs')@[C'']@[C']))"
    by simp
  with C'' have subR:"P \<turnstile> C'' \<prec>\<^sub>R C'"
    by (rule_tac Cs="butlast(D#rev Cs')" and Cs'="[]" in isSubobjs_subclsR)simp
  with C'' suboC butlast have "is_subobj P ((C,butlast(D#rev Cs')@[C'']@[C']))"
    by (auto intro:repSubobj_isSubobj simp del:butlast.simps)
  with butlast2 have "is_subobj P ((C,D#rev Cs'@[C']))"
    by (cases Cs')auto
  thus ?case by simp
qed

lemma isSubobj_isSubobj_isSubobj:
assumes 1:"is_subobj P ((C,[D]))" and 2:"is_subobj P ((D,D#Cs))"
shows "is_subobj P ((C,D#Cs))"

proof -
  obtain Cs' where Cs':"Cs' = rev Cs" by simp
  with 2 have "is_subobj P ((D,D#rev Cs'))" by simp
  with 1 have "is_subobj P ((C,D#rev Cs'))"
  by - (rule isSubobj_isSubobj_isSubobj_rev)
with Cs' show ?thesis by simp
qed

subsection \<open>Subobject handling and lemmas\<close>

text\<open>Subobjects consisting of repeated inheritance relations only:\<close>

inductive Subobjs\<^sub>R :: "prog \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> bool" for P :: prog
where
  SubobjsR_Base: "is_class P C \<Longrightarrow> Subobjs\<^sub>R P C [C]"
| SubobjsR_Rep: "\<lbrakk>P \<turnstile> C \<prec>\<^sub>R D; Subobjs\<^sub>R P D Cs\<rbrakk> \<Longrightarrow> Subobjs\<^sub>R P C (C # Cs)"

text\<open>All subobjects:\<close>

inductive Subobjs :: "prog \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> bool" for P :: prog
where
  Subobjs_Rep: "Subobjs\<^sub>R P C Cs \<Longrightarrow> Subobjs P C Cs"
| Subobjs_Sh: "\<lbrakk>P \<turnstile> C \<preceq>\<^sup>* C'; P \<turnstile> C' \<prec>\<^sub>S D; Subobjs\<^sub>R P D Cs\<rbrakk>
             \<Longrightarrow> Subobjs P C Cs"

lemma Subobjs_Base:"is_class P C \<Longrightarrow> Subobjs P C [C]"
by (fastforce intro:Subobjs_Rep SubobjsR_Base)

lemma SubobjsR_nonempty: "Subobjs\<^sub>R P C Cs \<Longrightarrow> Cs \<noteq> []"
by (induct rule: Subobjs\<^sub>R.induct, simp_all)

lemma Subobjs_nonempty: "Subobjs P C Cs \<Longrightarrow> Cs \<noteq> []"
by (erule Subobjs.induct)(erule SubobjsR_nonempty)+

lemma hd_SubobjsR:
  "Subobjs\<^sub>R P C Cs \<Longrightarrow> \<exists>Cs'. Cs = C#Cs'"
by(erule Subobjs\<^sub>R.induct,simp+)

lemma SubobjsR_subclassRep:
  "Subobjs\<^sub>R P C Cs \<Longrightarrow> (C,last Cs) \<in> (subclsR P)\<^sup>*"

apply(erule Subobjs\<^sub>R.induct)
 apply simp
apply(simp add: SubobjsR_nonempty)
done

lemma SubobjsR_subclass: "Subobjs\<^sub>R P C Cs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* last Cs"

apply(erule Subobjs\<^sub>R.induct)
 apply simp
apply(simp add: SubobjsR_nonempty)
apply(blast intro:subclsR_subcls1 rtrancl_trans)
done

lemma Subobjs_subclass: "Subobjs P C Cs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* last Cs"

apply(erule Subobjs.induct)
 apply(erule SubobjsR_subclass)
apply(erule rtrancl_trans)
apply(blast intro:subclsS_subcls1 SubobjsR_subclass rtrancl_trans)
done

lemma Subobjs_notSubobjsR:
  "\<lbrakk>Subobjs P C Cs; \<not> Subobjs\<^sub>R P C Cs\<rbrakk>
\<Longrightarrow> \<exists>C' D. P \<turnstile> C \<preceq>\<^sup>* C' \<and> P \<turnstile> C' \<prec>\<^sub>S D \<and> Subobjs\<^sub>R P D Cs"
apply (induct rule: Subobjs.induct)
 apply clarsimp
apply fastforce
done

lemma Subobjs_Subobjs:"Subobjs P C (Cs@ C'#Cs') \<Longrightarrow> Subobjs P C' (C'#Cs')"

  apply -
  apply (drule Subobjs.cases)
  apply auto
   apply (subgoal_tac "C = hd(Cs @ C' # Cs')")
    apply (fastforce intro:SubobjsR_Subobjs)
   apply (fastforce dest:hd_SubobjsR)
  apply (subgoal_tac "D = hd(Cs @ C' # Cs')")
   apply (fastforce intro:SubobjsR_Subobjs)
  apply (fastforce dest:hd_SubobjsR)
  done

lemma SubobjsR_isClass:
assumes subo:"Subobjs\<^sub>R P C Cs"
shows "is_class P C"

using subo
proof (induct rule:Subobjs\<^sub>R.induct)
  case SubobjsR_Base thus ?case by assumption
next
  case SubobjsR_Rep thus ?case by (fastforce intro:subclsR_subcls1 subcls1_class)
qed

lemma Subobjs_isClass:
assumes subo:"Subobjs P C Cs"
shows "is_class P C"

using subo
proof (induct rule:Subobjs.induct)
  case Subobjs_Rep thus ?case by (rule SubobjsR_isClass)
next
  case (Subobjs_Sh C C' D Cs)
  have leq:"P \<turnstile> C \<preceq>\<^sup>* C'" and leqS:"P \<turnstile> C' \<prec>\<^sub>S D" by fact+
  hence "(C,D) \<in> (subcls1 P)\<^sup>+" by (fastforce intro:rtrancl_into_trancl1 subclsS_subcls1)
  thus ?case by (induct rule:trancl_induct, fastforce intro:subcls1_class)
qed

lemma Subobjs_subclsR:
assumes subo:"Subobjs P C (Cs@[D,D']@Cs')"
shows "P \<turnstile> D \<prec>\<^sub>R D'"

using subo
proof -
  from subo have "Subobjs P D (D#D'#Cs')" by -(rule Subobjs_Subobjs,simp)
  then obtain C' where subo':"Subobjs\<^sub>R P C' (D#D'#Cs')"
    by (induct rule:Subobjs.induct,blast+)
  hence "C' = D" by -(drule hd_SubobjsR,simp)
  with subo' have "Subobjs\<^sub>R P D (D#D'#Cs')" by simp
  thus ?thesis by (fastforce elim:Subobjs\<^sub>R.cases dest:hd_SubobjsR)
qed

lemma assumes subo:"Subobjs\<^sub>R P (hd Cs) (Cs@[D])" and notempty:"Cs \<noteq> []"
  shows butlast_Subobjs_Rep:"Subobjs\<^sub>R P (hd Cs) Cs"
using subo notempty
proof (induct Cs)
  case Nil thus ?case by simp
next
  case (Cons C' Cs')
  have subo:"Subobjs\<^sub>R P (hd(C'#Cs')) ((C'#Cs')@[D])"
    and IH:"\<lbrakk>Subobjs\<^sub>R P (hd Cs') (Cs'@[D]); Cs' \<noteq> []\<rbrakk> \<Longrightarrow> Subobjs\<^sub>R P (hd Cs') Cs'" by fact+
  from subo have subo':"Subobjs\<^sub>R P C' (C'#Cs'@[D])" by simp
  show ?case
  proof (cases "Cs' = []")
    case True
    with subo' have "Subobjs\<^sub>R P C' [C',D]" by simp
    hence "is_class P C'" by(rule SubobjsR_isClass)
    hence "Subobjs\<^sub>R P C' [C']" by (rule SubobjsR_Base)
    with True show ?thesis by simp
  next
    case False
    with subo' obtain D' where subo'':"Subobjs\<^sub>R P D' (Cs'@[D])"
      and subR:"P \<turnstile> C' \<prec>\<^sub>R D'"
      by (auto elim:Subobjs\<^sub>R.cases)
    from False subo'' have hd:"D' = hd Cs'"
      by (induct Cs',auto dest:hd_SubobjsR)
    with subo'' False IH have "Subobjs\<^sub>R P (hd Cs') Cs'" by simp
    with subR hd have "Subobjs\<^sub>R P C' (C'#Cs')" by (fastforce intro:SubobjsR_Rep)
    thus ?thesis by simp
  qed
qed

lemma assumes subo:"Subobjs P C (Cs@[D])" and notempty:"Cs \<noteq> []"
  shows butlast_Subobjs:"Subobjs P C Cs"

using subo
proof (rule Subobjs.cases,auto)
  assume suboR:"Subobjs\<^sub>R P C (Cs@[D])" and "Subobjs P C (Cs@[D])"
  from suboR notempty have hd:"C = hd Cs"
    by (induct Cs,auto dest:hd_SubobjsR)
  with suboR notempty have "Subobjs\<^sub>R P (hd Cs) Cs"
    by(fastforce intro:butlast_Subobjs_Rep)
  with hd show "Subobjs P C Cs" by (fastforce intro:Subobjs_Rep)
next
  fix C' D' assume leq:"P \<turnstile> C \<preceq>\<^sup>* C'" and subS:"P \<turnstile> C' \<prec>\<^sub>S D'"
  and suboR:"Subobjs\<^sub>R P D' (Cs@[D])" and "Subobjs P C (Cs@[D])"
  from suboR notempty have hd:"D' = hd Cs"
    by (induct Cs,auto dest:hd_SubobjsR)
  with suboR notempty have "Subobjs\<^sub>R P (hd Cs) Cs"
    by(fastforce intro:butlast_Subobjs_Rep)
  with hd leq subS show "Subobjs P C Cs"
    by(fastforce intro:Subobjs_Sh)
qed

lemma assumes subo:"Subobjs P C (Cs@(rev Cs'))" and notempty:"Cs \<noteq> []"
  shows rev_appendSubobj:"Subobjs P C Cs"
using subo
proof(induct Cs')
  case Nil thus ?case by simp
next
  case (Cons D Ds)
  have subo':"Subobjs P C (Cs@rev(D#Ds))"
    and IH:"Subobjs P C (Cs@rev Ds) \<Longrightarrow> Subobjs P C Cs" by fact+
  from notempty subo' have "Subobjs P C (Cs@rev Ds)"
    by (fastforce intro:butlast_Subobjs)
  with IH show ?case by simp
qed

lemma appendSubobj:
assumes subo:"Subobjs P C (Cs@Cs')" and notempty:"Cs \<noteq> []"
shows "Subobjs P C Cs"

proof -
  obtain Cs'' where Cs'':"Cs'' = rev Cs'" by simp
  with subo have "Subobjs P C (Cs@(rev Cs''))" by simp
  with notempty show ?thesis by - (rule rev_appendSubobj)
qed

lemma SubobjsR_isSubobj:
  "Subobjs\<^sub>R P C Cs \<Longrightarrow> is_subobj P ((C,Cs))"
by(erule Subobjs\<^sub>R.induct,simp,
  auto dest:hd_SubobjsR intro:build_rec_isSubobj)

lemma leq_SubobjsR_isSubobj:
  "\<lbrakk>P \<turnstile> C \<preceq>\<^sup>* C'; P \<turnstile> C' \<prec>\<^sub>S D; Subobjs\<^sub>R P D Cs\<rbrakk>
\<Longrightarrow> is_subobj P ((C,Cs))"

apply (subgoal_tac "is_subobj P ((C,[D]))")
 apply (frule hd_SubobjsR)
 apply (drule SubobjsR_isSubobj)
 apply (erule exE)
 apply (simp del: is_subobj.simps)
 apply (erule isSubobj_isSubobj_isSubobj)
 apply simp
apply auto
done

lemma Subobjs_isSubobj:
  "Subobjs P C Cs \<Longrightarrow> is_subobj P ((C,Cs))"
by (auto elim:Subobjs.induct SubobjsR_isSubobj
  simp add:leq_SubobjsR_isSubobj)

subsection \<open>Paths\<close>

subsection \<open>Appending paths\<close>

text\<open>Avoided name clash by calling one path Path.\<close>

definition path_via :: "prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> bool" ("_ \<turnstile> Path _ to _ via _ " [51,51,51,51] 50) where
  "P \<turnstile> Path C to D via Cs \<equiv> Subobjs P C Cs \<and> last Cs = D"

definition path_unique :: "prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool" ("_ \<turnstile> Path _ to _ unique" [51,51,51] 50) where
  "P \<turnstile> Path C to D unique \<equiv> \<exists>!Cs. Subobjs P C Cs \<and> last Cs = D"

definition appendPath :: "path \<Rightarrow> path \<Rightarrow> path" (infixr "@\<^sub>p" 65) where
  "Cs @\<^sub>p Cs' \<equiv> if (last Cs = hd Cs') then Cs @ (tl Cs') else Cs'"

lemma appendPath_last: "Cs \<noteq> [] \<Longrightarrow> last Cs = last (Cs'@\<^sub>pCs)"
by(auto simp:appendPath_def last_append)(cases Cs, simp_all)+

inductive
  casts_to :: "prog \<Rightarrow> ty \<Rightarrow> val \<Rightarrow> val \<Rightarrow> bool"
    ("_ \<turnstile> _ casts _ to _ " [51,51,51,51] 50)
  for P :: prog
where

  casts_prim: "\<forall>C. T \<noteq> Class C \<Longrightarrow> P \<turnstile> T casts v to v"

| casts_null: "P \<turnstile> Class C casts Null to Null"

| casts_ref: "\<lbrakk> P \<turnstile> Path last Cs to C via Cs'; Ds = Cs@\<^sub>pCs' \<rbrakk>
  \<Longrightarrow> P \<turnstile> Class C casts Ref(a,Cs) to Ref(a,Ds)"

inductive
  Casts_to :: "prog \<Rightarrow> ty list \<Rightarrow> val list \<Rightarrow> val list \<Rightarrow> bool"
    ("_ \<turnstile> _ Casts _ to _ " [51,51,51,51] 50)
  for P :: prog
where

  Casts_Nil: "P \<turnstile> [] Casts [] to []"

| Casts_Cons: "\<lbrakk> P \<turnstile> T casts v to v'; P \<turnstile> Ts Casts vs to vs' \<rbrakk>
  \<Longrightarrow> P \<turnstile> (T#Ts) Casts (v#vs) to (v'#vs')"

lemma length_Casts_vs:
  "P \<turnstile> Ts Casts vs to vs' \<Longrightarrow> length Ts = length vs"
by (induct rule:Casts_to.induct,simp_all)

lemma length_Casts_vs':
  "P \<turnstile> Ts Casts vs to vs' \<Longrightarrow> length Ts = length vs'"
by (induct rule:Casts_to.induct,simp_all)

subsection \<open>The relation on paths\<close>

inductive_set
  leq_path1 :: "prog \<Rightarrow> cname \<Rightarrow> (path \<times> path) set"
  and leq_path1' :: "prog \<Rightarrow> cname \<Rightarrow> [path, path] \<Rightarrow> bool" ("_,_ \<turnstile> _ \<sqsubset>\<^sup>1 _" [71,71,71] 70)
  for P :: prog and C :: cname
where
  "P,C \<turnstile> Cs \<sqsubset>\<^sup>1 Ds \<equiv> (Cs,Ds) \<in> leq_path1 P C"
| leq_pathRep: "\<lbrakk> Subobjs P C Cs; Subobjs P C Ds; Cs = butlast Ds\<rbrakk>
  \<Longrightarrow> P,C \<turnstile> Cs \<sqsubset>\<^sup>1 Ds"
| leq_pathSh:  "\<lbrakk> Subobjs P C Cs; P \<turnstile> last Cs \<prec>\<^sub>S D \<rbrakk>
  \<Longrightarrow> P,C \<turnstile> Cs \<sqsubset>\<^sup>1 [D]"

abbreviation
  leq_path :: "prog \<Rightarrow> cname \<Rightarrow> [path, path] \<Rightarrow> bool" ("_,_ \<turnstile> _ \<sqsubseteq> _"  [71,71,71] 70) where
  "P,C \<turnstile> Cs \<sqsubseteq> Ds \<equiv> (Cs,Ds) \<in> (leq_path1 P C)\<^sup>*"

lemma leq_path_rep:
  "\<lbrakk> Subobjs P C (Cs@[C']); Subobjs P C (Cs@[C',C''])\<rbrakk>
\<Longrightarrow> P,C \<turnstile> (Cs@[C']) \<sqsubset>\<^sup>1 (Cs@[C',C''])"
by(rule leq_pathRep,simp_all add:butlast_tail)

lemma leq_path_sh:
  "\<lbrakk> Subobjs P C (Cs@[C']); P \<turnstile> C' \<prec>\<^sub>S C''\<rbrakk>
\<Longrightarrow> P,C \<turnstile> (Cs@[C']) \<sqsubset>\<^sup>1 [C'']"
by(erule leq_pathSh)simp

subsection\<open>Member lookups\<close>

definition FieldDecls :: "prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> (path \<times> ty) set" where
  "FieldDecls P C F \<equiv>
   {(Cs,T). Subobjs P C Cs \<and> (\<exists>Bs fs ms. class P (last Cs) = Some(Bs,fs,ms)
                                    \<and> map_of fs F = Some T)}"

definition LeastFieldDecl  :: "prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has least _:_ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> C has least F:T via Cs \<equiv>
   (Cs,T) \<in> FieldDecls P C F \<and>
   (\<forall>(Cs',T') \<in> FieldDecls P C F. P,C \<turnstile> Cs \<sqsubseteq> Cs')"

definition MethodDefs :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> (path \<times> method)set" where
  "MethodDefs P C M \<equiv>
   {(Cs,mthd). Subobjs P C Cs \<and> (\<exists>Bs fs ms. class P (last Cs) = Some(Bs,fs,ms)
                                    \<and> map_of ms M = Some mthd)}"

  \<comment> \<open>needed for well formed criterion\<close>
definition HasMethodDef :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has _ = _ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> C has M = mthd via Cs \<equiv> (Cs,mthd) \<in> MethodDefs P C M"

definition LeastMethodDef :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has least _ = _ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> C has least M = mthd via Cs \<equiv>
   (Cs,mthd) \<in> MethodDefs P C M \<and>
   (\<forall>(Cs',mthd') \<in> MethodDefs P C M. P,C \<turnstile> Cs \<sqsubseteq> Cs')"

definition MinimalMethodDefs :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> (path \<times> method)set" where
  "MinimalMethodDefs P C M \<equiv>
      {(Cs,mthd). (Cs,mthd) \<in> MethodDefs P C M \<and>
         (\<forall>(Cs',mthd')\<in> MethodDefs P C M. P,C \<turnstile> Cs' \<sqsubseteq> Cs \<longrightarrow> Cs' = Cs)}"

definition OverriderMethodDefs :: "prog \<Rightarrow> subobj \<Rightarrow> mname \<Rightarrow> (path \<times> method)set" where
  "OverriderMethodDefs P R M \<equiv>
      {(Cs,mthd). \<exists>Cs' mthd'. P \<turnstile> (ldc R) has least M = mthd' via Cs' \<and>
                      (Cs,mthd) \<in> MinimalMethodDefs P (mdc R) M \<and>
                      P,mdc R \<turnstile> Cs \<sqsubseteq> (snd R)@\<^sub>pCs'}"

definition FinalOverriderMethodDef :: "prog \<Rightarrow> subobj \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has overrider _ = _ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> R has overrider M = mthd via Cs \<equiv>
      (Cs,mthd) \<in> OverriderMethodDefs P R M \<and>
      card(OverriderMethodDefs P R M) = 1"
      (*(\<forall>(Cs',mthd') \<in> OverriderMethodDefs P R M. Cs = Cs' \<and> mthd = mthd')"*)

inductive
  SelectMethodDef :: "prog \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
     ("_ \<turnstile> '(_,_') selects _ = _ via _" [51,0,0,0,0,51] 50)
  for P :: prog
where

  dyn_unique:
    "P \<turnstile> C has least M = mthd via Cs' \<Longrightarrow> P \<turnstile> (C,Cs) selects M = mthd via Cs'"

| dyn_ambiguous:
    "\<lbrakk>\<forall>mthd Cs'. \<not> P \<turnstile> C has least M = mthd via Cs';
      P \<turnstile> (C,Cs) has overrider M = mthd via Cs'\<rbrakk>
  \<Longrightarrow> P \<turnstile> (C,Cs) selects M = mthd via Cs'"

lemma sees_fields_fun:
  "(Cs,T) \<in> FieldDecls P C F \<Longrightarrow> (Cs,T') \<in> FieldDecls P C F \<Longrightarrow> T = T'"
by(fastforce simp:FieldDecls_def)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C has least F:T via Cs; P \<turnstile> C has least F:T' via Cs\<rbrakk>
  \<Longrightarrow> T = T'"
by (fastforce simp:LeastFieldDecl_def dest:sees_fields_fun)

lemma has_least_method_has_method:
  "P \<turnstile> C has least M = mthd via Cs \<Longrightarrow> P \<turnstile> C has M = mthd via Cs"
by (simp add:LeastMethodDef_def HasMethodDef_def)

lemma visible_methods_exist:
  "(Cs,mthd) \<in> MethodDefs P C M \<Longrightarrow>
  (\<exists>Bs fs ms. class P (last Cs) = Some(Bs,fs,ms) \<and> map_of ms M = Some mthd)"
by(auto simp:MethodDefs_def)

lemma sees_methods_fun:
  "(Cs,mthd) \<in> MethodDefs P C M \<Longrightarrow> (Cs,mthd') \<in> MethodDefs P C M \<Longrightarrow> mthd = mthd'"
by(fastforce simp:MethodDefs_def)

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C has least M = mthd via Cs; P \<turnstile> C has least M = mthd' via Cs\<rbrakk>
  \<Longrightarrow> mthd = mthd'"
by (fastforce simp:LeastMethodDef_def dest:sees_methods_fun)

lemma overrider_method_fun:
assumes overrider:"P \<turnstile> (C,Cs) has overrider M = mthd via Cs'"
  and overrider':"P \<turnstile> (C,Cs) has overrider M = mthd' via Cs''"
shows "mthd = mthd' \<and> Cs' = Cs''"
proof -
  from overrider' have omd:"(Cs'',mthd') \<in> OverriderMethodDefs P (C,Cs) M"
    by(simp_all add:FinalOverriderMethodDef_def)
  from overrider have "(Cs',mthd) \<in> OverriderMethodDefs P (C,Cs) M"
    and "card(OverriderMethodDefs P (C,Cs) M) = 1"
    by(simp_all add:FinalOverriderMethodDef_def)
  hence "\<forall>(Ds,mthd'') \<in> OverriderMethodDefs P (C,Cs) M. (Cs',mthd) = (Ds,mthd'')"
    by(fastforce simp:card_Suc_eq)
  with omd show ?thesis by fastforce
qed

end


(*
   Title:  Theory  CompLocalSecrets.thy
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2014
*)
header {*Local Secrets of a component *}

theory CompLocalSecrets
imports Secrecy
begin

-- "Set of local secrets: the set of secrets which does not belong to"
-- "the set of private keys and unguessable values, but are transmitted"
-- "via local channels or belongs to the local secrets of its subcomponents"
axiomatization
  LocalSecrets :: "specID  \<Rightarrow> KS set"
where
LocalSecretsDef:
 "LocalSecrets A =
  {(m :: KS). m \<notin> specKeysSecrets A  \<and>
              ((\<exists> x y. ((x \<in> loc A) \<and> m = (kKS y) \<and> (exprChannel x (kE y))))
              |(\<exists> x z. ((x \<in> loc A) \<and> m = (sKS z) \<and> (exprChannel x (sE z)) )) )}
   \<union>  (\<Union> (LocalSecrets ` (subcomponents A) ))"

lemma LocalSecretsComposition1:
assumes "ls \<in> LocalSecrets P"
       and "subcomponents PQ = {P, Q}"
shows    "ls \<in> LocalSecrets PQ"
using assms by (simp (no_asm) only: LocalSecretsDef, auto)

lemma  LocalSecretsComposition_exprChannel_k:
assumes "exprChannel x (kE Keys)"
       and "\<not> ine P (kE Keys)"
       and "\<not> ine Q (kE Keys)"
       and "\<not> (x \<notin> ins P \<and> x \<notin> ins Q)"
shows "False"
using assms by (metis ine_def)

lemma  LocalSecretsComposition_exprChannel_s:
assumes "exprChannel x (sE Secrets)"
       and "\<not> ine P (sE Secrets)"
       and "\<not> ine Q (sE Secrets)"
       and "\<not> (x \<notin> ins P \<and> x \<notin> ins Q)"
shows "False"
using assms by (metis ine_ins_neg1)

lemma LocalSecretsComposition_neg1_k:
assumes "subcomponents PQ = {P, Q}"
       and "correctCompositionLoc PQ"
       and "\<not> ine P (kE Keys)"
       and "\<not> ine Q (kE Keys)"
       and "kKS Keys \<notin> LocalSecrets P"
       and "kKS Keys \<notin> LocalSecrets Q"
shows    "kKS Keys \<notin> LocalSecrets PQ"
proof -
  from assms show ?thesis
    apply (simp (no_asm) only: LocalSecretsDef,
           simp add: correctCompositionLoc_def, clarify)
    by (rule LocalSecretsComposition_exprChannel_k, auto)
qed

lemma LocalSecretsComposition_neg_k:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionLoc PQ"
       and "correctCompositionKS PQ"
       and "(kKS m) \<notin> specKeysSecrets P"
       and "(kKS m) \<notin> specKeysSecrets Q"
       and "\<not> ine P (kE m)"
       and "\<not> ine Q (kE m)"
       and "(kKS m) \<notin> ((LocalSecrets P) \<union> (LocalSecrets Q))"
shows    "(kKS m) \<notin> (LocalSecrets PQ)"
proof -
  from assms show ?thesis
    apply (simp (no_asm) only: LocalSecretsDef,
           simp add: correctCompositionLoc_def, clarify)
    by (rule LocalSecretsComposition_exprChannel_k, auto)
qed

lemma LocalSecretsComposition_neg_s:
assumes subPQ:"subcomponents PQ = {P,Q}"
       and cCompLoc:"correctCompositionLoc PQ"
       and cCompKS:"correctCompositionKS PQ"
       and notKSP:"(sKS m) \<notin> specKeysSecrets P"
       and notKSQ:"(sKS m) \<notin> specKeysSecrets Q"
       and "\<not> ine P (sE m)"
       and "\<not> ine Q (sE m)"
       and notLocSeqPQ:"(sKS m) \<notin> ((LocalSecrets P) \<union> (LocalSecrets Q))"
shows   "(sKS m) \<notin> (LocalSecrets PQ)"
proof -
  from subPQ and cCompKS and notKSP and notKSQ
  have sg1:"sKS m \<notin> specKeysSecrets PQ"
    by (simp add: correctCompositionKS_neg1)
  from subPQ and cCompLoc and notLocSeqPQ have sg2:
   "sKS m \<notin>  \<Union> (LocalSecrets ` subcomponents PQ)"
    by simp
  from sg1 and sg2 and assms show ?thesis
    apply (simp (no_asm) only: LocalSecretsDef,
           simp add: correctCompositionLoc_def, clarify)
    by (rule LocalSecretsComposition_exprChannel_s, auto)
qed

lemma LocalSecretsComposition_neg:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionLoc PQ"
       and "correctCompositionKS PQ"
       and "ks \<notin> specKeysSecrets P"
       and "ks \<notin> specKeysSecrets Q"
       and h1:"\<forall> m. ks = kKS m \<longrightarrow> (\<not> ine P (kE m) \<and> \<not> ine Q (kE m))"
       and h2:"\<forall> m. ks = sKS m \<longrightarrow> (\<not> ine P (sE m) \<and> \<not> ine Q (sE m))"
       and "ks \<notin> ((LocalSecrets P) \<union> (LocalSecrets Q))"
shows   "ks \<notin> (LocalSecrets PQ)"
proof (cases "ks")
  fix m
  assume a1:"ks = kKS m"
  from this and h1 have "\<not> ine P (kE m) \<and> \<not> ine Q (kE m)" by simp
  from this and a1 and assms show ?thesis
    by (simp add: LocalSecretsComposition_neg_k)
next
  fix m
  assume a2:"ks = sKS m"
  from this and h2 have "\<not> ine P (sE m) \<and> \<not> ine Q (sE m)" by simp
  from this and a2 and assms show ?thesis
    by (simp add: LocalSecretsComposition_neg_s)
qed

lemma LocalSecretsComposition_neg1_s:
assumes "subcomponents PQ = {P, Q}"
       and "correctCompositionLoc PQ"
       and "\<not> ine P (sE s)"
       and "\<not> ine Q (sE s)"
       and "sKS s \<notin> LocalSecrets P"
       and "sKS s \<notin> LocalSecrets Q"
shows    "sKS s \<notin> LocalSecrets PQ"
proof -
  from assms have
   "sKS s \<notin>  \<Union> (LocalSecrets ` subcomponents PQ)"
    by simp
    from  assms and this show ?thesis
    apply (simp (no_asm) only: LocalSecretsDef,
              simp add: correctCompositionLoc_def, clarify)
    by (rule LocalSecretsComposition_exprChannel_s, auto)
qed

lemma LocalSecretsComposition_ine1_k:
assumes "kKS k \<in> LocalSecrets PQ"
       and "subcomponents PQ = {P, Q}"
       and "correctCompositionLoc PQ"
       and "\<not> ine Q (kE k)"
       and "kKS k \<notin> LocalSecrets P"
       and "kKS k \<notin> LocalSecrets Q"
shows    "ine P (kE k)"
using assms by (metis LocalSecretsComposition_neg1_k)

lemma LocalSecretsComposition_ine1_s:
assumes "sKS s \<in> LocalSecrets PQ"
       and "subcomponents PQ = {P, Q}"
       and "correctCompositionLoc PQ"
       and "\<not> ine Q (sE s)"
       and "sKS s \<notin> LocalSecrets P"
       and "sKS s \<notin> LocalSecrets Q"
shows    "ine P (sE s)"
using assms by (metis LocalSecretsComposition_neg1_s)

lemma LocalSecretsComposition_ine2_k:
assumes "kKS k \<in> LocalSecrets PQ"
       and "subcomponents PQ = {P, Q}"
       and "correctCompositionLoc PQ"
       and "\<not> ine P (kE k)"
       and "kKS k \<notin> LocalSecrets P"
       and "kKS k \<notin> LocalSecrets Q"
shows   "ine Q (kE k)"
using assms  by (metis LocalSecretsComposition_ine1_k)

lemma LocalSecretsComposition_ine2_s:
assumes "sKS s \<in> LocalSecrets PQ"
       and "subcomponents PQ = {P, Q}"
       and "correctCompositionLoc PQ"
       and "\<not> ine P (sE s)"
       and "sKS s \<notin> LocalSecrets P"
       and "sKS s \<notin> LocalSecrets Q"
shows    "ine Q (sE s)"
using assms by (metis LocalSecretsComposition_ine1_s)

lemma LocalSecretsComposition_neg_loc_k:
assumes "kKS key \<notin> LocalSecrets P"
       and "exprChannel ch (kE key)"
       and "kKS key \<notin> specKeysSecrets P"
shows    "ch \<notin> loc P"
using assms by (simp only: LocalSecretsDef, auto)

lemma LocalSecretsComposition_neg_loc_s:
assumes "sKS secret \<notin> LocalSecrets P"
       and "exprChannel ch (sE secret)"
       and "sKS secret \<notin> specKeysSecrets P"
shows    "ch \<notin> loc P"
using assms by (simp only: LocalSecretsDef, auto)

lemma correctCompositionKS_exprChannel_k_P:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "kKS key \<notin> LocalSecrets PQ"
       and "ch \<in> ins P"
       and "exprChannel ch (kE key)"
       and "kKS key \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "ch \<in> ins PQ \<and> exprChannel ch (kE key)"
using assms
by (metis LocalSecretsComposition_neg_loc_k correctCompositionIn_L1)

lemma correctCompositionKS_exprChannel_k_Pex:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "kKS key \<notin> LocalSecrets PQ"
       and "ch \<in> ins P"
       and "exprChannel ch (kE key)"
       and "kKS key \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "\<exists>ch. ch \<in> ins PQ \<and> exprChannel ch (kE key)"
using assms
by (metis correctCompositionKS_exprChannel_k_P)

lemma correctCompositionKS_exprChannel_k_Q:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "kKS key \<notin> LocalSecrets PQ"
       and "ch \<in> ins Q"
       and h1:"exprChannel ch (kE key)"
       and "kKS key \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "ch \<in> ins PQ \<and> exprChannel ch (kE key)"
proof -
  from assms have "ch \<notin> loc PQ"
    by (simp add: LocalSecretsComposition_neg_loc_k)
  from this and assms have "ch \<in> ins PQ"
    by (simp add: correctCompositionIn_def)
  from this and h1 show ?thesis by simp
qed

lemma correctCompositionKS_exprChannel_k_Qex:
assumes "subcomponents PQ = {P,Q}"
        and "correctCompositionKS PQ"
        and "kKS key \<notin> LocalSecrets PQ"
        and "ch \<in> ins Q"
        and "exprChannel ch (kE key)"
        and "kKS key \<notin> specKeysSecrets PQ"
        and "correctCompositionIn PQ"
shows    "\<exists>ch. ch \<in> ins PQ \<and> exprChannel ch (kE key)"
using assms
by (metis correctCompositionKS_exprChannel_k_Q)

lemma correctCompositionKS_exprChannel_s_P:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "sKS secret \<notin> LocalSecrets PQ"
       and "ch \<in> ins P"
       and "exprChannel ch (sE secret)"
       and "sKS secret \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "ch \<in> ins PQ \<and> exprChannel ch (sE secret)"
using assms
by (metis LocalSecretsComposition_neg_loc_s correctCompositionIn_L1)

lemma correctCompositionKS_exprChannel_s_Pex:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "sKS secret \<notin> LocalSecrets PQ"
       and "ch \<in> ins P"
       and "exprChannel ch (sE secret)"
       and "sKS secret \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "\<exists>ch. ch \<in> ins PQ \<and> exprChannel ch (sE secret)"
using assms
by (metis correctCompositionKS_exprChannel_s_P)

lemma correctCompositionKS_exprChannel_s_Q:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "sKS secret \<notin> LocalSecrets PQ"
       and "ch \<in> ins Q"
       and h1:"exprChannel ch (sE secret)"
       and "sKS secret \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "ch \<in> ins PQ \<and> exprChannel ch (sE secret)"
proof -
  from assms have "ch \<notin> loc PQ"
    by (simp add: LocalSecretsComposition_neg_loc_s)
  from this and assms have "ch \<in> ins PQ"
    by (simp add: correctCompositionIn_def)
  from this and h1 show ?thesis by simp
qed

lemma correctCompositionKS_exprChannel_s_Qex:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionKS PQ"
       and "sKS secret \<notin> LocalSecrets PQ"
       and "ch \<in> ins Q"
       and "exprChannel ch (sE secret)"
       and "sKS secret \<notin> specKeysSecrets PQ"
       and "correctCompositionIn PQ"
shows    "\<exists>ch. ch \<in> ins PQ \<and> exprChannel ch (sE secret)"
using assms
by (metis correctCompositionKS_exprChannel_s_Q)

end


theory BaseLogicDeep
imports CoreStructures LogicSyntaxDeep "../HeapLang/State" LogicTypesDeep
begin

section \<open> Base Logic \<close>

(* Irrelevant contexts that were left out in the description are called I instead of \<Gamma>.  *)
inductive judgement :: "(string\<times>logic_type) list \<Rightarrow> 'a::ucamera logic_term \<Rightarrow> 'a logic_term \<Rightarrow> bool"
  ("_ | _ \<turnstile> _" 60)  where
  Asm: "I|P\<turnstile>P"
| Cut: "\<lbrakk>I|P\<turnstile>Q; I|Q\<turnstile>R\<rbrakk> \<Longrightarrow> I|P\<turnstile>Q"
| Eq: "\<lbrakk>(x,\<tau>)#\<Gamma>\<turnstile>Q:PropT; \<Gamma>|P\<turnstile>term_subst t x Q; \<Gamma>|P\<turnstile>EqTrm \<tau> t t'\<rbrakk> \<Longrightarrow> \<Gamma>|P\<turnstile>term_subst t' x Q"
| Refl: "I|TrueTrm\<turnstile>EqTrm \<tau> t t"
| BotE: "I|FalseTrm\<turnstile>P"
| TopI: "I|P\<turnstile>TrueTrm"
| ConjI: "\<lbrakk>I|P\<turnstile>Q; I|P\<turnstile>R\<rbrakk> \<Longrightarrow> I|P\<turnstile>Conj Q R"
| ConjEL: "I|P\<turnstile>Conj Q R \<Longrightarrow> I|P\<turnstile>Q"
| ConjER: "I|P\<turnstile>Conj Q R \<Longrightarrow> I|P\<turnstile>R"
| DisjIL: "I|P\<turnstile>Q \<Longrightarrow> I|P\<turnstile>Disj Q R"
| DisjIR: "I|P\<turnstile>R \<Longrightarrow> I|P\<turnstile>Disj Q R"
| DisjE: "\<lbrakk>I|P\<turnstile>R; I|Q\<turnstile>R\<rbrakk> \<Longrightarrow> I|Disj P Q\<turnstile>R"
| ImplI: "I|Conj P Q\<turnstile>R \<Longrightarrow> I|P\<turnstile>Impl Q R"
| ImplE: "\<lbrakk>I|P\<turnstile>Impl Q R; I|P\<turnstile>Q\<rbrakk> \<Longrightarrow> I|P\<turnstile>R"
| ForallI: "(x,\<tau>)#\<Gamma>|P\<turnstile>Q \<Longrightarrow> \<Gamma>|P\<turnstile>Forall x \<tau> Q"
| ForallE: "\<lbrakk>\<Gamma>|P\<turnstile>Forall x \<tau> Q; \<Gamma>\<turnstile>t:\<tau>\<rbrakk> \<Longrightarrow> \<Gamma>|P\<turnstile>term_subst t x Q"
| ExistsI: "\<lbrakk>\<Gamma>|P\<turnstile>term_subst t x Q; \<Gamma>\<turnstile>t:\<tau>\<rbrakk> \<Longrightarrow> \<Gamma>|P\<turnstile>Exists x \<tau> Q"
| ExistsE: "(x,\<tau>)#\<Gamma>|P\<turnstile>Q \<Longrightarrow> \<Gamma>|Exists x \<tau> P\<turnstile>Q"
| EtaRed: "I|P\<turnstile>Q \<Longrightarrow> I|P\<turnstile>Abs x \<tau> (AppL Q (VarL x))"

datatype 'a semantic_type = PropS "'a \<Rightarrow> nat \<Rightarrow> bool" | CmraS 'a | UnitS unit
  | ProdS "'a semantic_type\<times>'a semantic_type"
  | FunS "('a semantic_type\<times>'a semantic_type) fset" \<comment> \<open>BNFs can't have recursion in function arguments\<close>
  | ExprS expr | StateS state | ObservationS observation | ListS "'a semantic_type list"

definition funS :: "('a semantic_type\<Rightarrow>'a semantic_type) \<Rightarrow> 'a semantic_type" where
  "funS f = FunS (Abs_fset {(x,y) | x y. f x = y})"

definition appS :: "'a semantic_type \<Rightarrow> 'a semantic_type \<Rightarrow> 'a semantic_type" where
  "appS fS x \<equiv> case fS of FunS f \<Rightarrow> the_elem ((fset f) `` {x}) | _ \<Rightarrow> undefined"
notation appS (infixl "$$" 60)

abbreviation "unwrap_expr eS \<equiv> case eS of ExprS e \<Rightarrow> e | _ \<Rightarrow> undefined"
abbreviation "unwrap_state sS \<equiv> case sS of StateS s \<Rightarrow> s | _ \<Rightarrow> undefined"
abbreviation "unwrap_obs oS \<equiv> case oS of ObservationS ob \<Rightarrow> ob | _ \<Rightarrow> undefined"
abbreviation "unwrap_list m lS \<equiv> case lS of ListS l \<Rightarrow> map m l | _ \<Rightarrow> undefined"
abbreviation "unwrap_prop pS x n \<equiv> case pS of PropS p \<Rightarrow> p x n | _ \<Rightarrow> undefined"

definition head_step_sem :: "'a::ucamera semantic_type" where
  "head_step_sem \<equiv> funS (\<lambda>e1S. funS (\<lambda>s1S. funS (\<lambda>kl. funS (\<lambda>e2S. funS (\<lambda>s2S. funS (\<lambda>efsl.
      PropS (\<lambda>_ _.
      ((unwrap_expr e1S) (unwrap_state s1S) (unwrap_list unwrap_obs kl) \<Rightarrow>\<^sub>h
      (unwrap_expr e2S) (unwrap_state s2S) (unwrap_list unwrap_expr efsl))
  )))))))"

definition "wp_sem \<equiv> funS
  (\<lambda>e. PropS (\<lambda>x n. \<forall>s1 k e2 s2 efs. unwrap_prop (head_step_sem$$e$$s1$$k$$e2$$s2$$efs) x n))"

abbreviation "comb_prop p q pcomb \<equiv> (case p of Some (PropS p') \<Rightarrow> (case q of Some (PropS q') \<Rightarrow>
  Some (PropS (\<lambda>a n. pcomb p' q' a n)) | _ \<Rightarrow> None) | _ \<Rightarrow> None)"

fun logic_semantic
  :: "'a::ucamera logic_term \<Rightarrow> (string\<rightharpoonup>'a semantic_type) \<Rightarrow> 'a semantic_type option" where
  "logic_semantic Unit _ = Some (UnitS ())"
| "logic_semantic (VarL v) \<Gamma> = \<Gamma> v"
| "logic_semantic (Prod f s) \<Gamma> = comb_option (logic_semantic f \<Gamma>) (logic_semantic s \<Gamma>)
  (\<lambda>fS sS. ProdS (fS,sS))"
| "logic_semantic (FstL p) \<Gamma> = (case logic_semantic p \<Gamma> of Some (ProdS pS) \<Rightarrow> Some (fst pS)
  | _ \<Rightarrow> None)"
| "logic_semantic (SndL p) \<Gamma> = (case logic_semantic p \<Gamma> of Some (ProdS pS) \<Rightarrow> Some (snd pS)
  | _ \<Rightarrow> None)"
| "logic_semantic (Abs v _ b) \<Gamma> = Some (funS (\<lambda>vS. the (logic_semantic b (\<Gamma>(v\<mapsto>vS)))))"
| "logic_semantic (AppL f x) \<Gamma> = comb_option (logic_semantic f \<Gamma>) (logic_semantic x \<Gamma>) appS"
| "logic_semantic (Const x) _ = Some (CmraS x)"
| "logic_semantic (Core x) \<Gamma> = (case logic_semantic x \<Gamma> of Some (CmraS x') \<Rightarrow> Some (CmraS (core x'))
  | _ \<Rightarrow> None)"
| "logic_semantic (Comp x y) \<Gamma> = (case logic_semantic x \<Gamma> of Some (CmraS x') \<Rightarrow>
  (case logic_semantic y \<Gamma> of Some (CmraS y') \<Rightarrow> Some (CmraS (x'\<cdot>y')) | _ \<Rightarrow> None) | _ \<Rightarrow> None)"
| "logic_semantic FalseTrm _ = Some (PropS (\<lambda>_ _. False))"
| "logic_semantic TrueTrm _ = Some (PropS (\<lambda>_ _. True))"
| "logic_semantic (EqTrm _ x y) \<Gamma> = comb_option (logic_semantic x \<Gamma>) (logic_semantic y \<Gamma>)
  (\<lambda>x y. PropS (\<lambda> _ _. x=y))"
| "logic_semantic (Impl p q) \<Gamma> = comb_prop (logic_semantic p \<Gamma>) (logic_semantic q \<Gamma>)
  (\<lambda>p q a n. p a n \<longrightarrow> q a n)"
| "logic_semantic (Conj p q) \<Gamma> = comb_prop (logic_semantic p \<Gamma>) (logic_semantic q \<Gamma>)
  (\<lambda>p q a n. p a n \<and> q a n)"
| "logic_semantic (Disj p q) \<Gamma> = comb_prop (logic_semantic p \<Gamma>) (logic_semantic q \<Gamma>)
  (\<lambda>p q a n. p a n \<or> q a n)"
| "logic_semantic (Sep p q) \<Gamma> = comb_prop (logic_semantic p \<Gamma>) (logic_semantic q \<Gamma>)
  (\<lambda>p q a n. \<exists>b1 b2. n_equiv n a (b1\<cdot>b2) \<and> p b1 n \<and> q b2 n)"
| "logic_semantic (Wand p q) \<Gamma> = comb_prop (logic_semantic p \<Gamma>) (logic_semantic q \<Gamma>)
  (\<lambda>p q a n. \<forall>b m. m\<le>n \<longrightarrow> n_valid (a \<cdot> b) m \<longrightarrow> p b m \<longrightarrow> q (a \<cdot> b) m)"
| "logic_semantic (Guarded v _ b) \<Gamma> = (if guarded v b then
  Some (funS (\<lambda>vS. the (logic_semantic b (\<Gamma>(v\<mapsto>vS))))) else None)"
| "logic_semantic (Exists v _ b) \<Gamma> =
  Some (PropS (\<lambda>a n. \<exists>vS. unwrap_prop (the (logic_semantic b (\<Gamma>(v\<mapsto>vS)))) a n))"
| "logic_semantic (Forall v _ b) \<Gamma> =
  Some (PropS (\<lambda>a n. \<forall>vS. unwrap_prop (the (logic_semantic b (\<Gamma>(v\<mapsto>vS)))) a n))"
| "logic_semantic (Own x) \<Gamma> = (case logic_semantic x \<Gamma> of Some (CmraS x') \<Rightarrow>
  Some (PropS (\<lambda>a n. n_incl n x' a)) | _ \<Rightarrow> None)"
| "logic_semantic (Valid x) \<Gamma> = (case logic_semantic x \<Gamma> of Some (CmraS x') \<Rightarrow>
  Some (PropS (\<lambda>_. n_valid x')) | _ \<Rightarrow> None)"
| "logic_semantic (Persistent p) \<Gamma> = (case logic_semantic p \<Gamma> of Some (PropS p') \<Rightarrow>
  Some (PropS (\<lambda>a n. p' (core a) n)) | _ \<Rightarrow> None)"
| "logic_semantic (Plain p) \<Gamma> = (case logic_semantic p \<Gamma> of Some (PropS p') \<Rightarrow>
  Some (PropS (\<lambda>_ n. p' \<epsilon> n)) | _ \<Rightarrow> None)"
| "logic_semantic (Later p) \<Gamma> = (case logic_semantic p \<Gamma> of Some (PropS p') \<Rightarrow>
  Some (PropS (\<lambda>a n. n=0 \<or> p' a (n-1))))"
| "logic_semantic (Upd p) \<Gamma> = (case logic_semantic p \<Gamma> of Some (PropS p') \<Rightarrow>
  Some (PropS (\<lambda>a n. \<forall>m b. m\<le>n \<longrightarrow> n_valid (a \<cdot> b) m \<longrightarrow> (\<exists>c. n_valid (c \<cdot> b) m \<and> p' c m))))"

lemma "\<lbrakk>dom \<Gamma>S \<subseteq> dom \<Gamma>T; type_of_term t \<Gamma>T = None\<rbrakk> \<Longrightarrow> logic_semantic t \<Gamma>S = None"
apply (induction t)
apply (auto split: option.splits)
sorry

definition entails :: "'a::ucamera semantic_type \<Rightarrow> 'a semantic_type \<Rightarrow> bool" where
  "entails P Q \<equiv> let P' = unwrap_prop P in let Q' = unwrap_prop Q in
    (\<forall>a n. n_valid a n \<longrightarrow> P' a n \<longrightarrow> Q' a n)"

lemma "\<lbrakk>\<Gamma>T|P\<turnstile>Q; logic_semantic P \<Gamma>S = Some P'; logic_semantic Q \<Gamma>S = Some Q'\<rbrakk> \<Longrightarrow> entails P' Q'"
sorry

lemma "logic_semantic wp [''head_step''\<mapsto>head_step_sem] = Some wp_sem"
apply (auto simp add: wp_def head_step_sem_def funS_def appS_def the_elem_def Abs_fset_inverse)
sorry

text \<open>
  Deep Embedding of uniform predicates:

  - all Iris logic formulae as instances of datatype \<^typ>\<open>'a logic_term\<close>
  - terms with camera objects (\<^typ>\<open>'a::ucamera\<close>/\<^const>\<open>CmraT\<close>) very simple:
    \<^const>\<open>Const\<close>, \<^const>\<open>Core\<close>, \<^const>\<open>Comp\<close>
  - uniform predicates about camera objects (\<^typ>\<open>'a::ucamera\<Rightarrow>nat\<Rightarrow>bool\<close>/\<^const>\<open>PropT\<close>) very simple:
    \<^const>\<open>Own\<close>, \<^const>\<open>Valid\<close>, \<^const>\<open>Conj\<close>, \<^const>\<open>Disj\<close>, \<^const>\<open>TrueTrm\<close>, \<^const>\<open>FalseTrm\<close>,
    \<^const>\<open>EqTrm\<close>, \<^const>\<open>Impl\<close>, \<^const>\<open>Sep\<close>, \<^const>\<open>Wand\<close>, \<^const>\<open>Persistent\<close>, \<^const>\<open>Plain\<close>,
    \<^const>\<open>Later\<close>, \<^const>\<open>Upd\<close>, (maybe also have a wrapper for "pure" propositions, e.g. \<open>\<lambda>a n. True\<close>)
  - BUT: Iris base logic also reasons about terms of other types as well:
    \<^typ>\<open>unit\<close>/\<^const>\<open>UnitT\<close>, \<^typ>\<open>'a\<times>'b\<close>/\<^const>\<open>ProdT\<close>, \<^typ>\<open>'a\<Rightarrow>'b\<close>/\<^const>\<open>FunT\<close> (i.e. \<^typ>\<open>'a-n>'b\<close>),
    \<^typ>\<open>'a+'b\<close> (omitted), and all other types an application needs (e.g. \<^typ>\<open>expr\<close>/\<^const>\<open>Expr\<close>,
    \<^typ>\<open>state\<close>/\<^const>\<open>State\<close>, \<^typ>\<open>observation\<close>/\<^const>\<open>Observation\<close> and lists of these types)
  - Do we need to be to argue about other types than cameras within the base logic?
    => if we would only be able to reason about cameras, we would lose the ability to have
    sideconditions about them (e.g. if we can do a head step in HeapLang, we can also do a ghost update
    to then own the new state)
    => quantifiers make things really difficult either way if the variable, over which we abstract
    is used within a "pure" context
    => The biggest problem is the semantics of functions and application, no deep embedding can have
    well-typed function semantics (i.e. a datatype which wraps functions on itself)
  - Make quantifiers only inside a Pure wrapper doesn't work as it cuts the connection of outer camera
    objects necessary for the semantics from the inner ones.
\<close>
end


theory Hash_User
imports Hash_Specification Hash_Declaration

begin

lemma goal12'1:
  assumes H1: " x__index__subtype__1__first'' = (0 :: int)
  "
  assumes H6:
  " chain___default_rcd''
    (| h0'chain
       := ca__1''
    |)
    (| h1'chain
       := cb__1''
    |)
    (| h2'chain
       := cc__1''
    |)
    (| h3'chain
       := cd__1''
    |)
    (| h4'chain
       := ce__1''
    |)
    = round'
        ( chain___default_rcd''
          (| h0'chain
             := (1732584193 :: int)
          |)
          (| h1'chain
             := (4023233417 :: int)
          |)
          (| h2'chain
             := (2562383102 :: int)
          |)
          (| h3'chain
             := (271733878 :: int)
          |)
          (| h4'chain
             := (3285377520 :: int)
          |)
        )
        ( x'' x__index__subtype__1__first''
        )
  "
  shows " chain___default_rcd''
          (| h0'chain
             := ca__1''
          |)
          (| h1'chain
             := cb__1''
          |)
          (| h2'chain
             := cc__1''
          |)
          (| h3'chain
             := cd__1''
          |)
          (| h4'chain
             := ce__1''
          |)
          = rounds'
              ( chain___default_rcd''
                (| h0'chain
                   := (1732584193 :: int)
                |)
                (| h1'chain
                   := (4023233417 :: int)
                |)
                (| h2'chain
                   := (2562383102 :: int)
                |)
                (| h3'chain
                   := (271733878 :: int)
                |)
                (| h4'chain
                   := (3285377520 :: int)
                |)
              )
              ( x__index__subtype__1__first'' + (1 :: int) )
              x''
        " (is "?C1")
using H1 H6
by (simp add:
  rounds_def rmd_body_def round_def
  h_0_def h0_0_def h1_0_def h2_0_def h3_0_def h4_0_def)

lemma rounds_step:
  assumes "0 <= i"
  shows "rounds X b (Suc i) = round (X i) (rounds X b i)"
  by (simp add: rounds_def rmd_body_def)

lemma from_to_id: "from_chain (to_chain C) = C"
proof (cases C)
  fix a b c d e f::word32
  assume "C = (a, b, c, d, e)"
  thus ?thesis by (cases a) simp
qed

lemma steps_to_steps':
  "round X (foldl a b c) = round X (from_chain (to_chain (foldl a b c)))"
  unfolding from_to_id ..

lemma rounds'_step:
  assumes "0 <= i"
  shows "rounds' c (i + 1) x = round' (rounds' c i x) (x i)"
proof -
  have makesuc: "nat (i + 1) = Suc (nat i)" using assms by simp
  show ?thesis using assms
    by (simp add: makesuc rounds_def rmd_body_def steps_to_steps')
qed

lemma goal13'1:
  assumes "0 <= loop__1__i''"
  assumes H1:
  " chain___default_rcd''
    (| h0'chain
       := ca''
    |)
    (| h1'chain
       := cb''
    |)
    (| h2'chain
       := cc''
    |)
    (| h3'chain
       := cd''
    |)
    (| h4'chain
       := ce''
    |)
    = rounds'
        ( chain___default_rcd''
          (| h0'chain
             := (1732584193 :: int)
          |)
          (| h1'chain
             := (4023233417 :: int)
          |)
          (| h2'chain
             := (2562383102 :: int)
          |)
          (| h3'chain
             := (271733878 :: int)
          |)
          (| h4'chain
             := (3285377520 :: int)
          |)
        )
        ( loop__1__i'' + (1 :: int) )
        x''
  "
  assumes H18:
  " chain___default_rcd''
    (| h0'chain
       := ca__1''
    |)
    (| h1'chain
       := cb__1''
    |)
    (| h2'chain
       := cc__1''
    |)
    (| h3'chain
       := cd__1''
    |)
    (| h4'chain
       := ce__1''
    |)
    = round'
        ( chain___default_rcd''
          (| h0'chain
             := ca''
          |)
          (| h1'chain
             := cb''
          |)
          (| h2'chain
             := cc''
          |)
          (| h3'chain
             := cd''
          |)
          (| h4'chain
             := ce''
          |)
        )
        ( x'' ( loop__1__i'' + (1 :: int) )
        )
  "
  shows " chain___default_rcd''
          (| h0'chain
             := ca__1''
          |)
          (| h1'chain
             := cb__1''
          |)
          (| h2'chain
             := cc__1''
          |)
          (| h3'chain
             := cd__1''
          |)
          (| h4'chain
             := ce__1''
          |)
          = rounds'
              ( chain___default_rcd''
                (| h0'chain
                   := (1732584193 :: int)
                |)
                (| h1'chain
                   := (4023233417 :: int)
                |)
                (| h2'chain
                   := (2562383102 :: int)
                |)
                (| h3'chain
                   := (271733878 :: int)
                |)
                (| h4'chain
                   := (3285377520 :: int)
                |)
              )
              ( loop__1__i'' + (2 :: int) )
              x''
        "
proof -
  have loop_suc: "loop__1__i'' + 2 = (loop__1__i'' + 1) + 1" by simp
  have "0 <= loop__1__i'' + 1" using `0 <= loop__1__i''` by simp
  show ?thesis
    unfolding loop_suc
    unfolding rounds'_step[OF `0 <= loop__1__i'' + 1`]
    unfolding H1[symmetric]
    unfolding H18 ..
qed

lemma goal17'1:
  assumes H1:
  " chain___default_rcd''
    (| h0'chain
       := ca''
    |)
    (| h1'chain
       := cb''
    |)
    (| h2'chain
       := cc''
    |)
    (| h3'chain
       := cd''
    |)
    (| h4'chain
       := ce''
    |)
    = rounds'
        ( chain___default_rcd''
          (| h0'chain
             := (1732584193 :: int)
          |)
          (| h1'chain
             := (4023233417 :: int)
          |)
          (| h2'chain
             := (2562383102 :: int)
          |)
          (| h3'chain
             := (271733878 :: int)
          |)
          (| h4'chain
             := (3285377520 :: int)
          |)
        )
        ( x__index__subtype__1__last'' + (1 :: int) )
        x''
  "
  shows " chain___default_rcd''
          (| h0'chain
             := ca''
          |)
          (| h1'chain
             := cb''
          |)
          (| h2'chain
             := cc''
          |)
          (| h3'chain
             := cd''
          |)
          (| h4'chain
             := ce''
          |)
          = rmd_hash'
              x''
              ( x__index__subtype__1__last'' + (1 :: int) )
        "
unfolding rmd_def H1 rounds_def ..

lemmas userlemmas = goal12'1 goal13'1 goal17'1
end


theory Submission
  imports Defs
begin

abbreviation (input) change_rule :: "vname \<Rightarrow> bexp \<Rightarrow> assn \<Rightarrow> assn" where
"change_rule x b P \<equiv> \<lambda>s. \<exists>x'. (bval b (s[x'/x]) \<and> P (s[x'/x]))"

inductive
  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
where
Skip: "\<turnstile> {P} SKIP {P}"  |

Assign:  "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk>
      \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"  |

If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
     \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P} \<Longrightarrow>
        \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"  |

Swap: "\<turnstile> {\<lambda>s. P (s(x:=s y,y:=s x))} SWAP x y {P}" |

Change: "\<turnstile> {change_rule x b P} CHANGE x ST b {P}" |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
        \<Longrightarrow> \<turnstile> {P'} c {Q'}"

lemma sound: "\<Turnstile> {change_rule x b P} CHANGE x ST b {P}" nitpick
  sorry

lemma complete: "\<Turnstile> {P} (CHANGE x ST b) {Q} \<Longrightarrow> \<turnstile> {P} CHANGE x ST b {Q}"
  sorry

value "(Not (Less (Plus (V ''y'') (V ''x'')) (N 0)))"
value "(Not (Less (N 0) (Plus (V ''y'') (V ''x''))))"
definition MINUS :: com where
 "MINUS = (
  CHANGE ''y'' ST (And
  (Not (Less (Plus (V ''y'') (V ''x'')) (N 0)))
  (Not (Less (N 0) (Plus (V ''y'') (V ''x''))))
)
)"

lemma MINUS_correct:
  "\<turnstile> {\<lambda>s. s=s\<^sub>0} MINUS {\<lambda>s. s ''y'' = - s ''x'' \<and> (\<forall>v \<noteq> ''y''. s v = s\<^sub>0 v)}"
  unfolding MINUS_def
  sorry

definition invar :: "vname \<Rightarrow> bexp \<Rightarrow> vname \<Rightarrow> state \<Rightarrow> assn" where
  "invar x b y s\<^sub>0 = undefined"

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Tau_Stat_Imp
  imports Tau_Sim Weaken_Stat_Imp
begin

locale weakTauLaws = weak + tau
begin

lemma tauLaw1StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<lessapprox>\<^sub>w<Rel> Q"
  and     "(\<Psi>, \<tau>.(P), Q) \<in> Rel"

  shows "\<Psi> \<rhd> \<tau>.(P) \<lessapprox>\<^sub>w<Rel> Q"
proof -
  have "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q" by simp
  moreover have "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(rule insertTauAssertion)
  hence "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q) \<Psi>"
    by(metis FrameStatImpTrans FrameStatEq_def insertAssertionWeaken)
  ultimately show ?thesis using `(\<Psi>, \<tau>.(P), Q) \<in> Rel`
    by(rule weakenStatImpI)
qed

lemma tauLaw1StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<lessapprox><Rel> Q"
  and     C1: "\<And>\<Psi> P Q R. \<lbrakk>(\<Psi>, P, Q) \<in> Rel; \<Psi> \<rhd> Q \<sim> R\<rbrakk> \<Longrightarrow> (\<Psi>, P, R) \<in> Rel'"

  shows "\<Psi> \<rhd> P \<lessapprox><Rel'> \<tau>.(Q)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  from `\<Psi> \<rhd> P \<lessapprox><Rel> Q` obtain Q' Q''
    where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'" and PImpQ': "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q') \<Psi>"
      and Q'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" and PRelQ'': "(\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel"
    by(rule weakStatImpE)

  obtain Q''' where QTrans: "\<Psi> \<rhd> \<tau>.(Q) \<longmapsto>\<tau> \<prec> Q'''" and "\<Psi> \<rhd> Q \<sim> Q'''" using tauActionI by auto

  from `\<Psi> \<rhd> Q \<sim> Q'''` QChain bisimE(2) obtain Q'''' where Q'''Chain: "\<Psi> \<rhd> Q''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" and "\<Psi> \<rhd> Q' \<sim> Q''''"
    by(metis bisimE(4) simTauChain)

  from QTrans Q'''Chain have "\<Psi> \<rhd> \<tau>.(Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" by(drule_tac tauActTauChain) auto
  moreover from `\<Psi> \<rhd> Q' \<sim> Q''''` have "insertAssertion (extractFrame Q') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'''') \<Psi>"
    by(metis bisimE FrameStatEq_def)
  with PImpQ'  have "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'''') \<Psi>"
    by(rule FrameStatImpTrans)
  moreover from `\<Psi> \<rhd> Q' \<sim> Q''''` have "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<sim> Q''''" by(rule bisimE)
  then obtain Q''''' where Q''''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q'''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'''''" and "\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<sim> Q'''''" using Q'Chain bisimE(2)
    by(metis bisimE(4) simTauChain)
  note Q''''Chain
  moreover from `(\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel` `\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<sim> Q'''''` have "(\<Psi> \<otimes> \<Psi>', P, Q''''') \<in> Rel'"
    by(rule C1)
  ultimately show ?case by blast
qed

end

context tau begin

lemma tauLaw3StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>Q) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<lessapprox><Rel> \<alpha>\<cdot>Q"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<alpha>\<cdot>Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>Q" by auto
  moreover have "insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(P)))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>Q)) \<Psi>" using insertTauAssertion
    by(nominal_induct \<alpha> rule: prefix.strong_inducts) (auto simp add: FrameStatEq_def intro: FrameStatImpTrans)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<alpha>\<cdot>Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>Q" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>Q) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw3StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P, \<alpha>\<cdot>(\<tau>.(Q))) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<lessapprox><Rel> \<alpha>\<cdot>(\<tau>.(Q))"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd>  \<alpha>\<cdot>(\<tau>.(Q)) \<Longrightarrow>\<^sup>^\<^sub>\<tau>  \<alpha>\<cdot>(\<tau>.(Q))" by auto
  moreover have "insertAssertion (extractFrame(\<alpha>\<cdot>P)) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(Q)))) \<Psi>" using insertTauAssertion
    by(nominal_induct \<alpha> rule: prefix.strong_inducts) (auto simp add: FrameStatEq_def intro: FrameStatImpTrans)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd>  \<alpha>\<cdot>(\<tau>.(Q)) \<Longrightarrow>\<^sup>^\<^sub>\<tau>  \<alpha>\<cdot>(\<tau>.(Q))" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P, \<alpha>\<cdot>(\<tau>.(Q))) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

end

context tauSum begin

lemma tauLaw2StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> Rel"

  shows "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<lessapprox><Rel> \<tau>.(P)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<tau>.(P)" by auto
  moreover have "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(rule insertTauAssertion)
  hence "insertAssertion (extractFrame(P \<oplus> \<tau>.(P))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<tau>.(P))) \<Psi>" using Identity
    by(rule_tac FrameStatImpTrans) (auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<tau>.(P)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw2StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<tau>.(P), P \<oplus> \<tau>.(P)) \<in> Rel"

  shows "\<Psi> \<rhd> \<tau>.(P) \<lessapprox><Rel> P \<oplus> \<tau>.(P)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> P \<oplus> \<tau>.(P)" by auto
  moreover have "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(rule insertTauAssertion)
  hence "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(P \<oplus> \<tau>.(P))) \<Psi>" using Identity
    by(rule_tac FrameStatImpTrans) (auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<oplus> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> P \<oplus> \<tau>.(P)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<tau>.(P), P \<oplus> \<tau>.(P)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw4StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   M :: 'a
  and   N :: 'a

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><Rel> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  hence "insertAssertion (extractFrame(\<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi>"
    using insertTauAssertion Identity
    by(nominal_induct \<alpha> rule: prefix.strong_inducts, auto)
  (rule FrameStatImpTrans[where G="\<langle>\<epsilon>, \<Psi>\<rangle>"], auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw4StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><Rel> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  hence "insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi>"
    using insertTauAssertion Identity
    by(nominal_induct \<alpha> rule: prefix.strong_inducts, auto)
  (rule FrameStatImpTrans[where G="\<langle>\<epsilon>, \<Psi>\<rangle>"], auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

end

end


(*  Title:      Uint16.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

header {* Unsigned words of 16 bits *}

theory Uint16 imports
  Word_Misc
  Bits_Integer
begin

text {*
  Restriction for ML code generation:
  This theory assumes that the ML system provides a Word16
  implementation (mlton does, but PolyML 5.5 does not).
  Therefore, the code setup lives in the target @{text SML_word}
  rather than @{text SML}.  This ensures that code generation still
  works as long as @{text "uint16"} is not involved.
  For the target @{text SML} itself, no special code generation
  for this type is set up. Nevertheless, it should work by emulation via @{typ "16 word"}
  if the theory @{text Code_Target_Bits_Int} is imported.

  Restriction for OCaml code generation:
  OCaml does not provide an int16 type, so no special code generation
  for this type is set up.
*}

declare prod.Quotient[transfer_rule]

section {* Type definition and primitive operations *}

typedef uint16 = "UNIV :: 16 word set" ..

setup_lifting type_definition_uint16

text {* Use an abstract type for code generation to disable pattern matching on @{term Abs_uint16}. *}
declare Rep_uint16_inverse[code abstype]

declare Quotient_uint16[transfer_rule]

instantiation uint16 :: "{neg_numeral, Divides.div, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint16 :: uint16 is "0" .
lift_definition one_uint16 :: uint16 is "1" .
lift_definition plus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op +" .
lift_definition minus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op -" .
lift_definition uminus_uint16 :: "uint16 \<Rightarrow> uint16" is uminus .
lift_definition times_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op *" .
lift_definition div_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op div" .
lift_definition mod_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "op mod" .
instance by default (transfer, simp add: algebra_simps)+
end

instantiation uint16 :: linorder begin
lift_definition less_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "op <" .
lift_definition less_eq_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "op \<le>" .
instance by(default)(transfer, simp add: less_le_not_le linear)+
end

lemmas [code] = less_uint16.rep_eq less_eq_uint16.rep_eq

instantiation uint16 :: bitss begin
lift_definition bitNOT_uint16 :: "uint16 \<Rightarrow> uint16" is bitNOT .
lift_definition bitAND_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitAND .
lift_definition bitOR_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitOR .
lift_definition bitXOR_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitXOR .
lift_definition test_bit_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint16" is set_bit .
lift_definition set_bits_uint16 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16" is "set_bits" .
lift_definition lsb_uint16 :: "uint16 \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" is shiftl .
lift_definition shiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" is shiftr .
lift_definition msb_uint16 :: "uint16 \<Rightarrow> bool" is msb .
instance ..
end

lemmas [code] = test_bit_uint16.rep_eq lsb_uint16.rep_eq msb_uint16.rep_eq

instantiation uint16 :: equal begin
lift_definition equal_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "equal_class.equal" .
instance by default(transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint16.rep_eq

instantiation uint16 :: size begin
lift_definition size_uint16 :: "uint16 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint16.rep_eq

lift_definition sshiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" (infixl ">>>" 55) is sshiftr .

lift_definition uint16_of_int :: "int \<Rightarrow> uint16" is "word_of_int" .

definition uint16_of_nat :: "nat \<Rightarrow> uint16"
where "uint16_of_nat = uint16_of_int \<circ> int"

lift_definition int_of_uint16 :: "uint16 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint16 :: "uint16 \<Rightarrow> nat" is "unat" .

definition integer_of_uint16 :: "uint16 \<Rightarrow> integer"
where "integer_of_uint16 = integer_of_int o int_of_uint16"

text {* Use pretty numerals from integer for pretty printing *}

context includes integer.lifting begin

lift_definition Uint16 :: "integer \<Rightarrow> uint16" is "word_of_int" .

lemma Rep_uint16_numeral [simp]: "Rep_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def Abs_uint16_inverse numeral.simps plus_uint16_def)

lemma Rep_uint16_neg_numeral [simp]: "Rep_uint16 (- numeral n) = - numeral n"
by(simp only: uminus_uint16_def)(simp add: Abs_uint16_inverse)

lemma numeral_uint16_transfer [transfer_rule]:
  "(rel_fun op = cr_uint16) numeral numeral"
by(auto simp add: cr_uint16_def)

lemma numeral_uint16 [code_unfold]: "numeral n = Uint16 (numeral n)"
by transfer simp

lemma neg_numeral_uint16 [code_unfold]: "- numeral n = Uint16 (- numeral n)"
by transfer(simp add: cr_uint16_def)

end

lemma Abs_uint16_numeral [code_post]: "Abs_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def numeral.simps plus_uint16_def Abs_uint16_inverse)

lemma Abs_uint16_0 [code_post]: "Abs_uint16 0 = 0"
by(simp add: zero_uint16_def)

lemma Abs_uint16_1 [code_post]: "Abs_uint16 1 = 1"
by(simp add: one_uint16_def)

section {* Code setup *}

code_printing code_module Uint16 \<rightharpoonup> (SML_word)
{*(* Test that words can handle numbers between 0 and 15 *)
val _ = if 4 <= Word.wordSize then () else raise (Fail ("wordSize less than 4"));

structure Uint16 : sig
  val set_bit : Word16.word -> IntInf.int -> bool -> Word16.word
  val shiftl : Word16.word -> IntInf.int -> Word16.word
  val shiftr : Word16.word -> IntInf.int -> Word16.word
  val shiftr_signed : Word16.word -> IntInf.int -> Word16.word
  val test_bit : Word16.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word16.orb (x, mask)
     else Word16.andb (x, Word16.notb mask)
  end

fun shiftl x n =
  Word16.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word16.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word16.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word16.andb (x, Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word16.fromInt 0

end; (* struct Uint16 *)*}
code_reserved SML_word Uint16

code_printing code_module Uint16 \<rightharpoonup> (Haskell)
{*import qualified Data.Word;
import qualified Data.Int;

type Int16 = Data.Int.Int16;

type Word16 = Data.Word.Word16;*}
code_reserved Haskell Uint16

text {* Scala provides unsigned 16-bit numbers as Char. *}

code_printing code_module Uint16 \<rightharpoonup> (Scala)
{*object Uint16 {

def set_bit(x: scala.Char, n: BigInt, b: Boolean) : scala.Char =
  if (b)
    (x | (1.toChar << n.intValue)).toChar
  else
    (x & (1.toChar << n.intValue).unary_~).toChar

def shiftl(x: scala.Char, n: BigInt) : scala.Char = (x << n.intValue).toChar

def shiftr(x: scala.Char, n: BigInt) : scala.Char = (x >>> n.intValue).toChar

def shiftr_signed(x: scala.Char, n: BigInt) : scala.Char = (x.toShort >> n.intValue).toChar

def test_bit(x: scala.Char, n: BigInt) : Boolean = (x & (1.toChar << n.intValue)) != 0

} /* object Uint16 */*}
code_reserved Scala Uint16

text {*
  Avoid @{term Abs_uint16} in generated code, use @{term Rep_uint16'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint16}.

  The new destructor @{term Rep_uint16'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint16} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint16}
  ([code abstract] equations for @{typ uint16} may use @{term Rep_uint16} because
  these instances will be folded away.)

  To convert @{typ "16 word"} values into @{typ uint16}, use @{term "Abs_uint16'"}.
*}

definition Rep_uint16' where [simp]: "Rep_uint16' = Rep_uint16"

lemma Rep_uint16'_transfer [transfer_rule]:
  "rel_fun cr_uint16 op = (\<lambda>x. x) Rep_uint16'"
unfolding Rep_uint16'_def by(rule uint16.rep_transfer)

lift_definition Abs_uint16' :: "16 word \<Rightarrow> uint16" is "\<lambda>x :: 16 word. x" .

lemma Abs_uint16'_code [code]:
  "Abs_uint16' x = Uint16 (integer_of_int (uint x))"
including integer.lifting by transfer simp

lemma [code, code del]: "term_of_class.term_of = (term_of_class.term_of :: uint16 \<Rightarrow> _)" ..

lemma term_of_uint16_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint16.Abs_uint16'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]], TR (STR ''Uint16.uint16'') []]))
       (term_of_class.term_of (Rep_uint16' x))"
by(simp add: term_of_anything)

lemma Uin16_code [code abstract]: "Rep_uint16 (Uint16 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint16_def int_of_integer_symbolic_def by(simp add: Abs_uint16_inverse)

code_printing
  type_constructor uint16 \<rightharpoonup>
  (SML_word) "Word16.word" and
  (Haskell) "Uint16.Word16" and
  (Scala) "scala.Char"
| constant Uint16 \<rightharpoonup>
  (SML_word) "Word16.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint16.Word16)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Word16)" and
  (Scala) "_.charValue"
| constant "0 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 0)" and
  (Haskell) "(0 :: Uint16.Word16)" and
  (Scala) "0"
| constant "1 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 1)" and
  (Haskell) "(1 :: Uint16.Word16)" and
  (Scala) "1"
| constant "plus :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toChar"
| constant "uminus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toChar"
| constant "minus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toChar"
| constant "times :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toChar"
| constant "HOL.equal :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "!((_ : Word16.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint16 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) infixl 4 "<="
| constant "less :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) infixl 4 "<"
| constant "bitNOT :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toChar"
| constant "bitAND :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toChar"
| constant "bitOR :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toChar"
| constant "bitXOR :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toChar"

definition uint16_div :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_div x y = (if y = 0 then undefined (op div :: uint16 \<Rightarrow> _) x (0 :: uint16) else x div y)"

definition uint16_mod :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_mod x y = (if y = 0 then undefined (op mod :: uint16 \<Rightarrow> _) x (0 :: uint16) else x mod y)"

context includes undefined_transfer begin

lemma div_uint16_code [code]: "x div y = (if y = 0 then 0 else uint16_div x y)"
unfolding uint16_div_def by transfer(simp add: word_div_def)

lemma mod_uint16_code [code]: "x mod y = (if y = 0 then x else uint16_mod x y)"
unfolding uint16_mod_def by transfer(simp add: word_mod_def)

lemma uint16_div_code [code abstract]:
  "Rep_uint16 (uint16_div x y) =
  (if y = 0 then Rep_uint16 (undefined (op div :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x div Rep_uint16 y)"
unfolding uint16_div_def by transfer simp

lemma uint16_mod_code [code abstract]:
  "Rep_uint16 (uint16_mod x y) =
  (if y = 0 then Rep_uint16 (undefined (op mod :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x mod Rep_uint16 y)"
unfolding uint16_mod_def by transfer simp

end

code_printing constant uint16_div \<rightharpoonup>
  (SML_word) "Word16.div ((_), (_))" and
  (Haskell) "Prelude.div" and
  (Scala) "(_ '/ _).toChar"
| constant uint16_mod \<rightharpoonup>
  (SML_word) "Word16.mod ((_), (_))" and
  (Haskell) "Prelude.mod" and
  (Scala) "(_ % _).toChar"

definition uint16_test_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint16_test_bit x n =
  (if n < 0 \<or> 15 < n then undefined (test_bit :: uint16 \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint16_code [code]:
  "test_bit x n \<longleftrightarrow> n < 16 \<and> uint16_test_bit x (integer_of_nat n)"
unfolding uint16_test_bit_def including undefined_transfer integer.lifting
by transfer(auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint16_test_bit_code [code]:
  "uint16_test_bit w n =
  (if n < 0 \<or> 15 < n then undefined (test_bit :: uint16 \<Rightarrow> _) w n else Rep_uint16 w !! nat_of_integer n)"
unfolding uint16_test_bit_def by(simp add: test_bit_uint16.rep_eq)

code_printing constant uint16_test_bit \<rightharpoonup>
  (SML_word) "Uint16.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint16.test'_bit"

definition uint16_set_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint16"
where [code del]:
  "uint16_set_bit x n b =
  (if n < 0 \<or> 15 < n then undefined (set_bit :: uint16 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint16_code [code]:
  "set_bit x n b = (if n < 16 then uint16_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint16_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint16_set_bit_code [code abstract]:
  "Rep_uint16 (uint16_set_bit w n b) =
  (if n < 0 \<or> 15 < n then Rep_uint16 (undefined (set_bit :: uint16 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint16 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint16_set_bit_def by transfer simp

code_printing constant uint16_set_bit \<rightharpoonup>
  (SML_word) "Uint16.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint16.set'_bit"

lift_definition uint16_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16 \<Rightarrow> nat \<Rightarrow> uint16" is set_bits_aux .

lemma uint16_set_bits_code [code]:
  "uint16_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint16_set_bits f ((w << 1) OR (if f n' then 1 else 0)) n')"
by(transfer fixing: n)(cases n, simp_all)

lemma set_bits_uint16 [code]:
  "(BITS n. f n) = uint16_set_bits f 0 16"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint16 shows "lsb x = x !! 0"
by transfer(simp add: word_lsb_def word_test_bit_def)

definition uint16_shiftl :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftl x n = (if n < 0 \<or> 16 \<le> n then undefined (shiftl :: uint16 \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint16_code [code]: "x << n = (if n < 16 then uint16_shiftl x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint16_shiftl_def
by transfer(simp add: not_less shiftl_zero_size word_size)

lemma uint16_shiftl_code [code abstract]:
  "Rep_uint16 (uint16_shiftl w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (shiftl :: uint16 \<Rightarrow> _) w n)
   else Rep_uint16 w << nat_of_integer n)"
including undefined_transfer unfolding uint16_shiftl_def by transfer simp

code_printing constant uint16_shiftl \<rightharpoonup>
  (SML_word) "Uint16.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint16.shiftl"

definition uint16_shiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftr x n = (if n < 0 \<or> 16 \<le> n then undefined (shiftr :: uint16 \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint16_code [code]: "x >> n = (if n < 16 then uint16_shiftr x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint16_shiftr_def
by transfer(simp add: not_less shiftr_zero_size word_size)

lemma uint16_shiftr_code [code abstract]:
  "Rep_uint16 (uint16_shiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (shiftr :: uint16 \<Rightarrow> _) w n)
   else Rep_uint16 w >> nat_of_integer n)"
including undefined_transfer unfolding uint16_shiftr_def by transfer simp

code_printing constant uint16_shiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint16.shiftr"

definition uint16_sshiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_sshiftr x n =
  (if n < 0 \<or> 16 \<le> n then undefined sshiftr_uint16 x n else sshiftr_uint16 x (nat_of_integer n))"

lemma sshiftr_beyond: fixes x :: "'a :: len word" shows
  "size x \<le> n \<Longrightarrow> x >>> n = (if x !! (size x - 1) then -1 else 0)"
by(rule word_eqI)(simp add: nth_sshiftr word_size)

lemma sshiftr_uint16_code [code]:
  "x >>> n =
  (if n < 16 then uint16_sshiftr x (integer_of_nat n) else if x !! 15 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint16_sshiftr_def
by transfer (simp add: not_less sshiftr_beyond word_size)

lemma uint16_sshiftr_code [code abstract]:
  "Rep_uint16 (uint16_sshiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined sshiftr_uint16 w n)
   else Rep_uint16 w >>> nat_of_integer n)"
including undefined_transfer unfolding uint16_sshiftr_def by transfer simp

code_printing constant uint16_sshiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Int16) _)) :: Uint16.Word16)" and
  (Scala) "Uint16.shiftr'_signed"

lemma uint16_msb_test_bit: "msb x \<longleftrightarrow> (x :: uint16) !! 15"
by transfer(simp add: msb_nth)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint16_test_bit x 15"
by(simp add: uint16_test_bit_def uint16_msb_test_bit)

lemma uint16_of_int_code [code]: "uint16_of_int i = Uint16 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint16_code [code]:
  "int_of_uint16 x = int_of_integer (integer_of_uint16 x)"
by(simp add: integer_of_uint16_def)

lemma nat_of_uint16_code [code]:
  "nat_of_uint16 x = nat_of_integer (integer_of_uint16 x)"
unfolding integer_of_uint16_def including integer.lifting by transfer (simp add: unat_def)

lemma integer_of_uint16_code [code]:
  "integer_of_uint16 n = integer_of_int (uint (Rep_uint16' n))"
unfolding integer_of_uint16_def by transfer auto

code_printing
  constant "integer_of_uint16" \<rightharpoonup>
  (SML_word) "Word16.toInt _ : IntInf.int" and
  (Haskell) "Prelude.toInteger" and
  (Scala) "BigInt"

section {* Quickcheck setup *}

definition uint16_of_natural :: "natural \<Rightarrow> uint16"
where "uint16_of_natural x \<equiv> Uint16 (integer_of_natural x)"

instantiation uint16 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint16 \<equiv> qc_random_cnv uint16_of_natural"
definition "exhaustive_uint16 \<equiv> qc_exhaustive_cnv uint16_of_natural"
definition "full_exhaustive_uint16 \<equiv> qc_full_exhaustive_cnv uint16_of_natural"
instance ..
end

instantiation uint16 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint16 i in (x, 0xFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint16.uint16'') []" .

definition "narrowing_uint16 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint16 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint16 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint16 (infixl ">>>" 55)

end