theory ToDo_Tensor
  imports Tensor_Product
begin

lemma cinner_tensor: "(\<gamma> \<otimes> \<psi>) \<bullet>\<^sub>C (\<delta> \<otimes> \<phi>) = (\<psi> \<bullet>\<^sub>C \<phi>) * (\<gamma> \<bullet>\<^sub>C \<delta>)" for \<gamma> \<psi> \<delta> \<phi> :: \<open>_ ell2\<close>
  sorry

lemma addState_adj_times_addState[simp]:
  includes cblinfun_notation no_blinfun_notation
  fixes \<psi> \<phi> :: "'a ell2"
  shows "addState \<psi>* o\<^sub>C\<^sub>L addState \<phi> = (\<psi> \<bullet>\<^sub>C \<phi>) *\<^sub>C (id_cblinfun::('b ell2,'b ell2) cblinfun)"
proof -
  have "\<gamma> \<bullet>\<^sub>C ((addState \<psi>* o\<^sub>C\<^sub>L addState \<phi>) *\<^sub>V \<delta>) = \<gamma> \<bullet>\<^sub>C (((\<psi> \<bullet>\<^sub>C \<phi>) *\<^sub>C id_cblinfun) *\<^sub>V \<delta>)" for \<gamma> \<delta> :: "'b ell2"
    apply (simp add: cblinfun_compose_image cinner_adj_right)
    apply (transfer fixing: \<psi> \<phi> \<delta> \<gamma>)
    by (simp add: cinner_tensor)
  hence "(addState \<psi>* o\<^sub>C\<^sub>L addState \<phi>) *\<^sub>V \<delta> = ((\<psi> \<bullet>\<^sub>C \<phi>) *\<^sub>C id_cblinfun) *\<^sub>V \<delta>" for \<delta> :: "'b ell2"
    by (metis (no_types, lifting) adjoint_eqI cinner_adj_left double_adj)
  thus ?thesis
    by (rule cblinfun_eqI)
qed

lemma ket_product: "ket (a,b) = ket a \<otimes> ket b"
  sorry

lemma tensorOp_applyOp_distr:
  includes cblinfun_notation no_blinfun_notation
  shows "(A \<otimes> B) *\<^sub>V (\<psi> \<otimes> \<phi>) = (A *\<^sub>V \<psi>) \<otimes> (B *\<^sub>V \<phi>)"
  sorry

lemma assoc_op_apply_tensor[simp]:
  includes cblinfun_notation no_blinfun_notation
  shows "assoc_op *\<^sub>V (\<psi> \<otimes> (\<phi> \<otimes> \<tau>)) = (\<psi> \<otimes> \<phi>) \<otimes> \<tau>"
  sorry

lemma comm_op_apply_tensor[simp]:
  includes cblinfun_notation no_blinfun_notation
  shows "comm_op *\<^sub>V (\<psi>\<otimes>\<phi>) = (\<phi>\<otimes>\<psi>)"
  sorry

lemma assoc_op_adj_apply_tensor[simp]:
  includes cblinfun_notation no_blinfun_notation
  shows "assoc_op* *\<^sub>V ((\<psi>\<otimes>\<phi>)\<otimes>\<tau>) = \<psi>\<otimes>(\<phi>\<otimes>\<tau>)"
  sorry

lemma span_tensor: "ccspan G \<otimes> ccspan H = ccspan {g\<otimes>h|g h. g\<in>G \<and> h\<in>H}"
  sorry

lemma span_tensors:
  "closure (cspan {C1 \<otimes> C2| (C1::(_,_) l2bounded) (C2::(_,_) l2bounded). True}) = UNIV"
  sorry

end


(*by Ammer*)
theory VEBT_DelImperative imports VEBT_DeleteCorrectness VEBT_SuccPredImperative
begin

context begin
interpretation VEBT_internal .

section \<open>Imperative Delete\<close>

partial_function (heap_time) vebt_deletei::"VEBTi \<Rightarrow> nat \<Rightarrow> VEBTi Heap" where
  "vebt_deletei t x = (case t of (Leafi a b) \<Rightarrow> (if x = 0 then return (Leafi False b) else
                                         if x = 1 then return (Leafi a False) else
                                          return (Leafi a b)) |
                            (Nodei info deg treeArray summary) \<Rightarrow> (
                                if deg \<le> 1 then return  (Nodei info deg treeArray summary) else
                                     case info of None \<Rightarrow> return  (Nodei info deg treeArray summary)|
                                           (Some mima) \<Rightarrow> ( if x < fst mima \<or> x > snd mima then return  (Nodei info deg treeArray summary)
                                                      else  if fst mima = x \<and> snd mima = x then return  (Nodei None deg treeArray summary)
                                                  else do{ xminew <- (if x = fst mima then do {
                                                                        firstcluster <- vebt_minti summary;
                                                                        firsttree <- Array_Time.nth  treeArray (the firstcluster);
                                                                        mintft <- vebt_minti firsttree;
                                                                        let xn = (2^(deg div 2) * (the firstcluster) +
                                                                                (the mintft) );
                                                                        return (xn, xn)
                                                                               }
                                                                      else return (x, fst mima));
                                                          let xnew = fst xminew;
                                                          let minew = snd xminew;
                                                          h <- highi xnew (deg div 2);
                                                          l <- lowi xnew (deg div 2);
                                                          aktnode <- Array_Time.nth treeArray h;
                                                          aktnode'<-vebt_deletei aktnode l;
                                                          treeArray' <- Array_Time.upd h aktnode' treeArray;
                                                          miny <- vebt_minti aktnode';
                                                         (if (miny = None) then
                                                          do{
                                                              summary' <-vebt_deletei summary h;
                                                              ma <-  (if xnew = snd mima then
                                                              do{
                                                                  summax <- vebt_maxti summary';
                                                                  if summax = None then
                                                                        return minew
                                                                  else do{
                                                                          maxtree <- Array_Time.nth treeArray' (the summax);
                                                                          mofmtree<- vebt_maxti maxtree;
                                                                          return (the summax * 2^(deg div 2) +
                                                                                the mofmtree )
                                                                          }
                                                                 }
                                                                  else return (snd mima));
                                                              return (Nodei (Some (minew, ma)) deg treeArray' summary')
                                                          } else  if xnew = snd mima then
                                                            do{
                                                                nextree <- Array_Time.nth treeArray' h;
                                                                maxnext<- vebt_maxti nextree;
                                                                let ma = h * 2^(deg div 2) +
                                                                              (the maxnext);
                                                                return (Nodei (Some ( minew, ma)) deg treeArray' summary)
                                                               }
                                                            else return (Nodei (Some (minew, snd mima)) deg treeArray' summary) )
                                                          })))"

end

context VEBT_internal begin

text \<open>Some general lemmas\<close>

lemma midextr:"(P * Q * Q' *R \<Longrightarrow>\<^sub>A X) \<Longrightarrow> (P * R * Q *Q' \<Longrightarrow>\<^sub>A X)"
  by (smt (verit, ccfv_threshold) ab_semigroup_mult_class.mult.commute assn_aci(9) entails_def mod_frame_fwd)

lemma groupy: "A *B * (C * D) \<Longrightarrow>\<^sub>A X \<Longrightarrow>A *B * C * D \<Longrightarrow>\<^sub>A X "
  by (simp add: assn_aci(9))

lemma swappa: "B* A* C \<Longrightarrow>\<^sub>A X \<Longrightarrow>A *B * C  \<Longrightarrow>\<^sub>A X "
  by (simp add: ab_semigroup_mult_class.mult.commute)

lemma mulcomm: "(i::nat) * (2 * 2 ^ (va div 2)) =  (2 * 2 ^ (va div 2)) * i"
  by simp

text \<open>Modified function with ghost variable\<close>

partial_function (heap_time) vebt_deletei'::"VEBT \<Rightarrow> VEBTi \<Rightarrow> nat \<Rightarrow> VEBTi Heap" where
  "vebt_deletei' t ti x = (case ti of (Leafi a b) \<Rightarrow> (if x = 0 then return (Leafi False b) else
                                         if x = 1 then return (Leafi a False) else
                                          return (Leafi a b)) |
                        (Nodei info deg treeArray summary) \<Rightarrow> (
                                 do { assert'( is_Node t);
                      let (info',deg',treeList,summary') =
                     (case t of Node info' deg' treeList summary'
                                     \<Rightarrow> (info',deg',treeList,summary'));
                      assert'(info'=info \<and> deg'=deg \<and> is_Node t);
                                if deg \<le> 1 then return  (Nodei info deg treeArray summary) else
                                     case info of None \<Rightarrow> return  (Nodei info deg treeArray summary)|
                                           (Some mima) \<Rightarrow> (
                                                  if x < fst mima \<or> x > snd mima then return  (Nodei info deg treeArray summary)
                                                      else  if fst mima = x \<and> snd mima = x then return  (Nodei None deg treeArray summary)
                                                  else do{ xminew <- (if x = fst mima then do {
                                                                        firstcluster <- vebt_minti summary;
                                                                        firsttree <- Array_Time.nth  treeArray (the firstcluster);
                                                                        mintft <- vebt_minti firsttree;
                                                                        let xn = (2^(deg div 2) * (the firstcluster) +
                                                                                (the mintft) );
                                                                        return (xn, xn)
                                                                               }
                                                                      else return (x, fst mima));
                                                          let xnew = fst xminew;
                                                          let xn' =
                                                           (if x = fst (the info')
                                                            then the (vebt_mint summary') * 2^(deg div 2)
                                                             + the (vebt_mint (treeList ! the (vebt_mint summary')))
                                                            else x);
                                                          assert' (xnew = xn');
                                                          let minew = snd xminew;
                                                          assert' (minew = (if x = fst (the info') then xn' else  fst (the info')));
                                                          h <- highi xnew (deg div 2);
                                                          assert' (h = high xnew (deg div 2));
                                                          assert'( h < length treeList);
                                                          l <- lowi xnew (deg div 2);
                                                          assert'(l = low xnew (deg div 2));
                                                          aktnode <- Array_Time.nth treeArray h;
                                                          aktnode'<-vebt_deletei' (treeList ! h) aktnode l;
                                                          treeArray' <- Array_Time.upd h aktnode' treeArray;
                                                        let funnode = vebt_delete (treeList !  h) l;
                                                        let treeList' = treeList[h:= funnode];
                                                          miny <- vebt_minti aktnode';
                                                          assert' (miny = vebt_mint funnode);
                                                         (if (miny = None) then
                                                          do{
                                                              summaryi' <-vebt_deletei' summary' summary h;
                                                              ma <-  (if xnew = snd mima then
                                                              do{
                                                                  summax <- vebt_maxti summaryi';
                                                                  assert' (summax = vebt_maxt (vebt_delete summary' h));
                                                                  if summax = None then
                                                                        return minew
                                                                  else do{
                                                                          maxtree <- Array_Time.nth treeArray' (the summax);
                                                                          mofmtree<- vebt_maxti maxtree;
                                                                          return (the summax * 2^(deg div 2) +
                                                                                the mofmtree )
                                                                          }
                                                                 }
                                                                  else return (snd mima));
                                                              return (Nodei (Some (minew, ma)) deg treeArray' summaryi')
                                                          } else  if xnew = snd mima then
                                                            do{
                                                                nextree <- Array_Time.nth treeArray' h;
                                                                maxnext<- vebt_maxti nextree;
                                                                assert' (maxnext = vebt_maxt (treeList' ! h));
                                                                let ma = h * 2^(deg div 2) +
                                                                              (the maxnext);
                                                                return (Nodei (Some ( minew, ma)) deg treeArray' summary)
                                                               }
                                                            else return (Nodei (Some (minew, snd mima)) deg treeArray' summary) )
                                                          })}))"

theorem deleti'_rf_abstr: "invar_vebt t n \<Longrightarrow> <vebt_assn_raw t ti> vebt_deletei' t ti x< vebt_assn_raw (vebt_delete t x)>"
proof(induction t x arbitrary: ti n rule: vebt_delete.induct)
  case (1 a b)
  then show ?case by(subst vebt_deletei'.simps) (cases ti; sep_auto)
next
  case (2 a b)
  then show ?case by(subst vebt_deletei'.simps) (cases ti; sep_auto)
next
  case (3 a b n)
  then show ?case by(subst vebt_deletei'.simps) (cases ti; sep_auto)
next
  case (4 deg treeList summary uu)
  then show ?case by(subst vebt_deletei'.simps) (cases ti; sep_auto)
next
  case (5 mi ma treeList summary x)
  then show ?case by(subst vebt_deletei'.simps) (cases ti; sep_auto)
next
  case (6 mi ma treeList summary x)
  then show ?case by(subst vebt_deletei'.simps) (cases ti; sep_auto)
next
  case (7 mi ma va treeList summary x)
  have setprop: "t \<in> set treeList \<Longrightarrow> invar_vebt t (n div 2 )" for t using 7(3)
    by (cases) simp+
  have listlength: "length treeList = 2^(n - n div 2)" using 7(3)
    by (cases) simp+
  have sumprop: "invar_vebt summary (n - n div 2)" using 7(3)
    by (cases) simp+
  have mimaxprop: "mi \<le> ma \<and> ma \<le> 2^n" using 7(3)
    by cases  simp+
  hence xbound: "mi \<le> x \<Longrightarrow> x \<le> ma \<Longrightarrow> high x (n div 2) \<le> length treeList "
    using div_le_mono high_def listlength power_minus_is_div by auto
  let ?xn = "  the (vebt_mint summary) * 2 ^ (Suc (Suc va) div 2) + the (vebt_mint (treeList ! the (vebt_mint summary)))"
  obtain xnew where xndef: "xnew = ?xn" by simp
  let ?minn = "?xn"
  obtain minew where minewdef: "minew =?minn" by simp
  have highboundn:"ma \<noteq> mi \<Longrightarrow>x\<le> ma \<Longrightarrow>high xnew (n div 2 )< length treeList" using xndef
    by (smt (z3) "7.prems" deg_deg_n diff_diff_cancel div2_Suc_Suc div_le_dividend high_bound_aux leD le_add_diff_inverse less_imp_diff_less listlength mi_ma_2_deg nested_mint power_Suc)
  have highbound: "ma \<noteq> mi \<Longrightarrow>x\<le> ma \<Longrightarrow>high x (n div 2 )< length treeList"
    by (smt (z3) "7.prems" deg_deg_n div_le_dividend high_bound_aux le_less_trans listlength mi_ma_2_deg ordered_cancel_comm_monoid_diff_class.add_diff_inverse)
  let ?aktnode = "(treeList !
               high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)))"
  obtain aktnode where aktnodedef:"ma \<noteq> mi \<Longrightarrow>x\<le> ma  \<Longrightarrow>aktnode = ?aktnode"
    by meson
  let ?newnode = "vebt_delete ?aktnode (low ?xn (Suc (Suc va) div 2))"
  obtain newnode where newnodedef:"newnode = ?newnode" by presburger
  let ?newlist="treeList[ high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)) :=
                    ?newnode]"
  let ?newlist'="treeList[ high x  (Suc (va div 2)) := vebt_delete (treeList ! high x (Suc (va div 2))) (low x (Suc (va div 2)))]"
  show ?case
    apply(cases ti)
     prefer 2
     subgoal
      apply simp
     done
    supply [split del] = if_split
    apply (subst vebt_deletei'.simps; clarsimp split del: )
    apply (assn_simp; intro normalize_rules)
    apply simp
    apply(cases "x < mi \<or> ma < x")
    subgoal
      apply simp
      apply sep_auto
      done
    apply simp
    apply(cases "mi = x \<and> ma = x")
    subgoal
      apply simp
      apply sep_auto
      done
    apply (extract_pre_pure dest: extract_pre_list_assn_lengthD)
    apply (cases "mi = x \<and> ma = x"; simp)
    apply(cases "x = mi")
    subgoal
      apply simp
      apply sep_auto
      apply(sep_auto heap: vebt_minti_h)
      apply sep_auto
      apply (metis "7.prems" listlength mintlistlength option.sel)
      apply sep_auto
      apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
      apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i="the (vebt_mint summary)"])
      apply (metis "7.prems" atLeastLessThan_iff le0 listlength mintlistlength option.sel)
      apply (metis "7.prems" listlength mintlistlength option.sel)
      apply(sep_auto heap: vebt_minti_h)
      apply(rule cons_pre_rule)
      apply (rule repack)
      apply (metis "7.prems" listlength mintlistlength option.sel)
      apply sep_auto
      apply (sep_auto heap: highi_h)
      apply sep_auto
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n nested_mint)
      apply (sep_auto heap: lowi_h)
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n div2_Suc_Suc highboundn mimaxprop power_Suc xndef)
      apply sep_auto
      apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
      apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i=" high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2))"])
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute atLeastLessThan_iff deg_deg_n leI less_nat_zero_code nested_mint)
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n nested_mint)
      apply sep_auto
      apply(sep_auto heap: "7.IH"(1))
      apply(simp add: algebra_simps)
      apply(simp add: algebra_simps)
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n nested_mint)
      apply(rule setprop)
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n nested_mint nth_mem)
      apply sep_auto
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n nested_mint)
      apply(simp add: Let_def)
      apply sep_auto
      apply(sep_auto heap: vebt_minti_h)
      apply(rule cons_pre_rule)
      apply(rule big_assn_simp[of "high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2))"
                                   treeList "(low (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)))"
                                   _ _ _ _ summary])
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n div2_Suc_Suc highboundn mimaxprop power_Suc xndef)
      apply(cases "vebt_mint (vebt_delete (treeList !
              high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)))
             (low (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)))) = None")
      apply simp
      subgoal
       apply sep_auto
       apply(sep_auto heap:  "7.IH"(2))
       apply(simp add: algebra_simps)+
       apply (smt (z3) "7.prems" ab_semigroup_add_class.add.commute ab_semigroup_mult_class.mult.left_commute deg_deg_n nested_mint)
       apply(rule DEADID.rel_refl)
       apply(rule DEADID.rel_refl)
       apply(rule minminNull)
       apply (metis ab_semigroup_mult_class.mult.commute)
       apply(rule sumprop)
       apply(rule bind_rule'[where R="\<lambda> r.(let sn =  vebt_delete summary (high (2 * 2 ^ (va div 2) *
              the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2))) in ( \<up>(r = (
                                 if ?xn = ma then let maxs = vebt_maxt sn in if maxs = None then ?xn
                                         else 2 ^ (Suc (Suc va) div 2) * the maxs + the (vebt_maxt (?newlist ! the maxs)) else ma))))"])
       apply(cases "2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary))) = ma")
       apply simp+
       apply sep_auto
       apply(sep_auto heap: vebt_maxti_h)
       apply sep_auto
       using delete_pres_valid[of summary "n - n div 2"
            "(high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)))"]
              maxt_member[of "vebt_delete summary _" "n-n div 2"] member_bound[of "vebt_delete summary _ " _ "n-n div 2"] listlength sumprop
       apply (metis both_member_options_equiv_member dele_bmo_cont_corr maxbmo member_bound)
       apply sep_auto
       apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
       apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i=" the (  vebt_maxt (vebt_delete summary (high (2 * 2 ^ (va div 2) * the (vebt_mint summary)
                            + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)))))"])
       apply (metis atLeastLessThan_iff both_member_options_equiv_member dele_bmo_cont_corr le0 length_list_update listlength maxbmo member_bound option.sel sumprop)
       apply (metis both_member_options_equiv_member dele_bmo_cont_corr length_list_update listlength maxbmo member_bound option.sel sumprop)
       apply(sep_auto heap: vebt_maxti_h)
       apply sep_auto
       apply (simp add: ab_semigroup_mult_class.mult.commute)
       apply auto[1]
       apply(cases "  the(  vebt_maxt  (vebt_delete summary
              (high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary))))  (Suc (va div 2))))) < length treeList")
       using txe
       apply (metis length_list_update option.sel)
       apply (metis both_member_options_equiv_member dele_bmo_cont_corr listlength maxbmo member_bound option.sel sumprop)
       apply simp
       apply sep_auto
       apply (metis ab_semigroup_mult_class.mult.commute)
       apply sep_auto
       apply(simp add: Let_def)
       apply(cases " high (the (vebt_mint summary) * (2 * 2 ^ (va div 2)) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2)) < length treeList")
       apply simp
       apply(cases "minNull  (vebt_delete  (treeList !
                  high (the (vebt_mint summary) * (2 * 2 ^ (va div 2)) + the (vebt_mint (treeList ! the (vebt_mint summary))))  (Suc (va div 2)))
                 (low (the (vebt_mint summary) * (2 * 2 ^ (va div 2)) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2))))")
       subgoal
         apply(sep_auto simp: algebra_simps split: if_split)
        done
       subgoal
         apply(auto split: if_split)
         apply sep_auto
         prefer 2
         apply(rule  entails_solve_init)
         apply (tactic \<open>Seplogic_Auto.match_frame_tac  (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
         apply simp
         apply solve_entails
         apply (simp add: ab_semigroup_mult_class.mult.commute)
         prefer 3
         apply sep_auto
         apply (metis ab_semigroup_mult_class.mult.commute minminNull)+
        done
       subgoal
         apply(rule  entails_solve_init)
         apply simp
        done
       subgoal
         apply(simp add: Let_def)
         apply(auto split: if_split)
         apply sep_auto
         using "7.prems" deg_deg_n nested_mint apply blast
         apply(rule  entails_solve_init)
         apply (tactic \<open>Seplogic_Auto.match_frame_tac  (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
         apply simp
         apply solve_entails
         apply (simp add: ab_semigroup_mult_class.mult.commute)
         using "7.prems" deg_deg_n nested_mint apply blast
         apply sep_auto
         using "7.prems" deg_deg_n nested_mint apply blast
         using "7.prems" deg_deg_n nested_mint apply blast
         apply(rule  entails_solve_init)
         apply (tactic \<open>Seplogic_Auto.match_frame_tac (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
         apply simp
         apply solve_entails
         apply (simp add: ab_semigroup_mult_class.mult.commute)
         using "7.prems" deg_deg_n nested_mint apply blast
        done
       subgoal
         apply(simp add: Let_def)
         apply(auto split: if_split)
         apply sep_auto
         apply(rule  entails_solve_init)
         apply (tactic \<open>Seplogic_Auto.match_frame_tac  (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
         apply simp
         apply solve_entails
         apply (simp add: ab_semigroup_mult_class.mult.commute)
         apply (simp add: ab_semigroup_mult_class.mult.commute minminNull)
        done
       using "7.prems" deg_deg_n nested_mint apply blast
      done
      apply(auto split: if_split)
      apply sep_auto
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n nested_mint)
      apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
      apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i=" high (2 * 2 ^ (va div 2) * the (vebt_mint summary) + the (vebt_mint (treeList ! the (vebt_mint summary)))) (Suc (va div 2))"])
      apply (metis "7.prems" highboundn ab_semigroup_mult_class.mult.commute atLeastLessThan_iff deg_deg_n div2_Suc_Suc leI length_list_update less_nat_zero_code power_Suc xndef)
      apply (metis "7.prems" ab_semigroup_mult_class.mult.commute deg_deg_n length_list_update nested_mint)
      apply(sep_auto)
      apply(sep_auto heap: vebt_maxti_h)
      apply sep_auto
      apply (simp add: Let_def)
      apply(auto split: if_split)
      apply(simp add: Let_def)
      apply(auto split: if_split)
      apply (metis minNullmin  mulcomm option.simps(3))
      apply (metis minNullmin mulcomm option.distinct(1))
      subgoal
        apply sep_auto
        apply (simp add: ab_semigroup_mult_class.mult.commute)
        apply(rule  listI_assn_reinsert_upd[ where x = "_ ! _"] )
        apply(rule midextr)
        apply(rule midextr)
        apply(rule groupy)
        apply(rule ent_refl)
        apply (metis ab_semigroup_mult_class.mult.commute length_list_update)
        apply (metis ab_semigroup_mult_class.mult.commute atLeastLessThan_iff le0)
        apply(fr_rot 1)
        apply(rule swappa)
        apply(simp add:  mulcomm)
        apply(simp add:  listI_assn_conv)
        apply(rule ent_refl)
       done
     using "7.prems" deg_deg_n nested_mint
     apply blast
     apply sep_auto
     apply(simp add: Let_def)
     apply(auto split: if_split)
     apply (simp add: minNullmin mulcomm)
     apply (simp add: ab_semigroup_mult_class.mult.commute minNullmin)
     apply sep_auto
     apply sep_auto
     using "7.prems" deg_deg_n nested_mint apply blast
     apply(rule swappa)
     apply(simp add: mulcomm)
     apply(rule ent_refl)
    done
    apply simp
    apply(sep_auto heap: highi_h)
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound leI linorder_neqE_nat)
    apply(sep_auto heap: lowi_h)
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound leI linorder_neqE_nat)
    apply sep_auto
    apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
    apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i=" high x (Suc (va div 2))"])
    apply (metis "7.prems" atLeastLessThan_iff deg_deg_n div2_Suc_Suc highbound leI le_neq_implies_less less_nat_zero_code)
    apply (metis "7.prems" antisym_conv2 deg_deg_n div2_Suc_Suc highbound not_le_imp_less)
    apply(sep_auto heap: "7.IH"(1))
    apply (metis "7.prems" antisym_conv2 deg_deg_n div2_Suc_Suc highbound not_le_imp_less)
    apply(rule setprop)
    apply (metis "7.prems" antisym_conv2 deg_deg_n div2_Suc_Suc highbound not_le_imp_less nth_mem)
    apply sep_auto
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound not_le_imp_less order.not_eq_order_implies_strict)
    apply(sep_auto)
    apply(sep_auto heap: vebt_minti_h)
    apply(rule bind_rule)
    apply(rule assert'_rule)
    apply (meson mod_pure_star_dist mod_starE)
    apply(rule cons_pre_rule)
    apply(rule big_assn_simp'[])
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound leI le_neq_implies_less) apply auto[1]
    apply(cases "vebt_mint (vebt_delete (treeList ! high x (Suc (va div 2))) (low x (Suc (va div 2))))")
    apply simp
    subgoal
      apply sep_auto
      apply(sep_auto heap: "7.IH"(2))
      apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound leI le_neq_implies_less)
      apply simp+
      apply(simp add: minminNull)
      apply(rule sumprop)
      apply(rule bind_rule'[where R="\<lambda> r.(let sn =  vebt_delete summary (high x (Suc (va div 2))) in ( \<up>(r = (
                                 if x = ma then let maxs = vebt_maxt sn  in if maxs = None then mi
                                         else 2 ^ (Suc (Suc va) div 2) * the maxs + the (vebt_maxt (?newlist' ! the maxs)) else ma))))"])
      apply(cases "x = ma")
      apply simp
      apply(sep_auto)
      apply(sep_auto heap: vebt_maxti_h)
      apply(cases "vebt_maxt (vebt_delete summary (high ma (Suc (va div 2))))")
      apply simp
      apply sep_auto
      apply simp
      apply sep_auto
      apply (metis both_member_options_equiv_member dele_bmo_cont_corr listlength maxbmo member_bound sumprop)
      apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
      apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i="the ( vebt_maxt (vebt_delete summary (high ma (Suc (va div 2)))))"])
      apply (metis atLeastLessThan_iff both_member_options_equiv_member dele_bmo_cont_corr le0 length_list_update listlength maxbmo member_bound option.sel sumprop)
      apply (metis both_member_options_equiv_member dele_bmo_cont_corr length_list_update listlength maxbmo member_bound option.sel sumprop)
      apply sep_auto
      apply(sep_auto heap: vebt_maxti_h)
      apply sep_auto
      apply (smt (verit, ccfv_SIG) ab_semigroup_mult_class.mult.commute ab_semigroup_mult_class.mult.left_commute atLeastLessThan_empty_iff2 atLeastLessThan_iff both_member_options_equiv_member deg_deg_n dele_bmo_cont_corr div2_Suc_Suc div_by_Suc_0 div_mult_self1_is_m div_mult_self_is_m empty_iff ent_refl le0 le_neq_implies_less length_list_update listI_assn_extract list_assn_conv_idx listlength maxbmo member_bound mimaxprop numeral_2_eq_2 option.collapse option.distinct(1) sumprop zero_less_Suc)
      apply simp
      apply sep_auto
      apply sep_auto
      apply(simp add: Let_def)
      apply(cases "high ma (Suc (va div 2)) < length treeList")
      apply simp
      apply(simp add: Let_def)
      apply(cases "high ma (Suc (va div 2)) < length treeList")
      apply simp
      apply(cases "minNull (vebt_delete (treeList ! high ma (Suc (va div 2))) (low ma (Suc (va div 2))))")
      apply simp
      apply(simp add: Let_def)
      apply sep_auto
      apply simp
      apply sep_auto
      apply (meson minminNull)+
      apply simp
      apply(auto split: if_split)
      apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound le_refl)
      apply sep_auto
      apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound le_refl)
      apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound le_refl)
      apply(simp add: Let_def)
      apply(auto split: if_split)
      apply(simp add: Let_def)
      apply(auto split: if_split)
      apply sep_auto+
      apply (meson minminNull)
      apply sep_auto
      apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound linorder_neqE_nat not_le_imp_less)
     done
    apply simp
    apply(auto split: if_split)
    apply sep_auto
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc dual_order.refl highbound)
    apply (rewrite in "<\<hole>>_<_>" list_assn_conv_idx)
    apply (rewrite in "<\<hole>>_<_>" listI_assn_extract[where i="high ma (Suc (va div 2))"])
    apply (metis "7.prems" atLeastLessThan_iff deg_deg_n div2_Suc_Suc highbound le0 le_refl length_list_update)
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound le_refl length_list_update)
    apply sep_auto
    apply(sep_auto heap: vebt_maxti_h)
    apply sep_auto
    apply(simp add: Let_def)
    apply(auto split: if_split)
    apply(simp add: Let_def)
    apply(auto split: if_split)
    apply(simp add: Let_def)
    subgoal
      apply sep_auto
      apply (metis minNullmin option.distinct)+
     done
    apply sep_auto
    apply(rule ent_trans)
    apply(rule tcd[where treeList'= treeList])
    apply blast+
    apply(rule swappa)
    apply(rule ent_refl)
    apply sep_auto
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc highbound le_refl)
    apply (metis "7.prems" deg_deg_n div2_Suc_Suc dual_order.refl highbound)
    apply sep_auto
    apply(simp add: Let_def)
    apply(auto split: if_split)
    apply(simp add: Let_def)
    apply(auto split: if_split)
    apply sep_auto
    apply (metis minNullmin option.distinct(1))
    apply sep_auto+
   done
qed

lemma TBOUND_vebt_deletei:
  defines foo_def: "\<And> t x. foo t x \<equiv> if minNull (vebt_delete t x) then 1 else 20 * (1+height t)"
  shows "TBOUND (vebt_deletei' t ti x) (foo t x)"
proof-
  have fooNull:"minNull (vebt_delete t x) \<Longrightarrow> foo t x = 1" for t x using foo_def by simp
  have fooElse: "foo t x \<le> 20* (1+ height t)" for t using foo_def by simp
  have succ0foo: "Suc 0 \<le> foo t x" for t x unfolding foo_def by simp
  have fooNull': "vebt_mint (vebt_delete t x) = None \<Longrightarrow> foo t x = 1" for t x
    by (simp add: fooNull minminNull)
  have fooNull'': "vebt_maxt (vebt_delete t x) = None \<Longrightarrow> foo t x = 1" for t x
    by (metis fooNull fooNull' vebt_maxt.elims minNull.simps(4) vebt_mint.simps(1) option.simps(3))
  have minNotMaxDel: "x12a \<ge> 2 \<Longrightarrow> c \<noteq> d \<Longrightarrow>
    \<not> minNull (vebt_delete (Node (Some (c, d)) x12a x13 x14) y )" for x12a x13 x14 c d y
    apply(cases "( (Node (Some (c, d)) x12a x13 x14), y )" rule: vebt_delete.cases; simp)
    apply(auto simp add: Let_def)
    done
  have twentyheight:" i< length x13 \<Longrightarrow>n * height (x13 !i) \<le> m + n * max (height x14) (Max (height ` set x13))" for i x13 x14 n m
      by (meson height_i_max mult_le_mono2 trans_le_add2)
  have summheight:"n * height x14 \<le> m + n * max (height x14) (Max (height ` set x13))" for x14 x13 m n
      apply(simp add: max_def)
      apply (meson mult_le_mono2 trans_le_add2)
      done
  show ?thesis
    apply (induction arbitrary: t ti x rule: vebt_deletei'.fixp_induct)
      apply (rule TBOUND_fi'_adm)
      apply (rule TBOUND_empty)
      apply TBOUND
      apply(simp add: Let_def  eq_commute[of "Suc 0" "_" ] succ0foo fooNull' fooNull''
              split!: VEBT.splits VEBTi.splits option.splits prod.splits )
      apply(all \<open>(intro allI impI conjI)?\<close>)
      apply(all \<open>(clarify; simp only: succ0foo; fail)?\<close>)
      apply(simp_all add: foo_def minNotMaxDel twentyheight summheight not_less)
    done
  qed

lemma vebt_deletei_refines: "refines (vebt_deletei ti  x) (vebt_deletei' t ti x)"
  apply (induction arbitrary: t ti x rule: vebt_deletei'.fixp_induct)
  subgoal
   using refines_adm[where t = "\<lambda> arg. vebt_deletei (snd (fst arg)) (snd arg)"]
   by simp
  subgoal by simp
  subgoal for f t ti x
    apply(subst vebt_deletei.simps)
    apply refines
  done
  done

lemma htt_vebt_deletei: assumes "invar_vebt t n"
  shows  "<vebt_assn_raw t ti> vebt_deletei ti x <\<lambda> r. vebt_assn_raw (vebt_delete t x) r >T[20 + 20*(nat \<lceil>lb n\<rceil>)]"
  apply (rule htt_refine[where c = "vebt_deletei' t ti x"])
  prefer 2
  apply(rule vebt_deletei_refines)
  apply (rule httI_TBOUND)
  apply(rule deleti'_rf_abstr)
  apply(rule assms)
  apply(rule TBOUND_mono)
  apply(rule TBOUND_vebt_deletei)
  apply (auto simp add: if_split)
  apply(metis assms eq_imp_le heigt_uplog_rel int_eq_iff)
  done

end
end


(*  Title:      HOL/HOLCF/IOA/NTP/Sender.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>The implementation: sender\<close>

theory Sender
imports IOA.IOA Action
begin

type_synonym
'm sender_state = "'m list * bool multiset * bool multiset * bool * bool"
(*                messages   #sent           #received      header  mode *)

definition sq :: "'m sender_state => 'm list" where "sq = fst"
definition ssent :: "'m sender_state => bool multiset" where "ssent = fst \<circ> snd"
definition srcvd :: "'m sender_state => bool multiset" where "srcvd = fst \<circ> snd \<circ> snd"
definition sbit :: "'m sender_state => bool" where "sbit = fst \<circ> snd \<circ> snd \<circ> snd"
definition ssending :: "'m sender_state => bool" where "ssending = snd \<circ> snd \<circ> snd \<circ> snd"

definition
  sender_asig :: "'m action signature" where
  "sender_asig = ((UN m. {S_msg(m)}) Un (UN b. {R_ack(b)}),
                   UN pkt. {S_pkt(pkt)},
                   {C_m_s,C_r_s})"

definition
  sender_trans :: "('m action, 'm sender_state)transition set" where
  "sender_trans =
 {tr. let s = fst(tr);
          t = snd(snd(tr))
      in case fst(snd(tr))
      of
      S_msg(m) => sq(t)=sq(s)@[m]   \<and>
                  ssent(t)=ssent(s) \<and>
                  srcvd(t)=srcvd(s) \<and>
                  sbit(t)=sbit(s)   \<and>
                  ssending(t)=ssending(s) |
      R_msg(m) => False |
      S_pkt(pkt) => hdr(pkt) = sbit(s)      \<and>
                       (\<exists>Q. sq(s) = (msg(pkt)#Q))  \<and>
                       sq(t) = sq(s)           \<and>
                       ssent(t) = addm (ssent s) (sbit s) \<and>
                       srcvd(t) = srcvd(s) \<and>
                       sbit(t) = sbit(s)   \<and>
                       ssending(s)         \<and>
                       ssending(t) |
    R_pkt(pkt) => False |
    S_ack(b)   => False |
      R_ack(b) => sq(t)=sq(s)                  \<and>
                     ssent(t)=ssent(s)            \<and>
                     srcvd(t) = addm (srcvd s) b  \<and>
                     sbit(t)=sbit(s)              \<and>
                     ssending(t)=ssending(s) |
      C_m_s => count (ssent s) (~sbit s) < count (srcvd s) (~sbit s) \<and>
               sq(t)=sq(s)       \<and>
               ssent(t)=ssent(s) \<and>
               srcvd(t)=srcvd(s) \<and>
               sbit(t)=sbit(s)   \<and>
               ssending(s)       \<and>
               ~ssending(t) |
      C_m_r => False |
      C_r_s => count (ssent s) (sbit s) <= count (srcvd s) (~sbit s) \<and>
               sq(t)=tl(sq(s))      \<and>
               ssent(t)=ssent(s)    \<and>
               srcvd(t)=srcvd(s)    \<and>
               sbit(t) = (~sbit(s)) \<and>
               ~ssending(s)         \<and>
               ssending(t) |
      C_r_r(m) => False}"

definition
  sender_ioa :: "('m action, 'm sender_state)ioa" where
  "sender_ioa =
   (sender_asig, {([],{|},{|},False,True)}, sender_trans,{},{})"

lemma in_sender_asig:
  "S_msg(m) \<in> actions(sender_asig)"
  "R_msg(m) \<notin> actions(sender_asig)"
  "S_pkt(pkt) \<in> actions(sender_asig)"
  "R_pkt(pkt) \<notin> actions(sender_asig)"
  "S_ack(b) \<notin> actions(sender_asig)"
  "R_ack(b) \<in> actions(sender_asig)"
  "C_m_s \<in> actions(sender_asig)"
  "C_m_r \<notin> actions(sender_asig)"
  "C_r_s \<in> actions(sender_asig)"
  "C_r_r(m) \<notin> actions(sender_asig)"
  by (simp_all add: sender_asig_def actions_def asig_projections)

lemmas sender_projections = sq_def ssent_def srcvd_def sbit_def ssending_def

end


subsection \<open>ConditionalNode Phase\<close>

theory ConditionalPhase
  imports
    Common
    Proofs.StampEvalThms
begin

phase ConditionalNode
  terminating size
begin

lemma negates: "\<exists>v b. e = IntVal b v \<and> b > 0 \<Longrightarrow> val_to_bool (val[e]) \<longleftrightarrow> \<not>(val_to_bool (val[!e]))"
  unfolding intval_logic_negation.simps
  by (metis (mono_tags, lifting) intval_logic_negation.simps(1) logic_negate_def new_int.simps of_bool_eq(2) one_neq_zero take_bit_of_0 take_bit_of_1 val_to_bool.simps(1))

lemma negation_condition_intval:
  assumes "e = IntVal b ie"
  assumes "0 < b"
  shows "val[(!e) ? x : y] = val[e ? y : x]"
  using assms by (cases e; auto simp: negates logic_negate_def)

lemma negation_preserve_eval:
  assumes "[m, p] \<turnstile> exp[!e] \<mapsto> v"
  shows "\<exists>v'. ([m, p] \<turnstile> exp[e] \<mapsto> v') \<and> v = val[!v']"
  using assms by auto

lemma negation_preserve_eval_intval:
  assumes "[m, p] \<turnstile> exp[!e] \<mapsto> v"
  shows "\<exists>v' b vv. ([m, p] \<turnstile> exp[e] \<mapsto> v') \<and> v' = IntVal b vv \<and> b > 0"
  using assms
  by (metis eval_bits_1_64 intval_logic_negation.elims negation_preserve_eval unfold_unary)

optimization NegateConditionFlipBranches: "((!e) ? x : y) \<longmapsto> (e ? y : x)"
  apply simp using negation_condition_intval negation_preserve_eval_intval
  by (smt (verit, best) ConditionalExpr ConditionalExprE Value.distinct(1) evalDet negates negation_preserve_eval)

optimization DefaultTrueBranch: "(true ? x : y) \<longmapsto> x" .

optimization DefaultFalseBranch: "(false ? x : y) \<longmapsto> y" .

optimization ConditionalEqualBranches: "(e ? x : x) \<longmapsto> x" .

optimization condition_bounds_x: "((u < v) ? x : y) \<longmapsto> x
    when (stamp_under (stamp_expr u) (stamp_expr v) \<and> wf_stamp u \<and> wf_stamp v)"
  using stamp_under_defn by fastforce

optimization condition_bounds_y: "((u < v) ? x : y) \<longmapsto> y
    when (stamp_under (stamp_expr v) (stamp_expr u) \<and> wf_stamp u \<and> wf_stamp v)"
  using stamp_under_defn_inverse by fastforce

(** Start of new proofs **)

(* Value-level proofs *)
lemma val_optimise_integer_test:
  assumes "\<exists>v. x = IntVal 32 v"
  shows "val[((x & (IntVal 32 1)) eq (IntVal 32 0)) ? (IntVal 32 0) : (IntVal 32 1)] =
         val[x & IntVal 32 1]"
  using assms apply auto
  apply (metis (full_types) bool_to_val.simps(2) val_to_bool.simps(1))
  by (metis (mono_tags, lifting) and_one_eq bool_to_val.simps(1) even_iff_mod_2_eq_zero odd_iff_mod_2_eq_one val_to_bool.simps(1))

optimization ConditionalEliminateKnownLess: "((x < y) ? x : y) \<longmapsto> x
                                 when (stamp_under (stamp_expr x) (stamp_expr y)
                                      \<and> wf_stamp x \<and> wf_stamp y)"
    using stamp_under_defn by fastforce

(* Optimisations *)
optimization ConditionalEqualIsRHS: "((x eq y) ? x : y) \<longmapsto> y"
  apply auto
  by (smt (verit) Value.inject(1) bool_to_val.simps(2) bool_to_val_bin.simps evalDet
      intval_equals.elims val_to_bool.elims(1))

(* todo not sure if this is done properly *)
optimization normalizeX: "((x eq const (IntVal 32 0)) ?
                                (const (IntVal 32 0)) : (const (IntVal 32 1))) \<longmapsto> x
                                when (IRExpr_up x = 1) \<and> stamp_expr x = IntegerStamp b 0 1"
  apply auto
  subgoal premises p for m p v xa
    proof -
      obtain xa where xa: "[m,p] \<turnstile> x \<mapsto> xa"
        using p by blast
       have 3: "[m,p] \<turnstile> if val_to_bool (intval_equals xa (IntVal (32::nat) (0::64 word)))
                  then ConstantExpr (IntVal (32::nat) (0::64 word))
                  else ConstantExpr (IntVal (32::nat) (1::64 word)) \<mapsto> v"
         using evalDet p(3) p(5) xa
         using p(4) p(6) by blast
       then have 4: "xa = IntVal 32 0 | xa = IntVal 32 1"
         sorry
       then have 6: "v = xa"
         sorry
      then show ?thesis
        using xa by auto
    qed
  done

(* todo not sure if this is done properly *)
optimization normalizeX2: "((x eq (const (IntVal 32 1))) ?
                                 (const (IntVal 32 1)) : (const (IntVal 32 0))) \<longmapsto> x
                                 when (x = ConstantExpr (IntVal 32 0) | (x = ConstantExpr (IntVal 32 1)))" .

(* todo not sure if this is done properly *)
optimization flipX: "((x eq (const (IntVal 32 0))) ?
                           (const (IntVal 32 1)) : (const (IntVal 32 0))) \<longmapsto>
                            x \<oplus> (const (IntVal 32 1))
                            when (x = ConstantExpr (IntVal 32 0) | (x = ConstantExpr (IntVal 32 1)))" .

(* todo not sure if this is done properly *)
optimization flipX2: "((x eq (const (IntVal 32 1))) ?
                            (const (IntVal 32 0)) : (const (IntVal 32 1))) \<longmapsto>
                            x \<oplus> (const (IntVal 32 1))
                            when (x = ConstantExpr (IntVal 32 0) | (x = ConstantExpr (IntVal 32 1)))" .

lemma stamp_of_default:
  assumes "stamp_expr x = default_stamp"
  assumes "wf_stamp x"
  shows "([m, p] \<turnstile> x \<mapsto> v) \<longrightarrow> (\<exists>vv. v = IntVal 32 vv)"
  using assms
  by (metis default_stamp valid_value_elims(3) wf_stamp_def)

optimization OptimiseIntegerTest:
     "(((x & (const (IntVal 32 1))) eq (const (IntVal 32 0))) ?
      (const (IntVal 32 0)) : (const (IntVal 32 1))) \<longmapsto>
       x & (const (IntVal 32 1))
       when (stamp_expr x = default_stamp \<and> wf_stamp x)"
  apply simp apply (rule impI; (rule allI)+; rule impI)
  subgoal premises eval for m p v
proof -
  obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> xv"
    using eval by fast
  then have x32: "\<exists>v. xv = IntVal 32 v"
    using stamp_of_default eval by auto
  obtain lhs where lhs: "[m, p] \<turnstile> exp[(((x & (const (IntVal 32 1))) eq (const (IntVal 32 0))) ?
      (const (IntVal 32 0)) : (const (IntVal 32 1)))] \<mapsto> lhs"
    using eval(2) by auto
  then have lhsV: "lhs = val[((xv & (IntVal 32 1)) eq (IntVal 32 0)) ? (IntVal 32 0) : (IntVal 32 1)]"
    using xv evaltree.BinaryExpr evaltree.ConstantExpr evaltree.ConditionalExpr
    by (smt (verit) ConditionalExprE ConstantExprE bin_eval.simps(11) bin_eval.simps(4) evalDet intval_conditional.simps unfold_binary)
  obtain rhs where rhs: "[m, p] \<turnstile> exp[x & (const (IntVal 32 1))] \<mapsto> rhs"
    using eval(2) by blast
  then have rhsV: "rhs = val[xv & IntVal 32 1]"
    by (metis BinaryExprE ConstantExprE bin_eval.simps(4) evalDet xv)
  have "lhs = rhs" using val_optimise_integer_test x32
    using lhsV rhsV by presburger
  then show ?thesis
    by (metis eval(2) evalDet lhs rhs)
qed
  done

(* todo not sure if this is done properly *)
optimization opt_optimise_integer_test_2:
     "(((x & (const (IntVal 32 1))) eq (const (IntVal 32 0))) ?
                   (const (IntVal 32 0)) : (const (IntVal 32 1))) \<longmapsto>
                   x
                   when (x = ConstantExpr (IntVal 32 0) | (x = ConstantExpr (IntVal 32 1)))" .

(*
optimization opt_conditional_eliminate_known_less: "((x < y) ? x : y) \<longmapsto> x
                                 when (((stamp_under (stamp_expr x) (stamp_expr y)) |
                                      ((stpi_upper (stamp_expr x)) = (stpi_lower (stamp_expr y))))
                                      \<and> wf_stamp x \<and> wf_stamp y)"
   apply auto using stamp_under_defn
  apply simp sorry
*)

(*
optimization opt_normalize_x_original: "((BinaryExpr BinIntegerEquals x (ConstantExpr (IntVal32 0))) ?
                                (ConstantExpr (IntVal32 0)) : (ConstantExpr (IntVal32 1))) \<longmapsto> x
                                when (stamp_expr x = IntegerStamp 32 0 1 \<and>
                                      wf_stamp x)"
   apply unfold_optimization apply simp_all
  using wf_stamp_def apply (cases x; simp)

  sorry
*)

(** End of new proofs **)

end

end


(*  Title:      HOL/Datatype_Examples/Compat.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2014

Tests for compatibility with the old datatype package.
*)

section {* Tests for Compatibility with the Old Datatype Package *}

theory Compat
imports "~~/src/HOL/Library/Old_Datatype"
begin

subsection {* Viewing and Registering New-Style Datatypes as Old-Style Ones *}

ML {*
fun check_len n xs label =
  length xs = n orelse error ("Expected length " ^ string_of_int (length xs) ^ " for " ^ label);

fun check_lens (n1, n2, n3) (xs1, xs2, xs3) =
  check_len n1 xs1 "old" andalso check_len n2 xs2 "unfold" andalso check_len n3 xs3 "keep";

fun get_descrs thy lens T_name =
  (these (Option.map #descr (Old_Datatype_Data.get_info thy T_name)),
   these (Option.map #descr (BNF_LFP_Compat.get_info thy [] T_name)),
   these (Option.map #descr (BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] T_name)))
  |> tap (check_lens lens);
*}

old_datatype 'a old_lst = Old_Nl | Old_Cns 'a "'a old_lst"

text {*
A few tests to make sure that @{text old_datatype} works as expected:
*}

primrec old_len :: "'a old_lst \<Rightarrow> nat" where
  "old_len Old_Nl = 0"
| "old_len (Old_Cns _ xs) = Suc (old_len xs)"

export_code old_len checking SML OCaml? Haskell? Scala

lemma "Old_Nl = Old_Cns x xs"
  nitpick (* [expect = genuine] *)
  quickcheck [exhaustive, expect = counterexample]
  quickcheck [random, expect = counterexample]
  quickcheck [narrowing (* , expect = counterexample *)]
  oops

lemma "old_len xs = size xs"
  by (induct xs) auto

ML {* get_descrs @{theory} (1, 1, 1) @{type_name old_lst} *}

datatype 'a lst = Nl | Cns 'a "'a lst"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name lst} *}

datatype_compat lst

ML {* get_descrs @{theory} (1, 1, 1) @{type_name lst} *}

datatype 'b w = W | W' "'b w \<times> 'b list"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name w} *}

datatype_compat w

ML {* get_descrs @{theory} (2, 2, 1) @{type_name w} *}

datatype ('c, 'b) s = L 'c | R 'b

ML {* get_descrs @{theory} (0, 1, 1) @{type_name s} *}

datatype 'd x = X | X' "('d x lst, 'd list) s"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name x} *}

datatype_compat s

ML {* get_descrs @{theory} (1, 1, 1) @{type_name s} *}
ML {* get_descrs @{theory} (0, 1, 1) @{type_name x} *}

datatype_compat x

ML {* get_descrs @{theory} (3, 3, 1) @{type_name x} *}

thm x.induct x.rec
thm compat_x.induct compat_x.rec

datatype 'a tttre = TTTre 'a "'a tttre lst lst lst"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name tttre} *}

datatype_compat tttre

ML {* get_descrs @{theory} (4, 4, 1) @{type_name tttre} *}

thm tttre.induct tttre.rec
thm compat_tttre.induct compat_tttre.rec

datatype 'a ftre = FEmp | FTre "'a \<Rightarrow> 'a ftre lst"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name ftre} *}

datatype_compat ftre

ML {* get_descrs @{theory} (2, 2, 1) @{type_name ftre} *}

thm ftre.induct ftre.rec
thm compat_ftre.induct compat_ftre.rec

datatype 'a btre = BTre 'a "'a btre lst" "'a btre lst"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name btre} *}

datatype_compat btre

ML {* get_descrs @{theory} (3, 3, 1) @{type_name btre} *}

thm btre.induct btre.rec
thm compat_btre.induct compat_btre.rec

datatype 'a foo = Foo | Foo' 'a "'a bar" and 'a bar = Bar | Bar' 'a "'a foo"

ML {* get_descrs @{theory} (0, 2, 2) @{type_name foo} *}
ML {* get_descrs @{theory} (0, 2, 2) @{type_name bar} *}

datatype_compat foo bar

ML {* get_descrs @{theory} (2, 2, 2) @{type_name foo} *}
ML {* get_descrs @{theory} (2, 2, 2) @{type_name bar} *}

datatype 'a tre = Tre 'a "'a tre lst"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name tre} *}

datatype_compat tre

ML {* get_descrs @{theory} (2, 2, 1) @{type_name tre} *}

thm tre.induct tre.rec
thm compat_tre.induct compat_tre.rec

datatype 'a f = F 'a and 'a g = G 'a

ML {* get_descrs @{theory} (0, 2, 2) @{type_name f} *}
ML {* get_descrs @{theory} (0, 2, 2) @{type_name g} *}

datatype h = H "h f" | H'

ML {* get_descrs @{theory} (0, 1, 1) @{type_name h} *}

datatype_compat f g

ML {* get_descrs @{theory} (2, 2, 2) @{type_name f} *}
ML {* get_descrs @{theory} (2, 2, 2) @{type_name g} *}
ML {* get_descrs @{theory} (0, 1, 1) @{type_name h} *}

datatype_compat h

ML {* get_descrs @{theory} (3, 3, 1) @{type_name h} *}

thm h.induct h.rec
thm compat_h.induct compat_h.rec

datatype myunit = MyUnity

ML {* get_descrs @{theory} (0, 1, 1) @{type_name myunit} *}

datatype_compat myunit

ML {* get_descrs @{theory} (1, 1, 1) @{type_name myunit} *}

datatype mylist = MyNil | MyCons nat mylist

ML {* get_descrs @{theory} (0, 1, 1) @{type_name mylist} *}

datatype_compat mylist

ML {* get_descrs @{theory} (1, 1, 1) @{type_name mylist} *}

datatype foo' = FooNil | FooCons bar' foo' and bar' = Bar

ML {* get_descrs @{theory} (0, 2, 2) @{type_name foo'} *}
ML {* get_descrs @{theory} (0, 2, 2) @{type_name bar'} *}

datatype_compat bar' foo'

ML {* get_descrs @{theory} (2, 2, 2) @{type_name foo'} *}
ML {* get_descrs @{theory} (2, 2, 2) @{type_name bar'} *}

old_datatype funky = Funky "funky tre" | Funky'

ML {* get_descrs @{theory} (3, 3, 3) @{type_name funky} *}

old_datatype fnky = Fnky "nat tre"

ML {* get_descrs @{theory} (1, 1, 1) @{type_name fnky} *}

datatype tree = Tree "tree foo"

ML {* get_descrs @{theory} (0, 1, 1) @{type_name tree} *}

datatype_compat tree

ML {* get_descrs @{theory} (3, 3, 1) @{type_name tree} *}

thm tree.induct tree.rec
thm compat_tree.induct compat_tree.rec

subsection {* Creating New-Style Datatypes Using Old-Style Interfaces *}

ML {*
val l_specs =
  [((@{binding l}, [("'a", @{sort type})], NoSyn),
   [(@{binding N}, [], NoSyn),
    (@{binding C}, [@{typ 'a}, Type (Sign.full_name @{theory} @{binding l}, [@{typ 'a}])],
     NoSyn)])];
*}

setup {* snd o BNF_LFP_Compat.add_datatype [] l_specs *}

ML {* get_descrs @{theory} (1, 1, 1) @{type_name l} *}

thm l.exhaust l.map l.induct l.rec l.size

ML {*
val t_specs =
  [((@{binding t}, [("'b", @{sort type})], NoSyn),
   [(@{binding T}, [@{typ 'b},
       Type (@{type_name l}, [Type (Sign.full_name @{theory} @{binding t}, [@{typ 'b}])])],
     NoSyn)])];
*}

setup {* snd o BNF_LFP_Compat.add_datatype [] t_specs *}

ML {* get_descrs @{theory} (2, 2, 1) @{type_name t} *}

thm t.exhaust t.map t.induct t.rec t.size
thm compat_t.induct compat_t.rec

ML {*
val ft_specs =
  [((@{binding ft}, [("'a", @{sort type})], NoSyn),
   [(@{binding FT0}, [], NoSyn),
    (@{binding FT}, [@{typ 'a} --> Type (Sign.full_name @{theory} @{binding ft}, [@{typ 'a}])],
     NoSyn)])];
*}

setup {* snd o BNF_LFP_Compat.add_datatype [] ft_specs *}

ML {* get_descrs @{theory} (1, 1, 1) @{type_name ft} *}

thm ft.exhaust ft.induct ft.rec ft.size
thm compat_ft.induct compat_ft.rec

end


(*  File:       Sequential_Majority_Comparison.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Sequential Majority Comparison\<close>

theory Sequential_Majority_Comparison
  imports "Compositional_Structures/Basic_Modules/Plurality_Module"
          "Compositional_Structures/Drop_And_Pass_Compatibility"
          "Compositional_Structures/Revision_Composition"
          "Compositional_Structures/Maximum_Parallel_Composition"
          "Compositional_Structures/Defer_One_Loop_Composition"
begin

text
\<open>Sequential majority comparison compares two alternatives by plurality voting.
The loser gets rejected, and the winner is compared to the next alternative.
This process is repeated until only a single alternative is left, which is
then elected.\<close>

subsection \<open>Definition\<close>

fun smc :: "'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "smc x A p =
      ((((((pass_module 2 x) \<triangleright> ((plurality\<down>) \<triangleright> (pass_module 1 x))) \<parallel>\<^sub>\<up>
      (drop_module 2 x)) \<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d) \<triangleright> elect_module) A p)"

subsection \<open>Soundness\<close>

(*
   As all base components are electoral modules (, aggregators, or termination
   conditions), and all used compositional structures create electoral modules,
   sequential majority comparison unsurprisingly is an electoral module.
*)
theorem smc_sound:
  assumes order: "linear_order x"
  shows "electoral_module (smc x)"
  unfolding electoral_module_def
proof (simp, safe, simp_all)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    reject_xa:
      "xa \<in> reject (?smc) A p" and
    elect_xa:
      "xa \<in> elect (?smc) A p"
  show "False"
    using IntI drop_mod_sound elect_xa emptyE fin_A
          loop_comp_sound max_agg_sound order prof_A
          par_comp_sound pass_mod_sound reject_xa
          plurality_sound result_disj rev_comp_sound
          seq_comp_sound
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    reject_xa:
      "xa \<in> reject (?smc) A p" and
    defer_xa:
      "xa \<in> defer (?smc) A p"
  show "False"
    using IntI drop_mod_sound defer_xa emptyE fin_A
          loop_comp_sound max_agg_sound order prof_A
          par_comp_sound pass_mod_sound reject_xa
          plurality_sound result_disj rev_comp_sound
          seq_comp_sound
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    elect_xa:
      "xa \<in> elect (?smc) A p"
  show "xa \<in> A"
    using drop_mod_sound elect_in_alts elect_xa fin_A
          in_mono loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound plurality_sound
          prof_A rev_comp_sound seq_comp_sound
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    defer_xa:
      "xa \<in> defer (?smc) A p"
  show "xa \<in> A"
    using drop_mod_sound defer_in_alts defer_xa fin_A
          in_mono loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound plurality_sound
          prof_A rev_comp_sound seq_comp_sound
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    reject_xa:
      "xa \<in> reject (?smc) A p"
  have plurality_rev_sound:
    "electoral_module
      (plurality::'a set \<Rightarrow> (_ \<times> _) set list \<Rightarrow> _ set \<times> _ set \<times> _ set\<down>)"
    by simp
  have par1_sound:
    "electoral_module (pass_module 2 x \<triangleright> ((plurality\<down>) \<triangleright> pass_module 1 x))"
    using order
    by simp
  also have par2_sound:
      "electoral_module (drop_module 2 x)"
    using order
    by simp
  show "xa \<in> A"
    using reject_in_alts reject_xa fin_A in_mono
          loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound prof_A
          seq_comp_sound pass_mod_sound par1_sound
          par2_sound plurality_rev_sound
    by (metis (no_types))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    xa_in_A: "xa \<in> A" and
    not_defer_xa:
      "xa \<notin> defer (?smc) A p" and
    not_reject_xa:
      "xa \<notin> reject (?smc) A p"
  show "xa \<in> elect (?smc) A p"
    using drop_mod_sound loop_comp_sound max_agg_sound
          order par_comp_sound pass_mod_sound xa_in_A
          plurality_sound rev_comp_sound seq_comp_sound
          electoral_mod_defer_elem fin_A not_defer_xa
          not_reject_xa prof_A
    by metis
qed

subsection \<open>Electing\<close>

(*
   The sequential majority comparison electoral module is electing.
   This property is needed to convert electoral modules to a social choice
   function. Apart from the very last proof step, it is a part of the
   monotonicity proof below.
*)
theorem smc_electing:
  assumes order: "linear_order x"
  shows "electing (smc x)"
proof -
  let ?pass2 = "pass_module 2 x"
  let ?tie_breaker = "(pass_module 1 x)"
  let ?plurality_defer = "(plurality\<down>) \<triangleright> ?tie_breaker"
  let ?compare_two = "?pass2 \<triangleright> ?plurality_defer"
  let ?drop2 = "drop_module 2 x"
  let ?eliminator = "?compare_two \<parallel>\<^sub>\<up> ?drop2"
  let ?loop =
    "let t = defer_equal_condition 1 in (?eliminator \<circlearrowleft>\<^sub>t)"

  have 00011: "non_electing (plurality\<down>)"
    by simp
  have 00012: "non_electing ?tie_breaker"
    using order
    by simp
  have 00013: "defers 1 ?tie_breaker"
    using order pass_one_mod_def_one
    by simp
  have 20000: "non_blocking (plurality\<down>)"
    by simp

  have 0020: "disjoint_compatibility ?pass2 ?drop2"
    using order
    by simp (*disj_compat_comm*)
  have 1000: "non_electing ?pass2"
    using order
    by simp
  have 1001: "non_electing ?plurality_defer"
    using 00011 00012
    by simp
  have 2000: "non_blocking ?pass2"
    using order
    by simp
  have 2001: "defers 1 ?plurality_defer"
    using 20000 00011 00013 seq_comp_def_one
    by blast

  have 002: "disjoint_compatibility ?compare_two ?drop2"
    using order 0020
    by simp
  have 100: "non_electing ?compare_two"
    using 1000 1001
    by simp
  have 101: "non_electing ?drop2"
    using order
    by simp
  have 102: "agg_conservative max_aggregator"
    by simp
  have 200: "defers 1 ?compare_two"
    using 2000 1000 2001 seq_comp_def_one
    by auto
  have 201: "rejects 2 ?drop2"
    using order
    by simp

  have 10: "non_electing ?eliminator"
    using 100 101 102
    by simp
  have 20: "eliminates 1 ?eliminator"
    using 200 100 201 002 par_comp_elim_one
    by metis

  have 2: "defers 1 ?loop"
    using 10 20
    by simp
  have 3: "electing elect_module"
    by simp

  show ?thesis
    using 2 3 smc_sound smc.simps electing_def
          Defer_One_Loop_Composition.iter.simps
          order seq_comp_electing
    by metis
qed

subsection \<open>(Weak) Monotonicity Property\<close>

(*
   The following proof is a fully modular proof for weak monotonicity of
   sequential majority comparison. It is composed of many small steps.
*)
theorem smc_monotone:
  assumes order: "linear_order x"
  shows "monotonicity (smc x)"
proof -
(*Some aliases for parts of the SMC module.*)
  let ?pass2 = "pass_module 2 x"
  let ?tie_breaker = "(pass_module 1 x)"
  let ?plurality_defer = "(plurality\<down>) \<triangleright> ?tie_breaker"
  let ?compare_two = "?pass2 \<triangleright> ?plurality_defer"
  let ?drop2 = "drop_module 2 x"
  let ?eliminator = "?compare_two \<parallel>\<^sub>\<up> ?drop2"
  let ?loop =
    "let t = defer_equal_condition 1 in (?eliminator \<circlearrowleft>\<^sub>t)"

  have 00010: "defer_invariant_monotonicity (plurality\<down>)"
    by simp (*rev_comp_def_inv_mono plurality_strict_strong_mono*)
  have 00011: "non_electing (plurality\<down>)"
    by simp (*rev_comp_non_electing plurality_sound*)
  have 00012: "non_electing ?tie_breaker"
    using order
    by simp (*pass_mod_non_electing*)
  have 00013: "defers 1 ?tie_breaker"
    using order pass_one_mod_def_one
    by simp
  have 00014: "defer_monotonicity ?tie_breaker"
    using order
    by simp (*dl_inv_imp_def_mono pass_mod_dl_inv*)
  have 20000: "non_blocking (plurality\<down>)"
    by simp (*rev_comp_non_blocking plurality_electing*)

  have 0000: "defer_lift_invariance ?pass2"
    using order
    by simp (*pass_mod_dl_inv*)
  have 0001: "defer_lift_invariance ?plurality_defer"
    using 00010 00011 00012 00013 00014
    by simp (*def_inv_mono_imp_def_lift_inv*)
  have 0020: "disjoint_compatibility ?pass2 ?drop2"
    using order
    by simp (*disj_compat_comm drop_pass_disj_compat*)
  have 1000: "non_electing ?pass2"
    using order
    by simp (*pass_mod_non_electing*)
  have 1001: "non_electing ?plurality_defer"
    using 00011 00012
    by simp (*seq_comp_presv_non_electing*)
  have 2000: "non_blocking ?pass2"
    using order
    by simp (*pass_mod_non_blocking*)
  have 2001: "defers 1 ?plurality_defer"
    using 20000 00011 00013 seq_comp_def_one
    by blast

  have 000: "defer_lift_invariance ?compare_two"
    using 0000 0001
    by simp (*seq_comp_presv_def_lift_inv*)
  have 001: "defer_lift_invariance ?drop2"
    using order
    by simp (* drop_mod_def_lift_inv *)
  have 002: "disjoint_compatibility ?compare_two ?drop2"
    using order 0020
    by simp
      (*disj_compat_seq seq_comp_sound rev_comp_sound
        plurality_sound pass_mod_sound*)
  have 100: "non_electing ?compare_two"
    using 1000 1001
    by simp (*seq_comp_presv_non_electing*)
  have 101: "non_electing ?drop2"
    using order
    by simp (*drop_mod_non_electing*)
  have 102: "agg_conservative max_aggregator"
    by simp (*max_agg_conserv*)
  have 200: "defers 1 ?compare_two"
    using 2000 1000 2001 seq_comp_def_one
    by auto
  have 201: "rejects 2 ?drop2"
    using order
    by simp (*drop_two_mod_rej_two*)

  have 00: "defer_lift_invariance ?eliminator"
    using 000 001 002 par_comp_def_lift_inv
    by simp (*par_comp_def_lift_inv*)
  have 10: "non_electing ?eliminator"
    using 100 101 102
    by simp (*conserv_agg_presv_non_electing*)
  have 20: "eliminates 1 ?eliminator"
    using 200 100 201 002 par_comp_elim_one
    by simp

  have 0: "defer_lift_invariance ?loop"
    using 00
    by simp (*loop_comp_presv_def_lift_inv*)
  have 1: "non_electing ?loop"
    using 10
    by simp (*loop_comp_presv_non_electing*)
  have 2: "defers 1 ?loop"
    using 10 20
    by simp (*iter_elim_def_n*)
  have 3: "electing elect_module"
    by simp (*elect_mod_electing*)

  show ?thesis
    using 0 1 2 3
          Electoral_Module.monotonicity_def
          Defer_One_Loop_Composition.iter.simps
          smc_sound smc.simps order seq_comp_mono
    by (metis (full_types))
qed

end


theory bf
imports "~/git/Iptables_Semantics/Bitmagic/autocorres-0.98/autocorres/AutoCorres"
begin

install_C_file "bf.c"

autocorres [
  heap_abs_syntax,
  no_heap_abs=init,
  (*no_signed_word_abs=init,*)
  unsigned_word_abs=init] "bf.c"

term hrs_mem_update
term t_hrs_'_update
term heap_update_list
term globals.a_'
term globals.a_'
thm globals.a_'_def
term ptr_val
term Arrays.update
find_consts "'a['b]"

fun aupda :: "8 word['b::finite] \<Rightarrow> nat \<Rightarrow> 8 word['b]" where
  "aupda a 0 = Arrays.update a 0 0" |
  "aupda a (Suc i) = aupda (Arrays.update a (Suc i) 0) i"

lemma "i \<ge> CARD('b) \<Longrightarrow> aupda s i = Arrays.FCP (\<lambda>_. 0)"
  apply(induction s i rule: aupda.induct)
   apply(simp add: FCP_def Arrays.update_def)

  apply(simp)
  apply(case_tac "i = 255")
   apply(simp_all)

  oops

fun gaupda :: "globals \<Rightarrow> nat \<Rightarrow> globals" where
  "gaupda s 0 = s\<lparr>globals.a_' := Arrays.update (globals.a_' s) 0 0\<rparr>" |
  "gaupda s (Suc i) = gaupda (s\<lparr>globals.a_' := Arrays.update (globals.a_' s) i 0\<rparr>) i"

lemma "i \<ge> CARD(256) \<Longrightarrow> gaupda s i = s\<lparr>globals.a_' := Arrays.FCP (\<lambda>_. 0)\<rparr>"
  apply(induction s i rule: gaupda.induct)
   apply(simp)
  apply(simp)
  apply(case_tac "i = 255")
   apply(simp_all)

  oops

lemma (in bf) init:
  "\<forall>s\<^sub>0. \<lbrace> \<lambda>s.  s = s\<^sub>0 \<rbrace>
      init'
        \<lbrace> \<lambda>rs s. s = s\<^sub>0\<lparr>globals.a_' := Arrays.FCP (\<lambda>_. 0)\<rparr>  \<rbrace>!"
(*\<lbrace> \<lambda>rs s. s = t_hrs_'_update (hrs_mem_update (heap_update_list (addr) (replicate 255 0))) s\<^sub>0  \<rbrace>!*)
  unfolding init'_def
  apply(rule allI)
  apply (subst whileLoop_add_inv[where I="\<lambda>i s. i \<le> 256 \<and> i \<ge> 0 \<and> s = gaupda s\<^sub>0 ((unat (of_int i)))" and M="\<lambda>(i, _). nat (256 - i)"])
  apply(wp)
  apply(simp_all)
  apply(simp add: INT_MAX_def)

  apply(clarsimp)
  apply (clarsimp simp: FCP_def)

  oops

end


theory SINVAR_NoRefl
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant NoRefl *}

text{*Hosts are not allowed to communicate with themselves.*}

text {* This can be used to effectively lift hosts to roles.
        Just list all roles that are allowed to communicate with themselves.
        Otherwise, communication between hosts of the same role (group) is prohibited.
        Useful in conjunction with the security gateway. *}

datatype node_config = NoRefl | Refl

definition default_node_properties :: "node_config"
  where  "default_node_properties = NoRefl"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> edges G. s = r \<longrightarrow> nP s = Refl)"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection {*Preliminaries*}

 lemma NoRfl_ENRsr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_sr sinvar (\<lambda> nP\<^sub>s s nP\<^sub>r r. s = r \<longrightarrow> nP\<^sub>s = Refl)"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_sr_def)

  definition NoRefl_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "NoRefl_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 = e2 \<and> nP e1 = NoRefl} })"

 thm SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr]

  lemma NoRefl_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = NoRefl_offending_set"
    apply(simp only: fun_eq_iff NoRefl_offending_set_def)
    apply(intro allI, rename_tac G nP)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply(case_tac "sinvar G nP")
     apply(simp; fail)
    apply(simp)
    apply(rule)
     apply(rule)
     apply(clarsimp)
     using node_config.exhaust apply blast
    apply(rule)
    apply(rule)
    apply(clarsimp)
   done

  lemma NoRefl_unique_default:
    "\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst ` f \<longrightarrow> \<not> sinvar G (nP(i := otherbot)) \<Longrightarrow>
     otherbot = NoRefl"
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1}, edges = {(vertex_1,vertex_1)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
   apply(rule_tac x="(\<lambda> x. NoRefl)(vertex_1 := NoRefl, vertex_2 := NoRefl)" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_1)}" in exI, simp)
   done

interpretation NoRefl: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = NoRefl_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply(frule SINVAR_NoRefl.offending_notevalD)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply fastforce
   apply(fact NoRefl_unique_default)
  apply(fact NoRefl_offending_set)
  done

text{*It can also be interpreted as IFS*}
lemma NoRefl_SecurityInvariant_IFS: "SecurityInvariant_IFS sinvar default_node_properties"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply(frule SINVAR_NoRefl.offending_notevalD)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply fastforce
   apply(erule default_uniqueness_by_counterexample_IFS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1}, edges = {(vertex_1,vertex_1)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
   apply(rule_tac x="(\<lambda> x. NoRefl)(vertex_1 := NoRefl, vertex_2 := NoRefl)" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_1)}" in exI, simp)
  done

  lemma TopoS_NoRefl: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar receiver_violation default_node_properties

end


theory Inductive_Predicate
imports Setup
begin

(*<*)
hide_const %invisible append

inductive %invisible append where
  "append [] ys ys"
| "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"

lemma %invisible append: "append xs ys zs = (xs @ ys = zs)"
  by (induct xs arbitrary: ys zs) (auto elim: append.cases intro: append.intros)

lemmas lexordp_def =
  lexordp_def [unfolded lexord_def mem_Collect_eq split]
(*>*)

section {* Inductive Predicates \label{sec:inductive} *}

text {*
  The @{text "predicate compiler"} is an extension of the code generator
  which turns inductive specifications into equational ones, from
  which in turn executable code can be generated.  The mechanisms of
  this compiler are described in detail in
  @{cite "Berghofer-Bulwahn-Haftmann:2009:TPHOL"}.

  Consider the simple predicate @{const append} given by these two
  introduction rules:
*}

text %quote {*
  @{thm append.intros(1)[of ys]} \\
  @{thm append.intros(2)[of xs ys zs x]}
*}

text {*
  \noindent To invoke the compiler, simply use @{command_def "code_pred"}:
*}

code_pred %quote append .

text {*
  \noindent The @{command "code_pred"} command takes the name of the
  inductive predicate and then you put a period to discharge a trivial
  correctness proof.  The compiler infers possible modes for the
  predicate and produces the derived code equations.  Modes annotate
  which (parts of the) arguments are to be taken as input, and which
  output. Modes are similar to types, but use the notation @{text "i"}
  for input and @{text "o"} for output.

  For @{term "append"}, the compiler can infer the following modes:
  \begin{itemize}
    \item @{text "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool"}
    \item @{text "i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool"}
    \item @{text "o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool"}
  \end{itemize}
  You can compute sets of predicates using @{command_def "values"}:
*}

values %quote "{zs. append [(1::nat),2,3] [4,5] zs}"

text {* \noindent outputs @{text "{[1, 2, 3, 4, 5]}"}, and *}

values %quote "{(xs, ys). append xs ys [(2::nat),3]}"

text {* \noindent outputs @{text "{([], [2, 3]), ([2], [3]), ([2, 3], [])}"}. *}

text {*
  \noindent If you are only interested in the first elements of the
  set comprehension (with respect to a depth-first search on the
  introduction rules), you can pass an argument to @{command "values"}
  to specify the number of elements you want:
*}

values %quote 1 "{(xs, ys). append xs ys [(1::nat), 2, 3, 4]}"
values %quote 3 "{(xs, ys). append xs ys [(1::nat), 2, 3, 4]}"

text {*
  \noindent The @{command "values"} command can only compute set
  comprehensions for which a mode has been inferred.

  The code equations for a predicate are made available as theorems with
  the suffix @{text "equation"}, and can be inspected with:
*}

thm %quote append.equation

text {*
  \noindent More advanced options are described in the following subsections.
*}

subsection {* Alternative names for functions *}

text {*
  By default, the functions generated from a predicate are named after
  the predicate with the mode mangled into the name (e.g., @{text
  "append_i_i_o"}).  You can specify your own names as follows:
*}

code_pred %quote (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as concat,
  o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as split,
  i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as suffix) append .

subsection {* Alternative introduction rules *}

text {*
  Sometimes the introduction rules of an predicate are not executable
  because they contain non-executable constants or specific modes
  could not be inferred.  It is also possible that the introduction
  rules yield a function that loops forever due to the execution in a
  depth-first search manner.  Therefore, you can declare alternative
  introduction rules for predicates with the attribute @{attribute
  "code_pred_intro"}.  For example, the transitive closure is defined
  by:
*}

text %quote {*
  @{lemma [source] "r a b \<Longrightarrow> tranclp r a b" by (fact tranclp.intros(1))}\\
  @{lemma [source] "tranclp r a b \<Longrightarrow> r b c \<Longrightarrow> tranclp r a c" by (fact tranclp.intros(2))}
*}

text {*
  \noindent These rules do not suit well for executing the transitive
  closure with the mode @{text "(i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool"}, as
  the second rule will cause an infinite loop in the recursive call.
  This can be avoided using the following alternative rules which are
  declared to the predicate compiler by the attribute @{attribute
  "code_pred_intro"}:
*}

lemma %quote [code_pred_intro]:
  "r a b \<Longrightarrow> tranclp r a b"
  "r a b \<Longrightarrow> tranclp r b c \<Longrightarrow> tranclp r a c"
by auto

text {*
  \noindent After declaring all alternative rules for the transitive
  closure, you invoke @{command "code_pred"} as usual.  As you have
  declared alternative rules for the predicate, you are urged to prove
  that these introduction rules are complete, i.e., that you can
  derive an elimination rule for the alternative rules:
*}

code_pred %quote tranclp
proof -
  case tranclp
  from this converse_tranclpE [OF tranclp.prems] show thesis by metis
qed

text {*
  \noindent Alternative rules can also be used for constants that have
  not been defined inductively. For example, the lexicographic order
  which is defined as:
*}

text %quote {*
  @{thm [display] lexordp_def [of r]}
*}

text {*
  \noindent To make it executable, you can derive the following two
  rules and prove the elimination rule:
*}

lemma %quote [code_pred_intro]:
  "append xs (a # v) ys \<Longrightarrow> lexordp r xs ys"
(*<*)unfolding lexordp_def by (auto simp add: append)(*>*)

lemma %quote [code_pred_intro]:
  "append u (a # v) xs \<Longrightarrow> append u (b # w) ys \<Longrightarrow> r a b
  \<Longrightarrow> lexordp r xs ys"
(*<*)unfolding lexordp_def append apply simp
apply (rule disjI2) by auto(*>*)

code_pred %quote lexordp
(*<*)proof -
  fix r xs ys
  assume lexord: "lexordp r xs ys"
  assume 1: "\<And>r' xs' ys' a v. r = r' \<Longrightarrow> xs = xs' \<Longrightarrow> ys = ys'
    \<Longrightarrow> append xs' (a # v) ys' \<Longrightarrow> thesis"
  assume 2: "\<And>r' xs' ys' u a v b w. r = r' \<Longrightarrow> xs = xs' \<Longrightarrow> ys = ys'
    \<Longrightarrow> append u (a # v) xs' \<Longrightarrow> append u (b # w) ys' \<Longrightarrow> r' a b \<Longrightarrow> thesis"
  {
    assume "\<exists>a v. ys = xs @ a # v"
    from this 1 have thesis
        by (fastforce simp add: append)
  } moreover
  {
    assume "\<exists>u a b v w. r a b \<and> xs = u @ a # v \<and> ys = u @ b # w"
    from this 2 have thesis by (fastforce simp add: append)
  } moreover
  note lexord
  ultimately show thesis
    unfolding lexordp_def
    by fastforce
qed(*>*)

subsection {* Options for values *}

text {*
  In the presence of higher-order predicates, multiple modes for some
  predicate could be inferred that are not disambiguated by the
  pattern of the set comprehension.  To disambiguate the modes for the
  arguments of a predicate, you can state the modes explicitly in the
  @{command "values"} command.  Consider the simple predicate @{term
  "succ"}:
*}

inductive %quote succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "succ 0 (Suc 0)"
| "succ x y \<Longrightarrow> succ (Suc x) (Suc y)"

code_pred %quote succ .

text {*
  \noindent For this, the predicate compiler can infer modes @{text "o
  \<Rightarrow> o \<Rightarrow> bool"}, @{text "i \<Rightarrow> o \<Rightarrow> bool"}, @{text "o \<Rightarrow> i \<Rightarrow> bool"} and
  @{text "i \<Rightarrow> i \<Rightarrow> bool"}.  The invocation of @{command "values"}
  @{text "{n. tranclp succ 10 n}"} loops, as multiple modes for the
  predicate @{text "succ"} are possible and here the first mode @{text
  "o \<Rightarrow> o \<Rightarrow> bool"} is chosen. To choose another mode for the argument,
  you can declare the mode for the argument between the @{command
  "values"} and the number of elements.
*}

values %quote [mode: i \<Rightarrow> o \<Rightarrow> bool] 1 "{n. tranclp succ 10 n}" (*FIMXE does not terminate for n\<ge>1*)
values %quote [mode: o \<Rightarrow> i \<Rightarrow> bool] 1 "{n. tranclp succ n 10}"

subsection {* Embedding into functional code within Isabelle/HOL *}

text {*
  To embed the computation of an inductive predicate into functions
  that are defined in Isabelle/HOL, you have a number of options:

  \begin{itemize}

    \item You want to use the first-order predicate with the mode
      where all arguments are input. Then you can use the predicate directly, e.g.

      \begin{quote}
        @{text "valid_suffix ys zs = "} \\
        @{text "(if append [Suc 0, 2] ys zs then Some ys else None)"}
      \end{quote}

    \item If you know that the execution returns only one value (it is
      deterministic), then you can use the combinator @{term
      "Predicate.the"}, e.g., a functional concatenation of lists is
      defined with

      \begin{quote}
        @{term "functional_concat xs ys = Predicate.the (append_i_i_o xs ys)"}
      \end{quote}

      Note that if the evaluation does not return a unique value, it
      raises a run-time error @{term "not_unique"}.

  \end{itemize}
*}

subsection {* Further Examples *}

text {*
  Further examples for compiling inductive predicates can be found in
  @{file "~~/src/HOL/Predicate_Compile_Examples/Examples.thy"}.  There are
  also some examples in the Archive of Formal Proofs, notably in the
  @{text "POPLmark-deBruijn"} and the @{text "FeatherweightJava"}
  sessions.
*}

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)
 *)

(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Abstract Separation Logic, Alternative Definition"

theory Separation_Algebra_Alt
imports "~~/src/HOL/Main"
begin

text {*
  This theory contains an alternative definition of speration algebra,
  following Calcagno et al very closely. While some of the abstract
  development is more algebraic, it is cumbersome to instantiate.
  We only use it to prove equivalence and to give an impression of how
  it would look like.
*}

(* The @{text "++"} notation is a horrible choice, but this theory is
   only intended to show how the development would look like, not to
   actually use it. We remove the notation for map-add so it doesn't
   conflict.
*)
no_notation map_add (infixl "++" 100)

definition
  lift2 :: "('a => 'b => 'c option) \<Rightarrow> 'a option => 'b option => 'c option"
where
  "lift2 f a b \<equiv> case (a,b) of (Some a, Some b) \<Rightarrow> f a b | _ \<Rightarrow> None"

class sep_algebra_alt = zero +
  fixes add :: "'a => 'a => 'a option" (infixr "\<oplus>" 65)

  assumes add_zero [simp]: "x \<oplus> 0 = Some x"
  assumes add_comm: "x \<oplus> y = y \<oplus> x"
  assumes add_assoc: "lift2 add a (lift2 add b c) = lift2 add (lift2 add a b) c"

begin

definition
  disjoint :: "'a => 'a => bool" (infix "##" 60)
where
  "a ## b \<equiv> a \<oplus> b \<noteq> None"

lemma disj_com: "x ## y = y ## x"
  by (auto simp: disjoint_def add_comm)

lemma disj_zero [simp]: "x ## 0"
  by (auto simp: disjoint_def)

lemma disj_zero2 [simp]: "0 ## x"
  by (subst disj_com) simp

lemma add_zero2 [simp]: "0 \<oplus> x = Some x"
  by (subst add_comm) auto

definition
  substate :: "'a => 'a => bool" (infix "\<preceq>" 60) where
  "a \<preceq> b \<equiv> \<exists>c. a \<oplus> c = Some b"

definition
  sep_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "**" 61)
  where
  "P ** Q \<equiv> \<lambda>s. \<exists>p q. p \<oplus> q = Some s \<and> P p \<and> Q q"

definition emp :: "'a \<Rightarrow> bool" ("\<box>") where
  "\<box> \<equiv> \<lambda>s. s = 0"

definition
  sep_impl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<longrightarrow>\<^sup>*" 25)
  where
  "P \<longrightarrow>\<^sup>* Q \<equiv> \<lambda>h. \<forall>h' h''. h \<oplus> h' = Some h'' \<and> P h' \<longrightarrow> Q h''"

definition
  "sep_true \<equiv> \<lambda>s. True"

definition
  "sep_false \<equiv> \<lambda>s. False"

abbreviation
  add2 :: "'a option => 'a option => 'a option" (infixr "++" 65)
where
  "add2 == lift2 add"

lemma add2_None [simp]:
  "x ++ None = None"
  by (simp add: lift2_def split: option.splits)

lemma None_add2 [simp]:
  "None ++ x = None"
  by (simp add: lift2_def split: option.splits)

lemma add2_Some_Some:
  "Some x ++ Some y = x \<oplus> y"
  by (simp add: lift2_def)

lemma add2_zero [simp]:
  "Some x ++ Some 0 = Some x"
  by (simp add: add2_Some_Some)

lemma zero_add2 [simp]:
  "Some 0 ++ Some x = Some x"
  by (simp add: add2_Some_Some)

lemma sep_conjE:
  "\<lbrakk> (P ** Q) s; \<And>p q. \<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> X \<rbrakk> \<Longrightarrow> X"
  by (auto simp: sep_conj_def)

lemma sep_conjI:
  "\<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> (P ** Q) s"
  by (auto simp: sep_conj_def)

lemma sep_conj_comI:
  "(P ** Q) s \<Longrightarrow> (Q ** P) s"
  by (auto intro!: sep_conjI elim!: sep_conjE simp: add_comm)

lemma sep_conj_com:
  "P ** Q = Q ** P"
  by (auto intro: sep_conj_comI)

lemma lift_to_add2:
  "\<lbrakk>z \<oplus> q = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> Some z ++ Some x ++ Some y = Some s"
  by (simp add: add2_Some_Some)

lemma lift_to_add2':
  "\<lbrakk>q \<oplus> z = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> (Some x ++ Some y) ++ Some z = Some s"
  by (simp add: add2_Some_Some)

lemma add2_Some:
  "(x ++ Some y = Some z) = (\<exists>x'. x = Some x' \<and> x' \<oplus> y = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma Some_add2:
  "(Some x ++ y = Some z) = (\<exists>y'. y = Some y' \<and> x \<oplus> y' = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma sep_conj_assoc:
  "P ** (Q ** R) = (P ** Q) ** R"
  unfolding sep_conj_def
  apply (rule ext)
  apply (rule iffI)
   apply clarsimp
   apply (drule (1) lift_to_add2)
   apply (subst (asm) add_assoc)
   apply (fastforce simp: add2_Some_Some add2_Some)
  apply clarsimp
  apply (drule (1) lift_to_add2')
  apply (subst (asm) add_assoc [symmetric])
  apply (fastforce simp: add2_Some_Some Some_add2)
  done

lemma sep_true[simp]: "sep_true s" by (simp add: sep_true_def)
lemma sep_false[simp]: "\<not>sep_false x" by (simp add: sep_false_def)

lemma sep_conj_sep_true:
  "P s \<Longrightarrow> (P ** sep_true) s"
  by (auto simp: sep_conjI [where q=0])

lemma sep_conj_sep_true':
  "P s \<Longrightarrow> (sep_true ** P) s"
  by (auto simp: sep_conjI [where p=0])

lemma disjoint_submaps_exist:
  "\<exists>h\<^sub>0 h\<^sub>1. h\<^sub>0 \<oplus> h\<^sub>1 = Some h"
  by (rule_tac x=0 in exI, auto)

lemma sep_conj_true[simp]:
  "(sep_true ** sep_true) = sep_true"
  unfolding sep_conj_def
  by (auto intro: disjoint_submaps_exist)

lemma sep_conj_false_right[simp]:
  "(P ** sep_false) = sep_false"
  by (force elim: sep_conjE)

lemma sep_conj_false_left[simp]:
  "(sep_false ** P) = sep_false"
  by (subst sep_conj_com) (rule sep_conj_false_right)

lemma sep_conj_left_com:
  "(P ** (Q ** R)) = (Q ** (P ** R))" (is "?x = ?y")
proof -
  have "?x = ((Q ** R) ** P)" by (simp add: sep_conj_com)
  also have "\<dots> = (Q ** (R ** P))" by (subst sep_conj_assoc, simp)
  finally show ?thesis by (simp add: sep_conj_com)
qed

lemmas sep_conj_ac = sep_conj_com sep_conj_assoc sep_conj_left_com

lemma empty_empty[simp]: "\<box> 0"
  by (simp add: emp_def)

lemma sep_conj_empty[simp]:
  "(P ** \<box>) = P"
  by (simp add: sep_conj_def emp_def)

  lemma sep_conj_empty'[simp]:
  "(\<box> ** P) = P"
  by (subst sep_conj_com, rule sep_conj_empty)

lemma sep_conj_sep_emptyI:
  "P s \<Longrightarrow> (P ** \<box>) s"
  by simp

lemma sep_conj_true_P[simp]:
  "(sep_true ** (sep_true ** P)) = (sep_true ** P)"
  by (simp add: sep_conj_assoc)

lemma sep_conj_disj:
  "((\<lambda>s. P s \<or> Q s) ** R) s = ((P ** R) s \<or> (Q ** R) s)" (is "?x = (?y \<or> ?z)")
  by (auto simp: sep_conj_def)

lemma sep_conj_conj:
  "((\<lambda>s. P s \<and> Q s) ** R) s \<Longrightarrow> (P ** R) s \<and> (Q ** R) s"
  by (force intro: sep_conjI elim!: sep_conjE)

lemma sep_conj_exists1:
  "((\<lambda>s. \<exists>x. P x s) ** Q) s = (\<exists>x. (P x ** Q) s)"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_exists2:
  "(P ** (\<lambda>s. \<exists>x. Q x s)) = (\<lambda>s. (\<exists>x. (P ** Q x) s))"
  by (force intro!: sep_conjI elim!: sep_conjE)

lemmas sep_conj_exists = sep_conj_exists1 sep_conj_exists2

lemma sep_conj_forall:
  "((\<lambda>s. \<forall>x. P x s) ** Q) s \<Longrightarrow> (P x ** Q) s"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_impl:
  "\<lbrakk> (P ** Q) s; \<And>s. P s \<Longrightarrow> P' s; \<And>s. Q s \<Longrightarrow> Q' s \<rbrakk> \<Longrightarrow> (P' ** Q') s"
  by (erule sep_conjE, auto intro!: sep_conjI)

lemma sep_conj_impl1:
  assumes P: "\<And>s. P s \<Longrightarrow> I s"
  shows "(P ** R) s \<Longrightarrow> (I ** R) s"
  by (auto intro: sep_conj_impl P)

lemma sep_conj_sep_true_left:
  "(P ** Q) s \<Longrightarrow> (sep_true ** Q) s"
  by (erule sep_conj_impl, simp+)

lemma sep_conj_sep_true_right:
  "(P ** Q) s \<Longrightarrow> (P ** sep_true) s"
  by (subst (asm) sep_conj_com, drule sep_conj_sep_true_left,
      simp add: sep_conj_ac)

lemma sep_globalise:
  "\<lbrakk> (P ** R) s; (\<And>s. P s \<Longrightarrow> Q s) \<rbrakk> \<Longrightarrow> (Q ** R) s"
  by (fast elim: sep_conj_impl)

lemma sep_implI:
  assumes a: "\<And>h' h''. \<lbrakk> h \<oplus> h' = Some h''; P h' \<rbrakk> \<Longrightarrow> Q h''"
  shows "(P \<longrightarrow>\<^sup>* Q) h"
  unfolding sep_impl_def by (auto elim: a)

lemma sep_implD:
  "(x \<longrightarrow>\<^sup>* y) h \<Longrightarrow> \<forall>h' h''. h \<oplus> h' = Some h'' \<and> x h' \<longrightarrow> y h''"
  by (force simp: sep_impl_def)

lemma sep_impl_sep_true[simp]:
  "(P \<longrightarrow>\<^sup>* sep_true) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_false[simp]:
  "(sep_false \<longrightarrow>\<^sup>* P) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_true_P:
  "(sep_true \<longrightarrow>\<^sup>* P) s \<Longrightarrow> P s"
  apply (drule sep_implD)
  apply (erule_tac x=0 in allE)
  apply simp
  done

lemma sep_impl_sep_true_false[simp]:
  "(sep_true \<longrightarrow>\<^sup>* sep_false) = sep_false"
  by (force dest: sep_impl_sep_true_P)

lemma sep_conj_sep_impl:
  "\<lbrakk> P s; \<And>s. (P ** Q) s \<Longrightarrow> R s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s"
proof (rule sep_implI)
  fix h' h h''
  assume "P h" and "h \<oplus> h' = Some h''" and "Q h'"
  hence "(P ** Q) h''" by (force intro: sep_conjI)
  moreover assume "\<And>s. (P ** Q) s \<Longrightarrow> R s"
  ultimately show "R h''" by simp
qed

lemma sep_conj_sep_impl2:
  "\<lbrakk> (P ** Q) s; \<And>s. P s \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s \<rbrakk> \<Longrightarrow> R s"
  by (force dest: sep_implD elim: sep_conjE)

lemma sep_conj_sep_impl_sep_conj2:
  "(P ** R) s \<Longrightarrow> (P ** (Q \<longrightarrow>\<^sup>* (Q ** R))) s"
  by (erule (1) sep_conj_impl, erule sep_conj_sep_impl, simp add: sep_conj_ac)

lemma sep_conj_triv_strip2:
  "Q = R \<Longrightarrow> (Q ** P) = (R ** P)" by simp

end

end