(*  Title:       Iterators over Representations of Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section {* \isaheader{Iterators over Representations of Finite Sets} *}
theory SetAbstractionIterator
imports Main SetIterator
begin

text {* Sometimes, an iterator does not iterate over an abstract set directly.
 Especialy, if datastructures that are composed of several concrete datastructures
 for maps or sets are involved, it might be interesting to iterate over
 representations of values instead of the abstract values. This leads to the following construct. *}

locale set_iterator_abs_genord =
  fixes \<alpha> :: "'xc \<Rightarrow> 'xa"
    and invar :: "'xc \<Rightarrow> bool"
    and iti::"('xc,'\<sigma>) set_iterator"
    and S0::"'xa set"
    and R::"'xa \<Rightarrow> 'xa \<Rightarrow> bool"
  assumes foldli_transform:
    "\<exists>lc. (\<forall>xc \<in> set lc. invar xc) \<and>
          distinct (map \<alpha> lc) \<and> S0 = set (map \<alpha> lc) \<and>
          sorted_by_rel R (map \<alpha> lc) \<and> iti = foldli lc"
begin
  text {* In the simplest case, the function used for iteration does not depend on
    the representation, but just the abstract values. In this case, the \emph{normal} iterators
    can be used with an adapted function. *}
  lemma remove_abs :
    assumes f_OK: "\<And>xc. invar xc \<Longrightarrow> \<alpha> xc \<in> S0 \<Longrightarrow> fc xc = fa (\<alpha> xc)"
        and it_OK: "\<And>iti. set_iterator_genord iti S0 R \<Longrightarrow> P (iti c fa \<sigma>0)"
    shows "P (iti c fc \<sigma>0)"
  proof -
    from foldli_transform obtain lc where
          lc_invar: "\<And>xc. xc \<in> set lc \<Longrightarrow> invar xc"
      and \<alpha>_props: "distinct (map \<alpha> lc)" "S0 = set (map \<alpha> lc)"
                   "sorted_by_rel R (map \<alpha> lc)"
      and iti_eq: "iti = foldli lc" by blast

    from \<alpha>_props have "set_iterator_genord (foldli (map \<alpha> lc)) S0 R"
      by (rule_tac set_iterator_genord_I [of "map \<alpha> lc"]) simp_all
    with it_OK have P_OK: "P (foldli (map \<alpha> lc) c fa \<sigma>0)" by blast

    from lc_invar f_OK[unfolded \<alpha>_props(2)]
    have "foldli (map \<alpha> lc) c fa \<sigma>0 = foldli lc c fc \<sigma>0"
      by (induct lc arbitrary: \<sigma>0) simp_all

    with P_OK iti_eq show ?thesis by simp
  qed

  text {* In general, one needs the representation, though. Even in this case,
    the construct can be reduced to standard iterators. *}
  lemma remove_abs2 :
    "\<exists>S0'. set_iterator_genord iti S0' (\<lambda>x y. R (\<alpha> x) (\<alpha> y)) \<and>
           inj_on \<alpha> S0' \<and> \<alpha> ` S0' = S0 \<and> (\<forall>x \<in> S0'. invar x)"
  proof -
    from foldli_transform obtain lc where
          lc_invar: "\<And>xc. xc \<in> set lc \<Longrightarrow> invar xc"
      and \<alpha>_props: "distinct (map \<alpha> lc)" "S0 = set (map \<alpha> lc)"
                   "sorted_by_rel R (map \<alpha> lc)"
      and iti_eq: "iti = foldli lc" by blast
    from \<alpha>_props have it': "set_iterator_genord iti (set lc) (\<lambda>x y. R (\<alpha> x) (\<alpha> y))"
      apply (rule_tac set_iterator_genord_I [of lc])
      apply (simp_all add: distinct_map sorted_by_rel_map iti_eq)
    done

    from \<alpha>_props show ?thesis
      apply (rule_tac exI[where x = "set lc"])
      apply (simp add: lc_invar distinct_map it')
    done
  qed

  text {* Let's now derive the inference rules for iterators over representations. *}

  lemma iteratei_abs_simple_rule_P:
  assumes f_OK: "\<And>xc. invar xc \<Longrightarrow> \<alpha> xc \<in> S0 \<Longrightarrow> f xc = f' (\<alpha> xc)"
  assumes pre :
      "I S0 \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0;
                 \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0 - S. R y x\<rbrakk>
                 \<Longrightarrow> I (S - {x}) (f' x \<sigma>)"
      "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> c \<sigma>; I S \<sigma>;
               \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iti c f \<sigma>0)"
    apply (rule remove_abs[of f f' P c \<sigma>0])
    apply (simp add: f_OK)
    apply (erule set_iterator_genord.iteratei_rule_P [of _ S0 R I])
    apply (simp_all add: pre)
  done

  lemma iteratei_abs_simple_rule_insert_P:
  assumes f_OK: "\<And>xc. invar xc \<Longrightarrow> \<alpha> xc \<in> S0 \<Longrightarrow> f xc = f' (\<alpha> xc)"
  assumes pre :
      "I {} \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>(S0 - S) - {x}. R x y;
                 \<forall>y\<in>S. R y x\<rbrakk>
                  \<Longrightarrow> I (insert x S) (f' x \<sigma>)"
      "\<And>\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> S0;
              \<not> (c \<sigma>); I S \<sigma>; \<forall>x\<in>S0-S. \<forall>y\<in>S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
    apply (rule remove_abs[of f f' P c \<sigma>0])
    apply (simp add: f_OK)
    apply (erule set_iterator_genord.iteratei_rule_insert_P [of _ S0 R I])
    apply (simp_all add: pre)
  done

  lemma iteratei_abs_rule_P:
  assumes pre :
      "I S0 \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; invar x; \<alpha> x \<in> S; I S \<sigma>; S \<subseteq> S0;
                 \<forall>y\<in>S - {\<alpha> x}. R (\<alpha> x) y; \<forall>y\<in>S0 - S. R y (\<alpha> x)\<rbrakk>
                 \<Longrightarrow> I (S - {\<alpha> x}) (f x \<sigma>)"
      "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> c \<sigma>; I S \<sigma>;
               \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iti c f \<sigma>0)"
  proof -
    obtain S0' where S0'_props: "set_iterator_genord iti S0' (\<lambda>x y. R (\<alpha> x) (\<alpha> y))"
       "inj_on \<alpha> S0'" "S0 = \<alpha> ` S0'" "\<And>x. x \<in> S0' \<Longrightarrow> invar x" by (metis remove_abs2)

    show ?thesis
    proof (rule set_iterator_genord.iteratei_rule_P[OF S0'_props(1), of "\<lambda>S \<sigma>. I (\<alpha> ` S) \<sigma>" \<sigma>0 c], goal_cases)
      case 1
      thus ?case using S0'_props pre by simp
    next
      case 3 thus ?case using S0'_props pre by simp
    next
      case prems: (2 S \<sigma> x)

      from prems S0'_props have inv_x: "invar x" by blast
      from prems(4) have subs_alpha: "\<alpha> ` S \<subseteq> \<alpha> ` S0'" by auto
      from S0'_props prems(2,4)
      have diff_alpha: "\<alpha> ` S - {\<alpha> x} = \<alpha> ` (S - {x})" "\<alpha> ` S0' - \<alpha> ` S = \<alpha> ` (S0' - S)"
       by (auto simp add: inj_on_def subset_iff Ball_def)

      show ?case
        using pre(2)[of \<sigma> x "\<alpha> ` S"] S0'_props(3)
        by (simp add: inv_x prems subs_alpha diff_alpha)
    next
      case prems: (4 \<sigma> S)
      show ?case
        using pre(4)[of "\<alpha> ` S" \<sigma>] prems S0'_props
        by auto
    qed
  qed

      from prems S0'_props have inv_x: "invar x" by blast
      from prems(4) have subs_alpha: "\<alpha> ` S \<subseteq> \<alpha> ` S0'" by auto
      from S0'_props prems(2,4)
      have diff_alpha: "\<alpha> ` (S0' - S) - {\<alpha> x} = \<alpha> ` ((S0' - S) - {x})" "\<alpha> ` S0' - \<alpha> ` S = \<alpha> ` (S0' - S)"
       by (auto simp add: inj_on_def subset_iff Ball_def)

      show ?case
        using pre(2)[of \<sigma> x "\<alpha> ` S"] prems S0'_props(3)
        by (simp add: diff_alpha inv_x subs_alpha)
    next
      case prems: (4 \<sigma> S)

      from prems(1) have subs_alpha: "\<alpha> ` S \<subseteq> \<alpha> ` S0'" by auto

      from S0'_props prems
      have diff_alpha: "\<alpha> ` S0' - \<alpha> ` S = \<alpha> ` (S0' - S)"
       by (auto simp add: inj_on_def subset_iff Ball_def)

      from prems(1,2) S0'_props(2,3)
      have alpha_eq: "\<alpha> ` S \<noteq> \<alpha> ` S0'"
        apply (simp add: inj_on_def set_eq_iff image_iff Bex_def subset_iff)
        apply blast
      done

      show ?case
        using pre(4)[of "\<alpha> ` S" \<sigma>] S0'_props prems
        by (auto simp add: subs_alpha diff_alpha alpha_eq)
    qed
  qed
end

lemma set_iterator_abs_genord_trivial:
  "set_iterator_abs_genord id (\<lambda>_. True) = set_iterator_genord"
by (simp add: set_iterator_genord_def set_iterator_abs_genord_def fun_eq_iff)

lemma set_iterator_abs_genord_trivial_simp [simp] :
  assumes "\<forall>x. invar x"
      and "\<forall>x. \<alpha> x = x"
shows "set_iterator_abs_genord \<alpha> invar = set_iterator_genord"
proof -
  from assms have "invar = (\<lambda>_. True)" and "\<alpha> = id"
    by (simp_all add: fun_eq_iff)
  thus ?thesis by (simp add: set_iterator_abs_genord_trivial)
qed

subsection {* Introduce iterators over representations *}
lemma set_iterator_abs_genord_I2 :
  assumes it_OK: "set_iterator_genord iti S0 Rc"
      and R_OK: "\<And>xc1 xc2. \<lbrakk>invar xc1; invar xc2; Rc xc1 xc2\<rbrakk> \<Longrightarrow> Ra (\<alpha> xc1) (\<alpha> xc2)"
      and dist: "\<And>xc1 xc2. \<lbrakk>invar xc1; invar xc2; xc1 \<in> S0; xc2 \<in> S0; \<alpha> xc1 = \<alpha> xc2\<rbrakk> \<Longrightarrow> xc1 = xc2"
      and invar: "\<And>xc. xc \<in> S0 \<Longrightarrow> invar xc"
      and S0'_eq: "S0' = \<alpha> ` S0"
  shows "set_iterator_abs_genord \<alpha> invar iti S0' Ra"
  proof -
    from it_OK obtain l0 where dist_l0: "distinct l0" and
          S0_eq: "S0 = set l0" and
          sort_Rc: "sorted_by_rel Rc l0"  and iti_eq: "iti = foldli l0"
      unfolding set_iterator_genord_def by auto

    have "set l0 \<subseteq> S0" unfolding S0_eq by simp
    with dist_l0 sort_Rc
    have map_props: "distinct (map \<alpha> l0) \<and> sorted_by_rel Ra (map \<alpha> l0)"
    proof (induct l0)
      case Nil thus ?case by simp
    next
      case (Cons x l0)
      hence "distinct l0" and "x \<notin> set l0" and "x \<in> S0" and "set l0 \<subseteq> S0" and
            "distinct (map \<alpha> l0)" "sorted_by_rel Ra (map \<alpha> l0)" "\<And>x'. x' \<in> set l0 \<Longrightarrow> Rc x x'"
        by (simp_all)
      thus ?case using dist[of x] R_OK[of x] invar
        apply (simp add: image_iff Ball_def subset_iff)
        apply metis
      done
    qed

    show ?thesis
      unfolding S0'_eq
      apply (rule set_iterator_abs_genord.intro)
      apply (rule_tac exI[where x = l0])
      apply (simp add: iti_eq map_props S0_eq Ball_def invar)
    done
  qed

subsection {* Map-Iterators *}

lemma map_to_set_cong:
  "map_to_set m1 = map_to_set m2 \<longleftrightarrow> m1 = m2"
apply (simp add: set_eq_iff map_to_set_def)
apply (simp add: fun_eq_iff)
apply (metis not_Some_eq)
done

definition "map_iterator_abs_genord \<alpha> invar it m R \<equiv>
set_iterator_abs_genord (\<lambda>(k,v). (k, \<alpha> v)) (\<lambda>(k,v). invar v) it (map_to_set m) R"

lemma map_iterator_abs_genord_I2 :
  assumes it_OK: "map_iterator_genord iti m R'"
      and invar: "\<And>k v. m k = Some v \<Longrightarrow> invar v"
      and R_OK: "\<And>k v k' v'. invar v \<Longrightarrow> invar v' \<Longrightarrow> R' (k, v) (k', v') \<Longrightarrow> R (k, \<alpha> v) (k', \<alpha> v')"
      and m'_eq: "m' = ((map_option \<alpha>) o m)"
  shows "map_iterator_abs_genord \<alpha> invar iti m' R"
proof -
  let ?\<alpha>' = "\<lambda>(k,v). (k, \<alpha> v)"
  let ?invar' = "\<lambda>(k,v). invar v"

  have \<alpha>_rewr: "?\<alpha>' ` (map_to_set m) = map_to_set ((map_option \<alpha>) o m)"
    by (auto simp add: map_to_set_def)

  note rule' = set_iterator_abs_genord_I2[OF it_OK[unfolded set_iterator_def],
    of ?invar' R ?\<alpha>' "map_to_set (map_option \<alpha> \<circ> m)", unfolded \<alpha>_rewr map_iterator_abs_genord_def[symmetric]]

  show ?thesis
    unfolding m'_eq
    apply (rule rule')
    apply (auto simp add: map_to_set_def invar R_OK)
  done
qed

lemma map_iterator_abs_genord_remove_abs2 :
  assumes iti: "map_iterator_abs_genord \<alpha> invar iti m R"
  obtains m' where "map_iterator_genord iti m' (\<lambda>(k, v) (k', v'). R (k, \<alpha> v) (k', \<alpha> v'))"
       "(map_option \<alpha>) o m' = m" "\<And>k v. m' k = Some v \<Longrightarrow> invar v"
  proof -
    let ?\<alpha>' = "\<lambda>(k,v). (k, \<alpha> v)"
    let ?invar' = "\<lambda>(k,v). invar v"

    from set_iterator_abs_genord.foldli_transform [OF iti[unfolded map_iterator_abs_genord_def]]
    obtain lc where lc_invar: "\<And>k v. (k, v) \<in> set lc \<Longrightarrow> invar v"
      and \<alpha>_props: "distinct (map ?\<alpha>' lc)" "map_to_set m = set (map ?\<alpha>' lc)"
                   "sorted_by_rel R (map ?\<alpha>' lc)"
      and iti_eq: "iti = foldli lc" by blast

    from \<alpha>_props(2)[symmetric] have in_lc: "\<And>k v. (k, v) \<in> set lc \<Longrightarrow> m k = Some (\<alpha> v)"
      by (auto simp add: set_eq_iff image_iff map_to_set_def Ball_def Bex_def)
    from \<alpha>_props(1) have inj_on_\<alpha>': "inj_on ?\<alpha>' (set lc)" by (simp add: distinct_map)

    from in_lc inj_on_\<alpha>'
    have inj_on_fst: "inj_on fst (set lc)"
      apply (simp add: inj_on_def Ball_def)
      apply (metis option.inject)
    done

    let ?m' = "map_of lc"

    from \<alpha>_props have it': "map_iterator_genord iti ?m' (\<lambda>x y. R (?\<alpha>' x) (?\<alpha>' y))"
      apply (rule_tac set_iterator_genord_I [of lc])
      apply (simp_all add: distinct_map sorted_by_rel_map iti_eq map_to_set_map_of inj_on_fst)
    done

    from inj_on_fst \<alpha>_props(1)
    have "distinct (map fst (map ?\<alpha>' lc))"
      by (auto simp add: distinct_map inj_on_def Ball_def)
    hence "map_to_set m = map_to_set (map_of (map ?\<alpha>' lc))"
      by (simp add: \<alpha>_props map_to_set_map_of)
    hence m_eq: "map_option \<alpha> \<circ> map_of lc = m"
      by (simp add: map_of_map[symmetric] map_to_set_cong)

    from that[of ?m'] it' lc_invar \<alpha>_props(1) show ?thesis
      by (simp add: distinct_map split_def inj_on_fst ran_distinct m_eq)
  qed

lemma map_iterator_abs_genord_rule_P:
  assumes iti_OK: "map_iterator_abs_genord \<alpha> invar iti m R"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; invar v; m k = Some (\<alpha> v); it \<subseteq> dom m; I it \<sigma>;
                             \<forall>k' v'. k' \<in> it-{k} \<and> invar v' \<and> m k' = Some (\<alpha> v') \<longrightarrow> R (k, \<alpha> v) (k', \<alpha> v');
                             \<forall>k' v'. k' \<notin> it \<and> invar v' \<and> m k' = Some (\<alpha> v') \<longrightarrow> R (k', \<alpha> v') (k, \<alpha> v)\<rbrakk> \<Longrightarrow>
                            I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                         \<forall>k v k' v'. k \<notin> it \<and> invar v \<and> m k = Some (\<alpha> v) \<and>
                                     k' \<in> it \<and> invar v' \<and> m k' = Some (\<alpha> v') \<longrightarrow>
                                     R (k, \<alpha> v) (k', \<alpha> v') \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
proof -
  let ?\<alpha>' = "\<lambda>(k,v). (k, \<alpha> v)"
  let ?invar' = "\<lambda>(k,v). invar v"

  from map_iterator_abs_genord_remove_abs2 [OF iti_OK]
  obtain m' where m'_props: "map_iterator_genord iti m' (\<lambda>x y. R (?\<alpha>' x) (?\<alpha>' y))"
     "m = map_option \<alpha> \<circ> m'" "\<And>k v. m' k = Some v \<Longrightarrow> invar v"
     by (auto simp add: split_def)

  have dom_m'_eq: "dom m' = dom m"
    unfolding m'_props by (simp add: dom_def)

  show ?thesis
  proof (rule map_iterator_genord_rule_P[OF m'_props(1), of I], goal_cases)
    case 1
    thus ?case using I0 by (simp add: dom_m'_eq)
  next
    case 3
    thus ?case using IF by simp
  next
    case prems: (2 k v S \<sigma>)
    from IP [of \<sigma> k S v] prems
    show ?case
      by (simp add: m'_props) metis
  next
    case prems: (4 \<sigma> S)
    show ?case
      using II[of S \<sigma>] prems
      by (simp add: m'_props) metis
  qed
qed

lemma map_iterator_abs_genord_rule_insert_P:
  assumes iti_OK: "map_iterator_abs_genord \<alpha> invar iti m R"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; invar v; m k = Some (\<alpha> v); it \<subseteq> dom m; I it \<sigma>;
                             \<forall>k' v'. k' \<in> (dom m - it)-{k} \<and> invar v' \<and> m k' = Some (\<alpha> v') \<longrightarrow> R (k, \<alpha> v) (k', \<alpha> v');
                             \<forall>k' v'. k' \<in> it \<and> invar v' \<and> m k' = Some (\<alpha> v') \<longrightarrow> R (k', \<alpha> v') (k, \<alpha> v)\<rbrakk> \<Longrightarrow>
                            I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                         \<forall>k v k' v'. k \<in> it \<and> invar v \<and> m k = Some (\<alpha> v) \<and>
                                     k' \<notin> it \<and> invar v' \<and> m k' = Some (\<alpha> v') \<longrightarrow>
                                     R (k, \<alpha> v) (k', \<alpha> v') \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
proof -
  let ?\<alpha>' = "\<lambda>(k,v). (k, \<alpha> v)"
  let ?invar' = "\<lambda>(k,v). invar v"

  from map_iterator_abs_genord_remove_abs2 [OF iti_OK]
  obtain m' where m'_props: "map_iterator_genord iti m' (\<lambda>x y. R (?\<alpha>' x) (?\<alpha>' y))"
     "m = map_option \<alpha> \<circ> m'" "\<And>k v. m' k = Some v \<Longrightarrow> invar v"
     by (auto simp add: split_def)

  have dom_m'_eq: "dom m' = dom m"
    unfolding m'_props by (simp add: dom_def)

  show ?thesis
  proof (rule map_iterator_genord_rule_insert_P[OF m'_props(1), of I], goal_cases)
    case 1
    thus ?case using I0 by simp
  next
    case 3
    thus ?case using IF by (simp add: dom_m'_eq)
  next
    case prems: (2 k v S \<sigma>)
    from IP [of \<sigma> k S v] prems
    show ?case
      by (simp add: m'_props) metis
  next
    case prems: (4 \<sigma> S)
    show ?case
      using II[of S \<sigma>] prems
      by (simp add: m'_props) metis
  qed
qed

subsection {* Unsorted Iterators *}

definition "set_iterator_abs \<alpha> invar it S0 \<equiv> set_iterator_abs_genord \<alpha> invar it S0 (\<lambda>_ _. True)"

lemma set_iterator_abs_trivial:
  "set_iterator_abs id (\<lambda>_. True) = set_iterator"
by (simp add: set_iterator_def set_iterator_abs_def fun_eq_iff)

lemma set_iterator_abs_trivial_simp [simp]:
  assumes "\<forall>x. invar x"
      and "\<forall>x. \<alpha> x = x"
shows "set_iterator_abs \<alpha> invar = set_iterator"
proof -
  from assms have "invar = (\<lambda>_. True)" and "\<alpha> = id"
    by (simp_all add: fun_eq_iff)
  thus ?thesis by (simp add: set_iterator_abs_trivial)
qed

lemma set_iterator_abs_I2 :
  assumes it_OK: "set_iterator iti S0"
      and dist: "\<And>xc1 xc2. \<lbrakk>invar xc1; invar xc2; xc1 \<in> S0; xc2 \<in> S0; \<alpha> xc1 = \<alpha> xc2\<rbrakk> \<Longrightarrow> xc1 = xc2"
      and invar: "\<And>xc. xc \<in> S0 \<Longrightarrow> invar xc"
      and S0'_OK: "S0' = \<alpha> ` S0"
  shows "set_iterator_abs \<alpha> invar iti S0'"
unfolding set_iterator_abs_def S0'_OK
apply (rule set_iterator_abs_genord_I2[OF it_OK[unfolded set_iterator_def], of invar _ \<alpha>])
apply (simp_all add: dist invar)
done

lemma set_iterator_abs_simple_rule_P:
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   (\<And>xc. invar xc \<Longrightarrow> f xc = f' (\<alpha> xc));
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f' x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_simple_rule_P [of \<alpha> invar it S0 "\<lambda>_ _. True" f f' I \<sigma>0 c P]
by simp

lemma set_iterator_abs_simple_no_cond_rule_P:
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   (\<And>xc. invar xc \<Longrightarrow> f xc = f' (\<alpha> xc));
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f' x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
using set_iterator_abs_simple_rule_P[of \<alpha> invar it S0 f f' I \<sigma>0 "\<lambda>_. True" P]
by simp

lemma set_iterator_abs_simple_rule_insert_P :
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   (\<And>xc. invar xc \<Longrightarrow> f xc = f' (\<alpha> xc));
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f' x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_simple_rule_insert_P [of \<alpha> invar it S0 "\<lambda>_ _. True" f f' I \<sigma>0 c P]
by simp

lemma set_iterator_abs_no_cond_simple_rule_insert_P :
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   (\<And>xc. invar xc \<Longrightarrow> f xc = f' (\<alpha> xc));
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f' x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
using set_iterator_abs_simple_rule_insert_P[of \<alpha> invar it S0 f f' I \<sigma>0 "\<lambda>_. True" P]
by simp

lemma set_iterator_abs_rule_P:
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; invar x; \<alpha> x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {\<alpha> x}) (f x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_rule_P [of \<alpha> invar it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
by simp

lemma set_iterator_abs_no_cond_rule_P:
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> invar x; \<alpha> x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {\<alpha> x}) (f x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
using set_iterator_abs_rule_P[of \<alpha> invar it S0 I \<sigma>0 "\<lambda>_. True" f P]
by simp

lemma set_iterator_abs_rule_insert_P :
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; invar x; \<alpha> x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert (\<alpha> x) S) (f x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_rule_insert_P [of \<alpha> invar it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
by simp

lemma set_iterator_abs_no_cond_rule_insert_P :
"\<lbrakk> set_iterator_abs \<alpha> invar it S0;
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> invar x; \<alpha> x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert (\<alpha> x) S) (f x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
using set_iterator_abs_rule_insert_P[of \<alpha> invar it S0 I \<sigma>0 "\<lambda>_. True" f P]
by simp

subsection {* Unsorted Map-Iterators *}

definition "map_iterator_abs \<alpha> invar it m \<equiv> map_iterator_abs_genord \<alpha> invar it m (\<lambda>_ _. True)"

lemma map_iterator_abs_trivial:
  "map_iterator_abs id (\<lambda>_. True) = map_iterator"
by (simp add: set_iterator_def map_iterator_abs_def map_iterator_abs_genord_def
              set_iterator_abs_genord_def set_iterator_genord_def fun_eq_iff)

lemma map_iterator_abs_trivial_simp [simp] :
  assumes "\<forall>x. invar x"
      and "\<forall>x. \<alpha> x = x"
shows "map_iterator_abs \<alpha> invar = map_iterator"
proof -
  from assms have "invar = (\<lambda>_. True)" and "\<alpha> = id"
    by (simp_all add: fun_eq_iff)
  thus ?thesis by (simp add: map_iterator_abs_trivial)
qed

lemma map_iterator_abs_I2 :
  assumes it_OK: "map_iterator iti m"
      and invar: "\<And>k v. m k = Some v \<Longrightarrow> invar v"
      and m'_eq: "m' = map_option \<alpha> \<circ> m"
  shows "map_iterator_abs \<alpha> invar iti m'"
using assms
unfolding map_iterator_abs_def set_iterator_def
by (rule_tac map_iterator_abs_genord_I2 [OF it_OK[unfolded set_iterator_def]]) simp_all

lemma map_iterator_abs_rule_P:
  assumes iti_OK: "map_iterator_abs \<alpha> invar iti m"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; invar v; m k = Some (\<alpha> v); it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow>
                            I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
apply (rule map_iterator_abs_genord_rule_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF II)
done

lemma map_iterator_abs_no_cond_rule_P:
  assumes iti_OK: "map_iterator_abs \<alpha> invar iti m"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; invar v; m k = Some (\<alpha> v); it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow>
                            I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (iti (\<lambda>_. True) f \<sigma>0)"
apply (rule map_iterator_abs_rule_P [OF iti_OK, of I])
apply (simp_all add: I0 IP IF)
done

lemma map_iterator_abs_rule_insert_P:
  assumes iti_OK: "map_iterator_abs \<alpha> invar iti m"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; invar v; m k = Some (\<alpha> v); it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow>
                            I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
apply (rule map_iterator_abs_genord_rule_insert_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF II)
done

lemma map_iterator_abs_no_cond_rule_insert_P:
  assumes iti_OK: "map_iterator_abs \<alpha> invar iti m"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> dom m - it; invar v; m k = Some (\<alpha> v); it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow>
                            I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (iti (\<lambda>_. True) f \<sigma>0)"
apply (rule map_iterator_abs_genord_rule_insert_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF)
done

end


(*  Title:      ZF/ZF.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section{*Zermelo-Fraenkel Set Theory*}

theory ZF
imports "~~/src/FOL/FOL"
begin

declare [[eta_contract = false]]

typedecl i
instance i :: "term" ..

axiomatization
  zero :: "i"  ("0")   --{*the empty set*}  and
  Pow :: "i => i"  --{*power sets*}  and
  Inf :: "i"  --{*infinite set*}

text {*Bounded Quantifiers *}
consts
  Ball   :: "[i, i => o] => o"
  Bex   :: "[i, i => o] => o"

text {*General Union and Intersection *}
axiomatization Union :: "i => i"
consts Inter :: "i => i"

text {*Variations on Replacement *}
axiomatization PrimReplace :: "[i, [i, i] => o] => i"
consts
  Replace     :: "[i, [i, i] => o] => i"
  RepFun      :: "[i, i => i] => i"
  Collect     :: "[i, i => o] => i"

text{*Definite descriptions -- via Replace over the set "1"*}
consts
  The         :: "(i => o) => i"      (binder "THE " 10)
  If          :: "[o, i, i] => i"     ("(if (_)/ then (_)/ else (_))" [10] 10)

abbreviation (input)
  old_if      :: "[o, i, i] => i"   ("if '(_,_,_')") where
  "if(P,a,b) == If(P,a,b)"

text {*Finite Sets *}
consts
  Upair :: "[i, i] => i"
  cons  :: "[i, i] => i"
  succ  :: "i => i"

text {*Ordered Pairing *}
consts
  Pair  :: "[i, i] => i"
  fst   :: "i => i"
  snd   :: "i => i"
  split :: "[[i, i] => 'a, i] => 'a::{}"  --{*for pattern-matching*}

text {*Sigma and Pi Operators *}
consts
  Sigma :: "[i, i => i] => i"
  Pi    :: "[i, i => i] => i"

text {*Relations and Functions *}
consts
  "domain"    :: "i => i"
  range       :: "i => i"
  field       :: "i => i"
  converse    :: "i => i"
  relation    :: "i => o"        --{*recognizes sets of pairs*}
  "function"  :: "i => o"        --{*recognizes functions; can have non-pairs*}
  Lambda      :: "[i, i => i] => i"
  restrict    :: "[i, i] => i"

text {*Infixes in order of decreasing precedence *}
consts

  Image       :: "[i, i] => i"    (infixl "``" 90) --{*image*}
  vimage      :: "[i, i] => i"    (infixl "-``" 90) --{*inverse image*}
  "apply"     :: "[i, i] => i"    (infixl "`" 90) --{*function application*}
  "Int"       :: "[i, i] => i"    (infixl "Int" 70) --{*binary intersection*}
  "Un"        :: "[i, i] => i"    (infixl "Un" 65) --{*binary union*}
  Diff        :: "[i, i] => i"    (infixl "-" 65) --{*set difference*}
  Subset      :: "[i, i] => o"    (infixl "<=" 50) --{*subset relation*}

axiomatization
  mem         :: "[i, i] => o"    (infixl ":" 50) --{*membership relation*}

abbreviation
  not_mem :: "[i, i] => o"  (infixl "~:" 50)  --{*negated membership relation*}
  where "x ~: y == ~ (x : y)"

abbreviation
  cart_prod :: "[i, i] => i"    (infixr "*" 80) --{*Cartesian product*}
  where "A * B == Sigma(A, %_. B)"

abbreviation
  function_space :: "[i, i] => i"  (infixr "->" 60) --{*function space*}
  where "A -> B == Pi(A, %_. B)"

nonterminal "is" and patterns

syntax
  ""          :: "i => is"                   ("_")
  "_Enum"     :: "[i, is] => is"             ("_,/ _")

  "_Finset"   :: "is => i"                   ("{(_)}")
  "_Tuple"    :: "[i, is] => i"              ("<(_,/ _)>")
  "_Collect"  :: "[pttrn, i, o] => i"        ("(1{_: _ ./ _})")
  "_Replace"  :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _: _, _})")
  "_RepFun"   :: "[i, pttrn, i] => i"        ("(1{_ ./ _: _})" [51,0,51])
  "_INTER"    :: "[pttrn, i, i] => i"        ("(3INT _:_./ _)" 10)
  "_UNION"    :: "[pttrn, i, i] => i"        ("(3UN _:_./ _)" 10)
  "_PROD"     :: "[pttrn, i, i] => i"        ("(3PROD _:_./ _)" 10)
  "_SUM"      :: "[pttrn, i, i] => i"        ("(3SUM _:_./ _)" 10)
  "_lam"      :: "[pttrn, i, i] => i"        ("(3lam _:_./ _)" 10)
  "_Ball"     :: "[pttrn, i, o] => o"        ("(3ALL _:_./ _)" 10)
  "_Bex"      :: "[pttrn, i, o] => o"        ("(3EX _:_./ _)" 10)

  (** Patterns -- extends pre-defined type "pttrn" used in abstractions **)

  "_pattern"  :: "patterns => pttrn"         ("<_>")
  ""          :: "pttrn => patterns"         ("_")
  "_patterns" :: "[pttrn, patterns] => patterns"  ("_,/_")

translations
  "{x, xs}"     == "CONST cons(x, {xs})"
  "{x}"         == "CONST cons(x, 0)"
  "{x:A. P}"    == "CONST Collect(A, %x. P)"
  "{y. x:A, Q}" == "CONST Replace(A, %x y. Q)"
  "{b. x:A}"    == "CONST RepFun(A, %x. b)"
  "INT x:A. B"  == "CONST Inter({B. x:A})"
  "UN x:A. B"   == "CONST Union({B. x:A})"
  "PROD x:A. B" == "CONST Pi(A, %x. B)"
  "SUM x:A. B"  == "CONST Sigma(A, %x. B)"
  "lam x:A. f"  == "CONST Lambda(A, %x. f)"
  "ALL x:A. P"  == "CONST Ball(A, %x. P)"
  "EX x:A. P"   == "CONST Bex(A, %x. P)"

  "<x, y, z>"   == "<x, <y, z>>"
  "<x, y>"      == "CONST Pair(x, y)"
  "%<x,y,zs>.b" == "CONST split(%x <y,zs>.b)"
  "%<x,y>.b"    == "CONST split(%x y. b)"

notation (xsymbols)
  cart_prod       (infixr "\<times>" 80) and
  Int             (infixl "\<inter>" 70) and
  Un              (infixl "\<union>" 65) and
  function_space  (infixr "\<rightarrow>" 60) and
  Subset          (infixl "\<subseteq>" 50) and
  mem             (infixl "\<in>" 50) and
  not_mem         (infixl "\<notin>" 50) and
  Union           ("\<Union>_" [90] 90) and
  Inter           ("\<Inter>_" [90] 90)

syntax (xsymbols)
  "_Collect"  :: "[pttrn, i, o] => i"        ("(1{_ \<in> _ ./ _})")
  "_Replace"  :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _ \<in> _, _})")
  "_RepFun"   :: "[i, pttrn, i] => i"        ("(1{_ ./ _ \<in> _})" [51,0,51])
  "_UNION"    :: "[pttrn, i, i] => i"        ("(3\<Union>_\<in>_./ _)" 10)
  "_INTER"    :: "[pttrn, i, i] => i"        ("(3\<Inter>_\<in>_./ _)" 10)
  "_PROD"     :: "[pttrn, i, i] => i"        ("(3\<Pi>_\<in>_./ _)" 10)
  "_SUM"      :: "[pttrn, i, i] => i"        ("(3\<Sigma>_\<in>_./ _)" 10)
  "_lam"      :: "[pttrn, i, i] => i"        ("(3\<lambda>_\<in>_./ _)" 10)
  "_Ball"     :: "[pttrn, i, o] => o"        ("(3\<forall>_\<in>_./ _)" 10)
  "_Bex"      :: "[pttrn, i, o] => o"        ("(3\<exists>_\<in>_./ _)" 10)
  "_Tuple"    :: "[i, is] => i"              ("\<langle>(_,/ _)\<rangle>")
  "_pattern"  :: "patterns => pttrn"         ("\<langle>_\<rangle>")

notation (HTML output)
  cart_prod       (infixr "\<times>" 80) and
  Int             (infixl "\<inter>" 70) and
  Un              (infixl "\<union>" 65) and
  Subset          (infixl "\<subseteq>" 50) and
  mem             (infixl "\<in>" 50) and
  not_mem         (infixl "\<notin>" 50) and
  Union           ("\<Union>_" [90] 90) and
  Inter           ("\<Inter>_" [90] 90)

syntax (HTML output)
  "_Collect"  :: "[pttrn, i, o] => i"        ("(1{_ \<in> _ ./ _})")
  "_Replace"  :: "[pttrn, pttrn, i, o] => i" ("(1{_ ./ _ \<in> _, _})")
  "_RepFun"   :: "[i, pttrn, i] => i"        ("(1{_ ./ _ \<in> _})" [51,0,51])
  "_UNION"    :: "[pttrn, i, i] => i"        ("(3\<Union>_\<in>_./ _)" 10)
  "_INTER"    :: "[pttrn, i, i] => i"        ("(3\<Inter>_\<in>_./ _)" 10)
  "_PROD"     :: "[pttrn, i, i] => i"        ("(3\<Pi>_\<in>_./ _)" 10)
  "_SUM"      :: "[pttrn, i, i] => i"        ("(3\<Sigma>_\<in>_./ _)" 10)
  "_lam"      :: "[pttrn, i, i] => i"        ("(3\<lambda>_\<in>_./ _)" 10)
  "_Ball"     :: "[pttrn, i, o] => o"        ("(3\<forall>_\<in>_./ _)" 10)
  "_Bex"      :: "[pttrn, i, o] => o"        ("(3\<exists>_\<in>_./ _)" 10)
  "_Tuple"    :: "[i, is] => i"              ("\<langle>(_,/ _)\<rangle>")
  "_pattern"  :: "patterns => pttrn"         ("\<langle>_\<rangle>")

defs  (* Bounded Quantifiers *)
  Ball_def:      "Ball(A, P) == \<forall>x. x\<in>A \<longrightarrow> P(x)"
  Bex_def:       "Bex(A, P) == \<exists>x. x\<in>A & P(x)"

  subset_def:    "A \<subseteq> B == \<forall>x\<in>A. x\<in>B"

axiomatization where

  (* ZF axioms -- see Suppes p.238
     Axioms for Union, Pow and Replace state existence only,
     uniqueness is derivable using extensionality. *)

  extension:     "A = B <-> A \<subseteq> B & B \<subseteq> A" and
  Union_iff:     "A \<in> \<Union>(C) <-> (\<exists>B\<in>C. A\<in>B)" and
  Pow_iff:       "A \<in> Pow(B) <-> A \<subseteq> B" and

  (*We may name this set, though it is not uniquely defined.*)
  infinity:      "0\<in>Inf & (\<forall>y\<in>Inf. succ(y): Inf)" and

  (*This formulation facilitates case analysis on A.*)
  foundation:    "A=0 | (\<exists>x\<in>A. \<forall>y\<in>x. y\<notin>A)" and

  (*Schema axiom since predicate P is a higher-order variable*)
  replacement:   "(\<forall>x\<in>A. \<forall>y z. P(x,y) & P(x,z) \<longrightarrow> y=z) ==>
                         b \<in> PrimReplace(A,P) <-> (\<exists>x\<in>A. P(x,b))"

defs

  (* Derived form of replacement, restricting P to its functional part.
     The resulting set (for functional P) is the same as with
     PrimReplace, but the rules are simpler. *)

  Replace_def:  "Replace(A,P) == PrimReplace(A, %x y. (EX!z. P(x,z)) & P(x,y))"

  (* Functional form of replacement -- analgous to ML's map functional *)

  RepFun_def:   "RepFun(A,f) == {y . x\<in>A, y=f(x)}"

  (* Separation and Pairing can be derived from the Replacement
     and Powerset Axioms using the following definitions. *)

  Collect_def:  "Collect(A,P) == {y . x\<in>A, x=y & P(x)}"

  (*Unordered pairs (Upair) express binary union/intersection and cons;
    set enumerations translate as {a,...,z} = cons(a,...,cons(z,0)...)*)

  Upair_def: "Upair(a,b) == {y. x\<in>Pow(Pow(0)), (x=0 & y=a) | (x=Pow(0) & y=b)}"
  cons_def:  "cons(a,A) == Upair(a,a) \<union> A"
  succ_def:  "succ(i) == cons(i, i)"

  (* Difference, general intersection, binary union and small intersection *)

  Diff_def:      "A - B    == { x\<in>A . ~(x\<in>B) }"
  Inter_def:     "\<Inter>(A) == { x\<in>\<Union>(A) . \<forall>y\<in>A. x\<in>y}"
  Un_def:        "A \<union>  B  == \<Union>(Upair(A,B))"
  Int_def:      "A \<inter> B  == \<Inter>(Upair(A,B))"

  (* definite descriptions *)
  the_def:      "The(P)    == \<Union>({y . x \<in> {0}, P(y)})"
  if_def:       "if(P,a,b) == THE z. P & z=a | ~P & z=b"

  (* this "symmetric" definition works better than {{a}, {a,b}} *)
  Pair_def:     "<a,b>  == {{a,a}, {a,b}}"
  fst_def:      "fst(p) == THE a. \<exists>b. p=<a,b>"
  snd_def:      "snd(p) == THE b. \<exists>a. p=<a,b>"
  split_def:    "split(c) == %p. c(fst(p), snd(p))"
  Sigma_def:    "Sigma(A,B) == \<Union>x\<in>A. \<Union>y\<in>B(x). {<x,y>}"

  (* Operations on relations *)

  (*converse of relation r, inverse of function*)
  converse_def: "converse(r) == {z. w\<in>r, \<exists>x y. w=<x,y> & z=<y,x>}"

  domain_def:   "domain(r) == {x. w\<in>r, \<exists>y. w=<x,y>}"
  range_def:    "range(r) == domain(converse(r))"
  field_def:    "field(r) == domain(r) \<union> range(r)"
  relation_def: "relation(r) == \<forall>z\<in>r. \<exists>x y. z = <x,y>"
  function_def: "function(r) ==
                    \<forall>x y. <x,y>:r \<longrightarrow> (\<forall>y'. <x,y'>:r \<longrightarrow> y=y')"
  image_def:    "r `` A  == {y \<in> range(r) . \<exists>x\<in>A. <x,y> \<in> r}"
  vimage_def:   "r -`` A == converse(r)``A"

  (* Abstraction, application and Cartesian product of a family of sets *)

  lam_def:      "Lambda(A,b) == {<x,b(x)> . x\<in>A}"
  apply_def:    "f`a == \<Union>(f``{a})"
  Pi_def:       "Pi(A,B)  == {f\<in>Pow(Sigma(A,B)). A<=domain(f) & function(f)}"

  (* Restrict the relation r to the domain A *)
  restrict_def: "restrict(r,A) == {z \<in> r. \<exists>x\<in>A. \<exists>y. z = <x,y>}"

subsection {* Substitution*}

(*Useful examples:  singletonI RS subst_elem,  subst_elem RSN (2,IntI) *)
lemma subst_elem: "[| b\<in>A;  a=b |] ==> a\<in>A"
by (erule ssubst, assumption)

subsection{*Bounded universal quantifier*}

lemma ballI [intro!]: "[| !!x. x\<in>A ==> P(x) |] ==> \<forall>x\<in>A. P(x)"
by (simp add: Ball_def)

lemmas strip = impI allI ballI

lemma bspec [dest?]: "[| \<forall>x\<in>A. P(x);  x: A |] ==> P(x)"
by (simp add: Ball_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_ballE [elim]:
    "[| \<forall>x\<in>A. P(x);  x\<notin>A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: Ball_def, blast)

lemma ballE: "[| \<forall>x\<in>A. P(x);  P(x) ==> Q;  x\<notin>A ==> Q |] ==> Q"
by blast

(*Used in the datatype package*)
lemma rev_bspec: "[| x: A;  \<forall>x\<in>A. P(x) |] ==> P(x)"
by (simp add: Ball_def)

(*Trival rewrite rule;   @{term"(\<forall>x\<in>A.P)<->P"} holds only if A is nonempty!*)
lemma ball_triv [simp]: "(\<forall>x\<in>A. P) <-> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
by (simp add: Ball_def)

(*Congruence rule for rewriting*)
lemma ball_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P(x) <-> P'(x) |] ==> (\<forall>x\<in>A. P(x)) <-> (\<forall>x\<in>A'. P'(x))"
by (simp add: Ball_def)

lemma atomize_ball:
    "(!!x. x \<in> A ==> P(x)) == Trueprop (\<forall>x\<in>A. P(x))"
  by (simp only: Ball_def atomize_all atomize_imp)

lemmas [symmetric, rulify] = atomize_ball
  and [symmetric, defn] = atomize_ball

subsection{*Bounded existential quantifier*}

lemma bexI [intro]: "[| P(x);  x: A |] ==> \<exists>x\<in>A. P(x)"
by (simp add: Bex_def, blast)

(*The best argument order when there is only one @{term"x\<in>A"}*)
lemma rev_bexI: "[| x\<in>A;  P(x) |] ==> \<exists>x\<in>A. P(x)"
by blast

(*Not of the general form for such rules. The existential quanitifer becomes universal. *)
lemma bexCI: "[| \<forall>x\<in>A. ~P(x) ==> P(a);  a: A |] ==> \<exists>x\<in>A. P(x)"
by blast

lemma bexE [elim!]: "[| \<exists>x\<in>A. P(x);  !!x. [| x\<in>A; P(x) |] ==> Q |] ==> Q"
by (simp add: Bex_def, blast)

(*We do not even have @{term"(\<exists>x\<in>A. True) <-> True"} unless @{term"A" is nonempty!!*)
lemma bex_triv [simp]: "(\<exists>x\<in>A. P) <-> ((\<exists>x. x\<in>A) & P)"
by (simp add: Bex_def)

lemma bex_cong [cong]:
    "[| A=A';  !!x. x\<in>A' ==> P(x) <-> P'(x) |]
     ==> (\<exists>x\<in>A. P(x)) <-> (\<exists>x\<in>A'. P'(x))"
by (simp add: Bex_def cong: conj_cong)

subsection{*Rules for subsets*}

lemma subsetI [intro!]:
    "(!!x. x\<in>A ==> x\<in>B) ==> A \<subseteq> B"
by (simp add: subset_def)

(*Rule in Modus Ponens style [was called subsetE] *)
lemma subsetD [elim]: "[| A \<subseteq> B;  c\<in>A |] ==> c\<in>B"
apply (unfold subset_def)
apply (erule bspec, assumption)
done

(*Classical elimination rule*)
lemma subsetCE [elim]:
    "[| A \<subseteq> B;  c\<notin>A ==> P;  c\<in>B ==> P |] ==> P"
by (simp add: subset_def, blast)

(*Sometimes useful with premises in this order*)
lemma rev_subsetD: "[| c\<in>A; A<=B |] ==> c\<in>B"
by blast

lemma contra_subsetD: "[| A \<subseteq> B; c \<notin> B |] ==> c \<notin> A"
by blast

lemma rev_contra_subsetD: "[| c \<notin> B;  A \<subseteq> B |] ==> c \<notin> A"
by blast

lemma subset_refl [simp]: "A \<subseteq> A"
by blast

lemma subset_trans: "[| A<=B;  B<=C |] ==> A<=C"
by blast

(*Useful for proving A<=B by rewriting in some cases*)
lemma subset_iff:
     "A<=B <-> (\<forall>x. x\<in>A \<longrightarrow> x\<in>B)"
apply (unfold subset_def Ball_def)
apply (rule iff_refl)
done

text{*For calculations*}
declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]

subsection{*Rules for equality*}

(*Anti-symmetry of the subset relation*)
lemma equalityI [intro]: "[| A \<subseteq> B;  B \<subseteq> A |] ==> A = B"
by (rule extension [THEN iffD2], rule conjI)

lemma equality_iffI: "(!!x. x\<in>A <-> x\<in>B) ==> A = B"
by (rule equalityI, blast+)

lemmas equalityD1 = extension [THEN iffD1, THEN conjunct1]
lemmas equalityD2 = extension [THEN iffD1, THEN conjunct2]

lemma equalityE: "[| A = B;  [| A<=B; B<=A |] ==> P |]  ==>  P"
by (blast dest: equalityD1 equalityD2)

lemma equalityCE:
    "[| A = B;  [| c\<in>A; c\<in>B |] ==> P;  [| c\<notin>A; c\<notin>B |] ==> P |]  ==>  P"
by (erule equalityE, blast)

lemma equality_iffD:
  "A = B ==> (!!x. x \<in> A <-> x \<in> B)"
  by auto

subsection{*Rules for Replace -- the derived form of replacement*}

lemma Replace_iff:
    "b \<in> {y. x\<in>A, P(x,y)}  <->  (\<exists>x\<in>A. P(x,b) & (\<forall>y. P(x,y) \<longrightarrow> y=b))"
apply (unfold Replace_def)
apply (rule replacement [THEN iff_trans], blast+)
done

(*Introduction; there must be a unique y such that P(x,y), namely y=b. *)
lemma ReplaceI [intro]:
    "[| P(x,b);  x: A;  !!y. P(x,y) ==> y=b |] ==>
     b \<in> {y. x\<in>A, P(x,y)}"
by (rule Replace_iff [THEN iffD2], blast)

(*Elimination; may asssume there is a unique y such that P(x,y), namely y=b. *)
lemma ReplaceE:
    "[| b \<in> {y. x\<in>A, P(x,y)};
        !!x. [| x: A;  P(x,b);  \<forall>y. P(x,y)\<longrightarrow>y=b |] ==> R
     |] ==> R"
by (rule Replace_iff [THEN iffD1, THEN bexE], simp+)

(*As above but without the (generally useless) 3rd assumption*)
lemma ReplaceE2 [elim!]:
    "[| b \<in> {y. x\<in>A, P(x,y)};
        !!x. [| x: A;  P(x,b) |] ==> R
     |] ==> R"
by (erule ReplaceE, blast)

lemma Replace_cong [cong]:
    "[| A=B;  !!x y. x\<in>B ==> P(x,y) <-> Q(x,y) |] ==>
     Replace(A,P) = Replace(B,Q)"
apply (rule equality_iffI)
apply (simp add: Replace_iff)
done

subsection{*Rules for RepFun*}

lemma RepFunI: "a \<in> A ==> f(a) \<in> {f(x). x\<in>A}"
by (simp add: RepFun_def Replace_iff, blast)

(*Useful for coinduction proofs*)
lemma RepFun_eqI [intro]: "[| b=f(a);  a \<in> A |] ==> b \<in> {f(x). x\<in>A}"
apply (erule ssubst)
apply (erule RepFunI)
done

lemma RepFunE [elim!]:
    "[| b \<in> {f(x). x\<in>A};
        !!x.[| x\<in>A;  b=f(x) |] ==> P |] ==>
     P"
by (simp add: RepFun_def Replace_iff, blast)

lemma RepFun_cong [cong]:
    "[| A=B;  !!x. x\<in>B ==> f(x)=g(x) |] ==> RepFun(A,f) = RepFun(B,g)"
by (simp add: RepFun_def)

lemma RepFun_iff [simp]: "b \<in> {f(x). x\<in>A} <-> (\<exists>x\<in>A. b=f(x))"
by (unfold Bex_def, blast)

lemma triv_RepFun [simp]: "{x. x\<in>A} = A"
by blast

subsection{*Rules for Collect -- forming a subset by separation*}

(*Separation is derivable from Replacement*)
lemma separation [simp]: "a \<in> {x\<in>A. P(x)} <-> a\<in>A & P(a)"
by (unfold Collect_def, blast)

lemma CollectI [intro!]: "[| a\<in>A;  P(a) |] ==> a \<in> {x\<in>A. P(x)}"
by simp

lemma CollectE [elim!]: "[| a \<in> {x\<in>A. P(x)};  [| a\<in>A; P(a) |] ==> R |] ==> R"
by simp

lemma CollectD1: "a \<in> {x\<in>A. P(x)} ==> a\<in>A"
by (erule CollectE, assumption)

lemma CollectD2: "a \<in> {x\<in>A. P(x)} ==> P(a)"
by (erule CollectE, assumption)

lemma Collect_cong [cong]:
    "[| A=B;  !!x. x\<in>B ==> P(x) <-> Q(x) |]
     ==> Collect(A, %x. P(x)) = Collect(B, %x. Q(x))"
by (simp add: Collect_def)

subsection{*Rules for Unions*}

declare Union_iff [simp]

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI [intro]: "[| B: C;  A: B |] ==> A: \<Union>(C)"
by (simp, blast)

lemma UnionE [elim!]: "[| A \<in> \<Union>(C);  !!B.[| A: B;  B: C |] ==> R |] ==> R"
by (simp, blast)

subsection{*Rules for Unions of families*}
(* @{term"\<Union>x\<in>A. B(x)"} abbreviates @{term"\<Union>({B(x). x\<in>A})"} *)

lemma UN_iff [simp]: "b \<in> (\<Union>x\<in>A. B(x)) <-> (\<exists>x\<in>A. b \<in> B(x))"
by (simp add: Bex_def, blast)

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "[| a: A;  b: B(a) |] ==> b: (\<Union>x\<in>A. B(x))"
by (simp, blast)

lemma UN_E [elim!]:
    "[| b \<in> (\<Union>x\<in>A. B(x));  !!x.[| x: A;  b: B(x) |] ==> R |] ==> R"
by blast

lemma UN_cong:
    "[| A=B;  !!x. x\<in>B ==> C(x)=D(x) |] ==> (\<Union>x\<in>A. C(x)) = (\<Union>x\<in>B. D(x))"
by simp

(*No "Addcongs [UN_cong]" because @{term\<Union>} is a combination of constants*)

(* UN_E appears before UnionE so that it is tried first, to avoid expensive
  calls to hyp_subst_tac.  Cannot include UN_I as it is unsafe: would enlarge
  the search space.*)

subsection{*Rules for the empty set*}

(*The set @{term"{x\<in>0. False}"} is empty; by foundation it equals 0
  See Suppes, page 21.*)
lemma not_mem_empty [simp]: "a \<notin> 0"
apply (cut_tac foundation)
apply (best dest: equalityD2)
done

lemmas emptyE [elim!] = not_mem_empty [THEN notE]

lemma empty_subsetI [simp]: "0 \<subseteq> A"
by blast

lemma equals0I: "[| !!y. y\<in>A ==> False |] ==> A=0"
by blast

lemma equals0D [dest]: "A=0 ==> a \<notin> A"
by blast

declare sym [THEN equals0D, dest]

lemma not_emptyI: "a\<in>A ==> A \<noteq> 0"
by blast

lemma not_emptyE:  "[| A \<noteq> 0;  !!x. x\<in>A ==> R |] ==> R"
by blast

subsection{*Rules for Inter*}

(*Not obviously useful for proving InterI, InterD, InterE*)
lemma Inter_iff: "A \<in> \<Inter>(C) <-> (\<forall>x\<in>C. A: x) & C\<noteq>0"
by (simp add: Inter_def Ball_def, blast)

(* Intersection is well-behaved only if the family is non-empty! *)
lemma InterI [intro!]:
    "[| !!x. x: C ==> A: x;  C\<noteq>0 |] ==> A \<in> \<Inter>(C)"
by (simp add: Inter_iff)

(*A "destruct" rule -- every B in C contains A as an element, but
  A\<in>B can hold when B\<in>C does not!  This rule is analogous to "spec". *)
lemma InterD [elim, Pure.elim]: "[| A \<in> \<Inter>(C);  B \<in> C |] ==> A \<in> B"
by (unfold Inter_def, blast)

(*"Classical" elimination rule -- does not require exhibiting @{term"B\<in>C"} *)
lemma InterE [elim]:
    "[| A \<in> \<Inter>(C);  B\<notin>C ==> R;  A\<in>B ==> R |] ==> R"
by (simp add: Inter_def, blast)

subsection{*Rules for Intersections of families*}

(* @{term"\<Inter>x\<in>A. B(x)"} abbreviates @{term"\<Inter>({B(x). x\<in>A})"} *)

lemma INT_iff: "b \<in> (\<Inter>x\<in>A. B(x)) <-> (\<forall>x\<in>A. b \<in> B(x)) & A\<noteq>0"
by (force simp add: Inter_def)

lemma INT_I: "[| !!x. x: A ==> b: B(x);  A\<noteq>0 |] ==> b: (\<Inter>x\<in>A. B(x))"
by blast

lemma INT_E: "[| b \<in> (\<Inter>x\<in>A. B(x));  a: A |] ==> b \<in> B(a)"
by blast

lemma INT_cong:
    "[| A=B;  !!x. x\<in>B ==> C(x)=D(x) |] ==> (\<Inter>x\<in>A. C(x)) = (\<Inter>x\<in>B. D(x))"
by simp

(*No "Addcongs [INT_cong]" because @{term\<Inter>} is a combination of constants*)

subsection{*Rules for Powersets*}

lemma PowI: "A \<subseteq> B ==> A \<in> Pow(B)"
by (erule Pow_iff [THEN iffD2])

lemma PowD: "A \<in> Pow(B)  ==>  A<=B"
by (erule Pow_iff [THEN iffD1])

declare Pow_iff [iff]

lemmas Pow_bottom = empty_subsetI [THEN PowI]    --{* @{term"0 \<in> Pow(B)"} *}
lemmas Pow_top = subset_refl [THEN PowI]         --{* @{term"A \<in> Pow(A)"} *}

subsection{*Cantor's Theorem: There is no surjection from a set to its powerset.*}

(*The search is undirected.  Allowing redundant introduction rules may
  make it diverge.  Variable b represents ANY map, such as
  (lam x\<in>A.b(x)): A->Pow(A). *)
lemma cantor: "\<exists>S \<in> Pow(A). \<forall>x\<in>A. b(x) \<noteq> S"
by (best elim!: equalityCE del: ReplaceI RepFun_eqI)

end


(*  Title:      FOL/IFOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section \<open>Intuitionistic first-order logic\<close>

theory my_IFOL
imports Pure
begin

ML \<open>\<^assert> (not (can ML \<open>open RunCall\<close>))\<close>
ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>
ML_file \<open>~~/src/Provers/splitter.ML\<close>
ML_file \<open>~~/src/Provers/hypsubst.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/zipper.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/isand.ML\<close>
ML_file \<open>~~/src/Tools/IsaPlanner/rw_inst.ML\<close>
ML_file \<open>~~/src/Provers/quantifier1.ML\<close>
ML_file \<open>~~/src/Tools/intuitionistic.ML\<close>
ML_file \<open>~~/src/Tools/project_rule.ML\<close>
ML_file \<open>~~/src/Tools/atomize_elim.ML\<close>

subsection \<open>Syntax and axiomatic basis\<close>

setup Pure_Thy.old_appl_syntax_setup

class "term"
default_sort \<open>term\<close>

typedecl o

judgment
  Trueprop :: \<open>o \<Rightarrow> prop\<close>  (\<open>(_)\<close> 5)

subsubsection \<open>Equality\<close>

axiomatization
  eq :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>=\<close> 50)
where
  refl: \<open>a = a\<close> and
  subst: \<open>a = b \<Longrightarrow> P(a) \<Longrightarrow> P(b)\<close>

subsubsection \<open>Propositional logic\<close>

axiomatization
  False :: \<open>o\<close> and
  conj :: \<open>[o, o] => o\<close>  (infixr \<open>\<and>\<close> 35) and
  disj :: \<open>[o, o] => o\<close>  (infixr \<open>\<or>\<close> 30) and
  imp :: \<open>[o, o] => o\<close>  (infixr \<open>\<longrightarrow>\<close> 25)
where
  conjI: \<open>\<lbrakk>P;  Q\<rbrakk> \<Longrightarrow> P \<and> Q\<close> and
  conjunct1: \<open>P \<and> Q \<Longrightarrow> P\<close> and
  conjunct2: \<open>P \<and> Q \<Longrightarrow> Q\<close> and

  disjI1: \<open>P \<Longrightarrow> P \<or> Q\<close> and
  disjI2: \<open>Q \<Longrightarrow> P \<or> Q\<close> and
  disjE: \<open>\<lbrakk>P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close> and

  impI: \<open>(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q\<close> and
  mp: \<open>\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close> and

  FalseE: \<open>False \<Longrightarrow> P\<close>

subsubsection \<open>Quantifiers\<close>

axiomatization
  All :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<forall>\<close> 10) and
  Ex :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>\<close> 10)
where
  allI: \<open>(\<And>x. P(x)) \<Longrightarrow> (\<forall>x. P(x))\<close> and
  spec: \<open>(\<forall>x. P(x)) \<Longrightarrow> P(x)\<close> and
  exI: \<open>P(x) \<Longrightarrow> (\<exists>x. P(x))\<close> and
  exE: \<open>\<lbrakk>\<exists>x. P(x); \<And>x. P(x) \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R\<close>

subsubsection \<open>Definitions\<close>

definition \<open>True \<equiv> False \<longrightarrow> False\<close>

definition Not (\<open>\<not> _\<close> [40] 40)
  where not_def: \<open>\<not> P \<equiv> P \<longrightarrow> False\<close>

definition iff  (infixr \<open>\<longleftrightarrow>\<close> 25)
  where \<open>P \<longleftrightarrow> Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)\<close>

definition Only1 :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>!\<close> 10)
  where only1_def: \<open>!x. P(x) \<equiv> (\<forall>x.\<forall>y. P(x) \<and> P(y) \<longrightarrow> x = y)\<close>

definition Ex1 :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>!\<close> 10)
  where ex1new_def: \<open>\<exists>!x. P(x) \<equiv> (\<exists>x. P(x)) \<and> (!x. P(x))\<close>

axiomatization where  \<comment> \<open>Reflection, admissible\<close>
  eq_reflection: \<open>(x = y) \<Longrightarrow> (x \<equiv> y)\<close> and
  iff_reflection: \<open>(P \<longleftrightarrow> Q) \<Longrightarrow> (P \<equiv> Q)\<close>

abbreviation not_equal :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>\<noteq>\<close> 50)
  where \<open>x \<noteq> y \<equiv> \<not> (x = y)\<close>

subsubsection \<open>Old-style ASCII syntax\<close>

notation (ASCII)
  not_equal  (infixl \<open>~=\<close> 50) and
  Not  (\<open>~ _\<close> [40] 40) and
  conj  (infixr \<open>&\<close> 35) and
  disj  (infixr \<open>|\<close> 30) and
  All  (binder \<open>ALL \<close> 10) and
  Ex  (binder \<open>EX \<close> 10) and
  Ex1  (binder \<open>EX! \<close> 10) and
  imp  (infixr \<open>-->\<close> 25) and
  iff  (infixr \<open><->\<close> 25)

subsection \<open>Lemmas and proof tools\<close>

lemmas strip = impI allI

lemma TrueI: \<open>True\<close>
  unfolding True_def by (rule impI)

subsubsection \<open>Sequent-style elimination rules for \<open>\<and>\<close> \<open>\<longrightarrow>\<close> and \<open>\<forall>\<close>\<close>

lemma conjE:
  assumes major: \<open>P \<and> Q\<close>
    and r: \<open>\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
   apply (rule major [THEN conjunct1])
  apply (rule major [THEN conjunct2])
  done

lemma impE:
  assumes major: \<open>P \<longrightarrow> Q\<close>
    and \<open>P\<close>
  and r: \<open>Q \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
  apply (rule major [THEN mp])
  apply (rule \<open>P\<close>)
  done

lemma allE:
  assumes major: \<open>\<forall>x. P(x)\<close>
    and r: \<open>P(x) \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
  apply (rule major [THEN spec])
  done

text \<open>Duplicates the quantifier; for use with \<^ML>\<open>eresolve_tac\<close>.\<close>
lemma all_dupE:
  assumes major: \<open>\<forall>x. P(x)\<close>
    and r: \<open>\<lbrakk>P(x); \<forall>x. P(x)\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule r)
   apply (rule major [THEN spec])
  apply (rule major)
  done

subsubsection \<open>Negation rules, which translate between \<open>\<not> P\<close> and \<open>P \<longrightarrow> False\<close>\<close>

lemma notI: \<open>(P \<Longrightarrow> False) \<Longrightarrow> \<not> P\<close>
  unfolding not_def by (erule impI)

lemma notE: \<open>\<lbrakk>\<not> P; P\<rbrakk> \<Longrightarrow> R\<close>
  unfolding not_def by (erule mp [THEN FalseE])

lemma rev_notE: \<open>\<lbrakk>P; \<not> P\<rbrakk> \<Longrightarrow> R\<close>
  by (erule notE)

text \<open>This is useful with the special implication rules for each kind of \<open>P\<close>.\<close>
lemma not_to_imp:
  assumes \<open>\<not> P\<close>
    and r: \<open>P \<longrightarrow> False \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
  apply (rule r)
  apply (rule impI)
  apply (erule notE [OF \<open>\<not> P\<close>])
  done

text \<open>
  For substitution into an assumption \<open>P\<close>, reduce \<open>Q\<close> to \<open>P \<longrightarrow> Q\<close>, substitute into this implication, then apply \<open>impI\<close> to
  move \<open>P\<close> back into the assumptions.
\<close>
lemma rev_mp: \<open>\<lbrakk>P; P \<longrightarrow> Q\<rbrakk> \<Longrightarrow> Q\<close>
  by (erule mp)

text \<open>Contrapositive of an inference rule.\<close>
lemma contrapos:
  assumes major: \<open>\<not> Q\<close>
    and minor: \<open>P \<Longrightarrow> Q\<close>
  shows \<open>\<not> P\<close>
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

subsubsection \<open>Modus Ponens Tactics\<close>

text \<open>
  Finds \<open>P \<longrightarrow> Q\<close> and P in the assumptions, replaces implication by
  \<open>Q\<close>.
\<close>
ML \<open>
  fun mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN assume_tac ctxt i;
  fun eq_mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN eq_assume_tac i;
\<close>

subsection \<open>If-and-only-if\<close>

lemma iffI: \<open>\<lbrakk>P \<Longrightarrow> Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  apply (unfold iff_def)
  apply (rule conjI)
   apply (erule impI)
  apply (erule impI)
  done

lemma iffE:
  assumes major: \<open>P \<longleftrightarrow> Q\<close>
    and r: \<open>P \<longrightarrow> Q \<Longrightarrow> Q \<longrightarrow> P \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (insert major)
apply (unfold iff_def)
  apply (erule conjE)
  apply (erule r)
  apply assumption
  done

subsubsection \<open>Destruct rules for \<open>\<longleftrightarrow>\<close> similar to Modus Ponens\<close>

lemma iffD1: \<open>\<lbrakk>P \<longleftrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q\<close>
  apply (unfold iff_def)
  apply (erule conjunct1 [THEN mp])
  apply assumption
  done

lemma iffD2: \<open>\<lbrakk>P \<longleftrightarrow> Q; Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (unfold iff_def)
  apply (erule conjunct2 [THEN mp])
  apply assumption
  done

lemma rev_iffD1: \<open>\<lbrakk>P; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> Q\<close>
  apply (erule iffD1)
  apply assumption
  done

lemma rev_iffD2: \<open>\<lbrakk>Q; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> P\<close>
  apply (erule iffD2)
  apply assumption
  done

lemma iff_refl: \<open>P \<longleftrightarrow> P\<close>
  by (rule iffI)

lemma iff_sym: \<open>Q \<longleftrightarrow> P \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  apply (erule iffE)
  apply (rule iffI)
  apply (assumption | erule mp)+
  done

lemma iff_trans: \<open>\<lbrakk>P \<longleftrightarrow> Q; Q \<longleftrightarrow> R\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> R\<close>
  apply (rule iffI)
  apply (assumption | erule iffE | erule (1) notE impE)+
  done

subsection \<open>Equality rules\<close>

lemma sym: \<open>a = b \<Longrightarrow> b = a\<close>
  apply (erule subst)
  apply (rule refl)
  done

lemma trans: \<open>\<lbrakk>a = b; b = c\<rbrakk> \<Longrightarrow> a = c\<close>
  apply (erule subst, assumption)
  done

lemma not_sym: \<open>b \<noteq> a \<Longrightarrow> a \<noteq> b\<close>
  apply (erule contrapos)
  apply (erule sym)
  done

text \<open>
  Two theorems for rewriting only one instance of a definition:
  the first for definitions of formulae and the second for terms.
\<close>

lemma def_imp_iff: \<open>(A \<equiv> B) \<Longrightarrow> A \<longleftrightarrow> B\<close>
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: \<open>(A \<equiv> B) \<Longrightarrow> A = B\<close>
  apply unfold
  apply (rule refl)
  done

lemma meta_eq_to_iff: \<open>x \<equiv> y \<Longrightarrow> x \<longleftrightarrow> y\<close>
  by unfold (rule iff_refl)

subsection \<open>Only\<close>

text \<open>Quantifier "!x. P(x)" means "at most one object has property P"\<close>

lemma only1I:
  assumes H: \<open>(\<And>x y. (\<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y))\<close>
  shows \<open>!x. P(x)\<close>
  by (unfold only1_def, rule allI, rule allI, rule impI, rule H,
        erule conjunct1, erule conjunct2)

lemma only1D: \<open>!x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y)\<close>
  apply(unfold only1_def)
  apply(rule mp, rule spec, erule spec)
  apply(erule conjI, assumption)
  done

lemma only1E:
  assumes major: \<open>!x. P(x)\<close>
      and r: \<open>(\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> R\<close>
    shows \<open>R\<close>
  by (rule r, rule only1D[OF major], assumption+)

lemma only1lem:
  assumes H:\<open>(\<And>x. P(x) \<Longrightarrow> x = a)\<close>
  shows \<open>(\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y)\<close>
proof -
  fix x y
  assume W1:\<open>P(x)\<close>
  assume W2:\<open>P(y)\<close>
  have E1:\<open>x = a\<close> by (rule H[OF W1])
  have E2:\<open>y = a\<close> by (rule H[OF W2])
  show \<open>x = y\<close> by (rule trans[OF E1 sym[OF E2]])
qed

lemma only1I2:
  assumes H:\<open>(\<And>x. P(x) \<Longrightarrow> x = a)\<close>
  shows \<open>!x. P(x)\<close>
  apply (rule only1I)
  apply (rule only1lem)
  apply (rule H, assumption+)
  done

lemma only1rearr :
  assumes 1: \<open>!x. P(x)\<close>
  assumes M: \<open>P(x)\<close>
  shows \<open>\<forall>y. P(y) \<longrightarrow> y = x\<close>
proof (rule allI, rule impI, rule only1E[OF 1])
  fix y
  assume N: \<open>P(y)\<close>
  assume K: \<open>(\<And>x y. P(x) \<Longrightarrow> P(y) \<Longrightarrow> x = y)\<close>
  show \<open>y = x\<close> by (rule K[OF N M])
qed

subsection \<open>Unique existence\<close>

text \<open>
  NOTE THAT the following 2 quantifications:

    \<^item> \<open>\<exists>!x\<close> such that [\<open>\<exists>!y\<close> such that P(x,y)]   (sequential)
    \<^item> \<open>\<exists>!x,y\<close> such that P(x,y)                   (simultaneous)

  do NOT mean the same thing. The parser treats \<open>\<exists>!x y.P(x,y)\<close> as sequential.
\<close>

lemma ex1newI: \<open>\<lbrakk>\<exists>x. P(x); !x. P(x)\<rbrakk> \<Longrightarrow> \<exists>! x. P(x)\<close>
  by (unfold ex1new_def, rule conjI, assumption+)

lemma ex1newE: \<open>\<exists>!x. P(x) \<Longrightarrow> (\<lbrakk>\<exists>x. P(x); !x. P(x)\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (unfold ex1new_def)
  apply (assumption | erule exE conjE)+
  done

lemma ex1newD1: \<open>\<exists>!x. P(x) \<Longrightarrow> \<exists>x. P(x)\<close>
  by (erule ex1newE)

lemma ex1newD2: \<open>\<exists>!x. P(x) \<Longrightarrow> !x. P(x)\<close>
  by (erule ex1newE)

lemma ex1badI:
  assumes 1: \<open>P(a)\<close>
    and 2: \<open>(\<And>x. P(x) \<Longrightarrow> x = a)\<close>
  shows \<open>\<exists>!x. P(x)\<close>
proof(rule ex1newI)
  show \<open>\<exists>x. P(x)\<close> by (rule exI, rule 1)
next
  show \<open>!x. P(x)\<close> by (rule only1I2, rule 2, assumption)
qed

lemma ex1unfold: \<open>\<exists>!x. P(x) \<Longrightarrow> \<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x)\<close>
proof (erule ex1newE)
  assume 1: \<open>\<exists>x. P(x)\<close>
  assume 2: \<open>!x. P(x)\<close>
  show \<open>\<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x)\<close>
    by(rule exE[OF 1], rule exI, rule conjI, assumption, erule only1rearr[OF 2])
qed

lemma ex1fold: \<open>\<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x) \<Longrightarrow> \<exists>!x. P(x)\<close>
  by (erule exE, erule conjE, erule ex1badI, rule mp, erule spec, assumption)

lemma ex1_def : \<open>\<exists>!x. P(x) \<equiv> (\<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x))\<close>
  by (rule iff_reflection, rule iffI, erule ex1unfold, erule ex1fold)

lemma ex1I: \<open>P(a) \<Longrightarrow> (\<And>x. P(x) \<Longrightarrow> x = a) \<Longrightarrow> \<exists>!x. P(x)\<close>
  apply (unfold ex1_def)
  apply (assumption | rule exI conjI allI impI)+
  done

text \<open>Sometimes easier to use: the premises have no shared variables. Safe!\<close>

lemma ex_ex1I: \<open>\<exists>x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> \<exists>!x. P(x)\<close>
  by (erule ex1newI, erule only1I)

lemma ex1E':
  assumes 0: \<open>(\<And>x. \<lbrakk>P(x); \<forall>y. P(y) \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R)\<close>
  shows \<open>(\<exists>! x. P(x)) \<Longrightarrow> R\<close>
  apply (erule ex1newE)
  apply (erule exE)
  apply (rule 0, assumption, erule only1rearr, assumption)
  done

lemma ex_ex1I': \<open>\<exists>x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> \<exists>!x. P(x)\<close>
  apply (erule exE)
  apply (rule ex1I)
   apply assumption
  apply assumption
  done

lemma ex1E: \<open>\<exists>! x. P(x) \<Longrightarrow> (\<And>x. \<lbrakk>P(x); \<forall>y. P(y) \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (unfold ex1_def)
  apply (assumption | erule exE conjE)+
  done

subsubsection \<open>\<open>\<longleftrightarrow>\<close> congruence rules for simplification\<close>

text \<open>Use \<open>iffE\<close> on a premise. For \<open>conj_cong\<close>, \<open>imp_cong\<close>, \<open>all_cong\<close>, \<open>ex_cong\<close>.\<close>
ML \<open>
  fun iff_tac ctxt prems i =
    resolve_tac ctxt (prems RL @{thms iffE}) i THEN
    REPEAT1 (eresolve_tac ctxt @{thms asm_rl mp} i);
\<close>

method_setup iff =
  \<open>Attrib.thms >>
    (fn prems => fn ctxt => SIMPLE_METHOD' (iff_tac ctxt prems))\<close>

lemma conj_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<and> Q) \<longleftrightarrow> (P' \<and> Q')\<close>
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

text \<open>Reversed congruence rule!  Used in ZF/Order.\<close>
lemma conj_cong2:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(Q \<and> P) \<longleftrightarrow> (Q' \<and> P')\<close>
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

lemma disj_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close> and \<open>Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<or> Q) \<longleftrightarrow> (P' \<or> Q')\<close>
  apply (insert assms)
  apply (erule iffE disjE disjI1 disjI2 |
    assumption | rule iffI | erule (1) notE impE)+
  done

lemma imp_cong:
  assumes \<open>P \<longleftrightarrow> P'\<close>
    and \<open>P' \<Longrightarrow> Q \<longleftrightarrow> Q'\<close>
  shows \<open>(P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q')\<close>
  apply (insert assms)
  apply (assumption | rule iffI impI | erule iffE | erule (1) notE impE | iff assms)+
  done

lemma iff_cong: \<open>\<lbrakk>P \<longleftrightarrow> P'; Q \<longleftrightarrow> Q'\<rbrakk> \<Longrightarrow> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P' \<longleftrightarrow> Q')\<close>
  apply (erule iffE | assumption | rule iffI | erule (1) notE impE)+
  done

lemma not_cong: \<open>P \<longleftrightarrow> P' \<Longrightarrow> \<not> P \<longleftrightarrow> \<not> P'\<close>
  apply (assumption | rule iffI notI | erule (1) notE impE | erule iffE notE)+
  done

lemma all_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))\<close>
  apply (assumption | rule iffI allI | erule (1) notE impE | erule allE | iff assms)+
  done

lemma ex_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))\<close>
  apply (erule exE | assumption | rule iffI exI | erule (1) notE impE | iff assms)+
  done

lemma ex1_cong:
  assumes \<open>\<And>x. P(x) \<longleftrightarrow> Q(x)\<close>
  shows \<open>(\<exists>!x. P(x)) \<longleftrightarrow> (\<exists>!x. Q(x))\<close>
  apply (erule ex1E spec [THEN mp] | assumption | rule iffI ex1I | erule (1) notE impE | iff assms)+
  done

text \<open>Substitution.\<close>
lemma ssubst: \<open>\<lbrakk>b = a; P(a)\<rbrakk> \<Longrightarrow> P(b)\<close>
  apply (drule sym)
  apply (erule (1) subst)
  done

text \<open>A special case of \<open>ex1E\<close> that would otherwise need quantifier
  expansion.\<close>
lemma ex1_equalsE: \<open>\<lbrakk>\<exists>!x. P(x); P(a); P(b)\<rbrakk> \<Longrightarrow> a = b\<close>
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

subsubsection \<open>Polymorphic congruence rules\<close>

lemma subst_context: \<open>a = b \<Longrightarrow> t(a) = t(b)\<close>
  apply (erule ssubst)
  apply (rule refl)
  done

lemma subst_context2: \<open>\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> t(a,c) = t(b,d)\<close>
  apply (erule ssubst)+
  apply (rule refl)
  done

lemma subst_context3: \<open>\<lbrakk>a = b; c = d; e = f\<rbrakk> \<Longrightarrow> t(a,c,e) = t(b,d,f)\<close>
  apply (erule ssubst)+
  apply (rule refl)
  done

text \<open>
  Useful with \<^ML>\<open>eresolve_tac\<close> for proving equalities from known
  equalities.

        a = b
        |   |
        c = d
\<close>
lemma box_equals: \<open>\<lbrakk>a = b; a = c; b = d\<rbrakk> \<Longrightarrow> c = d\<close>
  apply (rule trans)
   apply (rule trans)
    apply (rule sym)
    apply assumption+
  done

text \<open>Dual of \<open>box_equals\<close>: for proving equalities backwards.\<close>
lemma simp_equals: \<open>\<lbrakk>a = c; b = d; c = d\<rbrakk> \<Longrightarrow> a = b\<close>
  apply (rule trans)
   apply (rule trans)
    apply assumption+
  apply (erule sym)
  done

subsubsection \<open>Congruence rules for predicate letters\<close>

lemma pred1_cong: \<open>a = a' \<Longrightarrow> P(a) \<longleftrightarrow> P(a')\<close>
  apply (rule iffI)
   apply (erule (1) subst)
  apply (erule (1) ssubst)
  done

lemma pred2_cong: \<open>\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> P(a,b) \<longleftrightarrow> P(a',b')\<close>
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

lemma pred3_cong: \<open>\<lbrakk>a = a'; b = b'; c = c'\<rbrakk> \<Longrightarrow> P(a,b,c) \<longleftrightarrow> P(a',b',c')\<close>
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

text \<open>Special case for the equality predicate!\<close>
lemma eq_cong: \<open>\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> a = b \<longleftrightarrow> a' = b'\<close>
  apply (erule (1) pred2_cong)
  done

subsection \<open>Simplifications of assumed implications\<close>

text \<open>
  Roy Dyckhoff has proved that \<open>conj_impE\<close>, \<open>disj_impE\<close>, and
  \<open>imp_impE\<close> used with \<^ML>\<open>mp_tac\<close> (restricted to atomic formulae) is
  COMPLETE for intuitionistic propositional logic.

  See R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
  (preprint, University of St Andrews, 1991).
\<close>

lemma conj_impE:
  assumes major: \<open>(P \<and> Q) \<longrightarrow> S\<close>
    and r: \<open>P \<longrightarrow> (Q \<longrightarrow> S) \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule conjI impI major [THEN mp] r)+

lemma disj_impE:
  assumes major: \<open>(P \<or> Q) \<longrightarrow> S\<close>
    and r: \<open>\<lbrakk>P \<longrightarrow> S; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule disjI1 disjI2 impI major [THEN mp] r)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.\<close>
lemma imp_impE:
  assumes major: \<open>(P \<longrightarrow> Q) \<longrightarrow> S\<close>
    and r1: \<open>\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q\<close>
    and r2: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  by (assumption | rule impI major [THEN mp] r1 r2)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.\<close>
lemma not_impE: \<open>\<not> P \<longrightarrow> S \<Longrightarrow> (P \<Longrightarrow> False) \<Longrightarrow> (S \<Longrightarrow> R) \<Longrightarrow> R\<close>
  apply (drule mp)
   apply (rule notI)
   apply assumption
  apply assumption
  done

text \<open>Simplifies the implication. UNSAFE.\<close>
lemma iff_impE:
  assumes major: \<open>(P \<longleftrightarrow> Q) \<longrightarrow> S\<close>
    and r1: \<open>\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q\<close>
    and r2: \<open>\<lbrakk>Q; P \<longrightarrow> S\<rbrakk> \<Longrightarrow> P\<close>
    and r3: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+
  done

text \<open>What if \<open>(\<forall>x. \<not> \<not> P(x)) \<longrightarrow> \<not> \<not> (\<forall>x. P(x))\<close> is an assumption?
  UNSAFE.\<close>
lemma all_impE:
  assumes major: \<open>(\<forall>x. P(x)) \<longrightarrow> S\<close>
    and r1: \<open>\<And>x. P(x)\<close>
    and r2: \<open>S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (rule allI impI major [THEN mp] r1 r2)+
  done

text \<open>
  Unsafe: \<open>\<exists>x. P(x)) \<longrightarrow> S\<close> is equivalent
  to \<open>\<forall>x. P(x) \<longrightarrow> S\<close>.\<close>
lemma ex_impE:
  assumes major: \<open>(\<exists>x. P(x)) \<longrightarrow> S\<close>
    and r: \<open>P(x) \<longrightarrow> S \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  apply (assumption | rule exI impI major [THEN mp] r)+
  done

text \<open>Courtesy of Krzysztof Grabczewski.\<close>
lemma disj_imp_disj: \<open>P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> S) \<Longrightarrow> R \<or> S\<close>
  apply (erule disjE)
  apply (rule disjI1) apply assumption
  apply (rule disjI2) apply assumption
  done

ML \<open>
structure Project_Rule = Project_Rule
(
  val conjunct1 = @{thm conjunct1}
  val conjunct2 = @{thm conjunct2}
  val mp = @{thm mp}
)
\<close>

ML_file \<open>fologic.ML\<close>

lemma thin_refl: \<open>\<lbrakk>x = x; PROP W\<rbrakk> \<Longrightarrow> PROP W\<close> .

ML \<open>
structure Hypsubst = Hypsubst
(
  val dest_eq = FOLogic.dest_eq
  val dest_Trueprop = FOLogic.dest_Trueprop
  val dest_imp = FOLogic.dest_imp
  val eq_reflection = @{thm eq_reflection}
  val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
  val imp_intr = @{thm impI}
  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
\<close>

ML_file \<open>intprover.ML\<close>

subsection \<open>Intuitionistic Reasoning\<close>

setup \<open>Intuitionistic.method_setup \<^binding>\<open>iprover\<close>\<close>

lemma impE':
  assumes 1: \<open>P \<longrightarrow> Q\<close>
    and 2: \<open>Q \<Longrightarrow> R\<close>
    and 3: \<open>P \<longrightarrow> Q \<Longrightarrow> P\<close>
  shows \<open>R\<close>
proof -
  from 3 and 1 have \<open>P\<close> .
  with 1 have \<open>Q\<close> by (rule impE)
  with 2 show \<open>R\<close> .
qed

lemma allE':
  assumes 1: \<open>\<forall>x. P(x)\<close>
    and 2: \<open>P(x) \<Longrightarrow> \<forall>x. P(x) \<Longrightarrow> Q\<close>
  shows \<open>Q\<close>
proof -
  from 1 have \<open>P(x)\<close> by (rule spec)
  from this and 1 show \<open>Q\<close> by (rule 2)
qed

lemma notE':
  assumes 1: \<open>\<not> P\<close>
    and 2: \<open>\<not> P \<Longrightarrow> P\<close>
  shows \<open>R\<close>
proof -
  from 2 and 1 have \<open>P\<close> .
  with 1 show \<open>R\<close> by (rule notE)
qed

lemmas [Pure.elim!] = disjE iffE FalseE conjE exE
  and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
  and [Pure.elim 2] = allE notE' impE'
  and [Pure.intro] = exI disjI2 disjI1

setup \<open>
  Context_Rules.addSWrapper
    (fn ctxt => fn tac => hyp_subst_tac ctxt ORELSE' tac)
\<close>

lemma iff_not_sym: \<open>\<not> (Q \<longleftrightarrow> P) \<Longrightarrow> \<not> (P \<longleftrightarrow> Q)\<close>
  by iprover

lemmas [sym] = sym iff_sym not_sym iff_not_sym
  and [Pure.elim?] = iffD1 iffD2 impE

lemma eq_commute: \<open>a = b \<longleftrightarrow> b = a\<close>
  apply (rule iffI)
  apply (erule sym)+
  done

subsection \<open>Atomizing meta-level rules\<close>

lemma atomize_all [atomize]: \<open>(\<And>x. P(x)) \<equiv> Trueprop (\<forall>x. P(x))\<close>
proof
  assume \<open>\<And>x. P(x)\<close>
  then show \<open>\<forall>x. P(x)\<close> ..
next
  assume \<open>\<forall>x. P(x)\<close>
  then show \<open>\<And>x. P(x)\<close> ..
qed

lemma atomize_imp [atomize]: \<open>(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)\<close>
proof
  assume \<open>A \<Longrightarrow> B\<close>
  then show \<open>A \<longrightarrow> B\<close> ..
next
  assume \<open>A \<longrightarrow> B\<close> and \<open>A\<close>
  then show \<open>B\<close> by (rule mp)
qed

lemma atomize_eq [atomize]: \<open>(x \<equiv> y) \<equiv> Trueprop (x = y)\<close>
proof
  assume \<open>x \<equiv> y\<close>
  show \<open>x = y\<close> unfolding \<open>x \<equiv> y\<close> by (rule refl)
next
  assume \<open>x = y\<close>
  then show \<open>x \<equiv> y\<close> by (rule eq_reflection)
qed

lemma atomize_iff [atomize]: \<open>(A \<equiv> B) \<equiv> Trueprop (A \<longleftrightarrow> B)\<close>
proof
  assume \<open>A \<equiv> B\<close>
  show \<open>A \<longleftrightarrow> B\<close> unfolding \<open>A \<equiv> B\<close> by (rule iff_refl)
next
  assume \<open>A \<longleftrightarrow> B\<close>
  then show \<open>A \<equiv> B\<close> by (rule iff_reflection)
qed

lemma atomize_conj [atomize]: \<open>(A &&& B) \<equiv> Trueprop (A \<and> B)\<close>
proof
  assume conj: \<open>A &&& B\<close>
  show \<open>A \<and> B\<close>
  proof (rule conjI)
    from conj show \<open>A\<close> by (rule conjunctionD1)
    from conj show \<open>B\<close> by (rule conjunctionD2)
  qed
next
  assume conj: \<open>A \<and> B\<close>
  show \<open>A &&& B\<close>
  proof -
    from conj show \<open>A\<close> ..
    from conj show \<open>B\<close> ..
  qed
qed

lemmas [symmetric, rulify] = atomize_all atomize_imp
  and [symmetric, defn] = atomize_all atomize_imp atomize_eq atomize_iff

subsection \<open>Atomizing elimination rules\<close>

lemma atomize_exL[atomize_elim]: \<open>(\<And>x. P(x) \<Longrightarrow> Q) \<equiv> ((\<exists>x. P(x)) \<Longrightarrow> Q)\<close>
  by rule iprover+

lemma atomize_conjL[atomize_elim]: \<open>(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (A \<and> B \<Longrightarrow> C)\<close>
  by rule iprover+

lemma atomize_disjL[atomize_elim]: \<open>((A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C) \<equiv> ((A \<or> B \<Longrightarrow> C) \<Longrightarrow> C)\<close>
  by rule iprover+

lemma atomize_elimL[atomize_elim]: \<open>(\<And>B. (A \<Longrightarrow> B) \<Longrightarrow> B) \<equiv> Trueprop(A)\<close> ..

subsection \<open>Calculational rules\<close>

lemma forw_subst: \<open>a = b \<Longrightarrow> P(b) \<Longrightarrow> P(a)\<close>
  by (rule ssubst)

lemma back_subst: \<open>P(a) \<Longrightarrow> a = b \<Longrightarrow> P(b)\<close>
  by (rule subst)

text \<open>
  Note that this list of rules is in reverse order of priorities.
\<close>

lemmas basic_trans_rules [trans] =
  forw_subst
  back_subst
  rev_mp
  mp
  trans

subsection \<open>``Let'' declarations\<close>

nonterminal letbinds and letbind

definition Let :: \<open>['a::{}, 'a => 'b] \<Rightarrow> ('b::{})\<close>
  where \<open>Let(s, f) \<equiv> f(s)\<close>

syntax
  "_bind"       :: \<open>[pttrn, 'a] => letbind\<close>           (\<open>(2_ =/ _)\<close> 10)
  ""            :: \<open>letbind => letbinds\<close>              (\<open>_\<close>)
  "_binds"      :: \<open>[letbind, letbinds] => letbinds\<close>  (\<open>_;/ _\<close>)
  "_Let"        :: \<open>[letbinds, 'a] => 'a\<close>             (\<open>(let (_)/ in (_))\<close> 10)

translations
  "_Let(_binds(b, bs), e)"  == "_Let(b, _Let(bs, e))"
  "let x = a in e"          == "CONST Let(a, \<lambda>x. e)"

lemma LetI:
  assumes \<open>\<And>x. x = t \<Longrightarrow> P(u(x))\<close>
  shows \<open>P(let x = t in u(x))\<close>
  apply (unfold Let_def)
  apply (rule refl [THEN assms])
  done

subsection \<open>Intuitionistic simplification rules\<close>

lemma conj_simps:
  \<open>P \<and> True \<longleftrightarrow> P\<close>
  \<open>True \<and> P \<longleftrightarrow> P\<close>
  \<open>P \<and> False \<longleftrightarrow> False\<close>
  \<open>False \<and> P \<longleftrightarrow> False\<close>
  \<open>P \<and> P \<longleftrightarrow> P\<close>
  \<open>P \<and> P \<and> Q \<longleftrightarrow> P \<and> Q\<close>
  \<open>P \<and> \<not> P \<longleftrightarrow> False\<close>
  \<open>\<not> P \<and> P \<longleftrightarrow> False\<close>
  \<open>(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)\<close>
  by iprover+

lemma disj_simps:
  \<open>P \<or> True \<longleftrightarrow> True\<close>
  \<open>True \<or> P \<longleftrightarrow> True\<close>
  \<open>P \<or> False \<longleftrightarrow> P\<close>
  \<open>False \<or> P \<longleftrightarrow> P\<close>
  \<open>P \<or> P \<longleftrightarrow> P\<close>
  \<open>P \<or> P \<or> Q \<longleftrightarrow> P \<or> Q\<close>
  \<open>(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)\<close>
  by iprover+

lemma not_simps:
  \<open>\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q\<close>
  \<open>\<not> False \<longleftrightarrow> True\<close>
  \<open>\<not> True \<longleftrightarrow> False\<close>
  by iprover+

lemma imp_simps:
  \<open>(P \<longrightarrow> False) \<longleftrightarrow> \<not> P\<close>
  \<open>(P \<longrightarrow> True) \<longleftrightarrow> True\<close>
  \<open>(False \<longrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(True \<longrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(P \<longrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(P \<longrightarrow> \<not> P) \<longleftrightarrow> \<not> P\<close>
  by iprover+

lemma iff_simps:
  \<open>(True \<longleftrightarrow> P) \<longleftrightarrow> P\<close>
  \<open>(P \<longleftrightarrow> True) \<longleftrightarrow> P\<close>
  \<open>(P \<longleftrightarrow> P) \<longleftrightarrow> True\<close>
  \<open>(False \<longleftrightarrow> P) \<longleftrightarrow> \<not> P\<close>
  \<open>(P \<longleftrightarrow> False) \<longleftrightarrow> \<not> P\<close>
  by iprover+

text \<open>The \<open>x = t\<close> versions are needed for the simplification
  procedures.\<close>
lemma quant_simps:
  \<open>\<And>P. (\<forall>x. P) \<longleftrightarrow> P\<close>
  \<open>(\<forall>x. x = t \<longrightarrow> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>(\<forall>x. t = x \<longrightarrow> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>\<And>P. (\<exists>x. P) \<longleftrightarrow> P\<close>
  \<open>\<exists>x. x = t\<close>
  \<open>\<exists>x. t = x\<close>
  \<open>(\<exists>x. x = t \<and> P(x)) \<longleftrightarrow> P(t)\<close>
  \<open>(\<exists>x. t = x \<and> P(x)) \<longleftrightarrow> P(t)\<close>
  by iprover+

text \<open>These are NOT supplied by default!\<close>
lemma distrib_simps:
  \<open>P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R\<close>
  \<open>(Q \<or> R) \<and> P \<longleftrightarrow> Q \<and> P \<or> R \<and> P\<close>
  \<open>(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)\<close>
  by iprover+

subsubsection \<open>Conversion into rewrite rules\<close>

lemma P_iff_F: \<open>\<not> P \<Longrightarrow> (P \<longleftrightarrow> False)\<close>
  by iprover
lemma iff_reflection_F: \<open>\<not> P \<Longrightarrow> (P \<equiv> False)\<close>
  by (rule P_iff_F [THEN iff_reflection])

lemma P_iff_T: \<open>P \<Longrightarrow> (P \<longleftrightarrow> True)\<close>
  by iprover
lemma iff_reflection_T: \<open>P \<Longrightarrow> (P \<equiv> True)\<close>
  by (rule P_iff_T [THEN iff_reflection])

subsubsection \<open>More rewrite rules\<close>

lemma conj_commute: \<open>P \<and> Q \<longleftrightarrow> Q \<and> P\<close> by iprover
lemma conj_left_commute: \<open>P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)\<close> by iprover
lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: \<open>P \<or> Q \<longleftrightarrow> Q \<or> P\<close> by iprover
lemma disj_left_commute: \<open>P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)\<close> by iprover
lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: \<open>P \<and> (Q \<or> R) \<longleftrightarrow> (P \<and> Q \<or> P \<and> R)\<close> by iprover
lemma conj_disj_distribR: \<open>(P \<or> Q) \<and> R \<longleftrightarrow> (P \<and> R \<or> Q \<and> R)\<close> by iprover

lemma disj_conj_distribL: \<open>P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)\<close> by iprover
lemma disj_conj_distribR: \<open>(P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)\<close> by iprover

lemma imp_conj_distrib: \<open>(P \<longrightarrow> (Q \<and> R)) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)\<close> by iprover
lemma imp_conj: \<open>((P \<and> Q) \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))\<close> by iprover
lemma imp_disj: \<open>(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)\<close> by iprover

lemma de_Morgan_disj: \<open>(\<not> (P \<or> Q)) \<longleftrightarrow> (\<not> P \<and> \<not> Q)\<close> by iprover

lemma not_ex: \<open>(\<not> (\<exists>x. P(x))) \<longleftrightarrow> (\<forall>x. \<not> P(x))\<close> by iprover
lemma imp_ex: \<open>((\<exists>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> Q)\<close> by iprover

lemma ex_disj_distrib: \<open>(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> ((\<exists>x. P(x)) \<or> (\<exists>x. Q(x)))\<close>
  by iprover

lemma all_conj_distrib: \<open>(\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> ((\<forall>x. P(x)) \<and> (\<forall>x. Q(x)))\<close>
  by iprover

end