(*  Title:       Iterators over Representations of Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* \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])
      case goal1 thus ?case using S0'_props pre by simp
    next
      case goal3 thus ?case using S0'_props pre by simp
    next
      case (goal2 S \<sigma> x) note assms = this

      from assms S0'_props have inv_x: "invar x" by blast
      from assms(4) have subs_alpha: "\<alpha> ` S \<subseteq> \<alpha> ` S0'" by auto
      from S0'_props assms(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 assms subs_alpha diff_alpha)
    next
      case (goal4 \<sigma> S) note assms = this
      show ?case
        using pre(4)[of "\<alpha> ` S" \<sigma>] assms S0'_props
        by auto
    qed
  qed

      from assms S0'_props have inv_x: "invar x" by blast
      from assms(4) have subs_alpha: "\<alpha> ` S \<subseteq> \<alpha> ` S0'" by auto
      from S0'_props assms(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"] assms S0'_props(3)
        by (simp add: diff_alpha inv_x subs_alpha)
    next
      case (goal4 \<sigma> S) note assms = this

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

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

      from assms(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 assms
        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])
    case goal1 thus ?case using I0 by (simp add: dom_m'_eq)
  next
    case goal3 thus ?case using IF by simp
  next
    case (goal2 k v S \<sigma>) note assms = this
    from IP [of \<sigma> k S v] assms
    show ?case
      by (simp add: m'_props) metis
  next
    case (goal4 \<sigma> S) note assms = this
    show ?case
      using II[of S \<sigma>] assms
      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])
    case goal1 thus ?case using I0 by simp
  next
    case goal3 thus ?case using IF by (simp add: dom_m'_eq)
  next
    case (goal2 k v S \<sigma>) note assms = this
    from IP [of \<sigma> k S v] assms
    show ?case
      by (simp add: m'_props) metis
  next
    case (goal4 \<sigma> S) note assms = this
    show ?case
      using II[of S \<sigma>] assms
      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


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: utype.thy                                                            *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Universal Types\<close>

theory utype
imports "../ucommon"
begin

text \<open>We are going to use the colon for model typing.\<close>

no_notation (ASCII)
  Set.member  ("'(:')") and
  Set.member  ("(_/ : _)" [51, 51] 50)

default_sort typerep

subsection \<open>Unified Types\<close>

text \<open>
  We use Isabelle's @{typ typerep} mechanism to encode UTP model types. This
  avoids having to fix the UTP type model upfront and thereby renders it open
  for extension by the user. A downside of this approach is that there exist
  @{type typerep} objects that do not correspond to permissible types in any
  UTP model, as they may not be injectable into our unified value model.
\<close>

type_synonym utype = "typerep"

translations (type) "utype" \<leftharpoondown> (type) "typerep"

subsection \<open>Type Syntax\<close>

text \<open>@{text "UTYPE('a)"} is synonymous to @{text "TYPEREP('a)"}.\<close>

syntax "_UTYPE" :: "type \<Rightarrow> typerep" ("UTYPE'(_')")

translations "UTYPE('a)" \<rightleftharpoons> (* \<rightharpoonup> *) "TYPEREP('a)"

subsection \<open>Polymorphic Typing\<close>

definition p_type_rel :: "'a \<Rightarrow> utype \<Rightarrow> bool" (infix ":" 50) where
[typing]: "x : t \<longleftrightarrow> UTYPE('a) = t"

subsection \<open>Proof Support\<close>

text \<open>
  The subsequent interpretation for type definitions automatically collects
  @{class typerep} theorems in the theorem attribute @{text typing}. Hence,
  the user does not have to worry about collecting them manually for any of
  the existing or newly-defined HOL types. The @{text typing} attribute is
  generally useful to facilitate proofs about model typing.
\<close>

ML_file "../utils/Typerep_Collect.ML"

text \<open>\todo{The below fails to collect the typerep theorem for @{type String.literal}?}\<close>

setup \<open>
  (Typedef.interpretation
    (Local_Theory.background_theory o Typerep_Collect.collect_typerep_thm))
\<close>

text \<open>
  The following are not collected by the interpretation above as they are
  ground types; we hence add them manually.
\<close>

declare typerep_bool_def [typing]
declare typerep_ind_def [typing]
declare typerep_fun_def [typing]
declare typerep_set_def [typing]

subsection \<open>Experiments\<close>

text \<open>The next shows that all typing theorems have been collected.\<close>

thm typing

text \<open>The examples in the sequel illustrates reasoning about types.\<close>

theorem "(1::nat) : UTYPE(nat)"
apply (simp add: typing)
done

theorem "1 : UTYPE(nat)"
apply (simp add: typing)
oops

theorem "\<not> (1::nat) : UTYPE(int)"
apply (simp add: typing)
done

theorem "(x::'a) : UTYPE('a)"
apply (simp add: typing)
done

theorem "{1::nat} : UTYPE('a set)"
apply (simp add: typing)
oops

theorem "{1::nat} : UTYPE(nat set)"
apply (simp add: typing)
done

theorem "{1} : UTYPE('a set)"
apply (simp add: typing)
oops

theorem "{1::('a::{numeral,typerep})} : UTYPE('a set)"
apply (simp add: typing)
done
end


section \<open>\<open>Extra_Lattice\<close> -- Additional results about lattices\<close>

theory Extra_Lattice
  imports Main
begin

subsection\<open>\<open>Lattice_Missing\<close> -- Miscellaneous missing facts about lattices\<close>

text \<open>Two bundles to activate and deactivate lattice specific notation (e.g., \<open>\<sqinter>\<close> etc.).
  Activate the notation locally via "@{theory_text \<open>includes lattice_notation\<close>}" in a lemma statement.
  (Or sandwich a declaration using that notation between "@{theory_text \<open>unbundle lattice_notation ... unbundle no_lattice_notation\<close>}.)\<close>

bundle lattice_notation begin
notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)
notation Inf ("\<Sqinter>")
notation Sup ("\<Squnion>")
notation bot ("\<bottom>")
notation top ("\<top>")
end

bundle no_lattice_notation begin
notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)
notation Inf ("\<Sqinter>")
notation Sup ("\<Squnion>")
notation bot ("\<bottom>")
notation top ("\<top>")
end

unbundle lattice_notation

text \<open>The following class \<open>complemented_lattice\<close> describes complemented lattices (with
  \<^const>\<open>uminus\<close> for the complement). The definition follows
  \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Definition_and_basic_properties\<close>.
  Additionally, it adopts the convention from \<^class>\<open>boolean_algebra\<close> of defining
  \<^const>\<open>minus\<close> in terms of the complement.\<close>

class complemented_lattice = bounded_lattice + uminus + minus +
  assumes inf_compl_bot[simp]: "inf x (-x) = bot"
    and sup_compl_top[simp]: "sup x (-x) = top"
    and diff_eq:  "x - y = inf x (- y)" begin

lemma dual_complemented_lattice:
  "class.complemented_lattice (\<lambda>x y. x \<squnion> (- y)) uminus sup greater_eq greater inf \<top> \<bottom>"
proof (rule class.complemented_lattice.intro)
  show "class.bounded_lattice (\<squnion>) (\<lambda>x y. (y::'a) \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
    by (rule dual_bounded_lattice)
  show "class.complemented_lattice_axioms (\<lambda>x y. (x::'a) \<squnion> - y) uminus (\<squnion>) (\<sqinter>) \<top> \<bottom>"
    by (unfold_locales, auto simp add: diff_eq)
qed

lemma compl_inf_bot [simp]: "inf (- x) x = bot"
  by (simp add: inf_commute)

lemma compl_sup_top [simp]: "sup (- x) x = top"
  by (simp add: sup_commute)

end

class complete_complemented_lattice = complemented_lattice + complete_lattice

text \<open>The following class \<open>complemented_lattice\<close> describes orthocomplemented lattices,
  following   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthocomplementation\<close>.\<close>
class orthocomplemented_lattice = complemented_lattice +
  assumes ortho_involution[simp]: "- (- x) = x"
    and ortho_antimono: "x \<le> y \<Longrightarrow> -x \<ge> -y" begin

lemma dual_orthocomplemented_lattice:
  "class.orthocomplemented_lattice (\<lambda>x y. x \<squnion> - y) uminus sup greater_eq greater inf \<top> \<bottom>"
proof (rule class.orthocomplemented_lattice.intro)
  show "class.complemented_lattice (\<lambda>x y. (x::'a) \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
    by (rule dual_complemented_lattice)
  show "class.orthocomplemented_lattice_axioms uminus (\<lambda>x y. (y::'a) \<le> x)"
    by (unfold_locales, auto simp add: diff_eq intro: ortho_antimono)
qed

lemma compl_eq_compl_iff [simp]: "- x = - y \<longleftrightarrow> x = y"
  by (metis ortho_involution)

lemma compl_bot_eq [simp]: "- bot = top"
  by (metis inf_compl_bot inf_top_left ortho_involution)

lemma compl_top_eq [simp]: "- top = bot"
  using compl_bot_eq ortho_involution by blast

text \<open>De Morgan's law\<close>
  (* Proof from: https://planetmath.org/orthocomplementedlattice *)
lemma compl_sup [simp]: "- (x \<squnion> y) = - x \<sqinter> - y"
proof -
  have "- (x \<squnion> y) \<le> - x"
    by (simp add: ortho_antimono)
  moreover have "- (x \<squnion> y) \<le> - y"
    by (simp add: ortho_antimono)
  ultimately have 1: "- (x \<squnion> y) \<le> - x \<sqinter> - y"
    by (simp add: sup.coboundedI1)
  have \<open>x \<le> - (-x \<sqinter> -y)\<close>
    by (metis inf.cobounded1 ortho_antimono ortho_involution)
  moreover have \<open>y \<le> - (-x \<sqinter> -y)\<close>
    by (metis inf.cobounded2 ortho_antimono ortho_involution)
  ultimately have \<open>x \<squnion> y \<le> - (-x \<sqinter> -y)\<close>
    by auto
  hence 2: \<open>-x \<sqinter> -y \<le> - (x \<squnion> y)\<close>
    using ortho_antimono by fastforce
  from 1 2 show ?thesis
    using dual_order.antisym by blast
qed

text \<open>De Morgan's law\<close>
lemma compl_inf [simp]: "- (x \<sqinter> y) = - x \<squnion> - y"
  using compl_sup
  by (metis ortho_involution)

lemma compl_mono:
  assumes "x \<le> y"
  shows "- y \<le> - x"
  by (simp add: assms local.ortho_antimono)

lemma compl_le_compl_iff [simp]: "- x \<le> - y \<longleftrightarrow> y \<le> x"
  by (auto dest: compl_mono)

lemma compl_le_swap2:
  assumes "- y \<le> x"
  shows "- x \<le> y"
  using assms local.ortho_antimono by fastforce

lemma compl_less_compl_iff[simp]: "- x < - y \<longleftrightarrow> y < x"
  by (auto simp add: less_le)

lemma compl_less_swap1:
  assumes "y < - x"
  shows "x < - y"
  using assms compl_less_compl_iff by fastforce

lemma compl_less_swap2:
  assumes "- y < x"
  shows "- x < y"
  using assms compl_le_swap1 compl_le_swap2 less_le_not_le by auto

lemma sup_cancel_left1: "sup (sup x a) (sup (- x) b) = top"
  by (simp add: sup_commute sup_left_commute)

lemma sup_cancel_left2: "sup (sup (- x) a) (sup x b) = top"
  by (simp add: sup.commute sup_left_commute)

lemma inf_cancel_left1: "inf (inf x a) (inf (- x) b) = bot"
  by (simp add: inf.left_commute inf_commute)

lemma inf_cancel_left2: "inf (inf (- x) a) (inf x b) = bot"
  using inf.left_commute inf_commute by auto

lemma sup_compl_top_left1 [simp]: "sup (- x) (sup x y) = top"
  by (simp add: sup_assoc[symmetric])

lemma sup_compl_top_left2 [simp]: "sup x (sup (- x) y) = top"
  using sup_compl_top_left1[of "- x" y] by simp

lemma inf_compl_bot_left1 [simp]: "inf (- x) (inf x y) = bot"
  by (simp add: inf_assoc[symmetric])

lemma inf_compl_bot_left2 [simp]: "inf x (inf (- x) y) = bot"
  using inf_compl_bot_left1[of "- x" y] by simp

lemma inf_compl_bot_right [simp]: "inf x (inf y (- x)) = bot"
  by (subst inf_left_commute) simp

end

class complete_orthocomplemented_lattice = orthocomplemented_lattice + complete_lattice

instance complete_orthocomplemented_lattice \<subseteq> complete_complemented_lattice
  by intro_classes

text \<open>The following class \<open>orthomodular_lattice\<close> describes orthomodular lattices,
following   \<^url>\<open>https://en.wikipedia.org/wiki/Complemented_lattice#Orthomodular_lattices\<close>.\<close>
class orthomodular_lattice = orthocomplemented_lattice +
  assumes orthomodular: "x \<le> y \<Longrightarrow> sup x (inf (-x) y) = y" begin

lemma dual_orthomodular_lattice:
  "class.orthomodular_lattice (\<lambda>x y. x \<squnion> - y) uminus sup greater_eq greater inf \<top> \<bottom>"
proof (rule class.orthomodular_lattice.intro)
  show "class.orthocomplemented_lattice (\<lambda>x y. (x::'a) \<squnion> - y) uminus (\<squnion>) (\<lambda>x y. y \<le> x) (\<lambda>x y. y < x) (\<sqinter>) \<top> \<bottom>"
    by (rule dual_orthocomplemented_lattice)
  show "class.orthomodular_lattice_axioms uminus (\<squnion>) (\<lambda>x y. (y::'a) \<le> x) (\<sqinter>)"
  proof (unfold_locales)
    show "(x::'a) \<sqinter> (- x \<squnion> y) = y"
      if "(y::'a) \<le> x"
      for x :: 'a
        and y :: 'a
      using that local.compl_eq_compl_iff local.ortho_antimono local.orthomodular by fastforce
  qed

qed

end

class complete_orthomodular_lattice = orthomodular_lattice + complete_lattice begin

end

instance complete_orthomodular_lattice \<subseteq> complete_orthocomplemented_lattice
  by intro_classes

instance boolean_algebra \<subseteq> orthomodular_lattice
proof
  fix x y :: 'a
  show "sup (x::'a) (inf (- x) y) = y"
    if "(x::'a) \<le> y"
    using that
    by (simp add: sup.absorb_iff2 sup_inf_distrib1)
  show "x - y = inf x (- y)"
    by (simp add: boolean_algebra_class.diff_eq)
qed auto

instance complete_boolean_algebra \<subseteq> complete_orthomodular_lattice
  by intro_classes

lemma image_of_maximum:
  fixes f::"'a::order \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes "mono f"
    and "\<And>x. x:M \<Longrightarrow> x\<le>m"
    and "m:M"
  shows "(SUP x\<in>M. f x) = f m"
  by (smt (verit, ccfv_threshold) assms(1) assms(2) assms(3) cSup_eq_maximum imageE imageI monoD)

lemma cSup_eq_cSup:
  fixes A B :: \<open>'a::conditionally_complete_lattice set\<close>
  assumes bdd: \<open>bdd_above A\<close>
  assumes B: \<open>\<And>a. a\<in>A \<Longrightarrow> \<exists>b\<in>B. b \<ge> a\<close>
  assumes A: \<open>\<And>b. b\<in>B \<Longrightarrow> \<exists>a\<in>A. a \<ge> b\<close>
  shows \<open>Sup A = Sup B\<close>
proof (cases \<open>B = {}\<close>)
  case True
  with A B have \<open>A = {}\<close>
    by auto
  with True show ?thesis by simp
next
  case False
  have \<open>bdd_above B\<close>
    by (meson A bdd bdd_above_def order_trans)
  have \<open>A \<noteq> {}\<close>
    using A False by blast
  moreover have \<open>a \<le> Sup B\<close> if \<open>a \<in> A\<close> for a
  proof -
    obtain b where \<open>b \<in> B\<close> and \<open>b \<ge> a\<close>
      using B \<open>a \<in> A\<close> by auto
    then show ?thesis
      apply (rule cSup_upper2)
      using \<open>bdd_above B\<close> by simp
  qed
  moreover have \<open>Sup B \<le> c\<close> if \<open>\<And>a. a \<in> A \<Longrightarrow> a \<le> c\<close> for c
    using False apply (rule cSup_least)
    using A that by fastforce
  ultimately show ?thesis
    by (rule cSup_eq_non_empty)
qed

unbundle no_lattice_notation

end


(*<*)
theory RCLogic
  imports Wellformed
begin
  (*>*)

hide_const Syntax.dom

chapter \<open>Refinement Constraint Logic\<close>

text \<open> Semantics for the logic we use in the refinement constraints. It is a multi-sorted, quantifier free
logic with polymorphic datatypes and linear arithmetic. We could have modelled by using one of the
encodings to FOL however we wanted to explore using a more direct model. \<close>

section \<open>Evaluation and Satisfiability\<close>

subsection \<open>Valuation\<close>

text \<open> Refinement constraint logic values. SUt is a value for the uninterpreted
       sort that corresponds to basic type variables. For now we only need one of these universes.
       We wrap an smt\_val inside it during a process we call 'boxing'
       which is introduced in the RCLogicL theory \<close>
nominal_datatype rcl_val = SBitvec "bit list" | SNum int | SBool bool | SPair rcl_val rcl_val |
  SCons tyid string rcl_val | SConsp tyid string b rcl_val |
  SUnit | SUt rcl_val

text \<open> RCL sorts. Represent our domains. The universe is the union of all of the these.
        S\_Ut is the single uninterpreted sort. These map almost directly to basic type
        but we have them to distinguish syntax (basic types) and semantics (RCL sorts) \<close>
nominal_datatype rcl_sort = S_bool | S_int | S_unit | S_pair rcl_sort rcl_sort | S_id tyid | S_app tyid rcl_sort | S_bitvec | S_ut

type_synonym valuation = "(x,rcl_val) map"

type_synonym type_valuation = "(bv,rcl_sort) map"

text \<open>Well-sortedness for RCL values\<close>
inductive wfRCV:: "\<Theta> \<Rightarrow> rcl_val \<Rightarrow> b \<Rightarrow> bool" ( " _  \<turnstile> _ : _" [50,50] 50) where
  wfRCV_BBitvecI:  "P \<turnstile> (SBitvec bv)  : B_bitvec"
| wfRCV_BIntI:  "P \<turnstile> (SNum n)  : B_int"
| wfRCV_BBoolI: "P \<turnstile> (SBool b) : B_bool"
| wfRCV_BPairI: "\<lbrakk> P \<turnstile> s1 : b1 ; P \<turnstile> s2 : b2 \<rbrakk> \<Longrightarrow> P \<turnstile> (SPair s1 s2) : (B_pair b1 b2)"
| wfRCV_BConsI: "\<lbrakk>  AF_typedef s dclist \<in> set \<Theta>;
      (dc, \<lbrace> x : b  | c \<rbrace>) \<in> set dclist ;
     \<Theta> \<turnstile> s1 : b \<rbrakk> \<Longrightarrow> \<Theta> \<turnstile>(SCons s dc s1) : (B_id s)"
| wfRCV_BConsPI:"\<lbrakk> AF_typedef_poly s bv dclist \<in> set \<Theta>;
      (dc, \<lbrace> x : b  | c \<rbrace>) \<in> set dclist ;
       atom bv \<sharp> (\<Theta>, SConsp s dc b' s1, B_app s b');
     \<Theta> \<turnstile> s1 : b[bv::=b']\<^sub>b\<^sub>b \<rbrakk> \<Longrightarrow> \<Theta> \<turnstile>(SConsp s dc b' s1) : (B_app s b')"
| wfRCV_BUnitI: "P \<turnstile> SUnit : B_unit"
| wfRCV_BVarI: "P \<turnstile> (SUt n) : (B_var bv)"
equivariance wfRCV
nominal_inductive wfRCV
  avoids wfRCV_BConsPI: bv
proof(goal_cases)
  case (1 s bv dclist \<Theta> dc x b c b' s1)
  then show ?case using fresh_star_def by auto
next
  case (2 s bv dclist \<Theta> dc x b c s1 b')
  then show ?case by auto
qed

inductive_cases wfRCV_elims :
  "wfRCV P s  B_bitvec"
  "wfRCV P s (B_pair b1 b2)"
  "wfRCV P s (B_int)"
  "wfRCV P s (B_bool)"
  "wfRCV P s (B_id ss)"
  "wfRCV P s (B_var bv)"
  "wfRCV P s (B_unit)"
  "wfRCV P s (B_app tyid b)"
  "wfRCV P (SBitvec bv) b"
  "wfRCV P (SNum n)  b"
  "wfRCV P (SBool n)  b"
  "wfRCV P (SPair s1 s2) b"
  "wfRCV P (SCons s dc s1) b"
  "wfRCV P (SConsp s dc b' s1) b"
  "wfRCV P SUnit b"
  "wfRCV P (SUt s1) b"

text \<open> Sometimes we want to assert @{text "P \<turnstile> s ~ b[bv=b']"} and we want to know what b is
however substitution is not injective so we can't write this in terms of @{text "wfRCV"}.
So we define a relation that makes the components of the substitution explicit. \<close>

inductive wfRCV_subst:: "\<Theta> \<Rightarrow> rcl_val \<Rightarrow> b \<Rightarrow> (bv*b) option \<Rightarrow> bool" where
  wfRCV_subst_BBitvecI:  "wfRCV_subst P (SBitvec bv) B_bitvec  sub "
| wfRCV_subst_BIntI:  "wfRCV_subst P (SNum n)  B_int sub "
| wfRCV_subst_BBoolI: "wfRCV_subst P (SBool b)  B_bool sub  "
| wfRCV_subst_BPairI: "\<lbrakk> wfRCV_subst P s1 b1 sub ; wfRCV_subst P s2 b2 sub \<rbrakk> \<Longrightarrow> wfRCV_subst P (SPair s1 s2) (B_pair b1 b2) sub"
| wfRCV_subst_BConsI: "\<lbrakk>  AF_typedef s dclist \<in> set \<Theta>;
      (dc, \<lbrace> x : b  | c \<rbrace>) \<in> set dclist ;
     wfRCV_subst \<Theta> s1 b None \<rbrakk> \<Longrightarrow> wfRCV_subst \<Theta> (SCons s dc s1) (B_id s) sub"
| wfRCV_subst_BConspI: "\<lbrakk>  AF_typedef_poly s bv dclist \<in> set \<Theta>;
      (dc, \<lbrace> x : b  | c \<rbrace>) \<in> set dclist ;
     wfRCV_subst \<Theta> s1 (b[bv::=b']\<^sub>b\<^sub>b) sub  \<rbrakk> \<Longrightarrow> wfRCV_subst \<Theta> (SConsp s dc b' s1) (B_app s b') sub"
| wfRCV_subst_BUnitI: "wfRCV_subst P SUnit B_unit sub "
| wfRCV_subst_BVar1I: "bvar \<noteq> bv \<Longrightarrow> wfRCV_subst P (SUt n) (B_var bv)  (Some (bvar,bin))"
| wfRCV_subst_BVar2I: "\<lbrakk> bvar = bv; wfRCV_subst P s bin None \<rbrakk> \<Longrightarrow> wfRCV_subst P s (B_var bv)  (Some (bvar,bin))"
| wfRCV_subst_BVar3I: "wfRCV_subst P (SUt n) (B_var bv)  None"
equivariance wfRCV_subst
nominal_inductive wfRCV_subst .

subsection \<open>Evaluation base-types\<close>

inductive eval_b :: "type_valuation \<Rightarrow> b \<Rightarrow> rcl_sort \<Rightarrow> bool"  ( "_ \<lbrakk> _ \<rbrakk> ~ _ " ) where
  "v \<lbrakk> B_bool \<rbrakk> ~ S_bool"
| "v \<lbrakk> B_int \<rbrakk> ~ S_int"
| "Some s = v bv \<Longrightarrow> v \<lbrakk> B_var bv \<rbrakk> ~ s"
equivariance eval_b
nominal_inductive eval_b .

subsection \<open>Wellformed vvaluations\<close>

definition wfI ::  "\<Theta> \<Rightarrow> \<Gamma> \<Rightarrow> valuation \<Rightarrow> bool" ( " _ ; _ \<turnstile> _" )  where
  "\<Theta> ; \<Gamma> \<turnstile> i = (\<forall> (x,b,c) \<in> toSet \<Gamma>. \<exists>s. Some s = i x \<and> \<Theta> \<turnstile> s : b)"

subsection \<open>Evaluating Terms\<close>

nominal_function eval_l :: "l \<Rightarrow> rcl_val" ( "\<lbrakk> _ \<rbrakk> " ) where
  "\<lbrakk> L_true \<rbrakk> = SBool True"
|  "\<lbrakk> L_false \<rbrakk> = SBool False"
|  "\<lbrakk> L_num n \<rbrakk> = SNum n"
|  "\<lbrakk> L_unit \<rbrakk> = SUnit"
|  "\<lbrakk> L_bitvec n \<rbrakk> = SBitvec n"
                   apply(auto simp: eqvt_def eval_l_graph_aux_def)
  by (metis l.exhaust)
nominal_termination (eqvt) by lexicographic_order

inductive eval_v :: "valuation \<Rightarrow> v \<Rightarrow> rcl_val \<Rightarrow> bool"  ( "_ \<lbrakk> _ \<rbrakk> ~ _ " ) where
  eval_v_litI:   "i \<lbrakk> V_lit l \<rbrakk> ~ \<lbrakk> l \<rbrakk> "
| eval_v_varI: "Some sv = i x  \<Longrightarrow> i \<lbrakk> V_var x \<rbrakk> ~ sv"
| eval_v_pairI: "\<lbrakk> i \<lbrakk> v1 \<rbrakk> ~ s1 ; i \<lbrakk> v2 \<rbrakk> ~ s2 \<rbrakk> \<Longrightarrow> i \<lbrakk> V_pair v1 v2 \<rbrakk> ~ SPair s1 s2"
| eval_v_consI: "i \<lbrakk> v \<rbrakk> ~ s \<Longrightarrow> i \<lbrakk> V_cons tyid dc v \<rbrakk> ~ SCons tyid dc s"
| eval_v_conspI: "i \<lbrakk> v \<rbrakk> ~ s \<Longrightarrow> i \<lbrakk> V_consp tyid dc b v \<rbrakk> ~ SConsp tyid dc b s"
equivariance eval_v
nominal_inductive eval_v .

inductive_cases eval_v_elims:
  "i \<lbrakk> V_lit l \<rbrakk> ~  s"
  "i \<lbrakk> V_var x \<rbrakk> ~  s"
  "i \<lbrakk> V_pair v1 v2 \<rbrakk> ~ s"
  "i \<lbrakk> V_cons tyid dc v \<rbrakk> ~ s"
  "i \<lbrakk> V_consp tyid dc b v \<rbrakk> ~ s"

inductive eval_e :: "valuation \<Rightarrow> ce \<Rightarrow> rcl_val \<Rightarrow> bool" ( "_ \<lbrakk> _ \<rbrakk> ~ _ " )  where
  eval_e_valI: "i \<lbrakk> v \<rbrakk> ~  sv \<Longrightarrow> i \<lbrakk> CE_val v \<rbrakk> ~ sv"
| eval_e_plusI: "\<lbrakk> i \<lbrakk> v1 \<rbrakk> ~ SNum n1; i \<lbrakk> v2 \<rbrakk> ~ SNum n2  \<rbrakk>  \<Longrightarrow> i \<lbrakk> (CE_op Plus v1 v2) \<rbrakk> ~ (SNum (n1+n2))"
| eval_e_leqI: "\<lbrakk> i \<lbrakk> v1 \<rbrakk> ~ (SNum n1); i \<lbrakk> v2 \<rbrakk> ~ (SNum n2) \<rbrakk>  \<Longrightarrow> i \<lbrakk> (CE_op LEq v1 v2) \<rbrakk> ~ (SBool (n1 \<le> n2))"
| eval_e_eqI: "\<lbrakk> i \<lbrakk> v1 \<rbrakk> ~ s1; i \<lbrakk> v2 \<rbrakk> ~ s2 \<rbrakk>  \<Longrightarrow> i \<lbrakk> (CE_op Eq v1 v2) \<rbrakk> ~ (SBool (s1 = s2))"
| eval_e_fstI: "\<lbrakk> i \<lbrakk> v \<rbrakk> ~ SPair v1 v2  \<rbrakk> \<Longrightarrow> i \<lbrakk> (CE_fst v) \<rbrakk> ~ v1"
| eval_e_sndI: "\<lbrakk> i \<lbrakk> v \<rbrakk> ~ SPair v1 v2  \<rbrakk> \<Longrightarrow> i \<lbrakk> (CE_snd v) \<rbrakk> ~ v2"
| eval_e_concatI:"\<lbrakk> i \<lbrakk> v1 \<rbrakk> ~ (SBitvec bv1); i \<lbrakk> v2 \<rbrakk> ~ (SBitvec bv2) \<rbrakk> \<Longrightarrow> i \<lbrakk> (CE_concat v1 v2) \<rbrakk> ~ (SBitvec (bv1@bv2))"
| eval_e_lenI:"\<lbrakk> i \<lbrakk> v \<rbrakk>  ~ (SBitvec bv) \<rbrakk> \<Longrightarrow> i \<lbrakk> (CE_len v) \<rbrakk> ~ (SNum (int (List.length bv)))"
equivariance eval_e
nominal_inductive eval_e .

inductive_cases eval_e_elims:
  "i \<lbrakk> (CE_val v) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_op Plus v1 v2) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_op LEq v1 v2) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_op Eq v1 v2) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_fst v) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_snd v) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_concat v1 v2) \<rbrakk> ~ s"
  "i \<lbrakk> (CE_len v) \<rbrakk> ~ s"

inductive eval_c :: "valuation \<Rightarrow> c \<Rightarrow> bool \<Rightarrow> bool" ( " _ \<lbrakk> _ \<rbrakk> ~ _ ")  where
  eval_c_trueI:  "i \<lbrakk> C_true \<rbrakk> ~ True"
| eval_c_falseI:"i \<lbrakk> C_false \<rbrakk> ~ False"
| eval_c_conjI: "\<lbrakk> i \<lbrakk> c1 \<rbrakk> ~ b1 ; i \<lbrakk> c2 \<rbrakk> ~ b2 \<rbrakk> \<Longrightarrow>  i \<lbrakk> (C_conj c1 c2) \<rbrakk> ~  (b1 \<and> b2)"
| eval_c_disjI: "\<lbrakk> i \<lbrakk> c1 \<rbrakk> ~ b1 ; i \<lbrakk> c2 \<rbrakk> ~ b2 \<rbrakk> \<Longrightarrow>  i \<lbrakk> (C_disj c1 c2) \<rbrakk> ~ (b1 \<or> b2)"
| eval_c_impI:"\<lbrakk> i \<lbrakk> c1 \<rbrakk> ~ b1 ; i \<lbrakk> c2 \<rbrakk> ~ b2 \<rbrakk> \<Longrightarrow>  i \<lbrakk> (C_imp c1 c2) \<rbrakk> ~ (b1 \<longrightarrow> b2)"
| eval_c_notI:"\<lbrakk> i \<lbrakk> c \<rbrakk> ~ b \<rbrakk> \<Longrightarrow> i \<lbrakk> (C_not c) \<rbrakk> ~ (\<not> b)"
| eval_c_eqI:"\<lbrakk> i \<lbrakk> e1 \<rbrakk> ~ sv1; i \<lbrakk> e2 \<rbrakk> ~ sv2 \<rbrakk> \<Longrightarrow> i \<lbrakk> (C_eq e1 e2) \<rbrakk> ~ (sv1=sv2)"
equivariance eval_c
nominal_inductive eval_c .

inductive_cases eval_c_elims:
  "i \<lbrakk> C_true \<rbrakk> ~  True"
  "i \<lbrakk> C_false \<rbrakk> ~ False"
  "i \<lbrakk> (C_conj c1 c2)\<rbrakk> ~ s"
  "i \<lbrakk> (C_disj c1 c2)\<rbrakk> ~ s"
  "i \<lbrakk> (C_imp c1 c2)\<rbrakk> ~ s"
  "i \<lbrakk> (C_not c) \<rbrakk> ~ s"
  "i \<lbrakk> (C_eq e1 e2)\<rbrakk> ~ s"
  "i \<lbrakk> C_true \<rbrakk> ~ s"
  "i \<lbrakk> C_false \<rbrakk> ~ s"

subsection \<open>Satisfiability\<close>

inductive  is_satis :: "valuation \<Rightarrow> c \<Rightarrow> bool" ( " _ \<Turnstile> _ " ) where
  "i \<lbrakk> c \<rbrakk> ~ True \<Longrightarrow> i \<Turnstile> c"
equivariance is_satis
nominal_inductive is_satis .

nominal_function is_satis_g :: "valuation \<Rightarrow> \<Gamma> \<Rightarrow> bool" ( " _ \<Turnstile> _ " ) where
  "i \<Turnstile> GNil = True"
| "i \<Turnstile> ((x,b,c) #\<^sub>\<Gamma> G) = ( i \<Turnstile> c \<and>  i \<Turnstile> G)"
       apply(auto simp: eqvt_def is_satis_g_graph_aux_def)
  by (metis \<Gamma>.exhaust old.prod.exhaust)
nominal_termination (eqvt) by lexicographic_order

section \<open>Validity\<close>

nominal_function  valid :: "\<Theta> \<Rightarrow> \<B> \<Rightarrow> \<Gamma> \<Rightarrow> c \<Rightarrow> bool"  ("_ ; _ ; _  \<Turnstile> _ " [50, 50] 50)  where
  "P ; B ; G \<Turnstile> c = ( (P ; B ; G \<turnstile>\<^sub>w\<^sub>f c) \<and> (\<forall>i. (P ; G \<turnstile> i) \<and>  i \<Turnstile> G \<longrightarrow> i \<Turnstile> c))"
  by (auto simp: eqvt_def wfI_def valid_graph_aux_def)
nominal_termination (eqvt) by lexicographic_order

section \<open>Lemmas\<close>
text \<open>Lemmas needed for Examples\<close>

lemma valid_trueI [intro]:
  fixes G::\<Gamma>
  assumes "P ; B \<turnstile>\<^sub>w\<^sub>f G"
  shows "P ; B ; G \<Turnstile> C_true"
proof -
  have "\<forall>i. i \<Turnstile> C_true" using is_satis.simps eval_c_trueI by simp
  moreover have "P ; B ; G \<turnstile>\<^sub>w\<^sub>f C_true" using wfC_trueI assms by simp
  ultimately show ?thesis using valid.simps by simp
qed

end


(*
    This file is a part of MMIsar - a translation of Metamath's set.mm to Isabelle 2005 (ZF logic).

    Copyright (C) 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Metamath examples\<close>

theory MMI_examples imports MMI_Complex_ZF

begin

text\<open>This theory contains 10 theorems translated from
  Metamath (with proofs). It is included
  in the proof document as an illustration of how a translated
  Metamath proof looks like. The "known\_theorems.txt"
  file included in the IsarMathLib distribution provides
  a list of all translated facts.\<close>

(******201-210****************************)

lemma (in MMIsar0) MMI_dividt:
   shows "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow> ( A \<cdiv> A ) = \<one>"
proof -
   have S1: "( A \<in> \<complex> \<and> A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> A ) = ( A \<cdot> ( \<one> \<cdiv> A ) )" by (rule MMI_divrect)
   from S1 have S2: "( ( A \<in> \<complex> \<and> A \<in> \<complex> ) \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> A ) = ( A \<cdot> ( \<one> \<cdiv> A ) )" by (rule MMI_3expa)
   from S2 have S3: "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> A ) = ( A \<cdot> ( \<one> \<cdiv> A ) )" by (rule MMI_anabsan)
   have S4: "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdot> ( \<one> \<cdiv> A ) ) = \<one>" by (rule MMI_recidt)
   from S3 S4 show "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow> ( A \<cdiv> A ) = \<one>" by (rule MMI_eqtrd)
qed

lemma (in MMIsar0) MMI_div0t:
   shows "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow> ( \<zero> \<cdiv> A ) = \<zero>"
proof -
   have S1: "\<zero> \<in> \<complex>" by (rule MMI_0cn)
   have S2: "( \<zero> \<in> \<complex> \<and> A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( \<zero> \<cdiv> A ) = ( \<zero> \<cdot> ( \<one> \<cdiv> A ) )" by (rule MMI_divrect)
   from S1 S2 have S3: "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( \<zero> \<cdiv> A ) = ( \<zero> \<cdot> ( \<one> \<cdiv> A ) )" by (rule MMI_mp3an1)
   have S4: "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow> ( \<one> \<cdiv> A ) \<in> \<complex>" by (rule MMI_recclt)
   have S5: "( \<one> \<cdiv> A ) \<in> \<complex> \<longrightarrow> ( \<zero> \<cdot> ( \<one> \<cdiv> A ) ) = \<zero>"
     by (rule MMI_mul02t)
   from S4 S5 have S6: "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow>
 ( \<zero> \<cdot> ( \<one> \<cdiv> A ) ) = \<zero>" by (rule MMI_syl)
   from S3 S6 show "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow> ( \<zero> \<cdiv> A ) = \<zero>" by (rule MMI_eqtrd)
qed

lemma (in MMIsar0) MMI_diveq0t:
   shows "( A \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) = \<zero> \<longleftrightarrow> A = \<zero> )"
proof -
   have S1: "( C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow> ( \<zero> \<cdiv> C ) = \<zero>" by (rule MMI_div0t)
   from S1 have S2: "( C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) =
 ( \<zero> \<cdiv> C ) \<longleftrightarrow> ( A \<cdiv> C ) = \<zero> )" by (rule MMI_eqeq2d)
   from S2 have S3: "( A \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) =
 ( \<zero> \<cdiv> C ) \<longleftrightarrow> ( A \<cdiv> C ) = \<zero> )" by (rule MMI_3adant1)
   have S4: "\<zero> \<in> \<complex>" by (rule MMI_0cn)
   have S5: "( A \<in> \<complex> \<and> \<zero> \<in> \<complex> \<and> ( C \<in> \<complex> \<and> C \<noteq> \<zero> ) ) \<longrightarrow>
 ( ( A \<cdiv> C ) = ( \<zero> \<cdiv> C ) \<longleftrightarrow> A = \<zero> )" by (rule MMI_div11t)
   from S4 S5 have S6: "( A \<in> \<complex> \<and> ( C \<in> \<complex> \<and> C \<noteq> \<zero> ) ) \<longrightarrow>
 ( ( A \<cdiv> C ) = ( \<zero> \<cdiv> C ) \<longleftrightarrow> A = \<zero> )" by (rule MMI_mp3an2)
   from S6 have S7: "( A \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) = ( \<zero> \<cdiv> C ) \<longleftrightarrow> A = \<zero> )" by (rule MMI_3impb)
   from S3 S7 show "( A \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) = \<zero> \<longleftrightarrow> A = \<zero> )" by (rule MMI_bitr3d)
qed

lemma (in MMIsar0) MMI_recrec: assumes A1: "A \<in> \<complex>" and
    A2: "A \<noteq> \<zero>"
   shows "( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) = A"
proof -
   from A1 have S1: "A \<in> \<complex>".
   from A2 have S2: "A \<noteq> \<zero>".
   from S1 S2 have S3: "( \<one> \<cdiv> A ) \<in> \<complex>" by (rule MMI_reccl)
   have S4: "\<one> \<in> \<complex>" by (rule MMI_1cn)
   from A1 have S5: "A \<in> \<complex>".
   have S6: "\<one> \<noteq> \<zero>" by (rule MMI_ax1ne0)
   from A2 have S7: "A \<noteq> \<zero>".
   from S4 S5 S6 S7 have S8: "( \<one> \<cdiv> A ) \<noteq> \<zero>" by (rule MMI_divne0)
   from S3 S8 have S9: "( ( \<one> \<cdiv> A ) \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) = \<one>"
     by (rule MMI_recid)
   from S9 have S10: "( A \<cdot> ( ( \<one> \<cdiv> A ) \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) ) =
 ( A \<cdot> \<one> )" by (rule MMI_opreq2i)
   from A1 have S11: "A \<in> \<complex>".
   from A2 have S12: "A \<noteq> \<zero>".
   from S11 S12 have S13: "( A \<cdot> ( \<one> \<cdiv> A ) ) = \<one>" by (rule MMI_recid)
   from S13 have S14: "( ( A \<cdot> ( \<one> \<cdiv> A ) ) \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) =
 ( \<one> \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) )" by (rule MMI_opreq1i)
   from A1 have S15: "A \<in> \<complex>".
   from S3 have S16: "( \<one> \<cdiv> A ) \<in> \<complex>" .
   from S3 have S17: "( \<one> \<cdiv> A ) \<in> \<complex>" .
   from S8 have S18: "( \<one> \<cdiv> A ) \<noteq> \<zero>" .
   from S17 S18 have S19: "( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) \<in> \<complex>" by (rule MMI_reccl)
   from S15 S16 S19 have S20:
     "( ( A \<cdot> ( \<one> \<cdiv> A ) ) \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) =
 ( A \<cdot> ( ( \<one> \<cdiv> A ) \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) )" by (rule MMI_mulass)
   from S19 have S21: "( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) \<in> \<complex>" .
   from S21 have S22: "( \<one> \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) =
 ( \<one> \<cdiv> ( \<one> \<cdiv> A ) )" by (rule MMI_mulid2)
   from S14 S20 S22 have S23:
     "( A \<cdot> ( ( \<one> \<cdiv> A ) \<cdot> ( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) ) ) =
 ( \<one> \<cdiv> ( \<one> \<cdiv> A ) )" by (rule MMI_3eqtr3)
   from A1 have S24: "A \<in> \<complex>".
   from S24 have S25: "( A \<cdot> \<one> ) = A" by (rule MMI_mulid1)
   from S10 S23 S25 show "( \<one> \<cdiv> ( \<one> \<cdiv> A ) ) = A" by (rule MMI_3eqtr3)
qed

lemma (in MMIsar0) MMI_divid: assumes A1: "A \<in> \<complex>" and
    A2: "A \<noteq> \<zero>"
   shows "( A \<cdiv> A ) = \<one>"
proof -
   from A1 have S1: "A \<in> \<complex>".
   from A1 have S2: "A \<in> \<complex>".
   from A2 have S3: "A \<noteq> \<zero>".
   from S1 S2 S3 have S4: "( A \<cdiv> A ) = ( A \<cdot> ( \<one> \<cdiv> A ) )" by (rule MMI_divrec)
   from A1 have S5: "A \<in> \<complex>".
   from A2 have S6: "A \<noteq> \<zero>".
   from S5 S6 have S7: "( A \<cdot> ( \<one> \<cdiv> A ) ) = \<one>" by (rule MMI_recid)
   from S4 S7 show "( A \<cdiv> A ) = \<one>" by (rule MMI_eqtr)
qed

lemma (in MMIsar0) MMI_div0: assumes A1: "A \<in> \<complex>" and
    A2: "A \<noteq> \<zero>"
   shows "( \<zero> \<cdiv> A ) = \<zero>"
proof -
   from A1 have S1: "A \<in> \<complex>".
   from A2 have S2: "A \<noteq> \<zero>".
   have S3: "( A \<in> \<complex> \<and> A \<noteq> \<zero> ) \<longrightarrow> ( \<zero> \<cdiv> A ) = \<zero>" by (rule MMI_div0t)
   from S1 S2 S3 show "( \<zero> \<cdiv> A ) = \<zero>" by (rule MMI_mp2an)
qed

lemma (in MMIsar0) MMI_div1: assumes A1: "A \<in> \<complex>"
   shows "( A \<cdiv> \<one> ) = A"
proof -
   from A1 have S1: "A \<in> \<complex>".
   from S1 have S2: "( \<one> \<cdot> A ) = A" by (rule MMI_mulid2)
   from A1 have S3: "A \<in> \<complex>".
   have S4: "\<one> \<in> \<complex>" by (rule MMI_1cn)
   from A1 have S5: "A \<in> \<complex>".
   have S6: "\<one> \<noteq> \<zero>" by (rule MMI_ax1ne0)
   from S3 S4 S5 S6 have S7: "( A \<cdiv> \<one> ) = A \<longleftrightarrow> ( \<one> \<cdot> A ) = A"
     by (rule MMI_divmul)
   from S2 S7 show "( A \<cdiv> \<one> ) = A" by (rule MMI_mpbir)
qed

lemma (in MMIsar0) MMI_div1t:
   shows "A \<in> \<complex> \<longrightarrow> ( A \<cdiv> \<one> ) = A"
proof -
   have S1: "A =
 if ( A \<in> \<complex> , A , \<one> ) \<longrightarrow>
 ( A \<cdiv> \<one> ) =
 ( if ( A \<in> \<complex> , A , \<one> ) \<cdiv> \<one> )" by (rule MMI_opreq1)
   have S2: "A =
 if ( A \<in> \<complex> , A , \<one> ) \<longrightarrow>
 A = if ( A \<in> \<complex> , A , \<one> )" by (rule MMI_id)
   from S1 S2 have S3: "A =
 if ( A \<in> \<complex> , A , \<one> ) \<longrightarrow>
 ( ( A \<cdiv> \<one> ) =
 A \<longleftrightarrow>
 ( if ( A \<in> \<complex> , A , \<one> ) \<cdiv> \<one> ) =
 if ( A \<in> \<complex> , A , \<one> ) )" by (rule MMI_eqeq12d)
   have S4: "\<one> \<in> \<complex>" by (rule MMI_1cn)
   from S4 have S5: "if ( A \<in> \<complex> , A , \<one> ) \<in> \<complex>" by (rule MMI_elimel)
   from S5 have S6: "( if ( A \<in> \<complex> , A , \<one> ) \<cdiv> \<one> ) =
 if ( A \<in> \<complex> , A , \<one> )" by (rule MMI_div1)
   from S3 S6 show "A \<in> \<complex> \<longrightarrow> ( A \<cdiv> \<one> ) = A" by (rule MMI_dedth)
qed

lemma (in MMIsar0) MMI_divnegt:
   shows "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( \<cn> ( A \<cdiv> B ) ) = ( ( \<cn> A ) \<cdiv> B )"
proof -
   have S1: "( A \<in> \<complex> \<and> ( \<one> \<cdiv> B ) \<in> \<complex> ) \<longrightarrow>
 ( ( \<cn> A ) \<cdot> ( \<one> \<cdiv> B ) ) =
 ( \<cn> ( A \<cdot> ( \<one> \<cdiv> B ) ) )" by (rule MMI_mulneg1t)
   have S2: "( B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow> ( \<one> \<cdiv> B ) \<in> \<complex>" by (rule MMI_recclt)
   from S1 S2 have S3: "( A \<in> \<complex> \<and> ( B \<in> \<complex> \<and> B \<noteq> \<zero> ) ) \<longrightarrow>
 ( ( \<cn> A ) \<cdot> ( \<one> \<cdiv> B ) ) =
 ( \<cn> ( A \<cdot> ( \<one> \<cdiv> B ) ) )" by (rule MMI_sylan2)
   from S3 have S4: "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( ( \<cn> A ) \<cdot> ( \<one> \<cdiv> B ) ) =
 ( \<cn> ( A \<cdot> ( \<one> \<cdiv> B ) ) )" by (rule MMI_3impb)
   have S5: "( ( \<cn> A ) \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( ( \<cn> A ) \<cdiv> B ) =
 ( ( \<cn> A ) \<cdot> ( \<one> \<cdiv> B ) )" by (rule MMI_divrect)
   have S6: "A \<in> \<complex> \<longrightarrow> ( \<cn> A ) \<in> \<complex>" by (rule MMI_negclt)
   from S5 S6 have S7: "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( ( \<cn> A ) \<cdiv> B ) =
 ( ( \<cn> A ) \<cdot> ( \<one> \<cdiv> B ) )" by (rule MMI_syl3an1)
   have S8: "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> B ) = ( A \<cdot> ( \<one> \<cdiv> B ) )" by (rule MMI_divrect)
   from S8 have S9: "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( \<cn> ( A \<cdiv> B ) ) =
 ( \<cn> ( A \<cdot> ( \<one> \<cdiv> B ) ) )" by (rule MMI_negeqd)
   from S4 S7 S9 show "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> B \<noteq> \<zero> ) \<longrightarrow>
 ( \<cn> ( A \<cdiv> B ) ) = ( ( \<cn> A ) \<cdiv> B )" by (rule MMI_3eqtr4rd)
qed

lemma (in MMIsar0) MMI_divsubdirt:
   shows "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cs> B ) \<cdiv> C ) =
 ( ( A \<cdiv> C ) \<cs> ( B \<cdiv> C ) )"
proof -
   have S1: "( ( A \<in> \<complex> \<and> ( \<cn> B ) \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<ca> ( \<cn> B ) ) \<cdiv> C ) =
 ( ( A \<cdiv> C ) \<ca> ( ( \<cn> B ) \<cdiv> C ) )" by (rule MMI_divdirt)
   have S2: "B \<in> \<complex> \<longrightarrow> ( \<cn> B ) \<in> \<complex>" by (rule MMI_negclt)
   from S1 S2 have S3: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<ca> ( \<cn> B ) ) \<cdiv> C ) =
 ( ( A \<cdiv> C ) \<ca> ( ( \<cn> B ) \<cdiv> C ) )" by (rule MMI_syl3anl2)
   have S4: "( A \<in> \<complex> \<and> B \<in> \<complex> ) \<longrightarrow>
 ( A \<ca> ( \<cn> B ) ) = ( A \<cs> B )" by (rule MMI_negsubt)
   from S4 have S5: "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<longrightarrow>
 ( A \<ca> ( \<cn> B ) ) = ( A \<cs> B )" by (rule MMI_3adant3)
   from S5 have S6: "( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<longrightarrow>
 ( ( A \<ca> ( \<cn> B ) ) \<cdiv> C ) =
 ( ( A \<cs> B ) \<cdiv> C )" by (rule MMI_opreq1d)
   from S6 have S7: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<ca> ( \<cn> B ) ) \<cdiv> C ) =
 ( ( A \<cs> B ) \<cdiv> C )" by (rule MMI_adantr)
   have S8: "( B \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( \<cn> ( B \<cdiv> C ) ) = ( ( \<cn> B ) \<cdiv> C )" by (rule MMI_divnegt)
   from S8 have S9: "( ( B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( \<cn> ( B \<cdiv> C ) ) = ( ( \<cn> B ) \<cdiv> C )" by (rule MMI_3expa)
   from S9 have S10: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( \<cn> ( B \<cdiv> C ) ) = ( ( \<cn> B ) \<cdiv> C )" by (rule MMI_3adantl1)
   from S10 have S11: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) \<ca> ( \<cn> ( B \<cdiv> C ) ) ) =
 ( ( A \<cdiv> C ) \<ca> ( ( \<cn> B ) \<cdiv> C ) )" by (rule MMI_opreq2d)
   have S12: "( ( A \<cdiv> C ) \<in> \<complex> \<and> ( B \<cdiv> C ) \<in> \<complex> ) \<longrightarrow>
 ( ( A \<cdiv> C ) \<ca> ( \<cn> ( B \<cdiv> C ) ) ) =
 ( ( A \<cdiv> C ) \<cs> ( B \<cdiv> C ) )" by (rule MMI_negsubt)
   have S13: "( A \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> C ) \<in> \<complex>" by (rule MMI_divclt)
   from S13 have S14: "( ( A \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> C ) \<in> \<complex>" by (rule MMI_3expa)
   from S14 have S15: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( A \<cdiv> C ) \<in> \<complex>" by (rule MMI_3adantl2)
   have S16: "( B \<in> \<complex> \<and> C \<in> \<complex> \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( B \<cdiv> C ) \<in> \<complex>" by (rule MMI_divclt)
   from S16 have S17: "( ( B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( B \<cdiv> C ) \<in> \<complex>" by (rule MMI_3expa)
   from S17 have S18: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( B \<cdiv> C ) \<in> \<complex>" by (rule MMI_3adantl1)
   from S12 S15 S18 have S19: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) \<ca> ( \<cn> ( B \<cdiv> C ) ) ) =
 ( ( A \<cdiv> C ) \<cs> ( B \<cdiv> C ) )" by (rule MMI_sylanc)
   from S11 S19 have S20: "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cdiv> C ) \<ca> ( ( \<cn> B ) \<cdiv> C ) ) =
 ( ( A \<cdiv> C ) \<cs> ( B \<cdiv> C ) )" by (rule MMI_eqtr3d)
   from S3 S7 S20 show "( ( A \<in> \<complex> \<and> B \<in> \<complex> \<and> C \<in> \<complex> ) \<and> C \<noteq> \<zero> ) \<longrightarrow>
 ( ( A \<cs> B ) \<cdiv> C ) =
 ( ( A \<cdiv> C ) \<cs> ( B \<cdiv> C ) )" by (rule MMI_3eqtr3d)
qed

end


(*  Title:       Show
    Author:      Christian Sternagel <c.sternagel@gmail.com>
    Author:      René Thiemann <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel <c.sternagel@gmail.com>
    Maintainer:  René Thiemann <rene.thiemann@uibk.ac.at>
*)

section \<open>Instances of the Show Class for Standard Types\<close>

theory Show_Instances
imports
  Show
  "~~/src/HOL/Rat"
begin

definition showsp_unit :: "unit showsp"
where
  "showsp_unit p x = shows_string ''()''"

lemma show_law_unit [show_law_intros]:
  "show_law showsp_unit x"
  by (rule show_lawI) (simp add: showsp_unit_def show_law_simps)

abbreviation showsp_char :: "char showsp"
where
  "showsp_char \<equiv> shows_prec"

lemma show_law_char [show_law_intros]:
  "show_law showsp_char x"
  by (rule show_lawI) (simp add: show_law_simps)

primrec showsp_bool :: "bool showsp"
where
  "showsp_bool p True = shows_string ''True''" |
  "showsp_bool p False = shows_string ''False''"

lemma show_law_bool [show_law_intros]:
  "show_law showsp_bool x"
  by (rule show_lawI, cases x) (simp_all add: show_law_simps)

primrec pshowsp_prod :: "(shows \<times> shows) showsp"
where
  "pshowsp_prod p (x, y) = shows_string ''('' o x o shows_string '', '' o y o shows_string '')''"

(*NOTE: in order to be compatible with automatically generated show funtions,
show-arguments of "map"-functions need to get precedence 1 (which may lead to
redundant parentheses in the output, but seems unavoidable in the current setup,
i.e., pshowsp via primrec followed by defining showsp via pshowsp composed with map).*)
definition showsp_prod :: "'a showsp \<Rightarrow> 'b showsp \<Rightarrow> ('a \<times> 'b) showsp"
where
  [code del]: "showsp_prod s1 s2 p = pshowsp_prod p o map_prod (s1 1) (s2 1)"

lemma showsp_prod_simps [simp, code]:
  "showsp_prod s1 s2 p (x, y) =
    shows_string ''('' o s1 1 x o shows_string '', '' o s2 1 y o shows_string '')''"
  by (simp add: showsp_prod_def)

fun string_of_digit :: "nat \<Rightarrow> string"
where
  "string_of_digit n =
    (if n = 0 then ''0''
    else if n = 1 then ''1''
    else if n = 2 then ''2''
    else if n = 3 then ''3''
    else if n = 4 then ''4''
    else if n = 5 then ''5''
    else if n = 6 then ''6''
    else if n = 7 then ''7''
    else if n = 8 then ''8''
    else ''9'')"

fun showsp_nat :: "nat showsp"
where
  "showsp_nat p n =
    (if n < 10 then shows_string (string_of_digit n)
    else showsp_nat p (n div 10) o shows_string (string_of_digit (n mod 10)))"
declare showsp_nat.simps [simp del]

lemma show_law_nat [show_law_intros]:
  "show_law showsp_nat n"
  by (rule show_lawI, induct n rule: nat_less_induct) (simp add: show_law_simps showsp_nat.simps)

lemma showsp_nat_append [show_law_simps]:
  "showsp_nat p n (x @ y) = showsp_nat p n x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_int :: "int showsp"
where
  "showsp_int p i =
    (if i < 0 then shows_string ''-'' o showsp_nat p (nat (- i)) else showsp_nat p (nat i))"

lemma show_law_int [show_law_intros]:
  "show_law showsp_int i"
  by (rule show_lawI, cases "i < 0") (simp_all add: showsp_int_def show_law_simps)

lemma showsp_int_append [show_law_simps]:
  "showsp_int p i (x @ y) = showsp_int p i x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_rat :: "rat showsp"
where
  "showsp_rat p x =
    (case quotient_of x of (d, n) \<Rightarrow>
      if n = 1 then showsp_int p d else showsp_int p d o shows_string ''/'' o showsp_int p n)"

lemma show_law_rat [show_law_intros]:
  "show_law showsp_rat r"
  by (rule show_lawI, cases "quotient_of r") (simp add: showsp_rat_def show_law_simps)

lemma showsp_rat_append [show_law_simps]:
  "showsp_rat p r (x @ y) = showsp_rat p r x @ y"
  by (intro show_lawD show_law_intros)

text \<open>
  Automatic show functions are not used for @{type unit}, @{type prod}, and numbers:
  for @{type unit} and @{type prod}, we do not want to display @{term "''Unity''"} and
  @{term "''Pair''"}; for @{type nat}, we do not want to display
  @{term "''Suc (Suc (... (Suc 0) ...))''"}; and neither @{type int}
  nor @{type rat} are datatypes.
\<close>

local_setup {*
  Show_Generator.register_foreign_partial_and_full_showsp @{type_name prod} 0
       @{term "pshowsp_prod"}
       @{term "showsp_prod"} (SOME @{thm showsp_prod_def})
       @{term "map_prod"} (SOME @{thm prod.map_comp}) [true, true]
       @{thm show_law_prod}
  #> Show_Generator.register_foreign_showsp @{typ unit} @{term "showsp_unit"} @{thm show_law_unit}
  #> Show_Generator.register_foreign_showsp @{typ bool} @{term "showsp_bool"} @{thm show_law_bool}
  #> Show_Generator.register_foreign_showsp @{typ char} @{term "showsp_char"} @{thm show_law_char}
  #> Show_Generator.register_foreign_showsp @{typ nat} @{term "showsp_nat"} @{thm show_law_nat}
  #> Show_Generator.register_foreign_showsp @{typ int} @{term "showsp_int"} @{thm show_law_int}
  #> Show_Generator.register_foreign_showsp @{typ rat} @{term "showsp_rat"} @{thm show_law_rat}
*}

derive "show" option sum prod unit bool nat int rat

export_code
  "shows_prec :: 'a::show option showsp"
  "shows_prec :: ('a::show, 'b::show) sum showsp"
  "shows_prec :: ('a::show \<times> 'b::show) showsp"
  "shows_prec :: unit showsp"
  "shows_prec :: char showsp"
  "shows_prec :: bool showsp"
  "shows_prec :: nat showsp"
  "shows_prec :: int showsp"
  "shows_prec :: rat showsp"
  checking

end