theory DirectDerivation
  imports Rule Gluing Deletion
begin

(* GRAT PDF P. 114 *)
locale direct_derivation =
  r: rule r b b' +
  gi: injective_morphism "lhs r" G g  +

  po1: pushout_diagram "interf r" "lhs r" D G b d g c +
  po2: pushout_diagram "interf r" "rhs r" D H b' d f c'
  for r b b' G g D d c H f c'
begin

  sublocale d_inj: injective_morphism "interf r" D d
    using po1.b_f_inj_imp_c_inj[OF r.k.injective_morphism_axioms gi.injective_morphism_axioms]
    by assumption

  sublocale pb1: pullback_diagram "interf r" "lhs r" D G b d g c
    using po1.pushout_pullback_inj_b[OF r.k.injective_morphism_axioms d_inj.injective_morphism_axioms]
    by assumption

sublocale pb2: pullback_diagram "interf r" "rhs r" D H b' d f c'
  using po2.pushout_pullback_inj_b[OF r.r.injective_morphism_axioms d_inj.injective_morphism_axioms]
  by assumption

theorem uniqueness_direct_derivation:
  assumes
    dd2: \<open>direct_derivation r b b' G g D' d' m H' f' m'\<close>
  shows \<open>(\<exists>u. bijective_morphism D D' u) \<and> (\<exists>u. bijective_morphism H H' u)\<close>
proof -
  interpret dd2: direct_derivation r b b' G g D' d' m H' f' m'
    using dd2 by assumption

  interpret g: injective_morphism "lhs r" G g
    using gi.injective_morphism_axioms
    by assumption

  interpret dd_inj: injective_morphism "interf r" D' d'
    using dd2.po1.b_f_inj_imp_c_inj[OF r.k.injective_morphism_axioms gi.injective_morphism_axioms]
    by assumption

    (*   front left face
           po1
         bottom face
           dd2.po1
     *)

    (* front right *)
    interpret fr: pullback_construction D G D' c m ..

    (* back left *)
    interpret bt: pullback_diagram "interf r" "interf r" "interf r" "lhs r" idM idM b b
      using fun_algrtr_4_7_2[OF r.k.injective_morphism_axioms] by assumption

    (* back right *)
    interpret pb_frontleft: pullback_diagram "interf r" "lhs r" D' G b d' g m
      using dd2.pb1.pullback_diagram_axioms
      by assumption

    interpret backside: pullback_diagram "interf r" D' "interf r" G \<open>d' \<circ>\<^sub>\<rightarrow> idM\<close> idM m \<open>g \<circ>\<^sub>\<rightarrow> b\<close>
      using pullback_composition[OF bt.pullback_diagram_axioms dd2.pb1.flip_diagram]
      by assumption

    define h where \<open>h \<equiv> \<lparr>node_map = \<lambda>v. (\<^bsub>d\<^esub>\<^sub>V v, \<^bsub>d'\<^esub>\<^sub>V v), edge_map = \<lambda>e. (\<^bsub>d\<^esub>\<^sub>E e, \<^bsub>d'\<^esub>\<^sub>E e)\<rparr>\<close>
    interpret h: morphism "interf r" fr.A h
    proof
      show \<open>\<^bsub>h\<^esub>\<^sub>E e \<in> E\<^bsub>fr.A\<^esub>\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
        using that fr.pb.edge_commutativity po1.c.morph_edge_range po1.edge_commutativity
              dd2.po1.edge_commutativity dd2.po1.c.morph_edge_range
        by(simp add: fr.A_def h_def fr.b_def morph_comp_def fr.c_def)
    next
      show \<open>\<^bsub>h\<^esub>\<^sub>V v \<in> V\<^bsub>fr.A\<^esub>\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
        using that fr.pb.node_commutativity po1.c.morph_node_range po1.node_commutativity dd2.po1.node_commutativity dd2.po1.c.morph_node_range
        by (simp add: fr.A_def h_def fr.b_def morph_comp_def fr.c_def)
    next
      show \<open>\<^bsub>h\<^esub>\<^sub>V (s\<^bsub>interf r\<^esub> e) = s\<^bsub>fr.A\<^esub> (\<^bsub>h\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
        using that
        by (simp add: po1.c.source_preserve dd2.po1.c.source_preserve fr.A_def h_def)
    next
      show \<open>\<^bsub>h\<^esub>\<^sub>V (t\<^bsub>interf r\<^esub> e) = t\<^bsub>fr.A\<^esub> (\<^bsub>h\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
        using that
        by (simp add: po1.c.target_preserve dd2.po1.c.target_preserve fr.A_def h_def)
    next
      show \<open>l\<^bsub>interf r\<^esub> v = l\<^bsub>fr.A\<^esub> (\<^bsub>h\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
        using that
        by (simp add: fr.A_def h_def po1.c.label_preserve)
    next
      show \<open>m\<^bsub>interf r\<^esub> e = m\<^bsub>fr.A\<^esub> (\<^bsub>h\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
        using that
        by (simp add: fr.A_def h_def po1.c.mark_preserve)
    qed

   (*  k: U \<rightarrow> C' = fr.c*)
  (* top square commutativity *)
    have a: \<open>\<^bsub>d' \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>V v = \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using that
      by (simp add: h_def fr.c_def morph_comp_def)

    have b: \<open>\<^bsub>d' \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>E e = \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that
      by (simp add: h_def fr.c_def morph_comp_def)
(* bottom square commutes is assumption *)
    have \<open>\<^bsub>g \<circ>\<^sub>\<rightarrow> b\<^esub>\<^sub>V v = \<^bsub>c \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using po1.node_commutativity that by blast
    have *: \<open>d' \<circ>\<^sub>\<rightarrow> idM = fr.c \<circ>\<^sub>\<rightarrow> h\<close>
      by (simp add: h_def fr.c_def morph_comp_def comp_def)

   interpret frontside: pullback_diagram "interf r" D' "interf r" G \<open>fr.c \<circ>\<^sub>\<rightarrow> h\<close> idM m \<open>c \<circ>\<^sub>\<rightarrow> d\<close>
    proof intro_locales
      show \<open>morphism_axioms (interf r) D' (fr.c \<circ>\<^sub>\<rightarrow> h)\<close>
        using \<open>d' \<circ>\<^sub>\<rightarrow> idM = fr.c \<circ>\<^sub>\<rightarrow> h\<close> backside.b.morphism_axioms morphism.axioms(3) by auto
    next
      show \<open>morphism_axioms (interf r) G (c \<circ>\<^sub>\<rightarrow> d)\<close>
        using po1.c.morphism_axioms po1.g.morphism_axioms morphism_def wf_morph_comp by blast
    next
      show \<open>pullback_diagram_axioms (interf r) D' (interf r) (fr.c \<circ>\<^sub>\<rightarrow> h) idM m (c \<circ>\<^sub>\<rightarrow> d)\<close>
      proof
        show \<open>\<^bsub>m \<circ>\<^sub>\<rightarrow> (fr.c \<circ>\<^sub>\<rightarrow> h)\<^esub>\<^sub>V v = \<^bsub>c \<circ>\<^sub>\<rightarrow> d \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
          using that backside.node_commutativity po1.node_commutativity
          by (simp add: morph_assoc_nodes fr.c_def morph_comp_def h_def)
      next
        show \<open>\<^bsub>m \<circ>\<^sub>\<rightarrow> (fr.c \<circ>\<^sub>\<rightarrow> h)\<^esub>\<^sub>E e = \<^bsub>c \<circ>\<^sub>\<rightarrow> d \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
          using that backside.edge_commutativity po1.edge_commutativity
          by (simp add: morph_assoc_nodes fr.c_def morph_comp_def h_def)
      next
        show \<open>Ex1M
        (\<lambda>x. morphism A' (interf r) x \<and>
             (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> h \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v) \<and>
             (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> h \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e) \<and>
             (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v) \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e))
        A'\<close>
          if \<open>graph A'\<close> \<open>morphism A' (interf r) c'\<close> \<open>morphism A' D' b'\<close>
             \<open>\<And>v. v \<in> V\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>m \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>c \<circ>\<^sub>\<rightarrow> d \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v\<close>
             \<open>\<And>e. e \<in> E\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>m \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>c \<circ>\<^sub>\<rightarrow> d \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e\<close> for A' :: "('g,'h) ngraph" and c' b'
        proof -
          interpret c': morphism A' "interf r" c'
            using \<open>morphism A' (interf r) c'\<close> by assumption

          have \<open>\<^bsub>m \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>g \<circ>\<^sub>\<rightarrow> b \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>A'\<^esub>\<close> for v
            using that \<open>\<And>v. v \<in> V\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>m \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>c \<circ>\<^sub>\<rightarrow> d \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v\<close> backside.node_commutativity
              c'.morph_node_range h.morph_node_range
            by (simp add: morph_comp_def h_def fr.A_def)

          moreover have \<open>\<^bsub>m \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>g \<circ>\<^sub>\<rightarrow> b \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>A'\<^esub>\<close> for e
            using that \<open>\<And>e. e \<in> E\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>m \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>c \<circ>\<^sub>\<rightarrow> d \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e\<close> backside.edge_commutativity
              c'.morph_edge_range h.morph_edge_range
            by (simp add: morph_comp_def h_def fr.A_def)

          ultimately show ?thesis
          using backside.universal_property[OF \<open>graph A'\<close> \<open>morphism A' (interf r) c'\<close> \<open>morphism A' D' b'\<close> ] *
          by auto
      qed
    qed
  qed

   interpret back_right: pullback_diagram "interf r" fr.A "interf r" D h idM fr.b d
    proof -
    have \<open>\<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>V v = \<^bsub>d \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
      using that
      by (simp add: fr.b_def h_def morph_comp_def)
    moreover have \<open>\<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>E e = \<^bsub>d \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
      using that
      by (simp add: fr.b_def h_def morph_comp_def)

    ultimately show \<open>pullback_diagram (interf r) fr.A (interf r) D h idM fr.b d\<close>
        using pullback_decomposition[OF h.morphism_axioms po1.c.morphism_axioms fr.pb.flip_diagram frontside.pullback_diagram_axioms]
        by simp
    qed

    (* top face *)
    interpret top: pushout_diagram "interf r" "interf r" fr.A D' idM h d' fr.c
    proof -
(*
      interpret bottom: pullback_diagram "interf r" "lhs r" D G b d g c
        using po1.pushout_pullback_inj_b[OF r.k.injective_morphism_axioms d.injective_morphism_axioms]
        by assumption
 *)
      interpret bls: pullback_diagram "interf r" D "interf r" G \<open>d \<circ>\<^sub>\<rightarrow> idM\<close> idM c \<open>g \<circ>\<^sub>\<rightarrow> b\<close>
        using pullback_composition[OF bt.pullback_diagram_axioms  pb1.flip_diagram]
        by assumption

(* righthand commutative square *)
      have a: \<open>\<^bsub>d \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>V v = \<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
        by (simp add: fr.b_def h_def morph_comp_def)
      have b: \<open>\<^bsub>d \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>E e = \<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
        by (simp add: fr.b_def h_def morph_comp_def)

    interpret brs: pullback_diagram "interf r" D "interf r" G \<open>fr.b \<circ>\<^sub>\<rightarrow> h\<close> idM c \<open>m \<circ>\<^sub>\<rightarrow> d'\<close>
      proof intro_locales
        show \<open>morphism_axioms (interf r) D (fr.b \<circ>\<^sub>\<rightarrow> h)\<close>
          using fr.b.morphism_axioms h.morphism_axioms morphism_def wf_morph_comp by blast
      next
        show \<open>morphism_axioms (interf r) G (m \<circ>\<^sub>\<rightarrow> d')\<close>
          using  morphism.axioms(3)[OF wf_morph_comp[OF dd2.po1.c.morphism_axioms dd2.po1.g.morphism_axioms]]
          by assumption
      next
        show \<open>pullback_diagram_axioms (interf r) D (interf r) (fr.b \<circ>\<^sub>\<rightarrow> h) idM c (m \<circ>\<^sub>\<rightarrow> d')\<close>
        proof
          show \<open>\<^bsub>c \<circ>\<^sub>\<rightarrow> (fr.b \<circ>\<^sub>\<rightarrow> h)\<^esub>\<^sub>V v = \<^bsub>m \<circ>\<^sub>\<rightarrow> d' \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
            using that dd2.po1.node_commutativity bls.node_commutativity
            by (simp add: morph_comp_def morph_assoc_nodes fr.b_def h_def)
        next
          show \<open>\<^bsub>c \<circ>\<^sub>\<rightarrow> (fr.b \<circ>\<^sub>\<rightarrow> h)\<^esub>\<^sub>E e = \<^bsub>m \<circ>\<^sub>\<rightarrow> d' \<circ>\<^sub>\<rightarrow> idM\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
            using that dd2.po1.edge_commutativity bls.edge_commutativity
            by (simp add: morph_comp_def morph_assoc_nodes fr.b_def h_def)
        next
          show \<open>Ex1M (\<lambda>x. morphism A' (interf r) x
                  \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v)
                  \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e)
                  \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>c'a\<^esub>\<^sub>V v)
                  \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>c'a\<^esub>\<^sub>E e)) A'\<close>
            if \<open>graph A'\<close> \<open>morphism A' (interf r) c'a\<close> \<open>morphism A' D b'\<close>
               \<open>\<And>v. v \<in> V\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>c \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>m \<circ>\<^sub>\<rightarrow> d' \<circ>\<^sub>\<rightarrow> c'a\<^esub>\<^sub>V v\<close>
               \<open>\<And>e. e \<in> E\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>c \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>m \<circ>\<^sub>\<rightarrow> d' \<circ>\<^sub>\<rightarrow> c'a\<^esub>\<^sub>E e\<close>
            for A' :: "('g,'h) ngraph" and c'a b'
          proof -
            interpret c'a: morphism A' "interf r" c'a
              using \<open>morphism A' (interf r) c'a\<close> by assumption

            interpret b': morphism A' D b'
              using \<open>morphism A' D b'\<close> by assumption

            have a: \<open>\<^bsub>c \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>g \<circ>\<^sub>\<rightarrow> b \<circ>\<^sub>\<rightarrow> c'a\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>A'\<^esub>\<close> for v
              using that \<open>\<And>v. v \<in> V\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>c \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>m \<circ>\<^sub>\<rightarrow> d' \<circ>\<^sub>\<rightarrow> c'a\<^esub>\<^sub>V v\<close> dd2.po1.node_commutativity
              by (simp add: morph_comp_def c'a.morph_node_range)

            have b: \<open>\<^bsub>c \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>g \<circ>\<^sub>\<rightarrow> b \<circ>\<^sub>\<rightarrow> c'a\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>A'\<^esub>\<close> for e
              using that  \<open>\<And>ea. ea \<in> E\<^bsub>A'\<^esub> \<Longrightarrow> \<^bsub>c \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E ea = \<^bsub>m \<circ>\<^sub>\<rightarrow> d' \<circ>\<^sub>\<rightarrow> c'a\<^esub>\<^sub>E ea\<close> dd2.po1.edge_commutativity
              by (simp add: morph_comp_def c'a.morph_edge_range)

            have s: \<open>(\<lambda>x. morphism A' (interf r) x \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>d \<circ>\<^sub>\<rightarrow> idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v)
                    \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>d \<circ>\<^sub>\<rightarrow> idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e) \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>c'a\<^esub>\<^sub>V v) \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>c'a\<^esub>\<^sub>E e)) = (\<lambda>x. morphism A' (interf r) x \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>b'\<^esub>\<^sub>V v) \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>fr.b \<circ>\<^sub>\<rightarrow> h \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>b'\<^esub>\<^sub>E e) \<and> (\<forall>v\<in>V\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>V v = \<^bsub>c'a\<^esub>\<^sub>V v) \<and> (\<forall>e\<in>E\<^bsub>A'\<^esub>. \<^bsub>idM \<circ>\<^sub>\<rightarrow> x\<^esub>\<^sub>E e = \<^bsub>c'a\<^esub>\<^sub>E e))\<close>
              by (simp add: morph_comp_def fr.b_def h_def)

            show  ?thesis
              using ex1m_eq_surrogate[OF s bls.universal_property[OF \<open>graph A'\<close> \<open>morphism A' (interf r) c'a\<close> \<open>morphism A' D b'\<close> a b]]
              by simp
          qed
        qed
      qed

      interpret top_pb: pullback_diagram "interf r" "interf r" fr.A D' idM h d' fr.c
        using pullback_decomposition[OF _ _ fr.pb.pullback_diagram_axioms brs.pullback_diagram_axioms]
        using "*" h.morphism_axioms dd2.po1.c.morphism_axioms pullback_diagram.flip_diagram by force

      interpret h: injective_morphism "interf r" fr.A h
      proof
        show \<open>inj_on \<^bsub>h\<^esub>\<^sub>V V\<^bsub>interf r\<^esub>\<close>
          using d_inj.inj_nodes
          by (simp add: h_def inj_on_def)
      next
        show \<open>inj_on \<^bsub>h\<^esub>\<^sub>E E\<^bsub>interf r\<^esub>\<close>
          using d_inj.inj_edges
          by (simp add: h_def inj_on_def)
      qed

      have a:\<open>(\<exists>v\<in>V\<^bsub>interf r\<^esub>. \<^bsub>d'\<^esub>\<^sub>V v = x) \<or> (\<exists>v\<in>V\<^bsub>fr.A\<^esub>. \<^bsub>fr.c\<^esub>\<^sub>V v = x)\<close> if \<open>x \<in> V\<^bsub>D'\<^esub>\<close> for x
        using that
        apply (simp add: fr.A_def fr.c_def)
        using r.k.injective_morphism_axioms dd2.d_inj.injective_morphism_axioms po1.joint_surjectivity_nodes dd2.po1.g.morph_node_range dd2.po1.reduced_chain_condition_nodes by blast

      have b: \<open>(\<exists>e\<in>E\<^bsub>interf r\<^esub>. \<^bsub>d'\<^esub>\<^sub>E e = x) \<or> (\<exists>e\<in>E\<^bsub>fr.A\<^esub>. \<^bsub>fr.c\<^esub>\<^sub>E e = x)\<close> if \<open>x \<in> E\<^bsub>D'\<^esub>\<close> for x
        using that
        apply (simp add: fr.A_def fr.c_def)
        using r.k.injective_morphism_axioms dd2.d_inj.injective_morphism_axioms dd2.po1.g.morph_edge_range po1.joint_surjectivity_edges morphism.morph_edge_range dd2.po1.reduced_chain_condition_edges
        by blast

      interpret k_inj: injective_morphism fr.A D' fr.c
        using pullback_diagram.g_inj_imp_b_inj[OF fr.pb.flip_diagram po1.b_inj_imp_g_inj[OF r.k.injective_morphism_axioms]]
        by assumption

      have a': \<open>(\<exists>v\<in>V\<^bsub>fr.A\<^esub>. \<^bsub>fr.c\<^esub>\<^sub>V v = x) \<or> (\<exists>v\<in>V\<^bsub>interf r\<^esub>. \<^bsub>d'\<^esub>\<^sub>V v = x)\<close> if \<open>x \<in> V\<^bsub>D'\<^esub>\<close> for x
        using that a by auto
      have b': \<open>(\<exists>e\<in>E\<^bsub>fr.A\<^esub>. \<^bsub>fr.c\<^esub>\<^sub>E e = x) \<or> (\<exists>e\<in>E\<^bsub>interf r\<^esub>. \<^bsub>d'\<^esub>\<^sub>E e = x)\<close> if \<open>x \<in> E\<^bsub>D'\<^esub>\<close> for x
        using that b by auto

      show \<open>pushout_diagram (interf r) (interf r) fr.A D' idM h d' fr.c\<close>
        using po_characterization[of "interf r" "interf r" idM fr.A h D' d' fr.c]
        using a' b' r.k.G.idm.injective_morphism_axioms dd2.d_inj.injective_morphism_axioms
          h.injective_morphism_axioms k_inj.injective_morphism_axioms
          top_pb.edge_commutativity top_pb.node_commutativity top_pb.reduced_chain_condition_edges
          top_pb.reduced_chain_condition_nodes
        by fastforce
    qed

    interpret k_bij: bijective_morphism fr.A D' fr.c
      using top.b_bij_imp_g_bij[OF r.k.G.idm.bijective_morphism_axioms]
      by assumption

    obtain kinv where kinv: \<open>bijective_morphism D' fr.A kinv\<close>
      and \<open>\<And>v. v \<in> V\<^bsub>fr.A\<^esub> \<Longrightarrow> \<^bsub>kinv \<circ>\<^sub>\<rightarrow> fr.c\<^esub>\<^sub>V v = v\<close> \<open>\<And>e. e \<in> E\<^bsub>fr.A\<^esub> \<Longrightarrow> \<^bsub>kinv \<circ>\<^sub>\<rightarrow> fr.c\<^esub>\<^sub>E e = e\<close>
      and \<open>\<And>v. v \<in> V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> kinv\<^esub>\<^sub>V v = v\<close> \<open>\<And>e. e \<in> E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> kinv\<^esub>\<^sub>E e = e\<close>
      by (metis k_bij.ex_inv)

    interpret kinv: bijective_morphism D' fr.A kinv
      using kinv by assumption

    (* here starts l *)
    interpret h: injective_morphism fr.A D fr.b
      using fr.pb.g_inj_imp_b_inj[OF dd2.po1.b_inj_imp_g_inj[OF r.k.injective_morphism_axioms]]
      by assumption

    interpret br: pushout_diagram "interf r" fr.A "interf r" D h idM fr.b d
    proof -
      have a: \<open>(\<exists>a1\<in>V\<^bsub>interf r\<^esub>. \<^bsub>h\<^esub>\<^sub>V a1 = x) \<and> (\<exists>a2\<in>V\<^bsub>interf r\<^esub>. \<^bsub>idM\<^esub>\<^sub>V a2 = y)\<close>
        if \<open>x \<in> V\<^bsub>fr.A\<^esub>\<close> \<open> y \<in> V\<^bsub>interf r\<^esub>\<close> \<open>\<^bsub>fr.b\<^esub>\<^sub>V x = \<^bsub>d\<^esub>\<^sub>V y \<close> for x y
        using back_right.reduced_chain_condition_nodes[OF that] by simp

      have b: \<open>(\<exists>a1\<in>E\<^bsub>interf r\<^esub>. \<^bsub>h\<^esub>\<^sub>E a1 = x) \<and> (\<exists>a2\<in>E\<^bsub>interf r\<^esub>. \<^bsub>idM\<^esub>\<^sub>E a2 = y)\<close>
        if \<open>x \<in> E\<^bsub>fr.A\<^esub>\<close> \<open> y \<in> E\<^bsub>interf r\<^esub>\<close> \<open> \<^bsub>fr.b\<^esub>\<^sub>E x = \<^bsub>d\<^esub>\<^sub>E y \<close> for x y
        using back_right.reduced_chain_condition_edges[OF that] by simp

      have cc: \<open>(\<exists>v\<in>V\<^bsub>interf r\<^esub>. \<^bsub>d\<^esub>\<^sub>V v = x) \<or> (\<exists>v\<in>V\<^bsub>fr.A\<^esub>. \<^bsub>fr.b\<^esub>\<^sub>V v = x)\<close> if \<open>x \<in> V\<^bsub>D\<^esub> \<close> for x
        using that
        using  r.k.injective_morphism_axioms fr.reduced_chain_condition_nodes
          po1.g.morph_node_range dd2.po1.joint_surjectivity_nodes
          po1.reduced_chain_condition_nodes
        by (metis d_inj.injective_morphism_axioms)

      have dd: \<open>(\<exists>e\<in>E\<^bsub>interf r\<^esub>. \<^bsub>d\<^esub>\<^sub>E e = x) \<or> (\<exists>e\<in>E\<^bsub>fr.A\<^esub>. \<^bsub>fr.b\<^esub>\<^sub>E e = x)\<close> if \<open>x \<in> E\<^bsub>D\<^esub> \<close> for x
        using that
        by (metis r.k.injective_morphism_axioms d_inj.injective_morphism_axioms
            fr.reduced_chain_condition_edges po1.g.morph_edge_range
            dd2.po1.joint_surjectivity_edges po1.reduced_chain_condition_edges)

      show \<open>pushout_diagram (interf r) fr.A (interf r) D h idM fr.b d\<close>
        using po_characterization[
            OF back_right.g_inj_imp_b_inj[OF d_inj.injective_morphism_axioms] r.k.G.idm.injective_morphism_axioms h.injective_morphism_axioms
            d_inj.injective_morphism_axioms back_right.node_commutativity back_right.edge_commutativity a b cc dd]
        by blast
    qed

    interpret l_bij: bijective_morphism fr.A D fr.b
    proof -
      interpret pushout_diagram "interf r" "interf r" fr.A D idM h d fr.b
        using br.flip_diagram by assumption

      show \<open>bijective_morphism fr.A D fr.b\<close>
        using b_bij_imp_g_bij[OF r.k.G.idm.bijective_morphism_axioms]
        by assumption
    qed

    obtain linv where linv:\<open>bijective_morphism D fr.A linv\<close>
      and \<open>\<And>v. v \<in> V\<^bsub>D\<^esub>\<Longrightarrow> \<^bsub>fr.b \<circ>\<^sub>\<rightarrow>linv\<^esub>\<^sub>V v = v\<close>  \<open>\<And>e. e \<in> E\<^bsub>D\<^esub>\<Longrightarrow> \<^bsub>fr.b \<circ>\<^sub>\<rightarrow>linv\<^esub>\<^sub>E e = e\<close>
      and \<open>\<And>v. v \<in> V\<^bsub>fr.A\<^esub>\<Longrightarrow> \<^bsub>linv \<circ>\<^sub>\<rightarrow> fr.b \<^esub>\<^sub>V v = v\<close> \<open>\<And>e. e \<in> E\<^bsub>fr.A\<^esub>\<Longrightarrow> \<^bsub>linv \<circ>\<^sub>\<rightarrow> fr.b \<^esub>\<^sub>E e= e\<close>
      by (metis l_bij.ex_inv)

    interpret linv: bijective_morphism D fr.A linv
      using linv by assumption

    define u where \<open>u \<equiv> fr.c \<circ>\<^sub>\<rightarrow> linv\<close>
    interpret u: bijective_morphism D D' u
      using bij_comp_bij_is_bij[OF linv k_bij.bijective_morphism_axioms]
      by (simp add: u_def)

    obtain uinv where uinv:\<open>bijective_morphism D' D uinv\<close>
      and \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = v\<close> \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = e\<close>
      \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v = v\<close> \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e = e\<close>
      using u.ex_inv
      by metis

    interpret uinv: bijective_morphism D' D uinv
      using uinv by assumption

(* here starts bijection of H *)
(* triangle (1) *)
    have aa: \<open>\<^bsub>u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>V v = \<^bsub>d'\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
    proof -
      have \<open>\<^bsub>u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>V v = \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> linv \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>V v\<close>
        by (simp add: u_def)
      also have \<open>\<dots> = \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> linv \<circ>\<^sub>\<rightarrow> fr.b  \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>V v\<close>
        by (simp add: morph_comp_def fr.c_def fr.b_def h_def)
      also have \<open>\<dots> = \<^bsub>fr.c  \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>V v\<close>
        using  \<open>\<And>v. v\<in> V\<^bsub>fr.A\<^esub>\<Longrightarrow> \<^bsub>linv \<circ>\<^sub>\<rightarrow> fr.b \<^esub>\<^sub>V v = v \<close> h.morph_node_range that
        by (simp add: morph_comp_def  h_def)
      also have \<open>\<dots> = \<^bsub>d'\<^esub>\<^sub>V v\<close>
        using "*"[symmetric] morph_comp_id(1)
        by simp
      finally show ?thesis .
    qed

    have bb:\<open>\<^bsub>u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>E e = \<^bsub>d'\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
    proof -
      have \<open>\<^bsub>u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>E e = \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> linv \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>E e\<close>
        by (simp add: u_def)
      also have \<open>\<dots> = \<^bsub>fr.c \<circ>\<^sub>\<rightarrow> linv \<circ>\<^sub>\<rightarrow> fr.b  \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>E e\<close>
        by (simp add: morph_comp_def fr.c_def fr.b_def h_def)
      also have \<open>\<dots> = \<^bsub>fr.c  \<circ>\<^sub>\<rightarrow> h\<^esub>\<^sub>E e\<close>
        using  \<open>\<And>e. e \<in> E\<^bsub>fr.A\<^esub>\<Longrightarrow> \<^bsub>linv \<circ>\<^sub>\<rightarrow> fr.b \<^esub>\<^sub>E e = e \<close> h.morph_edge_range that
        by (simp add: morph_comp_def  h_def)
      also have \<open>\<dots> = \<^bsub>d'\<^esub>\<^sub>E e\<close>
        using "*"[symmetric] morph_comp_id(1)
        by simp
      finally show ?thesis .
    qed

(* triangle (2) *)

    have cc:\<open>\<^bsub>uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>V v = \<^bsub>d\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>interf r\<^esub>\<close> for v
    proof -
      have \<open>\<^bsub>uinv \<circ>\<^sub>\<rightarrow> u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>V v = \<^bsub>uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>V v\<close>
        using aa that
        by (simp add: morph_comp_def)
      then have \<open>\<^bsub>d\<^esub>\<^sub>V v = \<^bsub>uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>V v\<close>
       using that \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = v\<close> po1.c.morph_node_range
       by (simp add: morph_comp_def)

     thus ?thesis
       by simp
   qed

    have dd:\<open>\<^bsub>uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>E e = \<^bsub>d\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>interf r\<^esub>\<close> for e
    proof -
      have \<open>\<^bsub>uinv \<circ>\<^sub>\<rightarrow> u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>E e = \<^bsub>uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>E e\<close>
        using bb that
        by (simp add: morph_comp_def)
      then have \<open>\<^bsub>d\<^esub>\<^sub>E e = \<^bsub>uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>E e\<close>
       using that \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = e\<close> po1.c.morph_edge_range
       by (simp add: morph_comp_def)

     thus ?thesis
       by simp
    qed

(* u' *)

    interpret m'u: morphism D H' "m' \<circ>\<^sub>\<rightarrow> u"
      using wf_morph_comp[OF u.morphism_axioms dd2.po2.g.morphism_axioms]
      by assumption

    have "**a": \<open>\<forall>v\<in>V\<^bsub>interf r\<^esub>. \<^bsub>f' \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>V v\<close>
                \<open>\<forall>e\<in>E\<^bsub>interf r\<^esub>. \<^bsub>f' \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u \<circ>\<^sub>\<rightarrow> d\<^esub>\<^sub>E e\<close>
      using aa bb dd2.po2.node_commutativity dd2.po2.edge_commutativity
      by (simp_all add: morph_comp_def)

    obtain u' where u': \<open>morphism H H' u'\<close>
      and \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>V v = \<^bsub>f'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>E e = \<^bsub>f'\<^esub>\<^sub>E e\<close>
      and \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e\<close>
        using po2.universal_property_exist_gen[OF dd2.po2.f.H.graph_axioms dd2.po2.f.morphism_axioms
            m'u.morphism_axioms "**a"]
        by fast
      interpret u': morphism H H' u'
        using u' by assumption

      interpret muinv: morphism D' H "c' \<circ>\<^sub>\<rightarrow> uinv"
        using wf_morph_comp[OF uinv.morphism_axioms po2.g.morphism_axioms]
        by assumption

      have "**b": \<open>\<forall>v\<in>V\<^bsub>interf r\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>V v = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>V v\<close>
           \<open>\<forall>e\<in>E\<^bsub>interf r\<^esub>. \<^bsub>f \<circ>\<^sub>\<rightarrow> b'\<^esub>\<^sub>E e = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv \<circ>\<^sub>\<rightarrow> d'\<^esub>\<^sub>E e\<close>
        using cc dd po2.node_commutativity po2.edge_commutativity
        by (simp_all add: morph_comp_def)

      obtain u'' where u'': \<open>morphism H' H u''\<close>
        and \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>V v = \<^bsub>f\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>E e = \<^bsub>f\<^esub>\<^sub>E e\<close>
        and \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>V v = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>E e = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e\<close>
        using dd2.po2.universal_property_exist_gen[OF po2.f.H.graph_axioms po2.f.morphism_axioms
              muinv.morphism_axioms "**b"]
        by fast
      interpret u'': morphism H' H u''
        using u'' by assumption

      have u'u'': \<open>(\<forall>v\<in>V\<^bsub>H'\<^esub>. \<^bsub>u' \<circ>\<^sub>\<rightarrow> u''\<^esub>\<^sub>V v = v) \<and> (\<forall>e\<in>E\<^bsub>H'\<^esub>. \<^bsub>u' \<circ>\<^sub>\<rightarrow> u''\<^esub>\<^sub>E e = e)\<close>
      proof -
        obtain x where x: \<open>morphism H' H' x\<close>
         \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>V v = \<^bsub>f'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>E e = \<^bsub>f'\<^esub>\<^sub>E e\<close>
         \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>V v = \<^bsub>m'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>E e = \<^bsub>m'\<^esub>\<^sub>E e\<close>
          using dd2.po2.universal_property_exist_gen[OF dd2.po2.f.H.graph_axioms dd2.po2.f.morphism_axioms
            dd2.po2.g.morphism_axioms ] dd2.po2.node_commutativity dd2.po2.edge_commutativity
          by fast

        have a'v: \<open>\<^bsub>f'\<^esub>\<^sub>V v = \<^bsub>u' \<circ>\<^sub>\<rightarrow> u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>rhs r\<^esub>\<close> for v
          using \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>V v = \<^bsub>f\<^esub>\<^sub>V v\<close> \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>V v = \<^bsub>f'\<^esub>\<^sub>V v\<close> that
          by (simp add: morph_comp_def)
        have a'e: \<open>\<^bsub>f'\<^esub>\<^sub>E e = \<^bsub>u' \<circ>\<^sub>\<rightarrow> u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>rhs r\<^esub>\<close> for e
          using \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>E e = \<^bsub>f\<^esub>\<^sub>E e\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>E e = \<^bsub>f'\<^esub>\<^sub>E e\<close> that
          by (simp add: morph_comp_def)

        have b'v: \<open>\<^bsub>m'\<^esub>\<^sub>V v = \<^bsub>u' \<circ>\<^sub>\<rightarrow> u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>D'\<^esub>\<close> for v
        proof -
          have \<open>\<^bsub>u' \<circ>\<^sub>\<rightarrow> c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>D'\<^esub>\<close>
            using \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v\<close>  that
              \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v = v\<close> uinv.morph_node_range
            by (simp add:  morph_comp_def)

          then have \<open>\<^bsub>u' \<circ>\<^sub>\<rightarrow> c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v = \<^bsub>m'\<^esub>\<^sub>V v\<close>
            using \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v = v\<close> that
            by(simp add:  morph_comp_def)
          thus ?thesis
            using \<open>\<And>v. v \<in> V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>V v = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v\<close> that
            by (simp add: morph_comp_def)
        qed

        have b'e: \<open>\<^bsub>m'\<^esub>\<^sub>E e = \<^bsub>u' \<circ>\<^sub>\<rightarrow> u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>D'\<^esub>\<close> for e
        proof -
          have \<open>\<^bsub>u' \<circ>\<^sub>\<rightarrow> c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>D'\<^esub>\<close>
            using \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e\<close>  that
              \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e = e\<close> uinv.morph_edge_range
            by (simp add:  morph_comp_def)

          then have \<open>\<^bsub>u' \<circ>\<^sub>\<rightarrow> c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e = \<^bsub>m'\<^esub>\<^sub>E e\<close>
            using \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e = e\<close> that
            by(simp add:  morph_comp_def)
          thus ?thesis
            using \<open>\<And>e. e \<in> E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>E e = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e\<close> that
            by (simp add: morph_comp_def)
        qed

        show ?thesis
          using a'v a'e b'v b'e
            \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>V v = \<^bsub>f'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>E e = \<^bsub>f'\<^esub>\<^sub>E e\<close>
            \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>V v = \<^bsub>m'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>E e = \<^bsub>m'\<^esub>\<^sub>E e\<close>
            dd2.po2.joint_surjectivity_nodes dd2.po2.joint_surjectivity_edges
          by (force  simp add: morph_comp_def)
      qed

      have u''u': \<open>(\<forall>v\<in>V\<^bsub>H\<^esub>. \<^bsub>u'' \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>V v = v) \<and> (\<forall>e\<in>E\<^bsub>H\<^esub>. \<^bsub>u'' \<circ>\<^sub>\<rightarrow> u'\<^esub>\<^sub>E e = e)\<close>
      proof -
        obtain x where x: \<open>morphism H H x\<close>
         \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>V v = \<^bsub>f\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>E e = \<^bsub>f\<^esub>\<^sub>E e\<close>
         \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
          using po2.universal_property_exist_gen[OF po2.f.H.graph_axioms po2.f.morphism_axioms
            po2.g.morphism_axioms ] po2.node_commutativity po2.edge_commutativity
          by fast

        have a'v: \<open>\<^bsub>f\<^esub>\<^sub>V v = \<^bsub>u'' \<circ>\<^sub>\<rightarrow> u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>rhs r\<^esub>\<close> for v
          using \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>V v = \<^bsub>f\<^esub>\<^sub>V v\<close> \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>V v = \<^bsub>f'\<^esub>\<^sub>V v\<close> that
          by (simp add: morph_comp_def)
        have a'e: \<open>\<^bsub>f\<^esub>\<^sub>E e = \<^bsub>u'' \<circ>\<^sub>\<rightarrow> u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>rhs r\<^esub>\<close> for e
          using \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> f'\<^esub>\<^sub>E e = \<^bsub>f\<^esub>\<^sub>E e\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>E e = \<^bsub>f'\<^esub>\<^sub>E e\<close> that
          by (simp add: morph_comp_def)

        have b'v: \<open>\<^bsub>c'\<^esub>\<^sub>V v = \<^bsub>u'' \<circ>\<^sub>\<rightarrow> u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v\<close> if \<open>v \<in> V\<^bsub>D\<^esub>\<close> for v
        proof -
          have \<open>\<^bsub>u'' \<circ>\<^sub>\<rightarrow> m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v\<close>
            using that \<open>\<And>v. v\<in>V\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>V v = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>V v\<close> u.morph_node_range
            by (simp add: morph_comp_def)
          then have \<open>\<^bsub>u'' \<circ>\<^sub>\<rightarrow> m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>
            using that  \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v = v\<close>
            by (simp add: morph_comp_def)
          thus ?thesis
            using \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>V v\<close> that
            by (simp add: morph_comp_def)
        qed
        have b'e: \<open>\<^bsub>c'\<^esub>\<^sub>E e = \<^bsub>u'' \<circ>\<^sub>\<rightarrow> u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
        proof -
          have \<open>\<^bsub>u'' \<circ>\<^sub>\<rightarrow> m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e\<close>
            using that \<open>\<And>e. e\<in>E\<^bsub>D'\<^esub> \<Longrightarrow> \<^bsub>u'' \<circ>\<^sub>\<rightarrow> m'\<^esub>\<^sub>E e = \<^bsub>c' \<circ>\<^sub>\<rightarrow> uinv\<^esub>\<^sub>E e\<close> u.morph_edge_range
            by (simp add: morph_comp_def)
          then have \<open>\<^bsub>u'' \<circ>\<^sub>\<rightarrow> m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
            using that  \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>uinv \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e = e\<close>
            by (simp add: morph_comp_def)
          thus ?thesis
            using \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>u' \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e = \<^bsub>m' \<circ>\<^sub>\<rightarrow> u\<^esub>\<^sub>E e\<close> that
            by (simp add: morph_comp_def)
        qed

        show ?thesis
          using a'v a'e b'v b'e
            \<open>\<And>v. v\<in>V\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>V v = \<^bsub>f\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>rhs r\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> f\<^esub>\<^sub>E e = \<^bsub>f\<^esub>\<^sub>E e\<close>
            \<open>\<And>v. v\<in>V\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close> \<open>\<And>e. e\<in>E\<^bsub>D\<^esub> \<Longrightarrow> \<^bsub>x \<circ>\<^sub>\<rightarrow> c'\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
            po2.joint_surjectivity_nodes po2.joint_surjectivity_edges
          by (force simp add: morph_comp_def)
      qed

      interpret bij_u': bijective_morphism H H' u'
        using comp_id_bij[OF u' u''] u''u' u'u''
        by blast

      show ?thesis
        using bij_u'.bijective_morphism_axioms u.bijective_morphism_axioms
        by blast
qed
end

corollary (in pushout_diagram) uniqueness_pc:
  assumes po2: \<open>pushout_diagram A B C' D b c' f g'\<close>
  and       b': \<open>injective_morphism A B b\<close>
  and       f': \<open>injective_morphism B D f\<close>
shows \<open>\<exists>u. bijective_morphism C C' u\<close>
proof -
  interpret po2: pushout_diagram A B C' D b c' f g'
    using po2 by assumption
  interpret b': injective_morphism A B b
    using b' by assumption

  interpret f': injective_morphism B D f
    using f' by assumption

  define r where \<open>r \<equiv> \<lparr>lhs = B, interf = A, rhs = A\<rparr>\<close>
  interpret b': injective_morphism "interf r" "lhs r" b
    by (simp add: r_def b')

  interpret A: graph A
    using c.morphism_axioms morphism.axioms(1) by blast

  interpret injective_morphism "interf r" "rhs r" idM
    by (standard)
       (simp_all add: r_def b.G.graph_axioms b.G.idm.injective_morphism_axioms
                      b.G.finite_nodes b.G.finite_edges
                      b.G.source_integrity b.G.target_integrity)

  interpret rule r b idM ..

  interpret injective_morphism "lhs r" D f
    by(simp add: r_def f')
  interpret morphism "interf r" C c
    by (simp add: r_def c.morphism_axioms)
  interpret pushout_diagram "interf r" "lhs r" C D b c f g
    by (simp add: r_def pushout_diagram_axioms)
  interpret morphism "rhs r" C c
    by (simp add: r_def c.morphism_axioms)

  interpret dd1: direct_derivation r b idM D f C c g C c idM
    by standard (auto simp add: morph_comp_def to_ngraph_def to_nmorph_def r_def)

  interpret morphism "interf r" C' c'
    by (simp add: r_def po2.c.morphism_axioms)
  interpret pushout_diagram "interf r" "lhs r" C' D b c' f g'
    by (simp add: r_def po2.pushout_diagram_axioms)
  interpret morphism "rhs r" C' c'
    by (simp add: r_def po2.c.morphism_axioms)

  interpret dd2: direct_derivation r b idM D f C' c' g' C' c' idM
    by standard (auto simp add: morph_comp_def to_ngraph_def to_nmorph_def r_def)

  show ?thesis
    using dd1.uniqueness_direct_derivation[OF dd2.direct_derivation_axioms]
    by simp
qed

locale direct_derivation_construction =
  r: rule r b b' +
  d: deletion "interf r" G "lhs r" g b +
  g: gluing "interf r" d.D "rhs r" d.d b' for G r b b' g H +
assumes a: \<open>H = g.H\<close>
begin

corollary
    \<open>pushout_diagram (interf r) (lhs r) d.D G b d.d g d.c'\<close> and \<open>pushout_diagram (interf r) (rhs r) d.D g.H b' d.d g.h g.c\<close>
  using
    d.po.pushout_diagram_axioms
    g.po.pushout_diagram_axioms
  by simp_all

sublocale direct_derivation:
  direct_derivation r b b' G g d.D d.d d.c' g.H g.h g.c ..

end

end


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

subsection \<open>Streams as an applicative functor\<close>

theory Applicative_Stream imports
  Applicative
  "HOL-Library.Stream"
  "HOL-Library.Adhoc_Overloading"
begin

primcorec (transfer) ap_stream :: "('a \<Rightarrow> 'b) stream \<Rightarrow> 'a stream \<Rightarrow> 'b stream"
where
    "shd (ap_stream f x) = shd f (shd x)"
  | "stl (ap_stream f x) = ap_stream (stl f) (stl x)"

adhoc_overloading Applicative.pure sconst
adhoc_overloading Applicative.ap ap_stream

context includes lifting_syntax applicative_syntax
begin

lemma ap_stream_id: "pure (\<lambda>x. x) \<diamondop> x = x"
by (coinduction arbitrary: x) simp

lemma ap_stream_homo: "pure f \<diamondop> pure x = pure (f x)"
by coinduction simp

lemma ap_stream_interchange: "f \<diamondop> pure x = pure (\<lambda>f. f x) \<diamondop> f"
by (coinduction arbitrary: f) auto

lemma ap_stream_composition: "pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
by (coinduction arbitrary: g f x) auto

applicative stream (S, K)
for
  pure: sconst
  ap: ap_stream
  rel: stream_all2
  set: sset
proof -
  fix g :: "('b \<Rightarrow> 'a \<Rightarrow> 'c) stream" and f x
  show "pure (\<lambda>g f x. g x (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> x \<diamondop> (f \<diamondop> x)"
    by (coinduction arbitrary: g f x) auto
next
  fix x :: "'b stream" and y :: "'a stream"
  show "pure (\<lambda>x y. x) \<diamondop> x \<diamondop> y = x"
    by (coinduction arbitrary: x y) auto
next
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  show "(R ===> stream_all2 R) pure pure"
  proof
    fix x y
    assume "R x y"
    then show "stream_all2 R (pure x) (pure y)"
      by coinduction simp
  qed
next
  fix R and f :: "('a \<Rightarrow> 'b) stream" and g :: "('a \<Rightarrow> 'c) stream" and x
  assume [transfer_rule]: "stream_all2 (eq_on (sset x) ===> R) f g"
  have [transfer_rule]: "stream_all2 (eq_on (sset x)) x x" by(simp add: stream.rel_refl_strong)
  show "stream_all2 R (f \<diamondop> x) (g \<diamondop> x)" by transfer_prover
qed (rule ap_stream_homo)

lemma smap_applicative[applicative_unfold]: "smap f x = pure f \<diamondop> x"
unfolding ap_stream_def by (coinduction arbitrary: x) auto

lemma smap2_applicative[applicative_unfold]: "smap2 f x y = pure f \<diamondop> x \<diamondop> y"
unfolding ap_stream_def by (coinduction arbitrary: x y) auto

end

end


theory Hotel_Example
imports Main "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
begin

datatype guest = Guest0 | Guest1
datatype key = Key0 | Key1 | Key2 | Key3
datatype room = Room0

type_synonym card = "key * key"

datatype event =
  Check_in guest room card
| Enter guest room card
| Exit guest room

definition initk :: "room \<Rightarrow> key"
  where "initk = (%r. Key0)"

declare initk_def[code_pred_def, code]

primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option"
where
  "owns [] r = None"
| "owns (e#s) r = (case e of
    Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
    Enter g r' c \<Rightarrow> owns s r |
    Exit g r' \<Rightarrow> owns s r)"

primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "currk [] r = initk r"
| "currk (e#s) r = (let k = currk s r in
    case e of Check_in g r' (k1, k2) \<Rightarrow> if r' = r then k2 else k
            | Enter g r' c \<Rightarrow> k
            | Exit g r \<Rightarrow> k)"

primrec issued :: "event list \<Rightarrow> key set"
where
  "issued [] = range initk"
| "issued (e#s) = issued s \<union>
  (case e of Check_in g r (k1, k2) \<Rightarrow> {k2} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"

primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set"
where
  "cards [] g = {}"
| "cards (e#s) g = (let C = cards s g in
                    case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
                                                else C
                            | Enter g r c \<Rightarrow> C
                            | Exit g r \<Rightarrow> C)"

primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "roomk [] r = initk r"
| "roomk (e#s) r = (let k = roomk s r in
    case e of Check_in g r' c \<Rightarrow> k
            | Enter g r' (x,y) \<Rightarrow> if r' = r (*& x = k*) then y else k
            | Exit g r \<Rightarrow> k)"

primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set"
where
  "isin [] r = {}"
| "isin (e#s) r = (let G = isin s r in
                 case e of Check_in g r c \<Rightarrow> G
                 | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
                 | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"

primrec hotel :: "event list \<Rightarrow> bool"
where
  "hotel []  = True"
| "hotel (e # s) = (hotel s & (case e of
  Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
  Enter g r (k,k') \<Rightarrow> (k,k') : cards s g & (roomk s r : {k, k'}) |
  Exit g r \<Rightarrow> g : isin s r))"

definition no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
[code del]: "no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"

definition feels_safe :: "event list \<Rightarrow> room \<Rightarrow> bool"
where
  "feels_safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
   s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 \<and>
   no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"

section \<open>Some setup\<close>

lemma issued_nil: "issued [] = {Key0}"
by (auto simp add: initk_def)

lemmas issued_simps[code] = issued_nil issued.simps(2)

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name Set.member},
  @{const_name "issued"}, @{const_name "cards"}, @{const_name "isin"},
  @{const_name Collect}, @{const_name insert}]\<close>
ML_val \<open>Core_Data.force_modes_and_compilations\<close>

fun find_first :: "('a => 'b option) => 'a list => 'b option"
where
  "find_first f [] = None"
| "find_first f (x # xs) = (case f x of Some y => Some y | None => find_first f xs)"

axiomatization cps_of_set :: "'a set => ('a => term list option) => term list option"
where cps_of_set_code [code]: "cps_of_set (set xs) f = find_first f xs"

axiomatization pos_cps_of_set :: "'a set => ('a => (bool * term list) option) => natural => (bool * term list) option"
where pos_cps_of_set_code [code]: "pos_cps_of_set (set xs) f i = find_first f xs"

axiomatization find_first' :: "('b Quickcheck_Exhaustive.unknown => 'a Quickcheck_Exhaustive.three_valued)
    => 'b list => 'a Quickcheck_Exhaustive.three_valued"
where find_first'_Nil: "find_first' f [] = Quickcheck_Exhaustive.No_value"
  and find_first'_Cons: "find_first' f (x # xs) =
    (case f (Quickcheck_Exhaustive.Known x) of
      Quickcheck_Exhaustive.No_value => find_first' f xs
    | Quickcheck_Exhaustive.Value x => Quickcheck_Exhaustive.Value x
    | Quickcheck_Exhaustive.Unknown_value =>
        (case find_first' f xs of Quickcheck_Exhaustive.Value x =>
          Quickcheck_Exhaustive.Value x
        | _ => Quickcheck_Exhaustive.Unknown_value))"

lemmas find_first'_code [code] = find_first'_Nil find_first'_Cons

axiomatization neg_cps_of_set :: "'a set => ('a Quickcheck_Exhaustive.unknown => term list Quickcheck_Exhaustive.three_valued) => natural => term list Quickcheck_Exhaustive.three_valued"
where neg_cps_of_set_code [code]: "neg_cps_of_set (set xs) f i = find_first' f xs"

setup \<open>
let
  val Fun = Predicate_Compile_Aux.Fun
  val Input = Predicate_Compile_Aux.Input
  val Output = Predicate_Compile_Aux.Output
  val Bool = Predicate_Compile_Aux.Bool
  val oi = Fun (Output, Fun (Input, Bool))
  val ii = Fun (Input, Fun (Input, Bool))
  fun of_set compfuns (Type ("fun", [T, _])) =
    case body_type (Predicate_Compile_Aux.mk_monadT compfuns T) of
      Type ("Quickcheck_Exhaustive.three_valued", _) =>
        Const(@{const_name neg_cps_of_set}, HOLogic.mk_setT T --> (Predicate_Compile_Aux.mk_monadT compfuns T))
    | _ => Const(@{const_name pos_cps_of_set}, HOLogic.mk_setT T --> (Predicate_Compile_Aux.mk_monadT compfuns T))
  fun member compfuns (U as Type ("fun", [T, _])) =
    (absdummy T (absdummy (HOLogic.mk_setT T) (Predicate_Compile_Aux.mk_if compfuns
      (Const (@{const_name "Set.member"}, T --> HOLogic.mk_setT T --> @{typ bool}) $ Bound 1 $ Bound 0))))

in
  Core_Data.force_modes_and_compilations @{const_name Set.member}
    [(oi, (of_set, false)), (ii, (member, false))]
end
\<close>
section \<open>Property\<close>

lemma "\<lbrakk> hotel s; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
quickcheck[tester = exhaustive, size = 6, expect = counterexample]
quickcheck[tester = smart_exhaustive, depth = 6, expect = counterexample]
oops

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
quickcheck[smart_exhaustive, depth = 10, allow_function_inversion, expect = counterexample]
oops

section \<open>Refinement\<close>

fun split_list
where
  "split_list [] = [([], [])]"
| "split_list (z # zs) = (([], z # zs) # [(z # xs', ys'). (xs', ys') <- split_list zs])"

lemma split_list: "((xs, ys) \<in> set (split_list zs)) = (zs = xs @ ys)"
apply (induct zs arbitrary: xs ys)
apply fastforce
apply (case_tac xs)
apply auto
done

lemma [code]: "feels_safe s r = list_ex (%(s3, s2, s1, g, c, c'). no_Check_in (s3 @ s2) r &
    isin (s2 @ [Check_in g r c] @ s1) r = {}) ([(s3, s2, s1, g, c, c'). (s3, Enter g' r' c # r3) <- split_list s, r' = r, (s2, Check_in g r'' c' # s1) <- split_list r3, r'' = r, g = g'])"
unfolding feels_safe_def list_ex_iff
by auto (metis split_list)+

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
(* quickcheck[exhaustive, size = 9, timeout = 2000] -- maybe possible with a lot of time *)
quickcheck[narrowing, size = 7, expect = counterexample]
oops

end


(*  Title:       Verification components with MKA and non-deterministic functions
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open>Verification of hybrid programs\<close>

text \<open> We show that non-deterministic functions or state transformers form an antidomain
Kleene algebra. We use this algebra's forward box operator to derive rules for weakest liberal
preconditions (wlps) of regular programs. Finally, we derive our three methods for verifying
correctness specifications for the continuous dynamics of HS. \<close>

theory HS_VC_MKA_ndfun
  imports
    "../HS_ODEs"
    "HS_VC_MKA"
    "../HS_VC_KA_ndfun"

begin

instantiation nd_fun :: (type) antidomain_kleene_algebra
begin

definition "ad f = (\<lambda>s. if ((f\<^sub>\<bullet>) s = {}) then {s} else {})\<^sup>\<bullet>"

lemma nd_fun_ad_zero[nd_fun_ka]: "ad x \<cdot> x = 0"
  and nd_fun_ad[nd_fun_ka]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and nd_fun_ad_one[nd_fun_ka]: "ad (ad x) + ad x = 1" for x::"'a nd_fun"
  unfolding antidomain_op_nd_fun_def times_nd_fun_def plus_nd_fun_def zero_nd_fun_def
  by (auto simp: nd_fun_eq_iff kcomp_def one_nd_fun_def)

instance
  apply intro_classes
  using nd_fun_ka by simp_all

end

subsubsection \<open> Regular programs\<close>

text\<open> Now that we know that non-deterministic functions form an Antidomain Kleene Algebra, we give
 a lifting operation from predicates to @{typ "'a nd_fun"} and use it to compute weakest liberal
preconditions.\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

notation fbox ("wp")

no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")
        and Relation.relcomp (infixl ";" 75)
        and Range_Semiring.antirange_semiring_class.ars_r ("r")
        and antidomain_semiringl.ads_d ("d")

abbreviation p2ndf :: "'a pred \<Rightarrow> 'a nd_fun" ("(1\<lceil>_\<rceil>)")
  where "\<lceil>Q\<rceil> \<equiv> (\<lambda> x::'a. {s::'a. s = x \<and> Q s})\<^sup>\<bullet>"

lemma p2ndf_simps[simp]:
  "\<lceil>P\<rceil> \<le> \<lceil>Q\<rceil> = (\<forall>s. P s \<longrightarrow> Q s)"
  "(\<lceil>P\<rceil> = \<lceil>Q\<rceil>) = (\<forall>s. P s = Q s)"
  "(\<lceil>P\<rceil> \<cdot> \<lceil>Q\<rceil>) = \<lceil>\<lambda> s. P s \<and> Q s\<rceil>"
  "(\<lceil>P\<rceil> + \<lceil>Q\<rceil>) = \<lceil>\<lambda> s. P s \<or> Q s\<rceil>"
  "ad \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  "d \<lceil>P\<rceil> = \<lceil>P\<rceil>" "\<lceil>P\<rceil> \<le> \<eta>\<^sup>\<bullet>"
  unfolding less_eq_nd_fun_def times_nd_fun_def plus_nd_fun_def ads_d_def
  by (auto simp: nd_fun_eq_iff kcomp_def le_fun_def antidomain_op_nd_fun_def)

text \<open> Lemmas for verification condition generation \<close>

lemma wp_nd_fun: "wp F \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<forall>s'. s' \<in> ((F\<^sub>\<bullet>) s) \<longrightarrow> P s'\<rceil>"
  apply(simp add: fbox_def antidomain_op_nd_fun_def)
  by(rule nd_fun_ext, auto simp: Rep_comp_hom kcomp_prop)

\<comment> \<open> Skip \<close>

abbreviation skip :: "'a nd_fun"
  where "skip \<equiv> 1"

\<comment> \<open> Tests \<close>

lemma wp_test[simp]: "wp \<lceil>P\<rceil> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<longrightarrow> Q s\<rceil>"
  by (subst wp_nd_fun, simp)

\<comment> \<open> Assignments \<close>

definition assign :: "'b \<Rightarrow> ('a^'b \<Rightarrow> 'a) \<Rightarrow> ('a^'b) nd_fun" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})\<^sup>\<bullet>"

lemma wp_assign[simp]: "wp (x ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j)\<rceil>"
  unfolding wp_nd_fun nd_fun_eq_iff vec_upd_def assign_def by auto

\<comment> \<open> Nondeterministic assignments \<close>

definition nondet_assign :: "'b \<Rightarrow> ('a^'b) nd_fun" ("(2_ ::= ? )" [70] 61)
  where "(x ::= ?) = (\<lambda>s. {(vec_upd s x k)|k. True})\<^sup>\<bullet>"

lemma wp_nondet_assign[simp]: "wp (x ::= ?) \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<forall>k. P (\<chi> j. ((($) s)(x := k)) j)\<rceil>"
  unfolding wp_nd_fun nondet_assign_def vec_upd_eq apply(clarsimp, safe)
  by (erule_tac x="(\<chi> j. if j = x then k else s $ j)" in allE, auto)

\<comment> \<open> Nondeterministic choice \<close>

lemma le_wp_choice_iff: "\<lceil>P\<rceil> \<le> wp (X + Y) \<lceil>Q\<rceil> \<longleftrightarrow> \<lceil>P\<rceil> \<le> wp X \<lceil>Q\<rceil> \<and> \<lceil>P\<rceil> \<le> wp Y \<lceil>Q\<rceil>"
  using le_fbox_choice_iff[of "\<lceil>P\<rceil>"] by simp

\<comment> \<open> Sequential composition \<close>

abbreviation seq_comp :: "'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" (infixl ";" 75)
  where "f ; g \<equiv> f \<cdot> g"

\<comment> \<open> Conditional statement \<close>

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> 'a nd_fun" ("IF _ THEN _ ELSE _" [64,64] 63)
  where "IF P THEN X ELSE Y \<equiv> aka_cond \<lceil>P\<rceil> X Y"

\<comment> \<open> Finite iteration \<close>

abbreviation loopi_sugar :: "'a nd_fun \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP R INV I \<equiv> aka_loopi R \<lceil>I\<rceil>"

lemma change_loopI: "LOOP X INV G = LOOP X INV I"
  by (unfold aka_loopi_def, simp)

lemma wp_loopI: "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> wp R \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> wp (LOOP R INV I) \<lceil>Q\<rceil>"
  using fbox_loopi[of "\<lceil>P\<rceil>"] by auto

lemma wp_loopI_break:
  "\<lceil>P\<rceil> \<le> wp Y \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> wp X \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>  \<Longrightarrow> \<lceil>P\<rceil> \<le> wp (Y ; (LOOP X INV I)) \<lceil>Q\<rceil>"
  using fbox_loopi_break[of "\<lceil>P\<rceil>"] by auto

subsubsection \<open> Evolution commands \<close>

text  \<open>Verification by providing evolution\<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> ('b \<Rightarrow> 'a set) \<Rightarrow> 'b nd_fun" ("EVOL")
  where "EVOL \<phi> G T = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G (T s))\<^sup>\<bullet>"

lemma wp_g_dyn[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "wp (EVOL \<phi> G U) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil>"
  unfolding wp_nd_fun g_evol_def g_orbit_eq by (auto simp: fun_eq_iff)

text \<open>Verification by providing solutions\<close>

definition g_ode ::"(real \<Rightarrow> ('a::banach) \<Rightarrow> 'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a nd_fun" ("(1x\<acute>= _ & _ on _ _ @ _)")
  where "(x\<acute>= f & G on U S @ t\<^sub>0) \<equiv> (\<lambda> s. g_orbital f G U S t\<^sub>0 s)\<^sup>\<bullet>"

lemma wp_g_orbital: "wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil>=
  \<lceil>\<lambda>s. \<forall>X\<in>Sols f U S t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> Q (X t)\<rceil>"
  unfolding g_orbital_eq(1) wp_nd_fun g_ode_def by (auto simp: fun_eq_iff)

context local_flow
begin

lemma wp_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "wp (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<lceil>Q\<rceil> =
  \<lceil>\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))\<rceil>"
  apply(unfold wp_g_orbital, clarsimp, rule iffI; clarify)
   apply(force simp: in_ivp_sols assms)
  apply(frule ivp_solsD(2), frule ivp_solsD(3), frule ivp_solsD(4))
  apply(subgoal_tac "\<forall>\<tau>\<in>down (U s) t. X \<tau> = \<phi> \<tau> s")
   apply(clarsimp, fastforce, rule ballI)
  apply(rule ivp_unique_solution[OF _ _ _ _ _ in_ivp_sols])
  using assms by auto

lemma wp_g_ode: "wp (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<lceil>Q\<rceil> =
  \<lceil>\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))\<rceil>"
  by (subst wp_g_ode_subset, simp_all add: init_time interval_time)

lemma wp_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> wp (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {0..t}) S @ 0) \<lceil>Q\<rceil> =
  \<lceil>\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))\<rceil>"
  apply(subst wp_g_ode_subset, simp_all add: subintervalI init_time real_Icc_closed_segment)
  by (auto simp: closed_segment_eq_real_ivl)

lemma wp_orbit: "wp (\<gamma>\<^sup>\<phi>\<^sup>\<bullet>) \<lceil>Q\<rceil> = \<lceil>\<lambda> s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s))\<rceil>"
  unfolding orbit_def wp_g_ode g_ode_def[symmetric] by auto

end

text \<open> Verification with differential invariants \<close>

definition g_ode_inv :: "(real \<Rightarrow> ('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on U S @ t\<^sub>0 DINV I) = (x\<acute>= f & G on U S @ t\<^sub>0)"

lemma wp_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil> = wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>H\<rceil>"
  unfolding wp_g_orbital using assms by auto

lemma wp_g_orbital_inv:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "\<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>I\<rceil>" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
  using assms(1)
  apply(rule order.trans)
  using assms(2)
  apply(rule order.trans)
  apply(rule fbox_iso)
  using assms(3) by auto

lemma wp_diff_inv[simp]: "(\<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>I\<rceil>) = diff_invariant I f U S t\<^sub>0 G"
  unfolding diff_invariant_eq wp_g_orbital by(auto simp: fun_eq_iff)

lemma diff_inv_guard_ignore:
  assumes "\<lceil>I\<rceil> \<le> wp (x\<acute>= f & (\<lambda>s. True) on U S @ t\<^sub>0) \<lceil>I\<rceil>"
  shows "\<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>I\<rceil>"
  using assms unfolding wp_diff_inv diff_invariant_eq by auto

context local_flow
begin

lemma wp_diff_inv_eq:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "diff_invariant I (\<lambda>t. f) U S 0 (\<lambda>s. True) =
  (\<lceil>\<lambda>s. s \<in> S \<longrightarrow> I s\<rceil> = wp (x\<acute>= (\<lambda>t. f) & (\<lambda>s. True) on U S @ 0) \<lceil>\<lambda>s. s \<in> S \<longrightarrow> I s\<rceil>)"
  unfolding wp_diff_inv[symmetric]
  apply(subst wp_g_ode_subset[OF assms], simp)+
  apply(clarsimp, safe, force)
   apply(erule_tac x=0 in ballE)
  using init_time in_domain ivp(2) assms apply(force, force)
  apply(erule_tac x=s in allE, clarsimp, erule_tac x=t in ballE)
  using in_domain ivp(2) assms by force+

lemma diff_inv_eq_inv_set:
  "diff_invariant I (\<lambda>t. f) (\<lambda>s. T) S 0 (\<lambda>s. True) = (\<forall>s. I s \<longrightarrow> \<gamma>\<^sup>\<phi> s \<subseteq> {s. I s})"
  unfolding diff_inv_eq_inv_set orbit_def by auto

end

lemma wp_g_odei: "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>I\<rceil> \<Longrightarrow> \<lceil>\<lambda>s. I s \<and> G s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow>
  \<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0 DINV I) \<lceil>Q\<rceil>"
  unfolding g_ode_inv_def
  apply(rule_tac b="wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>I\<rceil>" in order.trans)
   apply(rule_tac I="I" in wp_g_orbital_inv, simp_all)
  apply(subst wp_g_orbital_guard, simp)
  by (rule fbox_iso, simp)

subsubsection \<open> Derivation of the rules of dL \<close>

text \<open> We derive rules of differential dynamic logic (dL). This allows the components to reason
in the style of that logic. \<close>

abbreviation g_dl_ode ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _)")
  where "(x\<acute>= f & G) \<equiv> (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0)"

abbreviation g_dl_ode_inv :: "(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a nd_fun" ("(1x\<acute>=_ & _ DINV _)")
  where "(x\<acute>= f & G DINV I) \<equiv> (x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0 DINV I)"

lemma diff_solve_axiom1:
  assumes "local_flow f UNIV UNIV \<phi>"
  shows "wp (x\<acute>= f & G) \<lceil>Q\<rceil> =
  \<lceil>\<lambda>s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil>"
  by (subst local_flow.wp_g_ode_subset[OF assms], auto)

lemma diff_solve_axiom2:
  fixes c::"'a::{heine_borel, banach}"
  shows "wp (x\<acute>=(\<lambda>s. c) & G) \<lceil>Q\<rceil> =
  \<lceil>\<lambda>s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s + \<tau> *\<^sub>R c)) \<longrightarrow> Q (s + t *\<^sub>R c)\<rceil>"
  apply(subst local_flow.wp_g_ode_subset[where \<phi>="(\<lambda>t s. s + t *\<^sub>R c)" and T=UNIV])
  by (rule line_is_local_flow, auto)

lemma diff_solve_rule:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>Q\<rceil>"
  using assms by (subst local_flow.wp_g_ode_subset[OF assms(1)], auto)

lemma diff_weak_axiom1: "\<eta>\<^sup>\<bullet> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>G\<rceil>"
  unfolding wp_nd_fun g_ode_def g_orbital_eq less_eq_nd_fun_def
  by (auto simp: le_fun_def)

lemma diff_weak_axiom2:
  "wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>Q\<rceil> = wp (x\<acute>= f & G on T S @ t\<^sub>0) \<lceil>\<lambda> s. G s \<longrightarrow> Q s\<rceil>"
  unfolding wp_g_orbital image_def by force

lemma diff_weak_rule:
  assumes "\<lceil>G\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
  using assms by (auto simp: wp_g_orbital)

lemma wp_g_orbit_IdD:
  assumes "wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>C\<rceil> = \<eta>\<^sup>\<bullet>"
    and "\<forall>\<tau>\<in>(down (U s) t). x \<tau> \<in> g_orbital f G U S t\<^sub>0 s"
  shows "\<forall>\<tau>\<in>(down (U s) t). C (x \<tau>)"
proof
  fix \<tau> assume "\<tau> \<in> (down (U s) t)"
  hence "x \<tau> \<in> g_orbital f G U S t\<^sub>0 s"
    using assms(2) by blast
  also have "\<forall>y. y \<in> (g_orbital f G U S t\<^sub>0 s) \<longrightarrow> C y"
    using assms(1) unfolding wp_nd_fun g_ode_def
    by (subst (asm) nd_fun_eq_iff) auto
  ultimately show "C (x \<tau>)"
    by blast
qed

lemma diff_cut_axiom:
  assumes "wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>C\<rceil> = \<eta>\<^sup>\<bullet>"
  shows "wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil> = wp (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
proof(rule_tac f="\<lambda> x. wp x \<lceil>Q\<rceil>" in HOL.arg_cong, rule nd_fun_ext, rule subset_antisym)
  fix s show "((x\<acute>= f & G on U S @ t\<^sub>0)\<^sub>\<bullet>) s \<subseteq> ((x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0)\<^sub>\<bullet>) s"
  proof(clarsimp simp: g_ode_def)
    fix s' assume "s' \<in> g_orbital f G U S t\<^sub>0 s"
    then obtain \<tau>::real and X where x_ivp: "X \<in> ivp_sols f U S t\<^sub>0 s"
      and "X \<tau> = s'" and "\<tau> \<in> U s" and guard_x:"(\<P> X (down (U s) \<tau>) \<subseteq> {s. G s})"
      using g_orbitalD[of s' "f" G _ S t\<^sub>0 s] by blast
    have "\<forall>t\<in>(down (U s) \<tau>). \<P> X (down (U s) t) \<subseteq> {s. G s}"
      using guard_x by (force simp: image_def)
    also have "\<forall>t\<in>(down (U s) \<tau>). t \<in> (U s)"
      using \<open>\<tau> \<in> (U s)\<close> by auto
    ultimately have "\<forall>t\<in>(down (U s) \<tau>). X t \<in> g_orbital f G U S t\<^sub>0 s"
      using g_orbitalI[OF x_ivp] by (metis (mono_tags, lifting))
    hence "\<forall>t\<in>(down (U s) \<tau>). C (X t)"
      using wp_g_orbit_IdD[OF assms(1)] by blast
    thus "s' \<in> g_orbital f (\<lambda>s. G s \<and> C s) U S t\<^sub>0 s"
      using g_orbitalI[OF x_ivp \<open>\<tau> \<in> (U s)\<close>] guard_x \<open>X \<tau> = s'\<close> by fastforce
  qed
next
  fix s show "((x\<acute>= f & \<lambda>s. G s \<and> C s on U S @ t\<^sub>0)\<^sub>\<bullet>) s \<subseteq> ((x\<acute>= f & G on U S @ t\<^sub>0)\<^sub>\<bullet>) s"
    by (auto simp: g_orbital_eq g_ode_def)
qed

lemma diff_cut_rule:
  assumes wp_C: "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>C\<rceil>"
    and wp_Q: "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
proof(simp add: wp_nd_fun g_orbital_eq g_ode_def, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "P s" and "t \<in> U s"
    and x_ivp:"X \<in> ivp_sols f U S t\<^sub>0 s"
    and guard_x:"\<forall>x. x \<in> U s \<and> x \<le> t \<longrightarrow> G (X x)"
  have "\<forall>t\<in>(down (U s) t). X t \<in> g_orbital f G U S t\<^sub>0 s"
    using g_orbitalI[OF x_ivp] guard_x by auto
  hence "\<forall>t\<in>(down (U s) t). C (X t)"
    using wp_C \<open>P s\<close> by (subst (asm) wp_nd_fun, auto simp: g_ode_def)
  hence "X t \<in> g_orbital f (\<lambda>s. G s \<and> C s) U S t\<^sub>0 s"
    using guard_x \<open>t \<in> (U s)\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "Q (X t)"
    using \<open>P s\<close> wp_Q by (subst (asm) wp_nd_fun) (auto simp: g_ode_def)
qed

lemma diff_inv_axiom1:
  assumes "G s \<longrightarrow> I s" and "diff_invariant I (\<lambda>t. f) (\<lambda>s. {t. t \<ge> 0}) UNIV 0 G"
  shows "s \<in> ((wp (x\<acute>= f & G) \<lceil>I\<rceil>)\<^sub>\<bullet>) s"
  using assms unfolding wp_g_orbital diff_invariant_eq apply clarsimp
  by (erule_tac x=s in allE, frule ivp_solsD(2), clarsimp)

lemma diff_inv_axiom2:
  assumes "picard_lindeloef (\<lambda>t. f) UNIV UNIV 0"
    and "\<And>s. {t::real. t \<ge> 0} \<subseteq> picard_lindeloef.ex_ivl (\<lambda>t. f) UNIV UNIV 0 s"
    and "diff_invariant I (\<lambda>t. f) (\<lambda>s. {t::real. t \<ge> 0}) UNIV 0 G"
  shows "wp (x\<acute>= f & G) \<lceil>I\<rceil> = wp \<lceil>G\<rceil> \<lceil>I\<rceil>"
proof(unfold wp_g_orbital, subst wp_nd_fun, clarsimp simp: fun_eq_iff)
  fix s
  let "?ex_ivl s" = "picard_lindeloef.ex_ivl (\<lambda>t. f) UNIV UNIV 0 s"
  let "?lhs s" =
    "\<forall>X\<in>Sols (\<lambda>t. f) (\<lambda>s. {t. t \<ge> 0}) UNIV 0 s. \<forall>t\<ge>0. (\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)) \<longrightarrow> I (X t)"
  obtain X where xivp1: "X \<in> Sols (\<lambda>t. f) (\<lambda>s. ?ex_ivl s) UNIV 0 s"
    using picard_lindeloef.flow_in_ivp_sols_ex_ivl[OF assms(1)] by auto
  have xivp2: "X \<in> Sols (\<lambda>t. f) (\<lambda>s. Collect ((\<le>) 0)) UNIV 0 s"
    by (rule in_ivp_sols_subset[OF _ _ xivp1], simp_all add: assms(2))
  hence shyp: "X 0 = s"
    using ivp_solsD by auto
  have dinv: "\<forall>s. I s \<longrightarrow> ?lhs s"
    using assms(3) unfolding diff_invariant_eq by auto
  {assume "?lhs s" and "G s"
    hence "I s"
      by (erule_tac x=X in ballE, erule_tac x=0 in allE, auto simp: shyp xivp2)}
  hence "?lhs s \<longrightarrow> (G s \<longrightarrow> I s)"
    by blast
  moreover
  {assume "G s \<longrightarrow> I s"
    hence "?lhs s"
      apply(clarify, subgoal_tac "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)")
       apply(erule_tac x=0 in allE, frule ivp_solsD(2), simp)
      using dinv by blast+}
  ultimately show "?lhs s = (G s \<longrightarrow> I s)"
    by blast
qed

lemma diff_inv_rule:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "diff_invariant I f U S t\<^sub>0 G" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<lceil>P\<rceil> \<le> wp (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
  apply(rule wp_g_orbital_inv[OF assms(1) _ assms(3)])
  unfolding wp_diff_inv using assms(2) .

end


(*  Title:      HOL/Examples/Records.thy
    Author:     Wolfgang Naraschewski, TU Muenchen
    Author:     Norbert Schirmer, TU Muenchen
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Using extensible records in HOL -- points and coloured points\<close>

theory Records
  imports Main
begin

subsection \<open>Points\<close>

record point =
  xpos :: nat
  ypos :: nat

text \<open>
  Apart many other things, above record declaration produces the
  following theorems:
\<close>

thm point.simps
thm point.iffs
thm point.defs

text \<open>
  The set of theorems @{thm [source] point.simps} is added
  automatically to the standard simpset, @{thm [source] point.iffs} is
  added to the Classical Reasoner and Simplifier context.

  \<^medskip> Record declarations define new types and type abbreviations:
  @{text [display]
\<open>point = \<lparr>xpos :: nat, ypos :: nat\<rparr> = () point_ext_type
'a point_scheme = \<lparr>xpos :: nat, ypos :: nat, ... :: 'a\<rparr>  = 'a point_ext_type\<close>}
\<close>

consts foo2 :: "\<lparr>xpos :: nat, ypos :: nat\<rparr>"
consts foo4 :: "'a \<Rightarrow> \<lparr>xpos :: nat, ypos :: nat, \<dots> :: 'a\<rparr>"

subsubsection \<open>Introducing concrete records and record schemes\<close>

definition foo1 :: point
  where "foo1 = \<lparr>xpos = 1, ypos = 0\<rparr>"

definition foo3 :: "'a \<Rightarrow> 'a point_scheme"
  where "foo3 ext = \<lparr>xpos = 1, ypos = 0, \<dots> = ext\<rparr>"

subsubsection \<open>Record selection and record update\<close>

definition getX :: "'a point_scheme \<Rightarrow> nat"
  where "getX r = xpos r"

definition setX :: "'a point_scheme \<Rightarrow> nat \<Rightarrow> 'a point_scheme"
  where "setX r n = r \<lparr>xpos := n\<rparr>"

subsubsection \<open>Some lemmas about records\<close>

text \<open>Basic simplifications.\<close>

lemma "point.make n p = \<lparr>xpos = n, ypos = p\<rparr>"
  by (simp only: point.make_def)

lemma "xpos \<lparr>xpos = m, ypos = n, \<dots> = p\<rparr> = m"
  by simp

lemma "\<lparr>xpos = m, ypos = n, \<dots> = p\<rparr>\<lparr>xpos:= 0\<rparr> = \<lparr>xpos = 0, ypos = n, \<dots> = p\<rparr>"
  by simp

text \<open>\<^medskip> Equality of records.\<close>

lemma "n = n' \<Longrightarrow> p = p' \<Longrightarrow> \<lparr>xpos = n, ypos = p\<rparr> = \<lparr>xpos = n', ypos = p'\<rparr>"
  \<comment> \<open>introduction of concrete record equality\<close>
  by simp

lemma "\<lparr>xpos = n, ypos = p\<rparr> = \<lparr>xpos = n', ypos = p'\<rparr> \<Longrightarrow> n = n'"
  \<comment> \<open>elimination of concrete record equality\<close>
  by simp

lemma "r\<lparr>xpos := n\<rparr>\<lparr>ypos := m\<rparr> = r\<lparr>ypos := m\<rparr>\<lparr>xpos := n\<rparr>"
  \<comment> \<open>introduction of abstract record equality\<close>
  by simp

lemma "r\<lparr>xpos := n\<rparr> = r\<lparr>xpos := n'\<rparr>" if "n = n'"
  \<comment> \<open>elimination of abstract record equality (manual proof)\<close>
proof -
  let "?lhs = ?rhs" = ?thesis
  from that have "xpos ?lhs = xpos ?rhs" by simp
  then show ?thesis by simp
qed

text \<open>\<^medskip> Surjective pairing\<close>

lemma "r = \<lparr>xpos = xpos r, ypos = ypos r\<rparr>"
  by simp

lemma "r = \<lparr>xpos = xpos r, ypos = ypos r, \<dots> = point.more r\<rparr>"
  by simp

text \<open>\<^medskip> Representation of records by cases or (degenerate) induction.\<close>

lemma "r\<lparr>xpos := n\<rparr>\<lparr>ypos := m\<rparr> = r\<lparr>ypos := m\<rparr>\<lparr>xpos := n\<rparr>"
proof (cases r)
  fix xpos ypos more
  assume "r = \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>"
  then show ?thesis by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>ypos := m\<rparr> = r\<lparr>ypos := m\<rparr>\<lparr>xpos := n\<rparr>"
proof (induct r)
  fix xpos ypos more
  show "\<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>\<lparr>xpos := n, ypos := m\<rparr> =
      \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>\<lparr>ypos := m, xpos := n\<rparr>"
    by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>xpos := m\<rparr> = r\<lparr>xpos := m\<rparr>"
proof (cases r)
  fix xpos ypos more
  assume "r = \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>"
  then show ?thesis by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>xpos := m\<rparr> = r\<lparr>xpos := m\<rparr>"
proof (cases r)
  case fields
  then show ?thesis by simp
qed

lemma "r\<lparr>xpos := n\<rparr>\<lparr>xpos := m\<rparr> = r\<lparr>xpos := m\<rparr>"
  by (cases r) simp

text \<open>\<^medskip> Concrete records are type instances of record schemes.\<close>

definition foo5 :: nat
  where "foo5 = getX \<lparr>xpos = 1, ypos = 0\<rparr>"

text \<open>\<^medskip> Manipulating the ``\<open>...\<close>'' (more) part.\<close>

definition incX :: "'a point_scheme \<Rightarrow> 'a point_scheme"
  where "incX r = \<lparr>xpos = xpos r + 1, ypos = ypos r, \<dots> = point.more r\<rparr>"

lemma "incX r = setX r (Suc (getX r))"
  by (simp add: getX_def setX_def incX_def)

text \<open>\<^medskip> An alternative definition.\<close>

definition incX' :: "'a point_scheme \<Rightarrow> 'a point_scheme"
  where "incX' r = r\<lparr>xpos := xpos r + 1\<rparr>"

subsection \<open>Coloured points: record extension\<close>

datatype colour = Red | Green | Blue

record cpoint = point +
  colour :: colour

text \<open>
  The record declaration defines a new type constructor and abbreviations:
  @{text [display]
\<open>cpoint = \<lparr>xpos :: nat, ypos :: nat, colour :: colour\<rparr> =
  () cpoint_ext_type point_ext_type
'a cpoint_scheme = \<lparr>xpos :: nat, ypos :: nat, colour :: colour, \<dots> :: 'a\<rparr> =
  'a cpoint_ext_type point_ext_type\<close>}
\<close>

consts foo6 :: cpoint
consts foo7 :: "\<lparr>xpos :: nat, ypos :: nat, colour :: colour\<rparr>"
consts foo8 :: "'a cpoint_scheme"
consts foo9 :: "\<lparr>xpos :: nat, ypos :: nat, colour :: colour, \<dots> :: 'a\<rparr>"

text \<open>Functions on \<open>point\<close> schemes work for \<open>cpoints\<close> as well.\<close>

definition foo10 :: nat
  where "foo10 = getX \<lparr>xpos = 2, ypos = 0, colour = Blue\<rparr>"

subsubsection \<open>Non-coercive structural subtyping\<close>

text \<open>Term \<^term>\<open>foo11\<close> has type \<^typ>\<open>cpoint\<close>, not type \<^typ>\<open>point\<close> --- Great!\<close>

definition foo11 :: cpoint
  where "foo11 = setX \<lparr>xpos = 2, ypos = 0, colour = Blue\<rparr> 0"

subsection \<open>Other features\<close>

text \<open>Field names contribute to record identity.\<close>

record point' =
  xpos' :: nat
  ypos' :: nat

text \<open>
  \<^noindent> May not apply \<^term>\<open>getX\<close> to @{term [source] "\<lparr>xpos' = 2, ypos' = 0\<rparr>"}
  --- type error.
\<close>

text \<open>\<^medskip> Polymorphic records.\<close>

record 'a point'' = point +
  content :: 'a

type_synonym cpoint'' = "colour point''"

text \<open>Updating a record field with an identical value is simplified.\<close>
lemma "r\<lparr>xpos := xpos r\<rparr> = r"
  by simp

text \<open>Only the most recent update to a component survives simplification.\<close>
lemma "r\<lparr>xpos := x, ypos := y, xpos := x'\<rparr> = r\<lparr>ypos := y, xpos := x'\<rparr>"
  by simp

text \<open>
  In some cases its convenient to automatically split (quantified) records.
  For this purpose there is the simproc @{ML [source] "Record.split_simproc"}
  and the tactic @{ML [source] "Record.split_simp_tac"}. The simplification
  procedure only splits the records, whereas the tactic also simplifies the
  resulting goal with the standard record simplification rules. A
  (generalized) predicate on the record is passed as parameter that decides
  whether or how `deep' to split the record. It can peek on the subterm
  starting at the quantified occurrence of the record (including the
  quantifier). The value \<^ML>\<open>0\<close> indicates no split, a value greater
  \<^ML>\<open>0\<close> splits up to the given bound of record extension and finally the
  value \<^ML>\<open>~1\<close> completely splits the record. @{ML [source]
  "Record.split_simp_tac"} additionally takes a list of equations for
  simplification and can also split fixed record variables.
\<close>

lemma "(\<forall>r. P (xpos r)) \<longrightarrow> (\<forall>x. P x)"
  apply (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.split_simproc (K ~1)]) 1\<close>)
  apply simp
  done

lemma "(\<forall>r. P (xpos r)) \<longrightarrow> (\<forall>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply simp
  done

lemma "(\<exists>r. P (xpos r)) \<longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.split_simproc (K ~1)]) 1\<close>)
  apply simp
  done

lemma "(\<exists>r. P (xpos r)) \<longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply simp
  done

lemma "\<And>r. P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.split_simproc (K ~1)]) 1\<close>)
  apply auto
  done

lemma "\<And>r. P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply auto
  done

lemma "P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
  apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
  apply auto
  done

notepad
begin
  have "\<exists>x. P x"
    if "P (xpos r)" for P r
    apply (insert that)
    apply (tactic \<open>Record.split_simp_tac \<^context> [] (K ~1) 1\<close>)
    apply auto
    done
end

text \<open>
  The effect of simproc @{ML [source] Record.ex_sel_eq_simproc} is illustrated
  by the following lemma.\<close>

lemma "\<exists>r. xpos r = x"
  by (tactic \<open>simp_tac (put_simpset HOL_basic_ss \<^context>
    addsimprocs [Record.ex_sel_eq_simproc]) 1\<close>)

subsection \<open>A more complex record expression\<close>

record ('a, 'b, 'c) bar = bar1 :: 'a
  bar2 :: 'b
  bar3 :: 'c
  bar21 :: "'b \<times> 'a"
  bar32 :: "'c \<times> 'b"
  bar31 :: "'c \<times> 'a"

print_record "('a,'b,'c) bar"

subsection \<open>Some code generation\<close>

export_code foo1 foo3 foo5 foo10 checking SML

text \<open>
  Code generation can also be switched off, for instance for very large
  records:\<close>

declare [[record_codegen = false]]

record not_so_large_record =
  bar520 :: nat
  bar521 :: "nat \<times> nat"

declare [[record_codegen = true]]

end