theory secTypes
imports Semantics
begin

section \<open>Security types\<close>

subsection \<open>Security definitions\<close>

datatype secLevel = Low | High

type_synonym typeEnv = "vname \<rightharpoonup> secLevel"

inductive secExprTyping :: "typeEnv \<Rightarrow> expr \<Rightarrow> secLevel \<Rightarrow> bool" ("_ \<turnstile> _ : _")
where typeVal:  "\<Gamma> \<turnstile> Val V : lev"

  | typeVar:    "\<Gamma> Vn = Some lev \<Longrightarrow> \<Gamma> \<turnstile> Var Vn : lev"

  | typeBinOp1: "\<lbrakk>\<Gamma> \<turnstile> e1 : Low; \<Gamma> \<turnstile> e2 : Low\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : Low"

  | typeBinOp2: "\<lbrakk>\<Gamma> \<turnstile> e1 : High; \<Gamma> \<turnstile> e2 : lev\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : High"

  | typeBinOp3: "\<lbrakk>\<Gamma> \<turnstile> e1 : lev; \<Gamma> \<turnstile> e2 : High\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : High"

inductive secComTyping :: "typeEnv \<Rightarrow> secLevel \<Rightarrow> com \<Rightarrow> bool" ("_,_ \<turnstile> _")
where typeSkip:  "\<Gamma>,T \<turnstile> Skip"

  | typeAssH:    "\<Gamma> V = Some High \<Longrightarrow> \<Gamma>,T \<turnstile> V := e"

  | typeAssL:    "\<lbrakk>\<Gamma> \<turnstile> e : Low; \<Gamma> V = Some Low\<rbrakk> \<Longrightarrow> \<Gamma>,Low \<turnstile> V := e"

  | typeSeq:     "\<lbrakk>\<Gamma>,T \<turnstile> c1; \<Gamma>,T \<turnstile> c2\<rbrakk> \<Longrightarrow> \<Gamma>,T \<turnstile> c1;;c2"

  | typeWhile:   "\<lbrakk>\<Gamma> \<turnstile> b : T; \<Gamma>,T \<turnstile> c\<rbrakk> \<Longrightarrow> \<Gamma>,T \<turnstile> while (b) c"

  | typeIf:      "\<lbrakk>\<Gamma> \<turnstile> b : T; \<Gamma>,T \<turnstile> c1; \<Gamma>,T \<turnstile> c2\<rbrakk> \<Longrightarrow> \<Gamma>,T \<turnstile> if (b) c1 else c2"

  | typeConvert: "\<Gamma>,High \<turnstile> c \<Longrightarrow> \<Gamma>,Low \<turnstile> c"

subsection \<open>Lemmas concerning expressions\<close>

lemma exprTypeable:
  assumes "fv e \<subseteq> dom \<Gamma>" obtains T where "\<Gamma> \<turnstile> e : T"
proof -
  from \<open>fv e \<subseteq> dom \<Gamma>\<close> have "\<exists>T. \<Gamma> \<turnstile> e : T"
  proof(induct e)
    case (Val V)
    have "\<Gamma> \<turnstile> Val V : Low" by(rule typeVal)
    thus ?case by (rule exI)
  next
    case (Var V)
    have "V \<in> fv (Var V)" by simp
    with \<open>fv (Var V) \<subseteq> dom \<Gamma>\<close> have "V \<in> dom \<Gamma>" by simp
    then obtain T where "\<Gamma> V = Some T" by auto
    hence "\<Gamma> \<turnstile> Var V : T" by (rule typeVar)
    thus ?case by (rule exI)
  next
    case (BinOp e1 bop e2)
    note IH1 = \<open>fv e1 \<subseteq> dom \<Gamma> \<Longrightarrow> \<exists>T. \<Gamma> \<turnstile> e1 : T\<close>
    note IH2 = \<open>fv e2 \<subseteq> dom \<Gamma> \<Longrightarrow> \<exists>T. \<Gamma> \<turnstile> e2 : T\<close>
    from \<open>fv (e1 \<guillemotleft>bop\<guillemotright> e2) \<subseteq> dom \<Gamma>\<close>
    have "fv e1 \<subseteq> dom \<Gamma>" and "fv e2 \<subseteq> dom \<Gamma>" by auto
    from IH1[OF \<open>fv e1 \<subseteq> dom \<Gamma>\<close>] obtain T1 where "\<Gamma> \<turnstile> e1 : T1" by auto
    from IH2[OF \<open>fv e2 \<subseteq> dom \<Gamma>\<close>] obtain T2 where "\<Gamma> \<turnstile> e2 : T2" by auto
    show ?case
    proof (cases T1)
      case Low
      show ?thesis
      proof (cases T2)
        case Low
        with \<open>\<Gamma> \<turnstile> e1 : T1\<close> \<open>\<Gamma> \<turnstile> e2 : T2\<close> \<open>T1 = Low\<close>
        have "\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : Low" by(simp add:typeBinOp1)
        thus ?thesis by(rule exI)
      next
        case High
        with \<open>\<Gamma> \<turnstile> e1 : T1\<close> \<open>\<Gamma> \<turnstile> e2 : T2\<close> \<open>T1 = Low\<close>
        have "\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : High" by(simp add:typeBinOp3)
        thus ?thesis by(rule exI)
      qed
    next
      case High
      with \<open>\<Gamma> \<turnstile> e1 : T1\<close> \<open>\<Gamma> \<turnstile> e2 : T2\<close>
      have "\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : High" by (simp add: typeBinOp2)
      thus ?thesis by (rule exI)
    qed
  qed
  with that show ?thesis by blast
qed

lemma exprBinopTypeable:
  assumes "\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : T"
  shows "(\<exists>T1. \<Gamma> \<turnstile> e1 : T1) \<and> (\<exists>T2. \<Gamma> \<turnstile> e2 : T2)"
using assms by(auto elim:secExprTyping.cases)

lemma exprTypingHigh:
  assumes "\<Gamma> \<turnstile> e : T" and "x \<in> fv e" and "\<Gamma> x = Some High"
  shows "\<Gamma> \<turnstile> e : High"
using assms
proof (induct e arbitrary:T)
  case (Val V) show ?case by (rule typeVal)
next
  case (Var V)
  from \<open>x \<in> fv (Var V)\<close> have "x = V" by simp
  with \<open>\<Gamma> x = Some High\<close> show ?case by(simp add:typeVar)
next
  case (BinOp e1 bop e2)
  note IH1 = \<open>\<And>T. \<lbrakk>\<Gamma> \<turnstile> e1 : T; x \<in> fv e1; \<Gamma> x = Some High\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> e1 : High\<close>
  note IH2 = \<open>\<And>T. \<lbrakk>\<Gamma> \<turnstile> e2 : T; x \<in> fv e2; \<Gamma> x = Some High\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> e2 : High\<close>
  from \<open>\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : T\<close>
  have T:"(\<exists>T1. \<Gamma> \<turnstile> e1 : T1) \<and> (\<exists>T2. \<Gamma> \<turnstile> e2 : T2)" by (auto intro!:exprBinopTypeable)
  then obtain T1 where "\<Gamma> \<turnstile> e1 : T1" by auto
  from T obtain T2 where "\<Gamma> \<turnstile> e2 : T2" by auto
  from \<open>x \<in> fv (e1 \<guillemotleft>bop\<guillemotright> e2)\<close> have "x \<in> (fv e1 \<union> fv e2)" by simp
  hence "x \<in> fv e1 \<or> x \<in> fv e2" by auto
  thus ?case
  proof
    assume "x \<in> fv e1"
    from IH1[OF \<open>\<Gamma> \<turnstile> e1 : T1\<close> this \<open>\<Gamma> x = Some High\<close>] have "\<Gamma> \<turnstile> e1 : High" .
    with \<open>\<Gamma> \<turnstile> e2 : T2\<close> show ?thesis by(simp add:typeBinOp2)
  next
    assume "x \<in> fv e2"
    from IH2[OF \<open>\<Gamma> \<turnstile> e2 : T2\<close> this \<open>\<Gamma> x = Some High\<close>] have "\<Gamma> \<turnstile> e2 : High" .
    with \<open>\<Gamma> \<turnstile> e1 : T1\<close> show ?thesis by(simp add:typeBinOp3)
  qed
qed

lemma exprTypingLow:
  assumes "\<Gamma> \<turnstile> e : Low" and "x \<in> fv e" shows "\<Gamma> x = Some Low"
using assms
proof (induct e)
  case (Val V)
  have "fv (Val V) =  {}" by (rule FVc)
  with \<open>x \<in> fv (Val V)\<close> have False by auto
  thus ?thesis by simp
next
  case (Var V)
  from \<open>x \<in> fv (Var V)\<close> have xV: "x = V" by simp
  from \<open>\<Gamma> \<turnstile> Var V : Low\<close> have "\<Gamma> V = Some Low" by (auto elim:secExprTyping.cases)
  with xV show ?thesis by simp
next
  case (BinOp e1 bop e2)
  note IH1 = \<open>\<lbrakk>\<Gamma> \<turnstile> e1 : Low; x \<in> fv e1\<rbrakk> \<Longrightarrow> \<Gamma> x = Some Low\<close>
  note IH2=\<open>\<lbrakk>\<Gamma> \<turnstile> e2 : Low; x \<in> fv e2\<rbrakk> \<Longrightarrow> \<Gamma> x = Some Low\<close>
  from \<open>\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 : Low\<close> have "\<Gamma> \<turnstile> e1 : Low" and "\<Gamma> \<turnstile> e2 : Low"
    by(auto elim:secExprTyping.cases)
  from \<open>x \<in> fv (e1 \<guillemotleft>bop\<guillemotright> e2)\<close> have "x \<in> fv e1 \<union> fv e2" by (simp add:FVe)
  hence "x \<in> fv e1 \<or> x \<in> fv e2" by auto
  thus ?case
  proof
    assume "x \<in> fv e1"
    with IH1[OF \<open>\<Gamma> \<turnstile> e1 : Low\<close>] show ?thesis by auto
  next
    assume "x \<in> fv e2"
    with IH2[OF \<open>\<Gamma> \<turnstile> e2 : Low\<close>] show ?thesis by auto
  qed
qed

(* We assume that expressions are type correct and thus never evaluate to None.
   In this setting, the first premise is not needed.
   But for further extensions of the language with a standard type system
   we do not remove it. *)
lemma exprNotNone:
assumes "\<Gamma> \<turnstile> e : T" and "fv e \<subseteq> dom s"
shows "\<lbrakk>e\<rbrakk> s \<noteq> None"
using assms
proof (induct e arbitrary: \<Gamma> T s)
  case (Val v)
  show ?case by(simp add:Val)
next
  case (Var V)
  have "\<lbrakk>Var V\<rbrakk> s = s V" by (simp add:Var)
  have "V \<in> fv (Var V)" by (auto simp add:FVv)
  with \<open>fv (Var V) \<subseteq> dom s\<close> have "V \<in> dom s" by simp
  thus ?case by auto
next
  case (BinOp e1 bop e2)
  note IH1 = \<open>\<And>T. \<lbrakk>\<Gamma> \<turnstile> e1 : T; fv e1 \<subseteq> dom s \<rbrakk>  \<Longrightarrow> \<lbrakk>e1\<rbrakk> s \<noteq> None\<close>
  note IH2 = \<open>\<And>T. \<lbrakk>\<Gamma> \<turnstile> e2 : T; fv e2 \<subseteq> dom s \<rbrakk>  \<Longrightarrow> \<lbrakk>e2\<rbrakk> s \<noteq> None\<close>
  from \<open>\<Gamma> \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 :  T\<close> have "(\<exists>T1. \<Gamma> \<turnstile> e1 : T1) \<and> (\<exists>T2. \<Gamma> \<turnstile> e2 : T2)"
    by(rule exprBinopTypeable)
  then obtain T1 T2 where "\<Gamma> \<turnstile> e1 : T1" and "\<Gamma> \<turnstile> e2 : T2" by blast
  from \<open>fv (e1 \<guillemotleft>bop\<guillemotright> e2)  \<subseteq> dom s\<close> have "fv e1 \<union> fv e2 \<subseteq> dom s" by(simp add:FVe)
  hence "fv e1 \<subseteq> dom s" and "fv e2 \<subseteq> dom s" by auto
  from IH1[OF \<open>\<Gamma> \<turnstile> e1 : T1\<close> \<open>fv e1 \<subseteq> dom s\<close>] have "\<lbrakk>e1\<rbrakk>s \<noteq> None" .
  moreover from IH2[OF \<open>\<Gamma> \<turnstile> e2 : T2\<close> \<open>fv e2 \<subseteq> dom s\<close>] have "\<lbrakk>e2\<rbrakk>s \<noteq> None" .
  ultimately show ?case
    apply(cases bop) apply auto
    apply(case_tac y,auto,case_tac ya,auto)+
    done
qed

subsection \<open>Noninterference definitions\<close>

subsubsection \<open>Low Equivalence\<close>

text \<open>Low Equivalence is reflexive even if the involved states are undefined.
  But in non-reflexive situations low variables must be initialized
  (i.e. \<open>\<in> dom state\<close>), otherwise the proof will not work. This is not
  a restriction, but a natural requirement, and could be formalized as part of
  a standard type system.

  Low equivalence is also symmetric and transitiv (see lemmas) hence an
  equivalence relation.\<close>

definition lowEquiv :: "typeEnv \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" ("_ \<turnstile> _ \<approx>\<^sub>L _")
where "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2 \<equiv> \<forall>v\<in>dom \<Gamma>. \<Gamma> v = Some Low \<longrightarrow> (s1 v = s2 v)"

lemma lowEquivReflexive: "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s1"
by(simp add:lowEquiv_def)

lemma lowEquivSymmetric:
  "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2 \<Longrightarrow> \<Gamma> \<turnstile> s2 \<approx>\<^sub>L s1"
by(simp add:lowEquiv_def)

lemma lowEquivTransitive:
  "\<lbrakk>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2; \<Gamma> \<turnstile> s2 \<approx>\<^sub>L s3\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s3"
by(simp add:lowEquiv_def)

subsubsection \<open>Non Interference\<close>

definition nonInterference :: "typeEnv \<Rightarrow> com \<Rightarrow> bool"
where "nonInterference \<Gamma> c \<equiv>
  (\<forall>s1 s2 s1' s2'. (\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2 \<and> \<langle>c,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle> \<and> \<langle>c,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>)
    \<longrightarrow> \<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2')"

lemma nonInterferenceI:
  "\<lbrakk>\<And>s1 s2 s1' s2'. \<lbrakk>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2; \<langle>c,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>; \<langle>c,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'\<rbrakk> \<Longrightarrow> nonInterference \<Gamma> c"
by(auto simp:nonInterference_def)

lemma interpretLow:
  assumes "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and all:"\<forall>V\<in>fv e. \<Gamma> V = Some Low"
  shows "\<lbrakk>e\<rbrakk> s1 = \<lbrakk>e\<rbrakk> s2"
using all
proof (induct e)
  case (Val v)
  show ?case by (simp add: Val)
next
  case (Var V)
  have "\<lbrakk>Var V\<rbrakk> s1 = s1 V" and "\<lbrakk>Var V\<rbrakk> s2 = s2 V" by(auto simp:Var)
  have "V \<in> fv (Var V)" by(simp add:FVv)
  from \<open>V \<in> fv (Var V)\<close> \<open>\<forall>X\<in>fv (Var V). \<Gamma> X = Some Low\<close> have "\<Gamma> V = Some Low" by simp
  with assms have "s1 V = s2 V" by(auto simp add:lowEquiv_def)
  thus ?case by auto
next
  case (BinOp e1 bop e2)
  note IH1 = \<open>\<forall>V\<in>fv e1. \<Gamma> V = Some Low \<Longrightarrow> \<lbrakk>e1\<rbrakk>s1 = \<lbrakk>e1\<rbrakk>s2\<close>
  note IH2 = \<open>\<forall>V\<in>fv e2. \<Gamma> V = Some Low \<Longrightarrow> \<lbrakk>e2\<rbrakk>s1 = \<lbrakk>e2\<rbrakk>s2\<close>
  from \<open>\<forall>V\<in>fv (e1 \<guillemotleft>bop\<guillemotright> e2). \<Gamma> V = Some Low\<close> have "\<forall>V\<in>fv e1. \<Gamma> V = Some Low"
    and "\<forall>V\<in> fv e2. \<Gamma> V = Some Low" by auto
  from IH1[OF \<open>\<forall>V\<in>fv e1. \<Gamma> V = Some Low\<close>] have "\<lbrakk>e1\<rbrakk> s1 = \<lbrakk>e1\<rbrakk> s2" .
  moreover
  from IH2[OF \<open>\<forall>V\<in>fv e2. \<Gamma> V = Some Low\<close>] have "\<lbrakk>e2\<rbrakk> s1 = \<lbrakk>e2\<rbrakk> s2" .
  ultimately show ?case by(cases "\<lbrakk>e1\<rbrakk> s2",auto)
qed

lemma interpretLow2:
  assumes "\<Gamma> \<turnstile> e : Low" and "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" shows "\<lbrakk>e\<rbrakk> s1 = \<lbrakk>e\<rbrakk> s2"
proof -
  from \<open>\<Gamma> \<turnstile> e : Low\<close> have "fv e \<subseteq> dom \<Gamma>" by(auto dest:typeableFreevars)
  have "\<forall>x\<in> fv e. \<Gamma> x = Some Low"
  proof
    fix x assume "x \<in> fv e"
    with \<open>\<Gamma> \<turnstile> e : Low\<close> show "\<Gamma> x = Some Low" by(auto intro:exprTypingLow)
  qed
  with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> show ?thesis by(rule interpretLow)
qed

lemma assignNIhighlemma:
  assumes "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2"  and "\<Gamma> V = Some High" and "s1' = s1(V:= \<lbrakk>e\<rbrakk> s1)"
  and "s2' = s2(V:= \<lbrakk>e\<rbrakk> s2)"
  shows "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
proof -
  { fix V' assume "V' \<in> dom \<Gamma>" and  "\<Gamma> V' = Some Low"
    from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>  \<open>\<Gamma> V' = Some Low\<close> have "s1 V' = s2 V'"
      by(auto simp add:lowEquiv_def)
    have "s1' V' = s2' V'"
    proof(cases "V' = V")
      case True
      with \<open>\<Gamma> V' = Some Low\<close> \<open>\<Gamma> V = Some High\<close> have False by simp
      thus ?thesis by simp
    next
      case False
      with \<open>s1' = s1(V:= \<lbrakk>e\<rbrakk> s1)\<close> \<open>s2' = s2(V:= \<lbrakk>e\<rbrakk> s2)\<close>
      have "s1 V' = s1' V'" and "s2 V' = s2' V'" by auto
      with \<open>s1 V' = s2 V'\<close> show ?thesis by simp
    qed
  }
  thus ?thesis by(auto simp add:lowEquiv_def)
qed

lemma assignNIlowlemma:
  assumes "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2"  and "\<Gamma> V = Some Low" and "\<Gamma> \<turnstile> e : Low"
  and "s1' = s1(V:= \<lbrakk>e\<rbrakk> s1)" and "s2' = s2(V:= \<lbrakk>e\<rbrakk> s2)"
  shows "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
proof -
  { fix V' assume "V' \<in> dom \<Gamma>" and  "\<Gamma> V' = Some Low"
    from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>  \<open>\<Gamma> V' = Some Low\<close>
    have "s1 V' = s2 V'" by(auto simp add:lowEquiv_def)
    have "s1' V' = s2' V'"
    proof(cases "V' = V")
      case True
      with \<open>s1' = s1(V:= \<lbrakk>e\<rbrakk> s1)\<close> \<open>s2' = s2(V:= \<lbrakk>e\<rbrakk> s2)\<close>
      have "s1' V' = \<lbrakk>e\<rbrakk> s1" and "s2' V' = \<lbrakk>e\<rbrakk> s2" by auto
      from \<open>\<Gamma> \<turnstile> e : Low\<close> \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> have "\<lbrakk>e\<rbrakk> s1 = \<lbrakk>e\<rbrakk> s2"
        by(auto intro:interpretLow2)
      with \<open>s1' V' = \<lbrakk>e\<rbrakk> s1\<close> \<open>s2' V' = \<lbrakk>e\<rbrakk> s2\<close> show ?thesis by simp
    next
      case False
      with \<open>s1' = s1(V:= \<lbrakk>e\<rbrakk> s1)\<close> \<open>s2' = s2(V:= \<lbrakk>e\<rbrakk> s2)\<close>
      have "s1' V' = s1 V'" and "s2' V' = s2 V'" by auto
      with \<open>s1 V' = s2 V'\<close> have "s1' V' = s2' V'" by simp
      with False \<open>s1' V' = s1 V'\<close> \<open>s2' V' = s2 V'\<close>
      show ?thesis by auto
    qed
  }
  thus ?thesis by(simp add:lowEquiv_def)
qed

text \<open>Sequential Compositionality is given the status of a theorem because
  compositionality is no longer valid in case of concurrency\<close>

theorem SeqCompositionality:
  assumes "nonInterference \<Gamma> c1" and "nonInterference \<Gamma> c2"
  shows "nonInterference \<Gamma> (c1;;c2)"
proof(rule nonInterferenceI)
  fix s1 s2 s1' s2'
  assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>c1;;c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>"
    and "\<langle>c1;;c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
  from \<open>\<langle>c1;;c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> obtain s1'' where "\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s1''\<rangle>"
    and "\<langle>c2,s1''\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>" by(auto dest:Seq_reds)
  from \<open>\<langle>c1;;c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close> obtain s2'' where "\<langle>c1,s2\<rangle> \<rightarrow>* \<langle>Skip,s2''\<rangle>"
    and "\<langle>c2,s2''\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>" by(auto dest:Seq_reds)
  from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> \<open>\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s1''\<rangle>\<close> \<open>\<langle>c1,s2\<rangle> \<rightarrow>* \<langle>Skip,s2''\<rangle>\<close>
    \<open>nonInterference \<Gamma> c1\<close>
  have "\<Gamma> \<turnstile> s1'' \<approx>\<^sub>L s2''" by(auto simp:nonInterference_def)
  with \<open>\<langle>c2,s1''\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> \<open>\<langle>c2,s2''\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close> \<open>nonInterference \<Gamma> c2\<close>
  show "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'" by(auto simp:nonInterference_def)
qed

lemma WhileStepInduct:
  assumes while:"\<langle>while (b) c,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>"
  and body:"\<And>s1 s2. \<langle>c,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>  \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<Gamma>,High \<turnstile> c"
  shows "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2"
using while
proof (induct rule:while_reds_induct)
  case (false s) thus ?case by(auto simp add:lowEquiv_def)
next
  case (true s1 s3)
  from body[OF \<open>\<langle>c,s1\<rangle> \<rightarrow>* \<langle>Skip,s3\<rangle>\<close>] have "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s3" by simp
  with \<open>\<Gamma> \<turnstile> s3 \<approx>\<^sub>L s2\<close> show ?case by(auto intro:lowEquivTransitive)
qed

text \<open>In case control conditions from if/while are high, the body of an
  if/while must not change low variables in order to prevent implicit flow.
  That is, start and end state of any if/while body must be low equivalent.\<close>

theorem highBodies:
  assumes "\<Gamma>,High \<turnstile> c" and "\<langle>c,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>"
  shows "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2"
  \<comment> \<open>all intermediate states must be well formed, otherwise the proof does not
  work for uninitialized variables. Thus it is propagated through the
  theorem conclusion\<close>
using assms
proof(induct c arbitrary:s1 s2 rule:com.induct)
  case Skip
  from \<open>\<langle>Skip,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close> have "s1 = s2" by (auto dest:Skip_reds)
  thus ?case by(simp add:lowEquiv_def)
next
  case (LAss V e)
  from \<open>\<Gamma>,High \<turnstile> V:=e\<close> have "\<Gamma> V = Some High" by(auto elim:secComTyping.cases)
  from \<open>\<langle>V:=e,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close> have "s2 = s1(V:= \<lbrakk>e\<rbrakk>s1)" by (auto intro:LAss_reds)
  { fix V' assume "V' \<in> dom \<Gamma>" and "\<Gamma> V' = Some Low"
    have "s1 V' = s2 V'"
    proof(cases "V' = V")
      case True
      with \<open>\<Gamma> V' = Some Low\<close> \<open>\<Gamma> V = Some High\<close> have False by simp
      thus ?thesis by simp
    next
      case False
      with \<open>s2 = s1(V:= \<lbrakk>e\<rbrakk>s1)\<close> show ?thesis by simp
    qed
  }
  thus ?case by(auto simp add:lowEquiv_def)
next
  case (Seq c1 c2)
  note IH1 = \<open>\<And>s1 s2. \<lbrakk>\<Gamma>,High \<turnstile> c1; \<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>
  note IH2 = \<open>\<And>s1 s2. \<lbrakk>\<Gamma>,High \<turnstile> c2; \<langle>c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>
  from \<open>\<Gamma>,High \<turnstile> c1;;c2\<close> have "\<Gamma>,High \<turnstile> c1" and "\<Gamma>,High \<turnstile> c2"
    by(auto elim:secComTyping.cases)
  from \<open>\<langle>c1;;c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close>
  have "\<exists>s3. \<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s3\<rangle> \<and> \<langle>c2,s3\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>" by(auto intro:Seq_reds)
  then obtain s3 where "\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s3\<rangle>" and "\<langle>c2,s3\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>" by auto
  from IH1[OF \<open>\<Gamma>,High \<turnstile> c1\<close> \<open>\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s3\<rangle>\<close>]
  have "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s3" by simp
  from IH2[OF \<open>\<Gamma>,High \<turnstile> c2\<close> \<open>\<langle>c2,s3\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close>]
  have "\<Gamma> \<turnstile> s3 \<approx>\<^sub>L s2" by simp
  from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s3\<close> \<open>\<Gamma> \<turnstile> s3 \<approx>\<^sub>L s2\<close> show ?case
    by(auto intro:lowEquivTransitive)
next
  case (Cond b c1 c2)
  note IH1 = \<open>\<And>s1 s2. \<lbrakk>\<Gamma>,High \<turnstile> c1; \<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>
  note IH2 = \<open>\<And>s1 s2. \<lbrakk>\<Gamma>,High \<turnstile> c2; \<langle>c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>
  from \<open>\<Gamma>,High \<turnstile> if (b) c1 else c2\<close> have "\<Gamma>,High \<turnstile> c1" and "\<Gamma>,High \<turnstile> c2"
    by(auto elim:secComTyping.cases)
  from \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close>
  have "\<lbrakk>b\<rbrakk> s1 = Some true \<or> \<lbrakk>b\<rbrakk> s1 = Some false" by(auto dest:Cond_True_or_False)
  thus ?case
  proof
    assume "\<lbrakk>b\<rbrakk> s1 = Some true"
    with \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close> have "\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>"
      by (auto intro:CondTrue_reds)
    from IH1[OF \<open>\<Gamma>,High \<turnstile> c1\<close> this] show ?thesis .
  next
    assume "\<lbrakk>b\<rbrakk> s1 = Some false"
    with \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close> have "\<langle>c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>"
      by(auto intro:CondFalse_reds)
    from IH2[OF \<open>\<Gamma>,High \<turnstile> c2\<close> this] show ?thesis .
  qed
next
  case (While b c')
  note IH = \<open>\<And>s1 s2. \<lbrakk>\<Gamma>,High \<turnstile> c'; \<langle>c',s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close>
  from \<open>\<Gamma>,High \<turnstile> while (b) c'\<close> have "\<Gamma>,High \<turnstile> c'" by(auto elim:secComTyping.cases)
  from IH[OF this]
  have "\<And>s1 s2. \<lbrakk>\<langle>c',s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" .
  with \<open>\<langle>while (b) c',s1\<rangle> \<rightarrow>* \<langle>Skip,s2\<rangle>\<close> \<open>\<Gamma>,High \<turnstile> c'\<close>
  show ?case by(auto dest:WhileStepInduct)
qed

lemma CondHighCompositionality:
  assumes "\<Gamma>,High \<turnstile> if (b) c1 else c2"
  shows "nonInterference \<Gamma> (if (b) c1 else c2)"
proof(rule nonInterferenceI)
  fix s1 s2 s1' s2'
  assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>"
    and "\<langle>if (b) c1 else c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
  show "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
  proof -
    from \<open>\<Gamma>,High \<turnstile> if (b) c1 else c2\<close> \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close>
    have "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s1'" by(auto dest:highBodies)
    from \<open>\<Gamma>,High \<turnstile> if (b) c1 else c2\<close> \<open>\<langle>if (b) c1 else c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close>
    have "\<Gamma> \<turnstile> s2 \<approx>\<^sub>L s2'" by(auto dest:highBodies)
    with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> have "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2'" by(auto intro:lowEquivTransitive)
    from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s1'\<close> have "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s1" by(auto intro:lowEquivSymmetric)
    with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2'\<close> show ?thesis by(auto intro:lowEquivTransitive)
  qed
qed

lemma CondLowCompositionality:
  assumes "nonInterference \<Gamma> c1" and "nonInterference \<Gamma> c2" and "\<Gamma> \<turnstile> b : Low"
  shows "nonInterference \<Gamma> (if (b) c1 else c2)"
proof(rule nonInterferenceI)
  fix s1 s2 s1' s2'
  assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>"
    and "\<langle>if (b) c1 else c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
  from \<open>\<Gamma> \<turnstile> b : Low\<close> \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> have "\<lbrakk>b\<rbrakk> s1 = \<lbrakk>b\<rbrakk> s2"
    by(auto intro:interpretLow2)
  from \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close>
  have "\<lbrakk>b\<rbrakk> s1 = Some true \<or> \<lbrakk>b\<rbrakk> s1 = Some false" by(auto dest:Cond_True_or_False)
  thus "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
  proof
    assume "\<lbrakk>b\<rbrakk> s1 = Some true"
    with \<open>\<lbrakk>b\<rbrakk> s1 = \<lbrakk>b\<rbrakk> s2\<close> have "\<lbrakk>b\<rbrakk> s2 = Some true" by(auto intro:CondTrue_reds)
    from \<open>\<lbrakk>b\<rbrakk> s1 = Some true\<close> \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close>
    have "\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>" by(auto intro:CondTrue_reds)
    from \<open>\<lbrakk>b\<rbrakk> s2 = Some true\<close> \<open>\<langle>if (b) c1 else c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close>
    have "\<langle>c1,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>" by(auto intro:CondTrue_reds)
    with \<open>\<langle>c1,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> \<open>nonInterference \<Gamma> c1\<close>
    show ?thesis by(auto simp:nonInterference_def)
  next
    assume "\<lbrakk>b\<rbrakk> s1 = Some false"
    with \<open>\<lbrakk>b\<rbrakk> s1 = \<lbrakk>b\<rbrakk> s2\<close> have "\<lbrakk>b\<rbrakk> s2 = Some false" by(auto intro:CondTrue_reds)
    from \<open>\<lbrakk>b\<rbrakk> s1 = Some false\<close> \<open>\<langle>if (b) c1 else c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close>
    have "\<langle>c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>" by(auto intro:CondFalse_reds)
    from \<open>\<lbrakk>b\<rbrakk> s2 = Some false\<close> \<open>\<langle>if (b) c1 else c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close>
    have "\<langle>c2,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>" by(auto intro:CondFalse_reds)
    with \<open>\<langle>c2,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> \<open>nonInterference \<Gamma> c2\<close>
    show ?thesis by(auto simp:nonInterference_def)
  qed
qed

lemma WhileHighCompositionality:
  assumes "\<Gamma>,High \<turnstile> while (b) c'"
  shows "nonInterference \<Gamma> (while (b) c')"
proof(rule nonInterferenceI)
  fix s1 s2 s1' s2'
  assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>while (b) c',s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>"
    and "\<langle>while (b) c',s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
  show "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
  proof -
    from \<open>\<Gamma>,High \<turnstile> while (b) c'\<close> \<open>\<langle>while (b) c',s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close>
    have "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s1'" by(auto dest:highBodies)
    from \<open>\<Gamma>,High \<turnstile> while (b) c'\<close> \<open>\<langle>while (b) c',s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close>
    have "\<Gamma> \<turnstile> s2 \<approx>\<^sub>L s2'" by(auto dest:highBodies)
    with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> have "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2'" by(auto intro:lowEquivTransitive)
    from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s1'\<close> have "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s1" by(auto intro:lowEquivSymmetric)
    with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2'\<close> show ?thesis by(auto intro:lowEquivTransitive)
  qed
qed

lemma WhileLowCompositionality:
  assumes "nonInterference \<Gamma> c'" and "\<Gamma> \<turnstile> b : Low" and "\<Gamma>,Low \<turnstile> c'"
  shows "nonInterference \<Gamma> (while (b) c')"
proof(rule nonInterferenceI)
  fix s1 s2 s1' s2'
  assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>while (b) c',s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>"
    and "\<langle>while (b) c',s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
  { fix s1 s2 s1'' s2''
    assume "\<langle>c',s1\<rangle> \<rightarrow>* \<langle>Skip,s1''\<rangle>" and "\<langle>c',s2\<rangle> \<rightarrow>* \<langle>Skip,s2''\<rangle>"
      and  "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2"
    with \<open>nonInterference \<Gamma> c'\<close> have "\<Gamma> \<turnstile> s1'' \<approx>\<^sub>L s2''"
      by(auto simp:nonInterference_def)
  }
  hence "\<And>s1 s1'' s2 s2''. \<lbrakk>\<langle>c',s1\<rangle> \<rightarrow>* \<langle>Skip,s1''\<rangle>; \<langle>c',s2\<rangle> \<rightarrow>* \<langle>Skip,s2''\<rangle>;
                             \<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<rbrakk>  \<Longrightarrow>  \<Gamma> \<turnstile> s1'' \<approx>\<^sub>L s2''" by auto
  with \<open>\<langle>while (b) c',s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> \<open>\<langle>while (b) c',s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close>
    \<open>\<Gamma> \<turnstile> b : Low\<close> \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> show "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
    by(auto intro:WhileLowStepInduct)
qed

text \<open>and now: the main theorem:\<close>

theorem secTypeImpliesNonInterference:
  "\<Gamma>,T \<turnstile> c \<Longrightarrow> nonInterference \<Gamma> c"
proof (induct c arbitrary:T rule:com.induct)
  case Skip
  show ?case
  proof(rule nonInterferenceI)
    fix s1 s2 s1' s2'
    assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>Skip,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>" and "\<langle>Skip,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
    from \<open>\<langle>Skip,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> have "s1 = s1'" by(auto dest:Skip_reds)
    from \<open>\<langle>Skip,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close> have "s2 = s2'" by(auto dest:Skip_reds)
    from \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> and \<open>s1 = s1'\<close> and \<open>s2 = s2'\<close>
    show "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'" by simp
  qed
next
  case (LAss V e)
  from \<open>\<Gamma>,T \<turnstile> V:=e\<close>
  have varprem:"(\<Gamma> V = Some High) \<or> (\<Gamma> V = Some Low \<and> \<Gamma> \<turnstile> e : Low \<and> T = Low)"
    by (auto elim:secComTyping.cases)
  show ?case
  proof(rule nonInterferenceI)
    fix s1 s2 s1' s2'
    assume "\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2" and "\<langle>V:=e,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>" and "\<langle>V:=e,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>"
    from \<open>\<langle>V:=e,s1\<rangle> \<rightarrow>* \<langle>Skip,s1'\<rangle>\<close> have "s1' = s1(V:=\<lbrakk>e\<rbrakk> s1)" by(auto intro:LAss_reds)
    from \<open>\<langle>V:=e,s2\<rangle> \<rightarrow>* \<langle>Skip,s2'\<rangle>\<close> have "s2' = s2(V:=\<lbrakk>e\<rbrakk> s2)" by(auto intro:LAss_reds)
    from varprem show "\<Gamma> \<turnstile> s1' \<approx>\<^sub>L s2'"
    proof
      assume "\<Gamma> V = Some High"
      with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> \<open>s1' = s1(V:=\<lbrakk>e\<rbrakk> s1)\<close> \<open>s2' = s2(V:=\<lbrakk>e\<rbrakk> s2)\<close>
      show ?thesis by(auto intro:assignNIhighlemma)
    next
      assume "\<Gamma> V = Some Low \<and> \<Gamma> \<turnstile> e : Low \<and> T = Low"
      with \<open>\<Gamma> \<turnstile> s1 \<approx>\<^sub>L s2\<close> \<open>s1' = s1(V:=\<lbrakk>e\<rbrakk> s1)\<close> \<open>s2' = s2(V:=\<lbrakk>e\<rbrakk> s2)\<close>
      show ?thesis by(auto intro:assignNIlowlemma)
    qed
  qed
next
  case (Seq c1 c2)
  note IH1 = \<open>\<And>T. \<Gamma>,T \<turnstile> c1 \<Longrightarrow> nonInterference \<Gamma> c1\<close>
  note IH2 = \<open>\<And>T. \<Gamma>,T \<turnstile> c2 \<Longrightarrow> nonInterference \<Gamma> c2\<close>
  show ?case
  proof (cases T)
    case High
    with \<open>\<Gamma>,T \<turnstile> c1;;c2\<close> have "\<Gamma>,High \<turnstile> c1" and "\<Gamma>,High \<turnstile> c2"
      by(auto elim:secComTyping.cases)
    from IH1[OF \<open>\<Gamma>,High \<turnstile> c1\<close>] have "nonInterference \<Gamma> c1" .
    moreover
    from IH2[OF \<open>\<Gamma>,High \<turnstile> c2\<close>] have "nonInterference \<Gamma> c2" .
    ultimately show ?thesis by (auto intro:SeqCompositionality)
  next
    case Low
    with \<open>\<Gamma>,T \<turnstile> c1;;c2\<close>
    have "(\<Gamma>,Low \<turnstile> c1 \<and> \<Gamma>,Low \<turnstile> c2) \<or> \<Gamma>,High \<turnstile> c1;;c2"
      by(auto elim:secComTyping.cases)
    thus ?thesis
    proof
      assume "\<Gamma>,Low \<turnstile> c1 \<and> \<Gamma>,Low \<turnstile> c2"
      hence "\<Gamma>,Low \<turnstile> c1" and "\<Gamma>,Low \<turnstile> c2" by simp_all
      from IH1[OF \<open>\<Gamma>,Low \<turnstile> c1\<close>] have "nonInterference \<Gamma> c1" .
      moreover
      from IH2[OF \<open>\<Gamma>,Low \<turnstile> c2\<close>] have "nonInterference \<Gamma> c2" .
      ultimately show ?thesis by(auto intro:SeqCompositionality)
    next
      assume "\<Gamma>,High \<turnstile> c1;;c2"
      hence "\<Gamma>,High \<turnstile> c1" and "\<Gamma>,High \<turnstile> c2" by(auto elim:secComTyping.cases)
      from IH1[OF \<open>\<Gamma>,High \<turnstile> c1\<close>] have "nonInterference \<Gamma> c1" .
      moreover
      from IH2[OF \<open>\<Gamma>,High \<turnstile> c2\<close>] have "nonInterference \<Gamma> c2" .
      ultimately show ?thesis by(auto intro:SeqCompositionality)
    qed
  qed
next
  case (Cond b c1 c2)
  note IH1 = \<open>\<And>T. \<Gamma>,T \<turnstile> c1 \<Longrightarrow> nonInterference \<Gamma> c1\<close>
  note IH2 = \<open>\<And>T. \<Gamma>,T \<turnstile> c2 \<Longrightarrow> nonInterference \<Gamma> c2\<close>
  show ?case
  proof (cases T)
    case High
    with \<open>\<Gamma>,T \<turnstile> if (b) c1 else c2\<close> show ?thesis
      by(auto intro:CondHighCompositionality)
  next
    case Low
    with \<open>\<Gamma>,T \<turnstile> if (b) c1 else c2\<close>
    have "(\<Gamma> \<turnstile> b : Low \<and> \<Gamma>,Low \<turnstile> c1 \<and>\<Gamma>,Low \<turnstile> c2) \<or> \<Gamma>,High \<turnstile> if (b) c1 else c2"
      by(auto elim:secComTyping.cases)
    thus ?thesis
    proof
      assume "\<Gamma> \<turnstile> b : Low \<and> \<Gamma>,Low \<turnstile> c1 \<and> \<Gamma>,Low \<turnstile> c2"
      hence "\<Gamma> \<turnstile> b : Low" and "\<Gamma>,Low \<turnstile> c1" and "\<Gamma>,Low \<turnstile> c2" by simp_all
      from IH1[OF \<open>\<Gamma>,Low \<turnstile> c1\<close>] have "nonInterference \<Gamma> c1" .
      moreover
      from IH2[OF \<open>\<Gamma>,Low \<turnstile> c2\<close>] have "nonInterference \<Gamma> c2" .
      ultimately show ?thesis using \<open>\<Gamma> \<turnstile> b : Low\<close>
        by(auto intro:CondLowCompositionality)
    next
      assume "\<Gamma>,High \<turnstile> if (b) c1 else c2"
      thus ?thesis by(auto intro:CondHighCompositionality)
    qed
  qed
next
  case (While b c')
  note IH = \<open>\<And>T. \<Gamma>,T \<turnstile> c' \<Longrightarrow> nonInterference \<Gamma> c'\<close>
  show ?case
  proof(cases T)
    case High
    with \<open>\<Gamma>,T \<turnstile> while (b) c'\<close> show ?thesis by(auto intro:WhileHighCompositionality)
  next
    case Low
    with \<open>\<Gamma>,T \<turnstile> while (b) c'\<close>
    have "(\<Gamma> \<turnstile> b : Low \<and> \<Gamma>,Low \<turnstile> c') \<or> \<Gamma>,High \<turnstile> while (b) c'"
      by(auto elim:secComTyping.cases)
    thus ?thesis
    proof
      assume "\<Gamma> \<turnstile> b : Low \<and> \<Gamma>,Low \<turnstile> c'"
      hence "\<Gamma> \<turnstile> b : Low" and "\<Gamma>,Low \<turnstile> c'" by simp_all
      moreover
      from IH[OF \<open>\<Gamma>,Low \<turnstile> c'\<close>] have "nonInterference \<Gamma> c'" .
      ultimately show ?thesis by(auto intro:WhileLowCompositionality)
    next
      assume "\<Gamma>,High \<turnstile> while (b) c'"
      thus ?thesis by(auto intro:WhileHighCompositionality)
    qed
  qed
qed

end


theory Syntax
imports
  Complex_Main
  "Ids"
begin
section \<open>Syntax\<close>
text \<open>
  We define the syntax of dL terms, formulas and hybrid programs. As in
  CADE'15, the syntax allows arbitrarily nested differentials. However,
  the semantics of such terms is very surprising (e.g. (x')' is zero in
  every state), so we define predicates dfree and dsafe to describe terms
  with no differentials and no nested differentials, respectively.

  In keeping with the CADE'15 presentation we currently make the simplifying
  assumption that all terms are smooth, and thus division and arbitrary
  exponentiation are absent from the syntax. Several other standard logical
  constructs are implemented as derived forms to reduce the soundness burden.

  The types of formulas and programs are parameterized by three finite types
  ('a, 'b, 'c) used as identifiers for function constants, context constants, and
  everything else, respectively. These type variables are distinct because some
  substitution operations affect one type variable while leaving the others unchanged.
  Because these types will be finite in practice, it is more useful to think of them
  as natural numbers that happen to be represented as types (due to HOL's lack of dependent types).
  The types of terms and ODE systems follow the same approach, but have only two type
  variables because they cannot contain contexts.
\<close>
datatype ('a, 'c) trm =
\<comment> \<open>Real-valued variables given meaning by the state and modified by programs.\<close>
  Var 'c
\<comment> \<open>N.B. This is technically more expressive than true dL since most reals\<close>
\<comment> \<open>can't be written down.\<close>
| Const real
\<comment> \<open>A function (applied to its arguments) consists of an identifier for the function\<close>
\<comment> \<open>and a function \<open>'c \<Rightarrow> ('a, 'c) trm\<close> (where \<open>'c\<close> is a finite type) which specifies one\<close>
\<comment> \<open>argument of the function for each element of type \<open>'c\<close>. To simulate a function with\<close>
\<comment> \<open>less than \<open>'c\<close> arguments, set the remaining arguments to a constant, such as \<open>Const 0\<close>\<close>
| Function 'a "'c \<Rightarrow> ('a, 'c) trm" ("$f")
| Plus "('a, 'c) trm" "('a, 'c) trm"
| Times "('a, 'c) trm" "('a, 'c) trm"
\<comment> \<open>A (real-valued) variable standing for a differential, such as \<open>x'\<close>, given meaning by the state\<close>
\<comment> \<open>and modified by programs.\<close>
| DiffVar 'c ("$''")
\<comment> \<open>The differential of an arbitrary term \<open>(\<theta>)'\<close>\<close>
| Differential "('a, 'c) trm"

datatype('a, 'c) ODE =
\<comment> \<open>Variable standing for an ODE system, given meaning by the interpretation\<close>
OVar 'c
\<comment> \<open>Singleton ODE defining \<open>x' = \<theta>\<close>, where \<open>\<theta>\<close> may or may not contain \<open>x\<close>\<close>
\<comment> \<open>(but must not contain differentials)\<close>
| OSing 'c "('a, 'c) trm"
\<comment> \<open>The product \<open>OProd ODE1 ODE2\<close> composes two ODE systems in parallel, e.g.\<close>
\<comment> \<open>\<open>OProd (x' = y) (y' = -x)\<close> is the system \<open>{x' = y, y' = -x}\<close>\<close>
| OProd "('a, 'c) ODE" "('a, 'c) ODE"

datatype ('a, 'b, 'c) hp =
\<comment> \<open>Variables standing for programs, given meaning by the interpretation.\<close>
  Pvar 'c                           ("$\<alpha>")
\<comment> \<open>Assignment to a real-valued variable \<open>x := \<theta>\<close>\<close>
| Assign 'c "('a, 'c) trm"                (infixr ":=" 10)
\<comment> \<open>Assignment to a differential variable\<close>
| DiffAssign 'c "('a, 'c) trm"
\<comment> \<open>Program \<open>?\<phi>\<close> succeeds iff \<open>\<phi>\<close> holds in current state.\<close>
| Test "('a, 'b, 'c) formula"                 ("?")
\<comment> \<open>An ODE program is an ODE system with some evolution domain.\<close>
| EvolveODE "('a, 'c) ODE" "('a, 'b, 'c) formula"
\<comment> \<open>Non-deterministic choice between two programs \<open>a\<close> and \<open>b\<close>\<close>
| Choice "('a, 'b, 'c) hp" "('a, 'b, 'c) hp"            (infixl "\<union>\<union>" 10)
\<comment> \<open>Sequential composition of two programs \<open>a\<close> and \<open>b\<close>\<close>
| Sequence "('a, 'b, 'c) hp"  "('a, 'b, 'c) hp"         (infixr ";;" 8)
\<comment> \<open>Nondeterministic repetition of a program \<open>a\<close>, zero or more times.\<close>
| Loop "('a, 'b, 'c) hp"                      ("_**")

and ('a, 'b, 'c) formula =
  Geq "('a, 'c) trm" "('a, 'c) trm"
| Prop 'c "'c \<Rightarrow> ('a, 'c) trm"      ("$\<phi>")
| Not "('a, 'b, 'c) formula"            ("!")
| And "('a, 'b, 'c) formula" "('a, 'b, 'c) formula"    (infixl "&&" 8)
| Exists 'c "('a, 'b, 'c) formula"
\<comment> \<open>\<open>\<langle>\<alpha>\<rangle>\<phi>\<close> iff exists run of \<open>\<alpha>\<close> where \<open>\<phi>\<close> is true in end state\<close>
| Diamond "('a, 'b, 'c) hp" "('a, 'b, 'c) formula"         ("(\<langle> _ \<rangle> _)" 10)
\<comment> \<open>Contexts \<open>C\<close> are symbols standing for functions from (the semantics of) formulas to\<close>
\<comment> \<open>(the semantics of) formulas, thus \<open>C(\<phi>)\<close> is another formula. While not necessary\<close>
\<comment> \<open>in terms of expressiveness, contexts allow for more efficient reasoning principles.\<close>
| InContext 'b "('a, 'b, 'c) formula"

\<comment> \<open>Derived forms\<close>
definition Or :: "('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula" (infixl "||" 7)
where "Or P Q = Not (And (Not P) (Not Q))"

definition Implies :: "('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula" (infixr "\<rightarrow>" 10)
where "Implies P Q = Or Q (Not P)"

definition Equiv :: "('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula" (infixl "\<leftrightarrow>" 10)
where "Equiv P Q = Or (And P Q) (And (Not P) (Not Q))"

definition Forall :: "'c \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula"
where "Forall x P = Not (Exists x (Not P))"

definition Equals :: "('a, 'c) trm \<Rightarrow> ('a, 'c) trm \<Rightarrow> ('a, 'b, 'c) formula"
where "Equals \<theta> \<theta>' = ((Geq \<theta> \<theta>') && (Geq \<theta>' \<theta>))"

definition Greater :: "('a, 'c) trm \<Rightarrow> ('a, 'c) trm \<Rightarrow> ('a, 'b, 'c) formula"
where "Greater \<theta> \<theta>' = ((Geq \<theta> \<theta>') && (Not (Geq \<theta>' \<theta>)))"

definition Box :: "('a, 'b, 'c) hp \<Rightarrow> ('a, 'b, 'c) formula \<Rightarrow> ('a, 'b, 'c) formula" ("([[_]]_)" 10)
where "Box \<alpha> P = Not (Diamond \<alpha> (Not P))"

definition TT ::"('a,'b,'c) formula"
where "TT = Geq (Const 0) (Const 0)"

definition FF ::"('a,'b,'c) formula"
where "FF = Geq (Const 0) (Const 1)"

type_synonym ('a,'b,'c) sequent = "('a,'b,'c) formula list * ('a,'b,'c) formula list"
\<comment> \<open>Rule: assumptions, then conclusion\<close>
type_synonym ('a,'b,'c) rule = "('a,'b,'c) sequent list * ('a,'b,'c) sequent"

\<comment> \<open>silliness to enable proving disequality lemmas\<close>
primrec sizeF::"('sf,'sc, 'sz) formula \<Rightarrow> nat"
  and   sizeP::"('sf,'sc, 'sz) hp \<Rightarrow> nat"
where
  "sizeP (Pvar a) = 1"
| "sizeP (Assign x \<theta>) = 1"
| "sizeP (DiffAssign x \<theta>) = 1"
| "sizeP (Test \<phi>) = Suc (sizeF \<phi>)"
| "sizeP (EvolveODE ODE \<phi>) = Suc (sizeF \<phi>)"
| "sizeP (Choice \<alpha> \<beta>) = Suc (sizeP \<alpha> + sizeP \<beta>)"
| "sizeP (Sequence \<alpha> \<beta>) = Suc (sizeP \<alpha> + sizeP \<beta>)"
| "sizeP (Loop \<alpha>) = Suc (sizeP \<alpha>)"
| "sizeF (Geq p q) = 1"
| "sizeF (Prop p args) = 1"
| "sizeF (Not p) = Suc (sizeF p)"
| "sizeF (And p q) = sizeF p + sizeF q"
| "sizeF (Exists x p) = Suc (sizeF p)"
| "sizeF (Diamond p q) = Suc (sizeP p + sizeF q)"
| "sizeF (InContext C \<phi>) = Suc (sizeF \<phi>)"

lemma sizeF_diseq:"sizeF p \<noteq> sizeF q \<Longrightarrow> p \<noteq> q" by auto

named_theorems "expr_diseq" "Structural disequality rules for expressions"
lemma [expr_diseq]:"p \<noteq> And p q" by(induction p, auto)
lemma [expr_diseq]:"q \<noteq> And p q" by(induction q, auto)
lemma [expr_diseq]:"p \<noteq> Not p" by(induction p, auto)
lemma [expr_diseq]:"p \<noteq> Or p q" by(rule sizeF_diseq, auto simp add: Or_def)
lemma [expr_diseq]:"q \<noteq> Or p q" by(rule sizeF_diseq, auto simp add: Or_def)
lemma [expr_diseq]:"p \<noteq> Implies p q" by(rule sizeF_diseq, auto simp add: Implies_def Or_def)
lemma [expr_diseq]:"q \<noteq> Implies p q" by(rule sizeF_diseq, auto simp add: Implies_def Or_def)
lemma [expr_diseq]:"p \<noteq> Equiv p q" by(rule sizeF_diseq, auto simp add: Equiv_def Or_def)
lemma [expr_diseq]:"q \<noteq> Equiv p q" by(rule sizeF_diseq, auto simp add: Equiv_def Or_def)
lemma [expr_diseq]:"p \<noteq> Exists x p" by(induction p, auto)
lemma [expr_diseq]:"p \<noteq> Diamond a p" by(induction p, auto)
lemma [expr_diseq]:"p \<noteq> InContext C p" by(induction p, auto)

\<comment> \<open>A predicational is like a context with no argument, i.e. a variable standing for a\<close>
\<comment> \<open>state-dependent formula, given meaning by the interpretation. This differs from a predicate\<close>
\<comment> \<open>because predicates depend only on their arguments (which might then indirectly depend on the state).\<close>
\<comment> \<open>We encode a predicational as a context applied to a formula whose truth value is constant with\<close>
\<comment> \<open>respect to the state (specifically, always true)\<close>
fun Predicational :: "'b \<Rightarrow> ('a, 'b, 'c) formula" ("Pc")
where "Predicational P = InContext P (Geq (Const 0) (Const 0))"

\<comment> \<open>Abbreviations for common syntactic constructs in order to make axiom definitions, etc. more\<close>
\<comment> \<open>readable.\<close>
context ids begin
\<comment> \<open>"Empty" function argument tuple, encoded as tuple where all arguments assume a constant value.\<close>
definition empty::" 'b \<Rightarrow> ('a, 'b) trm"
where "empty \<equiv> \<lambda>i.(Const 0)"

\<comment> \<open>Function argument tuple with (effectively) one argument, where all others have a constant value.\<close>
fun singleton :: "('a, 'sz) trm \<Rightarrow> ('sz \<Rightarrow> ('a, 'sz) trm)"
where "singleton t i = (if i = vid1 then t else (Const 0))"

lemma expand_singleton:"singleton t = (\<lambda>i. (if i = vid1 then t else (Const 0)))"
  by auto

\<comment> \<open>Function applied to one argument\<close>
definition f1::"'sf \<Rightarrow> 'sz \<Rightarrow> ('sf,'sz) trm"
where "f1 f x = Function f (singleton (Var x))"

\<comment> \<open>Function applied to zero arguments (simulates a constant symbol given meaning by the interpretation)\<close>
definition f0::"'sf \<Rightarrow> ('sf,'sz) trm"
where "f0 f = Function f empty"

\<comment> \<open>Predicate applied to one argument\<close>
definition p1::"'sz \<Rightarrow> 'sz \<Rightarrow> ('sf, 'sc, 'sz) formula"
where "p1 p x = Prop p (singleton (Var x))"

\<comment> \<open>Predicational\<close>
definition P::"'sc \<Rightarrow> ('sf, 'sc, 'sz) formula"
where "P p = Predicational p"
end

subsection \<open>Well-Formedness predicates\<close>
inductive dfree :: "('a, 'c) trm \<Rightarrow> bool"
where
  dfree_Var: "dfree (Var i)"
| dfree_Const: "dfree (Const r)"
| dfree_Fun: "(\<And>i. dfree (args i)) \<Longrightarrow> dfree (Function i args)"
| dfree_Plus: "dfree \<theta>\<^sub>1 \<Longrightarrow> dfree \<theta>\<^sub>2 \<Longrightarrow> dfree (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dfree_Times: "dfree \<theta>\<^sub>1 \<Longrightarrow> dfree \<theta>\<^sub>2 \<Longrightarrow> dfree (Times \<theta>\<^sub>1 \<theta>\<^sub>2)"

inductive dsafe :: "('a, 'c) trm \<Rightarrow> bool"
where
  dsafe_Var: "dsafe (Var i)"
| dsafe_Const: "dsafe (Const r)"
| dsafe_Fun: "(\<And>i. dsafe (args i)) \<Longrightarrow> dsafe (Function i args)"
| dsafe_Plus: "dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Times: "dsafe \<theta>\<^sub>1 \<Longrightarrow> dsafe \<theta>\<^sub>2 \<Longrightarrow> dsafe (Times \<theta>\<^sub>1 \<theta>\<^sub>2)"
| dsafe_Diff: "dfree \<theta> \<Longrightarrow> dsafe (Differential \<theta>)"
| dsafe_DiffVar: "dsafe ($' i)"

\<comment> \<open>Explictly-written variables that are bound by the ODE. Needed to compute whether\<close>
\<comment> \<open>ODE's are valid (e.g. whether they bind the same variable twice)\<close>
fun ODE_dom::"('a, 'c) ODE \<Rightarrow> 'c set"
where
  "ODE_dom (OVar c) =  {}"
| "ODE_dom (OSing x \<theta>) = {x}"
| "ODE_dom (OProd ODE1 ODE2) = ODE_dom ODE1 \<union> ODE_dom ODE2"

inductive osafe:: "('a, 'c) ODE \<Rightarrow> bool"
where
  osafe_Var:"osafe (OVar c)"
| osafe_Sing:"dfree \<theta> \<Longrightarrow> osafe (OSing x \<theta>)"
| osafe_Prod:"osafe ODE1 \<Longrightarrow> osafe ODE2 \<Longrightarrow> ODE_dom ODE1 \<inter> ODE_dom ODE2 = {} \<Longrightarrow> osafe (OProd ODE1 ODE2)"

\<comment> \<open>Programs/formulas without any differential terms. This definition not currently used but may\<close>
\<comment> \<open>be useful in the future.\<close>
inductive hpfree:: "('a, 'b, 'c) hp \<Rightarrow> bool"
  and     ffree::  "('a, 'b, 'c) formula \<Rightarrow> bool"
where
  "hpfree (Pvar x)"
| "dfree e \<Longrightarrow> hpfree (Assign x e)"
\<comment> \<open>Differential programs allowed but not differential terms\<close>
| "dfree e \<Longrightarrow> hpfree (DiffAssign x e)"
| "ffree P \<Longrightarrow> hpfree (Test P)"
\<comment> \<open>Differential programs allowed but not differential terms\<close>
| "osafe ODE \<Longrightarrow> ffree P \<Longrightarrow> hpfree (EvolveODE ODE P)"
| "hpfree a \<Longrightarrow> hpfree b \<Longrightarrow> hpfree (Choice a b )"
| "hpfree a \<Longrightarrow> hpfree b \<Longrightarrow> hpfree (Sequence a b)"
| "hpfree a \<Longrightarrow> hpfree (Loop a)"
| "ffree f \<Longrightarrow> ffree (InContext C f)"
| "(\<And>arg. arg \<in> range args \<Longrightarrow> dfree arg) \<Longrightarrow> ffree (Prop p args)"
| "ffree p \<Longrightarrow> ffree (Not p)"
| "ffree p \<Longrightarrow> ffree q \<Longrightarrow> ffree (And p q)"
| "ffree p \<Longrightarrow> ffree (Exists x p)"
| "hpfree a \<Longrightarrow> ffree p \<Longrightarrow> ffree (Diamond a p)"
| "ffree (Predicational P)"
| "dfree t1 \<Longrightarrow> dfree t2 \<Longrightarrow> ffree (Geq t1 t2)"

inductive hpsafe:: "('a, 'b, 'c) hp \<Rightarrow> bool"
  and     fsafe::  "('a, 'b, 'c) formula \<Rightarrow> bool"
where
   hpsafe_Pvar:"hpsafe (Pvar x)"
 | hpsafe_Assign:"dsafe e \<Longrightarrow> hpsafe (Assign x e)"
 | hpsafe_DiffAssign:"dsafe e \<Longrightarrow> hpsafe (DiffAssign x e)"
 | hpsafe_Test:"fsafe P \<Longrightarrow> hpsafe (Test P)"
 | hpsafe_Evolve:"osafe ODE \<Longrightarrow> fsafe P \<Longrightarrow> hpsafe (EvolveODE ODE P)"
 | hpsafe_Choice:"hpsafe a \<Longrightarrow> hpsafe b \<Longrightarrow> hpsafe (Choice a b )"
 | hpsafe_Sequence:"hpsafe a \<Longrightarrow> hpsafe b \<Longrightarrow> hpsafe (Sequence a b)"
 | hpsafe_Loop:"hpsafe a \<Longrightarrow> hpsafe (Loop a)"

 | fsafe_Geq:"dsafe t1 \<Longrightarrow> dsafe t2 \<Longrightarrow> fsafe (Geq t1 t2)"
 | fsafe_Prop:"(\<And>i. dsafe (args i)) \<Longrightarrow> fsafe (Prop p args)"
 | fsafe_Not:"fsafe p \<Longrightarrow> fsafe (Not p)"
 | fsafe_And:"fsafe p \<Longrightarrow> fsafe q \<Longrightarrow> fsafe (And p q)"
 | fsafe_Exists:"fsafe p \<Longrightarrow> fsafe (Exists x p)"
 | fsafe_Diamond:"hpsafe a \<Longrightarrow> fsafe p \<Longrightarrow> fsafe (Diamond a p)"
 | fsafe_InContext:"fsafe f \<Longrightarrow> fsafe (InContext C f)"

\<comment> \<open>Auto-generated simplifier rules for safety predicates\<close>
inductive_simps
      dfree_Plus_simps[simp]: "dfree (Plus a b)"
  and dfree_Times_simps[simp]: "dfree (Times a b)"
  and dfree_Var_simps[simp]: "dfree (Var x)"
  and dfree_DiffVar_simps[simp]: "dfree (DiffVar x)"
  and dfree_Differential_simps[simp]: "dfree (Differential x)"
  and dfree_Fun_simps[simp]: "dfree (Function i args)"
  and dfree_Const_simps[simp]: "dfree (Const r)"

inductive_simps
      dsafe_Plus_simps[simp]: "dsafe (Plus a b)"
  and dsafe_Times_simps[simp]: "dsafe (Times a b)"
  and dsafe_Var_simps[simp]: "dsafe (Var x)"
  and dsafe_DiffVar_simps[simp]: "dsafe (DiffVar x)"
  and dsafe_Fun_simps[simp]: "dsafe (Function i args)"
  and dsafe_Diff_simps[simp]: "dsafe (Differential a)"
  and dsafe_Const_simps[simp]: "dsafe (Const r)"

inductive_simps
      osafe_OVar_simps[simp]:"osafe (OVar c)"
  and osafe_OSing_simps[simp]:"osafe (OSing x \<theta>)"
  and osafe_OProd_simps[simp]:"osafe (OProd ODE1 ODE2)"

inductive_simps
      hpsafe_Pvar_simps[simp]: "hpsafe (Pvar a)"
  and hpsafe_Sequence_simps[simp]: "hpsafe (a ;; b)"
  and hpsafe_Loop_simps[simp]: "hpsafe (a**)"
  and hpsafe_ODE_simps[simp]: "hpsafe (EvolveODE ODE p)"
  and hpsafe_Choice_simps[simp]: "hpsafe (a \<union>\<union> b)"
  and hpsafe_Assign_simps[simp]: "hpsafe (Assign x e)"
  and hpsafe_DiffAssign_simps[simp]: "hpsafe (DiffAssign x e)"
  and hpsafe_Test_simps[simp]: "hpsafe (? p)"

  and fsafe_Geq_simps[simp]: "fsafe (Geq t1 t2)"
  and fsafe_Prop_simps[simp]: "fsafe (Prop p args)"
  and fsafe_Not_simps[simp]: "fsafe (Not p)"
  and fsafe_And_simps[simp]: "fsafe (And p q)"
  and fsafe_Exists_simps[simp]: "fsafe (Exists x p)"
  and fsafe_Diamond_simps[simp]: "fsafe (Diamond a p)"
  and fsafe_Context_simps[simp]: "fsafe (InContext C p)"

definition Ssafe::"('sf,'sc,'sz) sequent \<Rightarrow> bool"
where "Ssafe S \<longleftrightarrow>((\<forall>i. i \<ge> 0 \<longrightarrow> i < length (fst S) \<longrightarrow> fsafe (nth (fst S) i))
                 \<and>(\<forall>i. i \<ge> 0 \<longrightarrow> i < length (snd S) \<longrightarrow> fsafe (nth (snd S) i)))"

definition Rsafe::"('sf,'sc,'sz) rule \<Rightarrow> bool"
where "Rsafe R \<longleftrightarrow> ((\<forall>i. i \<ge> 0 \<longrightarrow> i < length (fst R) \<longrightarrow> Ssafe (nth (fst R) i))
                    \<and> Ssafe (snd R))"

\<comment> \<open>Basic reasoning principles about syntactic constructs, including inductive principles\<close>
lemma dfree_is_dsafe: "dfree \<theta> \<Longrightarrow> dsafe \<theta>"
  by (induction rule: dfree.induct) (auto intro: dsafe.intros)

lemma hp_induct [case_names Var Assign DiffAssign Test Evolve Choice Compose Star]:
   "(\<And>x. P ($\<alpha> x)) \<Longrightarrow>
    (\<And>x1 x2. P (x1 := x2)) \<Longrightarrow>
    (\<And>x1 x2. P (DiffAssign x1 x2)) \<Longrightarrow>
    (\<And>x. P (? x)) \<Longrightarrow>
    (\<And>x1 x2. P (EvolveODE x1 x2)) \<Longrightarrow>
    (\<And>x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P (x1 \<union>\<union> x2)) \<Longrightarrow>
    (\<And>x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P (x1 ;; x2)) \<Longrightarrow>
    (\<And>x. P x \<Longrightarrow> P x**) \<Longrightarrow>
     P hp"
  by(induction rule: hp.induct) (auto)

lemma fml_induct:
  "(\<And>t1 t2. P (Geq t1 t2))
  \<Longrightarrow> (\<And>p args. P (Prop p args))
  \<Longrightarrow> (\<And>p. P p \<Longrightarrow> P (Not p))
  \<Longrightarrow> (\<And>p q. P p \<Longrightarrow> P q \<Longrightarrow> P (And p q))
  \<Longrightarrow> (\<And>x p. P p \<Longrightarrow> P (Exists x p))
  \<Longrightarrow> (\<And>a p. P p \<Longrightarrow> P (Diamond a p))
  \<Longrightarrow> (\<And>C p. P p \<Longrightarrow> P (InContext C p))
  \<Longrightarrow> P \<phi>"
  by (induction rule: formula.induct) (auto)

context ids begin
lemma proj_sing1:"(singleton \<theta> vid1) = \<theta>"
  by (auto)

lemma proj_sing2:"vid1 \<noteq> y  \<Longrightarrow> (singleton \<theta> y) = (Const 0)"
  by (auto)
end

end


theory ex08_tmpl
imports
  "~~/src/HOL/IMP/Sec_Typing"
  "~~/src/HOL/IMP/Com"
  "~~/src/HOL/IMP/Def_Init_Exp"
  "~~/src/HOL/IMP/Def_Init"
  "~~/src/HOL/IMP/Vars"
begin

subsection {* Ex 08.1: Security type system: bottom-up with subsumption *}

inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>' _ : _)" [0,0] 50) where
Skip2':
  "\<turnstile>' SKIP : l" |
Assign2':
  "sec x \<ge> sec a \<Longrightarrow> \<turnstile>' x ::= a : sec x" |
Semi2':
  "\<lbrakk> \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk> \<Longrightarrow> \<turnstile>' c\<^sub>1 ;; c\<^sub>2 : l" |
If2':
  "\<lbrakk> sec b \<le> min l\<^sub>1 l\<^sub>2;  \<turnstile>' c\<^sub>1 : l\<^sub>1;  \<turnstile>' c\<^sub>2 : l\<^sub>2 \<rbrakk>
  \<Longrightarrow> \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2 : min l\<^sub>1 l\<^sub>2" |
While2':
  "\<lbrakk> sec b \<le> l;  \<turnstile>' c : l \<rbrakk> \<Longrightarrow> \<turnstile>' WHILE b DO c : l"

lemma "\<turnstile> c : l \<Longrightarrow> \<turnstile>' c : l"
oops

lemma "\<turnstile>' c : l \<Longrightarrow> \<exists>l' \<ge> l. \<turnstile> c : l'"
oops

section {* Ex 08.2: Initialization-Sensitive Small Step Semantics *}

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "aval a s = Some i \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := Some i))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s = Some True \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "bval b s = Some False \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

inductive
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool"  (infix "\<rightarrow>*" 55)  where
refl:  "cs \<rightarrow>* cs" |
step:  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<rightarrow>* cs'' \<Longrightarrow> cs \<rightarrow>* cs''"

lemmas small_steps_induct = small_steps.induct[split_format(complete)]

subsection "Definite Initialization Analysis"

fun AA :: "com \<Rightarrow> vname set" where
"AA c = undefined"   (* provide a suitable definition *)

fun D :: "vname set \<Rightarrow> com \<Rightarrow> bool" where
"D A c = undefined"   (* provide a suitable definition *)

subsection "Soundness wrt Small Steps"

theorem progress:
"D (dom s) c \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists> cs'. (c,s) \<rightarrow> cs'"
oops

lemma D_incr: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> dom s \<union> AA c \<subseteq> dom s' \<union> AA c'"
oops

lemma D_mono: "A \<subseteq> A' \<Longrightarrow> D A c \<Longrightarrow> D A' c"
oops

theorem D_preservation:
"(c,s) \<rightarrow> (c',s') \<Longrightarrow> D (dom s) c \<Longrightarrow> D (dom s') c'"
oops

theorem D_sound:
"(c,s) \<rightarrow>* (c',s') \<Longrightarrow> D (dom s) c \<Longrightarrow> c' \<noteq> SKIP
 \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
oops

end


(*  Title:      FOLP/ex/Intro.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Derives some inference rules, illustrating the use of definitions.
*)

section {* Examples for the manual ``Introduction to Isabelle'' *}

theory Intro
imports FOLP
begin

subsubsection {* Some simple backward proofs *}

schematic_lemma mythm: "?p : P|P --> P"
apply (rule impI)
apply (rule disjE)
prefer 3 apply (assumption)
prefer 2 apply (assumption)
apply assumption
done

schematic_lemma "?p : (P & Q) | R --> (P | R)"
apply (rule impI)
apply (erule disjE)
apply (drule conjunct1)
apply (rule disjI1)
apply (rule_tac [2] disjI2)
apply assumption+
done

(*Correct version, delaying use of "spec" until last*)
schematic_lemma "?p : (ALL x y. P(x,y)) --> (ALL z w. P(w,z))"
apply (rule impI)
apply (rule allI)
apply (rule allI)
apply (drule spec)
apply (drule spec)
apply assumption
done

subsubsection {* Demonstration of @{text "fast"} *}

schematic_lemma "?p : (EX y. ALL x. J(y,x) <-> ~J(x,x))
        -->  ~ (ALL x. EX y. ALL z. J(z,y) <-> ~ J(z,x))"
apply (tactic {* fast_tac @{context} FOLP_cs 1 *})
done

schematic_lemma "?p : ALL x. P(x,f(x)) <->
        (EX y. (ALL z. P(z,y) --> P(z,f(x))) & P(x,y))"
apply (tactic {* fast_tac @{context} FOLP_cs 1 *})
done

subsubsection {* Derivation of conjunction elimination rule *}

schematic_lemma
  assumes major: "p : P&Q"
    and minor: "!!x y. [| x : P; y : Q |] ==> f(x, y) : R"
  shows "?p : R"
apply (rule minor)
apply (rule major [THEN conjunct1])
apply (rule major [THEN conjunct2])
done

subsection {* Derived rules involving definitions *}

text {* Derivation of negation introduction *}

schematic_lemma
  assumes "!!x. x : P ==> f(x) : False"
  shows "?p : ~ P"
apply (unfold not_def)
apply (rule impI)
apply (rule assms)
apply assumption
done

schematic_lemma
  assumes major: "p : ~P"
    and minor: "q : P"
  shows "?p : R"
apply (rule FalseE)
apply (rule mp)
apply (rule major [unfolded not_def])
apply (rule minor)
done

text {* Alternative proof of the result above *}
schematic_lemma
  assumes major: "p : ~P"
    and minor: "q : P"
  shows "?p : R"
apply (rule minor [THEN major [unfolded not_def, THEN mp, THEN FalseE]])
done

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

subsection \<open> AMV verification \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
verification components.\<close>

theory AMV_Example
  imports
    "../HS_VC_Spartan"
    Triangle.Angles

begin

definition "no_modfs X i \<equiv> \<forall>k. (\<lambda>s. s$i = k) \<le> |X] (\<lambda>s. s$i = k)"

lemma no_modfs_inv:
  "no_modfs X i \<Longrightarrow> (\<lambda>s. Q (s$i)) \<le> |X] (\<lambda>s. Q (s$i))"
  unfolding fbox_def no_modfs_def by (clarsimp simp: le_fun_def)

subsubsection \<open> Type of variables \<close>

(* Continuous Variables
  AMV's position vector: (x, y)
  AMV's velocity vector: (vx, vy)
  AMV's acceleration vector: (ax, ay)
  angle of AMV's velocity vector with horizontal: phi \<in> [-\<pi>,\<pi>]
  speed of AMV's: speed
  time: t
  [Therefore:
    s^2 = vx^2 + vy^2
    (vx, vy) = (speed * cos phi, speed * sgn phi * sin phi)  *)
abbreviation "amv_cstrs \<equiv> {''x'', ''y'', ''vx'', ''vy'', ''ax'', ''ay'',
  ''phi'', ''speed'', ''t''}"

(* Discrete Variables
  Speed Set Point: sSP
  Heading Set Point: hSP (radians)
  Longitudinal Acceleration Force: fl (colinear with velocity vector)
  Radial Acceleration Force: fr (perpendicular to fl)
  AMV's mode: mode
    operator control          - OCM
    main operating mode       - MOM
    high caution mode         - HCM
    collision avoidance mode  - CAM *)
abbreviation "amv_dstrs \<equiv> {''sSP'', ''hSP'', ''fl'', ''fr'', ''mode''}"

(* all variables *)
abbreviation "amv_strs \<equiv> {''x'', ''y'', ''vx'', ''vy'', ''ax'', ''ay'',
  ''phi'', ''speed'', ''t'', ''sSP'', ''hSP'', ''fl'', ''fr'', ''mode''}"

(* type of variables *)
typedef AMV = amv_strs
  morphisms to_str to_var
  by blast

notation to_var ("\<downharpoonright>\<^sub>V")

abbreviation "amv_terms \<equiv> {\<downharpoonright>\<^sub>V''x'', \<downharpoonright>\<^sub>V''y'', \<downharpoonright>\<^sub>V''vx'', \<downharpoonright>\<^sub>V''vy'', \<downharpoonright>\<^sub>V''ax'', \<downharpoonright>\<^sub>V''ay'',
  \<downharpoonright>\<^sub>V''phi'', \<downharpoonright>\<^sub>V''speed'', \<downharpoonright>\<^sub>V''t'', \<downharpoonright>\<^sub>V''sSP'', \<downharpoonright>\<^sub>V''hSP'', \<downharpoonright>\<^sub>V''fl'', \<downharpoonright>\<^sub>V''fr'', \<downharpoonright>\<^sub>V''mode''}"

lemma number_of_program_vars: "CARD(AMV) = 14"
  using type_definition.card type_definition_AMV by fastforce

instance AMV::finite
  apply(standard, subst bij_betw_finite[of to_str UNIV amv_strs])
   apply(rule bij_betwI')
     apply (simp add: to_str_inject)
  using to_str apply blast
   apply (metis to_var_inverse UNIV_I)
  by simp

abbreviation val_AMV :: "real^AMV \<Rightarrow> string \<Rightarrow> real" (infixl "\<restriction>\<^sub>V" 90)
  where "s\<restriction>\<^sub>Vstring \<equiv> s $ (to_var string)"

lemma AMV_univ: "(UNIV::AMV set) = amv_terms"
  by auto (metis AMV.to_str AMV.to_str_inverse insertE singletonD)

lemma AMV_exhaust: "x = \<downharpoonright>\<^sub>V''x'' \<or> x = \<downharpoonright>\<^sub>V''y'' \<or> x = \<downharpoonright>\<^sub>V''vx'' \<or> x = \<downharpoonright>\<^sub>V''vy''
  \<or> x = \<downharpoonright>\<^sub>V''ax'' \<or> x = \<downharpoonright>\<^sub>V''ay'' \<or> x = \<downharpoonright>\<^sub>V''phi'' \<or> x = \<downharpoonright>\<^sub>V''speed''
  \<or> x = \<downharpoonright>\<^sub>V''t'' \<or> x=\<downharpoonright>\<^sub>V''sSP'' \<or> x=\<downharpoonright>\<^sub>V''hSP'' \<or> x=\<downharpoonright>\<^sub>V''fl'' \<or> x=\<downharpoonright>\<^sub>V''fr'' \<or> x=\<downharpoonright>\<^sub>V''mode''"
  using AMV_univ by auto

lemma AMV_sum:
  fixes f :: "AMV \<Rightarrow> ('a::banach)"
  shows "(\<Sum>i\<in>UNIV. f i) = f (\<downharpoonright>\<^sub>V''x'') + f (\<downharpoonright>\<^sub>V''y'') + f (\<downharpoonright>\<^sub>V''vx'') + f (\<downharpoonright>\<^sub>V''vy'')
  + f (\<downharpoonright>\<^sub>V''ax'') + f (\<downharpoonright>\<^sub>V''ay'') + f (\<downharpoonright>\<^sub>V''phi'') + f (\<downharpoonright>\<^sub>V''speed'') + f (\<downharpoonright>\<^sub>V''t'')
  + f (\<downharpoonright>\<^sub>V''sSP'') + f (\<downharpoonright>\<^sub>V''hSP'') + f (\<downharpoonright>\<^sub>V''fl'') + f (\<downharpoonright>\<^sub>V''fr'') + f (\<downharpoonright>\<^sub>V''mode'')"
  unfolding AMV_univ by (simp add: to_var_inject)

lemma AMV_induct: "P (\<downharpoonright>\<^sub>V''x'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''y'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''vx'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''vy'')
  \<Longrightarrow> P (\<downharpoonright>\<^sub>V''ax'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''ay'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''phi'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''speed'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''t'')
  \<Longrightarrow> P (\<downharpoonright>\<^sub>V''sSP'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''hSP'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''fl'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''fr'') \<Longrightarrow> P (\<downharpoonright>\<^sub>V''mode'')
  \<Longrightarrow> \<forall>i. P i"
  using AMV_exhaust by metis

lemma AMV_eq:
  "(s1 = s2) \<longleftrightarrow> (s1\<restriction>\<^sub>V''x'' = s2\<restriction>\<^sub>V''x'' \<and> s1\<restriction>\<^sub>V''y'' = s2\<restriction>\<^sub>V''y'' \<and> s1\<restriction>\<^sub>V''vx'' = s2\<restriction>\<^sub>V''vx'' \<and>
  s1\<restriction>\<^sub>V''vy'' = s2\<restriction>\<^sub>V''vy'' \<and> s1\<restriction>\<^sub>V''ax'' = s2\<restriction>\<^sub>V''ax'' \<and> s1\<restriction>\<^sub>V''ay'' = s2\<restriction>\<^sub>V''ay'' \<and>
  s1\<restriction>\<^sub>V''phi'' = s2\<restriction>\<^sub>V''phi'' \<and> s1\<restriction>\<^sub>V''speed'' = s2\<restriction>\<^sub>V''speed'' \<and> s1\<restriction>\<^sub>V''t'' = s2\<restriction>\<^sub>V''t'' \<and>
  s1\<restriction>\<^sub>V''sSP'' = s2\<restriction>\<^sub>V''sSP'' \<and> s1\<restriction>\<^sub>V''hSP'' = s2\<restriction>\<^sub>V''hSP'' \<and>
  s1\<restriction>\<^sub>V''fl'' = s2\<restriction>\<^sub>V''fl'' \<and> s1\<restriction>\<^sub>V''fr'' = s2\<restriction>\<^sub>V''fr'' \<and> s1\<restriction>\<^sub>V''mode'' = s2\<restriction>\<^sub>V''mode'')"
  apply(clarsimp simp: vec_eq_iff, rule iffI, force)
  by (rule AMV_induct, auto)

subsubsection \<open> Formalisation of continuous dynamics \<close>

(* abbreviation "\<omega> \<equiv> U(arccos((v + a) \<bullet> v / (\<parallel>v + a\<parallel> * \<parallel>v\<parallel>)) \<triangleleft> \<not> \<parallel>v\<parallel> = 0 \<triangleright> 0)" *)
abbreviation pos :: "real^AMV \<Rightarrow> real^2"
  where "pos s \<equiv> (\<chi> i. if i=1 then s\<restriction>\<^sub>V''x'' else s\<restriction>\<^sub>V''y'')"

abbreviation vel :: "real^AMV \<Rightarrow> real^2"
  where "vel s \<equiv> (\<chi> i. if i=1 then s\<restriction>\<^sub>V''vx'' else s\<restriction>\<^sub>V''vy'')"

abbreviation acc :: "real^AMV \<Rightarrow> real^2"
  where "acc s \<equiv> (\<chi> i. if i=1 then s\<restriction>\<^sub>V''ax'' else s\<restriction>\<^sub>V''ay'')"

abbreviation "omega s \<equiv> (
  if \<parallel>vel s\<parallel> \<noteq> 0 then
    arccos((vel s + acc s) \<bullet> vel s / ((\<parallel>vel s + acc s\<parallel>) * (\<parallel>vel s\<parallel>)))
  else 0)"

(* [ p \<mapsto>\<^sub>s v
  , v \<mapsto>\<^sub>s a
  , a \<mapsto>\<^sub>s 0
  , \<phi> \<mapsto>\<^sub>s \<omega>
  , s \<mapsto>\<^sub>s (v \<bullet> a) / s \<triangleleft> \<not> s = 0 \<triangleright> \<parallel>a\<parallel>
  , t \<mapsto>\<^sub>s 1
  , old \<mapsto>\<^sub>s 0 ] *)
abbreviation f_amv :: "real^AMV \<Rightarrow> real^AMV" ("f")
  where "f s \<equiv> (\<chi> i.
    if i=\<downharpoonright>\<^sub>V''x'' then s\<restriction>\<^sub>V''vx'' else (
    if i=\<downharpoonright>\<^sub>V''y'' then s\<restriction>\<^sub>V''vy'' else (
    if i=\<downharpoonright>\<^sub>V''vx'' then s\<restriction>\<^sub>V''ax'' else (
    if i=\<downharpoonright>\<^sub>V''vy'' then s\<restriction>\<^sub>V''ay'' else (
    if i=\<downharpoonright>\<^sub>V''phi'' then omega s else (
    if i=\<downharpoonright>\<^sub>V''speed'' then (
      if s\<restriction>\<^sub>V''speed'' \<noteq> 0 then
        (vel s \<bullet> acc s) / s\<restriction>\<^sub>V''speed''
      else
        \<parallel>acc s\<parallel>) else (
    if i=\<downharpoonright>\<^sub>V''t'' then 1 else 0)))))))"

(* abbreviation "ax\<^sub>A\<^sub>V \<equiv> U(&\<^bold>c:t < \<epsilon> \<and>
    &\<^bold>c:s *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>),cos(&\<^bold>c:\<phi>)]\<^bold>] = &\<^bold>c:v \<and>
    0 \<le> &\<^bold>c:s \<and> &\<^bold>c:s \<le> S)" *)
abbreviation amv_guard :: "real \<Rightarrow> real \<Rightarrow> real^AMV \<Rightarrow> bool" ("G")
  where "G \<epsilon> S s \<equiv> s\<restriction>\<^sub>V''t'' < \<epsilon> \<and>
    s\<restriction>\<^sub>V''speed'' *\<^sub>R (\<chi> i. if i=1 then sin (s\<restriction>\<^sub>V''phi'') else cos (s\<restriction>\<^sub>V''phi'')) = vel s \<and>
    0 \<le> s\<restriction>\<^sub>V''speed'' \<and> s\<restriction>\<^sub>V''speed'' \<le> S"

(* abbreviation "Dynamics \<equiv> \<^bold>c:t := 0 ;; ODE" *)
abbreviation "amv_dyn \<epsilon> S \<equiv> (\<downharpoonright>\<^sub>V''t'' ::= (\<lambda>s. 0)) ; (x\<acute>= f & (G \<epsilon> S))"

subsubsection \<open> Formalisation of discrete control \<close>

locale AMV =
  fixes \<epsilon> :: real \<comment> \<open> max. time for ODE \<close>
    and "e\<^sub>\<Phi>" :: real \<comment> \<open> angle hysteresis \<close>
    and "s\<^sub>\<epsilon>" :: real \<comment> \<open> speed setpoint limiter \<close>
    and "\<Phi>\<^sub>\<epsilon>" :: real \<comment> \<open> angle setpoint limiter\<close>
    and flmax :: real \<comment> \<open> maximum force capable by motor \<close>
    and frmax :: real \<comment> \<open> maximum rotational force capable by motor \<close>
    and "k\<^sub>l" :: real \<comment> \<open> proportionality controller constant for longitudinal force \<close>
    and "k\<^sub>r" :: real \<comment> \<open> proportionality controller constant for radial force \<close>
    and m :: real \<comment> \<open> mass of the AMV \<close>
    and S :: real \<comment> \<open> max. (controlling) speed of AMV \<close> (* as opposed to that by laws of physics *)
    and H :: real \<comment> \<open> min. (controlling) speed of AMV \<close>
    and HCM :: real \<comment> \<open> high caution mode \<close>
    and MOM :: real \<comment> \<open> main operating mode \<close>
    and OCM :: real \<comment> \<open> operator control mode \<close>
    and wp :: "real^2" \<comment> \<open> waypoint's position  \<close>
    and Obs :: "(real^2) set" \<comment> \<open> set of obstacles \<close>
  assumes "Obs = {(\<chi> i::2. (1::real))}"
    and "HCM = 1"
    and "MOM = 2"
    and "OCM = 3"
    and mass: "m > 0"
    and longF: "flmax > 0"
    and rotF: "frmax > 0"
begin

(* abbreviation "angOfVec \<equiv> vangle \<^bold>[[0::real,100]\<^bold>]"
   abbreviation "steerToWP \<equiv> rh := angOfVec(nextWP - &\<^bold>c:p)" *)
abbreviation "steerToWP \<equiv> (\<downharpoonright>\<^sub>V''hSP'' ::= (\<lambda>s. vangle (\<chi> i. if i=1 then 0 else 100) (wp - pos s)))"

lemma "vector [0,100] = (\<chi> i::2. if i=1 then (0::real) else 100)"
  apply(simp add: vec_eq_iff vector_def)
  using exhaust_2 by auto

(* abbreviation
  "LRE \<equiv> ((mode = HCM) \<longrightarrow>\<^sub>r rs := 0.1 ;; steerToWP)
       \<sqinter> ((mode = OCM) \<longrightarrow>\<^sub>r II)
       \<sqinter> ((mode = MOM) \<longrightarrow>\<^sub>r
             rs := 1 ;;
             steerToWP ;;
             if (\<exists> o. o \<in> obsReg \<and> \<parallel>&\<^bold>c:p - \<guillemotleft>o\<guillemotright>\<parallel> \<le> 7.5) then mode := HCM ;; rs := 0.1 fi
          )" *)

abbreviation "nearObj k s \<equiv> \<exists>ob \<in> Obs. \<parallel>pos s - ob\<parallel> \<le> k"
abbreviation "onCollCourse k s \<equiv> \<exists>ob \<in> Obs. \<parallel>pos s - ob\<parallel> \<le> k \<and> vangle (ob - pos s) (vel s) < e\<^sub>\<Phi>"

abbreviation "LRE k \<equiv>
  IF (\<lambda>s. s\<restriction>\<^sub>V''mode'' = HCM) THEN
    (\<downharpoonright>\<^sub>V''sSP'' ::= (\<lambda>s. H)) ; steerToWP
  ELSE (IF (\<lambda>s. s\<restriction>\<^sub>V''mode'' = MOM) THEN
    (\<downharpoonright>\<^sub>V''sSP'' ::= (\<lambda>s. S)); steerToWP;
    (IF nearObj k THEN
      (\<downharpoonright>\<^sub>V''mode'' ::= (\<lambda>s. HCM));(\<downharpoonright>\<^sub>V''sSP'' ::= (\<lambda>s. H))
    ELSE skip)
  ELSE skip)"

(*
abbreviation "AP \<equiv>
  if \<parallel>rs - &\<^bold>c:s\<parallel> > s\<^sub>\<epsilon>
    then ft := sgn(rs - &\<^bold>c:s)*min(kp\<^sub>g\<^sub>v * \<parallel>rs - &\<^bold>c:s\<parallel>) f\<^sub>m\<^sub>a\<^sub>x
    else ft := 0 fi ;;
  if \<parallel>rh - &\<^bold>c:\<phi>\<parallel> > \<phi>\<^sub>\<epsilon>
    then fl := sgn(rh - &\<^bold>c:\<phi>)*min(kp\<^sub>g\<^sub>r * \<parallel>rh - &\<^bold>c:\<phi>\<parallel>) f\<^sub>m\<^sub>a\<^sub>x
    else fl := 0 fi ;;
  f := fl *\<^sub>R \<^bold>[[cos(&\<^bold>c:\<phi>), sin(&\<^bold>c:\<phi>)]\<^bold>]
     + ft *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>), cos(&\<^bold>c:\<phi>)]\<^bold>] ;;
  \<^bold>c:a := f /\<^sub>R m"
*)
abbreviation "AP \<equiv>
  (IF (\<lambda>s. \<bar>s\<restriction>\<^sub>V''sSP'' - s\<restriction>\<^sub>V''speed''\<bar> > s\<^sub>\<epsilon>) THEN
    (\<downharpoonright>\<^sub>V''fl'' ::= (\<lambda>s. sgn (s\<restriction>\<^sub>V''sSP'' - s\<restriction>\<^sub>V''speed'') * (min (k\<^sub>l * \<bar>s\<restriction>\<^sub>V''sSP'' - s\<restriction>\<^sub>V''speed''\<bar>) flmax)))
  ELSE
    (\<downharpoonright>\<^sub>V''fl'' ::= (\<lambda>s. 0)));
  (IF (\<lambda>s. \<bar>s\<restriction>\<^sub>V''hSP'' - s\<restriction>\<^sub>V''phi''\<bar> > \<Phi>\<^sub>\<epsilon>) THEN
    (\<downharpoonright>\<^sub>V''fr'' ::= (\<lambda>s. sgn (s\<restriction>\<^sub>V''hSP'' - s\<restriction>\<^sub>V''phi'') * (min (k\<^sub>r * \<bar>s\<restriction>\<^sub>V''hSP'' - s\<restriction>\<^sub>V''phi''\<bar>) frmax)))
  ELSE
    (\<downharpoonright>\<^sub>V''fr'' ::= (\<lambda>s. 0)));
  (\<downharpoonright>\<^sub>V''ax'' ::= (\<lambda>s. (s\<restriction>\<^sub>V''fl'' * cos (s\<restriction>\<^sub>V''phi'') + s\<restriction>\<^sub>V''fr'' * sin (s\<restriction>\<^sub>V''phi''))/m));
  (\<downharpoonright>\<^sub>V''ay'' ::= (\<lambda>s. (s\<restriction>\<^sub>V''fl'' * sin (s\<restriction>\<^sub>V''phi'') + s\<restriction>\<^sub>V''fr'' * cos (s\<restriction>\<^sub>V''phi''))/m))"

(* abbreviation "AUV \<equiv> (LRE ;; AP ;; Dynamics)\<^sup>\<star>" *)
abbreviation "AUV \<equiv> (LRE 7.5; AP; amv_dyn \<epsilon> S)"

lemma LRE_no_modfs:
  shows LRE_no_modfs_t: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''t'')"
    and LRE_no_modfs_x: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''x'')"
    and LRE_no_modfs_y: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''y'')"
    and LRE_no_modfs_vx: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''vx'')"
    and LRE_no_modfs_vy: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''vy'')"
    and LRE_no_modfs_ax: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''ax'')"
    and LRE_no_modfs_ay: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''ay'')"
    and LRE_no_modfs_speed: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''speed'')"
    and LRE_no_modfs_phi: "no_modfs (LRE 7.5) (\<downharpoonright>\<^sub>V''phi'')"
  unfolding no_modfs_def by (auto simp: to_var_inject)

lemma AP_no_modfs:
  shows AP_no_modfs_t: "no_modfs AP (\<downharpoonright>\<^sub>V''t'')"
    and AP_no_modfs_x: "no_modfs AP (\<downharpoonright>\<^sub>V''x'')"
    and AP_no_modfs_y: "no_modfs AP (\<downharpoonright>\<^sub>V''y'')"
    and AP_no_modfs_vx: "no_modfs AP (\<downharpoonright>\<^sub>V''vx'')"
    and AP_no_modfs_vy: "no_modfs AP (\<downharpoonright>\<^sub>V''vy'')"
    and AP_no_modfs_speed: "no_modfs AP (\<downharpoonright>\<^sub>V''speed'')"
    and AP_no_modfs_phi: "no_modfs AP (\<downharpoonright>\<^sub>V''phi'')"
  unfolding no_modfs_def by (auto simp: to_var_inject)

lemma amv_dyn_no_modfs_sSP: "no_modfs (amv_dyn a b) (\<downharpoonright>\<^sub>V''sSP'')"
  unfolding no_modfs_def apply (rule allI)
  apply(rule_tac R="\<lambda>s. s\<restriction>\<^sub>V''sSP'' = k" in hoare_kcomp, simp_all add: to_var_inject)
  by (auto intro!: diff_invariant_rules poly_derivatives simp: to_var_inject)

lemma amv_dyn_no_modfs_hSP: "no_modfs (amv_dyn a b) (\<downharpoonright>\<^sub>V''hSP'')"
  unfolding no_modfs_def apply (rule allI)
  apply(rule_tac R="\<lambda>s. s\<restriction>\<^sub>V''hSP'' = k" in hoare_kcomp, simp_all add: to_var_inject)
  by (auto intro!: diff_invariant_rules poly_derivatives simp: to_var_inject)

lemma amv_dyn_no_modfs_fr: "no_modfs (amv_dyn a b) (\<downharpoonright>\<^sub>V''fr'')"
  unfolding no_modfs_def apply (rule allI)
  apply(rule_tac R="\<lambda>s. s\<restriction>\<^sub>V''fr'' = k" in hoare_kcomp, simp_all add: to_var_inject)
  by (auto intro!: diff_invariant_rules poly_derivatives simp: to_var_inject)

lemma amv_dyn_no_modfs_fl: "no_modfs (amv_dyn a b) (\<downharpoonright>\<^sub>V''fl'')"
  unfolding no_modfs_def apply (rule allI)
  apply(rule_tac R="\<lambda>s. s\<restriction>\<^sub>V''fl'' = k" in hoare_kcomp, simp_all add: to_var_inject)
  by (auto intro!: diff_invariant_rules poly_derivatives simp: to_var_inject)

lemma "G \<epsilon> S \<le> |LRE 7.5] G \<epsilon> S"
  by (auto simp: to_var_inject vec_eq_iff)

lemma "(\<lambda>s. s\<restriction>\<^sub>V''t'' \<ge> 0) \<le> |x\<acute>= f & (G \<epsilon> S)] (\<lambda>s. s\<restriction>\<^sub>V''t'' \<ge> 0)"
  apply(simp, rule_tac \<nu>'="\<lambda>s. 0" and \<mu>'="\<lambda>s. 1" in diff_invariant_leq_rule)
  apply(auto intro!: poly_derivatives)
  by (erule_tac x="\<downharpoonright>\<^sub>V''t''" in allE, simp add: to_var_inject)

lemma "(\<lambda>s. s\<restriction>\<^sub>V''speed'' = \<parallel>vel s\<parallel>) \<le> |x\<acute>= f & (G \<epsilon> S)] (\<lambda>s. s\<restriction>\<^sub>V''speed'' = \<parallel>vel s\<parallel>)"
  apply(rule diff_weak_rule, clarsimp)
  apply(drule sym, simp, simp add: norm_vec_def L2_set_def)
  unfolding UNIV_2 by auto

lemma "(\<lambda>s. s\<restriction>\<^sub>V''sSP'' = s\<restriction>\<^sub>V''speed'' \<and> s\<restriction>\<^sub>V''hSP'' = s\<restriction>\<^sub>V''phi'') \<le> |AP] (\<lambda>s. acc s = 0)"
  by (auto simp: to_var_inject vec_eq_iff)

lemma "(\<lambda>s. s\<restriction>\<^sub>V''speed'' \<in> {s\<restriction>\<^sub>V''sSP'' - s\<^sub>\<epsilon> .. s\<restriction>\<^sub>V''sSP'' + s\<^sub>\<epsilon>} \<and> s\<restriction>\<^sub>V''hSP'' = s\<restriction>\<^sub>V''phi'') \<le> |AP] (\<lambda>s. acc s = 0)"
  apply (auto simp: to_var_inject vec_eq_iff)
  done

lemma "(\<lambda>s. s\<restriction>\<^sub>V''sSP'' < s\<restriction>\<^sub>V''speed'' - s\<^sub>\<epsilon> \<and> s\<restriction>\<^sub>V''hSP'' = s\<restriction>\<^sub>V''phi'') \<le> |AP] (\<lambda>s. \<parallel>acc s\<parallel> > 0)"
  using sin_zero_abs_cos_one mass longF rotF
  apply (auto simp: to_var_inject vec_eq_iff)
  using exhaust_2 apply fastforce

lemma "(\<lambda>s. acc s \<bullet> vel s = (\<parallel>acc s\<parallel>) * (\<parallel>vel s\<parallel>)) \<le> |amv_dyn a b] (\<lambda>s. acc s \<bullet> vel s = (\<parallel>acc s\<parallel>) * (\<parallel>vel s\<parallel>))"
  apply(rule_tac R="\<lambda>s. acc s \<bullet> vel s = (\<parallel>acc s\<parallel>) * (\<parallel>vel s\<parallel>)" in hoare_kcomp)
  apply(simp add: le_fun_def)
   apply(simp add: inner_vec_def norm_vec_def L2_set_def )

  oops

thm to_str_induct to_str_inject to_str_inverse
thm to_var_induct to_var_inject to_var_inverse

end

no_notation f_amv ("f")
        and amv_guard ("G")

end


theory Predicate_Compile_Alternative_Defs
imports Main
begin

section {* Common constants *}

declare HOL.if_bool_eq_disj[code_pred_inline]

declare bool_diff_def[code_pred_inline]
declare inf_bool_def[abs_def, code_pred_inline]
declare less_bool_def[abs_def, code_pred_inline]
declare le_bool_def[abs_def, code_pred_inline]

lemma min_bool_eq [code_pred_inline]: "(min :: bool => bool => bool) == (op &)"
by (rule eq_reflection) (auto simp add: fun_eq_iff min_def)

lemma [code_pred_inline]:
  "((A::bool) ~= (B::bool)) = ((A & ~ B) | (B & ~ A))"
by fast

setup {* Predicate_Compile_Data.ignore_consts [@{const_name Let}] *}

section {* Pairs *}

setup {* Predicate_Compile_Data.ignore_consts [@{const_name fst}, @{const_name snd}, @{const_name case_prod}] *}

section {* Bounded quantifiers *}

declare Ball_def[code_pred_inline]
declare Bex_def[code_pred_inline]

section {* Operations on Predicates *}

lemma Diff[code_pred_inline]:
  "(A - B) = (%x. A x \<and> \<not> B x)"
  by (simp add: fun_eq_iff)

lemma subset_eq[code_pred_inline]:
  "(P :: 'a => bool) < (Q :: 'a => bool) == ((\<exists>x. Q x \<and> (\<not> P x)) \<and> (\<forall> x. P x --> Q x))"
  by (rule eq_reflection) (auto simp add: less_fun_def le_fun_def)

lemma set_equality[code_pred_inline]:
  "A = B \<longleftrightarrow> (\<forall>x. A x \<longrightarrow> B x) \<and> (\<forall>x. B x \<longrightarrow> A x)"
  by (auto simp add: fun_eq_iff)

section {* Setup for Numerals *}

setup {* Predicate_Compile_Data.ignore_consts [@{const_name numeral}] *}
setup {* Predicate_Compile_Data.keep_functions [@{const_name numeral}] *}

setup {* Predicate_Compile_Data.ignore_consts [@{const_name div}, @{const_name mod}, @{const_name times}] *}

section {* Arithmetic operations *}

subsection {* Arithmetic on naturals and integers *}

definition plus_eq_nat :: "nat => nat => nat => bool"
where
  "plus_eq_nat x y z = (x + y = z)"

definition minus_eq_nat :: "nat => nat => nat => bool"
where
  "minus_eq_nat x y z = (x - y = z)"

definition plus_eq_int :: "int => int => int => bool"
where
  "plus_eq_int x y z = (x + y = z)"

definition minus_eq_int :: "int => int => int => bool"
where
  "minus_eq_int x y z = (x - y = z)"

definition subtract
where
  [code_unfold]: "subtract x y = y - x"

setup {*
let
  val Fun = Predicate_Compile_Aux.Fun
  val Input = Predicate_Compile_Aux.Input
  val Output = Predicate_Compile_Aux.Output
  val Bool = Predicate_Compile_Aux.Bool
  val iio = Fun (Input, Fun (Input, Fun (Output, Bool)))
  val ioi = Fun (Input, Fun (Output, Fun (Input, Bool)))
  val oii = Fun (Output, Fun (Input, Fun (Input, Bool)))
  val ooi = Fun (Output, Fun (Output, Fun (Input, Bool)))
  val plus_nat = Core_Data.functional_compilation @{const_name plus} iio
  val minus_nat = Core_Data.functional_compilation @{const_name "minus"} iio
  fun subtract_nat compfuns (_ : typ) =
    let
      val T = Predicate_Compile_Aux.mk_monadT compfuns @{typ nat}
    in
      absdummy @{typ nat} (absdummy @{typ nat}
        (Const (@{const_name "If"}, @{typ bool} --> T --> T --> T) $
          (@{term "op > :: nat => nat => bool"} $ Bound 1 $ Bound 0) $
          Predicate_Compile_Aux.mk_empty compfuns @{typ nat} $
          Predicate_Compile_Aux.mk_single compfuns
          (@{term "op - :: nat => nat => nat"} $ Bound 0 $ Bound 1)))
    end
  fun enumerate_addups_nat compfuns (_ : typ) =
    absdummy @{typ nat} (Predicate_Compile_Aux.mk_iterate_upto compfuns @{typ "nat * nat"}
    (absdummy @{typ natural} (@{term "Pair :: nat => nat => nat * nat"} $
      (@{term "nat_of_natural"} $ Bound 0) $
      (@{term "op - :: nat => nat => nat"} $ Bound 1 $ (@{term "nat_of_natural"} $ Bound 0))),
      @{term "0 :: natural"}, @{term "natural_of_nat"} $ Bound 0))
  fun enumerate_nats compfuns  (_ : typ) =
    let
      val (single_const, _) = strip_comb (Predicate_Compile_Aux.mk_single compfuns @{term "0 :: nat"})
      val T = Predicate_Compile_Aux.mk_monadT compfuns @{typ nat}
    in
      absdummy @{typ nat} (absdummy @{typ nat}
        (Const (@{const_name If}, @{typ bool} --> T --> T --> T) $
          (@{term "op = :: nat => nat => bool"} $ Bound 0 $ @{term "0::nat"}) $
          (Predicate_Compile_Aux.mk_iterate_upto compfuns @{typ nat} (@{term "nat_of_natural"},
            @{term "0::natural"}, @{term "natural_of_nat"} $ Bound 1)) $
            (single_const $ (@{term "op + :: nat => nat => nat"} $ Bound 1 $ Bound 0))))
    end
in
  Core_Data.force_modes_and_compilations @{const_name plus_eq_nat}
    [(iio, (plus_nat, false)), (oii, (subtract_nat, false)), (ioi, (subtract_nat, false)),
     (ooi, (enumerate_addups_nat, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
       (@{term "plus :: nat => nat => nat"}, @{term "plus_eq_nat"})
  #> Core_Data.force_modes_and_compilations @{const_name minus_eq_nat}
       [(iio, (minus_nat, false)), (oii, (enumerate_nats, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
      (@{term "minus :: nat => nat => nat"}, @{term "minus_eq_nat"})
  #> Core_Data.force_modes_and_functions @{const_name plus_eq_int}
    [(iio, (@{const_name plus}, false)), (ioi, (@{const_name subtract}, false)),
     (oii, (@{const_name subtract}, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
       (@{term "plus :: int => int => int"}, @{term "plus_eq_int"})
  #> Core_Data.force_modes_and_functions @{const_name minus_eq_int}
    [(iio, (@{const_name minus}, false)), (oii, (@{const_name plus}, false)),
     (ioi, (@{const_name minus}, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
      (@{term "minus :: int => int => int"}, @{term "minus_eq_int"})
end
*}

subsection {* Inductive definitions for ordering on naturals *}

inductive less_nat
where
  "less_nat 0 (Suc y)"
| "less_nat x y ==> less_nat (Suc x) (Suc y)"

lemma less_nat[code_pred_inline]:
  "x < y = less_nat x y"
apply (rule iffI)
apply (induct x arbitrary: y)
apply (case_tac y) apply (auto intro: less_nat.intros)
apply (case_tac y)
apply (auto intro: less_nat.intros)
apply (induct rule: less_nat.induct)
apply auto
done

inductive less_eq_nat
where
  "less_eq_nat 0 y"
| "less_eq_nat x y ==> less_eq_nat (Suc x) (Suc y)"

lemma [code_pred_inline]:
"x <= y = less_eq_nat x y"
apply (rule iffI)
apply (induct x arbitrary: y)
apply (auto intro: less_eq_nat.intros)
apply (case_tac y) apply (auto intro: less_eq_nat.intros)
apply (induct rule: less_eq_nat.induct)
apply auto done

section {* Alternative list definitions *}

subsection {* Alternative rules for @{text length} *}

definition size_list' :: "'a list => nat"
where "size_list' = size"

lemma size_list'_simps:
  "size_list' [] = 0"
  "size_list' (x # xs) = Suc (size_list' xs)"
by (auto simp add: size_list'_def)

declare size_list'_simps[code_pred_def]
declare size_list'_def[symmetric, code_pred_inline]

subsection {* Alternative rules for @{text list_all2} *}

lemma list_all2_NilI [code_pred_intro]: "list_all2 P [] []"
by auto

lemma list_all2_ConsI [code_pred_intro]: "list_all2 P xs ys ==> P x y ==> list_all2 P (x#xs) (y#ys)"
by auto

code_pred [skip_proof] list_all2
proof -
  case list_all2
  from this show thesis
    apply -
    apply (case_tac xb)
    apply (case_tac xc)
    apply auto
    apply (case_tac xc)
    apply auto
    done
qed

section {* Setup for String.literal *}

setup {* Predicate_Compile_Data.ignore_consts [@{const_name "STR"}] *}

section {* Simplification rules for optimisation *}

lemma [code_pred_simp]: "\<not> False == True"
by auto

lemma [code_pred_simp]: "\<not> True == False"
by auto

lemma less_nat_k_0 [code_pred_simp]: "less_nat k 0 == False"
unfolding less_nat[symmetric] by auto

end


(*  Title:      HOL/ex/Hex_Bin_Examples.thy
    Author:     Gerwin Klein, NICTA
*)

section \<open>Examples for hexadecimal and binary numerals\<close>

theory Hex_Bin_Examples imports Main
begin

text "Hex and bin numerals can be used like normal decimal numerals in input"
lemma "0xFF = 255" by (rule refl)
lemma "0xF = 0b1111" by (rule refl)

text \<open>
  Just like decimal numeral they are polymorphic, for arithmetic
  they need to be constrained
\<close>
lemma "0x0A + 0x10 = (0x1A :: nat)" by simp

text "The number of leading zeros is irrelevant"
lemma "0b00010000 = 0x10" by (rule refl)

text "Unary minus works as for decimal numerals"
lemma "- 0x0A = - 10" by (rule refl)

text \<open>
  Hex and bin numerals are printed as decimal: \<^term>\<open>0b10\<close>
\<close>
term "0b10"
term "0x0A"

text \<open>
  The numerals 0 and 1 are syntactically different from the
  constants 0 and 1. For the usual numeric types, their values
  are the same, though.
\<close>
lemma "0x01 = 1" oops
lemma "0x00 = 0" oops

lemma "0x01 = (1::nat)" by simp
lemma "0b0000 = (0::int)" by simp

end


theory Submission
  imports Defs
begin

lemma count_simp:  "count as = x \<Longrightarrow> count bs = y \<Longrightarrow> count (as@bs) = x + y"
by(induction as arbitrary: x bs y rule: count.induct, auto)

lemma ins_false: "count as = 0 \<Longrightarrow> count bs = 0 \<Longrightarrow> count (as @ False # bs) = -1"
  using count_simp by(induction as arbitrary: bs rule: count.induct, auto)

lemma ins_true: "count as = 0 \<Longrightarrow> count bs = 0 \<Longrightarrow> count (as @ True # bs) = 1"
  using count_simp by(induction as arbitrary: bs rule: count.induct, auto)

lemma ok_count_Zero: "ok bs \<Longrightarrow> count bs = 0"
apply(induction bs rule: ok.induct) using ins_false by auto

end