header {* Code Generation for the Skeleton Algorithm \label{sec:skel_code}*}
theory Gabow_Skeleton_Code
imports
  Gabow_Skeleton
  "../CAVA_Automata/Digraph_Impl"
  "../CAVA_Automata/CAVA_Base/CAVA_Code_Target"
begin

section {* Statistics *}
text {*
  In this section, we do the ML setup that gathers statistics about the
  algorithm's execution.
*}

code_printing
  code_module Gabow_Skeleton_Statistics \<rightharpoonup> (SML) {*
    structure Gabow_Skeleton_Statistics = struct
      val active = Unsynchronized.ref false
      val num_vis = Unsynchronized.ref 0

      val time = Unsynchronized.ref Time.zeroTime

      fun is_active () = !active
      fun newnode () = num_vis := !num_vis + 1

      fun start () = (active := true; time := Time.now ())
      fun stop () = (time := Time.- (Time.now (), !time))

      fun to_string () = let
        val t = Time.toMilliseconds (!time)
        val states_per_ms = real (!num_vis) / real t
        val realStr = Real.fmt (StringCvt.FIX (SOME 2))
      in
        "Required time: " ^ IntInf.toString (t) ^ "ms\n"
      ^ "States per ms: " ^ realStr states_per_ms ^ "\n"
      ^ "# states: " ^ IntInf.toString (!num_vis) ^ "\n"
      end

      val _ = Statistics.register_stat ("Gabow-Skeleton",is_active,to_string)

    end
*}
code_reserved SML Gabow_Skeleton_Statistics

code_printing
  constant stat_newnode \<rightharpoonup> (SML) "Gabow'_Skeleton'_Statistics.newnode"
| constant stat_start \<rightharpoonup> (SML) "Gabow'_Skeleton'_Statistics.start"
| constant stat_stop \<rightharpoonup> (SML) "Gabow'_Skeleton'_Statistics.stop"

section {* Automatic Refinement Setup *}
consts i_node_state :: interface

definition "node_state_rel \<equiv> {(-1::int,DONE)} \<union> {(int k,STACK k) | k. True }"
lemma node_state_rel_simps[simp]:
  "(i,DONE)\<in>node_state_rel \<longleftrightarrow> i=-1"
  "(i,STACK n)\<in>node_state_rel \<longleftrightarrow> i = int n"
  unfolding node_state_rel_def
  by auto

lemma node_state_rel_sv[simp,intro!,relator_props]:
  "single_valued node_state_rel"
  unfolding node_state_rel_def
  by (auto intro: single_valuedI)

lemmas [autoref_rel_intf] = REL_INTFI[of node_state_rel i_node_state]

primrec is_DONE where
  "is_DONE DONE = True"
| "is_DONE (STACK _) = False"

lemma node_state_rel_refine[autoref_rules]:
  "(-1,DONE)\<in>node_state_rel"
  "(int,STACK)\<in>nat_rel\<rightarrow>node_state_rel"
  "(\<lambda>i. i<0,is_DONE)\<in>node_state_rel\<rightarrow>bool_rel"
  "((\<lambda>f g i. if i\<ge>0 then f (nat i) else g),case_node_state)
    \<in>(nat_rel \<rightarrow> R) \<rightarrow> R \<rightarrow> node_state_rel \<rightarrow> R"
  unfolding node_state_rel_def
    apply auto [3]
    apply (fastforce dest: fun_relD)
    done

(* TODO: Make changing the Autoref-config simpler, by concentrating
    everything here *)
consts i_node :: interface

(* TODO: Move generic part of this locale to Digraph_impl *)
locale fr_graph_impl_loc = fr_graph G
  for mrel and G_impl and G :: "('v::hashable,'more) fr_graph_rec_scheme"
  +
  assumes G_refine: "(G_impl,G)\<in>\<langle>mrel,Id\<rangle>frg_impl_rel_ext"
begin
  abbreviation "node_rel \<equiv> Id :: ('v \<times> _) set"
  lemmas [autoref_rel_intf] = REL_INTFI[of node_rel i_node]

  lemmas [autoref_rules] = G_refine

  lemma locale_this: "fr_graph_impl_loc mrel G_impl G"
    by unfold_locales

  abbreviation "oGSi_rel \<equiv> \<langle>node_rel,node_state_rel\<rangle>dflt_ahm_rel"

  abbreviation "GSi_rel \<equiv>
    \<langle>node_rel\<rangle>as_rel
    \<times>\<^sub>r \<langle>nat_rel\<rangle>as_rel
    \<times>\<^sub>r \<langle>node_rel,node_state_rel\<rangle>dflt_ahm_rel
    \<times>\<^sub>r \<langle>nat_rel \<times>\<^sub>r \<langle>node_rel\<rangle>list_set_rel\<rangle>as_rel"

  lemmas [autoref_op_pat] = GS.S_def GS.B_def GS.I_def GS.P_def

end

section {* Generating the Code *}

context fr_graph_impl_loc
begin
  schematic_lemma push_code_aux: "(?c,push_impl)\<in>node_rel \<rightarrow> GSi_rel \<rightarrow> GSi_rel"
    unfolding push_impl_def_opt[abs_def]
    using [[autoref_trace_failed_id]]
    apply (autoref (keep_goal))
    done
  concrete_definition (in -) push_code uses fr_graph_impl_loc.push_code_aux
  lemmas [autoref_rules] = push_code.refine[OF locale_this]

  schematic_lemma pop_code_aux: "(?c,pop_impl)\<in>GSi_rel \<rightarrow> \<langle>GSi_rel\<rangle>nres_rel"
    unfolding pop_impl_def_opt[abs_def]
    unfolding GS.mark_as_done_def
    using [[autoref_trace_failed_id]]
    apply (autoref (keep_goal))
    done
  concrete_definition (in -) pop_code uses fr_graph_impl_loc.pop_code_aux
  lemmas [autoref_rules] = pop_code.refine[OF locale_this]

  schematic_lemma S_idx_of_code_aux:
    notes [autoref_rules] = IdI[of "undefined::nat"] (* TODO: hack!*)
    shows "(?c,GS.S_idx_of)\<in>GSi_rel \<rightarrow> node_rel \<rightarrow> nat_rel"
    unfolding GS.S_idx_of_def[abs_def]
    using [[autoref_trace_failed_id]]
    apply (autoref (keep_goal))
    done
  concrete_definition (in -) S_idx_of_code
    uses fr_graph_impl_loc.S_idx_of_code_aux
  lemmas [autoref_rules] = S_idx_of_code.refine[OF locale_this]

  schematic_lemma idx_of_code_aux:
    notes [autoref_rules] = IdI[of "undefined::nat"] (* TODO: hack!*)
    shows "(?c,GS.idx_of_impl)\<in> GSi_rel \<rightarrow> node_rel \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
    unfolding
      GS.idx_of_impl_def[abs_def, unfolded GS.find_seg_impl_def GS.S_idx_of_def,
        THEN opt_GSdef, unfolded GS_sel_simps, abs_def]
    using [[autoref_trace_failed_id]]
    apply (autoref (keep_goal))
    done
  concrete_definition (in -) idx_of_code uses fr_graph_impl_loc.idx_of_code_aux
  lemmas [autoref_rules] = idx_of_code.refine[OF locale_this]

  schematic_lemma collapse_code_aux:
    "(?c,collapse_impl)\<in>node_rel \<rightarrow> GSi_rel \<rightarrow> \<langle>GSi_rel\<rangle>nres_rel"
    unfolding collapse_impl_def_opt[abs_def]
    using [[autoref_trace_failed_id]]
    apply (autoref (keep_goal))
    done
  concrete_definition (in -) collapse_code
    uses fr_graph_impl_loc.collapse_code_aux
  lemmas [autoref_rules] = collapse_code.refine[OF locale_this]

  term select_edge_impl
  schematic_lemma select_edge_code_aux:
    "(?c,select_edge_impl)
      \<in> GSi_rel \<rightarrow> \<langle>\<langle>node_rel\<rangle>option_rel \<times>\<^sub>r GSi_rel\<rangle>nres_rel"
    unfolding select_edge_impl_def_opt[abs_def]

    using [[autoref_trace_failed_id]]
    using [[goals_limit=1]]
    apply (autoref (keep_goal,trace))
    done
  concrete_definition (in -) select_edge_code
    uses fr_graph_impl_loc.select_edge_code_aux
  lemmas [autoref_rules] = select_edge_code.refine[OF locale_this]

  context begin interpretation autoref_syn .

    term fr_graph.pop_impl
    lemma [autoref_op_pat]:
      "push_impl \<equiv> OP push_impl"
      "collapse_impl \<equiv> OP collapse_impl"
      "select_edge_impl \<equiv> OP select_edge_impl"
      "pop_impl \<equiv> OP pop_impl"
      by simp_all

  end

  schematic_lemma skeleton_code_aux:
    "(?c,skeleton_impl) \<in> \<langle>oGSi_rel\<rangle>nres_rel"
    unfolding skeleton_impl_def[abs_def] initial_impl_def GS_initial_impl_def
    unfolding path_is_empty_impl_def is_on_stack_impl_def is_done_impl_def
      is_done_oimpl_def
    unfolding GS.is_on_stack_impl_def GS.is_done_impl_def
    using [[autoref_trace_failed_id]]

    apply (autoref (keep_goal,trace))
    done
  concrete_definition (in -) skeleton_code
    uses fr_graph_impl_loc.skeleton_code_aux
  lemmas [autoref_rules] = skeleton_code.refine[OF locale_this]

  schematic_lemma pop_tr_aux: "RETURN ?c \<le> pop_code s"
    unfolding pop_code_def by refine_transfer
  concrete_definition (in -) pop_tr uses fr_graph_impl_loc.pop_tr_aux
  lemmas [refine_transfer] = pop_tr.refine[OF locale_this]

  schematic_lemma select_edge_tr_aux: "RETURN ?c \<le> select_edge_code s"
    unfolding select_edge_code_def by refine_transfer
  concrete_definition (in -) select_edge_tr
    uses fr_graph_impl_loc.select_edge_tr_aux
  lemmas [refine_transfer] = select_edge_tr.refine[OF locale_this]

  schematic_lemma idx_of_tr_aux: "RETURN ?c \<le> idx_of_code v s"
    unfolding idx_of_code_def by refine_transfer
  concrete_definition (in -) idx_of_tr uses fr_graph_impl_loc.idx_of_tr_aux
  lemmas [refine_transfer] = idx_of_tr.refine[OF locale_this]

  schematic_lemma collapse_tr_aux: "RETURN ?c \<le> collapse_code v s"
    unfolding collapse_code_def by refine_transfer
  concrete_definition (in -) collapse_tr uses fr_graph_impl_loc.collapse_tr_aux
  lemmas [refine_transfer] = collapse_tr.refine[OF locale_this]

  schematic_lemma skeleton_tr_aux: "RETURN ?c \<le> skeleton_code g"
    unfolding skeleton_code_def by refine_transfer
  concrete_definition (in -) skeleton_tr uses fr_graph_impl_loc.skeleton_tr_aux
  lemmas [refine_transfer] = skeleton_tr.refine[OF locale_this]

end

term skeleton_tr

export_code skeleton_tr checking SML

end


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

context weakTauLaws begin

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

  shows "\<Psi> \<rhd> \<tau>.(P) \<approx> P"
proof -
  let ?X = "{(\<Psi>, \<tau>.(P), P) | \<Psi> P. True}" let ?Y = "{(\<Psi>, P, \<tau>.(P)) | \<Psi> P. True}"
  have "(\<Psi>, \<tau>.(P), P) \<in> ?X \<union> ?Y" by auto
  moreover have "eqvt(?X \<union> ?Y)" by(auto simp add: eqvt_def simp add: eqvts)
  ultimately have "\<Psi> \<rhd> \<tau>.(P) \<approx>\<^sub>w P"
  proof(coinduct rule: weakenTransitiveCoinduct)
    case(cStatImp \<Psi> P Q)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      {
        fix \<Psi> P
        have "\<Psi> \<rhd> P \<lessapprox>\<^sub>w<(?X \<union> ?Y \<union> weakBisim)> P" by(auto simp add: weakenStatImp_def intro: weakBisimReflexive)
        moreover have "(\<Psi>, \<tau>.(P), P) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        ultimately have "\<Psi> \<rhd> \<tau>.(P) \<lessapprox>\<^sub>w<(?X \<union> ?Y \<union> weakBisim)> P"
          by(rule tauLaw1StatImpLeft)
      }
      with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?thesis by auto
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by auto
      {
        fix \<Psi> P
        have "\<Psi> \<rhd> P \<lessapprox><weakBisim> P" using weakBisimReflexive
          by(rule weakBisimE)
        moreover have "\<And>\<Psi> P Q R. \<lbrakk>\<Psi> \<rhd> P \<approx> Q; \<Psi> \<rhd> Q \<sim> R\<rbrakk> \<Longrightarrow> (\<Psi>, P, R) \<in> ?X \<union> ?Y \<union> weakBisim"
          by(fastforce intro: weakBisimTransitive strongBisimWeakBisim)
        ultimately have  "\<Psi> \<rhd> P \<lessapprox><( ?X \<union> ?Y \<union> weakBisim)> \<tau>.(P)" by(rule tauLaw1StatImpRight)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> ?Y \<union> weakBisim; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?X \<union> ?Y \<union> weakBisim"
          by(auto dest: statEqWeakBisim)
        ultimately have "\<Psi> \<rhd> P \<lessapprox>\<^sub>w<( ?X \<union> ?Y \<union> weakBisim)> \<tau>.(P)" by(rule weakStatImpWeakenStatImp)
      }
      with \<open>(\<Psi>, P, Q) \<in> ?Y\<close> show ?thesis by auto
    qed
  next
    case(cSim \<Psi> P Q)
    let ?Z = "{(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<sim> P' \<and> (\<Psi>, P', Q') \<in> ?X \<union> ?Y \<union> weakenBisim \<and> \<Psi> \<rhd> Q' \<sim> Q}"
    have "eqvt ?Z"
      apply auto
      apply(auto simp add: eqvt_def eqvts)
      apply(rule_tac x="(p \<bullet> (\<tau>.(Q')))" in exI)
      apply(auto intro: bisimClosed)
      apply(simp add: eqvts)
      apply(blast intro: bisimClosed weakBisimClosed)
      apply(rule_tac x="(p \<bullet> P')" in exI)
      apply(auto intro: bisimClosed)
      apply(rule_tac x="\<tau>.(p \<bullet> P')" in exI)
      apply auto
      apply(drule_tac p=p and Q=b in bisimClosed)
      apply(simp add: eqvts)
      apply(rule_tac x="(p \<bullet> P')" in exI)
      apply(auto intro: bisimClosed)
      apply(rule_tac x="p \<bullet> Q'" in exI)
      apply auto
      by(blast intro: bisimClosed dest: weakBisimClosed)+
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      {
        fix P
        have "\<Psi> \<rhd> P \<leadsto><?Z> P" using weakenBisimEqWeakBisim by(blast intro: weakSimReflexive weakBisimReflexive bisimReflexive)
        moreover note \<open>eqvt ?Z\<close>
        moreover have "\<And>\<Psi> P Q R. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; (\<Psi>, Q, R) \<in> ?Z\<rbrakk> \<Longrightarrow> (\<Psi>, P, R) \<in> ?Z"
          by(blast intro: bisimTransitive)
        ultimately have "\<Psi> \<rhd> \<tau>.(P) \<leadsto><?Z> P"
          by(rule tauLaw1SimLeft)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?Z; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?Z"
          by simp (blast intro: statEqWeakBisim statEqBisim)
        ultimately have "\<Psi> \<rhd> \<tau>.(P) \<leadsto>\<^sub>w<?Z> P" by(rule weakSimWeakenSim)
      }
      with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?thesis by auto
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by auto
      moreover {
        fix P
        note \<open>eqvt ?Z\<close>
        moreover have "(\<Psi>, P, P) \<in> ?Z" by simp (blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P Q R. \<lbrakk>(\<Psi>, P, Q) \<in> ?Z; \<Psi> \<rhd> Q \<sim> R\<rbrakk> \<Longrightarrow> (\<Psi>, P, R) \<in> ?Z"
          by(blast intro: bisimTransitive)
        ultimately have "\<Psi> \<rhd> P \<leadsto><?Z> \<tau>.(P)" by(rule tauLaw1SimRight)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?Z; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?Z"
          by simp (blast intro: statEqWeakBisim statEqBisim)
        ultimately have "\<Psi> \<rhd> P \<leadsto>\<^sub>w<?Z> \<tau>.(P)" by(rule weakSimWeakenSim)
      }
      ultimately show ?thesis by auto
    qed
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by auto
  next
    case(cSym \<Psi> P Q)
    thus ?case by auto
  qed
  thus ?thesis by simp
qed

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

  shows "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<approx> \<alpha>\<cdot>P"
proof -
  let ?X = "({(\<Psi>, \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>P) | \<Psi> \<alpha> P. True})"
  let ?Y = "({(\<Psi>, \<alpha>\<cdot>P, \<alpha>\<cdot>(\<tau>.(P))) | \<Psi> \<alpha> P. True})"

  have "(\<Psi>, \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>P) \<in> ?X \<union> ?Y" by blast
  moreover have "eqvt(?X \<union> ?Y)" by(fastforce simp add: eqvt_def simp add: eqvts)
  ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<approx>\<^sub>w \<alpha>\<cdot>P"
  proof(coinduct rule: weakenTransitiveCoinduct)
    case(cStatImp \<Psi> P Q)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      {
        fix \<Psi> \<alpha> P
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>P) \<in> ?X \<union> ?Y \<union> weakenBisim" by auto
        hence "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<lessapprox><(?X \<union> ?Y \<union> weakenBisim)> \<alpha>\<cdot>P" by(rule tauLaw3StatImpLeft)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> ?Y \<union> weakenBisim; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?X \<union> ?Y \<union> weakenBisim"
          by(fastforce intro: statEqWeakBisim)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<lessapprox>\<^sub>w<(?X \<union> ?Y \<union> weakenBisim)> \<alpha>\<cdot>P" by(rule weakStatImpWeakenStatImp)
      }
      with \<open>(\<Psi>, P, Q) \<in> ?X\<close> show ?thesis by blast
    next
      case False
      {
        fix \<Psi> \<alpha> P
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P, \<alpha>\<cdot>(\<tau>.(P))) \<in> ?X \<union> ?Y \<union> weakenBisim" by auto
        hence "\<Psi> \<rhd> \<alpha>\<cdot>P \<lessapprox><(?X \<union> ?Y \<union> weakenBisim)> \<alpha>\<cdot>(\<tau>.(P))" by(rule tauLaw3StatImpRight)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> ?Y \<union> weakenBisim; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?X \<union> ?Y \<union> weakenBisim"
          by(fastforce intro: statEqWeakBisim)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>P \<lessapprox>\<^sub>w<(?X \<union> ?Y \<union> weakenBisim)> \<alpha>\<cdot>(\<tau>.(P))" by(rule weakStatImpWeakenStatImp)
      }
      moreover from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by blast
      ultimately show ?thesis by auto
    qed
  next
    case(cSim \<Psi> P Q)
    let ?Z = "{(\<Psi>, P, Q) | \<Psi> P Q. \<exists>P' Q'. \<Psi> \<rhd> P \<sim> P' \<and> (\<Psi>, P', Q') \<in> ?X \<union> ?Y \<union> weakenBisim \<and> \<Psi> \<rhd> Q' \<sim> Q}"
    have "eqvt ?Z"
      apply(clarsimp simp add: eqvt_def)
      apply(elim disjE)
      apply(rule_tac x="p \<bullet> P'" in exI)
      apply(clarsimp simp add: bisimClosed eqvts)
      apply(blast intro: bisimClosed eqvts)
      apply(rule_tac x="p \<bullet> P'" in exI)
      apply(clarsimp simp add: bisimClosed eqvts)
      apply(rule_tac x="p \<bullet> (\<alpha>\<cdot>(\<tau>.(P)))" in exI)
      apply(clarsimp simp add: eqvts)
      apply(rule conjI)
      apply(rule disjI2)
      apply(blast intro: bisimClosed eqvts)
      apply(drule_tac p=p in bisimClosed)
      apply(drule_tac p=p in bisimClosed)
      apply(simp add: eqvts)
      by(blast dest: bisimClosed weakBisimClosed)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note \<open>(\<Psi>, P, Q) \<in> ?X\<close>
      moreover {
        fix \<Psi> P \<alpha>
        note \<open>eqvt ?Z\<close>
        moreover have "(\<Psi>, P, P) \<in> ?Z" using weakenBisimEqWeakBisim by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>xvec Tvec. length xvec = length Tvec \<Longrightarrow> (\<Psi>, P[xvec::=Tvec], P[xvec::=Tvec]) \<in> ?Z"
           using weakenBisimEqWeakBisim by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; (\<Psi>, Q, R) \<in> ?Z; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> (\<Psi>, P, S) \<in> ?Z" by(blast intro: bisimTransitive)
        moreover have "\<And>\<Psi> P Q \<Psi>'. (\<Psi>, P, Q) \<in> ?Z \<Longrightarrow> (\<Psi> \<otimes> \<Psi>', P, Q) \<in> ?Z" by(blast dest: weakenBisimE(3) bisimE(3))
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<leadsto><?Z> \<alpha>\<cdot>P" by(rule tauLaw3SimLeft)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?Z; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?Z" by simp (blast dest: statEqWeakBisim statEqBisim)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<leadsto>\<^sub>w<?Z> \<alpha>\<cdot>P" by(rule weakSimWeakenSim)
      }
      ultimately show ?thesis by auto
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by blast
      moreover {
        fix \<Psi> P \<alpha>
        note \<open>eqvt ?Z\<close>
        moreover have "\<And>\<Psi> xvec Tvec. length xvec=length Tvec \<Longrightarrow> (\<Psi>, P[xvec::=Tvec], \<tau>.(P[xvec::=Tvec])) \<in> ?Z"
          by simp (blast intro: weakBisimE(4) bisimReflexive tauLaw1)
        moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; (\<Psi>, Q, R) \<in> ?Z; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> (\<Psi>, P, S) \<in> ?Z" by(blast intro: bisimTransitive)
        moreover have "\<And>\<Psi>. (\<Psi>, P, \<tau>.(P)) \<in> ?Z" by simp (blast intro: weakBisimE(4) bisimReflexive tauLaw1)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>P \<leadsto><?Z> \<alpha>\<cdot>(\<tau>.(P))" by(rule tauLaw3SimRight)
        moreover have "\<And>\<Psi> P Q \<Psi>'. \<lbrakk>(\<Psi>, P, Q) \<in> ?Z; \<Psi> \<simeq> \<Psi>'\<rbrakk> \<Longrightarrow> (\<Psi>', P, Q) \<in> ?Z" by simp (blast dest: statEqWeakBisim statEqBisim)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>P \<leadsto>\<^sub>w<?Z> \<alpha>\<cdot>(\<tau>.(P))" by(rule weakSimWeakenSim)
      }
      ultimately show ?thesis by auto
    qed
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by auto
  next
    case(cSym \<Psi> P Q)
    thus ?case by blast
  qed
  thus ?thesis by simp
qed

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

  shows "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<doteq> \<alpha>\<cdot>P"
proof(induct rule: weakPsiCongI)
  case cWeakBisim
  show ?case by(rule tauLaw3)
next
  case cSimLeft
  have "\<Psi> \<rhd> P \<approx> P" by(rule weakBisimReflexive)
  moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; \<Psi> \<rhd> Q \<approx> R; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> P \<approx> S"
    by(blast intro: weakBisimTransitive strongBisimWeakBisim)
  ultimately show ?case using weakBisimE(3) by(rule tauLaw3CongSimLeft)
next
  case cSimRight
  have "\<Psi> \<rhd>  P \<approx> P" by(rule weakBisimReflexive)
  moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; \<Psi> \<rhd> Q \<approx> R; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> P \<approx> S"
    by(blast intro: weakBisimTransitive strongBisimWeakBisim)
  ultimately show ?case using tauLaw1[THEN weakBisimE(4)]
    by(rule tauLaw3CongSimRight)
qed

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

  shows "\<alpha>\<cdot>(\<tau>.(P)) \<doteq>\<^sub>c \<alpha>\<cdot>P"
proof(induct rule: weakCongI)
  case(cWeakPsiCong \<Psi> \<sigma>)
  show ?case
  proof(nominal_induct \<alpha> rule: prefix.strong_inducts)
  next
    case(pInput M yvec N)
    obtain p where "set p \<subseteq> set yvec \<times> set(p \<bullet> yvec)" and "(p \<bullet> yvec) \<sharp>* N" and "(p \<bullet> yvec) \<sharp>* P" and "(p \<bullet> yvec) \<sharp>* \<sigma>"
      by(rule_tac xvec=yvec and c="(N, P, \<sigma>)" in name_list_avoiding) auto
    thus ?case using \<open>wellFormedSubst \<sigma>\<close> tauLaw3PsiCong[where \<alpha>="pInput (substTerm.seqSubst M \<sigma>) (p \<bullet> yvec) (substTerm.seqSubst (p \<bullet> N) \<sigma>)"]
      by(simp add: inputChainAlpha' eqvts)
  next
    case(pOutput M N)
    thus ?case using  \<open>wellFormedSubst \<sigma>\<close> tauLaw3PsiCong[where \<alpha>="pOutput (substTerm.seqSubst M \<sigma>) (substTerm.seqSubst N \<sigma>)"]
      by simp
  next
    case pTau
    thus ?case using  \<open>wellFormedSubst \<sigma>\<close> tauLaw3PsiCong[where \<alpha>="pTau"]
      by simp
  qed
qed

end

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Sep_Tactic_Examples
imports
  "../sep-capDL/Sep_Tactic_Helper"
  KHeap_DP
begin

(* Thesis : Automated Tactics for Seperation Logic *)

(* seperation logic *)

(* after we show that addition and disjointedness on our heap obeys certain laws, we get a seperation algebra *)

(* connectives *)

term "P \<and>* Q"

term "P \<longrightarrow>* Q"

lemma frame_rule:
  "\<And>R. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. Q\<rbrace> \<Longrightarrow> \<lbrace>P \<and>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace>"
  oops

thm swap_cap_wp[no_vars]

lemma
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  apply (simp add: move_cap_def)
  apply (wp swap_parents_wp set_cap_wp) (* set_cap doesn't apply *)
thm set_cap_wp[no_vars]
   apply (rule hoare_strengthen_post)
    apply (wp set_cap_wp)
   apply (clarsimp simp: sep_conj_ac )
oops

(* tactics we had pre-thesis *)

lemma "(A \<and>* B \<and>* C \<and>* D) s  \<Longrightarrow>  (A \<and>* B \<and>* C \<and>* D) s"
  apply (sep_select 4)
  apply (sep_select_asm 3)
  apply (sep_select 2)
  apply (sep_cancel)
  apply (sep_cancel)
  apply (sep_cancel)
done

(* forward reasoning *)

lemma example_drule:
  "(ptr \<mapsto>o obj) s
  \<Longrightarrow> (ptr \<mapsto>S obj \<and>* ptr \<mapsto>f obj) s"
  by (metis sep_conj_commute sep_map_o_decomp)

lemma sep_drule_example:
  "(ptr \<mapsto>o obj \<and>* A \<and>* B ) s
  \<Longrightarrow> (A \<and>* B \<and>* ptr \<mapsto>f obj \<and>* ptr \<mapsto>S obj) s"
  apply (sep_drule  example_drule)
  apply (sep_solve)
done

(* backwards reasoning *)

lemma example_rule:
  "(ptr \<mapsto>f obj \<and>* ptr \<mapsto>S obj) s
  \<Longrightarrow> (ptr \<mapsto>o obj) s"
  by (metis sep_map_o_decomp)

lemma sep_rule_example: "(ptr \<mapsto>f obj \<and>* A \<and>* B \<and>* ptr \<mapsto>S obj ) s \<Longrightarrow> (ptr \<mapsto>o obj \<and>* A \<and>* B) s"
  apply (sep_rule example_rule)
  apply (sep_solve)
done

(* the state of proving before new stuff *)

lemma swap_cap_wp_old:
  "\<lbrace><dest \<mapsto>c cap \<and>*  src \<mapsto>c cap' \<and>* R>\<rbrace>
    swap_cap cap' src cap dest
   \<lbrace>\<lambda>_.<dest \<mapsto>c cap' \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp add: swap_cap_def)
  apply (wp swap_parents_wp set_cap_wp)
  apply (rule hoare_chain)
    apply (wp set_cap_wp)
    apply (sep_solve)+
done

lemma move_cap_wp_old:
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  including no_pre
  apply (simp add: move_cap_def)
  apply (wp swap_parents_wp)
   apply (rule hoare_strengthen_post)
    apply (wp set_cap_wp)
   apply (sep_select 2)
   apply (sep_solve)
  apply (rule hoare_chain)
    apply (wp insert_cap_orphan_wp)
   apply (sep_solve)
  apply (sep_solve)
done

lemma invoke_cnode_rotate2_wp_old:
  "(dest) \<noteq> (rnd) \<Longrightarrow>
  \<lbrace><dest \<mapsto>c cap1 \<and>* src \<mapsto>c cap2 \<and>*
    rnd \<mapsto>c - \<and>* R>\<rbrace>
     invoke_cnode (RotateCall cap1 cap2 dest src rnd)
  \<lbrace>\<lambda>_. <dest \<mapsto>c NullCap \<and>* src \<mapsto>c cap1 \<and>*
    rnd \<mapsto>c cap2 \<and>* R>\<rbrace>"
  including no_pre
  apply (clarsimp simp: invoke_cnode_def)
  apply (wp)
   apply (rule hoare_strengthen_post)
    apply (rule move_cap_wp)
   apply (sep_solve )
  apply (rule hoare_chain)
    apply (rule move_cap_wp)
   apply (sep_select_asm 2, sep_select_asm 3)
   apply (sep_solve)
  apply (sep_solve)
done

(* new sep_select/asm *)

lemma "(A \<and>* B \<and>* C \<and>* D) s  \<Longrightarrow>  (A \<and>* B \<and>* C \<and>* D) s"
  apply (sep_select 4 3 2 1)
  apply (sep_select_asm 4 3 2 1)
  apply (sep_select_asm 2 4)
oops

(* sep_select_pre/post *)

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

(* can be made to work for arbitrary monads *)

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>, \<lbrace>E\<rbrace>"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>, -"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

lemma "(P \<and>* (P \<longrightarrow>* Q)) s \<Longrightarrow> Q s"
  apply (sep_mp, assumption )
  done

lemma "P s \<Longrightarrow> (Q \<longrightarrow>* (P \<and>* Q)) s"
  apply (erule sep_curry[rotated])
  apply (assumption)
  done

thm sep_mp[no_vars] sep_curry[rotated, no_vars]

(* wp tactic testing *)

(* sep_wand approach *)

lemma move_cap_wp2:
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  apply (simp add: move_cap_def)
  apply (sep_wp set_cap_wp swap_parents_wp insert_cap_orphan_wp)+
  apply (sep_solve)
  done

lemma swap_cap_wp2:
  "\<lbrace><dest \<mapsto>c cap \<and>*  src \<mapsto>c cap' \<and>* R>\<rbrace>
    swap_cap cap' src cap dest
   \<lbrace>\<lambda>_.<dest \<mapsto>c cap' \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp: swap_cap_def)
  apply (sep_wp swap_parents_wp set_cap_wp)+
  apply (sep_solve)
  done

lemma invoke_cnode_rotate2_wp:
  "(dest) \<noteq> (rnd) \<Longrightarrow>
  \<lbrace><dest \<mapsto>c cap1 \<and>* src \<mapsto>c cap2 \<and>*
    rnd \<mapsto>c - \<and>* R>\<rbrace>
     invoke_cnode (RotateCall cap1 cap2 dest src rnd)
  \<lbrace>\<lambda>_. <dest \<mapsto>c NullCap \<and>* src \<mapsto>c cap1 \<and>*
    rnd \<mapsto>c cap2 \<and>* R>\<rbrace>"
  apply (clarsimp simp: invoke_cnode_def)
  apply (sep_wp move_cap_wp)+
  apply (sep_solve)
  done

(* sep_drule/rule *)

lemma sep_rule_example2:
 "\<lbrakk>(ptr \<mapsto>o obj) s; finite (dom (object_slots obj))\<rbrakk> \<Longrightarrow>
   (ptr \<mapsto>E obj \<and>* ptr \<mapsto>f obj \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj)) s"
  apply (subst (asm) sep_map_o_decomp)
  apply (subst (asm) sep_map_S_decomp, simp+)
  apply sep_solve
  done

lemma sep_drule_example2:
 "\<lbrakk>(ptr \<mapsto>f obj \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj) \<and>* ptr \<mapsto>E obj) s;
   finite (dom (object_slots obj))\<rbrakk>
    \<Longrightarrow>
  (ptr \<mapsto>o obj) s"
  by (metis sep_map_S_decomp sep_map_o_decomp)

(* sep_curry *)

lemma sep_drule_example_lemma:
  "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>f obj \<and>* A \<and>* B \<and>*
    (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj) \<and>* D \<and>* G \<and>* E \<and>* F \<and>* ptr \<mapsto>E obj ) s;
    finite (dom (object_slots obj))\<rbrakk>
  \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>* ptr \<mapsto>o obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B) s"
  apply (sep_drule sep_drule_example2)
   apply assumption
  apply sep_solve
  done

(* sep_back *)

lemma sep_rule_example_lemma:
 "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>o obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F ) s;
  finite (dom (object_slots obj))\<rbrakk> \<Longrightarrow>
  (D \<and>* G \<and>* E \<and>* F  \<and>* ptr \<mapsto>f obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>E obj \<and>*
   A \<and>* B \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj)) s"
  apply (sep_rule sep_rule_example2)
   apply sep_solve
  apply assumption
  done

(* works even with multiple conjuncts in assumptions and conclusions *)
lemma sep_rule_double_conjunct_example:
  "\<lbrakk>((obj_id, slot) \<mapsto>c cap \<and>* obj_id \<mapsto>f obj) s;
    object_slots obj slot = Some cap\<rbrakk>
  \<Longrightarrow> ((obj_id, slot) \<mapsto>s obj \<and>* obj_id \<mapsto>f obj) s"
  apply (sep_drule sep_map_s_sep_map_c)
   apply assumption
  apply (sep_cancel)+
  done

lemma sep_rule_double_conjunct_lemma:
  "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* obj_id \<mapsto>f obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F \<and>* (obj_id, slot) \<mapsto>c cap ) s;
    object_slots obj slot = Some cap\<rbrakk> \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>*(obj_id, slot) \<mapsto>s obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B \<and>*  obj_id \<mapsto>f obj) s"
  apply (sep_rule sep_rule_double_conjunct_example)
   apply sep_solve
  apply assumption
  done

(* side-conditions*)

lemma sep_drule_side_condition_lemma:
 "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* obj_id \<mapsto>f obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F \<and>* (obj_id, slot) \<mapsto>c cap ) s;
    object_slots obj slot = Some cap\<rbrakk> \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>*(obj_id, slot) \<mapsto>s obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B \<and>*  obj_id \<mapsto>f obj) s"
  apply (sep_drule sep_rule_double_conjunct_example, assumption)
  apply (sep_solve)
  done

schematic_goal "(P \<and>* ?A) s \<Longrightarrow> (A \<and>* B \<and>* P) s"
  apply (sep_solve)
  done

end


(*  Title:      SSA_CFG_code.thy
    Author:     Denis Lohner, Sebastian Ullrich
*)

theory SSA_CFG_code imports
  SSA_CFG
  Mapping_Exts
  "~~/src/HOL/Library/Product_Lexorder"
begin

definition Union_of :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a set \<Rightarrow> 'b set"
  where "Union_of f A \<equiv> \<Union>(f ` A)"

lemma Union_of_alt_def: "Union_of f A = (\<Union>x \<in> A. f x)"
  unfolding Union_of_def by simp

type_synonym ('node, 'val) phis_code = "('node \<times> 'val, 'val list) mapping"

context CFG_base begin
  definition addN :: "'node \<Rightarrow> ('var, 'node set) mapping \<Rightarrow> ('var, 'node set) mapping"
    where "addN n \<equiv> fold (\<lambda>v. Mapping.map_default v {} (insert n)) (sorted_list_of_set (uses n))"
  definition "addN' n = fold (\<lambda>v m. m(v \<mapsto> case_option {n} (insert n) (m v))) (sorted_list_of_set (uses n))"

  lemma addN_transfer [transfer_rule]:
    "rel_fun op = (rel_fun (pcr_mapping op = op =) (pcr_mapping op = op =)) addN' addN"
    unfolding addN_def [abs_def] addN'_def [abs_def]
      Mapping.map_default_def [abs_def] Mapping.default_def
  apply (auto simp: mapping.pcr_cr_eq rel_fun_def cr_mapping_def)
  apply transfer
  apply (rule fold_cong)
    apply simp
   apply simp
  apply (intro ext)
  by auto

  definition "useNodes_of = fold (addN) \<alpha>n Mapping.empty"
  lemmas useNodes_of_code = useNodes_of_def [unfolded addN_def [abs_def]]
  declare useNodes_of_code [code]

  lemma lookup_useNodes_of':
    assumes [simp]: "\<And>n. finite (uses n)"
    shows "Mapping.lookup (useNodes_of) v =
    (if (\<exists>n \<in> set \<alpha>n. v \<in> uses n) then Some {n \<in> set \<alpha>n. v \<in> uses n} else None)"
  proof -
    { fix m n xs v
      have "Mapping.lookup (fold (\<lambda>v. Mapping.map_default (v::'var) {} (insert (n::'node))) xs m) v=
        (case Mapping.lookup m v of None \<Rightarrow> (if v \<in> set xs then Some {n} else None)
          | Some N \<Rightarrow> (if v \<in> set xs then Some (insert n N) else Some N))"
      by (induction xs arbitrary: m) (auto simp: Mapping_lookup_map_default split: option.splits)
    }
    note addN_conv = this [of n "sorted_list_of_set (uses n)" for n, folded addN_def, simplified]
    { fix xs m v
      have "Mapping.lookup (fold (addN) xs m) v = (case Mapping.lookup m v of None \<Rightarrow> if (\<exists>n\<in>set xs. v \<in> uses n) then Some {n\<in>set xs. v \<in> uses n} else None
        | Some N \<Rightarrow> Some ({n\<in>set xs. v \<in> uses n} \<union> N))"
      by (induction xs arbitrary: m) (auto split: option.splits simp: addN_conv)
    }
    note this [of "\<alpha>n" Mapping.empty, simp]
    show ?thesis unfolding useNodes_of_def
      by (auto split: option.splits simp: lookup_empty)
  qed
end

context CFG begin
  lift_definition useNodes_of' :: " ('var, 'node set) mapping"
  is "\<lambda>v. if (\<exists>n \<in> set \<alpha>n. v \<in> uses n) then Some {n \<in> set \<alpha>n. v \<in> uses n} else None" .

  lemma useNodes_of': "useNodes_of' = useNodes_of"
  proof-
    { fix m n xs
      have "fold (\<lambda>v m. m(v::'var \<mapsto> case m v of None \<Rightarrow> {n::'node} | Some x \<Rightarrow> insert n x)) xs m =
        (\<lambda>v. case m v of None \<Rightarrow> (if v \<in> set xs then Some {n} else None)
          | Some N \<Rightarrow> (if v \<in> set xs then Some (insert n N) else Some N))"
      by (induction xs arbitrary: m)(auto split: option.splits)
    }
    note addN'_conv = this [of n "sorted_list_of_set (uses n)" for n, folded addN'_def, simplified]
    { fix xs m
      have "fold (addN') xs m = (\<lambda>v. case m v of None \<Rightarrow> if (\<exists>n\<in>set xs. v \<in> uses n) then Some {n\<in>set xs. v \<in> uses n} else None
        | Some N \<Rightarrow> Some ({n\<in>set xs. v \<in> uses n} \<union> N))"
      by (induction xs arbitrary: m) (auto 4 4 split: option.splits if_splits simp: addN'_conv intro!: ext)
    }
    note this [of "\<alpha>n" Map.empty, simp]
    show "useNodes_of' = useNodes_of"
    unfolding mmap_def useNodes_of_def
    by (transfer fixing:) auto
  qed

  declare useNodes_of'.transfer [unfolded useNodes_of', transfer_rule]

end

context CFG_SSA_base begin
  definition phis_addN
  where "phis_addN n = fold (\<lambda>v. Mapping.map_default v {} (insert n)) (case_option [] id (phis n))"

  definition phidefNodes where [code]:
    "phidefNodes = fold (\<lambda>(n,v). Mapping.update v n) (sorted_list_of_set (dom phis)) Mapping.empty"

  lemma keys_phidefNodes:
    assumes "finite (dom phis)"
    shows "Mapping.keys (phidefNodes) = snd ` dom phis"
  proof -
    { fix xs m x
      have "fold (\<lambda>(a,b) m. m(b \<mapsto> a)) (xs::('node \<times> 'val) list) m x = (if x \<in> snd ` set xs then (Some \<circ> fst) (last [(b,a)\<leftarrow>xs. a = x]) else m x)"
      by (induction xs arbitrary: m) (auto split: if_splits simp: filter_empty_conv intro: rev_image_eqI)
    }
    from this [of "sorted_list_of_set (dom phis)" Map.empty] assms
    show ?thesis
    unfolding phidefNodes_def keys_dom_lookup
    by (transfer fixing: phis) (auto simp: dom_def intro: rev_image_eqI)
  qed

  definition phiNodes_of :: " ('val, ('node \<times> 'val) set) mapping"
  where "phiNodes_of = fold (phis_addN) (sorted_list_of_set (dom phis)) Mapping.empty"

  lemma lookup_phiNodes_of:
  assumes [simp]: "finite (dom phis)"
  shows "Mapping.lookup (phiNodes_of) v =
    (if (\<exists>n \<in> dom phis. v \<in> set (the (phis n))) then Some {n \<in> dom phis. v \<in> set (the (phis n))} else None)"
  proof -
  {
    fix m n xs v
    have "Mapping.lookup (fold (\<lambda>v. Mapping.map_default v {} (insert (n::'node \<times> 'val))) xs (m::('val, ('node \<times> 'val) set) mapping)) v =
      (case Mapping.lookup m v of None \<Rightarrow> (if v \<in> set xs then Some {n} else None)
        | Some N \<Rightarrow> (if v \<in> set xs then Some (insert n N) else Some N))"
    by (induction xs arbitrary: m) (auto simp: Mapping_lookup_map_default split: option.splits)
  }
  note phis_addN_conv = this [of n "case_option [] id (phis n)" for n, folded phis_addN_def]
  {
    fix xs m v
    have "Mapping.lookup (fold (phis_addN) xs m) v =
      (case Mapping.lookup m v of None \<Rightarrow> if (\<exists>n \<in> set xs. v \<in> set (case_option [] id (phis n))) then Some {n \<in> set xs. v \<in> set (case_option [] id (phis n))} else None
        | Some N \<Rightarrow> Some ({n \<in> set xs. v \<in> set (case_option [] id (phis n))} \<union> N))"
    by (induction xs arbitrary: m) (auto simp: phis_addN_conv split: option.splits if_splits)+
  }
  note this [of "sorted_list_of_set (dom phis)", simp]
  show ?thesis
    unfolding phiNodes_of_def
  by (force split: option.splits simp: lookup_empty)
  qed

  lemmas phiNodes_of_code = phiNodes_of_def [unfolded phis_addN_def [abs_def]]
  declare phiNodes_of_code [code]

interpretation lifting_syntax .
lemma phis_transfer [transfer_rule]: "pcr_mapping op = op = phis (Mapping.Mapping phis)"
  by (auto simp: mapping.pcr_cr_eq rel_fun_def cr_mapping_def Mapping.Mapping_inverse)

end

context CFG_SSA begin
  declare lookup_phiNodes_of [OF phis_finite, simp]
  declare keys_phidefNodes [OF phis_finite, simp]
end

locale CFG_SSA_ext_base = CFG_SSA_base \<alpha>n predecessors Entry "defs" "uses" phis
  for \<alpha>n :: "'node::linorder list"
    and predecessors :: "'node \<Rightarrow> 'node list"
    and Entry :: "'node"
    and "defs" :: "'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'node \<Rightarrow> 'val set"
    and phis :: " ('node, 'val) phis"
begin
  abbreviation "cache f \<equiv> Mapping.tabulate \<alpha>n f"

  lemma lookup_cache[simp]: "n \<in> set \<alpha>n \<Longrightarrow> Mapping.lookup (cache f) n = Some (f n)"
  by transfer (auto simp: Map.map_of_map_restrict)

  lemma lookup_cacheD [dest]: "Mapping.lookup (cache f) x = Some y \<Longrightarrow> y = f x"
  by transfer (auto simp: Map.map_of_map_restrict restrict_map_def split: if_splits)

  lemma lookup_cache_usesD: "Mapping.lookup (cache uses) n = Some vs \<Longrightarrow> vs = uses n"
  by blast
end

definition[simp]: "usesOf m n \<equiv> case_option {} id (Mapping.lookup m n)"

locale CFG_SSA_ext = CFG_SSA_ext_base  \<alpha>n predecessors Entry "defs" "uses" phis
  + CFG_SSA \<alpha>n predecessors Entry "defs" "uses" phis
  for \<alpha>n :: "'node::linorder list"
    and predecessors :: "'node \<Rightarrow> 'node list"
    and Entry :: "'node"
    and "defs" :: "'node \<Rightarrow> 'val::linorder set"
    and "uses" :: "'node \<Rightarrow> 'val set"
    and phis :: " ('node, 'val) phis"
begin
  lemma usesOf_cache[abs_def, simp]: "usesOf (cache uses) n = uses n"
  by (auto simp: uses_in_\<alpha>n dest: lookup_cache_usesD split: option.split)
end

locale CFG_SSA_base_code = CFG_SSA_ext_base \<alpha>n predecessors Entry "defs" "usesOf uses" "Mapping.lookup phis"
  for \<alpha>n :: "'node::linorder list"
    and predecessors :: "'node \<Rightarrow> 'node list"
    and Entry :: "'node"
    and "defs" :: "'node \<Rightarrow> 'val::linorder set"
    and "uses" :: " ('node, 'val set) mapping"
    and phis :: " ('node, 'val) phis_code"
begin
  declare phis_transfer [simplified, transfer_rule]

  lemma phiDefs_code [code]:
  "phiDefs n = snd ` Set.filter (\<lambda>(n',v). n' = n) (Mapping.keys phis)"
    unfolding phiDefs_def
    by transfer (auto 4 3 intro: rev_image_eqI simp: Set.filter_def)

  lemmas phiUses_code [code] = phiUses_def [folded Union_of_alt_def]
  declare allUses_def [code]
  lemmas allVars_code [code] = allVars_def [folded Union_of_alt_def]
end

locale CFG_SSA_code = CFG_SSA_base_code  \<alpha>n predecessors Entry "defs" "uses" phis
  + CFG_SSA_ext \<alpha>n predecessors Entry "defs" "usesOf uses" "Mapping.lookup phis"
  for \<alpha>n :: "'node::linorder list"
    and predecessors :: "'node \<Rightarrow> 'node list"
    and Entry :: "'node"
    and "defs" :: "'node \<Rightarrow> 'val::linorder set"
    and "uses" :: " ('node, 'val set) mapping"
    and phis :: " ('node, 'val) phis_code"

definition "the_trivial v vs = (case (foldl (\<lambda>(good,v') w. if w = v then (good,v')
      else case v' of Some v' \<Rightarrow> (good \<and> w = v', Some v')
        | None \<Rightarrow> (good, Some w))
    (True, None) vs)
  of (False, _) \<Rightarrow> None | (True,v) \<Rightarrow> v)"

lemma the_trivial_Nil [simp]: "the_trivial x [] = None"
  unfolding the_trivial_def by simp

lemma the_trivialI:
  assumes "set vs \<subseteq> {v, v'}"
    and "v' \<noteq> v"
  shows "the_trivial v vs = (if set vs \<subseteq> {v} then None else Some v')"
proof -
  { fix vx
    have "\<lbrakk> set vs \<subseteq> {v, v'}; v' \<noteq> v; vx \<in> {None, Some v'} \<rbrakk>
    \<Longrightarrow> (case foldl (\<lambda>(good, v') w.
                    if w = v then (good, v')
                    else case v' of None \<Rightarrow> (good, Some w) | Some v' \<Rightarrow> (good \<and> w = v', Some v'))
           (True, vx) vs of
     (True, x) \<Rightarrow> x | (False, x) \<Rightarrow> None) = (if set vs \<subseteq> {v} then vx else Some v')"
    by (induction vs arbitrary: vx; case_tac vx; auto)
  }
  with assms show ?thesis unfolding the_trivial_def by simp
qed

lemma the_trivial_conv:
  shows "the_trivial v vs = (if \<exists>v' \<in> set vs. v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v} then Some (THE v'. v' \<in> set vs \<and> v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v}) else None)"
proof -
  { fix b a vs
    have "a \<noteq> v
       \<Longrightarrow> foldl (\<lambda>(good, v') w.
                     if w = v then (good, v')
                     else case v' of None \<Rightarrow> (good, Some w) | Some v' \<Rightarrow> (good \<and> w = v', Some v'))
            (b, Some a) vs =
           (b \<and> set vs \<subseteq> {v, a}, Some a)"
     by (induction vs arbitrary: b; clarsimp)
  }
  note this[simp]
  { fix b vx
    have "\<lbrakk> vx \<in> insert None (Some ` set vs); case_option True (\<lambda>vx. vx \<noteq> v) vx \<rbrakk>
    \<Longrightarrow> foldl (\<lambda>(good, v') w.
                    if w = v then (good, v')
                    else case v' of None \<Rightarrow> (good, Some w) | Some v' \<Rightarrow> (good \<and> w = v', Some v'))
        (b, vx) vs = (b \<and> (case vx of Some w \<Rightarrow> set vs \<subseteq> {v, w} | None \<Rightarrow> \<exists>w. set vs \<subseteq> {v, w}),
        (case vx of Some w \<Rightarrow> Some w | None \<Rightarrow> if (\<exists>v'\<in>set vs. v' \<noteq> v) then Some (hd (filter (\<lambda>v'. v' \<noteq> v) vs)) else None))"
    by (induction vs arbitrary: b vx; auto)
  }
  hence "the_trivial v vs = (if \<exists>v' \<in> set vs. v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v} then Some (hd (filter (\<lambda>v'. v' \<noteq> v) vs)) else None)"
    unfolding the_trivial_def by (auto split: bool.splits)
  thus ?thesis
  apply (auto split: if_splits)
  apply (rule the_equality [THEN sym])
   by (thin_tac "P" for P, (induction vs; auto))+
qed

lemma the_trivial_SomeE:
  assumes "the_trivial v vs = Some v'"
  obtains "v \<noteq> v'" and "set vs = {v'}" | "v \<noteq> v'" and "set vs = {v,v'}"
using assms
apply atomize_elim
apply (subst(asm) the_trivial_conv)
apply (split if_splits; simp)
by (subgoal_tac "(THE v'. v' \<in> set vs \<and> v' \<noteq> v \<and> set vs - {v'} \<subseteq> {v}) = hd (filter (\<lambda>v'. v' \<noteq> v) vs)")
  (fastforce simp: set_double_filter_hd set_single_hd set_minus_one)+

locale CFG_SSA_wf_base_code = CFG_SSA_base_code \<alpha>n predecessors Entry "defs" "uses" phis
  + CFG_SSA_wf_base \<alpha>n predecessors Entry "defs" "usesOf uses" "Mapping.lookup phis"
  for \<alpha>n :: "'node::linorder list"
    and predecessors :: "'node \<Rightarrow> 'node list"
    and Entry :: "'node"
    and "defs" :: "'node \<Rightarrow> 'val::linorder set"
    and "uses" :: " ('node, 'val set) mapping"
    and phis :: " ('node, 'val) phis_code"
begin
  definition [code]:
    "trivial_code (v::'val) vs = (the_trivial v vs \<noteq> None)"
  definition[code]: "trivial_phis = Set.filter (\<lambda>(n,v). trivial_code v (the (Mapping.lookup phis (n,v)))) (Mapping.keys phis)"
  definition [code]: "redundant_code = (trivial_phis \<noteq> {})"
end

locale CFG_SSA_wf_code = CFG_SSA_code \<alpha>n predecessors Entry "defs" "uses" phis
  + CFG_SSA_wf_base_code \<alpha>n predecessors Entry "defs" "uses" phis
  + CFG_SSA_wf \<alpha>n predecessors Entry "defs" "usesOf uses" "Mapping.lookup phis"
  for \<alpha>n :: "'node::linorder list"
    and predecessors :: "'node \<Rightarrow> 'node list"
    and Entry :: "'node"
    and "defs" :: "'node \<Rightarrow> 'val::linorder set"
    and "uses" :: " ('node, 'val set) mapping"
    and phis :: " ('node, 'val) phis_code"
begin
  lemma trivial_code:
    "phi v = Some vs \<Longrightarrow> trivial v = trivial_code v vs"
  unfolding trivial_def trivial_code_def
  apply (auto split: option.splits simp: isTrivialPhi_def)
    apply (clarsimp simp: the_trivial_conv split: if_splits)
   apply (clarsimp simp: the_trivial_conv split: if_splits)
  apply (erule the_trivial_SomeE)
   apply simp
   apply (rule phiArg_in_allVars; auto simp: phiArg_def)
  apply (rename_tac v')
  apply (rule_tac x=v' in bexI)
   apply simp
  apply (rule phiArg_in_allVars; auto simp: phiArg_def)
  done

  lemma trivial_phis:
    "trivial_phis = {(n,v). Mapping.lookup phis (n,v) \<noteq> None \<and> trivial v}"
  unfolding trivial_phis_def Set.filter_def
  apply (auto simp add: phi_def keys_dom_lookup)
   apply (subst trivial_code)
    apply (auto simp: image_def trivial_in_allVars phis_phi)
  apply (frule trivial_phi)
  apply (auto simp add: trivial_code phi_def[symmetric] phis_phi)
  done

  lemma redundant_code:
    "redundant = redundant_code"
  unfolding redundant_def redundant_code_def trivial_phis[of]
  apply (auto simp: image_def trivial_in_allVars)
  apply (frule trivial_phi)
  apply (auto simp: phi_def)
  done

  lemma trivial_code_mapI:
  "\<lbrakk> trivial_code v vs; f ` (set vs - {v}) \<noteq> {v} ; f v = v \<rbrakk> \<Longrightarrow> trivial_code v (map f vs)"
  unfolding trivial_code_def the_trivial_conv
    by (auto split: if_splits)

  lemma trivial_code_map_conv:
    "f v = v \<Longrightarrow> trivial_code v (map f vs) \<longleftrightarrow> (\<exists>v'\<in>set vs. f v' \<noteq> v \<and> (f ` set vs) - {f v'} \<subseteq> {v})"
    unfolding trivial_code_def the_trivial_conv
    by auto

end

locale CFG_SSA_Transformed_code = ssa: CFG_SSA_wf_code \<alpha>n predecessors Entry "defs" "uses" phis
   +
   CFG_SSA_Transformed \<alpha>n predecessors Entry oldDefs oldUses "defs" "usesOf uses" "Mapping.lookup phis" var
for
  \<alpha>n :: "'node::linorder list" and
  predecessors :: "'node \<Rightarrow> 'node list" and
  Entry::"'node" and
  oldDefs :: "'node \<Rightarrow> 'var::linorder set" and
  oldUses :: "'node \<Rightarrow> 'var set" and
  "defs" :: "'node \<Rightarrow> 'val::linorder set" and
  "uses" :: " ('node, 'val set) mapping" and
  phis :: " ('node, 'val) phis_code" and
  var :: "'val \<Rightarrow> 'var"
+
assumes dom_uses_in_graph: "Mapping.keys uses \<subseteq> set \<alpha>n"

end


(* @TAG(OTHER_LGPL) *)

(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      XVcgEx.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Examples for Parallel Assignments"

theory XVcgEx
imports "../XVcg"

begin

record "globals" =
  "G_'"::"nat"
  "H_'"::"nat"

record 'g vars = "'g state" +
  A_' :: nat
  B_' :: nat
  C_' :: nat
  I_' :: nat
  M_' :: nat
  N_' :: nat
  R_' :: nat
  S_' :: nat
  Arr_' :: "nat list"
  Abr_':: string

term "BASIC
         \<acute>A :== x,
         \<acute>B :== y
      END"

term "BASIC
         \<acute>G :== \<acute>H,
         \<acute>H :== \<acute>G
      END"

term "BASIC
        LET (x,y) = (\<acute>A,b);
            z = \<acute>B
        IN \<acute>A :== x,
           \<acute>G :== \<acute>A + y + z
      END"

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>A = 0\<rbrace>
      \<lbrace>\<acute>A < 0\<rbrace> \<longmapsto> BASIC
       LET (a,b,c) = foo \<acute>A
       IN
            \<acute>A :== a,
            \<acute>B :== b,
            \<acute>C :== c
      END
      \<lbrace>\<acute>A = x \<and> \<acute>B = y \<and> \<acute>C = c\<rbrace>"
apply vcg
oops

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>A = 0\<rbrace>
      \<lbrace>\<acute>A < 0\<rbrace> \<longmapsto> BASIC
       LET (a,b,c) = foo \<acute>A
       IN
            \<acute>A :== a,
            \<acute>G :== b + \<acute>B,
            \<acute>H :== c
      END
      \<lbrace>\<acute>A = x \<and> \<acute>G = y \<and> \<acute>H = c\<rbrace>"
apply vcg
oops

definition foo:: "nat \<Rightarrow> (nat \<times> nat \<times> nat)"
  where "foo n = (n,n+1,n+2)"

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>A = 0\<rbrace>
      \<lbrace>\<acute>A < 0\<rbrace> \<longmapsto> BASIC
       LET (a,b,c) = foo \<acute>A
       IN
            \<acute>A :== a,
            \<acute>G :== b + \<acute>B,
            \<acute>H :== c
      END
      \<lbrace>\<acute>A = x \<and> \<acute>G = y \<and> \<acute>H = c\<rbrace>"
apply (vcg add: foo_def snd_conv fst_conv)
oops

end


(*  Title:      Monad_Normalisation_Test.thy
    Author:     Manuel Eberl, TU München
    Author:     Andreas Lochbihler, ETH Zurich
    Author:     Joshua Schneider, ETH Zurich
*)

theory Monad_Normalisation_Test
imports Monad_Normalisation
begin

section \<open>Tests and examples\<close>

context includes monad_normalisation
begin

lemma
  assumes "f = id"
  shows
    "do {x \<leftarrow> B; z \<leftarrow> C x; d \<leftarrow> E z x; a \<leftarrow> D z x; y \<leftarrow> A; return_pmf (x,y)} =
     do {y \<leftarrow> A; x \<leftarrow> B; z \<leftarrow> C x; a \<leftarrow> D z x; d \<leftarrow> E z x; return_pmf (f (x,y))}"
apply (simp)
apply (simp add: assms)
done

lemma "(do {a \<leftarrow> E; b \<leftarrow> E; w \<leftarrow> B b a; z \<leftarrow> B a b; return_pmf (w,z)}) =
       (do {a \<leftarrow> E; b \<leftarrow> E; z \<leftarrow> B a b; w \<leftarrow> B b a; return_pmf (w,z)})"
by (simp)

lemma "(do {a \<leftarrow> E; b \<leftarrow> E; w \<leftarrow> B b a; z \<leftarrow> B a b; return_pmf (w,z)}) =
       (do {a \<leftarrow> E; b \<leftarrow> E; z \<leftarrow> B a b; w \<leftarrow> B b a; return_pmf (w,z)})"
by (simp)

lemma "do {y \<leftarrow> A; x \<leftarrow> A; z \<leftarrow> B x y y; w \<leftarrow> B x x y; Some (x,y)} =
       do {x \<leftarrow> A; y \<leftarrow> A; z \<leftarrow> B x x y; w \<leftarrow> B x y y; Some (x,y)}"
by (simp)

lemma "do {y \<leftarrow> A; x \<leftarrow> A; z \<leftarrow> B x y y; w \<leftarrow> B x x y; {x,y}} =
       do {x \<leftarrow> A; y \<leftarrow> A; z \<leftarrow> B x x y; w \<leftarrow> B x y y; {x,y}}"
by (simp)

lemma "do {y \<leftarrow> A; x \<leftarrow> A; z \<leftarrow> B x y y; w \<leftarrow> B x x y; return_pmf (x,y)} =
       do {x \<leftarrow> A; y \<leftarrow> A; z \<leftarrow> B x x y; w \<leftarrow> B x y y; return_pmf (x,y)}"
by (simp)

lemma "do {x \<leftarrow> A 0; y \<leftarrow> A x; w \<leftarrow> B y y; z \<leftarrow> B x y; a \<leftarrow> C; Predicate.single (a,a)} =
       do {x \<leftarrow> A 0; y \<leftarrow> A x; z \<leftarrow> B x y; w \<leftarrow> B y y; a \<leftarrow> C; Predicate.single (a,a)}"
by (simp)

lemma "do {x \<leftarrow> A 0; y \<leftarrow> A x; z \<leftarrow> B x y; w \<leftarrow> B y y; a \<leftarrow> C; return_pmf (a,a)} =
       do {x \<leftarrow> A 0; y \<leftarrow> A x; z \<leftarrow> B y y; w \<leftarrow> B x y; a \<leftarrow> C; return_pmf (a,a)}"
by (simp)

lemma "do {x \<leftarrow> B; z \<leftarrow> C x; d \<leftarrow> E z x; a \<leftarrow> D z x; y \<leftarrow> A; return_pmf (x,y)} =
       do {y \<leftarrow> A; x \<leftarrow> B; z \<leftarrow> C x; a \<leftarrow> D z x; d \<leftarrow> E z x; return_pmf (x,y)}"
by (simp)

no_adhoc_overloading Monad_Syntax.bind bind_pmf

context
  fixes \1 :: "'a \<Rightarrow> (('a \<times> 'a) \<times> 'b) spmf"
  and \2 :: "'a \<times> 'a \<Rightarrow> 'b \<Rightarrow> bool spmf"
  and sample_uniform :: "nat \<Rightarrow> nat spmf"
  and order :: "'a \<Rightarrow> nat"
begin

lemma
  "do {
      x \<leftarrow> sample_uniform (order \<G>);
      y \<leftarrow> sample_uniform (order \<G>);
      z \<leftarrow> sample_uniform (order \<G>);
      b \<leftarrow> coin_spmf;
      ((msg1, msg2), \<sigma>) \<leftarrow> \1 (f x);
      _ :: unit \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
      guess \<leftarrow> \2 (f y, xor (f z) (if b then msg1 else msg2)) \<sigma>;
      return_spmf (guess \<longleftrightarrow> b)
    } = do {
      x \<leftarrow> sample_uniform (order \<G>);
      y \<leftarrow> sample_uniform (order \<G>);
      ((msg1, msg2), \<sigma>) \<leftarrow> \1 (f x);
      _ :: unit \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
      b \<leftarrow> coin_spmf;
      x \<leftarrow> sample_uniform (order \<G>);
      guess \<leftarrow> \2 (f y, xor (f x) (if b then msg1 else msg2)) \<sigma>;
      return_spmf (guess \<longleftrightarrow> b)
    }"
by (simp add: split_def)

lemma
  "do {
      x \<leftarrow> sample_uniform (order \<G>);
      xa \<leftarrow> sample_uniform (order \<G>);
      x \<leftarrow> \1 (f x);
      case x of
      (x, xb) \<Rightarrow>
        (case x of
         (msg1, msg2) \<Rightarrow>
           \<lambda>\<sigma>. do {
                a \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
                x \<leftarrow> coin_spmf;
                xaa \<leftarrow> map_spmf f (sample_uniform (order \<G>));
                guess \<leftarrow> \2 (f xa, xaa) \<sigma>;
                return_spmf (guess \<longleftrightarrow> x)
              })
         xb
    } = do {
      x \<leftarrow> sample_uniform (order \<G>);
      xa \<leftarrow> sample_uniform (order \<G>);
      x \<leftarrow> \1 (f x);
      case x of
      (x, xb) \<Rightarrow>
        (case x of
         (msg1, msg2) \<Rightarrow>
           \<lambda>\<sigma>. do {
                a \<leftarrow> assert_spmf (valid_plain msg1 \<and> valid_plain msg2);
                z \<leftarrow> map_spmf f (sample_uniform (order \<G>));
                guess \<leftarrow> \2 (f xa, z) \<sigma>;
                map_spmf ((\<longleftrightarrow>) guess) coin_spmf
              })
         xb
    }"
by (simp add: map_spmf_conv_bind_spmf)

lemma elgamal_step3:
  "do {
      x \<leftarrow> sample_uniform (order \<G>);
      y \<leftarrow> sample_uniform (order \<G>);
      b \<leftarrow> coin_spmf;
      p \<leftarrow> \1 (f x);
      _ \<leftarrow> assert_spmf (valid_plain (fst (fst p)) \<and> valid_plain (snd (fst p)));
      guess \<leftarrow>
        \2 (f y, xor (f (x * y)) (if b then fst (fst p) else snd (fst p)))
         (snd p);
      return_spmf (guess \<longleftrightarrow> b)
    }  = do {
      y \<leftarrow> sample_uniform (order \<G>);
      b \<leftarrow> coin_spmf;
      p \<leftarrow> \1 (f y);
      _ \<leftarrow> assert_spmf (valid_plain (fst (fst p)) \<and> valid_plain (snd (fst p)));
      ya \<leftarrow> sample_uniform (order \<G>);
      b' \<leftarrow> \2 (f ya,
                 xor (f (y * ya)) (if b then fst (fst p) else snd (fst p)))
             (snd p);
      return_spmf (b' \<longleftrightarrow> b)
    }"
by (simp)

end

text \<open>Distributivity\<close>

lemma
  "do {
      x \<leftarrow> A :: nat spmf;
      a \<leftarrow> B;
      b \<leftarrow> B;
      if a = b then do {
        return_spmf x
      } else do {
        y \<leftarrow> C;
        return_spmf (x + y)
      }
   } = do {
      a \<leftarrow> B;
      b \<leftarrow> B;
      if b = a then A else do {
        y \<leftarrow> C;
        x \<leftarrow> A;
        return_spmf (y + x)
      }
   }"
by (simp add: add.commute cong: if_cong)

lemma
  "do {
      x \<leftarrow> A :: nat spmf;
      p \<leftarrow> do {
        a \<leftarrow> B;
        b \<leftarrow> B;
        return_spmf (a, b)
      };
      q \<leftarrow> coin_spmf;
      if q then do {
        return_spmf (x + fst p)
      } else do {
        y \<leftarrow> C;
        return_spmf (y + snd p)
      }
   } = do {
      q \<leftarrow> coin_spmf;
      if q then do {
        x \<leftarrow> A;
        a \<leftarrow> B;
        _ \<leftarrow> B;
        return_spmf (x + a)
      } else do {
        y \<leftarrow> C;
        a \<leftarrow> B;
        _ \<leftarrow> B;
        _ \<leftarrow> A;
        return_spmf (y + a)
      }
   }"
by (simp cong: if_cong)

lemma
  fixes f :: "nat \<Rightarrow> nat \<Rightarrow> nat + nat"
  shows
  "do {
      x \<leftarrow> (A::nat set);
      a \<leftarrow> B;
      b \<leftarrow> B;
      case f a b of
        Inl c \<Rightarrow> {x}
      | Inr c \<Rightarrow> do {
          y \<leftarrow> C x;
          {(x + y + c)}
        }
   } = do {
      a \<leftarrow> B;
      b \<leftarrow> B;
      case f b a of
        Inl c \<Rightarrow> A
      | Inr c \<Rightarrow> do {
          x \<leftarrow> A;
          y \<leftarrow> C x;
          {(y + c + x)}
      }
   }"
by (simp add: add.commute add.left_commute cong: sum.case_cong)

section \<open>Limits\<close>

text \<open>
  The following example shows that the combination of monad normalisation and regular ordered
  rewriting is not necessarily confluent.
\<close>

lemma "do {a \<leftarrow> A; b \<leftarrow> A; Some (a \<and> b, b)} =
       do {a \<leftarrow> A; b \<leftarrow> A; Some (a \<and> b, a)}"
apply (simp add: conj_comms)?       \<comment> \<open>no progress made\<close>
apply (rewrite option_bind_commute) \<comment> \<open>force a particular binder order\<close>
apply (simp only: conj_comms)
done

text \<open>
  The next example shows that even monad normalisation alone is not confluent because
  the term ordering prevents the reordering of \<open>f A\<close> with \<open>f B\<close>.
  But if we change \<open>A\<close> to \<open>E\<close>, then the reordering works as expected.
\<close>

lemma
  "do {a \<leftarrow> f A; b \<leftarrow> f B; c \<leftarrow> D b; d \<leftarrow> f C; F a c d} =
   do {b \<leftarrow> f B; c \<leftarrow> D b; a \<leftarrow> f A; d \<leftarrow> f C; F a c d}"
  for f :: "'b \<Rightarrow> 'a option" and D :: "'a \<Rightarrow> 'a option"
  apply(simp)? \<comment> \<open>no progress made\<close>
  apply(subst option_bind_commute, subst (2) option_bind_commute, rule refl)
  done

lemma
  "do {a \<leftarrow> f E; b \<leftarrow> f B; c \<leftarrow> D b; d \<leftarrow> f C; F a c d} =
   do {b \<leftarrow> f B; c \<leftarrow> D b; a \<leftarrow> f E; d \<leftarrow> f C; F a c d}"
  for f :: "'b \<Rightarrow> 'a option" and D :: "'a \<Rightarrow> 'a option"
  by simp

end

end