theory SepLogK_VCG
imports SepLogK_Hoare
begin

lemmas conseqS = conseq[where k=1, simplified]

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn2 bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

fun pre :: "acom \<Rightarrow> assn2 \<Rightarrow> assn2" where
"pre SKIP Q = ($1 ** Q)" |
"pre (x ::= a) Q = ((\<lambda>(ps,t). x\<in>dom ps \<and> vars a \<subseteq> dom ps \<and> Q (ps(x\<mapsto>(paval a ps)),t) ) ** $1)" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (
   $1 **  (\<lambda>(ps,n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C\<^sub>1 Q (ps,n)  else pre C\<^sub>2 Q (ps,n) )))" |
"pre ({I} WHILE b DO C) Q = (I ** $1)"

fun vc :: "acom \<Rightarrow> assn2 \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1 ;; C\<^sub>2) Q = ((vc C\<^sub>1 (pre C\<^sub>2 Q)) \<and> (vc C\<^sub>2 Q) )" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =  ( (\<forall>s. (I s \<longrightarrow> vars b \<subseteq> dom (fst s) ) \<and> ((\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b True s) s \<longrightarrow> pre C (I ** $ 1) s)
         \<and> ( (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b False s) s \<longrightarrow> Q s)) \<and> vc C (I  ** $ 1))"

lemma dollar0_left: "($ 0 \<and>* Q) = Q"
 apply rule unfolding dollar_def sep_conj_def
  by force

lemma vc_sound: "vc C Q \<Longrightarrow>  \<turnstile>\<^sub>3\<^sub>' {pre C Q} strip C { Q }"
proof (induct C arbitrary: Q)
  case Askip
  then show ?case
    apply simp
    apply(rule conseqS[OF Frame[OF Skip]])
        by (auto simp: dollar0_left)
next
  case (Aassign x1 x2)
  then show ?case
    apply simp
    apply(rule conseqS)
      apply(rule Assign4)
      apply auto done
next
  case (Aseq C1 C2)
  then show ?case   apply (auto intro: Seq)  done
next
  case (Aif b C1 C2)
  then have Aif1: "\<turnstile>\<^sub>3\<^sub>' {pre C1 Q} strip C1 {Q}"
        and Aif2: "\<turnstile>\<^sub>3\<^sub>' {pre C2 Q} strip C2 {Q}"  by auto
  show ?case apply simp
    apply (rule conseqS)
      apply(rule If[where P="%(ps,n).  (if pbval b ps then pre C1 Q (ps,n) else pre C2 Q (ps,n))" and Q="Q"])
    subgoal apply simp
      apply (rule conseqS) apply(fact Aif1) by auto
    subgoal apply simp
      apply (rule conseqS) apply(fact Aif2) by auto
     apply (auto simp: sep_conj_ac)
    unfolding sep_conj_def by blast
next
  case (Awhile I b C)
  then have
       dom : "\<And>s. (I s \<longrightarrow> vars b \<subseteq> dom (fst s) )"
      and i: "\<And>s.  (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b True s) s \<longrightarrow> pre C (I ** $ 1) s"
      and ii: "\<And>s.  (\<lambda>(s,n). I (s,n) \<and> lmaps_to_axpr b False s) s \<longrightarrow> Q s"
      and C: "\<turnstile>\<^sub>3\<^sub>' {pre C (I ** $ 1)} strip C {I ** $ 1}"
     by fastforce+

  show ?case
    apply simp
    apply(rule conseqS)
       apply(rule While[where P=I])
       apply(rule conseqS)
        apply(rule C)
    subgoal using i by auto
    subgoal apply simp using dom unfolding sep_conj_def by force
    subgoal apply simp using dom unfolding sep_conj_def by force
    subgoal using ii apply auto done
    done
qed

lemma vc2valid: "vc C Q \<Longrightarrow> \<forall>s. P s \<longrightarrow> pre C Q s \<Longrightarrow> \<Turnstile>\<^sub>3\<^sub>' {P} strip C { Q}"
  using hoareT_sound2_part weakenpre vc_sound by metis

lemma pre_mono: assumes "\<forall>s. P s \<longrightarrow> Q s" shows "\<And>s. pre C P s \<Longrightarrow> pre C Q s"
using assms proof(induct C arbitrary: P Q)
  case Askip
  then show ?case  apply (auto simp: sep_conj_def dollar_def)
    by force
next
  case (Aassign x1 x2)
  then show ?case by (auto simp: sep_conj_def dollar_def)
next
  case (Aseq C1 C2)
  then show ?case by auto
next
  case (Aif b C1 C2)
  then show ?case apply (auto simp: sep_conj_def dollar_def)
    subgoal for ps n
      apply(rule exI[where x=0])
      apply(rule exI[where x=1])
      apply(rule exI[where x=ps]) by auto
    done
next
  case (Awhile x1 x2 C)
  then show ?case by auto
qed

lemma vc_mono: assumes "\<forall>s. P s \<longrightarrow> Q s" shows "vc C P \<Longrightarrow> vc C Q"
using assms proof(induct C arbitrary: P Q)
  case Askip
  then show ?case by auto
next
  case (Aassign x1 x2)
  then show ?case  by auto
next
  case (Aseq C1 C2 P Q)
  then have i: "vc C1 (pre C2 P)" and ii: "vc C2 P" by auto
  from  pre_mono[OF ] Aseq(4) have iii: "\<forall>s. pre C2 P s \<longrightarrow> pre C2 Q s" by blast
  show ?case  apply auto
      using Aseq(1)[OF i  iii] Aseq(2)[OF ii Aseq(4)] by auto
next
  case (Aif x1 C1 C2)
  then show ?case  by auto
next
  case (Awhile I b C P Q)
  then show ?case by auto
qed

lemma vc_sound': "vc C Q \<Longrightarrow> (\<And>s n. P' (s, n) \<Longrightarrow> pre C Q (s, k * n)) \<Longrightarrow> (\<And>s n. Q (s, n) \<Longrightarrow> Q' (s, n div k)) \<Longrightarrow> 0 < k \<Longrightarrow> \<turnstile>\<^sub>3\<^sub>' {P'} strip C { Q'}"
  using conseq vc_mono vc_sound by metis

lemma pre_Frame: "(\<forall>s. P s \<longrightarrow> pre C Q s) \<Longrightarrow> vc C Q
     \<Longrightarrow> (\<exists>C'. strip C = strip C' \<and>  vc C' (Q ** F) \<and> (\<forall>s. (P ** F) s \<longrightarrow> pre C' (Q ** F) s) )"
proof (induct C arbitrary: P Q)
  case Askip
  show ?case
  proof (rule exI[where x="Askip"], safe)
    fix a b
    assume "(P \<and>* F) (a, b)"
    then obtain ps1 ps2 n1 n2 where A: "ps1##ps2" "a=ps1+ps2" "b=n1+n2"
      and P: "P (ps1,n1)" and F: "F (ps2,n2)" unfolding sep_conj_def by auto
    from P Askip have p: "($ (Suc 0) \<and>* Q) (ps1, n1)" by auto

    from p A F
    have "(($ (Suc 0) \<and>* Q) \<and>* F) (a, b)"
      apply(subst (2) sep_conj_def) by auto
    then show "pre SKIP (Q \<and>* F) (a, b)" by (simp add: sep_conj_ac)
  qed simp
next
  case (Aassign x a)
  show ?case
  proof (rule exI[where x="Aassign x a"], safe)
    fix ps n
    assume "(P \<and>* F) (ps,n)"
    then obtain ps1 ps2 n1 n2 where o: "ps1##ps2" "ps=ps1+ps2" "n=n1+n2"
      and P: "P (ps1,n1)" and F: "F (ps2,n2)" unfolding sep_conj_def by auto
    from P Aassign(1) have z: "((\<lambda>(ps, t). x \<in> dom ps \<and> vars a \<subseteq> dom ps \<and> Q (ps(x \<mapsto> paval a ps), t))
                                     \<and>* $ (Suc 0)) (ps1, n1)"
        by auto
    with o F show " pre (x ::= a) (Q \<and>* F) (ps,n)" apply auto
      unfolding sep_conj_def dollar_def apply (auto)
        subgoal by(simp add: plus_fun_def)
        subgoal by(auto simp add: plus_fun_def)
        subgoal
          by (smt add_update_distrib dom_fun_upd domain_conv insert_dom option.simps(3) paval_extend sep_disj_fun_def)
        done
  qed auto
next
  case (Aseq C1 C2)
  from Aseq(3) have pre: "\<forall>s. P s \<longrightarrow> pre C1 (pre C2 Q) s" by auto
  from Aseq(4) have vc1: "vc C1 (pre C2 Q)" and vc2: "vc C2 Q" by auto
  from Aseq(1)[OF pre vc1] obtain C1' where S1: "strip C1 = strip C1'"
      and vc1': "vc C1' (pre C2 Q \<and>* F)"
      and I1: "(\<forall>s. (P \<and>* F) s \<longrightarrow> pre C1' (pre C2 Q \<and>* F) s)" by blast
  from Aseq(2)[of "pre C2 Q" Q, OF _ vc2] obtain C2' where S2: "strip C2 = strip C2'"
      and vc2': "vc C2' (Q \<and>* F)"
      and I2: "(\<forall>s. (pre C2 Q \<and>* F) s \<longrightarrow> pre C2' (Q \<and>* F) s) " by blast

  show ?case apply(rule exI[where x="Aseq C1' C2'"])
    apply safe
    subgoal using S1 S2 by auto
    subgoal apply simp apply safe
      subgoal using vc_mono[OF I2 vc1'] .
      subgoal by (fact vc2')
    done
    subgoal using I1 I2 pre_mono
      by force
    done
next
  case (Aif b C1 C2)
  from Aif(3) have i: "\<forall>s. P s \<longrightarrow>
          ($ (Suc 0) \<and>*
           (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n))))
           s" by simp
  from Aif(4) have vc1: "vc C1 Q" and vc2: "vc C2 Q" by auto
  from Aif(1)[where P="pre C1 Q" and Q="Q", OF _ vc1] obtain C1' where
    s1: "strip C1 = strip C1'" and v1: "vc C1' (Q \<and>* F)"
    and p1: "(\<forall>s. (pre C1 Q \<and>* F) s \<longrightarrow> pre C1' (Q \<and>* F) s)"
    by auto
  from Aif(2)[where P="pre C2 Q" and Q="Q", OF _ vc2] obtain C2' where
    s2: "strip C2 = strip C2'" and v2: "vc C2' (Q \<and>* F)"
    and p2: "(\<forall>s. (pre C2 Q \<and>* F) s \<longrightarrow> pre C2' (Q \<and>* F) s)"
    by auto

  show ?case apply(rule exI[where x="Aif b C1' C2'"])
  proof safe
    fix ps n
    assume "(P \<and>* F) (ps, n)"
    then obtain ps1 ps2 n1 n2 where o: "ps1##ps2" "ps=ps1+ps2" "n=n1+n2"
      and P: "P (ps1,n1)" and F: "F (ps2,n2)" unfolding sep_conj_def by auto
    from P i have P': "($ (Suc 0) \<and>*
         (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n))))
         (ps1,n1)" by auto
    have PF: "(($ (Suc 0) \<and>*
         (\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n)))) ** F)
         (ps,n)" apply(subst (2) sep_conj_def)
        apply(rule exI[where x="(ps1,n1)"])
        apply(rule exI[where x="(ps2,n2)"])
      using F P' o by auto
    from this[simplified sep_conj_assoc] obtain ps1 ps2 n1 n2 where o: "ps1##ps2" "ps=ps1+ps2" "n=n1+n2"
      and P: "($ (Suc 0)) (ps1,n1)" and F: "((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then pre C1 Q (ps, n) else pre C2 Q (ps, n))) \<and>* F) (ps2,n2)"
      unfolding sep_conj_def apply auto by fast
    then have "((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then (pre C1 Q  \<and>* F) (ps, n) else (pre C2 Q  \<and>* F) (ps, n)))) (ps2,n2)"
      unfolding sep_conj_def apply auto
      apply (metis contra_subsetD domD map_add_dom_app_simps(1) plus_fun_conv sep_add_commute)
      using pbval_extend apply auto[1]
      apply (metis contra_subsetD domD map_add_dom_app_simps(1) plus_fun_conv sep_add_commute)
      using pbval_extend apply auto[1]    done
    then have "((\<lambda>(ps, n). vars b \<subseteq> dom ps \<and> (if pbval b ps then (pre C1' (Q \<and>* F)) (ps, n) else (pre C2' (Q \<and>* F)) (ps, n)))) (ps2,n2)"
      using p1 p2  by auto
    with o P
    show "pre (IF b THEN C1' ELSE C2') (Q \<and>* F) (ps, n)"
      apply auto apply(subst sep_conj_def) by force
  qed (auto simp: s1 s2 v1 v2)
next
  case (Awhile I b C)
  from Awhile(2) have pre: "\<forall>s. P s \<longrightarrow>  (I ** $1) s"  by auto
  from Awhile(3) have
    dom:  "\<forall>ps n. I (ps, n) \<longrightarrow> vars b \<subseteq> dom ps"
  and  tB: "\<forall>s. I s \<and> vars b \<subseteq> dom (fst s) \<and> pbval b (fst s) \<longrightarrow> pre C (I \<and>* $ (Suc 0)) s"
  and  fB: "\<forall>ps n. I (ps, n) \<and> vars b \<subseteq> dom ps \<and> \<not> pbval b ps \<longrightarrow> Q (ps, n)"
  and vcB: "vc C (I \<and>* $(Suc 0))" by auto
  from Awhile(1)[OF tB vcB] obtain C' where st: "strip C = strip C'"
    and vc': "vc C' ((I \<and>* $ (Suc 0)) \<and>* F)"
    and pre': "(\<forall>s. ((\<lambda>a. I a \<and> vars b \<subseteq> dom (fst a) \<and> pbval b (fst a)) \<and>* F) s \<longrightarrow>
            pre C' ((I \<and>* $ (Suc 0)) \<and>* F) s)"
    by auto
  show ?case apply(rule exI[where x="Awhile (I**F) b C'"])
    apply safe
    subgoal using st by simp
    subgoal apply simp apply safe
        subgoal using dom unfolding sep_conj_def apply auto
          by (metis domD sep_substate_disj_add subState subsetCE)
        subgoal  using pre' apply(auto simp: sep_conj_ac)
            apply(subst (asm)  sep_conj_def)
            apply(subst (asm)  sep_conj_def) apply auto
          by (metis dom pbval_extend sep_add_commute sep_disj_commuteI)
        subgoal using fB unfolding sep_conj_def apply auto
          using dom pbval_extend by fastforce
        subgoal using vc' apply(auto simp: sep_conj_ac) done
        done
      subgoal apply simp using pre unfolding sep_conj_def apply auto
        by (smt semiring_normalization_rules(23) sep_add_assoc sep_add_commute sep_add_disjD sep_add_disjI1)
      done
qed

lemma vc_complete: "\<turnstile>\<^sub>3\<^sub>a {P} c { Q } \<Longrightarrow> (\<exists>C. vc C Q \<and> (\<forall>s. P s \<longrightarrow> pre C Q s) \<and> strip C = c)"
proof(induct   rule: hoare3a.induct)
  case Skip
  then show ?case apply(rule exI[where x="Askip"]) by auto
next
  case (Assign4 x a Q)
  then show ?case apply(rule exI[where x="Aassign x a"]) by auto
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  from If(2) obtain C1 where A1: "vc C1 Q" "strip C1 = c\<^sub>1" and
    A2: "\<And>ps n. (P (ps, n) \<and> lmaps_to_axpr b True ps) \<longrightarrow> pre C1 Q (ps,n)"
    by blast
  from If(4) obtain C2 where B1: "vc C2 Q" "strip C2 = c\<^sub>2" and B2:
    "\<And>ps n. (P (ps, n) \<and> lmaps_to_axpr b False ps) \<longrightarrow> pre C2 Q (ps,n)"
    by blast

  show ?case apply(rule exI[where x="Aif b C1 C2"]) using A1 B1 apply auto
    subgoal for ps n
      unfolding sep_conj_def dollar_def apply auto
      apply(rule exI[where x="0"])
      apply(rule exI[where x="1"])
      apply(rule exI[where x="ps"])
      using A2 B2 by auto
  done
next
  case (Frame P C Q F)
  then obtain C' where vc: "vc C' Q" and pre: "(\<forall>s. P s \<longrightarrow> pre C' Q s)"
      and strip: "strip C' = C" by auto
  show ?case using pre_Frame[OF pre vc] strip by metis
next
  case (Seq P c\<^sub>1 Q c\<^sub>2 R)
  from Seq(2) obtain C1 where A1: "vc C1 Q" "strip C1 = c\<^sub>1" and
    A2: "\<And>s. P s \<longrightarrow> pre C1 Q s"
    by blast
  from Seq(4) obtain C2 where B1: "vc C2 R" "strip C2 = c\<^sub>2" and
    B2: "\<And>s. Q s \<longrightarrow> pre C2 R s"
    by blast
  show ?case apply(rule exI[where x="Aseq C1 C2"])
    using B1 A1 apply auto
    subgoal using vc_mono B2 by auto
    subgoal apply(rule pre_mono[where P=Q])  using  B2 apply auto
      using A2 by auto
    done
next
  case (While I b c)
  then obtain C where 1: "vc C ((\<lambda>(s, n). I (s, n) \<and> vars b \<subseteq> dom s) \<and>* $ 1)"
          "strip C = c" and 2:
         "\<And>ps n. (I (ps, n) \<and> lmaps_to_axpr b True ps) \<longrightarrow>
              pre C ((\<lambda>(s, n). I (s, n) \<and> vars b \<subseteq> dom s) \<and>* $ 1) (ps,n) " by blast

  show ?case apply(rule exI[where x="Awhile (\<lambda>(s, n). I (s, n) \<and> vars b \<subseteq> dom s) b C"])
    using 1 2 by auto
next
  case (conseqS P c Q P' Q')
  then obtain C' where C': "vc C' Q" "(\<forall>s. P s \<longrightarrow> pre C' Q s)" "strip C' = c"
    by blast
  show ?case apply(rule exI[where x=C'])
      using C' conseqS(3,4) pre_mono vc_mono by force
qed

theorem vc_completeness:
  assumes "\<Turnstile>\<^sub>3\<^sub>' {P} c { Q}"
  shows "\<exists>C k. vc C (Q ** sep_true)
          \<and> (\<forall>ps n. P (ps, n) \<longrightarrow> pre C (\<lambda>(ps, n). (Q ** sep_true) (ps, n div k)) (ps, k * n))
          \<and> strip C = c"
proof -
  let ?QG = "\<lambda>k (ps,n). (Q ** sep_true) (ps,n div k)"
  from assms obtain k where k[simp]: "k>0" and p: "\<And>ps n. P (ps, n) \<Longrightarrow> wp\<^sub>3\<^sub>' c (\<lambda>(ps, n). (Q ** sep_true) (ps, n div k)) (ps, k * n)"
    using valid_wp by blast

  from wpT_is_pre  have R: "\<turnstile>\<^sub>3\<^sub>a {wp\<^sub>3\<^sub>' c (?QG k)} c {?QG k}" by auto

  have z: "(\<forall>s. (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k)) s) \<Longrightarrow> (\<forall>s. (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n)) s)"
    by (metis (no_types) case_prod_conv k neq0_conv nonzero_mult_div_cancel_left old.prod.exhaust)

  have z: "\<And>ps n. ((Q \<and>* (\<lambda>s. True)) (ps, n div k) \<Longrightarrow> (Q \<and>* (\<lambda>s. True)) (ps, n))"
  proof -
    fix ps n
    assume "(Q \<and>* (\<lambda>s. True)) (ps, n div k) "
    then guess ps1 n1 ps2 n2 unfolding sep_conj_def by auto
    note o = this
    from o(4) have nn1: "n\<ge>n1" using k
      by (metis (full_types) add_leE div_le_dividend)
    show "(Q \<and>* (\<lambda>s. True)) (ps, n)" unfolding sep_conj_def
        apply(rule exI[where x="(ps1, n1)"])
      apply(rule exI[where x="(ps2, n - n1)"])
      using o nn1 by auto
  qed
  then have z': "\<forall>s. ((Q \<and>* (\<lambda>s. True)) (fst s, (snd s) div k) \<longrightarrow> (Q \<and>* (\<lambda>s. True)) s)"
    by (metis prod.collapse)

  from vc_complete[OF R]   guess C by auto
  note o = this

  have y: "\<And>ps n. P (ps, n) \<Longrightarrow>  pre C (\<lambda>(ps, n). (Q \<and>* (\<lambda>s. True)) (ps, n div k)) (ps, k * n)"
    using o p by metis

  show ?thesis apply(rule exI[where x=C])  apply(rule exI[where x=k])
    apply safe
    subgoal apply(rule vc_mono[OF _ o(1)]) using z  by blast
    subgoal using y by blast
    subgoal using o by simp
    done
qed

end


section \<open>Shallow Embedding of LLVM Semantics\<close>
theory LLVM_Shallow
imports Main
  "LLVM_Memory"
begin
  text \<open>We define a type synonym for the LLVM monad\<close>
  type_synonym 'a llM = "('a,unit,llvm_memory,err) M"
  translations
    (type) "'a llM" \<leftharpoondown> (type) "('a, unit, llvm_memory, err) M"

  subsection \<open>Shallow Embedding of Values\<close>

  text \<open>We use a type class to characterize types that can be injected into the value type.
    We will instantiate this type class to obtain injections from types of shape
    \<open>T = T\<times>T | _ word | _ ptr\<close>

    Although, this type class can be instantiated by other types, those will not be accepted
    by the code generator.

    We also define a class \<open>llvm_repv\<close>, which additionally contains \<open>unit\<close>.
    This is required for void functions, and if-the-else statements that produce no result.

    Again, while this class might be instantiated for other types, those will be rejected
    by the code generator.
  \<close>

  class llvm_repv

  class llvm_rep = llvm_repv +
    fixes to_val :: "'a \<Rightarrow> llvm_val"
      and from_val :: "llvm_val \<Rightarrow> 'a"
      and struct_of :: "'a itself \<Rightarrow> llvm_vstruct"
      and init :: 'a
    assumes from_to_id[simp]: "from_val o to_val = id"
    assumes to_from_id[simp]: "llvm_vstruct v = struct_of TYPE('a) \<Longrightarrow> to_val (from_val v) = v"
    assumes struct_of_matches[simp]: "llvm_vstruct (to_val x) = (struct_of TYPE('a))"
    assumes init_zero: "to_val init = llvm_zero_initializer (struct_of TYPE('a))"

  begin

    lemma from_to_id'[simp]: "from_val (to_val x) = x"
      using pointfree_idE[OF from_to_id] .

    lemma "to_val x = to_val y \<longleftrightarrow> x=y"
      by (metis from_to_id')

  end

  text \<open>We use a phantom type to attach the type of the pointed to value to a pointer.
    Note that we define pointers for any datatype. While it will always point to
    representable datatypes, this enables easy \<open>llvm_rep\<close> instantiations for recursive structures
    via pointers, such as linked list cells.
  \<close>
  datatype 'a ptr = PTR (the_raw_ptr: llvm_ptr)
  definition null :: "'a ptr" where "null = PTR llvm_null"

  text \<open>We instantiate the type classes for the supported types,
    i.e., unit, word, ptr, and prod.\<close>

  instance unit :: llvm_repv by standard

  instantiation word :: (len) llvm_rep begin
    definition "to_val w \<equiv> llvm_int (lconst (len_of TYPE('a)) (uint w))"
    definition "from_val v \<equiv> word_of_int (lint_to_uint (llvm_the_int v))"
    definition [simp]: "struct_of_word (_::'a word itself) \<equiv> llvm_s_int (len_of TYPE('a))"
    definition [simp]: "init_word \<equiv> 0::'a word"

    lemma int_inv_aux: "width i = LENGTH('a) \<Longrightarrow> lconst LENGTH('a) (uint (word_of_int (lint_to_uint i) :: 'a word)) = i"
      by (metis uint_const uint_eq uint_lower_bound uint_upper_bound width_lconst word_of_int_inverse word_ubin.norm_Rep)

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_word_def to_val_word_def)
      apply (auto simp: llvm_s_int_def llvm_zero_initializer_def llvm_int_def)
      subgoal for v apply (cases v)
        apply (auto simp: llvm_int_def llvm_the_int_def llvm_s_ptr_def llvm_struct_def llvm_ptr_def llvm_vstruct_def)
        using int_inv_aux apply (simp add: llvm_vstruct_def)
      done
      done

  end

  instantiation ptr :: (type) llvm_rep begin
    definition "to_val_ptr \<equiv> llvm_ptr o ptr.the_raw_ptr"
    definition "from_val_ptr v \<equiv> PTR (llvm_the_ptr v)"
    definition [simp]: "struct_of_ptr (_::'a ptr itself) \<equiv> llvm_s_ptr"
    definition [simp]: "init_ptr::'a ptr \<equiv> null"

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_ptr_def to_val_ptr_def)
      apply (auto simp: llvm_zero_initializer_def llvm_ptr_def llvm_s_ptr_def null_def llvm_null_def)
      subgoal for v apply (cases v)
        by (auto simp: llvm_s_int_def llvm_s_struct_def llvm_ptr_def llvm_the_ptr_def)
      done

  end

  instantiation prod :: (llvm_rep, llvm_rep) llvm_rep begin
    definition "to_val_prod \<equiv> \<lambda>(a,b). llvm_struct [to_val a, to_val b]"
    definition "from_val_prod p \<equiv> case llvm_the_struct p of [a,b] \<Rightarrow> (from_val a, from_val b)"
    definition [simp]: "struct_of_prod (_::('a\<times>'b) itself) \<equiv> llvm_s_struct [struct_of TYPE('a), struct_of TYPE('b)]"
    definition [simp]: "init_prod ::'a\<times>'b \<equiv> (init,init)"

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_prod_def to_val_prod_def)
      apply (auto simp: llvm_struct_def llvm_s_struct_def init_zero llvm_zero_initializer_def)
      subgoal for v
        apply (cases v)
        apply (auto simp: llvm_s_int_def llvm_s_ptr_def llvm_struct_def llvm_the_struct_def
          llvm_val.the_val_def llvm_vstruct_def split: prod.splits llvm_val.splits val.split)
        done
      done

  end

  lemma to_val_prod_conv[simp]: "to_val (a,b) = llvm_struct [to_val a, to_val b]"
    unfolding to_val_prod_def by auto

  text \<open>Checked conversion from value\<close>
  definition checked_from_val :: "llvm_val \<Rightarrow> 'a::llvm_rep llM" where
    "checked_from_val v \<equiv> doM {
      fcheck (STATIC_ERROR ''Type mismatch'') (llvm_vstruct v = struct_of TYPE('a));
      return (from_val v)
    }"

  subsection \<open>Instructions\<close>

  text \<open>The instructions are arranged in the order as they are described in the
    LLVM Language Reference Manual \<^url>\<open>https://llvm.org/docs/LangRef.html\<close>.\<close>

  subsubsection \<open>Binary Operations\<close>
  text \<open>We define a generic lifter for binary arithmetic operations.
    It is parameterized by an error condition.
  \<close> (* TODO: Use precondition instead of negated precondition! *)

  definition op_lift_arith2 :: "_ \<Rightarrow> _ \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word llM"
    where "op_lift_arith2 ovf f a b \<equiv> doM {
    let a = word_to_lint a;
    let b = word_to_lint b;
    fcheck (OVERFLOW_ERROR) (\<not>ovf a b);
    return (lint_to_word (f a b))
  }"

  definition "op_lift_arith2' \<equiv> op_lift_arith2 (\<lambda>_ _. False)"

  definition udivrem_is_undef :: "lint \<Rightarrow> lint \<Rightarrow> bool"
    where "udivrem_is_undef a b \<equiv> lint_to_uint b=0"
  definition sdivrem_is_undef :: "lint \<Rightarrow> lint \<Rightarrow> bool"
    where "sdivrem_is_undef a b \<equiv> lint_to_sint b=0 \<or> sdivrem_ovf a b"

  definition "ll_add \<equiv> op_lift_arith2' (+)"
  definition "ll_sub \<equiv> op_lift_arith2' (-)"
  definition "ll_mul \<equiv> op_lift_arith2' (*)"
  definition "ll_udiv \<equiv> op_lift_arith2 udivrem_is_undef (div)"
  definition "ll_urem \<equiv> op_lift_arith2 udivrem_is_undef (mod)"
  definition "ll_sdiv \<equiv> op_lift_arith2 sdivrem_is_undef (sdiv)"
  definition "ll_srem \<equiv> op_lift_arith2 sdivrem_is_undef (smod)"

  subsubsection \<open>Compare Operations\<close>
  definition op_lift_cmp :: "_ \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> 1 word llM"
    where "op_lift_cmp f a b \<equiv> doM {
    let a = word_to_lint a;
    let b = word_to_lint b;
    return (lint_to_word (bool_to_lint (f a b)))
  }"

  definition "ll_icmp_eq \<equiv>  op_lift_cmp (=)"
  definition "ll_icmp_ne \<equiv>  op_lift_cmp (\<noteq>)"
  definition "ll_icmp_sle \<equiv> op_lift_cmp (\<le>\<^sub>s)"
  definition "ll_icmp_slt \<equiv> op_lift_cmp (<\<^sub>s)"
  definition "ll_icmp_ule \<equiv> op_lift_cmp (\<le>)"
  definition "ll_icmp_ult \<equiv> op_lift_cmp (<)"

  subsubsection \<open>Bitwise Binary Operations\<close>
  definition "shift_ovf a n \<equiv> nat (lint_to_uint n) \<ge> width a"
  definition "bitSHL' a n \<equiv> bitSHL a (nat (lint_to_uint n))"
  definition "bitASHR' a n \<equiv> bitASHR a (nat (lint_to_uint n))"
  definition "bitLSHR' a n \<equiv> bitLSHR a (nat (lint_to_uint n))"

  definition "ll_shl \<equiv> op_lift_arith2 shift_ovf bitSHL'"
  definition "ll_lshr \<equiv> op_lift_arith2 shift_ovf bitLSHR'"
  definition "ll_ashr \<equiv> op_lift_arith2 shift_ovf bitASHR'"

  definition "ll_and \<equiv> op_lift_arith2' (lliAND)"
  definition "ll_or \<equiv> op_lift_arith2' (lliOR)"
  definition "ll_xor \<equiv> op_lift_arith2' (lliXOR)"

  subsubsection \<open>Aggregate Operations\<close>
  text \<open>In LLVM, there is an \<open>extractvalue\<close> and \<open>insertvalue\<close> operation.
    In our shallow embedding, these get instantiated for \<open>fst\<close> and \<open>snd\<close>.\<close>

  definition ll_extract_value :: "'t::llvm_rep \<Rightarrow> nat \<Rightarrow> 't\<^sub>1::llvm_rep llM"
    where "ll_extract_value p i \<equiv> doM {
      fcheck (STATIC_ERROR ''Expected struct'') (llvm_is_struct (to_val p));
      let vs = llvm_the_struct (to_val p);
      fcheck (STATIC_ERROR ''Field index out of range'') (i<length vs);
      checked_from_val (vs!i)
    }"

  definition ll_insert_value :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep \<Rightarrow> nat \<Rightarrow> 't::llvm_rep llM"
    where "ll_insert_value p x i \<equiv> doM {
      fcheck (STATIC_ERROR ''Expected struct'') (llvm_is_struct (to_val p));
      let vs = llvm_the_struct (to_val p);
      fcheck (STATIC_ERROR ''Field index out of range'') (i<length vs);
      checked_from_val (llvm_struct (vs[i:=to_val x]))
    }"

  (*
  definition "checked_split_pair v \<equiv> doM {
    fcheck (STATIC_ERROR ''Expected pair'') (llvm_is_pair v);
    return (llvm_the_pair v)
  }"

  definition ll_extract_fst :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep llM" where "ll_extract_fst p = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val a }"
  definition ll_extract_snd :: "'t::llvm_rep \<Rightarrow> 't\<^sub>2::llvm_rep llM" where "ll_extract_snd p = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val b }"
  definition ll_insert_fst :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep \<Rightarrow> 't llM" where "ll_insert_fst p x = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val (llvm_pair (to_val x) b) }"
  definition ll_insert_snd :: "'t::llvm_rep \<Rightarrow> 't\<^sub>2::llvm_rep \<Rightarrow> 't llM" where "ll_insert_snd p x = doM { (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val (llvm_pair a (to_val x)) }"
  *)

  (*
  definition ll_extract_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a llM" where "ll_extract_fst ab \<equiv> return (fst ab)"
  definition ll_extract_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b llM" where "ll_extract_snd ab \<equiv> return (snd ab)"
  definition ll_insert_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a \<Rightarrow> ('a\<times>'b) llM" where "ll_insert_fst ab a \<equiv> return (a,snd ab)"
  definition ll_insert_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b \<Rightarrow> ('a\<times>'b) llM" where "ll_insert_snd ab b \<equiv> return (fst ab,b)"
  *)

  subsubsection \<open>Memory Access and Addressing Operations\<close>

  definition ll_load :: "'a::llvm_rep ptr \<Rightarrow> 'a llM" where
    "ll_load p \<equiv> doM {
      r \<leftarrow> llvm_load (the_raw_ptr p);
      checked_from_val r
    }"

  definition ll_store :: "'a::llvm_rep \<Rightarrow> 'a ptr \<Rightarrow> unit llM" where
    "ll_store v p \<equiv> llvm_store (to_val v) (the_raw_ptr p)"

  text \<open>Note that LLVM itself does not have malloc and free instructions.
    However, these are primitive instructions in our abstract memory model,
    such that we have to model them in our semantics.

    The code generator will map them to the C standard library
    functions \<open>calloc\<close> and \<open>free\<close>.
  \<close>

  definition ll_malloc :: "'a::llvm_rep itself \<Rightarrow> _::len word \<Rightarrow> 'a ptr llM" where
    "ll_malloc TYPE('a) n = doM {
      fcheck MEM_ERROR (unat n > 0); \<comment> \<open>Disallow empty malloc\<close>
      r \<leftarrow> llvm_allocn (to_val (init::'a)) (unat n);
      return (PTR r)
    }"

  definition ll_free :: "'a::llvm_rep ptr \<Rightarrow> unit llM"
    where "ll_free p \<equiv> llvm_free (the_raw_ptr p)"

  text \<open>As for the aggregate operations, the \<open>getelementptr\<close> instruction is instantiated
    for pointer and structure indexing. \<close>

  definition ll_ofs_ptr :: "'a::llvm_rep ptr \<Rightarrow> _::len word \<Rightarrow> 'a ptr llM" where "ll_ofs_ptr p ofs = doM {
    r \<leftarrow> llvm_checked_idx_ptr (the_raw_ptr p) (sint ofs);
    return (PTR r)
  }"

  definition ll_gep_struct :: "'p::llvm_rep ptr \<Rightarrow> nat \<Rightarrow> 'a::llvm_rep ptr llM" where "ll_gep_struct p i = doM {
    fcheck (STATIC_ERROR ''gep_struct: Expected struct type'') (llvm_is_s_struct (struct_of TYPE('p)));
    r \<leftarrow> llvm_checked_gep (the_raw_ptr p) (PFLD i);
    return (PTR r)
  }"

  subsubsection \<open>Pointer Comparison\<close>
  text \<open>Note: There are no pointer comparison instructions in LLVM.
    To compare pointers in LLVM, they have to be casted to integers first.
    However, our abstract memory model cannot assign a bit-width to pointers.

    Thus, we model pointer comparison instructions in our semantics, and let the
    code generator translate them to integer comparisons.

    Up to now, we only model pointer equality.

    Note that the operand pointers must be null, or point to currently allocated memory.

    For less-than, more preconditions are required, which are consistent with the
    actual memory layout of LLVM. We could, e.g., adopt the rules from the C standard here.
  \<close>

  text \<open>Check if a pair of pointers is valid for comparison operation, i.e., one is null or both are currently allocated\<close>
  definition check_ptrs_cmp :: "'a::llvm_rep ptr \<Rightarrow> 'a ptr \<Rightarrow> unit llM" where
    "check_ptrs_cmp p\<^sub>1 p\<^sub>2 \<equiv> if p\<^sub>1=null \<or> p\<^sub>2=null then return () else doM { ll_load p\<^sub>1; ll_load p\<^sub>2; return ()}"

  definition op_lift_ptr_cmp :: "_ \<Rightarrow> 'a::llvm_rep ptr \<Rightarrow> 'a ptr \<Rightarrow> 1 word llM"
    where "op_lift_ptr_cmp f a b \<equiv> doM {
    check_ptrs_cmp a b;
    return (lint_to_word (bool_to_lint (f a b)))
  }"

  definition "ll_ptrcmp_eq \<equiv> op_lift_ptr_cmp (=)"
  definition "ll_ptrcmp_ne \<equiv> op_lift_ptr_cmp (\<noteq>)"

  subsubsection \<open>Conversion Operations\<close>
  definition "llb_trunc i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Trunc must go to smaller type'') (width i > w);
    return (trunc w i)
  }"

  definition "llb_sext i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Sext must go to greater type'') (width i < w);
    return (sext w i)
  }"

  definition "llb_zext i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Zext must go to greater type'') (width i < w);
    return (zext w i)
  }"

  definition op_lift_iconv :: "_ \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word itself  \<Rightarrow> 'b word llM"
    where "op_lift_iconv f a _ \<equiv> doM {
    let a = word_to_lint a;
    let w = LENGTH('b);
    r \<leftarrow> f a w;
    return (lint_to_word r)
  }"

  definition "ll_trunc \<equiv> op_lift_iconv llb_trunc"
  definition "ll_sext \<equiv> op_lift_iconv llb_sext"
  definition "ll_zext \<equiv> op_lift_iconv llb_zext"

  subsection \<open>Control Flow\<close>

  text \<open>Our shallow embedding uses a structured control flow, which allows
    only sequential composition, if-then-else, and function calls.

    The code generator then maps sequential composition to basic blocks,
    and if-then-else to a control flow graph with conditional branching.
    Function calls are mapped to LLVM function calls.
   \<close>

  text \<open>We use the to Boolean conversion from word-lib. We re-state its semantics here.\<close>

  lemma to_bool_as_lint_to_bool:
    "to_bool (w::1 word) = lint_to_bool (word_to_lint w)"
    unfolding to_bool_def word_to_lint_def
    apply (clarsimp simp: ltrue_def lfalse_def lint_to_bool_def)
    apply transfer
    apply auto
    done

  lemma to_bool_eq[simp]: "to_bool (w::1 word) \<longleftrightarrow> w\<noteq>0"
    by (rule to_bool_neq_0)

  definition llc_if :: "1 word \<Rightarrow> 'a::llvm_repv llM \<Rightarrow> 'a llM \<Rightarrow> 'a llM" where
    "llc_if b t e \<equiv> doM {
      if to_bool b then t else e
    }"

  lemma llc_if_mono[partial_function_mono]:
    "\<lbrakk>monotone orda ordb F; monotone orda ordb G\<rbrakk> \<Longrightarrow> monotone orda ordb (\<lambda>f. llc_if b (F f) (G f))"
    unfolding llc_if_def by pf_mono_prover

  subsubsection \<open>While-Combinator\<close>
  text \<open>
    Note that we also include the while combinator at this point, as we plan
    to add direct translation of while to a control flow graph as an optional
    feature of the code generator.

    In the current state, the code generator will recognize the while combinator,
    but refuse to translate it.

    Note that the standard way of using a while combinator is to translate it to
    a tail recursive function call, which the preprocessor can do automatically.
  \<close>

  definition llc_while :: "('a::llvm_repv \<Rightarrow> 1 word llM) \<Rightarrow> ('a \<Rightarrow> 'a llM) \<Rightarrow> 'a \<Rightarrow> 'a llM" where
    "llc_while b f s\<^sub>0 \<equiv> mwhile (\<lambda>s. b s \<bind> return o to_bool) f s\<^sub>0"

  lemma gen_code_thm_llc_while:
    assumes "f \<equiv> llc_while b body"
    shows "f s = doM { ctd \<leftarrow> b s; llc_if ctd (doM { s\<leftarrow>body s; f s}) (return s)}"
    unfolding assms
    unfolding llc_while_def llc_if_def
    apply (rewrite mwhile_unfold)
    by simp

  (* 'Definition' of llc_while for presentation in paper: *)
  lemma "llc_while b c s \<equiv> doM { x \<leftarrow> b s; llc_if x (doM {s\<leftarrow>c s; llc_while b c s}) (return s) }"
    unfolding llc_while_def llc_if_def
    apply (rewrite mwhile_unfold)
    by simp

end


theory formal_assurance
  imports refinement
begin

text \<open> Cyber-Physical State Space: controlled, monitored, and internal variables \<close>

alphabet ('c, 'm, 's) cpst =
  ctrl  :: 'c
  mon   :: 'm
  state :: 's

type_synonym ('c, 'm, 's) cpsprog = "('c, 'm, 's) cpst hrel"

text \<open> A cyber-physical system model consists of a state invariant over the controlled variables,
  and a body over the entire state \<close>

type_synonym ('c, 'm, 's) cps = "('c, 'm, 's) cpst machine"

locale valid_cps = machine M for M :: "('c, 'm, 's) cps" (structure) +
  \<comment> \<open> The invariant does not refer to monitored variables \<close>
  assumes invs_nmon: "mon \<sharp> Invs"
  \<comment> \<open> The actions do not change the monitored variables \<close>
  and body_mon_unch: "($mon\<acute> =\<^sub>u $mon) \<sqsubseteq> Body"
begin

  text \<open> Any predicate on monitored variables is invariant \<close>

  lemma env_assm_inv:
    assumes "ctrl \<sharp> A" "state \<sharp> A"
    shows "\<lbrace>A\<rbrace>Body\<lbrace>A\<rbrace>\<^sub>u"
  proof -
    from assms have "\<lbrace>A\<rbrace>($mon\<acute> =\<^sub>u $mon \<and> Body)\<lbrace>A\<rbrace>\<^sub>u"
      by (rel_blast)
    thus ?thesis
      by (simp add: body_mon_unch utp_pred_laws.inf.absorb2)
  qed

  lemma env_assm_inv':
    assumes "ctrl \<sharp> A" "state \<sharp> A"
    shows "`A \<Rightarrow> Body wlp A`"
    using assms(1) assms(2) env_assm_inv wlp_hoare_link by auto

  lemma env_assm_inv'':
    "`(\<exists> &ctrl \<bullet> \<exists> &state \<bullet> A) \<Rightarrow> Body wlp (\<exists> &ctrl \<bullet> \<exists> &state \<bullet> A)`"
    by (rule env_assm_inv', simp_all add: unrest)
end

text \<open> Demonstration that the unchanging monitored variable property can be demonstrated using wp. \<close>

lemma mon_unch_prop:
  fixes P :: "('c, 'm, 's) cpsprog"
  shows "($mon\<acute> =\<^sub>u $mon) \<sqsubseteq> P \<longleftrightarrow> (\<forall> r. `P wp r \<Rightarrow> (\<exists> &ctrl \<bullet> \<exists> &state \<bullet> r)`)"
proof -
  have "($mon\<acute> =\<^sub>u $mon) \<sqsubseteq> P \<longleftrightarrow> ctrl := * ;; state := * \<sqsubseteq> P"
    by rel_auto
  also have "... = (\<forall>r. `P wp r \<Rightarrow> (\<^bold>\<exists> v \<bullet> (\<^bold>\<exists> v \<bullet> r\<lbrakk>\<guillemotleft>v\<guillemotright>/&state\<rbrakk>)\<lbrakk>\<guillemotleft>v\<guillemotright>/&ctrl\<rbrakk>)`)"
    by (subst wp_refine_iff[THEN sym], simp add: wp)
  also have "... = (\<forall> r. `P wp r \<Rightarrow> (\<exists> &ctrl \<bullet> \<exists> &state \<bullet> r)`)"
    by (rel_simp')
  finally show ?thesis .
qed

type_synonym ('s\<^sub>1, 's\<^sub>2) cinv = "('s\<^sub>1, 's\<^sub>2) urel"

text \<open> Formal Assurance Case Signature \<close>

datatype reqtype = nxt | glob | fin

record ('c, 'm, 's) reqbody =
  pre   :: "('c, 'm, 's) cpst upred"
  post  :: "('c, 'm, 's) cpst upred"

no_utp_lift pre (0)
no_utp_lift post (0)

type_synonym ('c, 'm, 's) req = "reqtype \<times> ('c, 'm, 's) reqbody"

text \<open> The body of the CPS satisfies the safety or liveness requirement \<close>

fun req_sat :: "_ \<times> ('c, 'm, 's) cps \<Rightarrow> ('c, 'm, 's) req \<Rightarrow> bool" ("_ \<TTurnstile> _" [100, 101] 100) where
"(A, M) \<TTurnstile> (nxt, rb)  = `(A \<and> invs M \<and> pre rb) \<Rightarrow> (body M) wlp (post rb)`" |
"(A, M) \<TTurnstile> (glob, rb) = (\<exists> I. \<lbrace>I\<rbrace>body M\<lbrace>I\<rbrace>\<^sub>u \<and> `A \<and> pre rb \<and> invs M \<Rightarrow> I` \<and> `A \<and> I \<and> invs M \<Rightarrow> post rb`)" |
"(A, M) \<TTurnstile> (fin, rb) = `(A \<and> invs M \<and> pre rb) \<Rightarrow> (body M)\<^sup>\<star> wp (post rb)`"

lemma global_satisfaction:
  assumes "valid_cps M" "(A, M) \<TTurnstile> (glob, rb)" "ctrl \<sharp> A" "state \<sharp> A"
  shows "\<lbrace>A \<and> pre rb \<and> invs M\<rbrace>(body M)\<^sup>\<star>\<lbrace>post rb\<rbrace>\<^sub>u"
proof -
  obtain I where I:"\<lbrace>I\<rbrace>body M\<lbrace>I\<rbrace>\<^sub>u" "`A \<and> pre rb \<and> invs M \<Rightarrow> I`" "`A \<and> I \<and> invs M \<Rightarrow> post rb`"
    by (meson assms req_sat.simps(2))
  from I(3) have post: "`I \<Rightarrow> A \<and> invs M \<Rightarrow> post rb`"
    by (rel_auto)

  have "\<lbrace>A \<and> pre rb \<and> invs M\<rbrace>(body M)\<^sup>\<star>\<lbrace>A \<and> invs M \<Rightarrow> post rb\<rbrace>\<^sub>u"
    using I(1) I(2) hoare_r_conseq iter_hoare_r post by blast
  moreover have "\<lbrace>invs M\<rbrace>(body M)\<^sup>\<star>\<lbrace>invs M\<rbrace>\<^sub>u"
    using assms(1) iter_hoare_r machine.body_invs' valid_cps.axioms(1) by blast
  moreover have "\<lbrace>A\<rbrace>(body M)\<^sup>\<star>\<lbrace>A\<rbrace>\<^sub>u"
    by (simp add: assms(1) assms(3) assms(4) iter_hoare_r valid_cps.env_assm_inv)
  ultimately show ?thesis
    by (simp add: wlp_hoare_link, rel_auto)
qed

text \<open> A formal assurance case consists of assumptions, guarantees, and a model \<close>

record ('c, 'm, 's) fac =
  assm  :: "('c, 'm, 's) cpst upred"
  guar  :: "('c, 'm, 's) req set"

no_utp_lift assm (0)
no_utp_lift guar (0)

record ('c, 'm, 's) fmac = "('c, 'm, 's) fac" +
  model :: "('c, 'm, 's) cps"

definition fac_sem where "fac_sem AC = (mon := * ;; ?[assm AC] ;; body (model AC))\<^sup>\<star>"

locale valid_fac =
  fixes AC :: "('c, 'm, 's) fmac"
  assumes valid_cps: "valid_cps (model AC)"
  \<comment> \<open> The assumption refers only to monitored variables \<close>
  and "ctrl \<sharp> assm AC" "state \<sharp> assm AC"
  \<comment> \<open> All requirements are satisfied by the model \<close>
  and reqs_satisfied: "\<And> R. R \<in> guar AC \<Longrightarrow> (assm AC, model AC) \<TTurnstile> R"
begin

  lemma assm_invar_body: "\<lbrace>assm AC\<rbrace>body (model AC)\<lbrace>assm AC\<rbrace>\<^sub>u"
    using valid_cps.env_assm_inv valid_fac_axioms valid_fac_def by blast

end

text \<open> Lift safety requirements using a functional retrieve relation\<close>

definition lift_sreqs ::
  "('c\<^sub>1, 'm\<^sub>1, 's\<^sub>1) fmac \<Rightarrow>
   (('c\<^sub>2, 'm\<^sub>2, 's\<^sub>2) cpst, ('c\<^sub>1, 'm\<^sub>1, 's\<^sub>1) cpst) psubst \<Rightarrow>
   reqtype \<leftrightarrow> ('c\<^sub>2, 'm\<^sub>2, 's\<^sub>2) reqbody" where
"lift_sreqs AC \<sigma> \<equiv> {(t, \<lparr> pre = \<sigma> \<dagger> (assm AC \<and> pre b), post = \<sigma> \<dagger> post b \<rparr>) | t b. t \<in> {nxt, glob} \<and> (t, b) \<in> guar AC}"

text \<open> Extend an existing FAC with a new model and additional requirements; we assume that a
  data refinement will be exhibited between the abstract and concrete models \<close>

definition fac_extend ::
  "('c\<^sub>1, 'm\<^sub>1, 's\<^sub>1) fmac \<Rightarrow> (('c\<^sub>2, 'm\<^sub>2, 's\<^sub>2) cpst, ('c\<^sub>1, 'm\<^sub>1, 's\<^sub>1) cpst) psubst \<Rightarrow>
   ('c\<^sub>2, 'm\<^sub>2, 's\<^sub>2) fmac \<Rightarrow> ('c\<^sub>2, 'm\<^sub>2, 's\<^sub>2) fmac" where
  "fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2 = \<lparr> assm = assm AC\<^sub>2, guar = lift_sreqs AC\<^sub>1 \<sigma> \<union> guar AC\<^sub>2, model = model AC\<^sub>2 \<rparr>"

text \<open> Theorem to prove the validity of the above; requires a data refinement argument \<close>

lemma fac_extend_intro:
  assumes
    \<comment> \<open> Valid models \<close>
    "valid_cps (model AC\<^sub>1)" "valid_cps (model AC\<^sub>2)"
    \<comment> \<open> Original assurance case is valid \<close>
    "valid_fac AC\<^sub>1"
    \<comment> \<open> Weaken the assumption \<close>
    "`(\<sigma> \<dagger> assm AC\<^sub>1) \<Rightarrow> assm AC\<^sub>2`"
    \<comment> \<open> Demonstrate a backward functional refinement \<close>
    "func_refinement (func_refine (model AC\<^sub>1) (model AC\<^sub>2) \<sigma>) \<sigma>"
    \<comment> \<open> Prove all additional requirements \<close>
    "\<And> R. R \<in> guar AC\<^sub>2 \<Longrightarrow> ((assm AC\<^sub>2, model AC\<^sub>2) \<TTurnstile> R)"
    \<comment> \<open> New assumption refers only to monitored variables \<close>
    "ctrl \<sharp> assm AC\<^sub>2" "state \<sharp> assm AC\<^sub>2"
  shows "valid_fac (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2)"
proof (rule valid_fac.intro)
  interpret func_refinement "func_refine (model AC\<^sub>1) (model AC\<^sub>2) \<sigma>" \<sigma>
    by (simp add: assms)
  show "valid_cps (model (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2))"
    by (simp add: fac_extend_def assms)
  show "\<And>R. R \<in> guar (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2) \<Longrightarrow> (assm (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2), model (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2)) \<TTurnstile> R"
  proof (clarsimp simp add: fac_extend_def, erule disjE)
    fix rt rb
    assume "(rt, rb) \<in> guar AC\<^sub>2"
    thus "(assm AC\<^sub>2, model AC\<^sub>2) \<TTurnstile> (rt, rb)"
      by (simp add: assms)
  next
    fix rt rb
    assume a: "(rt, rb) \<in> lift_sreqs AC\<^sub>1 \<sigma>"
    hence rt: "rt = nxt \<or> rt = glob"
      by (auto simp add: lift_sreqs_def)
    from a obtain Pre Post where rb: "(rt, \<lparr> pre = Pre, post = Post \<rparr>) \<in> guar AC\<^sub>1" "rb = \<lparr> pre = \<sigma> \<dagger> (assm AC\<^sub>1 \<and> Pre), post = \<sigma> \<dagger> Post \<rparr>"
      by (auto simp add: lift_sreqs_def, (metis (full_types) old.unit.exhaust reqbody.surjective)+)
    have osat: "(assm AC\<^sub>1, model AC\<^sub>1) \<TTurnstile> (rt, \<lparr> pre = Pre, post = Post \<rparr>)"
      by (simp add: assms(3) rb(1) valid_fac.reqs_satisfied)
    show "(assm AC\<^sub>2, model AC\<^sub>2) \<TTurnstile> (rt, rb)"
    proof (cases "rt = nxt")
      case True
      have "`assm AC\<^sub>1 \<Rightarrow> Invs\<^bsub>model AC\<^sub>1\<^esub> \<and> Pre \<Rightarrow> Body\<^bsub>model AC\<^sub>1\<^esub> wlp Post`"
        by (metis True assms(3) hoare_gcmd rb(1) req_sat.simps(1) reqbody.select_convs(1) reqbody.select_convs(2) valid_fac.reqs_satisfied wlp_gcmd wlp_hoare_link)
      hence "`Invs\<^bsub>model AC\<^sub>1\<^esub> \<and> (Pre \<and> assm AC\<^sub>1) \<Rightarrow> Body\<^bsub>model AC\<^sub>1\<^esub> wlp Post`"
        by (rel_auto)
      hence "`Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> (\<sigma> \<dagger> (Pre \<and> assm AC\<^sub>1)) \<Rightarrow> Body\<^bsub>model AC\<^sub>2\<^esub> wlp (\<sigma> \<dagger> Post)`"
        using refinement_preserves_safety_wlp_func
        by (simp add: func_refine_def)
      with rb True show ?thesis
        by (auto, metis hoare_r_weaken_pre(2) utp_pred_laws.inf.commute wlp_hoare_link)
    next
      case False
      with rt have glob:"rt = glob"
        by auto
      with osat obtain I where I:"\<lbrace>I\<rbrace> Body\<^bsub>model AC\<^sub>1\<^esub> \<lbrace>I\<rbrace>\<^sub>u" "`assm AC\<^sub>1 \<and> Pre \<and> Invs\<^bsub>model AC\<^sub>1\<^esub> \<Rightarrow> I`" "`assm AC\<^sub>1 \<and> I \<and> Invs\<^bsub>model AC\<^sub>1\<^esub> \<Rightarrow> Post`"
        by (auto)
      hence 1:"\<lbrace>Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> (\<sigma> \<dagger> (I \<and> assm AC\<^sub>1))\<rbrace>Body\<^bsub>model AC\<^sub>2\<^esub>\<lbrace>(\<sigma> \<dagger> I)\<rbrace>\<^sub>u"
        by (metis func_refine_def hoare_r_weaken_pre(1) refinement.refinement.select_convs(1) refinement.refinement.select_convs(2) refinement_preserves_safety_func utp_pred_laws.inf_commute)
      have 2: "\<lbrace>Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> (\<sigma> \<dagger> assm AC\<^sub>1)\<rbrace>Body\<^bsub>model AC\<^sub>2\<^esub>\<lbrace>\<sigma> \<dagger> assm AC\<^sub>1\<rbrace>\<^sub>u"
      proof -
        have "\<lbrace>Invs\<^bsub>model AC\<^sub>1\<^esub> \<and> assm AC\<^sub>1\<rbrace>Body\<^bsub>model AC\<^sub>1\<^esub>\<lbrace>assm AC\<^sub>1\<rbrace>\<^sub>u"
          by (simp add: assms(3) hoare_r_weaken_pre(2) valid_fac.assm_invar_body)
        thus ?thesis
          using refinement_preserves_safety_func by (simp add: func_refine_def)
      qed
      have 3: "\<lbrace>Invs\<^bsub>model AC\<^sub>2\<^esub>\<rbrace>Body\<^bsub>model AC\<^sub>2\<^esub>\<lbrace>Invs\<^bsub>model AC\<^sub>2\<^esub>\<rbrace>\<^sub>u"
        by (simp add: assms(2) machine.body_invs' valid_cps.axioms(1))
      from 1 2 3 have 4:"\<lbrace>Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> (\<sigma> \<dagger> (I \<and> assm AC\<^sub>1))\<rbrace>Body\<^bsub>model AC\<^sub>2\<^esub>\<lbrace>Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> (\<sigma> \<dagger> (I \<and> assm AC\<^sub>1))\<rbrace>\<^sub>u"
        by (smt hoare_r_conj hoare_r_weaken_pre(2) subst_conj utp_pred_laws.conj_assoc utp_pred_laws.inf_commute)
      have 5: "`assm AC\<^sub>2 \<and> pre rb \<and> Invs\<^bsub>model AC\<^sub>2\<^esub> \<Rightarrow> Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> \<sigma> \<dagger> (I \<and> assm AC\<^sub>1)`"
      proof -
        from I(2) have "`\<sigma> \<dagger> (assm AC\<^sub>1 \<and> Pre \<and> Invs\<^bsub>model AC\<^sub>1\<^esub>) \<Rightarrow> \<sigma> \<dagger> I`"
          by (rel_auto)
        moreover have "`Invs\<^bsub>model AC\<^sub>2\<^esub> \<Rightarrow> \<sigma> \<dagger> Invs\<^bsub>model AC\<^sub>1\<^esub>`"
          by (metis func_invs func_refine_def refinement.refinement.select_convs(1) refinement.refinement.select_convs(2))
        ultimately show ?thesis
          by (simp add: rb usubst, rel_simp)
      qed
      from I(3) have 6: "`assm AC\<^sub>2 \<and> (Invs\<^bsub>model AC\<^sub>2\<^esub> \<and> \<sigma> \<dagger> (I \<and> assm AC\<^sub>1)) \<and> Invs\<^bsub>model AC\<^sub>2\<^esub> \<Rightarrow> post rb`"
      proof -
        from I(3) have "`\<sigma> \<dagger> (assm AC\<^sub>1 \<and> I \<and> Invs\<^bsub>model AC\<^sub>1\<^esub>) \<Rightarrow> \<sigma> \<dagger> Post`"
          by (rel_auto)
        moreover have "`Invs\<^bsub>model AC\<^sub>2\<^esub> \<Rightarrow> \<sigma> \<dagger> Invs\<^bsub>model AC\<^sub>1\<^esub>`"
          by (metis func_invs func_refine_def refinement.refinement.select_convs(1) refinement.refinement.select_convs(2))
        ultimately show ?thesis
          by (simp add: rb usubst, rel_auto)
      qed
      from glob I(2-3) 4 5 6 show ?thesis
        by (auto)
    qed
  qed
  show "ctrl \<sharp> assm (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2)"
    by (simp add: fac_extend_def assms)
  show "state \<sharp> assm (fac_extend AC\<^sub>1 \<sigma> AC\<^sub>2)"
    by (simp add: fac_extend_def assms)
qed

end


(* @SUITE wp *)

theory wp_assign
imports "../Hoare_Tactics"
begin

abbreviation "z == Variable ''z'' :: int variable"

lemma
  assumes "hoare {P &m} skip {z+2=99}"
  shows "hoare {P &m} z:=z+2 {z=99}"
  apply wp
  by (fact assms)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Strengthen
imports Main
begin

text {* Implementation of the @{text strengthen} tool and the @{text mk_strg}
attribute. See the theory @{text Strengthen_Demo} for a demonstration. *}

locale strengthen_implementation begin

definition "st P rel x y = (x = y \<or> (P \<and> rel x y) \<or> (\<not> P \<and> rel y x))"

definition
  st_prop1 :: "prop \<Rightarrow> prop \<Rightarrow> prop"
where
  "st_prop1 (PROP P) (PROP Q) \<equiv> (PROP Q \<Longrightarrow> PROP P)"

definition
  st_prop2 :: "prop \<Rightarrow> prop \<Rightarrow> prop"
where
  "st_prop2 (PROP P) (PROP Q) \<equiv> (PROP P \<Longrightarrow> PROP Q)"

definition "failed == True"

definition elim :: "prop \<Rightarrow> prop"
where
 "elim (P :: prop) == P"

definition "oblig (P :: prop) == P"

end

notation strengthen_implementation.elim ("{elim| _ |}")
notation strengthen_implementation.oblig ("{oblig| _ |}")
notation strengthen_implementation.failed ("<strg-failed>")

syntax
  "_ap_strg_bool" :: "['a, 'a] => 'a"  ("_ =strg<--|=> _")
  "_ap_wkn_bool" :: "['a, 'a] => 'a"  ("_ =strg-->|=> _")
  "_ap_ge_bool" :: "['a, 'a] => 'a"  ("_ =strg<=|=> _")
  "_ap_le_bool" :: "['a, 'a] => 'a"  ("_ =strg>=|=> _")

syntax(xsymbols)
  "_ap_strg_bool" :: "['a, 'a] => 'a"  ("_ =strg\<longleftarrow>|=> _")
  "_ap_wkn_bool" :: "['a, 'a] => 'a"  ("_ =strg\<longrightarrow>|=> _")
  "_ap_ge_bool" :: "['a, 'a] => 'a"  ("_ =strg\<le>|=> _")
  "_ap_le_bool" :: "['a, 'a] => 'a"  ("_ =strg\<ge>|=> _")

translations
  "P =strg\<longleftarrow>|=> Q" == "CONST strengthen_implementation.st (CONST False) (CONST HOL.implies) P Q"
  "P =strg\<longrightarrow>|=> Q" == "CONST strengthen_implementation.st (CONST True) (CONST HOL.implies) P Q"
  "P =strg\<le>|=> Q" == "CONST strengthen_implementation.st (CONST False) (CONST Orderings.less_eq) P Q"
  "P =strg\<ge>|=> Q" == "CONST strengthen_implementation.st (CONST True) (CONST Orderings.less_eq) P Q"

context strengthen_implementation begin

lemma failedI:
  "<strg-failed>"
  by (simp add: failed_def)

lemma strengthen_refl:
  "st P rel x x"
  by (simp add: st_def)

lemma st_prop_refl:
  "PROP (st_prop1 (PROP P) (PROP P))"
  "PROP (st_prop2 (PROP P) (PROP P))"
  unfolding st_prop1_def st_prop2_def
  by safe

lemma strengthenI:
  "rel x y \<Longrightarrow> st True rel x y"
  "rel y x \<Longrightarrow> st False rel x y"
  by (simp_all add: st_def)

lemmas imp_to_strengthen = strengthenI(2)[where rel="op \<longrightarrow>"]
lemmas rev_imp_to_strengthen = strengthenI(1)[where rel="op \<longrightarrow>"]
lemmas ord_to_strengthen = strengthenI[where rel="op \<le>"]

lemma use_strengthen_imp:
  "st False (op \<longrightarrow>) Q P \<Longrightarrow> P \<Longrightarrow> Q"
  by (simp add: st_def)

lemma use_strengthen_prop_elim:
  "PROP P \<Longrightarrow> PROP (st_prop2 (PROP P) (PROP Q))
    \<Longrightarrow> (PROP Q \<Longrightarrow> PROP R) \<Longrightarrow> PROP R"
  unfolding st_prop2_def
  apply (drule(1) meta_mp)+
  apply assumption
  done

lemma strengthen_Not:
  "st False rel x y \<Longrightarrow> st (\<not> True) rel x y"
  "st True rel x y \<Longrightarrow> st (\<not> False) rel x y"
  by auto

lemmas gather =
    swap_prems_eq[where A="PROP (Trueprop P)" and B="PROP (elim Q)" for P Q]
    swap_prems_eq[where A="PROP (Trueprop P)" and B="PROP (oblig Q)" for P Q]

lemma mk_True_imp:
  "P \<equiv> True \<longrightarrow> P"
  by simp

lemma narrow_quant:
  "(\<And>x. PROP P \<Longrightarrow> PROP (Q x)) \<equiv> (PROP P \<Longrightarrow> (\<And>x. PROP (Q x)))"
  "(\<And>x. (R \<longrightarrow> S x)) \<equiv> PROP (Trueprop (R \<longrightarrow> (\<forall>x. S x)))"
  "(\<And>x. (S x \<longrightarrow> R)) \<equiv> PROP (Trueprop ((\<exists>x. S x) \<longrightarrow> R))"
  apply (simp_all add: atomize_all)
  apply rule
   apply assumption
  apply assumption
  done

ML {*
structure Make_Strengthen_Rule = struct

fun binop_conv' cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2;

val mk_elim = Conv.rewr_conv @{thm elim_def[symmetric]}
val mk_oblig = Conv.rewr_conv @{thm oblig_def[symmetric]}

fun count_vars t = Term.fold_aterms
    (fn (Var v) => Termtab.map_default (Var v, 0) (fn x => x + 1)
        | _ => I) t Termtab.empty

fun gather_to_imp ctxt drule pattern = let
    val pattern = (if drule then "D" :: pattern else pattern)
    fun inner pat ct = case (head_of (Thm.term_of ct), pat) of
        (@{term Pure.imp}, ("E" :: pat)) => binop_conv' mk_elim (inner pat) ct
      | (@{term Pure.imp}, ("A" :: pat)) => binop_conv' mk_elim (inner pat) ct
      | (@{term Pure.imp}, ("O" :: pat)) => binop_conv' mk_oblig (inner pat) ct
      | (@{term Pure.imp}, _) => binop_conv' (Object_Logic.atomize ctxt) (inner (drop 1 pat)) ct
      | (_, []) => Object_Logic.atomize ctxt ct
      | (_, pat) => raise THM ("gather_to_imp: leftover pattern: " ^ commas pat, 1, [])
    fun simp thms = Raw_Simplifier.rewrite ctxt false thms
    fun ensure_imp ct = case strip_comb (Thm.term_of ct) |> apsnd (map head_of)
     of
        (@{term Pure.imp}, _) => Conv.arg_conv ensure_imp ct
      | (@{term HOL.Trueprop}, [@{term HOL.implies}]) => Conv.all_conv ct
      | (@{term HOL.Trueprop}, _) => Conv.arg_conv (Conv.rewr_conv @{thm mk_True_imp}) ct
      | _ => raise CTERM ("gather_to_imp", [ct])
    val gather = simp @{thms gather}
        then_conv (if drule then Conv.all_conv else simp @{thms atomize_conjL})
        then_conv simp @{thms atomize_imp}
        then_conv ensure_imp
  in Conv.fconv_rule (inner pattern then_conv gather) end

fun imp_list t = let
    val (x, y) = Logic.dest_implies t
  in x :: imp_list y end handle TERM _ => [t]

fun mk_ex (xnm, T) t = HOLogic.exists_const T $ Term.lambda (Var (xnm, T)) t
fun mk_all (xnm, T) t = HOLogic.all_const T $ Term.lambda (Var (xnm, T)) t

fun quantify_vars ctxt drule thm = let
    val (lhs, rhs) = Thm.concl_of thm |> HOLogic.dest_Trueprop
      |> HOLogic.dest_imp
    val all_vars = count_vars (Thm.prop_of thm)
    val new_vars = count_vars (if drule then rhs else lhs)
    val quant = filter (fn v => Termtab.lookup new_vars v = Termtab.lookup all_vars v)
            (Termtab.keys new_vars)
        |> map (Thm.cterm_of ctxt)
  in fold Thm.forall_intr quant thm
    |> Conv.fconv_rule (Raw_Simplifier.rewrite ctxt false @{thms narrow_quant})
  end

fun mk_strg (typ, pat) ctxt thm = let
    val drule = typ = "D" orelse typ = "D'"
    val imp = gather_to_imp ctxt drule pat thm
      |> (if typ = "I'" orelse typ = "D'"
          then quantify_vars ctxt drule else I)
  in if typ = "I" orelse typ = "I'"
    then imp RS @{thm imp_to_strengthen}
    else if drule then imp RS @{thm rev_imp_to_strengthen}
    else if typ = "lhs" then imp RS @{thm ord_to_strengthen(1)}
    else if typ = "rhs" then imp RS @{thm ord_to_strengthen(2)}
    else raise THM ("mk_strg: unknown type: " ^ typ, 1, [thm])
 end

fun auto_mk ctxt thm = let
    val concl_C = try (fst o dest_Const o head_of
        o HOLogic.dest_Trueprop) (Thm.concl_of thm)
  in case (Thm.nprems_of thm, concl_C) of
    (_, SOME @{const_name failed}) => thm
  | (_, SOME @{const_name st}) => thm
  | (0, SOME @{const_name HOL.implies}) => (thm RS @{thm imp_to_strengthen}
      handle THM _ => @{thm failedI})
  | _ => mk_strg ("I'", []) ctxt thm
  end

fun mk_strg_args (SOME (typ, pat)) ctxt thm = mk_strg (typ, pat) ctxt thm
  | mk_strg_args NONE ctxt thm = auto_mk ctxt thm

val arg_pars = Scan.option (Scan.first (map Args.$$$ ["I", "I'", "D", "D'", "lhs", "rhs"])
  -- Scan.repeat (Args.$$$ "A" || Args.$$$ "E" || Args.$$$ "O" || Args.$$$ "_"))

val attr_pars : attribute context_parser
    = (Scan.lift arg_pars -- Args.context)
        >> (fn (args, ctxt) => Thm.rule_attribute [] (K (mk_strg_args args ctxt)))

end
*}

end

attribute_setup mk_strg = \<open>Make_Strengthen_Rule.attr_pars\<close>
          "put rule in 'strengthen' form (see theory Strengthen_Demo)"

text {* Quick test. *}

lemmas foo = nat.induct[mk_strg I O O]
    nat.induct[mk_strg D O]
    nat.induct[mk_strg I' E]
    exI[mk_strg I'] exI[mk_strg I]

context strengthen_implementation begin

lemma do_elim:
  "PROP P \<Longrightarrow> PROP elim (PROP P)"
  by (simp add: elim_def)

lemma intro_oblig:
  "PROP P \<Longrightarrow> PROP oblig (PROP P)"
  by (simp add: oblig_def)

ML {*

structure Strengthen = struct

structure Congs = Theory_Data
(struct
    type T = thm list
    val empty = []
    val extend = I
    val merge = Thm.merge_thms;
end);

val tracing = Attrib.config_bool @{binding strengthen_trace} (K false)

fun map_context_total f (Context.Theory t) = (Context.Theory (f t))
  | map_context_total f (Context.Proof p)
    = (Context.Proof (Context.raw_transfer (f (Proof_Context.theory_of p)) p))

val strg_add = Thm.declaration_attribute
        (fn thm => map_context_total (Congs.map (Thm.add_thm thm)));

val strg_del = Thm.declaration_attribute
        (fn thm => map_context_total (Congs.map (Thm.del_thm thm)));

val setup =
  Attrib.setup @{binding "strg"} (Attrib.add_del strg_add strg_del)
    "strengthening congruence rules"
    #> snd tracing;

fun goal_predicate t = let
    val gl = Logic.strip_assums_concl t
    val cn = head_of #> dest_Const #> fst
  in if cn gl = @{const_name oblig} then "oblig"
    else if cn gl = @{const_name elim} then "elim"
    else if cn gl = @{const_name st_prop1} then "st_prop1"
    else if cn gl = @{const_name st_prop2} then "st_prop2"
    else if cn (HOLogic.dest_Trueprop gl) = @{const_name st} then "st"
    else ""
  end handle TERM _ => ""

fun do_elim ctxt = SUBGOAL (fn (t, i) => if goal_predicate t = "elim"
    then eresolve_tac ctxt @{thms do_elim} i else all_tac)

fun final_oblig_strengthen ctxt = SUBGOAL (fn (t, i) => case goal_predicate t of
    "oblig" => resolve_tac ctxt @{thms intro_oblig} i
  | "st" => resolve_tac ctxt @{thms strengthen_refl} i
  | "st_prop1" => resolve_tac ctxt @{thms st_prop_refl} i
  | "st_prop2" => resolve_tac ctxt @{thms st_prop_refl} i
  | _ => all_tac)

infix 1 THEN_TRY_ALL_NEW;

(* Like THEN_ALL_NEW but allows failure, although at least one subsequent
   method must succeed. *)
fun (tac1 THEN_TRY_ALL_NEW tac2) i st = let
    fun inner b j st = if i > j then (if b then all_tac else no_tac) st
      else ((tac2 j THEN inner true (j - 1)) ORELSE inner b (j - 1)) st
  in st |> (tac1 i THEN (fn st' =>
    inner false (i + Thm.nprems_of st' - Thm.nprems_of st) st')) end

fun maybe_trace_tac false _ _ = K all_tac
  | maybe_trace_tac true ctxt msg = SUBGOAL (fn (t, _) => let
    val tr = Pretty.big_list msg [Syntax.pretty_term ctxt t]
  in
    Pretty.writeln tr;
    all_tac
  end)

fun maybe_trace_rule false _ _ rl = rl
  | maybe_trace_rule true ctxt msg rl = let
    val tr = Pretty.big_list msg [Syntax.pretty_term ctxt (Thm.prop_of rl)]
  in
    Pretty.writeln tr;
    rl
  end

type params = {trace : bool, once : bool}

fun params once ctxt = {trace = Config.get ctxt (fst tracing), once = once}

fun apply_tac_as_strg ctxt (params : params) (tac : tactic)
  = SUBGOAL (fn (t, i) => case Logic.strip_assums_concl t of
      @{term Trueprop} $ (@{term "st False (op \<longrightarrow>)"} $ x $ _)
      => let
    val triv = Thm.trivial (Thm.cterm_of ctxt (HOLogic.mk_Trueprop x))
    val trace = #trace params
  in
    fn thm => tac triv
        |> Seq.map (maybe_trace_rule trace ctxt "apply_tac_as_strg: making strg")
        |> Seq.maps (Seq.try (Make_Strengthen_Rule.auto_mk ctxt))
        |> Seq.maps (fn str_rl => resolve_tac ctxt [str_rl] i thm)
  end | _ => no_tac)

fun opt_tac f (SOME v) = f v
  | opt_tac _ NONE = K no_tac

fun apply_strg ctxt (params : params) congs rules tac = EVERY' [
    maybe_trace_tac (#trace params) ctxt "apply_strg",
    DETERM o TRY o resolve_tac ctxt @{thms strengthen_Not},
    DETERM o ((resolve_tac ctxt rules THEN_ALL_NEW do_elim ctxt)
        ORELSE' (opt_tac (apply_tac_as_strg ctxt params) tac)
        ORELSE' (resolve_tac ctxt congs THEN_TRY_ALL_NEW
            (fn i => apply_strg ctxt params congs rules tac i)))
]

fun setup_strg ctxt params thms meths = let
    val congs = Congs.get (Proof_Context.theory_of ctxt)
    val rules = map (Make_Strengthen_Rule.auto_mk ctxt) thms
    val tac = case meths of [] => NONE
      | _ => SOME (FIRST (map (fn meth => Method.NO_CONTEXT_TACTIC ctxt
        (Method.evaluate meth ctxt [])) meths))
  in apply_strg ctxt params congs rules tac
        THEN_ALL_NEW final_oblig_strengthen ctxt end

fun strengthen ctxt asm concl thms meths = let
    val strg = setup_strg ctxt (params false ctxt) thms meths
  in
    (if not concl then K no_tac
        else resolve_tac ctxt @{thms use_strengthen_imp} THEN' strg)
    ORELSE' (if not asm then K no_tac
        else eresolve_tac ctxt @{thms use_strengthen_prop_elim} THEN' strg)
  end

fun default_strengthen ctxt thms = strengthen ctxt false true thms []

val strengthen_args =
  Attrib.thms >> curry (fn (rules, ctxt) =>
    Method.CONTEXT_METHOD (fn _ =>
      Method.RUNTIME (Method.CONTEXT_TACTIC
        (strengthen ctxt false true rules [] 1))
    )
  );

val strengthen_asm_args =
  Attrib.thms >> curry (fn (rules, ctxt) =>
    Method.CONTEXT_METHOD (fn _ =>
      Method.RUNTIME (Method.CONTEXT_TACTIC
        (strengthen ctxt true false rules [] 1))
    )
  );

val strengthen_method_args =
  Method.text_closure >> curry (fn (meth, ctxt) =>
    Method.CONTEXT_METHOD (fn _ =>
      Method.RUNTIME (Method.CONTEXT_TACTIC
        (strengthen ctxt true true [] [meth] 1))
    )
  );

end

*}

end

setup "Strengthen.setup"

method_setup strengthen = {* Strengthen.strengthen_args *}
  "strengthen the goal (see theory Strengthen_Demo)"

method_setup strengthen_asm = {* Strengthen.strengthen_asm_args *}
  "apply ''strengthen'' to weaken an assumption"

method_setup strengthen_method = {* Strengthen.strengthen_method_args *}
  "use an argument method in ''strengthen'' sites"

text {* Important strengthen congruence rules. *}

context strengthen_implementation begin

lemma strengthen_imp_imp[simp]:
  "st True (op \<longrightarrow>) A B = (A \<longrightarrow> B)"
  "st False (op \<longrightarrow>) A B = (B \<longrightarrow> A)"
  by (simp_all add: st_def)

abbreviation(input)
  "st_ord t \<equiv> st t (op \<le> :: ('a :: preorder) \<Rightarrow> _)"

lemma strengthen_imp_ord[simp]:
  "st_ord True A B = (A \<le> B)"
  "st_ord False A B = (B \<le> A)"
  by (auto simp add: st_def)

lemma strengthen_imp_conj [strg]:
  "\<lbrakk> B \<Longrightarrow> st F (op \<longrightarrow>) A A'; st F (op \<longrightarrow>) B B' \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (A \<and> B) (A' \<and> B')"
  by (cases F, auto)

lemma strengthen_imp_disj [strg]:
  "\<lbrakk> \<not> B \<Longrightarrow> st F (op \<longrightarrow>) A A'; st F (op \<longrightarrow>) B B' \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (A \<or> B) (A' \<or> B')"
  by (cases F, auto)

lemma strengthen_imp_implies [strg]:
  "\<lbrakk> st (\<not> F) (op \<longrightarrow>) X X'; X \<Longrightarrow> st F (op \<longrightarrow>) Y Y' \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (X \<longrightarrow> Y) (X' \<longrightarrow> Y')"
  by (cases F, auto)

lemma strengthen_all[strg]:
  "\<lbrakk> \<And>x. st F (op \<longrightarrow>) (P x) (Q x) \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (\<forall>x. P x) (\<forall>x. Q x)"
  by (cases F, auto)

lemma strengthen_ex[strg]:
  "\<lbrakk> \<And>x. st F (op \<longrightarrow>) (P x) (Q x) \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (\<exists>x. P x) (\<exists>x. Q x)"
  by (cases F, auto)

lemma strengthen_Ball[strg]:
  "\<lbrakk> st_ord (Not F) S S';
        \<And>x. x \<in> S \<Longrightarrow> st F (op \<longrightarrow>) (P x) (Q x) \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (\<forall>x \<in> S. P x) (\<forall>x \<in> S'. Q x)"
  by (cases F, auto)

lemma strengthen_Bex[strg]:
  "\<lbrakk> st_ord F S S';
        \<And>x. x \<in> S \<Longrightarrow> st F (op \<longrightarrow>) (P x) (Q x) \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (\<exists>x \<in> S. P x) (\<exists>x \<in> S'. Q x)"
  by (cases F, auto)

lemma strengthen_Collect[strg]:
  "\<lbrakk> \<And>x. st F (op \<longrightarrow>) (P x) (P' x) \<rbrakk>
    \<Longrightarrow> st_ord F {x. P x} {x. P' x}"
  by (cases F, auto)

lemma strengthen_mem[strg]:
  "\<lbrakk> st_ord F S S' \<rbrakk>
    \<Longrightarrow> st F (op \<longrightarrow>) (x \<in> S) (x \<in> S')"
  by (cases F, auto)

lemma strengthen_ord[strg]:
  "st_ord (\<not> F) x x' \<Longrightarrow> st_ord F y y'
    \<Longrightarrow> st F (op \<longrightarrow>) (x \<le> y) (x' \<le> y')"
  by (cases F, simp_all, (metis order_trans)+)

lemma strengthen_strict_ord[strg]:
  "st_ord (\<not> F) x x' \<Longrightarrow> st_ord F y y'
    \<Longrightarrow> st F (op \<longrightarrow>) (x < y) (x' < y')"
  by (cases F, simp_all, (metis order_le_less_trans order_less_le_trans)+)

lemma strengthen_image[strg]:
  "st_ord F S S' \<Longrightarrow> st_ord F (f ` S) (f ` S')"
  by (cases F, auto)

lemma strengthen_vimage[strg]:
  "st_ord F S S' \<Longrightarrow> st_ord F (f -` S) (f -` S')"
  by (cases F, auto)

lemma strengthen_Int[strg]:
  "st_ord F A A' \<Longrightarrow> st_ord F B B' \<Longrightarrow> st_ord F (A \<inter> B) (A' \<inter> B')"
  by (cases F, auto)

lemma strengthen_Un[strg]:
  "st_ord F A A' \<Longrightarrow> st_ord F B B' \<Longrightarrow> st_ord F (A \<union> B) (A' \<union> B')"
  by (cases F, auto)

lemma strengthen_UN[strg]:
  "st_ord F A A' \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> st_ord F (B x) (B' x))
    \<Longrightarrow> st_ord F (\<Union>x \<in> A. B x) (\<Union>x \<in> A'. B' x)"
  by (cases F, auto)

lemma strengthen_INT[strg]:
  "st_ord (\<not> F) A A' \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> st_ord F (B x) (B' x))
    \<Longrightarrow> st_ord F (\<Inter>x \<in> A. B x) (\<Inter>x \<in> A'. B' x)"
  by (cases F, auto)

lemma strengthen_imp_strengthen_prop[strg]:
  "st False (op \<longrightarrow>) P Q \<Longrightarrow> PROP (st_prop1 (Trueprop P) (Trueprop Q))"
  "st True (op \<longrightarrow>) P Q \<Longrightarrow> PROP (st_prop2 (Trueprop P) (Trueprop Q))"
  unfolding st_prop1_def st_prop2_def
  by auto

lemma st_prop_meta_imp[strg]:
  "PROP (st_prop2 (PROP X) (PROP X'))
    \<Longrightarrow> PROP (st_prop1 (PROP Y) (PROP Y'))
    \<Longrightarrow> PROP (st_prop1 (PROP X \<Longrightarrow> PROP Y) (PROP X' \<Longrightarrow> PROP Y'))"
  "PROP (st_prop1 (PROP X) (PROP X'))
    \<Longrightarrow> PROP (st_prop2 (PROP Y) (PROP Y'))
    \<Longrightarrow> PROP (st_prop2 (PROP X \<Longrightarrow> PROP Y) (PROP X' \<Longrightarrow> PROP Y'))"
  unfolding st_prop1_def st_prop2_def
  by (erule meta_mp | assumption)+

lemma st_prop_meta_all[strg]:
  "(\<And>x. PROP (st_prop1 (PROP (X x)) (PROP (X' x))))
    \<Longrightarrow> PROP (st_prop1 (\<And>x. PROP (X x)) (\<And>x. PROP (X' x)))"
  "(\<And>x. PROP (st_prop2 (PROP (X x)) (PROP (X' x))))
    \<Longrightarrow> PROP (st_prop2 (\<And>x. PROP (X x)) (\<And>x. PROP (X' x)))"
  unfolding st_prop1_def st_prop2_def
   apply (rule Pure.asm_rl)
   apply (erule meta_allE, erule meta_mp)
   apply assumption
  apply (rule Pure.asm_rl)
  apply (erule meta_allE, erule meta_mp)
  apply assumption
  done

(* to think about, what more monotonic constructions can we find? *)

end

lemma imp_consequent:
  "P \<longrightarrow> Q \<longrightarrow> P" by simp

text {* Test cases. *}

lemma
  assumes x: "\<And>x. P x \<longrightarrow> Q x"
  shows "{x. x \<noteq> None \<and> P (the x)} \<subseteq> {y. \<forall>x. y = Some x \<longrightarrow> Q x}"
  apply (strengthen x)
  apply clarsimp
  done

locale strengthen_silly_test begin

definition
  silly :: "nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "silly x y = (x \<le> y)"

lemma silly_trans:
  "silly x y \<Longrightarrow> silly y z \<Longrightarrow> silly x z"
  by (simp add: silly_def)

lemma silly_refl:
  "silly x x"
  by (simp add: silly_def)

lemma foo:
  "silly x y \<Longrightarrow> silly a b \<Longrightarrow> silly b c
    \<Longrightarrow> silly x y \<and> (\<forall>x :: nat. silly a c )"
  using [[strengthen_trace = true]]
  apply (strengthen silly_trans[mk_strg I E])+
  apply (strengthen silly_refl)
  apply simp
  done

lemma foo_asm:
  "silly x y \<Longrightarrow> silly y z
    \<Longrightarrow> (silly x z \<Longrightarrow> silly a b) \<Longrightarrow> silly z z \<Longrightarrow> silly a b"
  apply (strengthen_asm silly_trans[mk_strg I A])
  apply (strengthen_asm silly_trans[mk_strg I A])
  apply simp
  done

lemma foo_method:
  "silly x y \<Longrightarrow> silly a b \<Longrightarrow> silly b c
    \<Longrightarrow> silly x y \<and> (\<forall>x :: nat. z \<longrightarrow> silly a c )"
  using [[strengthen_trace = true]]
  apply simp
  apply (strengthen_method \<open>rule silly_trans\<close>)
  apply (strengthen_method \<open>rule exI[where x=b]\<close>)
  apply simp
  done

end
end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weakening
  imports Weak_Bisimulation
begin

locale weak = env +
  assumes weaken: "\<Psi> \<hookrightarrow> \<Psi> \<otimes> \<Psi>'"
begin

lemma entWeaken:
  fixes \<Psi> :: 'b
  and   \<phi> :: 'c

  assumes "\<Psi> \<turnstile> \<phi>"

  shows "\<Psi> \<otimes> \<Psi>' \<turnstile> \<phi>"
using assms weaken
by(auto simp add: Assertion_stat_imp_def)

lemma assertWeaken:
  fixes \<Psi>  :: 'b
  and   \<Psi>' :: 'b

  shows "\<Psi> \<hookrightarrow> \<Psi> \<otimes> \<Psi>'"
by(auto simp add: Assertion_stat_imp_def entWeaken)

lemma frameWeaken:
  fixes F :: "'b frame"
  and   G :: "'b frame"

  shows "F \<hookrightarrow>\<^sub>F F \<otimes>\<^sub>F G"
proof -
  obtain A\<^sub>F \<Psi>\<^sub>F where FrF: "F = \<langle>A\<^sub>F, \<Psi>\<^sub>F\<rangle>" and "A\<^sub>F \<sharp>* F" and  "A\<^sub>F \<sharp>* G"
    by(rule_tac F=F and C="(F, G)" in fresh_frame) auto
  obtain A\<^sub>G \<Psi>\<^sub>G where FrG: "G = \<langle>A\<^sub>G, \<Psi>\<^sub>G\<rangle>" and "A\<^sub>G \<sharp>* F" and  "A\<^sub>G \<sharp>* G" and "A\<^sub>G \<sharp>* A\<^sub>F" and "A\<^sub>G \<sharp>* \<Psi>\<^sub>F"
    by(rule_tac F=G and C="(F, G, A\<^sub>F, \<Psi>\<^sub>F)" in fresh_frame) auto
  from FrG `A\<^sub>F \<sharp>* G` `A\<^sub>G \<sharp>* A\<^sub>F` have "A\<^sub>F \<sharp>* \<Psi>\<^sub>G" by auto
  have "\<Psi>\<^sub>F \<hookrightarrow> \<Psi>\<^sub>F \<otimes> \<Psi>\<^sub>G" by(rule weaken)
  hence "\<langle>A\<^sub>G, \<Psi>\<^sub>F\<rangle> \<hookrightarrow>\<^sub>F \<langle>A\<^sub>G, \<Psi>\<^sub>F \<otimes> \<Psi>\<^sub>G\<rangle>" by(rule_tac frame_imp_res_chain_pres) auto
  with `A\<^sub>G \<sharp>* \<Psi>\<^sub>F` have "\<langle>\<epsilon>, \<Psi>\<^sub>F\<rangle> \<hookrightarrow>\<^sub>F \<langle>A\<^sub>G, \<Psi>\<^sub>F \<otimes> \<Psi>\<^sub>G\<rangle>" using frame_res_fresh_chain
    by(rule_tac Frame_stat_imp_trans) (auto simp add: Frame_stat_eq_def)
  with FrF FrG `A\<^sub>G \<sharp>* A\<^sub>F` `A\<^sub>G \<sharp>* \<Psi>\<^sub>F` `A\<^sub>F \<sharp>* \<Psi>\<^sub>G` show ?thesis
    by(force simp add: frame_chain_append intro: frame_imp_res_chain_pres)
qed

lemma unitAssertWeaken:
  fixes \<Psi> :: 'b

  shows "\<one> \<hookrightarrow> \<Psi>"
proof -
  have "\<one> \<hookrightarrow> \<one> \<otimes> \<Psi>" by(rule assertWeaken)
  moreover have "\<one> \<otimes> \<Psi> \<hookrightarrow> \<Psi>" by(metis Identity Assertion_stat_eq_def Commutativity Assertion_stat_eq_trans)
  ultimately show ?thesis by(rule Assertion_stat_imp_trans)
qed

lemma unitFrameWeaken:
  fixes F :: "'b frame"

  shows "\<langle>\<epsilon>, \<one>\<rangle> \<hookrightarrow>\<^sub>F F"
proof -
  have "\<langle>\<epsilon>, \<one>\<rangle> \<hookrightarrow>\<^sub>F ((\<langle>\<epsilon>, \<one>\<rangle>) \<otimes>\<^sub>F F)" by(rule frameWeaken)
  moreover obtain A\<^sub>F \<Psi>\<^sub>F where FrF: "F = \<langle>A\<^sub>F, \<Psi>\<^sub>F\<rangle>"
    by(rule_tac F=F and C="()" in fresh_frame) auto
  hence "(\<langle>\<epsilon>, \<one>\<rangle>) \<otimes>\<^sub>F F \<simeq>\<^sub>F F"
    by simp (metis frame_int_identity frame_int_commutativity Frame_stat_eq_trans Frame_stat_eq_sym)
  ultimately show ?thesis by(metis Frame_stat_imp_trans Frame_stat_eq_def)
qed

lemma insert_assertionWeaken:
  fixes F :: "'b frame"
  and   \<Psi> :: 'b

  shows "\<langle>\<epsilon>, \<Psi>\<rangle> \<hookrightarrow>\<^sub>F insert_assertion F \<Psi>"
proof -
  have "\<langle>\<epsilon>, \<Psi>\<rangle> \<hookrightarrow>\<^sub>F (\<langle>\<epsilon>, \<Psi>\<rangle>) \<otimes>\<^sub>F F" by(rule frameWeaken)
  thus ?thesis by simp
qed

lemma frameImpStatEq:
  fixes A\<^sub>F  :: "name list"
  and   \<Psi>  :: 'b
  and   \<Psi>' :: 'b
  and   \<phi>  :: 'c

  assumes "(\<langle>A\<^sub>F, \<Psi>\<rangle>) \<turnstile>\<^sub>F \<phi>"
  and     "\<Psi> \<simeq> \<Psi>'"

  shows "(\<langle>A\<^sub>F, \<Psi>'\<rangle>) \<turnstile>\<^sub>F \<phi>"
proof -
  obtain p::"name prm" where "(p \<bullet> A\<^sub>F) \<sharp>* \<phi>" and "(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>'"
                         and "distinct_perm p" and S: "set p \<subseteq> set A\<^sub>F \<times> set(p \<bullet> A\<^sub>F)"
    by(rule_tac c="(\<phi>, \<Psi>, \<Psi>')" in name_list_avoiding) auto
  from `(\<langle>A\<^sub>F, \<Psi>\<rangle>) \<turnstile>\<^sub>F \<phi>` `(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>` S have "(\<langle>(p \<bullet> A\<^sub>F), p \<bullet> \<Psi>\<rangle>) \<turnstile>\<^sub>F \<phi>" by(simp add: frame_chain_alpha)
  hence "(p \<bullet> \<Psi>) \<turnstile> \<phi>" using `(p \<bullet> A\<^sub>F) \<sharp>* \<phi>` by(rule frame_impE)
  moreover from `\<Psi> \<simeq> \<Psi>'` have "(p \<bullet> \<Psi>) \<simeq> (p \<bullet> \<Psi>')" by(rule Assertion_stat_eq_closed)
  ultimately have "(p \<bullet> \<Psi>') \<turnstile> \<phi>" by(simp add: Assertion_stat_eq_def Assertion_stat_imp_def)
  hence "(\<langle>(p \<bullet> A\<^sub>F), p \<bullet> \<Psi>'\<rangle>) \<turnstile>\<^sub>F \<phi>" using `(p \<bullet> A\<^sub>F) \<sharp>* \<phi>`
    by(rule_tac frame_impI) auto
  with `(p \<bullet> A\<^sub>F) \<sharp>* \<Psi>'` S show ?thesis by(simp add: frame_chain_alpha)
qed

  assumes "\<Psi> \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'"

  shows "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame P') \<Psi>"
proof(auto simp add: Frame_stat_imp_def)
  fix \<phi> :: 'c
  obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* P" and "A\<^sub>P \<sharp>* \<phi>" and "A\<^sub>P \<sharp>* \<Psi>" and "distinct A\<^sub>P"
    by(rule_tac C="(P, \<phi>, \<Psi>)" in fresh_frame) auto
  with `\<Psi> \<rhd> P \<longmapsto>None @ \<tau> \<prec> P'` obtain \<Psi>' A\<^sub>P' \<Psi>\<^sub>P' where FrP': "extract_frame P' = \<langle>A\<^sub>P', \<Psi>\<^sub>P'\<rangle>" and "\<Psi>\<^sub>P \<otimes> \<Psi>' \<simeq> \<Psi>\<^sub>P'"
                                              and "A\<^sub>P' \<sharp>* P'" and "A\<^sub>P' \<sharp>* \<phi>"  and "A\<^sub>P' \<sharp>* \<Psi>"
    by(rule_tac C="(\<Psi>, \<phi>)" in expand_tau_frame) auto
  assume "insert_assertion (extract_frame P) \<Psi> \<turnstile>\<^sub>F \<phi>"
  with FrP `A\<^sub>P \<sharp>* \<phi>` `A\<^sub>P \<sharp>* \<Psi>` have "\<Psi> \<otimes> \<Psi>\<^sub>P \<turnstile> \<phi>" by(auto dest: frame_impE)
  hence "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<turnstile> \<phi>" by(rule entWeaken)
  hence "\<Psi> \<otimes> \<Psi>\<^sub>P' \<turnstile> \<phi>" using `\<Psi>\<^sub>P \<otimes> \<Psi>' \<simeq> \<Psi>\<^sub>P'`
    by(rule_tac stat_eq_ent, auto) (metis Associativity composition_sym Assertion_stat_eq_trans Assertion_stat_eq_sym Commutativity)
  with `A\<^sub>P' \<sharp>* \<phi>` `A\<^sub>P' \<sharp>* \<Psi>` FrP' show "insert_assertion (extract_frame P') \<Psi> \<turnstile>\<^sub>F \<phi>"
    by(force intro: frame_impI)
qed

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

  assumes "\<Psi> \<rhd> P \<longmapsto> \<pi> @ Rs"

  shows "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto> \<pi> @ Rs"
using assms
proof(nominal_induct avoiding: \<Psi>' rule: semantics.strong_induct)
  case(c_input \<Psi> M K xvec N Tvec P \<Psi>')
  from `\<Psi> \<turnstile> M \<leftrightarrow> K` have "\<Psi> \<otimes> \<Psi>' \<turnstile> M \<leftrightarrow> K" by(rule entWeaken)
  thus ?case using `distinct xvec` `set xvec \<subseteq> (supp N)` `length xvec = length Tvec`
    by(rule Input)
next
  case(Output \<Psi> M K N P \<Psi>')
  from `\<Psi> \<turnstile> M \<leftrightarrow> K` have "\<Psi> \<otimes> \<Psi>' \<turnstile> M \<leftrightarrow> K" by(rule entWeaken)
  thus ?case by(rule semantics.Output)
next
  case(Case \<Psi> P \<pi> Rs \<phi> Cs \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto> \<pi> @ Rs" by(rule Case)
  moreover note `(\<phi>, P) mem Cs`
  moreover from `\<Psi> \<turnstile> \<phi>` have "\<Psi> \<otimes> \<Psi>' \<turnstile> \<phi>" by(rule entWeaken)
  ultimately show ?case using `guarded P`
    by(rule semantics.Case)
next
  case(c_par1 \<Psi> \<Psi>\<^sub>Q P \<pi> \<alpha> P' Q A\<^sub>Q \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<rhd> P \<longmapsto>\<pi> @ \<alpha> \<prec> P'" by(rule c_par1)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>Q \<rhd> P \<longmapsto>\<pi> @ \<alpha> \<prec> P'"
    by(metis stat_eq_transition Composition Associativity Commutativity Assertion_stat_eq_trans)
  thus ?case using `extract_frame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>` `bn \<alpha> \<sharp>* Q` `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>'` `A\<^sub>Q \<sharp>* P` `A\<^sub>Q \<sharp>* \<alpha>`
    by(rule_tac Par1) auto
next
  case(c_par2 \<Psi> \<Psi>\<^sub>P Q \<pi> \<alpha> Q' P A\<^sub>P \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<rhd> Q \<longmapsto>\<pi> @ \<alpha> \<prec> Q'" by(rule c_par2)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<rhd> Q \<longmapsto>\<pi> @ \<alpha> \<prec> Q'"
    by(metis stat_eq_transition Composition Associativity Commutativity Assertion_stat_eq_trans)
  thus ?case using `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>` `bn \<alpha> \<sharp>* P` `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>'` `A\<^sub>P \<sharp>* Q` `A\<^sub>P \<sharp>* \<alpha>`
    by(rule_tac Par2) auto
next
  case(c_comm1 \<Psi> \<Psi>\<^sub>Q P A\<^sub>P yvec K M N P' \<Psi>\<^sub>P Q A\<^sub>Q zvec xvec Q' \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<rhd> P \<longmapsto> Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>N\<rparr> \<prec> P'" by(rule c_comm1)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>Q \<rhd> P \<longmapsto> Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>N\<rparr> \<prec> P'"
    by(metis stat_eq_transition Composition Associativity Commutativity Assertion_stat_eq_trans)
  moreover note `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>`
  moreover have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<rhd> Q \<longmapsto>Some (\<langle>A\<^sub>Q; zvec, M\<rangle>) @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q'" by(rule c_comm1)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<rhd> Q \<longmapsto>Some (\<langle>A\<^sub>Q; zvec, M\<rangle>) @ K\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> Q'"
    by(metis stat_eq_transition Composition Associativity Commutativity Assertion_stat_eq_trans)
  moreover note `extract_frame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>`
  ultimately show ?case using `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>'` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* Q` `A\<^sub>P \<sharp>* M` `A\<^sub>P \<sharp>* A\<^sub>Q`
                              `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>'` `A\<^sub>Q \<sharp>* P` `A\<^sub>Q \<sharp>* Q` `A\<^sub>Q \<sharp>* K` `xvec \<sharp>* P`
                              `yvec \<sharp>* \<Psi>` `yvec \<sharp>* \<Psi>\<^sub>P` `yvec \<sharp>* \<Psi>'` `yvec \<sharp>* Q`
                              `zvec \<sharp>* \<Psi>` `zvec \<sharp>* \<Psi>\<^sub>Q` `zvec \<sharp>* \<Psi>'` `zvec \<sharp>* P`
    by(rule_tac Comm1) (assumption | auto)+
next
  case(c_comm2 \<Psi> \<Psi>\<^sub>Q P A\<^sub>P yvec K M xvec N P' \<Psi>\<^sub>P Q A\<^sub>Q zvec Q' \<Psi>')
  have "(\<Psi> \<otimes> \<Psi>\<^sub>Q) \<otimes> \<Psi>' \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'" by(rule c_comm2)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>Q \<rhd> P \<longmapsto>Some (\<langle>A\<^sub>P; yvec, K\<rangle>) @ M\<lparr>\<nu>*xvec\<rparr>\<langle>N\<rangle> \<prec> P'"
    by(metis stat_eq_transition Composition Associativity Commutativity Assertion_stat_eq_trans)
  moreover note `extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>`
  moreover have "(\<Psi> \<otimes> \<Psi>\<^sub>P) \<otimes> \<Psi>' \<rhd> Q \<longmapsto>Some (\<langle>A\<^sub>Q; zvec, M\<rangle>) @ K\<lparr>N\<rparr> \<prec> Q'" by(rule c_comm2)
  hence "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>P \<rhd> Q \<longmapsto>Some (\<langle>A\<^sub>Q; zvec, M\<rangle>) @ K\<lparr>N\<rparr> \<prec> Q'"
    by(metis stat_eq_transition Composition Associativity Commutativity Assertion_stat_eq_trans)
  moreover note `extract_frame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>`
  ultimately show ?case using `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>'` `A\<^sub>P \<sharp>* P` `A\<^sub>P \<sharp>* Q` `A\<^sub>P \<sharp>* M` `A\<^sub>P \<sharp>* A\<^sub>Q`
                              `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>'` `A\<^sub>Q \<sharp>* P` `A\<^sub>Q \<sharp>* Q` `A\<^sub>Q \<sharp>* K` `xvec \<sharp>* Q`
                              `yvec \<sharp>* \<Psi>` `yvec \<sharp>* \<Psi>\<^sub>P` `yvec \<sharp>* \<Psi>'` `yvec \<sharp>* Q`
                              `zvec \<sharp>* \<Psi>` `zvec \<sharp>* \<Psi>\<^sub>Q` `zvec \<sharp>* \<Psi>'` `zvec \<sharp>* P`
    by(rule_tac Comm2) (assumption | auto)+
next
  case(c_open \<Psi> P \<pi> M xvec yvec N P' x \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto>Some \<pi> @ M\<lparr>\<nu>*(xvec@yvec)\<rparr>\<langle>N\<rangle> \<prec> P'" by(rule c_open)
  thus ?case using `x \<in> supp N` `x \<sharp> \<Psi>` `x \<sharp> \<Psi>'` `x \<sharp> M` `x \<sharp> xvec` `x \<sharp> yvec`
    by(rule_tac Open) auto
next
  case(c_scope \<Psi> P \<pi> \<alpha> P' x \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<longmapsto>\<pi> @ \<alpha> \<prec> P'" by(rule c_scope)
  thus ?case using `x \<sharp> \<Psi>` `x \<sharp> \<Psi>'` `x \<sharp> \<alpha>` by(rule_tac Scope) auto
next
  case(Bang \<Psi> P \<pi> Rs \<Psi>')
  have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<parallel> !P\<longmapsto>\<pi> @ Rs" by(rule Bang)
  thus ?case using `guarded P` by(rule semantics.Bang)
qed

end

end


(*  Title:      HOL/IMPP/Natural.thy
    Author:     David von Oheimb (based on a theory by Tobias Nipkow et al), TUM
*)

section {* Natural semantics of commands *}

theory Natural
imports Com
begin

(** Execution of commands **)

consts
  newlocs :: locals
  setlocs :: "state => locals => state"
  getlocs :: "state => locals"
  update  :: "state => vname => val => state"     ("_/[_/::=/_]" [900,0,0] 900)

abbreviation
  loc :: "state => locals"  ("_<_>" [75,0] 75) where
  "s<X> == getlocs s X"

inductive
  evalc :: "[com,state,    state] => bool"  ("<_,_>/ -c-> _" [0,0,  51] 51)
  where
    Skip:    "<SKIP,s> -c-> s"

  | Assign:  "<X :== a,s> -c-> s[X::=a s]"

  | Local:   "<c, s0[Loc Y::= a s0]> -c-> s1 ==>
              <LOCAL Y := a IN c, s0> -c-> s1[Loc Y::=s0<Y>]"

  | Semi:    "[| <c0,s0> -c-> s1; <c1,s1> -c-> s2 |] ==>
              <c0;; c1, s0> -c-> s2"

  | IfTrue:  "[| b s; <c0,s> -c-> s1 |] ==>
              <IF b THEN c0 ELSE c1, s> -c-> s1"

  | IfFalse: "[| ~b s; <c1,s> -c-> s1 |] ==>
              <IF b THEN c0 ELSE c1, s> -c-> s1"

  | WhileFalse: "~b s ==> <WHILE b DO c,s> -c-> s"

  | WhileTrue:  "[| b s0;  <c,s0> -c-> s1;  <WHILE b DO c, s1> -c-> s2 |] ==>
                 <WHILE b DO c, s0> -c-> s2"

  | Body:       "<the (body pn), s0> -c-> s1 ==>
                 <BODY pn, s0> -c-> s1"

  | Call:       "<BODY pn, (setlocs s0 newlocs)[Loc Arg::=a s0]> -c-> s1 ==>
                 <X:=CALL pn(a), s0> -c-> (setlocs s1 (getlocs s0))
                                          [X::=s1<Res>]"

inductive
  evaln :: "[com,state,nat,state] => bool"  ("<_,_>/ -_-> _" [0,0,0,51] 51)
  where
    Skip:    "<SKIP,s> -n-> s"

  | Assign:  "<X :== a,s> -n-> s[X::=a s]"

  | Local:   "<c, s0[Loc Y::= a s0]> -n-> s1 ==>
              <LOCAL Y := a IN c, s0> -n-> s1[Loc Y::=s0<Y>]"

  | Semi:    "[| <c0,s0> -n-> s1; <c1,s1> -n-> s2 |] ==>
              <c0;; c1, s0> -n-> s2"

  | IfTrue:  "[| b s; <c0,s> -n-> s1 |] ==>
              <IF b THEN c0 ELSE c1, s> -n-> s1"

  | IfFalse: "[| ~b s; <c1,s> -n-> s1 |] ==>
              <IF b THEN c0 ELSE c1, s> -n-> s1"

  | WhileFalse: "~b s ==> <WHILE b DO c,s> -n-> s"

  | WhileTrue:  "[| b s0;  <c,s0> -n-> s1;  <WHILE b DO c, s1> -n-> s2 |] ==>
                 <WHILE b DO c, s0> -n-> s2"

  | Body:       "<the (body pn), s0> -    n-> s1 ==>
                 <BODY pn, s0> -Suc n-> s1"

  | Call:       "<BODY pn, (setlocs s0 newlocs)[Loc Arg::=a s0]> -n-> s1 ==>
                 <X:=CALL pn(a), s0> -n-> (setlocs s1 (getlocs s0))
                                          [X::=s1<Res>]"

inductive_cases evalc_elim_cases:
  "<SKIP,s> -c-> t"  "<X:==a,s> -c-> t"  "<LOCAL Y:=a IN c,s> -c-> t"
  "<c1;;c2,s> -c-> t"  "<IF b THEN c1 ELSE c2,s> -c-> t"
  "<BODY P,s> -c-> s1"  "<X:=CALL P(a),s> -c-> s1"

inductive_cases evaln_elim_cases:
  "<SKIP,s> -n-> t"  "<X:==a,s> -n-> t"  "<LOCAL Y:=a IN c,s> -n-> t"
  "<c1;;c2,s> -n-> t"  "<IF b THEN c1 ELSE c2,s> -n-> t"
  "<BODY P,s> -n-> s1"  "<X:=CALL P(a),s> -n-> s1"

inductive_cases evalc_WHILE_case: "<WHILE b DO c,s> -c-> t"
inductive_cases evaln_WHILE_case: "<WHILE b DO c,s> -n-> t"

declare evalc.intros [intro]
declare evaln.intros [intro]

declare evalc_elim_cases [elim!]
declare evaln_elim_cases [elim!]

(* evaluation of com is deterministic *)
lemma com_det [rule_format (no_asm)]: "<c,s> -c-> t ==> (!u. <c,s> -c-> u --> u=t)"
apply (erule evalc.induct)
apply (erule_tac [8] V = "<?c,s1> -c-> s2" in thin_rl)
(*blast needs unify_search_bound = 40*)
apply (best elim: evalc_WHILE_case)+
done

lemma evaln_evalc: "<c,s> -n-> t ==> <c,s> -c-> t"
apply (erule evaln.induct)
apply (tactic {* ALLGOALS (resolve_tac @{thms evalc.intros} THEN_ALL_NEW atac) *})
done

lemma Suc_le_D_lemma: "[| Suc n <= m'; (!!m. n <= m ==> P (Suc m)) |] ==> P m'"
apply (frule Suc_le_D)
apply blast
done

lemma evaln_nonstrict [rule_format]: "<c,s> -n-> t ==> !m. n<=m --> <c,s> -m-> t"
apply (erule evaln.induct)
apply (auto elim!: Suc_le_D_lemma)
done

lemma evaln_Suc: "<c,s> -n-> s' ==> <c,s> -Suc n-> s'"
apply (erule evaln_nonstrict)
apply auto
done

lemma evaln_max2: "[| <c1,s1> -n1-> t1;  <c2,s2> -n2-> t2 |] ==>
    ? n. <c1,s1> -n -> t1 & <c2,s2> -n -> t2"
apply (cut_tac m = "n1" and n = "n2" in nat_le_linear)
apply (blast dest: evaln_nonstrict)
done

lemma evalc_evaln: "<c,s> -c-> t ==> ? n. <c,s> -n-> t"
apply (erule evalc.induct)
apply (tactic {* ALLGOALS (REPEAT o etac exE) *})
apply (tactic {* TRYALL (EVERY' [dtac @{thm evaln_max2}, assume_tac @{context},
  REPEAT o eresolve_tac [exE, conjE]]) *})
apply (tactic {* ALLGOALS (rtac exI THEN' resolve_tac @{thms evaln.intros} THEN_ALL_NEW atac) *})
done

lemma eval_eq: "<c,s> -c-> t = (? n. <c,s> -n-> t)"
apply (fast elim: evalc_evaln evaln_evalc)
done

end


section \<open>\isaheader{Map Interface}\<close>
theory Intf_Map
imports Refine_Monadic.Refine_Monadic
begin

consts i_map :: "interface \<Rightarrow> interface \<Rightarrow> interface"

definition [simp]: "op_map_empty \<equiv> Map.empty"
definition op_map_lookup :: "'k \<Rightarrow> ('k\<rightharpoonup>'v) \<rightharpoonup> 'v"
  where [simp]: "op_map_lookup k m \<equiv> m k"
definition [simp]: "op_map_update k v m \<equiv> m(k\<mapsto>v)"
definition [simp]: "op_map_delete k m \<equiv> m |` (-{k})"
definition [simp]: "op_map_restrict P m \<equiv> m |` {k\<in>dom m. P (k, the (m k))}"
definition [simp]: "op_map_isEmpty x \<equiv> x=Map.empty"
definition [simp]: "op_map_isSng x \<equiv> \<exists>k v. x=[k\<mapsto>v]"
definition [simp]: "op_map_ball m P \<equiv> Ball (map_to_set m) P"
definition [simp]: "op_map_bex m P \<equiv> Bex (map_to_set m) P"
definition [simp]: "op_map_size m \<equiv> card (dom m)"
definition [simp]: "op_map_size_abort n m \<equiv> min n (card (dom m))"
definition [simp]: "op_map_sel m P \<equiv> SPEC (\<lambda>(k,v). m k = Some v \<and> P k v)"
definition [simp]: "op_map_pick m \<equiv> SPEC (\<lambda>(k,v). m k = Some v)"

definition [simp]: "op_map_pick_remove m \<equiv>
  SPEC (\<lambda>((k,v),m'). m k = Some v \<and> m' = m |` (-{k}))"

context begin interpretation autoref_syn .

  "m=Map.empty \<equiv> op_map_isEmpty$m"
  "Map.empty=m \<equiv> op_map_isEmpty$m"
  "dom m = {} \<equiv> op_map_isEmpty$m"
  "{} = dom m \<equiv> op_map_isEmpty$m"

  "\<exists>k v. m=[k\<mapsto>v] \<equiv> op_map_isSng$m"
  "\<exists>k v. [k\<mapsto>v]=m \<equiv> op_map_isSng$m"
  "\<exists>k. dom m={k} \<equiv> op_map_isSng$m"
  "\<exists>k. {k} = dom m \<equiv> op_map_isSng$m"
  "1 = card (dom m) \<equiv> op_map_isSng$m"

  "\<And>P. Ball (map_to_set m) P \<equiv> op_map_ball$m$P"
  "\<And>P. Bex (map_to_set m) P \<equiv> op_map_bex$m$P"

  "card (dom m) \<equiv> op_map_size$m"

  "min n (card (dom m)) \<equiv> op_map_size_abort$n$m"
  "min (card (dom m)) n \<equiv> op_map_size_abort$n$m"

  "\<And>P. SPEC (\<lambda>(k,v). m k=Some v \<and> P k v) \<equiv> op_map_sel$m$P"
  "\<And>P. SPEC (\<lambda>(k,v). P k v \<and> m k=Some v) \<equiv> op_map_sel$m$P"

  "\<And>P. SPEC (\<lambda>(k,v). m k = Some v) \<equiv> op_map_pick$m"
  "\<And>P. SPEC (\<lambda>(k,v). (k,v) \<in> map_to_set m) \<equiv> op_map_pick$m"
  by (auto
    intro!: eq_reflection ext
    simp: restrict_map_def dom_eq_singleton_conv card_Suc_eq map_to_set_def
    dest!: sym[of "Suc 0" "card (dom m)"] sym[of _ "dom m"]
  )

  lemma [autoref_op_pat]:
    "SPEC (\<lambda>((k,v),m'). m k = Some v \<and> m' = m |` (-{k}))
      \<equiv> op_map_pick_remove$m"
    by simp

  lemma op_map_pick_remove_alt: "
    do {((k,v),m) \<leftarrow> op_map_pick_remove m; f k v m}
      = (
    do {
      (k,v)\<leftarrow>SPEC (\<lambda>(k,v). m k = Some v);
       let m=m |` (-{k});
       f k v m
    })"
    unfolding op_map_pick_remove_def
    apply (auto simp: pw_eq_iff refine_pw_simps)
    done

  lemma [autoref_op_pat]:
    "do {
      (k,v)\<leftarrow>SPEC (\<lambda>(k,v). m k = Some v);
       let m=m |` (-{k});
       f k v m
    } \<equiv> do {((k,v),m) \<leftarrow> op_map_pick_remove m; f k v m}"
    unfolding op_map_pick_remove_alt .

end

lemma [autoref_itype]:
  "op_map_empty ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_lookup ::\<^sub>i Ik \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_option"
  "op_map_update ::\<^sub>i Ik \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_delete ::\<^sub>i Ik \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_restrict
    ::\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "op_map_isEmpty ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_bool"
  "op_map_isSng ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_bool"
  "op_map_ball ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_map_bex ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (\<langle>Ik,Iv\<rangle>\<^sub>ii_prod \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_map_size ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_nat"
  "op_map_size_abort ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i i_nat"
  "(++) ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"
  "map_of ::\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map"

  "op_map_sel ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i (Ik \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i i_bool)
    \<rightarrow>\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "op_map_pick ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  "op_map_pick_remove
    ::\<^sub>i \<langle>Ik,Iv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Ik,Iv\<rangle>\<^sub>ii_prod,\<langle>Ik,Iv\<rangle>\<^sub>ii_map\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  by simp_all

lemma hom_map1[autoref_hom]:
  "CONSTRAINT Map.empty (\<langle>Rk,Rv\<rangle>Rm)"
  "CONSTRAINT map_of (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
  "CONSTRAINT (++) (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk,Rv\<rangle>Rm)"
  by simp_all

term op_map_restrict

  "CONSTRAINT op_map_sel (\<langle>Rk,Rv\<rangle>Rm\<rightarrow>(Rk \<rightarrow> Rv \<rightarrow> bool_rel)\<rightarrow>\<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
  "CONSTRAINT op_map_pick (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>Rk\<times>\<^sub>rRv\<rangle>nres_rel)"
  "CONSTRAINT op_map_pick_remove (\<langle>Rk,Rv\<rangle>Rm \<rightarrow> \<langle>(Rk\<times>\<^sub>rRv)\<times>\<^sub>r\<langle>Rk,Rv\<rangle>Rm\<rangle>nres_rel)"
  by simp_all

definition "finite_map_rel R \<equiv> Range R \<subseteq> Collect (finite \<circ> dom)"
lemma finite_map_rel_trigger: "finite_map_rel R \<Longrightarrow> finite_map_rel R" .

declaration \<open>Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms finite_map_rel_trigger}\<close>

end