(* Author: Andreas Lochbihler, ETH Zurich
   Author: Joshua Schneider, ETH Zurich *)

section \<open>Axiomatisation\<close>

theory Axiomatised_BNF_CC imports
  Preliminaries
  "HOL-Library.Rewrite"
begin

unbundle cardinal_syntax

text \<open>
  This theory axiomatises two \BNFCC{}s, which will be used to demonstrate the closedness of \BNFCC{}s
  under various operations.
\<close>

subsection \<open>First abstract \BNFCC{}\<close>

subsubsection \<open>Axioms and basic definitions\<close>

typedecl ('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F

text \<open>@{type F} has each three live, co-, and contravariant parameters, and one fixed parameter.\<close>

consts
  rel_F :: "('l1 \<Rightarrow> 'l1' \<Rightarrow> bool) \<Rightarrow> ('l2 \<Rightarrow> 'l2' \<Rightarrow> bool) \<Rightarrow> ('l3 \<Rightarrow> 'l3' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co3 \<Rightarrow> 'co3' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow>
    ('contra3 \<Rightarrow> 'contra3' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F \<Rightarrow>
    ('l1', 'l2', 'l3', 'co1', 'co2', 'co3', 'contra1', 'contra2', 'contra3', 'f) F \<Rightarrow> bool"
  map_F :: "('l1 \<Rightarrow> 'l1') \<Rightarrow> ('l2 \<Rightarrow> 'l2') \<Rightarrow> ('l3 \<Rightarrow> 'l3') \<Rightarrow>
    ('co1 \<Rightarrow> 'co1') \<Rightarrow> ('co2 \<Rightarrow> 'co2') \<Rightarrow> ('co3 \<Rightarrow> 'co3') \<Rightarrow>
    ('contra1' \<Rightarrow> 'contra1) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2) \<Rightarrow> ('contra3' \<Rightarrow> 'contra3) \<Rightarrow>
    ('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F \<Rightarrow>
    ('l1', 'l2', 'l3', 'co1', 'co2', 'co3', 'contra1', 'contra2', 'contra3', 'f) F"

axiomatization where
  rel_F_mono [mono]:
  "\<And>L1 L1' L2 L2' L3 L3' Co1 Co1' Co2 Co2' Co3 Co3'
    Contra1 Contra1' Contra2 Contra2' Contra3 Contra3'.
    \<lbrakk> L1 \<le> L1'; L2 \<le> L2'; L3 \<le> L3'; Co1 \<le> Co1'; Co2 \<le> Co2'; Co3 \<le> Co3';
      Contra1' \<le> Contra1; Contra2' \<le> Contra2; Contra3' \<le> Contra3 \<rbrakk> \<Longrightarrow>
    rel_F L1 L2 L3 Co1 Co2 Co3 Contra1 Contra2 Contra3 \<le>
    rel_F L1' L2' L3' Co1' Co2' Co3' Contra1' Contra2' Contra3'" and
  rel_F_eq: "rel_F (=) (=) (=) (=) (=) (=) (=) (=) (=) = (=)" and
  rel_F_conversep: "\<And>L1 L2 L3 Co1 Co2 Co3 Contra1 Contra2 Contra3.
    rel_F L1\<inverse>\<inverse> L2\<inverse>\<inverse> L3\<inverse>\<inverse> Co1\<inverse>\<inverse> Co2\<inverse>\<inverse> Co3\<inverse>\<inverse> Contra1\<inverse>\<inverse> Contra2\<inverse>\<inverse> Contra3\<inverse>\<inverse> =
    (rel_F L1 L2 L3 Co1 Co2 Co3 Contra1 Contra2 Contra3)\<inverse>\<inverse>" and
  map_F_id0: "map_F id id id id id id id id id = id" and
  map_F_comp: "\<And>l1 l1' l2 l2' l3 l3' co1 co1' co2 co2' co3 co3'
    contra1 contra1' contra2 contra2' contra3 contra3'.
    map_F l1 l2 l3 co1 co2 co3 contra1 contra2 contra3 \<circ>
      map_F l1' l2' l3' co1' co2' co3' contra1' contra2' contra3' =
    map_F (l1 \<circ> l1') (l2 \<circ> l2') (l3 \<circ> l3') (co1 \<circ> co1') (co2 \<circ> co2') (co3 \<circ> co3')
      (contra1' \<circ> contra1) (contra2' \<circ> contra2) (contra3' \<circ> contra3)" and
  map_F_parametric:
  "\<And>L1 L1' L2 L2' L3 L3' Co1 Co1' Co2 Co2' Co3 Co3'
    Contra1 Contra1' Contra2 Contra2' Contra3 Contra3'.
    rel_fun (rel_fun L1 L1') (rel_fun (rel_fun L2 L2') (rel_fun (rel_fun L3 L3')
      (rel_fun (rel_fun Co1 Co1') (rel_fun (rel_fun Co2 Co2') (rel_fun (rel_fun Co3 Co3')
      (rel_fun (rel_fun Contra1' Contra1) (rel_fun (rel_fun Contra2' Contra2)
      (rel_fun (rel_fun Contra3' Contra3)
      (rel_fun (rel_F L1 L2 L3 Co1 Co2 Co3 Contra1 Contra2 Contra3)
      (rel_F L1' L2' L3' Co1' Co2' Co3' Contra1' Contra2' Contra3')))))))))) map_F map_F"

definition rel_F_pos_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('co3 \<Rightarrow> 'co3' \<Rightarrow> bool) \<Rightarrow> ('co3' \<Rightarrow> 'co3'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra3 \<Rightarrow> 'contra3' \<Rightarrow> bool) \<Rightarrow> ('contra3' \<Rightarrow> 'contra3'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'l3 \<times> 'l3' \<times> 'l3'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_F_pos_distr_cond Co1 Co1' Co2 Co2' Co3 Co3'
    Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool)
    (L2 :: 'l2 \<Rightarrow> 'l2' \<Rightarrow> bool) (L2' :: 'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool)
    (L3 :: 'l3 \<Rightarrow> 'l3' \<Rightarrow> bool) (L3' :: 'l3' \<Rightarrow> 'l3'' \<Rightarrow> bool).
    (rel_F L1 L2 L3 Co1 Co2 Co3 Contra1 Contra2 Contra3 ::
      (_, _, _, _, _, _, _, _, _, 'f) F \<Rightarrow> _) OO
      rel_F L1' L2' L3' Co1' Co2' Co3' Contra1' Contra2' Contra3' \<le>
    rel_F (L1 OO L1') (L2 OO L2') (L3 OO L3') (Co1 OO Co1') (Co2 OO Co2') (Co3 OO Co3')
      (Contra1 OO Contra1') (Contra2 OO Contra2') (Contra3 OO Contra3'))"

definition rel_F_neg_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('co3 \<Rightarrow> 'co3' \<Rightarrow> bool) \<Rightarrow> ('co3' \<Rightarrow> 'co3'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra3 \<Rightarrow> 'contra3' \<Rightarrow> bool) \<Rightarrow> ('contra3' \<Rightarrow> 'contra3'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'l3 \<times> 'l3' \<times> 'l3'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_F_neg_distr_cond Co1 Co1' Co2 Co2' Co3 Co3'
    Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool)
    (L2 :: 'l2 \<Rightarrow> 'l2' \<Rightarrow> bool) (L2' :: 'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool)
    (L3 :: 'l3 \<Rightarrow> 'l3' \<Rightarrow> bool) (L3' :: 'l3' \<Rightarrow> 'l3'' \<Rightarrow> bool).
    rel_F (L1 OO L1') (L2 OO L2') (L3 OO L3') (Co1 OO Co1') (Co2 OO Co2') (Co3 OO Co3')
      (Contra1 OO Contra1') (Contra2 OO Contra2') (Contra3 OO Contra3') \<le>
    (rel_F L1 L2 L3 Co1 Co2 Co3 Contra1 Contra2 Contra3 ::
      (_, _, _, _, _, _, _, _, _, 'f) F \<Rightarrow> _) OO
      rel_F L1' L2' L3' Co1' Co2' Co3' Contra1' Contra2' Contra3')"

axiomatization where
  rel_F_pos_distr_cond_eq:
  "\<And>tytok. rel_F_pos_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) (=) (=) (=) (=) tytok"
  and
  rel_F_neg_distr_cond_eq:
  "\<And>tytok. rel_F_neg_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) (=) (=) (=) (=) tytok"

text \<open>Restrictions to live variables.\<close>

definition "rell_F L1 L2 L3 = rel_F L1 L2 L3 (=) (=) (=) (=) (=) (=)"
definition "mapl_F l1 l2 l3 = map_F l1 l2 l3 id id id id id id"

typedecl ('co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) Fbd

consts
  set1_F :: "('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F \<Rightarrow> 'l1 set"
  set2_F :: "('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F \<Rightarrow> 'l2 set"
  set3_F :: "('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F \<Rightarrow> 'l3 set"
  bd_F :: "('co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) Fbd rel"

axiomatization where
  set1_F_map: "\<And>l1 l2 l3. set1_F \<circ> mapl_F l1 l2 l3 = image l1 \<circ> set1_F" and
  set2_F_map: "\<And>l1 l2 l3. set2_F \<circ> mapl_F l1 l2 l3 = image l2 \<circ> set2_F" and
  set3_F_map: "\<And>l1 l2 l3. set3_F \<circ> mapl_F l1 l2 l3 = image l3 \<circ> set3_F" and
  bd_F_card_order: "card_order bd_F" and
  bd_F_cinfinite: "cinfinite bd_F" and
  set1_F_bound: "\<And>x :: (_, _, _, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F.
    card_of (set1_F x) \<le>o (bd_F :: ('co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) Fbd rel)" and
  set2_F_bound: "\<And>x :: (_, _, _, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F.
    card_of (set2_F x) \<le>o (bd_F :: ('co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) Fbd rel)" and
  set3_F_bound: "\<And>x :: (_, _, _, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F.
    card_of (set3_F x) \<le>o (bd_F :: ('co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) Fbd rel)" and
  mapl_F_cong: "\<And>l1 l1' l2 l2' l3 l3' x.
    \<lbrakk> \<And>z. z \<in> set1_F x \<Longrightarrow> l1 z = l1' z; \<And>z. z \<in> set2_F x \<Longrightarrow> l2 z = l2' z;
      \<And>z. z \<in> set3_F x \<Longrightarrow> l3 z = l3' z \<rbrakk> \<Longrightarrow>
    mapl_F l1 l2 l3 x = mapl_F l1' l2' l3' x" and
  rell_F_mono_strong: "\<And>L1 L1' L2 L2' L3 L3' x y.
    \<lbrakk> rell_F L1 L2 L3 x y;
      \<And>a b. a \<in> set1_F x \<Longrightarrow> b \<in> set1_F y \<Longrightarrow> L1 a b \<Longrightarrow> L1' a b;
      \<And>a b. a \<in> set2_F x \<Longrightarrow> b \<in> set2_F y \<Longrightarrow> L2 a b \<Longrightarrow> L2' a b;
      \<And>a b. a \<in> set3_F x \<Longrightarrow> b \<in> set3_F y \<Longrightarrow> L3 a b \<Longrightarrow> L3' a b \<rbrakk> \<Longrightarrow>
    rell_F L1' L2' L3' x y"

subsubsection \<open>Derived rules\<close>

lemmas rel_F_mono' = rel_F_mono[THEN predicate2D, rotated -1]

lemma rel_F_eq_refl: "rel_F (=) (=) (=) (=) (=) (=) (=) (=) (=) x x"
  by (simp add: rel_F_eq)

lemma map_F_id: "map_F id id id id id id id id id x = x"
  by (simp add: map_F_id0)

lemmas map_F_rel_cong = map_F_parametric[unfolded rel_fun_def, rule_format, rotated -1]

lemma rell_F_mono: "\<lbrakk> L1 \<le> L1'; L2 \<le> L2'; L3 \<le> L3' \<rbrakk> \<Longrightarrow> rell_F L1 L2 L3 \<le> rell_F L1' L2' L3'"
  unfolding rell_F_def by (rule rel_F_mono) (auto)

lemma mapl_F_id0: "mapl_F id id id = id"
  unfolding mapl_F_def using map_F_id0 .

lemma mapl_F_id: "mapl_F id id id x = x"
  by (simp add: mapl_F_id0)

lemma mapl_F_comp: "mapl_F l1 l2 l3 \<circ> mapl_F l1' l2' l3' = mapl_F (l1 \<circ> l1') (l2 \<circ> l2') (l3 \<circ> l3')"
  unfolding mapl_F_def
  apply (rule trans)
   apply (rule map_F_comp)
  apply (simp)
  done

lemma map_F_mapl_F: "map_F l1 l2 l3 co1 co2 co3 contra1 contra2 contra3 x =
  map_F id id id co1 co2 co3 contra1 contra2 contra3 (mapl_F l1 l2 l3 x)"
  unfolding mapl_F_def map_F_comp[THEN fun_cong, simplified] by simp

lemma mapl_F_map_F: "mapl_F l1 l2 l3 (map_F id id id co1 co2 co3 contra1 contra2 contra3 x) =
  map_F l1 l2 l3 co1 co2 co3 contra1 contra2 contra3 x"
  unfolding mapl_F_def map_F_comp[THEN fun_cong, simplified] by simp

text \<open>Parametric mappers are unique:\<close>

lemma rel_F_Grp_weak: "rel_F (Grp UNIV l1) (Grp UNIV l2) (Grp UNIV l3)
    (Grp UNIV co1) (Grp UNIV co2) (Grp UNIV co3)
    (Grp UNIV contra1)\<inverse>\<inverse> (Grp UNIV contra2)\<inverse>\<inverse> (Grp UNIV contra3)\<inverse>\<inverse> =
  Grp UNIV (map_F l1 l2 l3 co1 co2 co3 contra1 contra2 contra3)"
  apply (rule antisym)
   apply (rule predicate2I)
   apply (rule GrpI)
    apply (rewrite in "_ = \<hole>" map_F_id[symmetric])
    apply (subst rel_F_eq[symmetric])
    apply (erule map_F_rel_cong; simp add: Grp_def)
   apply (rule UNIV_I)
  apply (rule predicate2I)
  apply (erule GrpE)
  apply (drule sym)
  apply (hypsubst)
  apply (rewrite in "rel_F _ _ _ _ _ _ _ _ _ \<hole>" map_F_id[symmetric])
  apply (rule map_F_rel_cong)
           apply (rule rel_F_eq_refl)
          apply (simp_all add: Grp_def)
  done

lemmas
  rel_F_pos_distr = rel_F_pos_distr_cond_def[THEN iffD1, rule_format] and
  rel_F_neg_distr = rel_F_neg_distr_cond_def[THEN iffD1, rule_format]

lemma rell_F_compp:
  "rell_F (L1 OO L1') (L2 OO L2') (L3 OO L3') = rell_F L1 L2 L3 OO rell_F L1' L2' L3'"
  unfolding rell_F_def
  apply (rule antisym)
   apply (rule order_trans[rotated])
    apply (rule rel_F_neg_distr)
    apply (rule rel_F_neg_distr_cond_eq)
   apply (simp add: eq_OO)
  apply (rule order_trans)
   apply (rule rel_F_pos_distr)
   apply (rule rel_F_pos_distr_cond_eq)
  apply (simp add: eq_OO)
  done

subsubsection \<open>F is a BNF\<close>

lemma rell_F_eq_onp: "rell_F (eq_onp P1) (eq_onp P2) (eq_onp P3) =
  eq_onp (\<lambda>x. (\<forall>z\<in>set1_F x. P1 z) \<and> (\<forall>z\<in>set2_F x. P2 z) \<and> (\<forall>z\<in>set3_F x. P3 z))"
  (is "?rel_eq_onp = ?eq_onp_pred")
proof (intro ext iffI)
  fix x y
  assume rel: "?rel_eq_onp x y"
  from rel have "rell_F (=) (=) (=) x y"
    unfolding rell_F_def by (auto elim: rel_F_mono' simp add: eq_onp_def)
  then have "y = x" unfolding rell_F_def rel_F_eq ..
  let ?true = "\<lambda>_. True" and ?label = "\<lambda>P x. P x"
  from rel have "rell_F (=) (=) (=) (mapl_F ?true ?true ?true x)
    (mapl_F (?label P1) (?label P2) (?label P3) x)"
    unfolding rell_F_def mapl_F_def \<open>y = x\<close>
    by (auto simp add: eq_onp_def elim: map_F_rel_cong)
  then have *: "mapl_F ?true ?true ?true x = mapl_F (?label P1) (?label P2) (?label P3) x"
    unfolding rell_F_def rel_F_eq .
  note \<open>y = x\<close>
  moreover {
    from *
    have "set1_F (mapl_F ?true ?true ?true x) = set1_F (mapl_F (?label P1) (?label P2) (?label P3) x)"
      by simp
    then have "?true ` set1_F x = ?label P1 ` set1_F x"
      unfolding set1_F_map[THEN fun_cong, simplified] .
    then have "\<forall>z\<in>set1_F x. P1 z" by auto
  }
  moreover {
    from *
    have "set2_F (mapl_F ?true ?true ?true x) = set2_F (mapl_F (?label P1) (?label P2) (?label P3) x)"
      by simp
    then have "?true ` set2_F x = ?label P2 ` set2_F x"
      unfolding set2_F_map[THEN fun_cong, simplified] .
    then have "\<forall>z\<in>set2_F x. P2 z" by auto
  }
  moreover {
    from *
    have "set3_F (mapl_F ?true ?true ?true x) = set3_F (mapl_F (?label P1) (?label P2) (?label P3) x)"
      by simp
    then have "?true ` set3_F x = ?label P3 ` set3_F x"
      unfolding set3_F_map[THEN fun_cong, simplified] .
    then have "\<forall>z\<in>set3_F x. P3 z" by auto
  }
  ultimately show "?eq_onp_pred x y" by (simp add: eq_onp_def)
next
  fix x y
  assume eq_onp: "?eq_onp_pred x y"
  then have "rell_F (=) (=) (=) x y"
    by (auto simp add: rell_F_def rel_F_eq eq_onp_def)
  then show "?rel_eq_onp x y"
    using eq_onp by (auto elim!: rell_F_mono_strong simp add: eq_onp_def)
qed

lemma rell_F_Grp: "rell_F (Grp A1 f1) (Grp A2 f2) (Grp A3 f3) =
  Grp {x. set1_F x \<subseteq> A1 \<and> set2_F x \<subseteq> A2 \<and> set3_F x \<subseteq> A3} (mapl_F f1 f2 f3)"
proof -
  have "rell_F (Grp A1 f1) (Grp A2 f2) (Grp A3 f3) = rell_F (eq_onp (\<lambda>x. x \<in> A1) OO Grp UNIV f1)
    (eq_onp (\<lambda>x. x \<in> A2) OO Grp UNIV f2) (eq_onp (\<lambda>x. x \<in> A3) OO Grp UNIV f3)"
    by (simp add: eq_onp_compp_Grp)
  also have "... = rell_F (eq_onp (\<lambda>x. x \<in> A1)) (eq_onp (\<lambda>x. x \<in> A2)) (eq_onp (\<lambda>x. x \<in> A3)) OO
    rell_F (Grp UNIV f1) (Grp UNIV f2) (Grp UNIV f3)"
    using rell_F_compp .
  also have "... = eq_onp (\<lambda>x. set1_F x \<subseteq> A1 \<and> set2_F x \<subseteq> A2 \<and> set3_F x \<subseteq> A3) OO
    rell_F (Grp UNIV f1) (Grp UNIV f2) (Grp UNIV f3)"
    by (simp add: rell_F_eq_onp subset_eq)
  also have "... = eq_onp (\<lambda>x. set1_F x \<subseteq> A1 \<and> set2_F x \<subseteq> A2 \<and> set3_F x \<subseteq> A3) OO
    Grp UNIV (mapl_F f1 f2 f3)"
    unfolding rell_F_def mapl_F_def
      rel_F_Grp_weak[of _ _ _ id id id id id id, folded eq_alt, simplified]
    ..
  also have "... = Grp {x. set1_F x \<subseteq> A1 \<and> set2_F x \<subseteq> A2 \<and> set3_F x \<subseteq> A3} (mapl_F f1 f2 f3)"
    by (simp add: eq_onp_compp_Grp)
  finally show ?thesis .
qed

lemma rell_F_compp_Grp: "rell_F L1 L2 L3 =
  (Grp {x. set1_F x \<subseteq> {(x, y). L1 x y} \<and> set2_F x \<subseteq> {(x, y). L2 x y} \<and> set3_F x \<subseteq> {(x, y). L3 x y}}
    (mapl_F fst fst fst))\<inverse>\<inverse> OO
  Grp {x. set1_F x \<subseteq> {(x, y). L1 x y} \<and> set2_F x \<subseteq> {(x, y). L2 x y} \<and> set3_F x \<subseteq> {(x, y). L3 x y}}
    (mapl_F snd snd snd)"
  apply (unfold rell_F_Grp[symmetric])
  apply (unfold rell_F_def)
  apply (simp add: rel_F_conversep[symmetric])
  apply (fold rell_F_def)
  apply (simp add: rell_F_compp[symmetric] Grp_fst_snd)
  done

lemma F_in_rell: "rell_F L1 L2 L3 = (\<lambda>x y. \<exists>z. (set1_F z \<subseteq> {(x, y). L1 x y} \<and>
  set2_F z \<subseteq> {(x, y). L2 x y} \<and> set3_F z \<subseteq> {(x, y). L3 x y}) \<and>
  mapl_F fst fst fst z = x \<and> mapl_F snd snd snd z = y)"
  using rell_F_compp_Grp by (simp add: OO_Grp_alt)

bnf "('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F"
  map: mapl_F
  sets: set1_F set2_F set3_F
  bd: "bd_F :: ('co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) Fbd rel"
  rel: rell_F
  by (fact mapl_F_id0 mapl_F_comp[symmetric] mapl_F_cong set1_F_map set2_F_map set3_F_map
    bd_F_card_order bd_F_cinfinite set1_F_bound set2_F_bound set3_F_bound
    rell_F_compp[symmetric, THEN eq_refl] F_in_rell)+

subsubsection \<open>Composition witness\<close>

consts
  rel_F_witness :: "('l1 \<Rightarrow> 'l1'' \<Rightarrow> bool) \<Rightarrow> ('l2 \<Rightarrow> 'l2'' \<Rightarrow> bool) \<Rightarrow> ('l3 \<Rightarrow> 'l3'' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('co3 \<Rightarrow> 'co3' \<Rightarrow> bool) \<Rightarrow> ('co3' \<Rightarrow> 'co3'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra3 \<Rightarrow> 'contra3' \<Rightarrow> bool) \<Rightarrow> ('contra3' \<Rightarrow> 'contra3'' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'l2, 'l3, 'co1, 'co2, 'co3, 'contra1, 'contra2, 'contra3, 'f) F \<times>
    ('l1'', 'l2'', 'l3'', 'co1'', 'co2'', 'co3'', 'contra1'', 'contra2'', 'contra3'', 'f) F \<Rightarrow>
    ('l1 \<times> 'l1'', 'l2 \<times> 'l2'', 'l3 \<times> 'l3'', 'co1', 'co2', 'co3', 'contra1', 'contra2', 'contra3',
      'f) F"

specification (rel_F_witness)
  rel_F_witness1: "\<And>L1 L2 L3 Co1 Co1' Co2 Co2' Co3 Co3'
    Contra1 Contra1' Contra2 Contra2' Contra3 Contra3'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times>
      'l3 \<times> ('l3 \<times> 'l3'') \<times> 'l3'' \<times> 'f) itself)
    (x :: ('l1, 'l2, 'l3, _, _, _, _, _, _, 'f) F)
    (y :: ('l1'', 'l2'', 'l3'', _, _, _, _, _, _, 'f) F).
    \<lbrakk> rel_F_neg_distr_cond Co1 Co1' Co2 Co2' Co3 Co3'
        Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' tytok;
      rel_F L1 L2 L3 (Co1 OO Co1') (Co2 OO Co2') (Co3 OO Co3')
          (Contra1 OO Contra1') (Contra2 OO Contra2') (Contra3 OO Contra3') x y \<rbrakk> \<Longrightarrow>
    rel_F (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y)
    (\<lambda>x (x', y). x' = x \<and> L3 x y) Co1 Co2 Co3 Contra1 Contra2 Contra3 x
    (rel_F_witness L1 L2 L3 Co1 Co1' Co2 Co2' Co3 Co3'
      Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' (x, y))"
  rel_F_witness2:"\<And>L1 L2 L3 Co1 Co1' Co2 Co2' Co3 Co3'
    Contra1 Contra1' Contra2 Contra2' Contra3 Contra3'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times>
      'l3 \<times> ('l3 \<times> 'l3'') \<times> 'l3'' \<times> 'f) itself)
    (x :: ('l1, 'l2, 'l3, _, _, _, _, _, _, 'f) F)
    (y :: ('l1'', 'l2'', 'l3'', _, _, _, _, _, _, 'f) F).
    \<lbrakk> rel_F_neg_distr_cond Co1 Co1' Co2 Co2' Co3 Co3'
        Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' tytok;
      rel_F L1 L2 L3 (Co1 OO Co1') (Co2 OO Co2') (Co3 OO Co3')
          (Contra1 OO Contra1') (Contra2 OO Contra2') (Contra3 OO Contra3') x y \<rbrakk> \<Longrightarrow>
    rel_F (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y)
    (\<lambda>(x, y') y. y' = y \<and> L3 x y) Co1' Co2' Co3' Contra1' Contra2' Contra3'
    (rel_F_witness L1 L2 L3 Co1 Co1' Co2 Co2' Co3 Co3'
       Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' (x, y)) y"
  apply(rule exI[where x="\<lambda>L1 L2 L3 Co1 Co1' Co2 Co2' Co3 Co3'
     Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' (x, y). SOME z.
     rel_F (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) (\<lambda>x (x', y). x' = x \<and> L3 x y)
      Co1 Co2 Co3 Contra1 Contra2 Contra3 x z \<and>
     rel_F (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) (\<lambda>(x, y') y. y' = y \<and> L3 x y)
      Co1' Co2' Co3' Contra1' Contra2' Contra3' z y"])
  apply(fold all_conj_distrib)
  apply(rule allI)+
  apply(fold imp_conjR)
  apply(rule impI)+
  apply clarify
  apply(rule someI_ex)
  subgoal for L1 L2 L3 Co1 Co1' Co2 Co2' Co3 Co3' Contra1 Contra1' Contra2 Contra2' Contra3 Contra3' x y
    apply(drule rel_F_neg_distr[where
          ?L1.0 = "\<lambda>x (x', y). x' = x \<and> L1 x y" and ?L1'.0 = "\<lambda>(x, y) y'. y = y' \<and> L1 x y'" and
          ?L2.0 = "\<lambda>x (x', y). x' = x \<and> L2 x y" and ?L2'.0 = "\<lambda>(x, y) y'. y = y' \<and> L2 x y'" and
          ?L3.0 = "\<lambda>x (x', y). x' = x \<and> L3 x y" and ?L3'.0 = "\<lambda>(x, y) y'. y = y' \<and> L3 x y'"])
    apply(drule predicate2D)
     apply(erule rel_F_mono[THEN predicate2D, rotated -1]; fastforce)
    apply(erule relcomppE)
    apply(rule exI conjI)+
     apply assumption+
    done
  done

subsection \<open>Second abstract \BNFCC{}\<close>

subsubsection \<open>Axioms and basic definitions\<close>

typedecl ('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G

text \<open>@{type G} has each two live, co, and contravariant parameters, and one fixed parameter.\<close>

consts
  rel_G :: "('l1 \<Rightarrow> 'l1' \<Rightarrow> bool) \<Rightarrow> ('l2 \<Rightarrow> 'l2' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G \<Rightarrow>
    ('l1', 'l2', 'co1', 'co2', 'contra1', 'contra2', 'f) G \<Rightarrow> bool"
  map_G :: "('l1 \<Rightarrow> 'l1') \<Rightarrow> ('l2 \<Rightarrow> 'l2') \<Rightarrow>
    ('co1 \<Rightarrow> 'co1') \<Rightarrow> ('co2 \<Rightarrow> 'co2') \<Rightarrow>
    ('contra1' \<Rightarrow> 'contra1) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2) \<Rightarrow>
    ('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G \<Rightarrow>
    ('l1', 'l2', 'co1', 'co2', 'contra1', 'contra2', 'f) G"

axiomatization where
  rel_G_mono [mono]:
  "\<And>L1 L1' L2 L2' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'.
    \<lbrakk> L1 \<le> L1'; L2 \<le> L2'; Co1 \<le> Co1'; Co2 \<le> Co2'; Contra1' \<le> Contra1; Contra2' \<le> Contra2 \<rbrakk> \<Longrightarrow>
    rel_G L1 L2 Co1 Co2 Contra1 Contra2 \<le> rel_G L1' L2' Co1' Co2' Contra1' Contra2'" and
  rel_G_eq: "rel_G (=) (=) (=) (=) (=) (=) = (=)" and
  rel_G_conversep: "\<And>L1 L2 Co1 Co2 Contra1 Contra2.
    rel_G L1\<inverse>\<inverse> L2\<inverse>\<inverse> Co1\<inverse>\<inverse> Co2\<inverse>\<inverse> Contra1\<inverse>\<inverse> Contra2\<inverse>\<inverse> = (rel_G L1 L2 Co1 Co2 Contra1 Contra2)\<inverse>\<inverse>" and
  map_G_id0: "map_G id id id id id id = id" and
  map_G_comp: "\<And>l1 l1' l2 l2' co1 co1' co2 co2' contra1 contra1' contra2 contra2'.
    map_G l1 l2 co1 co2 contra1 contra2 \<circ> map_G l1' l2' co1' co2' contra1' contra2' =
      map_G (l1 \<circ> l1') (l2 \<circ> l2') (co1 \<circ> co1') (co2 \<circ> co2')
      (contra1' \<circ> contra1) (contra2' \<circ> contra2)" and
  map_G_parametric:
  "\<And>L1 L1' L2 L2' Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'.
    rel_fun (rel_fun L1 L1') (rel_fun (rel_fun L2 L2')
      (rel_fun (rel_fun Co1 Co1') (rel_fun (rel_fun Co2 Co2')
      (rel_fun (rel_fun Contra1' Contra1) (rel_fun (rel_fun Contra2' Contra2)
      (rel_fun (rel_G L1 L2 Co1 Co2 Contra1 Contra2)
      (rel_G L1' L2' Co1' Co2' Contra1' Contra2')))))))
      map_G map_G"

definition rel_G_pos_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_G_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool)
    (L2 :: 'l2 \<Rightarrow> 'l2' \<Rightarrow> bool) (L2' :: 'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool).
    (rel_G L1 L2 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, _, 'f) G \<Rightarrow> _) OO
      rel_G L1' L2' Co1' Co2' Contra1' Contra2' \<le>
    rel_G (L1 OO L1') (L2 OO L2') (Co1 OO Co1') (Co2 OO Co2')
      (Contra1 OO Contra1') (Contra2 OO Contra2'))"

definition rel_G_neg_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'l2 \<times> 'l2' \<times> 'l2'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool)
    (L2 :: 'l2 \<Rightarrow> 'l2' \<Rightarrow> bool) (L2' :: 'l2' \<Rightarrow> 'l2'' \<Rightarrow> bool).
    rel_G (L1 OO L1') (L2 OO L2') (Co1 OO Co1') (Co2 OO Co2')
      (Contra1 OO Contra1') (Contra2 OO Contra2') \<le>
    (rel_G L1 L2 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, _, 'f) G \<Rightarrow> _) OO
      rel_G L1' L2' Co1' Co2' Contra1' Contra2')"

axiomatization where
  rel_G_pos_distr_cond_eq:
  "\<And>tytok. rel_G_pos_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok" and
  rel_G_neg_distr_cond_eq:
  "\<And>tytok. rel_G_neg_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"

text \<open>Restrictions to live variables.\<close>

definition "rell_G L1 L2 = rel_G L1 L2 (=) (=) (=) (=)"
definition "mapl_G l1 l2 = map_G l1 l2 id id id id"

typedecl ('co1, 'co2, 'contra1, 'contra2, 'f) Gbd

consts
  set1_G :: "('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G \<Rightarrow> 'l1 set"
  set2_G :: "('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G \<Rightarrow> 'l2 set"
  bd_G :: "('co1, 'co2, 'contra1, 'contra2, 'f) Gbd rel"
  wit_G :: "'l2 \<Rightarrow> ('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G"
    \<comment> \<open>non-emptiness witness for least fixpoint\<close>

axiomatization where
  set1_G_map: "\<And>l1 l2. set1_G \<circ> mapl_G l1 l2 = image l1 \<circ> set1_G" and
  set2_G_map: "\<And>l1 l2. set2_G \<circ> mapl_G l1 l2 = image l2 \<circ> set2_G" and
  bd_G_card_order: "card_order bd_G" and
  bd_G_cinfinite: "cinfinite bd_G" and
  set1_G_bound: "\<And>x :: (_, _, 'co1, 'co2, 'contra1, 'contra2, 'f) G.
    card_of (set1_G x) \<le>o (bd_G :: ('co1, 'co2, 'contra1, 'contra2, 'f) Gbd rel)" and
  set2_G_bound: "\<And>x :: (_, _, 'co1, 'co2, 'contra1, 'contra2, 'f) G.
    card_of (set2_G x) \<le>o (bd_G :: ('co1, 'co2, 'contra1, 'contra2, 'f) Gbd rel)" and
  mapl_G_cong: "\<And>l1 l1' l2 l2' l3 l3' x.
    \<lbrakk> \<And>z. z \<in> set1_G x \<Longrightarrow> l1 z = l1' z; \<And>z. z \<in> set2_G x \<Longrightarrow> l2 z = l2' z \<rbrakk> \<Longrightarrow>
    mapl_G l1 l2 x = mapl_G l1' l2' x" and
  rell_G_mono_strong: "\<And>L1 L1' L2 L2' x y.
    \<lbrakk> rell_G L1 L2 x y;
      \<And>a b. a \<in> set1_G x \<Longrightarrow> b \<in> set1_G y \<Longrightarrow> L1 a b \<Longrightarrow> L1' a b;
      \<And>a b. a \<in> set2_G x \<Longrightarrow> b \<in> set2_G y \<Longrightarrow> L2 a b \<Longrightarrow> L2' a b \<rbrakk> \<Longrightarrow>
    rell_G L1' L2' x y" and
  wit_G_set1: "\<And>l2 x. x \<in> set1_G (wit_G l2) \<Longrightarrow> False" and
  wit_G_set2: "\<And>l2 x. x \<in> set2_G (wit_G l2) \<Longrightarrow> x = l2"

subsubsection \<open>Derived rules\<close>

lemmas rel_G_mono' = rel_G_mono[THEN predicate2D, rotated -1]

lemma rel_G_eq_refl: "rel_G (=) (=) (=) (=) (=) (=) x x"
  by (simp add: rel_G_eq)

lemmas map_G_rel_cong = map_G_parametric[unfolded rel_fun_def, rule_format, rotated -1]

lemma rell_G_mono: "\<lbrakk> L1 \<le> L1'; L2 \<le> L2' \<rbrakk> \<Longrightarrow> rell_G L1 L2 \<le> rell_G L1' L2'"
  unfolding rell_G_def by (rule rel_G_mono) (auto)

lemma mapl_G_id0: "mapl_G id id = id"
  unfolding mapl_G_def using map_G_id0 .

lemma mapl_G_id: "mapl_G id id x = x"
  by (simp add: mapl_G_id0)

lemma mapl_G_comp: "mapl_G l1 l2 \<circ> mapl_G l1' l2' = mapl_G (l1 \<circ> l1') (l2 \<circ> l2')"
  unfolding mapl_G_def
  apply (rule trans)
   apply (rule map_G_comp)
  apply (simp)
  done

lemma map_G_mapl_G:
  "map_G l1 l2 co1 co2 contra1 contra2 x = map_G id id co1 co2 contra1 contra2 (mapl_G l1 l2 x)"
  unfolding mapl_G_def map_G_comp[THEN fun_cong, simplified] by simp

lemma mapl_G_map_G:
  "mapl_G l1 l2 (map_G id id co1 co2 contra1 contra2 x) = map_G l1 l2 co1 co2 contra1 contra2 x"
  unfolding mapl_G_def map_G_comp[THEN fun_cong, simplified] by simp

text \<open>Parametric mappers are unique:\<close>

lemma rel_G_Grp_weak: "rel_G (Grp UNIV l1) (Grp UNIV l2) (Grp UNIV co1) (Grp UNIV co2)
  (Grp UNIV contra1)\<inverse>\<inverse> (Grp UNIV contra2)\<inverse>\<inverse> = Grp UNIV (map_G l1 l2 co1 co2 contra1 contra2)"
  apply (rule antisym)
   apply (rule predicate2I)
   apply (rule GrpI)
    apply (rewrite in "_ = \<hole>" map_G_id[symmetric])
    apply (subst rel_G_eq[symmetric])
    apply (erule map_G_rel_cong; simp add: Grp_def)
   apply (rule UNIV_I)
  apply (rule predicate2I)
  apply (erule GrpE)
  apply (drule sym)
  apply (hypsubst)
  apply (rewrite in "rel_G _ _ _ _ _ _ \<hole>" map_G_id[symmetric])
  apply (rule map_G_rel_cong)
        apply (rule rel_G_eq_refl)
       apply (simp_all add: Grp_def)
  done

lemmas
  rel_G_pos_distr = rel_G_pos_distr_cond_def[THEN iffD1, rule_format] and
  rel_G_neg_distr = rel_G_neg_distr_cond_def[THEN iffD1, rule_format]

lemma rell_G_compp:
  "rell_G (L1 OO L1') (L2 OO L2') = rell_G L1 L2 OO rell_G L1' L2'"
  unfolding rell_G_def
  apply (rule antisym)
   apply (rule order_trans[rotated])
    apply (rule rel_G_neg_distr)
    apply (rule rel_G_neg_distr_cond_eq)
   apply (simp add: eq_OO)
  apply (rule order_trans)
   apply (rule rel_G_pos_distr)
   apply (rule rel_G_pos_distr_cond_eq)
  apply (simp add: eq_OO)
  done

subsubsection \<open>G is a BNF\<close>

lemma rell_G_eq_onp:
  "rell_G (eq_onp P1) (eq_onp P2) = eq_onp (\<lambda>x. (\<forall>z\<in>set1_G x. P1 z) \<and> (\<forall>z\<in>set2_G x. P2 z))"
  (is "?rel_eq_onp = ?eq_onp_pred")
proof (intro ext iffI)
  fix x y
  assume rel: "?rel_eq_onp x y"
  from rel have "rell_G (=) (=) x y"
    unfolding rell_G_def by (auto elim: rel_G_mono' simp add: eq_onp_def)
  then have "y = x" unfolding rell_G_def rel_G_eq ..
  let ?true = "\<lambda>_. True" and ?label = "\<lambda>P x. P x"
  from rel have "rell_G (=) (=) (mapl_G ?true ?true x) (mapl_G (?label P1) (?label P2) x)"
    unfolding rell_G_def mapl_G_def \<open>y = x\<close>
    by (auto simp add: eq_onp_def elim: map_G_rel_cong)
  then have *: "mapl_G ?true ?true x = mapl_G (?label P1) (?label P2) x"
    unfolding rell_G_def rel_G_eq .
  note \<open>y = x\<close>
  moreover {
    from *
    have "set1_G (mapl_G ?true ?true x) = set1_G (mapl_G (?label P1) (?label P2) x)"
      by simp
    then have "?true ` set1_G x = ?label P1 ` set1_G x"
      unfolding set1_G_map[THEN fun_cong, simplified] .
    then have "\<forall>z\<in>set1_G x. P1 z" by auto
  }
  moreover {
    from *
    have "set2_G (mapl_G ?true ?true x) = set2_G (mapl_G (?label P1) (?label P2) x)"
      by simp
    then have "?true ` set2_G x = ?label P2 ` set2_G x"
      unfolding set2_G_map[THEN fun_cong, simplified] .
    then have "\<forall>z\<in>set2_G x. P2 z" by auto
  }
  ultimately show "?eq_onp_pred x y" by (simp add: eq_onp_def)
next
  fix x y
  assume eq_onp: "?eq_onp_pred x y"
  then have "rell_G (=) (=) x y"
    by (auto simp add: rell_G_def rel_G_eq eq_onp_def)
  then show "?rel_eq_onp x y"
    using eq_onp by (auto elim!: rell_G_mono_strong simp add: eq_onp_def)
qed

lemma rell_G_Grp:
  "rell_G (Grp A1 f1) (Grp A2 f2) = Grp {x. set1_G x \<subseteq> A1 \<and> set2_G x \<subseteq> A2} (mapl_G f1 f2)"
proof -
  have "rell_G (Grp A1 f1) (Grp A2 f2) = rell_G (eq_onp (\<lambda>x. x \<in> A1) OO Grp UNIV f1)
    (eq_onp (\<lambda>x. x \<in> A2) OO Grp UNIV f2)"
    by (simp add: eq_onp_compp_Grp)
  also have "... = rell_G (eq_onp (\<lambda>x. x \<in> A1)) (eq_onp (\<lambda>x. x \<in> A2)) OO
    rell_G (Grp UNIV f1) (Grp UNIV f2)"
    using rell_G_compp .
  also have "... = eq_onp (\<lambda>x. set1_G x \<subseteq> A1 \<and> set2_G x \<subseteq> A2) OO
    rell_G (Grp UNIV f1) (Grp UNIV f2)"
    by (simp add: rell_G_eq_onp subset_eq)
  also have "... = eq_onp (\<lambda>x. set1_G x \<subseteq> A1 \<and> set2_G x \<subseteq> A2) OO Grp UNIV (mapl_G f1 f2)"
    unfolding rell_G_def mapl_G_def
      rel_G_Grp_weak[of _ _ id id id id, folded eq_alt, simplified]
    ..
  also have "... = Grp {x. set1_G x \<subseteq> A1 \<and> set2_G x \<subseteq> A2} (mapl_G f1 f2)"
    by (simp add: eq_onp_compp_Grp)
  finally show ?thesis .
qed

lemma G_in_rell: "rell_G L1 L2 = (\<lambda>x y. \<exists>z. (set1_G z \<subseteq> {(x, y). L1 x y} \<and>
  set2_G z \<subseteq> {(x, y). L2 x y}) \<and> mapl_G fst fst z = x \<and> mapl_G snd snd z = y)"
  using rell_G_compp_Grp by (simp add: OO_Grp_alt)

bnf "('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G"
  map: mapl_G
  sets: set1_G set2_G
  bd: "bd_G :: ('co1, 'co2, 'contra1, 'contra2, 'f) Gbd rel"
  wits: wit_G
  rel: rell_G
  by (fact mapl_G_id0 mapl_G_comp[symmetric] mapl_G_cong set1_G_map set2_G_map
    bd_G_card_order bd_G_cinfinite set1_G_bound set2_G_bound rell_G_compp[symmetric, THEN eq_refl]
    G_in_rell wit_G_set1 wit_G_set2)+

subsubsection \<open>Composition witness\<close>

consts
  rel_G_witness :: "('l1 \<Rightarrow> 'l1'' \<Rightarrow> bool) \<Rightarrow> ('l2 \<Rightarrow> 'l2'' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'l2, 'co1, 'co2, 'contra1, 'contra2, 'f) G \<times>
    ('l1'', 'l2'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) G \<Rightarrow>
    ('l1 \<times> 'l1'', 'l2 \<times> 'l2'', 'co1', 'co2', 'contra1', 'contra2', 'f) G"

specification (rel_G_witness)
  rel_G_witness1: "\<And>L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself)
    (x :: ('l1, 'l2, _, _, _, _, 'f) G) (y :: ('l1'', 'l2'', _, _, _, _, 'f) G).
    \<lbrakk> rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok;
      rel_G L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y \<rbrakk> \<Longrightarrow>
    rel_G (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) Co1 Co2 Contra1 Contra2 x
    (rel_G_witness L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y))"
  rel_G_witness2:"\<And>L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'
    (tytok :: ('l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'l2 \<times> ('l2 \<times> 'l2'') \<times> 'l2'' \<times> 'f) itself)
    (x :: ('l1, 'l2, _, _, _, _, 'f) G) (y :: ('l1'', 'l2'', _, _, _, _, 'f) G).
    \<lbrakk> rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok;
      rel_G L1 L2 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y \<rbrakk> \<Longrightarrow>
    rel_G (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) Co1' Co2' Contra1' Contra2'
    (rel_G_witness L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y)) y"
  apply(rule exI[where x="\<lambda>L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y). SOME z.
     rel_G (\<lambda>x (x', y). x' = x \<and> L1 x y) (\<lambda>x (x', y). x' = x \<and> L2 x y) Co1 Co2 Contra1 Contra2 x z \<and>
     rel_G (\<lambda>(x, y') y. y' = y \<and> L1 x y) (\<lambda>(x, y') y. y' = y \<and> L2 x y) Co1' Co2' Contra1' Contra2' z y"])
  apply(fold all_conj_distrib)
  apply(rule allI)+
  apply(fold imp_conjR)
  apply(rule impI)+
  apply clarify
  apply(rule someI_ex)
  subgoal for L1 L2 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x y
    apply(drule rel_G_neg_distr[where
          ?L1.0 = "\<lambda>x (x', y). x' = x \<and> L1 x y" and ?L1'.0 = "\<lambda>(x, y) y'. y = y' \<and> L1 x y'" and
          ?L2.0 = "\<lambda>x (x', y). x' = x \<and> L2 x y" and ?L2'.0 = "\<lambda>(x, y) y'. y = y' \<and> L2 x y'"])
    apply(drule predicate2D)
     apply(erule rel_G_mono[THEN predicate2D, rotated -1]; fastforce)
    apply(erule relcomppE)
    apply(rule exI conjI)+
     apply assumption+
    done
  done

end


(*  Author:     Stefan Berghofer, TU Muenchen, 2005; Lukas Bulwahn, TU Muenchen, 2009
*)

theory Execute
imports POPLmarkRecord "HOL-Library.Code_Target_Numeral"
begin

section \<open>Executing the specification\<close>

text \<open>
\label{sec:exec}
An important criterion that a solution to the {\sc PoplMark} Challenge should
fulfill is the possibility to {\it animate} the specification. For example,
it should be possible to apply the reduction relation for the calculus to
example terms. Since the reduction relations are defined inductively, they can
be interpreted as a logic program in the style of {\sc Prolog}.
The definition of the single-step evaluation relation presented in \secref{sec:evaluation}
and \secref{sec:evaluation-rcd} is directly executable.

In order to compute the normal form of a term using the one-step evaluation
relation \<open>\<longmapsto>\<close>, we introduce the inductive predicate \<open>t \<Down> u\<close>,
denoting that \<open>u\<close> is a normal form of \<open>t\<close>.
\<close>

inductive norm :: "trm \<Rightarrow> trm \<Rightarrow> bool"  (infixl "\<Down>" 50)
where
  "t \<in> value \<Longrightarrow> t \<Down> t"
| "t \<longmapsto> s \<Longrightarrow> s \<Down> u \<Longrightarrow> t \<Down> u"

definition normal_forms where
  "normal_forms t \<equiv> {u. t \<Down> u}"

lemma [code_pred_intro Rcd_Nil]: "valuep (Rcd [])"
by (auto intro: valuep.intros)

lemma [code_pred_intro Rcd_Cons]: "valuep t \<Longrightarrow> valuep (Rcd fs) \<Longrightarrow> valuep (Rcd ((l, t) # fs))"
by (auto intro!: valuep.intros elim!: valuep.cases)

lemmas valuep.intros(1)[code_pred_intro Abs'] valuep.intros(2)[code_pred_intro TAbs']

code_pred (modes: i => bool) valuep
proof -
  case valuep
  from valuep.prems show thesis
  proof (cases rule: valuep.cases)
    case (Rcd fs)
    from this valuep.Rcd_Nil valuep.Rcd_Cons show thesis
      by (cases fs) (auto intro: valuep.intros)
  next
    case Abs
    with valuep.Abs' show thesis .
  next
    case TAbs
    with valuep.TAbs' show thesis .
  qed
qed

thm valuep.equation

code_pred (modes: i => i => bool, i => o => bool as normalize) norm .

thm norm.equation

lemma [code_unfold]: "x \<in> value \<longleftrightarrow> valuep x"
  by (simp add: value_def)

definition
  natT :: type where
  "natT \<equiv> \<forall><:Top. (\<forall><:TVar 0. (\<forall><:TVar 1. (TVar 2 \<rightarrow> TVar 1) \<rightarrow> TVar 0 \<rightarrow> TVar 1))"

definition
  fact2 :: trm where
  "fact2 \<equiv>
   LET PVar natT =
     (\<lambda><:Top. \<lambda><:TVar 0. \<lambda><:TVar 1. \<lambda>:TVar 2 \<rightarrow> TVar 1. \<lambda>: TVar 1. Var 1 \<bullet> Var 0)
   IN
   LET PRcd
     [(''pluspp'', PVar (natT \<rightarrow> natT \<rightarrow> natT)),
      (''multpp'', PVar (natT \<rightarrow> natT \<rightarrow> natT))] = Rcd
     [(''multpp'', \<lambda>:natT. \<lambda>:natT. \<lambda><:Top. \<lambda><:TVar 0. \<lambda><:TVar 1. \<lambda>:TVar 2 \<rightarrow> TVar 1.
        Var 5 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 2 \<bullet>\<^sub>\<tau> TVar 1 \<bullet> (Var 4 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 2 \<bullet>\<^sub>\<tau> TVar 1) \<bullet> Var 0),
      (''pluspp'', \<lambda>:natT. \<lambda>:natT. \<lambda><:Top. \<lambda><:TVar 0. \<lambda><:TVar 1. \<lambda>:TVar 2 \<rightarrow> TVar 1. \<lambda>:TVar 1.
        Var 6 \<bullet>\<^sub>\<tau> TVar 4 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 3 \<bullet> Var 1 \<bullet>
          (Var 5 \<bullet>\<^sub>\<tau> TVar 4 \<bullet>\<^sub>\<tau> TVar 3 \<bullet>\<^sub>\<tau> TVar 2 \<bullet> Var 1 \<bullet> Var 0))]
   IN
     Var 0 \<bullet> (Var 1 \<bullet> Var 2 \<bullet> Var 2) \<bullet> Var 2"

value "normal_forms fact2"

text \<open>
Unfortunately, the definition based
on evaluation contexts from \secref{sec:evaluation-ctxt} is not directly executable.
The reason is that from the definition of evaluation contexts, the code generator
cannot immediately read off an algorithm that, given a term \<open>t\<close>, computes a context
\<open>E\<close> and a term \<open>t\<^sub>0\<close> such that \<open>t = E t\<^sub>0\<close>. In order to do this, one
would have to extract the algorithm contained in the proof of the {\it decomposition lemma}
from \secref{sec:evaluation-ctxt}.
\<close>

values "{u. norm fact2 u}"

end


(*
    Title:      Code_Generation_IArrays_SML.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Exporting code to SML\<close>

theory Code_Generation_IArrays_SML
imports
  "HOL-Library.Code_Real_Approx_By_Float"
  Code_Generation_IArrays
begin

text\<open>Some serializations of gcd and abs in SML. Since gcd is not part of the standard SML library,
we have serialized it to the corresponding operation in PolyML and MLton.\<close>

context
includes integer.lifting
begin

lift_definition gcd_integer :: "integer => integer => integer"
  is "gcd :: int => int => int" .

lemma gcd_integer_code[code]:
"gcd_integer l k = \<bar>if l = (0::integer) then k else gcd_integer l (\<bar>k\<bar> mod \<bar>l\<bar>)\<bar>"
apply (transfer) using gcd_code_int by (metis gcd.commute)
end

code_printing
 constant "abs :: integer => _" \<rightharpoonup> (SML) "IntInf.abs"
 | constant "gcd_integer :: integer => _ => _" \<rightharpoonup> (SML) "(PolyML.IntInf.gcd ((_),(_)))" (*Only for Poly/ML*)
 (* | constant "gcd_integer :: integer => _ => _" \<rightharpoonup> (SML) "(MLton.IntInf.gcd ((_),(_)))"*) (*Only for MLton*)

lemma gcd_code[code]:
"gcd a b = int_of_integer (gcd_integer (of_int a) (of_int b))"
by (metis gcd_integer.abs_eq int_of_integer_integer_of_int integer_of_int_eq_of_int)

code_printing
  constant "abs :: real => real" \<rightharpoonup>
    (SML) "Real.abs"

declare [[code drop: "abs :: real \<Rightarrow> real"]]

text\<open>There are several ways to serialize div and mod. The following ones are four examples of it:\<close>

(*The times are obtained after computing the rref of a 100x100 rational matrix.*)

(* 21.484 seconds*)
(*
code_printing
constant "divmod_integer :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.divMod ((_),(_)))"
*)

(*19.04 seconds*)
(*
code_printing
constant "(div) :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.div ((_), (_)))"
| constant "(mod) :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.mod ((_), (_)))"
*)

(*18.832 seconds*)
(*
code_printing
constant "(div) :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.quot ((_), (_)))"
| constant "(mod) :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.rem ((_), (_)))"
*)

(*18.792 seconds*)
(*
code_printing
constant "divmod_integer :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.quotRem ((_),(_)))"
*)

(*Thus, the best option for our development is:*)

code_printing
constant "divmod_integer :: integer => _ => _" \<rightharpoonup> (SML) "(IntInf.quotRem ((_),(_)))"

export_code
  print_rank_real
  print_rank_rat
  print_rank_z2
  print_rank
  print_result_real
  print_result_rat
  print_result_z2
  print_result_Gauss
  print_det_rat
  print_det_real
  print_det
  print_inverse_real
  print_inverse_rat
  print_inverse
  print_system_rat
  print_system
  in SML module_name "Gauss_SML" (*file "Gauss_SML.sml"*)

(* For the Mathematica bug:*)

(*
export_code
  print_rank_real
  print_rank_rat
  print_rank_z2
  print_rank
  print_result_real
  print_result_rat
  print_result_z2
  print_result_Gauss
  print_det_rat
  print_det_real
  print_det
  print_inverse_real
  print_inverse_rat
  print_inverse
  print_system_rat
  print_system

  bigMatrix
  in SML module_name "Gauss_SML" file "Gauss_SML.sml"
*)

end


theory TopoS_Stateful_Policy
imports TopoS_Composition_Theory
begin

section\<open>Stateful Policy\<close>

text\<open>Details described in \<^cite>\<open>"diekmann2014esss"\<close>.\<close>

text\<open>Algorithm\<close>
term TopoS_Composition_Theory.generate_valid_topology
text\<open>generates a valid high-level topology. Now we discuss how to turn this into
       a stateful policy.\<close>

text\<open>
Example:
  SensorNode produces data and has no security level.
  SensorSink has high security level
  SensorNode -> SensorSink, but not the other way round.
  Implementation: UDP in one direction

  Alice is in internal protected subnet. Google can not arbitrarily access Alice.
  Alice sends requests to google.
  It is desirable that Alice gets the response back
  Implementation: TCP and stateful packet filter that allows, once Alice establishes a connection, to get a response back via this connection.

Result:
  IFS violations undesirable.
  ACS violations may be okay under certain conditions.
\<close>

term all_security_requirements_fulfilled

text\<open>@{term "G = (V, E\<^sub>f\<^sub>i\<^sub>x, E\<^sub>s\<^sub>t\<^sub>a\<^sub>t\<^sub>e)"}\<close>
record 'v stateful_policy =
    hosts :: "'v set" \<comment> \<open>nodes, vertices\<close>
    flows_fix :: "('v \<times>'v) set" \<comment> \<open>edges in high-level policy\<close>
    flows_state :: "('v \<times>'v) set" \<comment> \<open>edges that can have stateful flows, i.e. backflows\<close>

text\<open>All the possible ways packets can travel in a @{typ "'v stateful_policy"}.
        They can either choose the fixed links;
        Or use a stateful link, i.e. establish state.
        Once state is established, packets can flow back via the established link.\<close>
definition all_flows :: "'v stateful_policy \<Rightarrow> ('v \<times> 'v) set" where
  "all_flows \<T> \<equiv> flows_fix \<T> \<union> flows_state \<T> \<union> backflows (flows_state \<T>)"

definition stateful_policy_to_network_graph :: "'v stateful_policy \<Rightarrow> 'v graph" where
  "stateful_policy_to_network_graph \<T> = \<lparr> nodes = hosts \<T>, edges = all_flows \<T> \<rparr>"

text\<open>@{typ "'v stateful_policy"} syntactically well-formed\<close>
locale wf_stateful_policy =
  fixes \<T> :: "'v stateful_policy"
  assumes E_wf: "fst ` (flows_fix \<T>) \<subseteq> (hosts \<T>)"
                   "snd ` (flows_fix \<T>) \<subseteq> (hosts \<T>)"
  and E_state_fix: "flows_state \<T> \<subseteq> flows_fix \<T>"
  and finite_Hosts: "finite (hosts \<T>)"
begin

  lemma finite_fix: "finite (flows_fix \<T>)"
  proof -
    from finite_subset[OF E_wf(1) finite_Hosts] have 1: "finite (fst ` flows_fix \<T>)" .
    from finite_subset[OF E_wf(2) finite_Hosts] have 2: "finite (snd ` flows_fix \<T>)" .
    have s: "flows_fix \<T> \<subseteq> (fst ` flows_fix \<T> \<times> snd ` flows_fix \<T>)" by force
    from finite_cartesian_product[OF 1 2] have "finite (fst ` flows_fix \<T> \<times> snd ` flows_fix \<T>)" .
    from finite_subset[OF s this] show ?thesis .
  qed

  lemma finite_state: "finite (flows_state \<T>)"
    using finite_subset[OF E_state_fix finite_fix] by assumption

  lemma finite_backflows_state: "finite (backflows (flows_state \<T>))"
    using [[simproc add: finite_Collect]] by(simp add: backflows_def finite_state)

  lemma E_state_backflows_wf: "fst ` backflows (flows_state \<T>) \<subseteq> (hosts \<T>)"
                         "snd ` backflows (flows_state \<T>) \<subseteq> (hosts \<T>)"
    by(auto simp add: backflows_def E_state_valid E_state_validD)

end

text\<open>Minimizing stateful flows such that only newly added backflows remain\<close>
  definition filternew_flows_state :: "'v stateful_policy \<Rightarrow> ('v \<times> 'v) set" where
    "filternew_flows_state \<T> \<equiv> {(s, r) \<in> flows_state \<T>. (r, s) \<notin> flows_fix \<T>}"

  lemma filternew_subseteq_flows_state: "filternew_flows_state \<T> \<subseteq> flows_state \<T>"
    by(auto simp add: filternew_flows_state_def)

  \<comment> \<open>alternative definitions, all are equal\<close>
  lemma filternew_flows_state_alt: "filternew_flows_state \<T>  = flows_state \<T> - (backflows (flows_fix \<T>))"
    apply(simp add: backflows_def filternew_flows_state_def)
    apply(rule)
     apply blast+
    done

  lemma stateful_policy_to_network_graph_filternew: "\<lbrakk> wf_stateful_policy \<T> \<rbrakk> \<Longrightarrow>
    stateful_policy_to_network_graph \<T> =
    stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>"
    apply(drule wf_stateful_policy.E_state_fix)
    apply(simp add: stateful_policy_to_network_graph_def all_flows_def)
    apply(rule Set.equalityI)
     apply(simp add: filternew_flows_state_def backflows_def)
     apply(rule, blast)+
    apply(simp add: filternew_flows_state_def backflows_def)
    apply fastforce
    done

  lemma backflows_filternew_disjunct_flows_fix:
    "\<forall> b \<in> (backflows (filternew_flows_state \<T>)). b \<notin> flows_fix \<T>"
    by(simp add: filternew_flows_state_def backflows_def)

text\<open>Given a high-level policy, we can construct a pretty large syntactically valid low level policy. However, the stateful policy will
       almost certainly violate security requirements!\<close>
  lemma "wf_graph G \<Longrightarrow> wf_stateful_policy \<lparr> hosts = nodes G, flows_fix = nodes G \<times> nodes G, flows_state = nodes G \<times> nodes G \<rparr>"
    by(simp add: wf_stateful_policy_def wf_graph_def)

text\<open>@{const wf_stateful_policy} implies @{term wf_graph}\<close>
  lemma wf_stateful_policy_is_wf_graph: "wf_stateful_policy \<T> \<Longrightarrow> wf_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
    apply(frule wf_stateful_policy.E_state_backflows_wf)
    apply(frule wf_stateful_policy.E_state_backflows_wf(2))
    apply(frule wf_stateful_policy.E_state_valid)
    apply(frule wf_stateful_policy.E_state_valid(2))
    apply(frule wf_stateful_policy.E_wf)
    apply(frule wf_stateful_policy.E_wf(2))
    apply(simp add: all_flows_def wf_graph_def wf_stateful_policy_def
          wf_stateful_policy.finite_fix wf_stateful_policy.finite_state wf_stateful_policy.finite_backflows_state)
    apply(rule conjI)
     apply (metis image_Un sup.bounded_iff)+
    done

(*we use the second way of writing it in the paper*)
lemma "(\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ). F \<subseteq> backflows (filternew_flows_state \<T>)) \<longleftrightarrow>
    \<Union>(get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>)) \<subseteq> (backflows (flows_state \<T>)) - (flows_fix \<T>)"
    by(simp add: filternew_flows_state_alt backflows_minus_backflows, blast)

text\<open>When is a stateful policy @{term "\<T>"} compliant with a high-level policy @{term "G"} and the security requirements @{term "M"}?\<close>
locale stateful_policy_compliance =
  fixes \<T> :: "('v::vertex) stateful_policy"
  fixes G :: "'v graph"
  fixes M :: "('v) SecurityInvariant_configured list"
  assumes
    \<comment> \<open>the graph must be syntactically valid\<close>
    wfG: "wf_graph G"
    and
    \<comment> \<open>security requirements must be valid\<close>
    validReqs: "valid_reqs M"
    and
    \<comment> \<open>the high-level policy must be valid\<close>
    high_level_policy_valid: "all_security_requirements_fulfilled M G"
    and
    \<comment> \<open>the stateful policy must be syntactically valid\<close>
    stateful_policy_wf:
    "wf_stateful_policy \<T>"
    and
    \<comment> \<open>the stateful policy must talk about the same nodes as the high-level policy\<close>
    hosts_nodes:
    "hosts \<T> = nodes G"
    and
    \<comment> \<open>only flows that are allowed in the high-level policy are allowed in the stateful policy\<close>
    flows_edges:
    "flows_fix \<T> \<subseteq> edges G"
    and
    \<comment> \<open>the low level policy must comply with the high-level policy\<close>
      \<comment> \<open>all information flow strategy requirements must be fulfilled, i.e. no leaks!\<close>
      compliant_stateful_IFS:
        "all_security_requirements_fulfilled (get_IFS M) (stateful_policy_to_network_graph \<T>)"
      and
      \<comment> \<open>No Access Control side effects must occur\<close>
      compliant_stateful_ACS:
        "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T> ). F \<subseteq> backflows (filternew_flows_state \<T>)"

  begin
    lemma compliant_stateful_ACS_no_side_effects_filternew_helper:
      "\<forall> E \<subseteq> backflows (filternew_flows_state \<T>). \<forall> F \<in> get_offending_flows (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E"
    proof(rule, rule)
      fix E
      assume a1: "E \<subseteq> backflows (filternew_flows_state \<T>)"
      from validReqs have valid_ReqsACS: "valid_reqs (get_ACS M)" by(simp add: get_ACS_def valid_reqs_def)

      from compliant_stateful_ACS stateful_policy_to_network_graph_filternew[OF stateful_policy_wf] have compliant_stateful_ACS_only_state_violations_filternew:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>). F \<subseteq> backflows (filternew_flows_state \<T>)" by simp

      from wf_stateful_policy_is_wf_graph[OF stateful_policy_wf] have wfGfilternew:
        "wf_graph \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>)\<rparr>"
        apply(simp add: all_flows_def filternew_flows_state_alt backflows_minus_backflows)
        by(auto simp add: wf_graph_def)

      from wf_stateful_policy.E_state_fix[OF stateful_policy_wf] filternew_subseteq_flows_state have flows_fix_un_filternew_simp: "flows_fix \<T> \<union> filternew_flows_state \<T> = flows_fix \<T>" by blast

      from compliant_stateful_ACS_only_state_violations_filternew have
        "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
        \<Union>(c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>)\<rparr>) \<subseteq> backflows (filternew_flows_state \<T>)"
        by(simp add: stateful_policy_to_network_graph_def all_flows_def get_offending_flows_def, blast)

      \<comment> \<open>idea: use @{thm compliant_stateful_ACS} with the @{thm configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq}
        lemma and substract @{term "backflows (filternew_flows_state \<T>) - E"}, on the right hand side @{term E} remains, as Graph's edges @{term "flows_fix \<T>  \<union> E"} remains\<close>

      from configured_SecurityInvariant.Un_set_offending_flows_bound_minus_subseteq[where X="backflows (filternew_flows_state \<T>)", OF _ wfGfilternew this]
        \<open>valid_reqs (get_ACS M)\<close>
        have
        "\<And> m E. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> filternew_flows_state \<T> \<union> backflows (filternew_flows_state \<T>) - E\<rparr>. F \<subseteq> backflows (filternew_flows_state \<T>) - E"
        by(auto simp add: all_flows_def valid_reqs_def)
      from this flows_fix_un_filternew_simp have rule:
        "\<And> m E. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - E\<rparr>. F \<subseteq> backflows (filternew_flows_state \<T>) - E"
        by simp

      from  backflows_finite rev_finite_subset[OF wf_stateful_policy.finite_state[OF stateful_policy_wf] filternew_subseteq_flows_state] have
        "finite (backflows (filternew_flows_state \<T>))" by blast
      from a1 this have "finite E" by (metis rev_finite_subset)

      from a1 obtain E' where E'_prop1: "backflows (filternew_flows_state \<T>) - E' = E" and E'_prop2: "E' = backflows (filternew_flows_state \<T>) - E" by blast
      from E'_prop2 \<open>finite (backflows (filternew_flows_state \<T>))\<close> \<open>finite E\<close> have "finite E'" by blast

      from Set.double_diff[where B="backflows (filternew_flows_state \<T>)" and C="backflows (filternew_flows_state \<T>)" and A="E", OF a1, simplified] have Ebackflowssimp:
        "backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) = E" .

      have "flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) =
          (flows_fix \<T> - (backflows (filternew_flows_state \<T>))) \<union> E"
          apply(simp add: Set.Un_Diff)
          apply(simp add: Ebackflowssimp)
          by blast
      also have "(flows_fix \<T> - (backflows (filternew_flows_state \<T>))) \<union> E = flows_fix \<T>  \<union> E" using backflows_filternew_disjunct_flows_fix by blast
      finally have flows_E_simp: "flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E) = flows_fix \<T>  \<union> E" .

      from rule[simplified E'_prop1 E'_prop2] have
      "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
      \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E)\<rparr>.
       F \<subseteq> backflows (filternew_flows_state \<T>) - (backflows (filternew_flows_state \<T>) - E)"
       by(simp)
      from this Ebackflowssimp flows_E_simp have
      "\<And>m. m \<in> set (get_ACS M) \<Longrightarrow>
        \<forall>F\<in>c_offending_flows m \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
       by simp
      thus  "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
        by(simp add: get_offending_flows_def)
      qed

    theorem compliant_stateful_ACS_no_side_effects:
      "\<forall> E \<subseteq> backflows (flows_state \<T>). \<forall> F \<in> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E"
    proof -
      from compliant_stateful_ACS stateful_policy_to_network_graph_filternew[OF stateful_policy_wf] have a1:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<lparr>hosts = hosts \<T>, flows_fix = flows_fix \<T>, flows_state = filternew_flows_state \<T> \<rparr>). F \<subseteq> backflows (filternew_flows_state \<T>)" by simp

      have backflows_split: "backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)) = backflows (flows_state \<T>)"
        by (metis Diff_subset Un_Diff_cancel Un_absorb1 backflows_minus_backflows filternew_flows_state_alt)

      have
        "\<forall>E\<subseteq>backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)).
             \<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E"
        proof(rule allI, rule impI)
          fix E
          assume h1: "E \<subseteq> backflows (filternew_flows_state \<T>) \<union> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))"

          have "\<exists> E1 E2. E1 \<subseteq> backflows (filternew_flows_state \<T>) \<and> E2 \<subseteq> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>)) \<and> E1 \<union> E2 = E \<and> E1 \<inter> E2 = {}"
            apply(rule_tac x="{e \<in> E. e \<in> backflows (filternew_flows_state \<T>)}" in exI)
            apply(rule_tac x="{e \<in> E. e \<in>(backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))}" in exI)
            apply(simp)
            apply(rule)
             apply blast
            apply(rule)
             apply blast
            apply(rule)
             using h1 apply blast
            using backflows_filternew_disjunct_flows_fix by blast

          from this obtain E1 E2 where E1_prop: "E1 \<subseteq> backflows (filternew_flows_state \<T>)" and E2_prop: "E2 \<subseteq> (backflows (flows_state \<T>) - backflows (filternew_flows_state \<T>))" and "E = E1 \<union> E2" and "E1 \<inter> E2 = {}" by blast

          \<comment> \<open>the stateful flows are @{text "\<subseteq>"} fix flows. If substracting the new stateful flows, onyly the existing fix flows remain\<close>
          from E2_prop filternew_flows_state_alt have "E2 \<subseteq> flows_fix \<T>" by (metis (opaque_lifting, no_types) Diff_subset_conv Un_Diff_cancel2 backflows_minus_backflows inf_sup_ord(3) order.trans)
          \<comment> \<open>hence, E2 disappears\<close>
          from Set.Un_absorb1[OF this] have E2_absorb: "flows_fix \<T> \<union> E2 = flows_fix \<T>" by blast

          from \<open>E = E1 \<union> E2\<close> have E2E1eq: "E2 \<union> E1 = E" by blast

          from \<open>E = E1 \<union> E2\<close> \<open>E1 \<inter> E2 = {}\<close> have "E1 \<subseteq> E" by simp

          from compliant_stateful_ACS_no_side_effects_filternew_helper E1_prop have "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E1 \<rparr>. F \<subseteq> E1" by simp
          hence "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E2 \<union> E1 \<rparr>. F \<subseteq> E1" using E2_absorb[symmetric] by simp
          hence "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E \<rparr>. F \<subseteq> E1" using E2E1eq by (metis Un_assoc)

          from this \<open>E1 \<subseteq> E\<close> show "\<forall>F\<in>get_offending_flows (get_ACS M) \<lparr>nodes = hosts \<T>, edges = flows_fix \<T> \<union> E\<rparr>. F \<subseteq> E" by blast
        qed

      from this backflows_split show ?thesis by presburger
    qed

    corollary compliant_stateful_ACS_no_side_effects': "\<forall> E \<subseteq> backflows (flows_state \<T>). \<forall> F \<in> get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T> \<union> E \<rparr>. F \<subseteq> E"
      using compliant_stateful_ACS_no_side_effects wf_stateful_policy.E_state_fix[OF stateful_policy_wf] by (metis Un_absorb2)

    text\<open>The high level graph generated from the low level policy is a valid graph\<close>
    lemma valid_stateful_policy: "wf_graph \<lparr>nodes = hosts \<T>, edges = all_flows \<T>\<rparr>"
      by(rule wf_stateful_policy_is_wf_graph,fact stateful_policy_wf)

    text\<open>The security requirements are definitely fulfilled if we consider only the fixed flows and the
           normal direction of the stateful flows (i.e. no backflows).
           I.e. considering no states, everything must be fulfilled\<close>
    lemma compliant_stateful_ACS_static_valid: "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T>  \<rparr>"
    proof -
      from validReqs have valid_ReqsACS: "valid_reqs (get_ACS M)" by(simp add: get_ACS_def valid_reqs_def)
      from wfG hosts_nodes[symmetric] have wfG': "wf_graph \<lparr> nodes = hosts \<T>, edges = edges G  \<rparr>" by(case_tac G, simp)
      from high_level_policy_valid have "all_security_requirements_fulfilled (get_ACS M) G"
        by(simp add: get_ACS_def all_security_requirements_fulfilled_def)
      from this hosts_nodes[symmetric] have "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = edges G  \<rparr>"
        by(case_tac G, simp)
      from all_security_requirements_fulfilled_mono[OF valid_ReqsACS flows_edges wfG' this] show ?thesis .
    qed
    theorem compliant_stateful_ACS_static_valid':
      "all_security_requirements_fulfilled M \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>"
      proof -
        from validReqs have valid_ReqsIFS: "valid_reqs (get_IFS M)" by(simp add: get_IFS_def valid_reqs_def)

        \<comment> \<open>show that it holds for IFS, by monotonicity as it holds for more in IFS\<close>
        from all_security_requirements_fulfilled_mono[OF valid_ReqsIFS _ valid_stateful_policy compliant_stateful_IFS[unfolded stateful_policy_to_network_graph_def]] have
          goalIFS: "all_security_requirements_fulfilled (get_IFS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>" by(simp add: all_flows_def)

        from wf_stateful_policy.E_state_fix[OF stateful_policy_wf] have "flows_fix \<T> \<union> flows_state \<T> =  flows_fix \<T>" by blast
        from this compliant_stateful_ACS_static_valid have goalACS:
          "all_security_requirements_fulfilled (get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T>  \<rparr>" by simp

        \<comment> \<open>ACS and IFS together form M, we know it holds for ACS\<close>
        from goalACS goalIFS show ?thesis
          apply(simp add: all_security_requirements_fulfilled_def get_IFS_def get_ACS_def)
          by fastforce
    qed

    text\<open>The flows with state are a subset of the flows allowed by the policy\<close>
    theorem flows_state_edges: "flows_state \<T> \<subseteq> edges G"
      using wf_stateful_policy.E_state_fix[OF stateful_policy_wf] flows_edges by simp

    text\<open>All offending flows are subsets of the reveres stateful flows\<close>
    lemma compliant_stateful_ACS_only_state_violations:
      "\<forall>F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
      proof -
        have "backflows (filternew_flows_state \<T>) \<subseteq> backflows (flows_state \<T>)" by (metis Diff_subset backflows_minus_backflows filternew_flows_state_alt)
        from compliant_stateful_ACS this have
          "\<forall> F \<in> get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
          by (metis subset_trans)
        thus ?thesis .
      qed
    theorem compliant_stateful_ACS_only_state_violations': "\<forall>F \<in> get_offending_flows M (stateful_policy_to_network_graph \<T>). F \<subseteq> backflows (flows_state \<T>)"
      proof -
        from validReqs have valid_ReqsIFS: "valid_reqs (get_IFS M)" by(simp add: get_IFS_def valid_reqs_def)
        have offending_split: "\<And>G. get_offending_flows M G = (get_offending_flows (get_IFS M) G \<union> get_offending_flows (get_ACS M) G)"
          apply(simp add: get_offending_flows_def get_IFS_def get_ACS_def) by blast
       show ?thesis
        apply(subst offending_split)
        using compliant_stateful_ACS_only_state_violations
              all_security_requirements_fulfilled_imp_get_offending_empty[OF valid_ReqsIFS compliant_stateful_IFS]
        by auto
      qed

    text \<open>All violations are backflows of valid flows\<close>
    corollary compliant_stateful_ACS_only_state_violations_union: "\<Union>(get_offending_flows (get_ACS M) (stateful_policy_to_network_graph \<T>)) \<subseteq> backflows (flows_state \<T>)"
    using compliant_stateful_ACS_only_state_violations by fastforce

    corollary compliant_stateful_ACS_only_state_violations_union': "\<Union>(get_offending_flows M (stateful_policy_to_network_graph \<T>)) \<subseteq> backflows (flows_state \<T>)"
    using compliant_stateful_ACS_only_state_violations' by fastforce

    text\<open>All individual flows cause no side effects, i.e. each backflow causes at most itself as violation, no other
           side-effect violations are induced.\<close>
    lemma  compliant_stateful_ACS_no_state_singleflow_side_effect:
      "\<forall> (v\<^sub>1, v\<^sub>2) \<in> backflows (flows_state \<T>).
       \<Union>(get_offending_flows(get_ACS M) \<lparr> nodes = hosts \<T>, edges = flows_fix \<T> \<union> flows_state \<T> \<union> {(v\<^sub>1, v\<^sub>2)} \<rparr>) \<subseteq> {(v\<^sub>1, v\<^sub>2)}"
    using compliant_stateful_ACS_no_side_effects' by blast
  end

subsection\<open>Summarizing the important theorems\<close>

  text\<open>No information flow security requirements are violated (including all added stateful flows)\<close>
  thm stateful_policy_compliance.compliant_stateful_IFS

  text\<open>There are not access control side effects when allowing stateful backflows.
          I.e. for all possible subsets of the to-allow backflows, the violations they cause are only these backflows themselves\<close>
  thm stateful_policy_compliance.compliant_stateful_ACS_no_side_effects'

    text\<open>Also, considering all backflows individually, they cause no side effect, i.e. the only violation added is the backflow itself\<close>
    thm stateful_policy_compliance.compliant_stateful_ACS_no_state_singleflow_side_effect

    text\<open>In particular, all introduced offending flows for access control strategies are at most the stateful backflows\<close>
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union
    text\<open>Which implies: all introduced offending flows are at most the stateful backflows\<close>
    thm stateful_policy_compliance.compliant_stateful_ACS_only_state_violations_union'

  text\<open>Disregarding the backflows of stateful flows, all security requirements are fulfilled.\<close>
  thm stateful_policy_compliance.compliant_stateful_ACS_static_valid'

end


\<^marker>\<open>creator "Bohua Zhan"\<close>
\<^marker>\<open>contributor "Kevin Kappelmann"\<close>
section \<open>Logic Proof Steps\<close>
theory Proof_Steps_Logic
imports Auto2_HOTG
  HOTG.Pairs
begin
paragraph \<open>Summary\<close>
text \<open>Setup for proof steps related to logic. Adapted from \<open>Auto2_HOL/HOL/Logic_Thms.thy\<close>.\<close>

subsection \<open>Trivial contradictions\<close>
setup \<open>add_resolve_prfstep @{thm HOL.refl}\<close>
setup \<open>add_forward_prfstep @{thm contra_triv}\<close>
setup \<open>add_resolve_prfstep @{thm TrueI}\<close>
lemma FalseD [resolve]: "\<not>False" by simp
lemma exists_triv_eq [resolve]: "\<exists>x. x = x" by auto

subsection \<open>Not\<close>
setup \<open>add_forward_prfstep_cond @{thm HOL.not_sym}
  [with_filt (not_type_filter "s" boolT)]\<close>

subsection \<open>Iff\<close>
setup \<open>add_gen_prfstep ("iff_intro1",
  [WithGoal @{term_pat "(?A::bool) = ?B"},
   CreateCase @{term_pat "?A::bool"},
   WithScore 25])\<close>
lemma iff_goal:
  "A \<noteq> B \<Longrightarrow> A \<Longrightarrow> \<not>B" "A \<noteq> B \<Longrightarrow> B \<Longrightarrow> \<not>A"
  "A \<noteq> B \<Longrightarrow> \<not>A \<Longrightarrow> B" "A \<noteq> B \<Longrightarrow> \<not>B \<Longrightarrow> A"
  "(\<not>A) \<noteq> B \<Longrightarrow> A \<Longrightarrow> B" "A \<noteq> (\<not>B) \<Longrightarrow> B \<Longrightarrow> A" by auto
setup \<open>fold (fn th => add_forward_prfstep_cond th [with_score 1]) @{thms iff_goal}\<close>

subsection \<open>Quantifiers: normalization\<close>
lemma exists_split: "(\<exists>x y. P x \<and> Q y) = ((\<exists>x. P x) \<and> (\<exists>y. Q y))" by simp
setup \<open>add_backward_prfstep (equiv_backward_th @{thm exists_split})\<close>
subsection \<open>Case analysis\<close>
setup \<open>add_gen_prfstep ("case_intro",
  [WithTerm @{term_pat "if ?cond then (?yes::?'a) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_fact",
  [WithFact @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
setup \<open>add_gen_prfstep ("case_intro_goal",
  [WithGoal @{term_pat "if ?cond then (?yes::bool) else ?no"},
   CreateCase @{term_pat "?cond::bool"}])\<close>
lemma if_eval':
  "P \<Longrightarrow> (if \<not>P then x else y) = y" by auto
lemma ifb_eval:
  "P \<Longrightarrow> (if P then (x::bool) else y) = x"
  "\<not>P \<Longrightarrow> (if P then (x::bool) else y) = y"
  "P \<Longrightarrow> (if \<not>P then (x::bool) else y) = y" by auto
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1])
  ([@{thm HOL.if_P}, @{thm HOL.if_not_P}, @{thm if_eval'}] @ @{thms ifb_eval})\<close>

subsection \<open>THE and \<exists>!\<close>
setup \<open>add_forward_prfstep_cond @{thm theI'} [with_term "THE x. ?P x"]\<close>
setup \<open>add_gen_prfstep ("ex1_case",
  [WithGoal @{term_pat "\<exists>!x. ?P x"}, CreateConcl @{term_pat "\<exists>x. ?P x"}])\<close>
lemma ex_ex1I' [backward1]: "\<forall>y. P y \<longrightarrow> x = y \<Longrightarrow> P x \<Longrightarrow> \<exists>!x. P x" by auto
lemma the1_equality': "P a \<Longrightarrow> \<exists>!x. P x \<Longrightarrow> (THE x. P x) = a" by (simp add: the1_equality)
setup \<open>add_forward_prfstep_cond @{thm the1_equality'} [with_term "THE x. ?P x"]\<close>

(* subsection \<open>Axiom of choice\<close>
setup \<open>add_prfstep_custom ("ex_choice",
  [WithGoal @{term_pat "EX f. !x. ?Q f x"}],
  (fn ((id, _), ths) => fn _ => fn _ =>
    let
      val choice = @{thm choice} |> apply_to_thm (Conv.rewr_conv UtilBase.backward_conv_th)
    in
      [Update.thm_update (id, (ths MRS choice))]
    end
    handle THM _ => []))
\<close> *)

(*subsection \<open>Least operator\<close>
lemma Least_equality' [backward1]:
  "P (x::('a::order)) \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Least P = x" by (simp add: Least_equality)*)

subsection \<open>Pairs\<close>
setup \<open>add_rewrite_rule @{thm fst_pair_eq}\<close>
setup \<open>add_rewrite_rule @{thm snd_pair_eq}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm pair_eq_iff})\<close>
setup \<open>Auto2_Setup.Normalizer.add_rewr_normalizer ("rewr_case", @{thm uncurry_def})\<close>

subsection \<open>Let\<close>
setup \<open>Auto2_Setup.Normalizer.add_rewr_normalizer ("rewr_let", @{thm Let_def})\<close>

(*subsection \<open>Equivalence relations\<close>
setup \<open>add_forward_prfstep @{thm Relation.symD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.symI}\<close>
setup \<open>add_forward_prfstep @{thm Relation.transD}\<close>
setup \<open>add_backward_prfstep @{thm Relation.transI}\<close>

subsection \<open>Options\<close>
setup \<open>add_resolve_prfstep @{thm option.distinct(1)}\<close>
setup \<open>add_rewrite_rule @{thm Option.option.sel}\<close>
setup \<open>add_forward_prfstep @{thm option.collapse}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm option.simps(1)})\<close>
setup \<open>fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms Option.option.case}\<close>*)

end