theory Test_Asm_Sem
imports
  Lense_Knowledge_Base
  "HOL-Word.Word"
  "More_Eisbach_Tools"
  Abstract_System
  "HOL-Library.Rewrite"
begin

  section \<open>Syntax\<close>

  type_synonym val64 = "64 word"
  (*type_synonym byte = "8 word"*)

  datatype rname = RAX_REG | RBX_REG | RCX_REG | RDX_REG | RIP_REG
  datatype fname = Z_FLAG

  datatype instr =
    LOAD rname rname  (* LOAD dst:reg src:reg    dst = [src] *)
  | STORE rname rname (* STORE dst:reg src:reg   [dst] = src *)
  | LOADI rname val64
  | MOV rname rname
  | ADD rname rname rname
  | CMP rname rname
  | JMP val64
  | JE val64
  | HLT        (* Defined termination of program *)

  section \<open>Semantics\<close>

  datatype state = STATE
    (regs: "rname \<Rightarrow> val64")
    (mem: "val64 \<Rightarrow> val64")
    (flags: "fname \<Rightarrow> bool")
    (instrs: "instr list")
    (halted: bool)

  define_lenses state

  lemma pre_state_lenses[simp]:
    "pre_get regs\<^sub>L s"
    "pre_get mem\<^sub>L s"
    "pre_get flags\<^sub>L s"
    "pre_get instrs\<^sub>L s"
    "pre_get halted\<^sub>L s"
    unfolding regs\<^sub>L_def mem\<^sub>L_def flags\<^sub>L_def instrs\<^sub>L_def halted\<^sub>L_def
    by (auto split: state.splits)

  lemma state\<^sub>L_indeps[simp]:
    "regs\<^sub>L \<bowtie> mem\<^sub>L"
    "regs\<^sub>L \<bowtie> flags\<^sub>L"
    "regs\<^sub>L \<bowtie> instrs\<^sub>L"
    "regs\<^sub>L \<bowtie> halted\<^sub>L"

    "mem\<^sub>L \<bowtie> flags\<^sub>L"
    "mem\<^sub>L \<bowtie> instrs\<^sub>L"
    "mem\<^sub>L \<bowtie> halted\<^sub>L"

    "flags\<^sub>L \<bowtie> instrs\<^sub>L"
    "flags\<^sub>L \<bowtie> halted\<^sub>L"

    "instrs\<^sub>L \<bowtie> halted\<^sub>L"
    by (unfold_locales; unfold regs\<^sub>L_def mem\<^sub>L_def flags\<^sub>L_def instrs\<^sub>L_def halted\<^sub>L_def; auto split: state.split)+

  lemmas [simp] = state\<^sub>L_indeps[THEN lens_indep_sym]

  definition "reg\<^sub>L r \<equiv> regs\<^sub>L (r)\<^sub>L"    (* TODO: Attribute [lens] to auto-prove and register "lens x" lemma! *)
  definition "flag\<^sub>L r \<equiv> flags\<^sub>L (r)\<^sub>L"

  lemma lens_reg\<^sub>L[simp]: "hlens (reg\<^sub>L r)" by (simp add: reg\<^sub>L_def)
  lemma pre_reg\<^sub>L[simp]: "pre_get (reg\<^sub>L r) s" by (simp add: reg\<^sub>L_def)
  lemma lens_flag\<^sub>L[simp]: "hlens (flag\<^sub>L r)" by (simp add: flag\<^sub>L_def)
  lemma pre_flag\<^sub>L[simp]: "pre_get (flag\<^sub>L r) s" by (simp add: flag\<^sub>L_def)

  fun exec_instr :: "instr \<Rightarrow> (unit, state) se" where
    "exec_instr (LOAD dst src) = doE {
      addr \<leftarrow> use (reg\<^sub>L src);
      val \<leftarrow> use (mem\<^sub>L (addr)\<^sub>L);
      reg\<^sub>L dst ::= val
    }"
  | "exec_instr (STORE dst src) = doE {
      addr \<leftarrow> use (reg\<^sub>L dst);
      val \<leftarrow> use (reg\<^sub>L src);
      mem\<^sub>L (addr)\<^sub>L ::= val
    }"
  | "exec_instr (LOADI dst val) = doE {
      reg\<^sub>L dst ::= val
    }"
  | "exec_instr (MOV dst src) = doE {
      reg\<^sub>L dst ::^= use (reg\<^sub>L src)
    }"
  | "exec_instr (ADD dst src1 src2) = doE {
      v1 \<leftarrow> use (reg\<^sub>L src1);
      v2 \<leftarrow> use (reg\<^sub>L src2);
      let v = v1+v2;
      reg\<^sub>L dst ::= v;
      flag\<^sub>L Z_FLAG ::= (v=0)
    }"
  | "exec_instr (CMP src1 src2) = doE {
      v1 \<leftarrow> use (reg\<^sub>L src1);
      v2 \<leftarrow> use (reg\<^sub>L src2);
      flag\<^sub>L Z_FLAG ::= (v1 = v2)
    }"
  | "exec_instr (JMP tgt) = doE {
      reg\<^sub>L RIP_REG ::= tgt
    }"
  | "exec_instr (JE tgt) = doE {
      zf \<leftarrow> use (flag\<^sub>L Z_FLAG);
      if zf then
        reg\<^sub>L RIP_REG ::= tgt
      else sreturn ()
    }"
  | "exec_instr HLT = doE { halted\<^sub>L ::= True }"

  definition "fetch_instr \<equiv> doE {
    ip \<leftarrow> use (reg\<^sub>L RIP_REG);
    use (instrs\<^sub>L[unat ip]\<^sub>L)
  }"

  definition step :: "(unit, state) se" where
    "step \<equiv> doE {
      instr \<leftarrow> fetch_instr;
      reg\<^sub>L RIP_REG %= op+1;
      exec_instr instr
    }"

  global_interpretation det_system step halted
    defines yields = yields' .

  declare yields_unfold[code]

  definition "execute \<equiv> doE {
    s \<leftarrow> sget;
    s \<leftarrow> lift (yields s);
    case s of None \<Rightarrow> sfail | Some s \<Rightarrow> sput s
  }"

  definition zero_state :: state where
    "zero_state \<equiv> (STATE
      (\<lambda>_. 0)
      (\<lambda>_. 0)
      (\<lambda>_. False)
      ([])
      False
    )"

  section \<open>Execution Example\<close>

  definition "pow_prog \<equiv> [
(*0*)   LOADI RCX_REG 0,
(*1*)   LOADI RAX_REG 1,
(*2*)   LOADI RBX_REG 1,
(*3*)   CMP RCX_REG RDX_REG,
(*4*)   JE 8,
(*5*)     ADD RAX_REG RAX_REG RAX_REG,
(*6*)     ADD RCX_REG RCX_REG RBX_REG,
(*7*)   JMP 3,
(*8*)   HLT
(*9*)
  ]"

  value "(doE {
    reg\<^sub>L RDX_REG ::= 5;
    instrs\<^sub>L ::= pow_prog;
    execute;
    use (reg\<^sub>L RAX_REG)
  })
  zero_state"

section \<open>Verification\<close>

definition wf_state :: "state \<Rightarrow> bool"
  where "wf_state _ \<equiv> True" (* Can be used to add additional constraints to state *)

lemma wf_state_weak_invar: "is_weak_invar wf_state"
  apply (rule is_weak_invarI)
  by (simp add: wf_state_def)

hide_fact (open) wf_state_def (* Once wf_state is established as invariant,
  we should not need it any more! -- At least for now, when it is True.
  Thus, wf_state is just a dummy to show that additional invariant kbxfer works!
*)

lemma [DEL_KBXFER_simps]:
  assumes "KBXFER R s s'"
  shows
    "wf_state s = DEL_TAG (wf_state s)"
    by (auto simp: DEL_TAG_def)

interpretation std_invar_system step halted wf_state
  apply standard
  by (rule wf_state_weak_invar)

definition "location \<equiv> get' (reg\<^sub>L RIP_REG)"

interpretation cfg_system step halted wf_state location by standard

type_synonym floyd_invar = "val64 \<rightharpoonup> (state \<Rightarrow> bool)"

thm floyd_invarI floyd_vcsI

lemma reg\<^sub>L_indep[simp]: "r\<noteq>r' \<Longrightarrow> reg\<^sub>L r \<bowtie> reg\<^sub>L r'"
  unfolding reg\<^sub>L_def
  by (simp add: lens_indep_left_comp)

lemma flag\<^sub>L_indep[simp]: "r\<noteq>r' \<Longrightarrow> flag\<^sub>L r \<bowtie> flag\<^sub>L r'"
  unfolding flag\<^sub>L_def
  by (simp add: lens_indep_left_comp)

lemma flag_regL_indep[simp, THEN lens_indep_sym, simp]:
  "flag\<^sub>L f \<bowtie> reg\<^sub>L r"
  unfolding reg\<^sub>L_def flag\<^sub>L_def
  by (simp add: lens_indep_extend2)

lemma flag\<^sub>L_more_indep[simp, THEN lens_indep_sym, simp]:
  "flag\<^sub>L f \<bowtie> mem\<^sub>L"
  "flag\<^sub>L f \<bowtie> instrs\<^sub>L"
  "flag\<^sub>L f \<bowtie> halted\<^sub>L"
  unfolding flag\<^sub>L_def
  by (simp_all add: lens_indep_left_ext)

lemma reg\<^sub>L_more_indep[simp, THEN lens_indep_sym, simp]:
  "reg\<^sub>L f \<bowtie> mem\<^sub>L"
  "reg\<^sub>L f \<bowtie> instrs\<^sub>L"
  "reg\<^sub>L f \<bowtie> halted\<^sub>L"
  unfolding reg\<^sub>L_def
  by (simp_all add: lens_indep_left_ext)

abbreviation "REG r \<equiv> VAL (reg\<^sub>L r)"
abbreviation "RAX \<equiv> REG RAX_REG"
abbreviation "RBX \<equiv> REG RBX_REG"
abbreviation "RCX \<equiv> REG RCX_REG"
abbreviation "RDX \<equiv> REG RDX_REG"
abbreviation "RIP \<equiv> REG RIP_REG"
abbreviation "FLAG f \<equiv> VAL (flag\<^sub>L f)"
abbreviation "ZFLAG \<equiv> FLAG Z_FLAG"
abbreviation "PROG \<equiv> VAL instrs\<^sub>L"

text \<open>Use to convert location into value for RIP\<close>
lemma location_eq_conv: "location s = i \<longleftrightarrow> RIP i s"
  unfolding VAL_def by (auto simp: location_def)

lemma halted_eq_conv:
  "halted s \<longleftrightarrow> VAL halted\<^sub>L True s"
  "\<not>VAL halted\<^sub>L True s \<longleftrightarrow> VAL halted\<^sub>L False s"
  "VAL halted\<^sub>L True s \<Longrightarrow> \<not>VAL halted\<^sub>L False s"
  unfolding VAL_def
  by auto (auto simp: halted\<^sub>L_def split: state.splits)

lemmas prep_precond_conv = location_eq_conv halted_eq_conv

lemma location_conv[simp]: "RIP i s \<Longrightarrow> location s = i"
  by (auto simp: location_def)

lemma wps_fetch_instr_eq[wps_iffs]:
  assumes "RIP i s" "PROG \<pi> s"
  assumes "unat i < length \<pi>"
  shows "wps fetch_instr Q s \<longleftrightarrow> Q (\<pi> ! unat i) s"
  unfolding fetch_instr_def
  using assms
  by (simp add: wps_eqs wps_use_eq)

lemma wps_stepI[wps_intros]:
  assumes "RIP i s" "PROG \<pi> s"
  assumes "unat i < length \<pi>"
  assumes "\<And>s'. \<lbrakk>KBXFER (ltrans (reg\<^sub>L RIP_REG)) s s'; RIP (1 + i) s'\<rbrakk> \<Longrightarrow> wps (exec_instr (\<pi> ! unat i)) Q s'"
  shows "wps step Q s"
  unfolding step_def
  apply (rule wps_rls | fact)+
  done

lemma wps_CMPI[wps_intros]:
  assumes "REG r1 x1 s" "REG r2 x2 s"
  assumes "\<And>s'. \<lbrakk>KBXFER (ltrans (flag\<^sub>L Z_FLAG)) s s'; ZFLAG (x1 = x2) s'\<rbrakk> \<Longrightarrow> Q () s'"
  shows "wps (exec_instr (CMP r1 r2)) Q s"
  apply (simp)
  apply (intro wps_rls)
  apply (fact|simp)+
  done

lemma wps_JEI[wps_intros]:
  assumes "ZFLAG z s"
  assumes "\<And>s'. \<lbrakk>z; KBXFER (ltrans (reg\<^sub>L RIP_REG)) s s'; RIP tgt s'\<rbrakk> \<Longrightarrow> Q () s'"
  assumes "\<not> z \<Longrightarrow> Q () s"
  shows "wps (exec_instr (JE tgt)) Q s"
  apply (simp)
  apply (intro wps_rls)
  apply (fact|simp)+
  done

lemma wps_JMPI[wps_intros]:
  assumes "\<And>s'. \<lbrakk>KBXFER (ltrans (reg\<^sub>L RIP_REG)) s s'; RIP tgt s'\<rbrakk> \<Longrightarrow> Q () s'"
  shows "wps (exec_instr (JMP tgt)) Q s"
  apply (simp)
  apply (intro wps_rls)
  apply (fact|simp)+
  done

lemma wps_HLTI[wps_intros]:
  assumes "\<And>s'. \<lbrakk>KBXFER (ltrans halted\<^sub>L) s s'; VAL halted\<^sub>L True s'\<rbrakk> \<Longrightarrow> Q () s'"
  shows "wps (exec_instr HLT) Q s"
  apply (simp)
  apply (intro wps_rls)
  apply (fact|simp)+
  done

lemma wps_ADDI[wps_intros]:
  assumes "REG r2 x2 s" "REG r3 x3 s"
  assumes "\<And>s'a. \<lbrakk>REG r1 (x2 + x3) s'a; ZFLAG (x2 + x3 = 0) s'a;
            KBXFER (ltrans (reg\<^sub>L r1) OO ltrans (flag\<^sub>L Z_FLAG)) s s'a\<rbrakk>
           \<Longrightarrow> Q () s'a"
  shows "wps (exec_instr (ADD r1 r2 r3)) Q s"
  apply (simp add: Let_def)
  apply (rule wps_rls | fact | kbxfer')+
  apply kbxfer_trans
  by fact

lemma wps_LOADI[wps_intros]:
  assumes "\<And>s'. \<lbrakk>KBXFER (ltrans (reg\<^sub>L r)) s s'; REG r i s'\<rbrakk> \<Longrightarrow> Q () s'"
  shows "wps (exec_instr (LOADI r i)) Q s"
  apply (simp)
  apply (intro wps_rls)
  apply (fact|simp)+
  done

declare exec_instr.simps[simp del]

section \<open>Verification Example\<close>

lemma nat_to_numeral1:
  "Suc 0 = Numeral1"
  "Suc (numeral n) = numeral (Num.inc n)"
  by (auto simp: add_One)

lemmas nat_to_numeral = nat_to_numeral1 Num.inc.simps

schematic_goal [simplified nat_to_numeral, simp]: "length pow_prog = ?l"
  unfolding pow_prog_def by simp

schematic_goal [simplified,simp]:
  "pow_prog ! 0 = ?c0"
  "pow_prog ! 1 = ?c1"
  "pow_prog ! 2 = ?c2"
  "pow_prog ! 3 = ?c3"
  "pow_prog ! 4 = ?c4"
  "pow_prog ! 5 = ?c5"
  "pow_prog ! 6 = ?c6"
  "pow_prog ! 7 = ?c7"
  "pow_prog ! 8 = ?c8"
  unfolding pow_prog_def by auto

prop "RDX p s \<and> VAL (mem\<^sub>L((p + 0))\<^sub>L) x0 s \<and> VAL (mem\<^sub>L((p + 1))\<^sub>L) x1 s"

definition pp_\<Theta> :: "_ \<Rightarrow> floyd_invar" where "pp_\<Theta> rdx\<^sub>0 \<equiv> [
  0 \<mapsto> (\<lambda>s. VAL halted\<^sub>L False s \<and> PROG pow_prog s \<and> RDX rdx\<^sub>0 s),
  3 \<mapsto> (\<lambda>s. \<exists>rax rbx rcx hlt. RAX rax s \<and> RBX rbx s \<and> RCX rcx s \<and> RDX rdx\<^sub>0 s
      \<and> VAL halted\<^sub>L hlt s \<and> \<not>hlt \<and> PROG pow_prog s
      \<and> rbx = 1 \<and> rax = 2 ^ unat rcx \<and> rcx \<le> rdx\<^sub>0),
  9 \<mapsto> (\<lambda>s. \<exists>rax hlt. RAX rax s \<and> RDX rdx\<^sub>0 s
      \<and> VAL halted\<^sub>L hlt s \<and> hlt \<and> PROG pow_prog s
      \<and> rax = 2 ^ unat rdx\<^sub>0
      )
]"

schematic_goal [simplified,simp]:
  "pp_\<Theta> rdx\<^sub>0 0 = ?p0"
  "pp_\<Theta> rdx\<^sub>0 3 = ?p3"
  "pp_\<Theta> rdx\<^sub>0 9 = ?p9"
  "i\<notin>{0,3,9} \<Longrightarrow> pp_\<Theta> rdx\<^sub>0 i = None"
  unfolding pp_\<Theta>_def by auto

lemma incr_aux1:
  fixes a b :: "'a::len word"
  shows "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> unat (a+1) = Suc (unat a)"
  by (smt Suc_eq_plus1 add.commute inc_i inc_le le_less not_less unatSuc unat_1 unat_plus_simple)

lemma incr_aux2:
  fixes a b :: "'a::len word"
  shows "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a+1\<le>b"
  by (simp add: inc_le)

(* TODO: Move this VCG to more generic place! Currently placed here for quick experiments. *)
method vcg_clarify = (intro impI conjI)?, (((rule exI, rule conjI, assumption)+ | (simp add: prep_precond_conv))+)?
method vcg_step_aux = (rule wps_rls linvar_unfoldI, (assumption+)?); kbxfer?
method vcg_step = vcg_clarify, vcg_step_aux
method vcg = (vcg_step+, vcg_clarify)

lemma pp_std_invar: "is_std_invar (floyd.invar (pp_\<Theta> rdx\<^sub>0))"
  apply (rule floyd_invarI)
  apply (rewrite at "floyd_vcs \<hole> _" pp_\<Theta>_def)
  apply (intro floyd_vcsI; (clarsimp simp: prep_precond_conv)?)

  subgoal for s by vcg

  subgoal for s
    apply vcg
    apply (elim_determ thin_rl[of "VAL _ _ _"])
    apply (auto simp: incr_aux1 inc_le) []
    done
  done

theorem pow_prog_correct: "htriple
  (\<lambda>s. RIP 0 s \<and> PROG pow_prog s \<and> VAL halted\<^sub>L False s \<and> RDX n s)
  (\<lambda>s. RAX (2^unat n) s)"
  apply (rule floyd_htripleI[where \<Theta> = "pp_\<Theta> n"], clarify)
  subgoal by vcg
  subgoal by (rule pp_std_invar)
  subgoal for s \<phi>
    unfolding pp_\<Theta>_def
    by (clarsimp split: if_splits simp: prep_precond_conv)
  done

end


(*  Title:       The Standard Redundancy Criterion
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>The Standard Redundancy Criterion\<close>

theory Standard_Redundancy
  imports Proving_Process
begin

text \<open>
This material is based on Section 4.2.2 (``The Standard Redundancy Criterion'') of Bachmair and
Ganzinger's chapter.
\<close>

locale standard_redundancy_criterion =
  inference_system \<Gamma> for \<Gamma> :: "('a :: wellorder) inference set"
begin

definition redundant_infer :: "'a clause set \<Rightarrow> 'a inference \<Rightarrow> bool" where
  "redundant_infer N \<gamma> \<longleftrightarrow>
   (\<exists>DD. set_mset DD \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD + side_prems_of \<gamma> \<longrightarrow> I \<Turnstile> concl_of \<gamma>)
      \<and> (\<forall>D. D \<in># DD \<longrightarrow> D < main_prem_of \<gamma>))"

definition Rf :: "'a clause set \<Rightarrow> 'a clause set" where
  "Rf N = {C. \<exists>DD. set_mset DD \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD \<longrightarrow> I \<Turnstile> C) \<and> (\<forall>D. D \<in># DD \<longrightarrow> D < C)}"

definition Ri :: "'a clause set \<Rightarrow> 'a inference set" where
  "Ri N = {\<gamma> \<in> \<Gamma>. redundant_infer N \<gamma>}"

lemma tautology_Rf:
  assumes "Pos A \<in># C"
  assumes "Neg A \<in># C"
  shows "C \<in> Rf N"
proof -
  have "set_mset {#} \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m {#} \<longrightarrow> I \<Turnstile> C) \<and> (\<forall>D. D \<in># {#} \<longrightarrow> D < C)"
    using assms by auto
  then show "C \<in> Rf N"
    unfolding Rf_def by blast
qed

lemma tautology_redundant_infer:
  assumes
    pos: "Pos A \<in># concl_of \<iota>" and
    neg: "Neg A \<in># concl_of \<iota>"
  shows "redundant_infer N \<iota>"
  by (metis empty_iff empty_subsetI neg pos pos_neg_in_imp_true redundant_infer_def set_mset_empty)

lemma contradiction_Rf: "{#} \<in> N \<Longrightarrow> Rf N = UNIV - {{#}}"
  unfolding Rf_def by force

text \<open>
The following results correspond to Lemma 4.5. The lemma \<open>wlog_non_Rf\<close> generalizes the core of
the argument.
\<close>

lemma Rf_mono: "N \<subseteq> N' \<Longrightarrow> Rf N \<subseteq> Rf N'"
  unfolding Rf_def by auto

lemma wlog_non_Rf:
  assumes ex: "\<exists>DD. set_mset DD \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E) \<and> (\<forall>D'. D' \<in># DD \<longrightarrow> D' < D)"
  shows "\<exists>DD. set_mset DD \<subseteq> N - Rf N \<and> (\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E) \<and> (\<forall>D'. D' \<in># DD \<longrightarrow> D' < D)"
proof -
  from ex obtain DD0 where
    dd0: "DD0 \<in> {DD. set_mset DD \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E) \<and> (\<forall>D'. D' \<in># DD \<longrightarrow> D' < D)}"
    by blast
  have "\<exists>DD. set_mset DD \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E) \<and> (\<forall>D'. D' \<in># DD \<longrightarrow> D' < D) \<and>
      (\<forall>DD'. set_mset DD' \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD' + CC \<longrightarrow> I \<Turnstile> E) \<and> (\<forall>D'. D' \<in># DD' \<longrightarrow> D' < D) \<longrightarrow>
    DD \<le> DD')"
    using wf_eq_minimal[THEN iffD1, rule_format, OF wf_less_multiset dd0]
    unfolding not_le[symmetric] by blast
  then obtain DD where
    dd_subs_n: "set_mset DD \<subseteq> N" and
    ddcc_imp_e: "\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E" and
    dd_lt_d: "\<forall>D'. D' \<in># DD \<longrightarrow> D' < D" and
    d_min: "\<forall>DD'. set_mset DD' \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD' + CC \<longrightarrow> I \<Turnstile> E) \<and> (\<forall>D'. D' \<in># DD' \<longrightarrow> D' < D) \<longrightarrow>
      DD \<le> DD'"
    by blast

  have "\<forall>Da. Da \<in># DD \<longrightarrow> Da \<notin> Rf N"
  proof clarify
    fix Da
    assume
      da_in_dd: "Da \<in># DD" and
      da_rf: "Da \<in> Rf N"

    from da_rf obtain DD' where
      dd'_subs_n: "set_mset DD' \<subseteq> N" and
      dd'_imp_da: "\<forall>I. I \<Turnstile>m DD' \<longrightarrow> I \<Turnstile> Da" and
      dd'_lt_da: "\<forall>D'. D' \<in># DD' \<longrightarrow> D' < Da"
      unfolding Rf_def by blast

    define DDa where
      "DDa = DD - {#Da#} + DD'"

    have "set_mset DDa \<subseteq> N"
      unfolding DDa_def using dd_subs_n dd'_subs_n
      by (meson contra_subsetD in_diffD subsetI union_iff)
    moreover have "\<forall>I. I \<Turnstile>m DDa + CC \<longrightarrow> I \<Turnstile> E"
      using dd'_imp_da ddcc_imp_e da_in_dd unfolding DDa_def true_cls_mset_def
      by (metis in_remove1_mset_neq union_iff)
    moreover have "\<forall>D'. D' \<in># DDa \<longrightarrow> D' < D"
      using dd_lt_d dd'_lt_da da_in_dd unfolding DDa_def
      by (metis insert_DiffM2 order.strict_trans union_iff)
    moreover have "DDa < DD"
      unfolding DDa_def
      by (meson da_in_dd dd'_lt_da mset_lt_single_right_iff single_subset_iff union_le_diff_plus)
    ultimately show False
      using d_min unfolding less_eq_multiset_def by (auto intro!: antisym)
  qed
  then show ?thesis
    using dd_subs_n ddcc_imp_e dd_lt_d by auto
qed

lemma Rf_imp_ex_non_Rf:
  assumes "C \<in> Rf N"
  shows "\<exists>CC. set_mset CC \<subseteq> N - Rf N \<and> (\<forall>I. I \<Turnstile>m CC \<longrightarrow> I \<Turnstile> C) \<and> (\<forall>C'. C' \<in># CC \<longrightarrow> C' < C)"
  using assms by (auto simp: Rf_def intro: wlog_non_Rf[of _ "{#}", simplified])

lemma Rf_subs_Rf_diff_Rf: "Rf N \<subseteq> Rf (N - Rf N)"
proof
  fix C
  assume c_rf: "C \<in> Rf N"
  then obtain CC where
    cc_subs: "set_mset CC \<subseteq> N - Rf N" and
    cc_imp_c: "\<forall>I. I \<Turnstile>m CC \<longrightarrow> I \<Turnstile> C" and
    cc_lt_c: "\<forall>C'. C' \<in># CC \<longrightarrow> C' < C"
    using Rf_imp_ex_non_Rf by blast
  have "\<forall>D. D \<in># CC \<longrightarrow> D \<notin> Rf N"
    using cc_subs by (simp add: subset_iff)
  then have cc_nr:
    "\<And>C DD. C \<in># CC \<Longrightarrow> set_mset DD \<subseteq> N \<Longrightarrow> \<forall>I. I \<Turnstile>m DD \<longrightarrow> I \<Turnstile> C \<Longrightarrow> \<exists>D. D \<in># DD \<and> \<not> D < C"
      unfolding Rf_def by auto metis
  have "set_mset CC \<subseteq> N"
    using cc_subs by auto
  then have "set_mset CC \<subseteq>
    N - {C. \<exists>DD. set_mset DD \<subseteq> N \<and> (\<forall>I. I \<Turnstile>m DD \<longrightarrow> I \<Turnstile> C) \<and> (\<forall>D. D \<in># DD \<longrightarrow> D < C)}"
    using cc_nr by blast
  then show "C \<in> Rf (N - Rf N)"
    using cc_imp_c cc_lt_c unfolding Rf_def by auto
qed

lemma Rf_eq_Rf_diff_Rf: "Rf N = Rf (N - Rf N)"
  by (metis Diff_subset Rf_mono Rf_subs_Rf_diff_Rf subset_antisym)

text \<open>
The following results correspond to Lemma 4.6.
\<close>

lemma Ri_mono: "N \<subseteq> N' \<Longrightarrow> Ri N \<subseteq> Ri N'"
  unfolding Ri_def redundant_infer_def by auto

lemma Ri_subs_Ri_diff_Rf: "Ri N \<subseteq> Ri (N - Rf N)"
proof
  fix \<gamma>
  assume \<gamma>_ri: "\<gamma> \<in> Ri N"
  then obtain CC D E where \<gamma>: "\<gamma> = Infer CC D E"
    by (cases \<gamma>)
  have cc: "CC = side_prems_of \<gamma>" and d: "D = main_prem_of \<gamma>" and e: "E = concl_of \<gamma>"
    unfolding \<gamma> by simp_all
  obtain DD where
    "set_mset DD \<subseteq> N" and "\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E" and "\<forall>C. C \<in># DD \<longrightarrow> C < D"
    using \<gamma>_ri unfolding Ri_def redundant_infer_def cc d e by blast
  then obtain DD' where
    "set_mset DD' \<subseteq> N - Rf N" and "\<forall>I. I \<Turnstile>m DD' + CC \<longrightarrow> I \<Turnstile> E" and "\<forall>D'. D' \<in># DD' \<longrightarrow> D' < D"
    using wlog_non_Rf by atomize_elim blast
  then show "\<gamma> \<in> Ri (N - Rf N)"
    using \<gamma>_ri unfolding Ri_def redundant_infer_def d cc e by blast
qed

lemma Ri_eq_Ri_diff_Rf: "Ri N = Ri (N - Rf N)"
  by (metis Diff_subset Ri_mono Ri_subs_Ri_diff_Rf subset_antisym)

lemma Ri_subset_\<Gamma>: "Ri N \<subseteq> \<Gamma>"
  unfolding Ri_def by blast

lemma Rf_indep: "N' \<subseteq> Rf N \<Longrightarrow> Rf N \<subseteq> Rf (N - N')"
  by (metis Diff_cancel Diff_eq_empty_iff Diff_mono Rf_eq_Rf_diff_Rf Rf_mono)

lemma Ri_indep: "N' \<subseteq> Rf N \<Longrightarrow> Ri N \<subseteq> Ri (N - N')"
  by (metis Diff_mono Ri_eq_Ri_diff_Rf Ri_mono order_refl)

lemma Rf_model:
  assumes "I \<Turnstile>s N - Rf N"
  shows "I \<Turnstile>s N"
proof -
  have "I \<Turnstile>s Rf (N - Rf N)"
    unfolding true_clss_def
    by (subst Rf_def, simp add: true_cls_mset_def, metis assms subset_eq true_clss_def)
  then have "I \<Turnstile>s Rf N"
    using Rf_subs_Rf_diff_Rf true_clss_mono by blast
  then show ?thesis
    using assms by (metis Un_Diff_cancel true_clss_union)
qed

lemma Rf_sat: "satisfiable (N - Rf N) \<Longrightarrow> satisfiable N"
  by (metis Rf_model)

text \<open>
The following corresponds to Theorem 4.7:
\<close>

sublocale redundancy_criterion \<Gamma> Rf Ri
  by unfold_locales (rule Ri_subset_\<Gamma>, (elim Rf_mono Ri_mono Rf_indep Ri_indep Rf_sat)+)

end

locale standard_redundancy_criterion_reductive =
  standard_redundancy_criterion + reductive_inference_system
begin

text \<open>
The following corresponds to Theorem 4.8:
\<close>

lemma Ri_effective:
  assumes
    in_\<gamma>: "\<gamma> \<in> \<Gamma>" and
    concl_of_in_n_un_rf_n: "concl_of \<gamma> \<in> N \<union> Rf N"
  shows "\<gamma> \<in> Ri N"
proof -
  obtain CC D E where
    \<gamma>: "\<gamma> = Infer CC D E"
    by (cases \<gamma>)
  then have cc: "CC = side_prems_of \<gamma>" and d: "D = main_prem_of \<gamma>" and e: "E = concl_of \<gamma>"
    unfolding \<gamma> by simp_all
  note e_in_n_un_rf_n = concl_of_in_n_un_rf_n[folded e]

  {
    assume "E \<in> N"
    moreover have "E < D"
      using \<Gamma>_reductive e d in_\<gamma> by auto
    ultimately have
      "set_mset {#E#} \<subseteq> N" and "\<forall>I. I \<Turnstile>m {#E#} + CC \<longrightarrow> I \<Turnstile> E" and "\<forall>D'. D' \<in># {#E#} \<longrightarrow> D' < D"
      by simp_all
    then have "redundant_infer N \<gamma>"
      using redundant_infer_def cc d e by blast
  }
  moreover
  {
    assume "E \<in> Rf N"
    then obtain DD where
      dd_sset: "set_mset DD \<subseteq> N" and
      dd_imp_e: "\<forall>I. I \<Turnstile>m DD \<longrightarrow> I \<Turnstile> E" and
      dd_lt_e: "\<forall>C'. C' \<in># DD \<longrightarrow> C' < E"
      unfolding Rf_def by blast
    from dd_lt_e have "\<forall>Da. Da \<in># DD \<longrightarrow> Da < D"
      using d e in_\<gamma> \<Gamma>_reductive less_trans by blast
    then have "redundant_infer N \<gamma>"
      using redundant_infer_def dd_sset dd_imp_e cc d e by blast
  }
  ultimately show "\<gamma> \<in> Ri N"
    using in_\<gamma> e_in_n_un_rf_n unfolding Ri_def by blast
qed

sublocale effective_redundancy_criterion \<Gamma> Rf Ri
  unfolding effective_redundancy_criterion_def
  by (intro conjI redundancy_criterion_axioms, unfold_locales, rule Ri_effective)

lemma contradiction_Rf: "{#} \<in> N \<Longrightarrow> Ri N = \<Gamma>"
  unfolding Ri_def redundant_infer_def using \<Gamma>_reductive le_multiset_empty_right
  by (force intro: exI[of _ "{#{#}#}"] le_multiset_empty_left)

end

locale standard_redundancy_criterion_counterex_reducing =
  standard_redundancy_criterion + counterex_reducing_inference_system
begin

text \<open>
The following result corresponds to Theorem 4.9.
\<close>

lemma saturated_upto_complete_if:
  assumes
    satur: "saturated_upto N" and
    unsat: "\<not> satisfiable N"
  shows "{#} \<in> N"
proof (rule ccontr)
  assume ec_ni_n: "{#} \<notin> N"

  define M where
    "M = N - Rf N"

  have ec_ni_m: "{#} \<notin> M"
    unfolding M_def using ec_ni_n by fast

  have "I_of M \<Turnstile>s M"
  proof (rule ccontr)
    assume "\<not> I_of M \<Turnstile>s M"
    then obtain D where
      d_in_m: "D \<in> M" and
      d_cex: "\<not> I_of M \<Turnstile> D" and
      d_min: "\<And>C. C \<in> M \<Longrightarrow> C < D \<Longrightarrow> I_of M \<Turnstile> C"
      using ex_min_counterex by meson
    then obtain \<gamma> CC E where
      \<gamma>: "\<gamma> = Infer CC D E" and
      cc_subs_m: "set_mset CC \<subseteq> M" and
      cc_true: "I_of M \<Turnstile>m CC" and
      \<gamma>_in: "\<gamma> \<in> \<Gamma>" and
      e_cex: "\<not> I_of M \<Turnstile> E" and
      e_lt_d: "E < D"
      using \<Gamma>_counterex_reducing[OF ec_ni_m] not_less by metis
    have cc: "CC = side_prems_of \<gamma>" and d: "D = main_prem_of \<gamma>" and e: "E = concl_of \<gamma>"
      unfolding \<gamma> by simp_all
    have "\<gamma> \<in> Ri N"
      by (rule subsetD[OF satur[unfolded saturated_upto_def inferences_from_def infer_from_def]])
        (simp add: \<gamma>_in d_in_m cc_subs_m cc[symmetric] d[symmetric] M_def[symmetric])
    then have "\<gamma> \<in> Ri M"
      unfolding M_def using Ri_indep by fast
    then obtain DD where
      dd_subs_m: "set_mset DD \<subseteq> M" and
      dd_cc_imp_d: "\<forall>I. I \<Turnstile>m DD + CC \<longrightarrow> I \<Turnstile> E" and
      dd_lt_d: "\<forall>C. C \<in># DD \<longrightarrow> C < D"
      unfolding Ri_def redundant_infer_def cc d e by blast
    from dd_subs_m dd_lt_d have "I_of M \<Turnstile>m DD"
      using d_min unfolding true_cls_mset_def by (metis contra_subsetD)
    then have "I_of M \<Turnstile> E"
      using dd_cc_imp_d cc_true by auto
    then show False
      using e_cex by auto
  qed
  then have "I_of M \<Turnstile>s N"
    using M_def Rf_model by blast
  then show False
    using unsat by blast
qed

theorem saturated_upto_complete:
  assumes "saturated_upto N"
  shows "\<not> satisfiable N \<longleftrightarrow> {#} \<in> N"
  using assms saturated_upto_complete_if true_clss_def by auto

end

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedMap, algorithms for iterators, min, max, to_sorted_list

*)

header {* \isaheader{Generic Algorithms for Maps} *}
theory MapGA
imports SetIteratorCollectionsGA
begin

text_raw {*\label{thy:MapGA}*}

record ('k,'v,'s) map_basic_ops =
  bmap_op_\<alpha> :: "('k,'v,'s) map_\<alpha>"
  bmap_op_invar :: "('k,'v,'s) map_invar"
  bmap_op_empty :: "('k,'v,'s) map_empty"
  bmap_op_lookup :: "('k,'v,'s) map_lookup"
  bmap_op_update :: "('k,'v,'s) map_update"
  bmap_op_update_dj :: "('k,'v,'s) map_update_dj"
  bmap_op_delete :: "('k,'v,'s) map_delete"
  bmap_op_list_it :: "('k,'v,'s) map_list_it"

record ('k,'v,'s) omap_basic_ops = "('k,'v,'s) map_basic_ops" +
  bmap_op_ordered_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"
  bmap_op_rev_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"

locale StdBasicMapDefs =
  poly_map_iteratei_defs "bmap_op_list_it ops"
  for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == bmap_op_\<alpha> ops"
  abbreviation invar where "invar == bmap_op_invar ops"
  abbreviation empty where "empty == bmap_op_empty ops"
  abbreviation lookup where "lookup == bmap_op_lookup ops"
  abbreviation update where "update == bmap_op_update ops"
  abbreviation update_dj where "update_dj == bmap_op_update_dj ops"
  abbreviation delete where "delete == bmap_op_delete ops"
  abbreviation list_it where "list_it == bmap_op_list_it ops"
end

locale StdBasicOMapDefs = StdBasicMapDefs ops
  + poly_map_iterateoi_defs "bmap_op_ordered_list_it ops"
  + poly_map_rev_iterateoi_defs "bmap_op_rev_list_it ops"
  for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
  abbreviation ordered_list_it where "ordered_list_it
    \<equiv> bmap_op_ordered_list_it ops"
  abbreviation rev_list_it where "rev_list_it
    \<equiv> bmap_op_rev_list_it ops"
end

locale StdBasicMap = StdBasicMapDefs ops +
  map \<alpha> invar +
  map_empty \<alpha> invar empty +
  map_lookup \<alpha> invar lookup  +
  map_update \<alpha> invar update  +
  map_update_dj \<alpha> invar update_dj +
  map_delete \<alpha> invar delete  +
  poly_map_iteratei \<alpha> invar list_it
  for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
  lemmas correct[simp] = empty_correct lookup_correct update_correct
    update_dj_correct delete_correct
end

locale StdBasicOMap =
  StdBasicOMapDefs ops +
  StdBasicMap ops +
  poly_map_iterateoi \<alpha> invar ordered_list_it +
  poly_map_rev_iterateoi \<alpha> invar rev_list_it
  for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
end

context StdBasicMapDefs begin
  definition "g_sng k v \<equiv> update k v (empty ())"
  definition "g_add m1 m2 \<equiv> iterate m2 (\<lambda>(k,v) \<sigma>. update k v \<sigma>) m1"

  definition
    "g_sel m P \<equiv>
      iteratei m (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. if P x then Some x else None) None"

  definition "g_bex m P \<equiv> iteratei m (\<lambda>x. \<not>x) (\<lambda>kv \<sigma>. P kv) False"
  definition "g_ball m P \<equiv> iteratei m id (\<lambda>kv \<sigma>. P kv) True"

  definition "g_size m \<equiv> iterate m (\<lambda>_. Suc) (0::nat)"
  definition "g_size_abort b m \<equiv> iteratei m (\<lambda>s. s<b) (\<lambda>_. Suc) (0::nat)"

  definition "g_isEmpty m \<equiv> g_size_abort 1 m = 0"
  definition "g_isSng m \<equiv> g_size_abort 2 m = 1"

  definition "g_to_list m \<equiv> iterate m (op #) []"

  definition "g_list_to_map l \<equiv> foldl (\<lambda>m (k,v). update k v m) (empty ())
    (rev l)"

  definition "g_add_dj m1 m2 \<equiv> iterate m2 (\<lambda>(k,v) \<sigma>. update_dj k v \<sigma>) m1"

  definition "g_restrict P m \<equiv> iterate m
    (\<lambda>(k,v) \<sigma>. if P (k,v) then update_dj k v \<sigma> else \<sigma>) (empty ())"

  definition dflt_ops :: "('k,'v,'s) map_ops"
    where [icf_rec_def]:
    "dflt_ops \<equiv>
      \<lparr>
        map_op_\<alpha> = \<alpha>,
        map_op_invar = invar,
        map_op_empty = empty,
        map_op_lookup = lookup,
        map_op_update = update,
        map_op_update_dj = update_dj,
        map_op_delete = delete,
        map_op_list_it = list_it,
        map_op_sng = g_sng,
        map_op_restrict = g_restrict,
        map_op_add = g_add,
        map_op_add_dj = g_add_dj,
        map_op_isEmpty = g_isEmpty,
        map_op_isSng = g_isSng,
        map_op_ball = g_ball,
        map_op_bex = g_bex,
        map_op_size = g_size,
        map_op_size_abort = g_size_abort,
        map_op_sel = g_sel,
        map_op_to_list = g_to_list,
        map_op_to_map = g_list_to_map
      \<rparr>"

  local_setup {* Locale_Code.lc_decl_del @{term dflt_ops}*}

end

lemma update_dj_by_update:
  assumes "map_update \<alpha> invar update"
  shows "map_update_dj \<alpha> invar update"
proof -
  interpret map_update \<alpha> invar update by fact
  show ?thesis
    apply (unfold_locales)
    apply (auto simp add: update_correct)
    done
qed

lemma map_iterator_linord_is_it:
  "map_iterator_linord m it \<Longrightarrow> map_iterator m it"
  unfolding set_iterator_def set_iterator_map_linord_def
  apply (erule set_iterator_genord.set_iterator_weaken_R)
  ..

context StdBasicMap
begin

  lemma g_add_impl: "map_add \<alpha> invar g_add"
  proof
    fix m1 m2
    assume "invar m1" "invar m2"

    have A: "g_add m1 m2 = iterate_add_to_map m1 update (iteratei m2)"
      unfolding g_add_def iterate_add_to_map_def by simp
    have "\<alpha> (g_add m1 m2) = \<alpha> m1 ++ \<alpha> m2 \<and> invar (g_add m1 m2)"
      unfolding A
      apply (rule
        iterate_add_to_map_correct[of \<alpha> invar update m1 "iteratei m2" "\<alpha> m2"])
      apply unfold_locales []
      apply fact
      apply (rule iteratei_correct, fact)
      done
    thus "\<alpha> (g_add m1 m2) = \<alpha> m1 ++ \<alpha> m2" "invar (g_add m1 m2)" by auto
  qed

  lemma g_sel_impl: "map_sel' \<alpha> invar g_sel"
  proof -
    have A: "\<And>m P. g_sel m P = iterate_sel_no_map (iteratei m) P"
      unfolding g_sel_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix m P
      assume I: "invar m"
      note iterate_sel_no_map_correct[OF iteratei_correct[OF I], of P]
    }
    thus ?thesis
      apply unfold_locales
      unfolding A
      apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
      apply clarify
      apply (metis option.exhaust PairE)
      apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
      done
  qed

  lemma g_bex_impl: "map_bex \<alpha> invar g_bex"
    apply unfold_locales
    unfolding g_bex_def
    apply (rule_tac I="\<lambda>it \<sigma>. \<sigma> \<longleftrightarrow> (\<exists>kv\<in>it. P kv)"
      in iteratei_rule_insert_P)
    by (auto simp: map_to_set_def)

  lemma g_size_impl: "map_size \<alpha> invar g_size"
  proof
    fix m
    assume I: "invar m"
    have A: "g_size m \<equiv> iterate_size (iteratei m)"
      unfolding g_size_def iterate_size_def by simp

    from iterate_size_correct [OF iteratei_correct[OF I]]
    show "g_size m = card (dom (\<alpha> m))"
      unfolding A
      by (simp_all add: card_map_to_set)
  qed

  lemma g_size_abort_impl: "map_size_abort \<alpha> invar g_size_abort"
  proof
    fix s m
    assume I: "invar m"
    have A: "g_size_abort s m \<equiv> iterate_size_abort (iteratei m) s"
      unfolding g_size_abort_def iterate_size_abort_def by simp

    from iterate_size_abort_correct [OF iteratei_correct[OF I]]
    show "g_size_abort s m = min s (card (dom (\<alpha> m)))"
      unfolding A
      by (simp_all add: card_map_to_set)
  qed

  lemma g_isEmpty_impl: "map_isEmpty \<alpha> invar g_isEmpty"
  proof
    fix m
    assume I: "invar m"
    interpret map_size_abort \<alpha> invar g_size_abort by (rule g_size_abort_impl)
    from size_abort_correct[OF I] have
      "g_size_abort 1 m = min 1 (card (dom (\<alpha> m)))" .
    thus "g_isEmpty m = (\<alpha> m = Map.empty)" unfolding g_isEmpty_def
      by (auto simp: min_def card_0_eq[OF finite] I)
  qed

  lemma g_isSng_impl: "map_isSng \<alpha> invar g_isSng"
  proof
    fix m
    assume I: "invar m"
    interpret map_size_abort \<alpha> invar g_size_abort by (rule g_size_abort_impl)
    from size_abort_correct[OF I] have
      "g_size_abort 2 m = min 2 (card (dom (\<alpha> m)))" .
    thus "g_isSng m = (\<exists>k v. \<alpha> m = [k \<mapsto> v])" unfolding g_isSng_def
      by (auto simp: min_def I card_Suc_eq dom_eq_singleton_conv)
  qed

  lemma g_to_list_impl: "map_to_list \<alpha> invar g_to_list"
  proof
    fix m
    assume I: "invar m"

    have A: "g_to_list m = iterate_to_list (iteratei m)"
      unfolding g_to_list_def iterate_to_list_def by simp

    from iterate_to_list_correct [OF iteratei_correct[OF I]]
    have set_l_eq: "set (g_to_list m) = map_to_set (\<alpha> m)" and
      dist_l: "distinct (g_to_list m)" unfolding A by simp_all

    from dist_l show dist_fst_l: "distinct (map fst (g_to_list m))"
      by (simp add: distinct_map set_l_eq map_to_set_def inj_on_def)

    from map_of_map_to_set[of "(g_to_list m)" "\<alpha> m", OF dist_fst_l] set_l_eq
    show "map_of (g_to_list m) = \<alpha> m" by simp
  qed

  lemma g_list_to_map_impl: "list_to_map \<alpha> invar g_list_to_map"
  proof -
    {
      fix m0 l
      assume "invar m0"
      hence "invar (foldl (\<lambda>s (k,v). update k v s) m0 l) \<and>
        \<alpha> (foldl (\<lambda>s (k,v). update k v s) m0 l) = \<alpha> m0 ++ map_of (rev l)"
      proof (induction l arbitrary: m0)
        case Nil thus ?case by simp
      next
        case (Cons kv l)
        obtain k v where [simp]: "kv=(k,v)" by (cases kv) auto
        have "invar (foldl (\<lambda>s (k, v). update k v s) m0 (kv # l))"
          apply simp
          apply (rule conjunct1[OF Cons.IH])
          apply (simp add: update_correct Cons.prems)
          done
        moreover have "\<alpha> (foldl (\<lambda>s (k, v). update k v s) m0 (kv # l)) =
          \<alpha> m0 ++ map_of (rev (kv # l))"
          apply simp
          thm trans[OF conjunct2[OF Cons.IH]]
          apply (rule trans[OF conjunct2[OF Cons.IH]])
          apply (auto
            simp: update_correct Cons.prems Map.map_add_def[abs_def]
            split: option.split
          )
          done
        ultimately show ?case
          by simp
      qed
    } thus ?thesis
      apply unfold_locales
      unfolding g_list_to_map_def
      apply (auto simp: empty_correct)
      done
  qed

  lemma g_add_dj_impl: "map_add_dj \<alpha> invar g_add_dj"
  proof
    fix m1 m2
    assume "invar m1" "invar m2" and DJ: "dom (\<alpha> m1) \<inter> dom (\<alpha> m2) = {}"

    have A: "g_add_dj m1 m2 = iterate_add_to_map m1 update_dj (iteratei m2)"
      unfolding g_add_dj_def iterate_add_to_map_def by simp
    have "\<alpha> (g_add_dj m1 m2) = \<alpha> m1 ++ \<alpha> m2 \<and> invar (g_add_dj m1 m2)"
      unfolding A
      apply (rule
        iterate_add_to_map_dj_correct[
        of \<alpha> invar update_dj m1 "iteratei m2" "\<alpha> m2"])
      apply unfold_locales []
      apply fact
      apply (rule iteratei_correct, fact)
      using DJ apply (simp add: Int_ac)
      done
    thus "\<alpha> (g_add_dj m1 m2) = \<alpha> m1 ++ \<alpha> m2" "invar (g_add_dj m1 m2)" by auto
  qed

  lemma g_restrict_impl: "map_restrict \<alpha> invar \<alpha> invar g_restrict"
  proof
    fix m P
    assume I: "invar m"

    have AUX: "\<And>k v it \<sigma>.
       \<lbrakk>it \<subseteq> {(k, v). \<alpha> m k = Some v}; \<alpha> m k = Some v; (k, v) \<notin> it;
        {(k, v). \<alpha> \<sigma> k = Some v} = it \<inter> Collect P\<rbrakk>
       \<Longrightarrow> k \<notin> dom (\<alpha> \<sigma>)"
    proof (rule ccontr, simp)
      fix k v it \<sigma>
      assume "k\<in>dom (\<alpha> \<sigma>)"
      then obtain v' where "\<alpha> \<sigma> k = Some v'" by auto
      moreover assume "{(k, v). \<alpha> \<sigma> k = Some v} = it \<inter> Collect P"
      ultimately have MEM: "(k,v')\<in>it" by auto
      moreover assume "it \<subseteq> {(k, v). \<alpha> m k = Some v}" and "\<alpha> m k = Some v"
      ultimately have "v'=v" by auto
      moreover assume "(k,v)\<notin>it"
      moreover note MEM
      ultimately show False by simp
    qed

    have "\<alpha> (g_restrict P m) = \<alpha> m |` {k. \<exists>v. \<alpha> m k = Some v \<and> P (k, v)} \<and>
      invar (g_restrict P m)"
      unfolding g_restrict_def
      apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma>
        \<and> map_to_set (\<alpha> \<sigma>) = it \<inter> Collect P"
        in iterate_rule_insert_P)
      apply (auto simp: I empty_correct update_dj_correct map_to_set_def AUX)
      apply (auto split: split_if_asm)
      apply (rule ext)
      apply (auto simp: Map.restrict_map_def)
      apply force
      apply (rule ccontr)
      apply force
      done
    thus "\<alpha> (g_restrict P m) = \<alpha> m |` {k. \<exists>v. \<alpha> m k = Some v \<and> P (k, v)}"
      "invar (g_restrict P m)" by auto
  qed

context StdBasicOMapDefs
begin
  definition
    "g_min m P \<equiv>
      iterateoi m (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. if P x then Some x else None) None"

  definition
    "g_max m P \<equiv>
      rev_iterateoi m (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. if P x then Some x else None) None"

  definition "g_to_sorted_list m \<equiv> rev_iterateo m (op #) []"
  definition "g_to_rev_list m \<equiv> iterateo m (op #) []"

  definition dflt_oops :: "('k,'v,'s) omap_ops"
    where [icf_rec_def]:
    "dflt_oops \<equiv> map_ops.extend dflt_ops
      \<lparr>
        map_op_ordered_list_it = ordered_list_it,
        map_op_rev_list_it = rev_list_it,
        map_op_min = g_min,
        map_op_max = g_max,
        map_op_to_sorted_list = g_to_sorted_list,
        map_op_to_rev_list = g_to_rev_list
      \<rparr>"
  local_setup {* Locale_Code.lc_decl_del @{term dflt_oops}*}

end

context StdBasicOMap
begin
  lemma g_min_impl: "map_min \<alpha> invar g_min"
  proof
    fix m P

    assume I: "invar m"

    from iterateoi_correct[OF I]
    have iti': "map_iterator_linord (iterateoi m) (\<alpha> m)" by simp
    note sel_correct = iterate_sel_no_map_map_linord_correct[OF iti', of P]

    have A: "g_min m P = iterate_sel_no_map (iterateoi m) P"
      unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp

    { assume "rel_of (\<alpha> m) P \<noteq> {}"
      with sel_correct
      show "g_min m P \<in> Some ` rel_of (\<alpha> m) P"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { assume "rel_of (\<alpha> m) P = {}"
       with sel_correct show "g_min m P = None"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { fix k v
      assume "(k, v) \<in> rel_of (\<alpha> m) P"
      with sel_correct show "fst (the (g_min m P)) \<le> k"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }
  qed

  lemma g_max_impl: "map_max \<alpha> invar g_max"
  proof
    fix m P

    assume I: "invar m"

    from rev_iterateoi_correct[OF I]
    have iti': "map_iterator_rev_linord (rev_iterateoi m) (\<alpha> m)" by simp
    note sel_correct = iterate_sel_no_map_map_rev_linord_correct[OF iti', of P]

    have A: "g_max m P = iterate_sel_no_map (rev_iterateoi m) P"
      unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp

    { assume "rel_of (\<alpha> m) P \<noteq> {}"
      with sel_correct
      show "g_max m P \<in> Some ` rel_of (\<alpha> m) P"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { assume "rel_of (\<alpha> m) P = {}"
       with sel_correct show "g_max m P = None"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { fix k v
      assume "(k, v) \<in> rel_of (\<alpha> m) P"
      with sel_correct show "fst (the (g_max m P)) \<ge> k"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }
  qed

  lemma g_to_sorted_list_impl: "map_to_sorted_list \<alpha> invar g_to_sorted_list"
  proof
    fix m
    assume I: "invar m"
    note iti = rev_iterateoi_correct[OF I]
    from iterate_to_list_map_rev_linord_correct[OF iti]
    show "sorted (map fst (g_to_sorted_list m))"
         "distinct (map fst (g_to_sorted_list m))"
         "map_of (g_to_sorted_list m) = \<alpha> m"
      unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
  qed

  lemma g_to_rev_list_impl: "map_to_rev_list \<alpha> invar g_to_rev_list"
  proof
    fix m
    assume I: "invar m"
    note iti = iterateoi_correct[OF I]
    from iterate_to_list_map_linord_correct[OF iti]
    show "sorted (rev (map fst (g_to_rev_list m)))"
         "distinct (map fst (g_to_rev_list m))"
         "map_of (g_to_rev_list m) = \<alpha> m"
      unfolding g_to_rev_list_def iterate_to_list_def
      by (simp_all add: rev_map)
  qed

  lemma dflt_oops_impl: "StdOMap dflt_oops"
  proof -
    interpret aux!: StdMap dflt_ops by (rule dflt_ops_impl)

    show ?thesis
      apply (rule StdOMap_intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule g_min_impl)
      apply (rule g_max_impl)
      apply (rule g_to_sorted_list_impl)
      apply (rule g_to_rev_list_impl)
      done
  qed

end

locale g_image_filter_defs_loc =
  m1!: StdMapDefs ops1 +
  m2!: StdMapDefs ops2
  for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
  definition "g_image_filter f m1 \<equiv> m1.iterate m1 (\<lambda>kv \<sigma>. case f kv of
      None => \<sigma>
    | Some (k',v') => m2.update_dj k' v' \<sigma>
    ) (m2.empty ())"
end

locale g_image_filter_loc = g_image_filter_defs_loc ops1 ops2 +
  m1!: StdMap ops1 +
  m2!: StdMap ops2
  for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
  lemma g_image_filter_impl:
    "map_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_image_filter"
  proof
    fix m k' v' and f :: "('k1 \<times> 'v1) \<Rightarrow> ('k2 \<times> 'v2) option"
    assume invar_m: "m1.invar m" and
           unique_f: "transforms_to_unique_keys (m1.\<alpha> m) f"

    have A: "g_image_filter f m =
      iterate_to_map m2.empty m2.update_dj (
        set_iterator_image_filter f (m1.iteratei m))"
      unfolding g_image_filter_def iterate_to_map_alt_def
        set_iterator_image_filter_def case_prod_beta
      by simp

    from m1.iteratei_correct[OF invar_m]
    have iti_m: "map_iterator (m1.iteratei m) (m1.\<alpha> m)" by simp

    from unique_f have inj_on_f: "inj_on f (map_to_set (m1.\<alpha> m) \<inter> dom f)"
      unfolding transforms_to_unique_keys_def inj_on_def Ball_def map_to_set_def
      by auto (metis option.inject)

    def vP \<equiv> "\<lambda>k v. \<exists>k' v'. m1.\<alpha> m k' = Some v' \<and> f (k', v') = Some (k, v)"
    have vP_intro: "\<And>k v. (\<exists>k' v'. m1.\<alpha> m k' = Some v'
        \<and> f (k', v') = Some (k, v)) \<longleftrightarrow> vP k v"
      unfolding vP_def by simp
    { fix k v
      have "Eps_Opt (vP k) = Some v \<longleftrightarrow> vP k v"
        using unique_f unfolding vP_def transforms_to_unique_keys_def
        apply (rule_tac Eps_Opt_eq_Some)
        apply (metis Pair_eq option.inject)
      done
    } note Eps_vP_elim[simp] = this
    have map_intro: "{y. \<exists>x. x \<in> map_to_set (m1.\<alpha> m) \<and> f x = Some y}
      = map_to_set (\<lambda>k. Eps_Opt (vP k))"
      by (simp add: map_to_set_def vP_intro set_eq_iff split: prod.splits)

    from set_iterator_image_filter_correct [OF iti_m, OF inj_on_f,
      unfolded map_intro]
    have iti_filter: "map_iterator (set_iterator_image_filter f (m1.iteratei m))
          (\<lambda>k. Eps_Opt (vP k))" by auto

    have upd: "map_update_dj m2.\<alpha> m2.invar m2.update_dj" by unfold_locales
    have emp: "map_empty m2.\<alpha> m2.invar m2.empty" by unfold_locales

    from iterate_to_map_correct[OF upd emp iti_filter] show
      "map_op_invar ops2 (g_image_filter f m) \<and>
          (map_op_\<alpha> ops2 (g_image_filter f m) k' = Some v') =
          (\<exists>k v. map_op_\<alpha> ops1 m k = Some v \<and> f (k, v) = Some (k', v'))"
      unfolding A vP_def[symmetric]
      by (simp add: vP_intro)

  qed
end

sublocale g_image_filter_loc
  < map_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_image_filter
  by (rule g_image_filter_impl)

locale g_value_image_filter_defs_loc =
  m1!: StdMapDefs ops1 +
  m2!: StdMapDefs ops2
  for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
  definition "g_value_image_filter f m1 \<equiv> m1.iterate m1 (\<lambda>(k,v) \<sigma>.
    case f k v of
      None => \<sigma>
    | Some v' => m2.update_dj k v' \<sigma>
    ) (m2.empty ())"

end

(* TODO: Move to Misc *)
lemma restrict_map_dom_subset: "\<lbrakk> dom m \<subseteq> R\<rbrakk> \<Longrightarrow> m|`R = m"
  apply (rule ext)
  apply (auto simp: restrict_map_def)
  apply (case_tac "m x")
  apply auto
  done

locale g_value_image_filter_loc = g_value_image_filter_defs_loc ops1 ops2 +
  m1!: StdMap ops1 +
  m2!: StdMap ops2
  for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
  lemma g_value_image_filter_impl:
    "map_value_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_value_image_filter"
    apply unfold_locales
    unfolding g_value_image_filter_def
    apply (rule_tac I="\<lambda>it \<sigma>. m2.invar \<sigma>
      \<and> m2.\<alpha> \<sigma> = (\<lambda>k. Option.bind (map_op_\<alpha> ops1 m k) (f k)) |` it"
      in m1.old_iterate_rule_insert_P)

    apply auto []
    apply (auto simp: m2.empty_correct) []
    defer
    apply simp []
    apply (rule restrict_map_dom_subset)
    apply (auto) []
    apply (case_tac "m1.\<alpha> m x")
    apply (auto) [2]

    apply (auto split: option.split simp: m2.update_dj_correct intro!: ext)
    apply (auto simp: restrict_map_def)
    done
end

sublocale g_value_image_filter_loc
  < map_value_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_value_image_filter
  by (rule g_value_image_filter_impl)

end


section \<open>Syntactic Criteria\<close>
theory Syntactic_Criteria
  imports Compositionality
begin

context PL_Indis
begin

lemma proper_intros[intro]:
  "proper Done"
  "proper (Atm atm)"
  "proper c1 \<Longrightarrow> proper c2 \<Longrightarrow> proper (Seq c1 c2)"
  "proper c1 \<Longrightarrow> proper c2 \<Longrightarrow> proper (Ch ch c1 c2)"
  "proper c \<Longrightarrow> proper (While tst c)"
  "properL cs \<Longrightarrow> proper (Par cs)"
  "properL cs \<Longrightarrow> proper (ParT cs)"
  "(\<And>c. c \<in> set cs \<Longrightarrow> proper c) \<Longrightarrow> cs \<noteq> [] \<Longrightarrow> properL cs"
  by auto

lemma discr:
  "discr Done"
  "presAtm atm \<Longrightarrow> discr (Atm atm)"
  "discr c1 \<Longrightarrow> discr c2 \<Longrightarrow> discr (Seq c1 c2)"
  "discr c1 \<Longrightarrow> discr c2 \<Longrightarrow> discr (Ch ch c1 c2)"
  "discr c \<Longrightarrow> discr (While tst c)"
  "properL cs \<Longrightarrow> (\<And>c. c \<in> set cs \<Longrightarrow> discr c) \<Longrightarrow> discr (Par cs)"
  "properL cs \<Longrightarrow> (\<And>c. c \<in> set cs \<Longrightarrow> discr c) \<Longrightarrow> discr (ParT cs)"
  by (auto intro!: discr_Par discr_ParT)

lemma siso:
  "compatAtm atm \<Longrightarrow> siso (Atm atm)"
  "siso c1 \<Longrightarrow> siso c2 \<Longrightarrow> siso (Seq c1 c2)"
  "compatCh ch \<Longrightarrow> siso c1 \<Longrightarrow> siso c2 \<Longrightarrow> siso (Ch ch c1 c2)"
  "compatTst tst \<Longrightarrow> siso c \<Longrightarrow> siso (While tst c)"
  "properL cs \<Longrightarrow> (\<And>c. c \<in> set cs \<Longrightarrow> siso c) \<Longrightarrow> siso (Par cs)"
  "properL cs \<Longrightarrow> (\<And>c. c \<in> set cs \<Longrightarrow> siso c) \<Longrightarrow> siso (ParT cs)"
  by (auto intro!: siso_Par siso_ParT)

lemma Sbis:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>s Atm atm"
  "siso c1 \<Longrightarrow> c2 \<approx>s c2 \<Longrightarrow> Seq c1 c2 \<approx>s Seq c1 c2"
  "proper c1 \<Longrightarrow> proper c2 \<Longrightarrow> c1 \<approx>s c1 \<Longrightarrow> discr c2 \<Longrightarrow> Seq c1 c2 \<approx>s Seq c1 c2"
  "compatCh ch \<Longrightarrow> c1 \<approx>s c1 \<Longrightarrow> c2 \<approx>s c2 \<Longrightarrow> Ch ch c1 c2 \<approx>s Ch ch c1 c2"
  "properL cs \<Longrightarrow> (\<And>c. c \<in> set cs \<Longrightarrow> c \<approx>s c) \<Longrightarrow> Par cs \<approx>s Par cs"
  by (auto intro!: Par_Sbis)

lemma ZObis:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>01 Atm atm"
  "siso c1 \<Longrightarrow> c2 \<approx>01 c2 \<Longrightarrow> Seq c1 c2 \<approx>01 Seq c1 c2"
  "proper c1 \<Longrightarrow> proper c2 \<Longrightarrow> c1 \<approx>01 c1 \<Longrightarrow> discr c2 \<Longrightarrow> Seq c1 c2 \<approx>01 Seq c1 c2"
  "compatCh ch \<Longrightarrow> c1 \<approx>01 c1 \<Longrightarrow> c2 \<approx>01 c2 \<Longrightarrow> Ch ch c1 c2 \<approx>01 Ch ch c1 c2"
  "properL cs \<Longrightarrow> (\<And>c. c \<in> set cs \<Longrightarrow> c \<approx>s c) \<Longrightarrow> ParT cs \<approx>01 ParT cs"
  by (auto intro!: ParT_ZObis)

lemma discr_imp_Sbis: "proper c \<Longrightarrow> discr c \<Longrightarrow> c \<approx>s c"
  by auto

lemma siso_imp_Sbis: "siso c \<Longrightarrow> c \<approx>s c"
  by auto

lemma Sbis_imp_ZObis: "c \<approx>s c \<Longrightarrow> c \<approx>01 c"
  by auto

(* The syntactic predicates: SC_\<phi> corresponds to the paper's overlined \<phi>: *)

fun SC_discr where
  "SC_discr Done          \<longleftrightarrow> True"
| "SC_discr (Atm atm)     \<longleftrightarrow> presAtm atm"
| "SC_discr (Seq c1 c2)   \<longleftrightarrow> SC_discr c1 \<and> SC_discr c2"
| "SC_discr (Ch ch c1 c2) \<longleftrightarrow> SC_discr c1 \<and> SC_discr c2"
| "SC_discr (While tst c) \<longleftrightarrow> SC_discr c"
| "SC_discr (ParT cs) \<longleftrightarrow> (\<forall>c\<in>set cs. SC_discr c)"
| "SC_discr (Par cs)  \<longleftrightarrow> (\<forall>c\<in>set cs. SC_discr c)"

theorem SC_discr_discr[intro]: "proper c \<Longrightarrow> SC_discr c \<Longrightarrow> discr c"
  by (induct c) (auto intro!: discr)

fun SC_siso where
  "SC_siso Done           \<longleftrightarrow> True"
| "SC_siso (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_siso (Seq c1 c2)    \<longleftrightarrow> SC_siso c1 \<and> SC_siso c2"
| "SC_siso (Ch ch c1 c2)  \<longleftrightarrow> compatCh ch \<and> SC_siso c1 \<and> SC_siso c2"
| "SC_siso (While tst c)  \<longleftrightarrow> compatTst tst \<and> SC_siso c"
| "SC_siso (Par cs)   \<longleftrightarrow> (\<forall>c\<in>set cs. SC_siso c)"
| "SC_siso (ParT cs)  \<longleftrightarrow> (\<forall>c\<in>set cs. SC_siso c)"

theorem SC_siso_siso[intro]: "proper c \<Longrightarrow> SC_siso c \<Longrightarrow> siso c"
  by (induct c) (auto intro!: siso)

fun SC_Sbis where
  "SC_Sbis Done           \<longleftrightarrow> True"
| "SC_Sbis (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_Sbis (Seq c1 c2)    \<longleftrightarrow> (SC_siso c1 \<and> SC_Sbis c2) \<or>
                             (SC_Sbis c1 \<and> SC_discr c2) \<or>
                             SC_discr (Seq c1 c2) \<or> SC_siso (Seq c1 c2)"
| "SC_Sbis (Ch ch c1 c2)  \<longleftrightarrow> (if compatCh ch
                             then SC_Sbis c1 \<and> SC_Sbis c2
                             else (SC_discr (Ch ch c1 c2) \<or> SC_siso (Ch ch c1 c2)))"
| "SC_Sbis (While tst c)  \<longleftrightarrow> SC_discr (While tst c) \<or> SC_siso (While tst c)"
| "SC_Sbis (Par cs)   \<longleftrightarrow> (\<forall>c\<in>set cs. SC_Sbis c)"
| "SC_Sbis (ParT cs)  \<longleftrightarrow> SC_siso (ParT cs) \<or> SC_discr (ParT cs)"

theorem SC_siso_SCbis[intro]: "SC_siso c \<Longrightarrow> SC_Sbis c"
  by (induct c) auto

theorem SC_discr_SCbis[intro]: "SC_discr c \<Longrightarrow> SC_Sbis c"
  by (induct c) auto

declare SC_siso.simps[simp del]

declare SC_discr.simps[simp del]

theorem SC_Sbis_Sbis[intro]: "proper c \<Longrightarrow> SC_Sbis c \<Longrightarrow> c \<approx>s c"
  by (induct c)
     (auto intro: Sbis discr_imp_Sbis siso_imp_Sbis
           split: if_split_asm)

fun SC_ZObis where
  "SC_ZObis Done           \<longleftrightarrow> True"
| "SC_ZObis (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_ZObis (Seq c1 c2)    \<longleftrightarrow> (SC_siso c1 \<and> SC_ZObis c2) \<or>
                             (SC_ZObis c1 \<and> SC_discr c2) \<or>
                             SC_Sbis (Seq c1 c2)"
| "SC_ZObis (Ch ch c1 c2)  \<longleftrightarrow> (if compatCh ch
                             then SC_ZObis c1 \<and> SC_ZObis c2
                             else SC_Sbis (Ch ch c1 c2))"
| "SC_ZObis (While tst c)  \<longleftrightarrow> SC_Sbis (While tst c)"
| "SC_ZObis (Par cs)   \<longleftrightarrow> SC_Sbis (Par cs)"
| "SC_ZObis (ParT cs)  \<longleftrightarrow> (\<forall>c\<in>set cs. SC_Sbis c)"

theorem SC_Sbis_SC_ZObis[intro]: "SC_Sbis c \<Longrightarrow> SC_ZObis c"
  by (induct c) (auto simp: SC_siso.simps SC_discr.simps)

declare SC_Sbis.simps[simp del]

theorem SC_ZObis_ZObis: "proper c \<Longrightarrow> SC_ZObis c \<Longrightarrow> c \<approx>01 c"
  apply (induct c)
  apply (auto intro: Sbis_imp_ZObis ZObis split: if_split_asm)
  apply (auto intro!: ZObis(5))
  done

end

end