section "Hoare Logic based on Separation Logic and Time Credits"
theory SepLog_Hoare
  imports Big_StepT_Partial    "SepLogAdd/Sep_Algebra_Add"
begin

subsection "Definition of Validity"

definition hoare3_valid :: "assn2 \<Rightarrow> com \<Rightarrow> assn2 \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>3 {(1_)}/ (_)/ { (1_)}" 50) where
"\<Turnstile>\<^sub>3 { P } c { Q }  \<longleftrightarrow>
     (\<forall>ps n. P (ps,n)
     \<longrightarrow> (\<exists>ps' m. ((c,ps) \<Rightarrow>\<^sub>A m \<Down> ps')
           \<and> n\<ge>m \<and> Q (ps', n-m))  )"

lemma alternative: "\<Turnstile>\<^sub>3 { P } c { Q }  \<longleftrightarrow>
     (\<forall>ps n. P (ps,n)
     \<longrightarrow> (\<exists>ps' t n'. ((c,ps) \<Rightarrow>\<^sub>A t \<Down> ps')
             \<and> n=n'+t \<and> Q (ps', n'))  )"
proof rule
  assume "\<Turnstile>\<^sub>3 {P} c { Q}"
  then have P: "(\<forall>ps n. P (ps,n) \<longrightarrow> (\<exists>ps' m. ((c,ps) \<Rightarrow>\<^sub>A m \<Down> ps') \<and> n\<ge>m \<and> Q (ps', n-m))  )" unfolding hoare3_valid_def.
  show "\<forall>ps n. P (ps, n) \<longrightarrow> (\<exists>ps' m e. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> n = e + m \<and> Q (ps', e))"
  proof (safe)
    fix ps n
    assume "P (ps, n)"
    with P obtain ps' m where Z: "((c,ps) \<Rightarrow>\<^sub>A m \<Down> ps')" "n\<ge>m" "Q (ps', n-m)" by blast
    show "\<exists>ps' m e. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> n = e + m \<and> Q (ps', e)"
    apply(rule exI[where x=ps'])
    apply(rule exI[where x=m])
      apply(rule exI[where x="n-m"]) using Z by auto
  qed
next
  assume "\<forall>ps n. P (ps, n) \<longrightarrow> (\<exists>ps' m e. (c, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> n = e + m \<and> Q (ps', e))"
  then show "\<Turnstile>\<^sub>3 { P } c { Q } "  unfolding hoare3_valid_def
     by fastforce
qed

subsection "Hoare Rules"

inductive
  hoareT3 :: "assn2 \<Rightarrow> com \<Rightarrow> assn2 \<Rightarrow> bool" ("\<turnstile>\<^sub>3 ({(1_)}/ (_)/ { (1_)})" 50)
where

Skip:  "\<turnstile>\<^sub>3 {$1} SKIP { $0}"  |

Assign:  "\<turnstile>\<^sub>3 {lmaps_to_expr_x x a v ** $1} x::=a { (%(s,c). dom s = vars a - {x} \<and> c = 0) ** x \<hookrightarrow> v }"  |

If: "\<lbrakk> \<turnstile>\<^sub>3 { \<lambda>(s,n). P (s,n) \<and> lmaps_to_axpr b True s } c\<^sub>1 { Q };
       \<turnstile>\<^sub>3 {  \<lambda>(s,n). P (s,n) \<and> lmaps_to_axpr b False s } c\<^sub>2 { Q } \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>3 { (\<lambda>(s,n). P (s,n) \<and> vars b \<subseteq> dom s) ** $1} IF b THEN c\<^sub>1 ELSE c\<^sub>2 { Q}"   |

Frame:  "\<lbrakk>    \<turnstile>\<^sub>3 { P } C { Q  } \<rbrakk>
             \<Longrightarrow> \<turnstile>\<^sub>3 { P ** F } C { Q ** F } "  |

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

While:  "\<lbrakk> \<turnstile>\<^sub>3 { (\<lambda>(s,n). P (s,n) \<and> lmaps_to_axpr b True s) } C { P  ** $1 }  \<rbrakk>
             \<Longrightarrow> \<turnstile>\<^sub>3 { (\<lambda>(s,n). P (s,n) \<and>  vars b \<subseteq> dom s) ** $1 } WHILE b DO C {  \<lambda>(s,n). P (s,n) \<and> lmaps_to_axpr b False s } "  |

conseq: "\<lbrakk> \<turnstile>\<^sub>3 {P}c{Q} ; \<And>s. P' s \<Longrightarrow> P s ; \<And>s. Q s \<Longrightarrow> Q' s \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>3 {P'}c{ Q'}"   |

normalize:  "\<lbrakk>    \<turnstile>\<^sub>3 { P ** $m } C { Q  ** $n }; n\<le>m \<rbrakk>
             \<Longrightarrow> \<turnstile>\<^sub>3 { P ** $(m-n) } C { Q } "   |

constancy:  "\<lbrakk>    \<turnstile>\<^sub>3 { P } C { Q }; \<And>ps ps'. ps = ps' on UNIV - lvars C \<Longrightarrow> R ps = R ps'  \<rbrakk>
             \<Longrightarrow> \<turnstile>\<^sub>3 { %(ps,n). P (ps,n) \<and> R ps } C { %(ps,n). Q (ps,n) \<and> R ps } " |

Assign''': "\<turnstile>\<^sub>3 {  $1 ** (x \<hookrightarrow> ds) } x ::= (N v) {  (x \<hookrightarrow> v) }" |

Assign'''': "\<lbrakk>  symeval P a v; \<turnstile>\<^sub>3 {P} x ::= (N v) {Q'}  \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>3 {P} x ::= a {Q'}" |

Assign4:  "\<turnstile>\<^sub>3 { (\<lambda>(ps,t). x\<in>dom ps \<and> vars a \<subseteq> dom ps \<and> Q (ps(x\<mapsto>(paval a ps)),t) ) ** $1} x::=a { Q }" |

False: "\<turnstile>\<^sub>3 {  \<lambda>(ps,n). False } c {  Q }" |

pureI: "( P \<Longrightarrow>  \<turnstile>\<^sub>3 { Q} c { R}) \<Longrightarrow>  \<turnstile>\<^sub>3 {\<up>P ** Q} c { R}"

text \<open>Derived Rules\<close>

lemma Frame_R:  assumes "\<turnstile>\<^sub>3 { P } C { Q  }" "Frame P' P F"
             shows "\<turnstile>\<^sub>3 { P' } C { Q ** F } "
  apply(rule conseq) apply(rule Frame) apply(rule assms(1))
      using assms(2) unfolding Frame_def by auto

lemma strengthen_post: assumes "\<turnstile>\<^sub>3 {P}c{Q}" "\<And>s. Q s \<Longrightarrow> Q' s"
  shows "\<turnstile>\<^sub>3 {P}c{ Q'}"
  apply(rule conseq)
    apply (rule assms(1))
    apply simp apply fact done

lemma weakenpre:  "\<lbrakk> \<turnstile>\<^sub>3 {P}c{Q} ; \<And>s. P' s \<Longrightarrow> P s  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>3 {P'}c{ Q}"
  using conseq by auto

subsection \<open>Soundness Proof\<close>

lemma exec_preserves_disj: "(c,ps) \<Rightarrow>\<^sub>A t \<Down> ps' \<Longrightarrow> ps'' ## ps \<Longrightarrow> ps'' ## ps'"
 apply(drule big_step_t3_post_dom_conv)
  unfolding sep_disj_fun_def domain_conv by auto

lemma FrameRuleSound: assumes "\<Turnstile>\<^sub>3 { P  } C { Q  }"
  shows "\<Turnstile>\<^sub>3 { P ** F } C { Q ** F }"
proof -
  {
    fix ps n
    assume "(P \<and>* F) (ps, n)"
    then obtain pP nP pF nF where orth: "(pP, nP) ## (pF, nF)" and add: "(ps, n) = (pP, nP) + (pF, nF)"
              and P: "P (pP, nP)" and F: "F (pF, nF)" unfolding sep_conj_def by auto
    from assms[unfolded hoare3_valid_def] P
      obtain pP' m where ex: "(C, pP) \<Rightarrow>\<^sub>A m \<Down> pP'" and m: "m \<le> nP" and Q: "Q (pP', nP - m)" by blast

    have exF: "(C, ps) \<Rightarrow>\<^sub>A m \<Down> pP' + pF"
       using Framer2 ex orth add by auto
    have QF: "(Q \<and>* F) (pP' + pF, n - m)"
      unfolding sep_conj_def
          apply(rule exI[where x="(pP',nP-m)"])
          apply(rule exI[where x="(pF,nF)"])
          using orth exec_preserves_disj[OF ex] add m F Q by (auto simp add: sep_add_ac)
    have "(C, ps) \<Rightarrow>\<^sub>A m \<Down> pP'+pF \<and> m \<le> n \<and> (Q \<and>* F) (pP'+pF, n - m)"
      using QF exF add m by auto
    hence "\<exists>ps' m. (C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> m \<le> n \<and> (Q \<and>* F) (ps', n - m)" by auto
  }
  thus ?thesis unfolding hoare3_valid_def by auto
qed

theorem hoare3_sound: assumes "\<turnstile>\<^sub>3 { P }c{ Q  }"
  shows "\<Turnstile>\<^sub>3 { P } c { Q }" using assms
proof(induction  rule: hoareT3.induct)
  case (False c Q)
  then show ?case by (auto simp: hoare3_valid_def)
next
  case Skip
  then show ?case by (auto simp: hoare3_valid_def dollar_def)
next
  case (Assign4 x a Q)
  then show ?case
    apply (auto simp: dollar_def sep_conj_def hoare3_valid_def )
      subgoal for ps b y
        apply(rule exI[where x="ps(x \<mapsto> paval a ps)"])
          apply(rule exI[where x="Suc 0"]) by auto
      done
next
  case (Assign x a v)
  then show ?case unfolding hoare3_valid_def apply auto apply (auto simp: dollar_def ) apply (subst (asm) separate_othogonal)
      apply simp_all apply(intro exI conjI)
      apply(rule big_step_t_part.Assign)
      apply (auto simp: pointsto_def)  unfolding  sep_conj_def
    subgoal for ps apply(rule exI[where x="((%y. if y=x then None else ps y) , 0)"])
      apply(rule exI[where x="((%y. if y = x then Some (paval a ps) else None),0)"])
        apply (auto simp: sep_disj_prod_def sep_disj_fun_def plus_fun_def)
      apply (smt domIff domain_conv)
      apply (metis domI insertE option.simps(3))
      using domIff by fastforce
    done
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  from If(3)[unfolded hoare3_valid_def]
    have T: "\<And>ps n. P (ps, n) \<Longrightarrow> vars b \<subseteq> dom ps \<Longrightarrow> pbval b ps
     \<Longrightarrow> (\<exists>ps' m. (c\<^sub>1, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> m \<le> n \<and> Q (ps', n-m))" by auto
  from If(4)[unfolded hoare3_valid_def]
    have F: "\<And>ps n. P (ps, n) \<Longrightarrow> vars b \<subseteq> dom ps \<Longrightarrow> \<not> pbval b ps
     \<Longrightarrow> (\<exists>ps' m. (c\<^sub>2, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<and> m \<le> n \<and> Q (ps', n-m))" by auto
  show ?case unfolding hoare3_valid_def apply auto apply (auto simp: dollar_def)
  proof (goal_cases)
    case (1 ps n)
    then obtain n' where P: "P (ps, n')" and dom: "vars b \<subseteq> dom ps" and Suc: "n = Suc n'" unfolding sep_conj_def
      by force
    show ?case
    proof(cases "pbval b ps")
      case True
      with T[OF P dom] obtain ps' m where d: "(c\<^sub>1, ps) \<Rightarrow>\<^sub>A m \<Down> ps'"
            and m1: "m \<le> n'" and Q: "Q (ps', n'-m)" by blast
      from big_step_t3_post_dom_conv[OF d] have klong: "dom ps' = dom ps" .
      show ?thesis
        apply(rule exI[where x=ps']) apply(rule exI[where x="m+1"])
          apply safe
            apply(rule big_step_t_part.IfTrue)
              apply (rule dom)
              apply fact
               apply (rule True)
           apply (rule d)
           apply simp
        using m1 Suc apply simp
           using Q Suc by force
    next
      case False
      with F[OF P dom] obtain ps' m where d: "(c\<^sub>2, ps) \<Rightarrow>\<^sub>A m \<Down> ps'"
            and m1: "m \<le> n'" and Q: "Q (ps', n'-m)" by blast
      from big_step_t3_post_dom_conv[OF d] have "dom ps' = dom ps" .
      show ?thesis
        apply(rule exI[where x=ps']) apply(rule exI[where x="m+1"])
          apply safe
            apply(rule big_step_t_part.IfFalse)
          apply fact
          apply fact
               apply (rule False)
           apply (rule d)
          apply simp
        using m1 Suc apply simp
           using Q Suc by force
       qed
     qed
next
  case (Frame P C Q F)
  then show ?case using FrameRuleSound by auto
next
  case (Seq P C\<^sub>1 Q C\<^sub>2 R)
  show ?case unfolding hoare3_valid_def
  proof (safe, goal_cases)
    case (1 ps n)
    with Seq(3)[unfolded hoare3_valid_def] obtain ps' m where C1: "(C\<^sub>1, ps) \<Rightarrow>\<^sub>A m \<Down> ps'"
          and m: "m \<le> n" and Q: "Q (ps', n - m)" by blast
    with Seq(4)[unfolded hoare3_valid_def] obtain ps'' m' where C2: "(C\<^sub>2, ps') \<Rightarrow>\<^sub>A m' \<Down> ps''"
          and m': "m' \<le> n - m" and R: "R (ps'', n - m - m')" by blast
    have a: "(C\<^sub>1;; C\<^sub>2, ps) \<Rightarrow>\<^sub>A m + m' \<Down> ps''" apply(rule big_step_t_part.Seq)
        apply fact+ by simp
    have b: "m + m' \<le> n" using m' m by auto
    have c: "R (ps'', n - (m + m'))" using R by simp
    show ?case apply(rule exI[where x=ps'']) apply(rule exI[where x="m+m'"])
      using a b c by auto
  qed
next
  case (While P b C)
  show ?case  unfolding hoare3_valid_def apply auto  apply (auto simp: dollar_def)
  proof (goal_cases)
    case (1 ps n)
    from 1 show ?case
      proof(induct n arbitrary: ps rule: less_induct)
        case (less x ps3)

      show ?case
      proof(cases "pbval b ps3")
        case True
        \<comment> \<open>prepare premise to obtain ...\<close>
        from less(2) obtain x' where P: "P (ps3, x')" and dom: "vars b \<subseteq> dom ps3"  and Suc: "x = Suc x'" unfolding sep_conj_def dollar_def by auto
        from P dom True have
           g: "((\<lambda>(s, n). P (s, n) \<and> lmaps_to_axpr b True s)) (ps3, x')"
            unfolding dollar_def by auto
        \<comment> \<open>... the loop body from the outer IH\<close>
        from While(2)[unfolded hoare3_valid_def] g obtain ps3' x'' where C: "(C, ps3) \<Rightarrow>\<^sub>A x'' \<Down> ps3'" and x: "x'' \<le> x'" and P': "(P \<and>* $ 1) (ps3', x' - x'')" by blast
        then obtain x''' where P'': "P (ps3', x''')"  and Suc'': "x' - x'' = Suc x'''" unfolding sep_conj_def dollar_def by auto

        from C big_step_t3_post_dom_conv have "dom ps3 = dom ps3'" by simp
        with dom have dom': "vars b \<subseteq> dom ps3'" by auto

        \<comment> \<open>prepare premises to ...\<close>
        from C big_step_t3_gt0 have gt0: "x'' > 0" by auto
        have "\<exists>ps' m. (WHILE b DO C, ps3') \<Rightarrow>\<^sub>A m \<Down> ps' \<and> m \<le> (x - (1 + x'')) \<and> P (ps', (x - (1 + x'')) - m) \<and> vars b \<subseteq> dom ps' \<and> \<not> pbval b ps'"
          apply(rule less(1))
          using gt0 x Suc apply simp
            using dom' Suc P' unfolding dollar_def sep_conj_def
            by force
        \<comment> \<open>... obtain the tail of the While loop from the inner IH\<close>
        then obtain ps3'' m where w: "((WHILE b DO C, ps3') \<Rightarrow>\<^sub>A m \<Down> ps3'')"
                    and m'': "m \<le> (x - (1 + x''))" and P'': "P (ps3'', (x - (1 + x'')) - m)"
                    and dom'': "vars b \<subseteq> dom ps3''" and b'': "\<not> pbval b ps3''" by auto

        \<comment> \<open>combine body and tail to one loop unrolling:\<close>
        \<comment> \<open>- the Bigstep Semantic\<close>
        have BigStep: "(WHILE b DO C, ps3) \<Rightarrow>\<^sub>A 1 + x'' + m \<Down> ps3''"
          apply(rule big_step_t_part.WhileTrue)
              apply (fact True) apply (fact dom) apply (fact C) apply (fact w) by simp
        \<comment> \<open>- the TimeBound\<close>
        have TimeBound: "1 + x'' + m \<le> x"
          using m'' Suc'' Suc by simp
        \<comment> \<open>- the invariantPreservation\<close>
        have invariantPreservation: "P (ps3'', x - (1 + x'' + m))" using P'' m'' by auto

        \<comment> \<open>finally combine BigStep Semantic, TimeBound, invariantPreservation\<close>
        show ?thesis
          apply(rule exI[where x="ps3''"])
          apply(rule exI[where x="1 + x'' + m"])
            using BigStep TimeBound invariantPreservation dom'' b'' by blast
      next
        case False
        from less(2) obtain x' where P: "P (ps3, x')" and dom: "vars b \<subseteq> dom ps3" and Suc: "x = Suc x'" unfolding sep_conj_def
          by force
        show ?thesis
        apply(rule exI[where x=ps3])
        apply(rule exI[where x="Suc 0"]) apply safe
            apply (rule big_step_t_part.WhileFalse)
        subgoal using dom by simp
            apply fact
        using Suc apply simp
        using P Suc apply simp
          using dom apply auto
          using False apply auto done
      qed
    qed
  qed
next
  case (conseq P c Q P' Q')
  then show ?case unfolding hoare3_valid_def by metis
next
  case (normalize P m C Q n)
  then show ?case unfolding hoare3_valid_def
  apply(safe) proof (goal_cases)
    case (1 ps N)
    have Q2: "P (ps, N - (m - n))" apply(rule stardiff) by fact
    have mn: "m - n \<le> N" apply(rule stardiff(2)) by fact
    have P: "(P \<and>* $ m) (ps, N - (m - n) + m)"  unfolding sep_conj_def dollar_def
      apply(rule exI[where x="(ps,N - (m - n))"]) apply(rule exI[where x="(0,m)"])
      apply(auto simp: sep_disj_prod_def sep_disj_nat_def) by fact
    have " N - (m - n) + m =  N +n" using normalize(2)
      using mn by auto

    from P 1(3) obtain ps' m' where "(C, ps) \<Rightarrow>\<^sub>A m' \<Down> ps'" and m': "m' \<le> N - (m - n) + m" and Q: "(Q \<and>* $ n) (ps', N - (m - n) + m - m')" by blast
    have Q2: "Q (ps', (N - (m - n) + m - m') - n)" apply(rule stardiff) by fact
    have nm2: "n \<le> (N - (m - n) + m - m')" apply(rule stardiff(2)) by fact
    show ?case
      apply(rule exI[where x="ps'"]) apply(rule exI[where x="m'"])
      apply(safe)
        apply fact
        using Q2
        using \<open>N - (m - n) + m = N + n\<close> m' nm2 apply linarith
        using Q2 \<open>N - (m - n) + m = N + n\<close> by auto
    qed
next
  case (constancy P C Q R)
  from constancy(3) show ?case unfolding hoare3_valid_def
 apply safe proof (goal_cases)
    case (1 ps n)
    then obtain ps' m where C: "(C, ps) \<Rightarrow>\<^sub>A m \<Down> ps'" and m: "m \<le> n" and Q: "Q (ps', n - m)" by blast
    from C big_step_t3_same have "ps = ps' on UNIV - lvars C" by auto
    with constancy(2) 1(3) have "R ps'" by auto

    show ?case apply(rule exI[where x=ps']) apply(rule exI[where x=m])
      apply(safe)
         apply fact+ done
  qed
next
  case (Assign''' x ds v)
  then show ?case
    unfolding hoare3_valid_def apply auto
    subgoal for ps n apply(rule exI[where x="ps(x\<mapsto>v)"])
      apply(rule exI[where x="Suc 0"])
      apply safe
        apply(rule big_step_t_part.Assign)
        apply (auto)
         subgoal apply(subst (asm) separate_othogonal_commuted') by(auto simp: dollar_def pointsto_def)
         subgoal apply(subst (asm) separate_othogonal_commuted') by(auto simp: dollar_def pointsto_def)
         subgoal apply(subst (asm) separate_othogonal_commuted') by(auto simp: dollar_def pointsto_def)
         done
       done

next
  case (Assign'''' P a v x Q')
  show ?case

  unfolding hoare3_valid_def   apply auto
    proof (goal_cases)
      case (1 ps n)
      with Assign''''(3)[unfolded hoare3_valid_def] obtain ps' m
        where "(x ::= N v, ps) \<Rightarrow>\<^sub>A m \<Down> ps'" "m \<le> n" "Q' (ps', n - m)" by metis
      from 1(1) Assign''''(1)[unfolded symeval_def] have "paval' a ps = Some v" by auto
      show ?case apply(rule exI[where x=ps']) apply(rule exI[where x=m])
        apply safe
          apply(rule avalDirekt3_correct)
          apply fact+ done
    qed
next
  case (pureI P Q c R)
  then show ?case unfolding hoare3_valid_def by auto
qed

subsection \<open>Completeness\<close>

definition wp3 :: "com \<Rightarrow> assn2 \<Rightarrow> assn2" ("wp\<^sub>3") where
"wp\<^sub>3 c Q  =  (\<lambda>(s,n). \<exists>t m. n\<ge>m \<and> (c,s) \<Rightarrow>\<^sub>A m \<Down> t \<and> Q (t,n-m))"

lemma wp3_SKIP[simp]: "wp\<^sub>3 SKIP Q = (Q ** $1)"
  apply (auto intro!: ext simp: wp3_def)
    unfolding sep_conj_def dollar_def sep_disj_prod_def sep_disj_nat_def apply auto apply force
    subgoal for t n apply(rule exI[where x=t])  apply(rule exI[where x="Suc 0"])
      using big_step_t_part.Skip by auto
    done

lemma wp3_Assign[simp]: "wp\<^sub>3 (x ::= e) Q = ((\<lambda>(ps,t). vars e \<union> {x} \<subseteq> dom ps \<and> Q (ps(x \<mapsto> paval e ps),t)) ** $1)"
  apply (auto intro!: ext simp: wp3_def )
  unfolding sep_conj_def apply (auto simp: sep_disj_prod_def sep_disj_nat_def dollar_def) apply force
    by fastforce

lemma wpt_Seq[simp]: "wp\<^sub>3 (c\<^sub>1;;c\<^sub>2) Q = wp\<^sub>3 c\<^sub>1 (wp\<^sub>3 c\<^sub>2 Q)"
  apply (auto simp: wp3_def fun_eq_iff )
  subgoal for a b t m1 s2 m2
      apply(rule exI[where x="s2"])
      apply(rule exI[where x="m1"])
        apply simp
      apply(rule exI[where x="t"])
      apply(rule exI[where x="m2"])
      apply simp done
  subgoal for s m t' m1 t m2
      apply(rule exI[where x="t"])
      apply(rule exI[where x="m1+m2"])
    apply (auto simp: big_step_t_part.Seq) done
      done

lemma wp3_If[simp]:
 "wp\<^sub>3 (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = ((\<lambda>(ps,t). vars b \<subseteq> dom ps \<and> wp\<^sub>3 (if pbval b ps then c\<^sub>1 else c\<^sub>2) Q (ps,t)) ** $1)"
  apply (auto simp: wp3_def fun_eq_iff)
  unfolding sep_conj_def apply (auto simp: sep_disj_prod_def sep_disj_nat_def dollar_def)
  subgoal for a ba t x apply(rule exI[where x="ba - 1"]) apply auto
    apply(rule exI[where x=t]) apply(rule exI[where x=x]) apply auto done
  subgoal for a ba t x apply(rule exI[where x="ba - 1"]) apply auto
    apply(rule exI[where x=t]) apply(rule exI[where x=x]) apply auto done
  subgoal for a ba t m
    apply(rule exI[where x=t]) apply(rule exI[where x="Suc m"]) apply auto
    apply(cases "pbval b a")
    subgoal apply simp apply(subst big_step_t_part.IfTrue) using big_step_t3_post_dom_conv by auto
    subgoal apply simp apply(subst big_step_t_part.IfFalse) using big_step_t3_post_dom_conv by auto
  done
  done

lemma sFTrue: assumes "pbval b ps" "vars b \<subseteq> dom ps"
  shows "wp\<^sub>3 (WHILE b DO c) Q (ps, n) = ((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q) (ps, n) else Q (ps, n))) \<and>* $ 1) (ps, n)"
    (is "?wp = (?I \<and>* $ 1) _")
proof
  assume "wp\<^sub>3 (WHILE b DO c) Q (ps, n)"
  from this[unfolded wp3_def] obtain ps'' tt where tn: "tt \<le> n" and w1: "(WHILE b DO c, ps) \<Rightarrow>\<^sub>A tt \<Down> ps''" and Q: "Q (ps'', n - tt) " by blast
  with assms obtain t t' ps' where w2: "(WHILE b DO c, ps') \<Rightarrow>\<^sub>A t' \<Down> ps''" and c: "(c, ps) \<Rightarrow>\<^sub>A t \<Down> ps'" and tt: "tt=1+t+t'" by auto

  from tn obtain k where n: "n=tt+k"
    using le_Suc_ex by blast

  from assms show "(?I \<and>* $ 1) (ps,n)"
    unfolding sep_conj_def dollar_def  wp3_def  apply auto
    apply(rule exI[where x="t+t'+k"])
      apply safe subgoal using n tt by auto
      apply(rule exI[where x="ps'"])
    apply(rule exI[where x="t"])
    using c apply auto
      apply(rule exI[where x="ps''"])
    apply(rule exI[where x="t'"])
    using w2 Q n by auto
next
  assume "(?I \<and>* $ 1) (ps,n)"
  with assms have Q: "wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q) (ps, n-1)" and n: "n\<ge>1" unfolding dollar_def sep_conj_def by auto
  then obtain t ps' t' ps'' where t: "t \<le> n - 1"
        and c: "(c, ps) \<Rightarrow>\<^sub>A t \<Down> ps'" and  t': "t' \<le> (n-1) - t" and w: "(WHILE b DO c, ps') \<Rightarrow>\<^sub>A t' \<Down> ps''"
        and Q: "Q (ps'', ((n-1) - t) - t')"
    unfolding wp3_def by auto

  show "?wp" unfolding wp3_def
    apply simp apply(rule exI[where x="ps''"]) apply(rule exI[where x="1+t+t'"])
    apply safe
    subgoal using t t' n by simp
    subgoal using c w assms by auto
    subgoal using Q t t' n by simp
    done
qed

lemma sFFalse: assumes "~ pbval b ps" "vars b \<subseteq> dom ps"
  shows "wp\<^sub>3 (WHILE b DO c) Q (ps, n) = ((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q) (ps, n) else Q (ps, n))) \<and>* $ 1) (ps, n)"
    (is "?wp = (?I \<and>* $ 1) _")
proof
  assume "wp\<^sub>3 (WHILE b DO c) Q (ps, n)"
  from this[unfolded wp3_def] obtain ps' t where tn: "t \<le> n" and w1: "(WHILE b DO c, ps) \<Rightarrow>\<^sub>A t \<Down> ps'" and Q: "Q (ps', n - t) " by blast
  from assms have w2: "(WHILE b DO c, ps) \<Rightarrow>\<^sub>A 1 \<Down> ps" by auto
  from w1 w2 big_step_t_determ2 have t1: "t=1" and pps: "ps=ps'" by auto
  from assms show "(?I \<and>* $ 1) (ps,n)"
    unfolding sep_conj_def dollar_def using t1 tn Q pps apply auto  apply(rule exI[where x="n-1"]) by auto
next
  assume "(?I \<and>* $ 1) (ps,n)"
  with assms have Q: "Q(ps,n-1)" "n\<ge>1" unfolding dollar_def sep_conj_def by auto
  from assms have w2: "(WHILE b DO c, ps) \<Rightarrow>\<^sub>A 1 \<Down> ps" by auto
  show "?wp" unfolding wp3_def
    apply auto   apply(rule exI[where x=ps]) apply(rule exI[where x=1])
      using Q w2 by auto
qed

lemma sF': "wp\<^sub>3 (WHILE b DO c) Q (ps,n) = ((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q) (ps, n) else Q (ps, n))) \<and>* $ 1) (ps,n)"
  apply(cases "vars b \<subseteq> dom ps")
  subgoal apply(cases "pbval b ps") using sFTrue sFFalse by auto
  subgoal   by (auto simp add: dollar_def wp3_def sep_conj_def)
      done

lemma sF: "wp\<^sub>3 (WHILE b DO c) Q s = ((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q) (ps, n) else Q (ps, n))) \<and>* $ 1) s"
 using sF'
  by (metis (mono_tags, lifting) prod.case_eq_if prod.collapse sep_conj_impl1)

lemma assumes "\<And>Q. \<turnstile>\<^sub>3 {wp\<^sub>3 c Q} c {Q}"
  shows WhileWpisPre: "\<turnstile>\<^sub>3 {wp\<^sub>3 (WHILE b DO c) Q} WHILE b DO c { Q}"
proof -
  define I where  "I \<equiv> (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q) (ps, n) else Q (ps, n)))"

  from assms[where Q="(wp\<^sub>3 (WHILE b DO c) Q)"] have
    c: "\<turnstile>\<^sub>3 {wp\<^sub>3 c (wp\<^sub>3 (WHILE b DO c) Q)} c {(wp\<^sub>3 (WHILE b DO c) Q)}" .
  have c': "\<turnstile>\<^sub>3 { (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b True s) } c { I  ** $1 }"
    apply(rule conseq)
      apply(rule c)
    subgoal apply auto unfolding I_def by auto
    subgoal  unfolding I_def   using sF by auto
    done

  from hoareT3.While[where P="I"] c' have
    w: "\<turnstile>\<^sub>3 { (\<lambda>(s,n). I (s,n) \<and>  vars b \<subseteq> dom s) ** $1 } WHILE b DO c {  \<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b False s }" .

  show "\<turnstile>\<^sub>3 {wp\<^sub>3 (WHILE b DO c) Q} WHILE b DO c { Q}"
      apply(rule conseq)
      apply(rule w)
    subgoal using sF I_def
      by (smt Pair_inject R case_prodE case_prodI2)
    subgoal unfolding I_def by auto
    done
qed

definition hoareT3_validGC :: "assn2 \<Rightarrow> com \<Rightarrow> assn2 \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>G {(1_)}/ (_)/ { (1_)}" 50) where
"\<Turnstile>\<^sub>G { P } c { Q }  \<longleftrightarrow> \<Turnstile>\<^sub>3 { P } c { Q ** (%_.True) }"

end


theory locale_trail
imports Main
begin

definition nonempty::"'a list set"
  where
"nonempty = {xs . length xs > 1}"

definition appendlist where "appendlist x y = x@y"
lemma assoc:"(xs@ys)@zs = xs@(ys@zs)"
  apply(induction xs)
   apply auto
  done

locale comm =
  fixes S:: "'a set"
  and f::"'a \<Rightarrow> 'a \<Rightarrow>'a"
assumes "f (f x y) z = f x (f y z)"

interpretation random:comm "nonempty" "appendlist"
  apply(unfold_locales)
  apply(simp add:appendlist_def)
  done

end


theory Quantum_Separation_LogicDef
  imports QSemanticsBig Sep_Prod_Instance
begin

type_synonym ('s,'p) triplet = "('s state) assn \<times> 'p \<times> ('s state) assn"

context vars
begin

definition Q_sep_dis::"(('s state) \<Rightarrow> bool) \<Rightarrow> (('s state) \<Rightarrow> bool) \<Rightarrow>  (('s state) \<Rightarrow> bool)"
(infixr "\<and>*\<^sub>q" 35)
where "Q_sep_dis A B \<equiv> (\<lambda>s. fst s \<in> (fst ` {s. A s \<and> B s}) \<and>
                            (fst (snd s) \<in> (fst ` (snd ` {s. A s \<and> B s}))) \<and>
                            ((\<lambda>s. s \<in> (snd ` (snd ` {s. A s}))) \<and>*
                             (\<lambda>s. s \<in> (snd ` (snd ` {s. B s})))) (snd (snd s)))"

definition Q_sep_dis_set::"(('s state) set) \<Rightarrow> (('s state) set) \<Rightarrow>  (('s state) set)"
(infixr "\<and>\<^sup>*" 35)
where "Q_sep_dis_set A B \<equiv> let eq_stack = (fst ` (snd ` A)) \<inter> (fst ` (snd ` B));
                               eq_stack_S = (\<lambda>S. {s. s \<in> S \<and> fst (snd s) \<in> eq_stack})  in
                            {s. \<forall>s1 s2. s1 \<in> eq_stack_S A \<and> s2 \<in> eq_stack_S B \<and>
                                   fst (snd s1) = fst (snd s2) \<longrightarrow>
                                fst s = fst s1 * fst s2 \<and> fst (snd s) = fst (snd s1) \<and>
                               ((\<lambda>s. s \<in> (snd ` (snd ` {s. s = s1}))) \<and>*
                               (\<lambda>s. s \<in> (snd ` (snd ` {s. s = s2})))) (snd (snd s))}"

definition map_assn'::"'s expr_q \<Rightarrow> 's expr_q \<Rightarrow> ('s state, (complex) QState) expr \<Rightarrow> (('s state) set)"
 ("_\<cdot>_ \<mapsto> _"  [1000, 20, 1000] 60)
  where "map_assn' q1 q2 v \<equiv> let qv = (\<lambda>s. fst (get_qstate s));
                            qs = (\<lambda>s. snd (get_qstate s));
                            st = (\<lambda>s. get_stack s) in
                 {s. fst s = 1 \<and>(q1 (st s, qv s) \<union> q2 (st s, qv s)) \<noteq> {} \<and>
                      (\<exists>\<qq>' \<qq>''. (qs s) = (v s) \<and> (v s) = \<qq>' +  \<qq>'' \<and> \<qq>' ## \<qq>'' \<and>
                                (q1 (st s, qv s)) = QState_vars \<qq>' \<and>
                                (q1 (st s, qv s)) = QState_vars \<qq>')}"

(*definition map_assna::"('s,nat set) expr \<Rightarrow> ('s, (complex) QState) expr \<Rightarrow> (('s state) set)"
 ("_ \<mapsto> _"   [20, 1000] 60)
  where "map_assna q v \<equiv> let qv = (\<lambda>s. fst (get_qstate s));
                            qs = (\<lambda>s. snd (get_qstate s));
                            st = (\<lambda>s. get_stack s) in
                 {s. fst s = 1 \<and>(q1 (st s, qv s) \<union> q2 (st s, qv s)) \<noteq> {} \<and>
                      (\<exists>\<qq>' \<qq>''. (qs s) = (v s) \<and> (v s) = \<qq>' +  \<qq>'' \<and> \<qq>' ## \<qq>'' \<and>
                                (q1 (st s, qv s)) = QState_vars \<qq>' \<and>
                                (q1 (st s, qv s)) = QState_vars \<qq>')}" *)

definition map_assn::"'s expr_q \<Rightarrow> ('s state, (complex) QState) expr \<Rightarrow> (('s state) set)"  (infixr "\<mapsto>\<^sub>q" 35)
  where "map_assn f v \<equiv> let qv = (\<lambda>s. fst (get_qstate s));
                            qs = (\<lambda>s. snd (get_qstate s));
                            st = (\<lambda>s. get_stack s) in
                 {s. (f (st s, qv s)) \<noteq> {} \<and> (\<exists>\<qq>' \<qq>''. (qs s) = (v s) \<and> (v s) = \<qq>' +  \<qq>'' \<and> \<qq>' ## \<qq>'' \<and> (f (st s, qv s)) = QState_vars \<qq>')}"

definition map_assnl::"('s,nat) expr \<Rightarrow> ('s state, (complex) QState) expr \<Rightarrow> (('s state) set)"  (infixr "\<mapsto>\<^sub>l" 35)
  where "map_assnl f v \<equiv> let qv = (\<lambda>s. fst (get_qstate s));
                            qs = (\<lambda>s. snd (get_qstate s));
                            st = (\<lambda>s. get_stack s) in
                 {s. (qv s) (f (st s)) \<noteq> {} \<and> (\<exists>\<qq>'. (qs s) =  \<qq>' +  (v s) \<and> \<qq>' ## (v s) \<and> (qv s) (f (st s)) = QState_vars (v s))}"

definition aij::"'s expr_q \<Rightarrow> ('s state, (complex) QState) expr \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>'s state \<Rightarrow>  complex"
  where "aij v f i j\<equiv>  let qv = (\<lambda>s. fst (get_qstate s));
                            st = (\<lambda>s. get_stack s) in
                 (\<lambda>s. vector_element_12 (f s) (v (st s, qv s)) (i,j))"

definition v_f::"'s expr_q \<Rightarrow>( nat \<Rightarrow>'s state \<Rightarrow>  complex) \<Rightarrow> ('s state, (complex) QState) expr"
  where "v_f q f \<equiv> let qv = (\<lambda>s. fst (get_qstate s));
                            st = (\<lambda>s. get_stack s) in
                     (\<lambda>s. QState(q (st s, qv s), map (\<lambda>e. f e s) [0..<2^card (q (st s, qv s))]))"

definition valid::"[('s state) assn,('v, 's) com,('s state) assn] \<Rightarrow> bool"
    ("\<Turnstile>_ _ _"  [1000, 20, 1000] 60)
    where "\<Turnstile> P c Q \<equiv> \<forall>\<sigma> \<sigma>'. \<turnstile> \<langle>c,\<sigma>\<rangle> \<Rightarrow> \<sigma>' \<longrightarrow> \<sigma> \<in> Normal ` P \<longrightarrow> \<sigma>' \<noteq> Fault \<longrightarrow>
                            \<sigma>' \<in> Normal ` Q"

inductive "hoarep"::"[('s state) assn,('v,'s) com, ('s state) assn] => bool"
    ("\<turnstile>(_/ (_)/ _)" [1000,20,1000]60)
where
  Skip: "\<turnstile> Q Skip Q"

| SMod: "\<turnstile>{s.  set_stack s (f (get_stack s)) \<in> Q} (SMod f) Q"

| QMod: " \<turnstile> {s. q_v = fst (get_qstate s) \<and> q_s = snd (get_qstate s) \<and> st = get_stack s \<and>
                (qs (st,q_v)) \<subseteq> QState_vars q_s \<and>
                set_qstate s (matrix_sep (qs (st,q_v)) (get_qstate s) M) \<in> Q}
                (QMod M qs)
             Q"

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

| Cond: "\<lbrakk>\<turnstile>(P \<inter> {s. get_stack s \<in> b}) c\<^sub>1 Q; \<turnstile>(P \<inter> {s. get_stack s \<in> - b}) c\<^sub>2 Q\<rbrakk>
         \<Longrightarrow>
         \<turnstile> P (IF b c\<^sub>1 c\<^sub>2) Q"

| While: "\<turnstile> (P \<inter> {s. get_stack s \<in> b}) c\<^sub>1 P
          \<Longrightarrow>
          \<turnstile> P (While b c\<^sub>1) (P \<inter> {s. get_stack s \<in> - b})"

(* | QAlloc: " \<turnstile> {s. qv = fst (get_qstate s) \<and> qs = snd (get_qstate s) \<and> st = get_stack s \<and>
                  length (v st) = (e st) \<and> e st \<noteq> 0 \<and>
                  vs = (SOME x. x \<in>new_q_addr e s) \<and> q' = (SOME q. q \<notin> (dom_q_vars qv)) \<and>
                  set_stack
                      (set_qstate s (qv (q':=vs) , qs + QState (vs ,(v st)) ) )
                      (set_value st q (from_nat q'))
                    \<in> Q}
              (Alloc q e v) Q" *)

| QAlloc:"qv = (\<lambda>s. fst (get_qstate s)) \<and> st =(\<lambda>s. get_stack s) \<Longrightarrow>
          not_access_locals v \<Longrightarrow>
          \<turnstile> {s. ((qv s)(qa (st s)) = {}) \<and>
                   length (v (st s)) = (e (st s)) \<and>
                   QState_list (Qs s) = (v (st s)) \<and>
                 (set_stack s (set_value (st s) q (from_nat (qa (st s))))) \<in> (qa \<mapsto>\<^sub>l Qs)}
              (Alloc q e v) (qa \<mapsto>\<^sub>l Qs)"

| QDispose: "qv = (\<lambda>s. fst (get_qstate s)) \<and> st =(\<lambda>s. get_stack s) \<Longrightarrow>
             (\<forall>s st1 st2. st1\<noteq>st2 \<longrightarrow> Qs (set_stack s st1) = Qs (set_stack s st2)) \<Longrightarrow>
              \<exists>Q n. P = ((q \<mapsto>\<^sub>l Qs) \<inter> {s. n = vec_norm (QState_vector (Qs s)) } \<inter>
              {s. set_qstate s ((qv s) ((q (st s)):={}),\<qq>' + n \<cdot>\<^sub>q |>) \<in>Q}) \<Longrightarrow>
              \<turnstile> P (Dispose q) Q"

(* | QMeasure1: " \<turnstile> {s.  \<exists>k. pr = get_prob s \<and> qv = fst (get_qstate s) \<and> qs = snd (get_qstate s) \<and> st = get_stack s \<and>
                 q (st, qv) \<subseteq> (QState_vars qs) \<and>
                 (\<delta>k, q') = measure_vars k (q (st, qv)) (qv,qs) \<and>
                 st' = set_value st v (from_nat (pr * \<delta>k)) \<and>
                set_prob (set_stack (set_qstate s q') st') (pr * \<delta>k) \<in> Q}
               (Measure v q) Q"  *)

| QMeasure: "qv = (\<lambda>s. fst (get_qstate s)) \<and> st = (\<lambda>s. get_stack s)  \<Longrightarrow>
             (\<forall>s st1 st2. st1\<noteq>st2 \<longrightarrow> Qs (set_stack s st1) = Qs (set_stack s st2)) \<Longrightarrow>
             \<rho> = (\<lambda>i s. (\<Sum>j\<in> (QState_vars (Qs s) - (q (st s, qv s))). norm (aij q Qs i j s )^2) /
                        (\<Sum>i\<in>q (st s, qv s). \<Sum>j\<in> (QState_vars (Qs s) - (q (st s, qv s))). norm (aij q Qs i j s )^2 )) \<Longrightarrow>
             \<Psi> = (\<lambda>i. ((q \<cdot> (\<lambda>s. {}) \<mapsto>  (\<lambda>s. QState (q (st s, qv s), unit_vecl (2^card (q (st s, qv s))) i))) \<and>\<^sup>*
                        (qr \<cdot> (\<lambda>s. {}) \<mapsto> (v_f qr (\<lambda>j s. (aij q Qs i j s) / sqrt (\<rho> i s)) )))) \<Longrightarrow>
               \<turnstile> ((q \<cdot> qr \<mapsto> Qs) \<inter> ({s. \<exists>i\<in>q (st s, qv s). \<Phi> (set_stack s (set_value (st s) v (from_nat i)))}))
                    (Measure v q)
                  ((\<Union>i\<in>A. \<Psi> i) \<inter> {s. \<Phi> s})"

| Frame: "\<turnstile> P c Q \<Longrightarrow> {v. (\<exists>p q. access_v  (\<lambda>s. (p, (s,q)) \<in> A) v = True)} \<inter>
                      modify_locals c = {} \<Longrightarrow> \<turnstile> (P \<and>\<^sup>* A) c (Q \<and>\<^sup>* A)"

| Conseq: "\<forall>s \<in> P. \<exists>P' Q'. \<turnstile> P' c Q' \<and> s \<in> P' \<and> Q' \<subseteq> Q
           \<Longrightarrow> \<turnstile> P c Q"

lemma alloc_sound:
  assumes a0: "qv = (\<lambda>s. fst (get_qstate s)) \<and> st = get_stack" and
   a1:"not_access_locals v"
  shows "\<Turnstile>{s. qv s (qa (st s)) = {} \<and>
          length (v (st s)) = e (st s) \<and>
          QState_list (Qs s) = v (st s) \<and>
          set_stack s (set_value (st s) q (from_nat (qa (st s)))) \<in> (qa \<mapsto>\<^sub>l Qs)} q:=alloc[e] v (qa \<mapsto>\<^sub>l Qs)"
proof-
  { fix \<sigma> \<sigma>'
     assume a00:"\<turnstile> \<langle>q:=alloc[e] v,\<sigma>\<rangle> \<Rightarrow> \<sigma>'" and
            a01:"\<sigma> \<in> Normal `
              {s. qv s (qa (st s)) = {} \<and>
                length (v (st s)) = e (st s) \<and>
                QState_list (Qs s) = v (st s) \<and>
                set_stack s (set_value (st s) q (from_nat (qa (st s)))) \<in> (qa \<mapsto>\<^sub>l Qs)}" and
            a02:"\<sigma>' \<noteq> Fault"
     have "\<sigma>' \<in> Normal ` (qa \<mapsto>\<^sub>l Qs)" sorry
   } thus ?thesis unfolding valid_def by auto
qed

lemma quantum_separation_logic_sound:
 "\<turnstile> P c Q \<Longrightarrow> \<Turnstile> P c Q"
proof(induct rule:hoarep.induct)
case (Skip Q)
  then show ?case unfolding valid_def
    by (auto elim: QExec_Normal_elim_cases)
next
  case (SMod f Q)
  then show ?case unfolding valid_def
    unfolding get_stack_def set_stack_def get_prob_def get_qstate_def
    by (fastforce intro: QExec_Normal_elim_cases(3))
next
  case (QMod q_v q_s st qs M Q)
  then show ?case unfolding valid_def
    unfolding get_stack_def set_qstate_def get_prob_def get_qstate_def
    by (fastforce intro: QExec_Normal_elim_cases(4)[of M])
next
  case (Seq P c\<^sub>1 R c\<^sub>2 Q)
  have valid_c1:"\<Turnstile>P c\<^sub>1 R" by fact
  have valid_c2:"\<Turnstile>R c\<^sub>2 Q" by fact
  show ?case
  proof-
  { fix \<sigma> \<sigma>'
    assume exec:" \<turnstile> \<langle>c\<^sub>1;; c\<^sub>2,Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>'"
    assume not_in_f:"\<sigma>' \<noteq> Fault "
    assume P:"\<sigma> \<in> P"
    from exec P obtain r where
      exec_c1: "\<turnstile>\<langle>c\<^sub>1,Normal \<sigma>\<rangle> \<Rightarrow> r" and exec_c2:  "\<turnstile>\<langle>c\<^sub>2,r\<rangle> \<Rightarrow> \<sigma>'"
      by cases auto
    with not_in_f have not_in_f_r:"r \<noteq> Fault"
      by (auto dest: exec_Fault_end)
    with valid_c1 exec_c1 P
    have r: "r\<in>Normal ` R"
      unfolding valid_def by auto
    have "\<sigma>' \<in> Normal ` Q"
    proof(cases r)
      case (Normal r')
      with exec_c2 r show ?thesis
        using valid_c2 not_in_f unfolding valid_def by auto
    next
      case Fault
      then show ?thesis using not_in_f_r by auto
    qed
  } thus ?case unfolding valid_def by auto
qed
next
  case (Cond P b c\<^sub>1 Q c\<^sub>2)
  have valid_c1:"\<Turnstile>(P \<inter> {s. get_stack s \<in> b}) c\<^sub>1 Q" by fact
  have valid_c2:"\<Turnstile>(P \<inter> {s. get_stack s \<in> - b}) c\<^sub>2 Q" by fact
  show "\<Turnstile>P IF b c\<^sub>1 c\<^sub>2 Q"
  proof-
    { fix \<sigma> \<sigma>'
      assume exec: "\<turnstile>\<langle>IF b c\<^sub>1 c\<^sub>2,Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>'"
      assume P: "\<sigma> \<in> P"
      assume t_notin_F: "\<sigma>' \<noteq> Fault"
      have "\<sigma>' \<in> Normal ` Q"
      proof(cases "get_stack \<sigma> \<in> b")
        case True
        with exec have "\<turnstile>\<langle>c\<^sub>1,Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>'"
          by cases (auto simp add: get_stack_def)
        with P True show ?thesis
          using valid_c1 t_notin_F
          unfolding valid_def get_stack_def by auto
      next
        case False
        with exec have "\<turnstile>\<langle>c\<^sub>2,Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>'"
          by cases (auto simp add: get_stack_def)
        with P False show ?thesis
          using valid_c2 t_notin_F
          unfolding valid_def get_stack_def by auto
      qed
    } thus ?case unfolding valid_def by auto
  qed
next
  case (While P b c)
  have valid_c: "\<Turnstile>(P \<inter> {s. get_stack s \<in> b}) c P" by fact
  show ?case
  proof-
  { fix \<sigma> \<sigma>'
    assume exec: "\<turnstile>\<langle>While b c,Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>'"
    assume P: "\<sigma> \<in> P"
    assume t_notin_F: "\<sigma>' \<noteq> Fault"
    have "\<sigma>' \<in> Normal ` (P \<inter> {s. get_stack s \<in> - b})"
    proof (cases "\<sigma> \<in> {s. get_stack s \<in> b}")
      case True
      {  fix d::"('v,'s) com" fix \<sigma> \<sigma>'
         assume exec: "\<turnstile>\<langle>d,\<sigma>\<rangle> \<Rightarrow> \<sigma>'"
         assume d: "d=While b c"
         from exec d
         have "\<lbrakk>\<sigma> \<in> Normal ` P; \<sigma>' \<noteq> Fault \<rbrakk>
               \<Longrightarrow> \<sigma>' \<in> Normal ` (P \<inter> {s. get_stack s \<in> - b})"
         proof (induct)
           case (WhileTrue \<sigma> b' c' \<delta> \<Q> \<sigma>' \<sigma>'')
           have t_notin_F: "\<sigma>'' \<noteq> Fault" by fact
           have eqs: "While b' c' = While b c" by fact
           note valid_c
           moreover from WhileTrue
           obtain "\<turnstile>\<langle>c,Normal (\<delta>, \<sigma>, \<Q>)\<rangle> \<Rightarrow> \<sigma>'" and
              "\<turnstile>\<langle>While b c,\<sigma>'\<rangle> \<Rightarrow> \<sigma>''" and
            "Normal (\<delta>, \<sigma>, \<Q>) \<in> Normal `(P \<inter> {s. get_stack s \<in> b})"
             unfolding get_stack_def by auto
           moreover with t_notin_F have "\<sigma>' \<noteq> Fault"
             using exec_Fault_end by blast
           ultimately
           have r: "\<sigma>' \<in> Normal ` P" unfolding valid_def
             by - auto
           from this _
           show "\<sigma>'' \<in> Normal ` (P \<inter> {s. get_stack s \<in> - b})"
           proof(cases \<sigma>')
             case (Normal \<sigma>1')
             then show ?thesis
               using r  eqs t_notin_F
               by - (rule WhileTrue.hyps,auto)
           next
             case Fault with r show ?thesis by blast
           qed
         qed (auto simp add: get_stack_def)
       } with exec P t_notin_F show ?thesis by auto
    next
      case False with exec P have "\<sigma>' = Normal \<sigma>"
        unfolding get_stack_def
        by cases auto
      with P False show ?thesis by auto
    qed
  } thus ?case unfolding valid_def by auto
  qed
next
  case (QAlloc qv st v qa e Qs q)
  then show ?case using alloc_sound by auto
next
  case (QDispose qv st Qs P q \<qq>' Q)
  then show ?case sorry
next
  case (QMeasure qv st Qs \<rho> q \<Psi> qr \<Phi> v A)
  then show ?case sorry
next
  case (Frame P c Q A)
  then show ?case sorry
next
  case (Conseq P c Q)
  hence adapt: "\<forall>s \<in> P. (\<exists>P' Q' A'. \<Turnstile> P' c Q'  \<and>
                          s \<in> P' \<and> Q' \<subseteq> Q )"
    by blast
  then show "\<Turnstile> P c Q"
  proof-
  {
    fix s t
    assume exec: "\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t"
    assume P: "s \<in> P"
    assume t_notin_F: "t \<noteq> Fault"
    have "t \<in> Normal ` Q"
    proof-
      from P adapt obtain P' Q' Z where
         spec:"\<Turnstile> P' c Q'"  and
        P': "s \<in> P'"  and  strengthen: "Q' \<subseteq> Q "
        by auto
      from spec [rule_format]  exec P' t_notin_F
      have "t \<in> Normal ` Q'" unfolding valid_def by auto
      with strengthen show ?thesis by blast
    qed
  } thus ?thesis unfolding valid_def by auto qed
qed

end
end


theory SINVAR_Dependability_impl
imports SINVAR_Dependability "../TopoS_Interface_impl"
begin

code_identifier code_module SINVAR_Dependability_impl => (Scala) SINVAR_Dependability

subsubsection {* SecurityInvariant Dependability List Implementation *}

text {* Less-equal other nodes depend on the output of a node than its dependability level. *}
fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> set (edgesL G). (num_reachable G e1) \<le> (nP e1))"

value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 3)"
value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 2)"

text{* Generate a valid configuration to start from: *}
   fun dependability_fix_nP :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<Rightarrow> dependability_level)" where
      "dependability_fix_nP G nP = (\<lambda>v. let nr = num_reachable G v in (if nr \<le> (nP v) then (nP v) else nr))"

   theorem dependability_fix_nP_impl_correct: "wf_list_graph G \<Longrightarrow> dependability_fix_nP G nP  = SINVAR_Dependability.dependability_fix_nP (list_graph_to_graph G) nP"
   by(simp add: num_reachable_correct fun_eq_iff)

   value "let G = \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,1), (2,1), (3,1), (4,1), (1,2), (1,3)] \<rparr> in (let nP = dependability_fix_nP G (\<lambda>e. 0) in map (\<lambda>v. nP v) (nodesL G))"

   value "let G = \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,1)] \<rparr> in (let nP = dependability_fix_nP G (\<lambda>e. 0) in map (\<lambda>v. nP v) (nodesL G))"

definition Dependability_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<times> 'v) list list" where
  "Dependability_offending_list = Generic_offending_list sinvar"

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_Dependability.default_node_properties))"

definition "Dependability_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_Dependability.default_node_properties P))"

lemma sinvar_correct: "wf_list_graph G \<Longrightarrow> SINVAR_Dependability.sinvar (list_graph_to_graph G) nP = sinvar G nP"
   apply(simp)
   apply(rule all_edges_list_I)
   apply(simp add: fun_eq_iff)
   apply(clarify)
   apply(rename_tac x)
   apply(drule_tac v="x" in  num_reachable_correct)
  apply presburger
done

interpretation Dependability_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_Dependability.default_node_properties
  and sinvar_spec=SINVAR_Dependability.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_Dependability.receiver_violation
  and offending_flows_impl=Dependability_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=Dependability_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(rule conjI)
   apply(simp add: TopoS_Dependability; fail)
  apply(intro allI impI)
  apply(fact sinvar_correct)
 apply(rule conjI)
  apply(unfold Dependability_offending_list_def)
  apply(intro allI impI)
  apply(rule Generic_offending_list_correct)
   apply(assumption)
  apply(simp only: sinvar_correct)
 apply(rule conjI)
  apply(intro allI)
  apply(simp only: NetModel_node_props_def)
  apply(metis Dependability.node_props.simps Dependability.node_props_eq_node_props_formaldef)
 apply(simp only: Dependability_eval_def)
 apply(intro allI impI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_Dependability])
 apply(simp only: sinvar_correct)
done

subsubsection {* Dependability packing *}
  definition SINVAR_LIB_Dependability :: "('v::vertex, SINVAR_Dependability.dependability_level) TopoS_packed" where
    "SINVAR_LIB_Dependability \<equiv>
    \<lparr> nm_name = ''Dependability'',
      nm_receiver_violation = SINVAR_Dependability.receiver_violation,
      nm_default = SINVAR_Dependability.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = Dependability_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = Dependability_eval
      \<rparr>"
  interpretation SINVAR_LIB_Dependability_interpretation: TopoS_modelLibrary SINVAR_LIB_Dependability
      SINVAR_Dependability.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_Dependability_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text {*Example: *}
  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. SINVAR_Dependability.default_node_properties)(1:=3, 2:=2, 3:=1, 4:=0, 8:=2, 9:=2, 10:=0))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. SINVAR_Dependability.default_node_properties)(1:=10, 2:=10, 3:=10, 4:=10, 8:=10, 9:=10, 10:=10))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. 2))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in Dependability_eval G  \<lparr>node_properties=[1\<mapsto>3, 2\<mapsto>2, 3\<mapsto>1, 4\<mapsto>0, 8\<mapsto>2, 9\<mapsto>2, 10\<mapsto>0] \<rparr>"

  value "Dependability_offending_list \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> (\<lambda> n. 2)"

hide_fact (open) sinvar_correct
hide_const (open) sinvar NetModel_node_props

end


theory Type_Checker
imports Exp Com
begin

  fun o_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<rightharpoonup> 'b list" where
    "o_map _ [] = Some []"
  | "o_map f (x#xs) = do { y \<leftarrow> f x; ys \<leftarrow> o_map f xs; Some (y#ys) }"

  fun (in -) o2b :: "unit option \<Rightarrow> bool" where
    "o2b None = False"
  | "o2b (Some _) = True"

  lemma (in -) o2b_alt: "o2b m \<longleftrightarrow> m\<noteq>None" by (cases m) auto

  type_synonym typing = "vname \<rightharpoonup> type"

  definition typing_of :: "(type \<times> vname) list \<Rightarrow> typing" where
    "typing_of l \<equiv> map_of (map (\<lambda>(t,v). (v,t)) l)"

  definition (in program_loc) "GT \<equiv> typing_of (program.globals p)"

  context program_loc begin

    context
      fixes fdecl :: fun_decl
    begin
      definition "LT \<equiv> typing_of (fun_decl.params fdecl @ fun_decl.locals fdecl)"
      definition "RT \<equiv> fun_decl.rtype fdecl"

      definition read_varty :: "vname \<rightharpoonup> type"
        where "read_varty x = do {
          case LT x of
            Some t \<Rightarrow> Some t
          | None \<Rightarrow> GT x
        }"

      abbreviation "assert_int t \<equiv> assert (t=TInt)"
      abbreviation "assert_ptr t \<equiv> assert (is_TPtr t)"

      context begin
        private abbreviation bin_int_op :: "_ \<Rightarrow> exp \<Rightarrow> exp \<rightharpoonup> type"
        where
          "bin_int_op tyeval e1 e2 \<equiv>
            tyeval e1 \<guillemotright>= (\<lambda>t1.
            tyeval e2 \<guillemotright>= (\<lambda>t2.
            assert_int t1 \<guillemotright>
            assert_int t2 \<guillemotright>
            Some TInt))
          "

        fun tyeval :: "exp \<rightharpoonup> type"
          and tyeval_l :: "lexp \<rightharpoonup> type"
        where
          "tyeval (Const c) = Some TInt"
        | "tyeval Null = Some TNull"
        | "tyeval (V x) = read_varty x"
        | "tyeval (Plus e1 e2) = do {
            t1\<leftarrow>tyeval e1;
            t2\<leftarrow>tyeval e2;
            case (t1,t2) of
              (TInt,TInt) \<Rightarrow> Some TInt
            | (TPtr t, TInt) \<Rightarrow> Some (TPtr t)
            | (TNull, TInt) \<Rightarrow> None  (* Here, type-checker rejects addition to null constant!*)
            | _ \<Rightarrow> None
          }"
        | "tyeval (Subst e1 e2) = do {
            t1\<leftarrow>tyeval e1;
            t2\<leftarrow>tyeval e2;
            case (t1,t2) of
              (TInt,TInt) \<Rightarrow> Some TInt
            | (TPtr T, TInt) \<Rightarrow> Some (TPtr T)
            | (TPtr T1, TPtr T2) \<Rightarrow> do { assert (T1=T2); Some (TInt) }
            | (TNull, _) \<Rightarrow> None  (* Here, type-checker rejects subtraction of null constant!*)
            | (_,TNull) \<Rightarrow> None  (* Here, type-checker rejects subtraction of null constant!*)
            | _ \<Rightarrow> None
          }"
        | "tyeval (Minus e) = do { t \<leftarrow> tyeval e; assert_int t; Some TInt }"
        | "tyeval (Div e1 e2) = bin_int_op tyeval e1 e2"
        | "tyeval (Mod e1 e2) = bin_int_op tyeval e1 e2"
        | "tyeval (Mult e1 e2) = bin_int_op tyeval e1 e2"
        | "tyeval (Less e1 e2) = bin_int_op tyeval e1 e2"  (* TODO: Ptr comparison!? *)
        | "tyeval (Not e) = do { t \<leftarrow> tyeval e; assert_int t; Some TInt }"
        | "tyeval (And e1 e2) = bin_int_op tyeval e1 e2"
        | "tyeval (Or e1 e2) = bin_int_op tyeval e1 e2"
        | "tyeval (Eq e1 e2) = do {
            t1\<leftarrow>tyeval e1;
            t2\<leftarrow>tyeval e2;
            case (t1,t2) of
              (TInt,TInt) \<Rightarrow> Some TInt
            | (TPtr _, TNull) \<Rightarrow> Some TInt
            | (TNull, TPtr _) \<Rightarrow> Some TInt
            | (TPtr t, TPtr t') \<Rightarrow> if t=t' then Some TInt else None
            | _ \<Rightarrow> None
          }"
        | "tyeval (New t e) = do {
            tyeval e \<guillemotright>= assert_int;
            Some (TPtr t)
          }"
        | "tyeval (Deref e) = do {
            t \<leftarrow> tyeval e;
            case t of TPtr t' \<Rightarrow> Some t' | _ \<Rightarrow> None
          }"
        | "tyeval (Ref e) = do {
            t \<leftarrow> tyeval_l e;
            Some (TPtr t)
          }"
        | "tyeval (Index e1 e2) = do {
            t1\<leftarrow>tyeval e1;
            tyeval e2 \<guillemotright>= assert_int;
            case t1 of TPtr t \<Rightarrow> Some t | _ \<Rightarrow> None
          }"

        | "tyeval_l (Derefl e) = do {
            t \<leftarrow> tyeval e;
            case t of
              TPtr t \<Rightarrow> Some t
            | _ \<Rightarrow> None
          }"

        | "tyeval_l (Indexl e1 e2) = do {
            t1\<leftarrow>tyeval e1;
            tyeval e2 \<guillemotright>= assert_int;
            case t1 of TPtr t \<Rightarrow> Some t | _ \<Rightarrow> None
          }"
    end

    definition "args_compat fd args \<equiv> do {
      argst \<leftarrow> o_map tyeval args;
      assert (map fst (fun_decl.params fd) = argst)
      }"

    definition "fun_compatv f args \<equiv> do {
      fdecl \<leftarrow> proc_table f;
      args_compat fdecl args
    }"

    definition "fun_compat x f args \<equiv> do {
      t \<leftarrow> read_varty x;
      fdecl \<leftarrow> proc_table f;
      args_compat fdecl args;
      assert (fun_decl.rtype fdecl = Some t)
    }"

    definition "fun_compatl le f args \<equiv> do {
      t \<leftarrow> tyeval_l le;
      fdecl \<leftarrow> proc_table f;
      args_compat fdecl args;
      assert (fun_decl.rtype fdecl = Some t)
    }"

    fun tycheck_com :: "com \<rightharpoonup> unit" where
      "tycheck_com SKIP = Some ()"
    | "tycheck_com (Assignl e1 e2) = do {
        t1 \<leftarrow> tyeval_l e1;
        t2 \<leftarrow> tyeval e2;
        assert (t1=t2)
      }"
    | "tycheck_com (Assign x e) = do {
        t1 \<leftarrow> read_varty x;
        t2 \<leftarrow> tyeval e;
        assert (t1=t2)
      }"
    | "tycheck_com (Seq c1 c2) = tycheck_com c1 \<guillemotright> tycheck_com c2"
    | "tycheck_com (If e c1 c2) = do {
        tyeval e \<guillemotright>= assert_int;
        tycheck_com c1;
        tycheck_com c2
      }"
    | "tycheck_com (While e c) = do {
        tyeval e \<guillemotright>= assert_int;
        tycheck_com c
      }"
    | "tycheck_com (Free e) = do {
        tyeval e \<guillemotright>= assert_ptr
      }"
    | "tycheck_com (Return e) = do {
        t \<leftarrow> tyeval e;
        assert (RT = Some t)
      }"
    | "tycheck_com (Returnv) = assert (RT=None)"
    | "tycheck_com (Callfunl e f args) = fun_compatl e f args"
    | "tycheck_com (Callfun x f args) = fun_compat x f args"
    | "tycheck_com (Callfunv f args) = fun_compatv f args"

    fun tm_com_ret :: "com \<Rightarrow> bool" where
      "tm_com_ret SKIP \<longleftrightarrow> RT=None"
    | "tm_com_ret (Assignl _ _) \<longleftrightarrow> RT=None"
    | "tm_com_ret (Assign _ _) \<longleftrightarrow> RT=None"
    | "tm_com_ret (Seq _ c2) \<longleftrightarrow> tm_com_ret c2"
    | "tm_com_ret (If _ c1 c2) \<longleftrightarrow> tm_com_ret c1 \<and> tm_com_ret c2"
    | "tm_com_ret (While _ _) \<longleftrightarrow> RT=None"
    | "tm_com_ret (Free _) \<longleftrightarrow> RT=None"
    | "tm_com_ret (Return _) \<longleftrightarrow> True"
    | "tm_com_ret (Returnv) \<longleftrightarrow> True"
    | "tm_com_ret (Callfunl _ _ _) \<longleftrightarrow> RT=None"
    | "tm_com_ret (Callfun _ _ _) \<longleftrightarrow> RT=None"
    | "tm_com_ret (Callfunv _ _) \<longleftrightarrow> RT=None"

    abbreviation "tm_com com \<equiv> o2b (tycheck_com com) \<and> tm_com_ret com"

  end

  definition tm_fdecl :: "fun_decl \<Rightarrow> bool" where
    "tm_fdecl fdecl \<equiv> tm_com fdecl (fun_decl.body fdecl)"

  definition "tm_prog \<equiv> \<forall>fdecl\<in>set (program.procs p). tm_fdecl fdecl"

  definition "wt_prog \<equiv> valid_program p \<and> tm_prog"
end

locale well_typed_program = valid_program +
  assumes tm: "tm_prog"
begin

  lemma valid_fun_bodyI:
    assumes "proc_table f = Some fd"
    shows "tm_com fd (fun_decl.body fd)"
    using assms tm
    unfolding tm_prog_def tm_fdecl_def proc_table_of_def
    using map_of_SomeD by fastforce

end

end


theory "AList-Utils-Nominal"
imports "AList-Utils" "Nominal-Utils"
begin

subsubsection \<open>Freshness lemmas related to associative lists\<close>

lemma domA_not_fresh:
  "x \<in> domA \<Gamma> \<Longrightarrow> \<not>(atom x \<sharp> \<Gamma>)"
  by (induct \<Gamma>, auto simp add: fresh_Cons fresh_Pair)

lemma fresh_delete:
  assumes "a \<sharp> \<Gamma>"
  shows "a \<sharp> delete v \<Gamma>"
using assms
by(induct \<Gamma>)(auto simp add: fresh_Cons)

lemma fresh_star_delete:
  assumes "S \<sharp>* \<Gamma>"
  shows "S \<sharp>* delete v \<Gamma>"
  using assms fresh_delete unfolding fresh_star_def by fastforce

lemma fv_delete_subset:
  "fv (delete v \<Gamma>) \<subseteq> fv \<Gamma>"
  using fresh_delete unfolding fresh_def fv_def by auto

lemma fresh_heap_expr:
  assumes "a \<sharp> \<Gamma>"
  and "(x,e) \<in> set \<Gamma>"
  shows "a \<sharp> e"
  using assms
  by (metis fresh_list_elem fresh_Pair)

lemma fresh_heap_expr':
  assumes "a \<sharp> \<Gamma>"
  and "e \<in> snd ` set \<Gamma>"
  shows "a \<sharp> e"
  using assms
  by (induct \<Gamma>, auto simp add: fresh_Cons fresh_Pair)

lemma fresh_star_heap_expr':
  assumes "S \<sharp>* \<Gamma>"
  and "e \<in> snd ` set \<Gamma>"
  shows "S \<sharp>* e"
  using assms
  by (metis fresh_star_def fresh_heap_expr')

lemma fresh_map_of:
  assumes "x \<in> domA \<Gamma>"
  assumes "a \<sharp> \<Gamma>"
  shows "a \<sharp> the (map_of \<Gamma> x)"
  using assms
  by (induct \<Gamma>)(auto simp add: fresh_Cons fresh_Pair)

lemma fresh_star_map_of:
  assumes "x \<in> domA \<Gamma>"
  assumes "a \<sharp>* \<Gamma>"
  shows "a \<sharp>* the (map_of \<Gamma> x)"
  using assms by (simp add: fresh_star_def fresh_map_of)

lemma domA_fv_subset: "domA \<Gamma> \<subseteq> fv \<Gamma>"
  by (induction \<Gamma>) auto

lemma map_of_fv_subset: "x \<in> domA \<Gamma> \<Longrightarrow> fv (the (map_of \<Gamma> x)) \<subseteq> fv \<Gamma>"
  by (induction \<Gamma>) auto

lemma map_of_Some_fv_subset: "map_of \<Gamma> x = Some e \<Longrightarrow> fv e \<subseteq> fv \<Gamma>"
  by (metis domA_from_set map_of_fv_subset map_of_SomeD option.sel)

subsubsection \<open>Equivariance lemmas\<close>

lemma domA[eqvt]:
  "\<pi> \<bullet> domA \<Gamma> = domA (\<pi> \<bullet> \<Gamma>)"
  by (simp add: domA_def)

lemma mapCollect[eqvt]:
  "\<pi> \<bullet> mapCollect f m = mapCollect (\<pi> \<bullet> f) (\<pi> \<bullet> m)"
unfolding mapCollect_def
by perm_simp rule

subsubsection \<open>Freshness and distinctness\<close>

lemma fresh_distinct_list:
 assumes "atom ` S \<sharp>* l"
 shows "S \<inter> set l = {}"
 using assms
 by (metis disjoint_iff_not_equal fresh_list_elem fresh_star_def image_eqI not_self_fresh)

lemma fresh_distinct_fv:
 assumes "atom ` S \<sharp>* l"
 shows "S \<inter> fv l = {}"
 using assms
 by (metis disjoint_iff_not_equal fresh_star_def fv_not_fresh image_eqI)

subsubsection \<open>Pure codomains\<close>

lemma domA_fv_pure:
  fixes \<Gamma> :: "('a::at_base \<times> 'b::pure) list"
  shows  "fv \<Gamma> = domA \<Gamma>"
  apply (induct \<Gamma>)
  apply simp
  apply (case_tac a)
  apply (simp)
  done

lemma domA_fresh_pure:
  fixes \<Gamma> :: "('a::at_base \<times> 'b::pure) list"
  shows  "x \<in> domA \<Gamma> \<longleftrightarrow> \<not>(atom x \<sharp> \<Gamma>)"
  unfolding domA_fv_pure[symmetric]
  by (auto simp add: fv_def fresh_def)

end