section \<open>Labeled Graphs\<close>
text \<open>We define graphs as in the paper. Graph homomorphisms and subgraphs are defined slightly
      differently.
      Their correspondence to the definitions in the paper is given by separate lemmas.
      After defining graphs, we only talk about the semantics until after defining homomorphisms.
      The reason is that graph rewriting can be done without knowing about semantics.\<close>

theory LabeledGraphs
imports MissingRelation
begin

datatype ('l,'v) labeled_graph
  = LG (edges:"('l \<times> 'v \<times> 'v) set") (vertices:"'v set")

definition restrict where
  "restrict G = LG {(l,v1,v2) \<in> edges G. v1 \<in> vertices G \<and> v2 \<in> vertices G } (vertices G)"

text \<open>Definition 1. We define graphs and show that any graph with no edges (in particular
       the empty graph) is indeed a graph.\<close>
abbreviation graph where
  "graph X \<equiv> X = restrict X"

lemma graph_empty_e[intro]: "graph (LG {} v)" unfolding restrict_def by auto

lemma graph_single[intro]: "graph (LG {(a,b,c)} {b,c})" unfolding restrict_def by auto

abbreviation finite_graph where
  "finite_graph X \<equiv> graph X \<and> finite (vertices X) \<and> finite (edges X)"

lemma restrict_idemp[simp]:
  "restrict (restrict x) = restrict x"
by(cases x,auto simp:restrict_def)

lemma vertices_restrict[simp]:
  "vertices (restrict G) = vertices G"
  by(cases G,auto simp:restrict_def)

lemma restrictI[intro]:
  assumes "edges G \<subseteq> {(l,v1,v2). v1 \<in> vertices G \<and> v2 \<in> vertices G }"
  shows "G = restrict G"
  using assms by(cases G,auto simp:restrict_def)

lemma restrict_subsD[dest]:
  assumes "edges G \<subseteq> edges (restrict G)"
  shows "G = restrict G"
  using assms by(cases G,auto simp:restrict_def)

lemma restrictD[dest]:
  assumes "G = restrict G"
  shows "edges G \<subseteq> {(l,v1,v2). v1 \<in> vertices G \<and> v2 \<in> vertices G }"
proof -
  have "edges (restrict G) \<subseteq> {(l,v1,v2). v1 \<in> vertices G \<and> v2 \<in> vertices G }"
    by (cases G,auto simp:restrict_def)
  thus ?thesis using assms by auto
qed

(* Given a relation on vertices, make one on edges *)
definition on_triple where "on_triple R \<equiv> {((l,s,t),(l',s',t')) . l=l' \<and> (s,s') \<in> R \<and> (t,t') \<in> R}"

lemma on_triple[simp]:
  "((l1,v1,v2),(l2,v3,v4)) \<in> on_triple R \<longleftrightarrow> (v1,v3)\<in> R \<and> (v2,v4) \<in> R \<and> l1 = l2"
unfolding on_triple_def by auto

lemma on_tripleD[dest]:
  assumes "((l1,v1,v2),(l2,v3,v4)) \<in> on_triple R"
  shows "l2 = l1" "(v1,v3)\<in> R" "(v2,v4) \<in> R"
 using assms unfolding on_triple_def by auto

lemma on_triple_ID_restrict[simp]:
  shows "on_triple (Id_on (vertices G)) `` edges G = edges (restrict G)"
  unfolding on_triple_def by(cases G,auto simp:restrict_def)

lemma relcomp_on_triple[simp]:
  shows "on_triple (R O S) = on_triple R O on_triple S"
  unfolding on_triple_def by fast

lemma on_triple_preserves_finite[intro]:
"finite E  \<Longrightarrow> finite (on_triple (BNF_Def.Gr A f) `` E)"
  by (auto simp:on_triple_def BNF_Def.Gr_def)

lemma on_triple_fst[simp]:
  assumes "vertices G = Domain g" "graph G"
  shows "x \<in> fst ` on_triple g `` (edges G) \<longleftrightarrow> x \<in> fst ` edges G"
proof
  assume "x \<in> fst ` on_triple g `` edges G"
  then obtain a b where "(x,a,b) \<in> on_triple g `` edges G" by force
  then obtain c d where "(x,c,d) \<in> edges G" unfolding on_triple_def by auto
  thus "x \<in> fst ` edges G" by force next
  assume "x \<in> fst ` edges G"
  then obtain a b where ab:"(x,a,b) \<in> edges G" by force
  then obtain c d where "(a,c) \<in> g" "(b,d) \<in> g" using assms by force
  hence "(x,c,d) \<in> on_triple g `` edges G" using ab unfolding on_triple_def by auto
  thus "x \<in> fst ` on_triple g `` edges G" by (metis fst_conv image_iff)
qed

definition edge_preserving where
  "edge_preserving h e1 e2 \<equiv>
     (\<forall> (k,v1,v2) \<in> e1. \<forall> v1' v2'. ((v1, v1') \<in> h \<and> (v2,v2') \<in> h)
                                    \<longrightarrow> (k,v1',v2') \<in> e2)"

lemma edge_preserving_atomic:
  assumes "edge_preserving h1 e1 e2" "(v1, v1') \<in> h1" "(v2, v2') \<in> h1" "(k, v1, v2) \<in> e1"
  shows "(k, v1', v2') \<in> e2"
using assms unfolding edge_preserving_def by auto

lemma edge_preservingI[intro]:
  assumes "on_triple R `` E \<subseteq> G"
  shows "edge_preserving R E G"
  unfolding edge_preserving_def proof(clarify,goal_cases)
  case (1 a s t v1' v2')
  thus ?case by (intro assms[THEN subsetD]) (auto simp:on_triple_def)
  qed

lemma on_triple_dest[dest]:
  assumes "on_triple R `` E \<subseteq> G"
          "(l,x,y) \<in> E" "(x,xx) \<in> R" "(y,yy) \<in> R"
        shows "(l,xx,yy) \<in> G"
  using assms unfolding Image_def on_triple_def by blast

lemma edge_preserving:
  shows "edge_preserving R E G \<longleftrightarrow> on_triple R `` E \<subseteq> G"
proof
  assume "edge_preserving R E G"
  hence "\<And> k v1 v2 v1' v2'. (k, v1, v2)\<in>E \<Longrightarrow>
            (v1, v1') \<in> R \<Longrightarrow> (v2, v2') \<in> R \<Longrightarrow> (k, v1', v2') \<in> G"
    unfolding edge_preserving_def by auto
  then show "on_triple R `` E \<subseteq> G" unfolding Image_def by auto
qed auto

lemma edge_preserving_subset:
  assumes "R\<^sub>1 \<subseteq> R\<^sub>2" "E\<^sub>1 \<subseteq> E\<^sub>2" "edge_preserving R\<^sub>2 E\<^sub>2 G"
  shows "edge_preserving R\<^sub>1 E\<^sub>1 G"
  using assms unfolding edge_preserving_def by blast

lemma edge_preserving_unionI[intro]:
  assumes "edge_preserving f A G" "edge_preserving f B G"
  shows "edge_preserving f (A \<union> B) G"
  using assms unfolding edge_preserving_def by blast

lemma compose_preserves_edge_preserving:
  assumes "edge_preserving h1 e1 e2" "edge_preserving h2 e2 e3"
  shows "edge_preserving (h1 O h2) e1 e3" unfolding edge_preserving_def
proof(standard,standard,standard,standard,standard,standard,goal_cases)
  case (1 _ k _ v1 v2 v1'' v2'')
  hence 1:"(k, v1, v2) \<in> e1" "(v1, v1'') \<in> h1 O h2" "(v2, v2'') \<in> h1 O h2" by auto
  then obtain v1' v2' where
    v:"(v1,v1') \<in> h1" "(v1',v1'') \<in> h2" "(v2,v2') \<in> h1" "(v2',v2'') \<in> h2" by auto
  from edge_preserving_atomic[OF assms(1) v(1,3) 1(1)]
       edge_preserving_atomic[OF assms(2) v(2,4)]
  show ?case by metis
qed

lemma edge_preserving_Id[intro]: "edge_preserving (Id_on y) x x"
unfolding edge_preserving_def by auto

text \<open>This is an alternate version of definition 10. We require @term{vertices s = Domain h}
   to ensure that graph homomorphisms are sufficiently unique:
   The partiality follows the definition in the paper, per the remark before Def. 7.
   but it means that we cannot use Isabelle's total functions for the homomorphisms.
   We show that graph homomorphisms and embeddings coincide in a separate lemma.\<close>

definition graph_homomorphism where
  "graph_homomorphism G\<^sub>1 G\<^sub>2 f
    = ( vertices G\<^sub>1 = Domain f
      \<and> graph G\<^sub>1 \<and> graph G\<^sub>2
      \<and> f `` vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2
      \<and> univalent f
      \<and> edge_preserving f (edges G\<^sub>1) (edges G\<^sub>2)
      )"

lemma graph_homomorphismI:
  assumes "vertices s = Domain h"
          "h `` vertices s \<subseteq> vertices t"
          "univalent h"
          "edge_preserving h (edges s) (edges t)"
          "s = restrict s" "t = restrict t"
  shows "graph_homomorphism s t h" using assms unfolding graph_homomorphism_def by auto

lemma graph_homomorphism_composes[intro]:
  assumes "graph_homomorphism a b x"
          "graph_homomorphism b c y"
  shows "graph_homomorphism a c (x O y)" proof(rule graph_homomorphismI,goal_cases)
  case 1
    have "vertices a \<subseteq> Domain x" "x `` vertices a \<subseteq> Domain y"
      using assms(1,2)[unfolded graph_homomorphism_def] by blast+
    from this Domain_O[OF this]
    show ?case using assms[unfolded graph_homomorphism_def] by auto
  next
  case 2 from assms show ?case unfolding graph_homomorphism_def by blast
  qed (insert assms,auto simp:graph_homomorphism_def intro:compose_preserves_edge_preserving)

lemma graph_homomorphism_empty[simp]:
  "graph_homomorphism (LG {} {}) G f \<longleftrightarrow> f = {} \<and> graph G"
unfolding graph_homomorphism_def by auto

lemma graph_homomorphism_Id[intro]:
  shows "graph_homomorphism (restrict a) (restrict a) (Id_on (vertices a))"
  by (rule graph_homomorphismI;auto simp:edge_preserving_def)

lemma Id_on_vertices_identity:
  assumes "graph_homomorphism a b f"
          "(aa, ba) \<in> f"
  shows "(aa, ba) \<in> Id_on (vertices a) O f"
        "(aa, ba) \<in> f O Id_on (vertices b)"
  using assms unfolding graph_homomorphism_def by auto

text \<open>Alternate version of definition 7.\<close>
abbreviation subgraph
  where "subgraph G\<^sub>1 G\<^sub>2
  \<equiv> graph_homomorphism G\<^sub>1 G\<^sub>2 (Id_on (vertices G\<^sub>1))"

lemma subgraph_trans:
  assumes "subgraph G\<^sub>1 G\<^sub>2" "subgraph G\<^sub>2 G\<^sub>3"
  shows "subgraph G\<^sub>1 G\<^sub>3"
proof-
  from assms[unfolded graph_homomorphism_def]
  have "Id_on (vertices G\<^sub>1) O Id_on (vertices G\<^sub>2) = Id_on (vertices G\<^sub>1)"
    by auto
  with graph_homomorphism_composes[OF assms] show ?thesis by auto
qed

text \<open> Just before Definition 7 in the paper, a notation is introduced for applying a function to
       a graph. We use @{term map_graph} for this, and the version @{term map_graph_fn} in
       case that its first argument is a total function rather than a partial one. \<close>
(* Introducing the map notation just above Def 7 in the paper *)
definition map_graph :: "('c \<times> 'b) set \<Rightarrow> ('a, 'c) labeled_graph \<Rightarrow> ('a, 'b) labeled_graph" where
  "map_graph f G = LG (on_triple f `` (edges G)) (f `` (vertices G))"

lemma map_graph_selectors[simp]:
  "vertices (map_graph f G) = f `` (vertices G)"
  "edges (map_graph f G) = on_triple f `` (edges G)"
  unfolding map_graph_def by auto

lemma map_graph_comp[simp]:
  assumes "Range g \<subseteq> Domain f"
  shows "map_graph (g O f) = map_graph f o map_graph g"
proof(standard,goal_cases) (* need goal_cases to get the type of x right *)
  case (1 x)
  from assms have "map_graph (g O f) x = (map_graph f o map_graph g) x"
    unfolding map_graph_def by auto
  thus ?case by auto
qed

lemma map_graph_returns_restricted:
  assumes "vertices G = Domain f"
  shows "map_graph f G = restrict (map_graph f G)"
  using assms by(cases G,auto simp:map_graph_def restrict_def)

lemma map_graph_preserves_restricted[intro]:
  assumes "graph G"
  shows "graph (map_graph f G)"
proof(rule restrictI,standard) fix x
  assume "x \<in> edges (map_graph f G)"
  with assms show "x \<in> {(l, v1, v2). v1\<in>vertices (map_graph f G) \<and> v2\<in>vertices (map_graph f G)}"
    by(cases x,auto simp:map_graph_def)
qed

lemma map_graph_edge_preserving[intro]:
  shows "edge_preserving f (edges G) (edges (map_graph f G))"
  unfolding map_graph_def by auto

lemma map_graph_homo[intro]:
  assumes "univalent f" "vertices G = Domain f" "G = restrict G"
  shows "graph_homomorphism G (map_graph f G) f"
proof(rule graph_homomorphismI)
  show "f `` vertices G \<subseteq> vertices (map_graph f G)"
    unfolding map_graph_def by auto
  show "edge_preserving f (edges G) (edges (map_graph f G))" by auto
  show "map_graph f G = restrict (map_graph f G)" using assms by auto
qed fact+

lemma map_graph_homo_simp:
  "graph_homomorphism G (map_graph f G) f
   \<longleftrightarrow> univalent f \<and> vertices G = Domain f \<and> graph G"
proof
  show "graph_homomorphism G (map_graph f G) f \<Longrightarrow>
    univalent f \<and> vertices G = Domain f \<and> G = restrict G"
    unfolding graph_homomorphism_def by blast
qed auto

abbreviation on_graph where
"on_graph G f \<equiv> BNF_Def.Gr (vertices G) f"

abbreviation map_graph_fn where
"map_graph_fn G f \<equiv> map_graph (on_graph G f) G"

lemma map_graph_fn_graphI[intro]:
"graph (map_graph_fn G f)" unfolding map_graph_def restrict_def by auto

lemma on_graph_id[simp]:
  shows "on_graph B id = Id_on (vertices B)"
  unfolding BNF_Def.Gr_def by auto

lemma in_on_graph[intro]:
  assumes "x \<in> vertices G" "(a x,y) \<in> b"
  shows "(x, y) \<in> on_graph G a O b"
  using assms unfolding BNF_Def.Gr_def by auto

lemma on_graph_comp:
  "on_graph G (f o g) = on_graph G g O on_graph (map_graph_fn G g) f"
  unfolding BNF_Def.Gr_def by auto

lemma map_graph_fn_eqI:
  assumes "\<And> x. x \<in> vertices G \<Longrightarrow> f x = g x"
  shows "map_graph_fn G f = map_graph_fn G g" (is "?l = ?r")
proof -
  {  fix a ac ba
    assume "(a, ac, ba) \<in> edges G" "ac \<in> vertices G" "ba \<in> vertices G"
    hence "\<exists>x\<in>edges G. (x, a, g ac, g ba) \<in> on_triple (on_graph G f)"
          "\<exists>x\<in>edges G. (x, a, g ac, g ba) \<in> on_triple (on_graph G g)"
      using assms by (metis in_Gr on_triple)+
  }
  hence e:"edges ?l = edges ?r" using assms by (auto simp:Image_def)
  have v:"vertices ?l = vertices ?r" using assms by (auto simp:image_def)
  from e v show ?thesis by(cases ?l,cases ?r,auto)
qed

lemma map_graph_fn_comp[simp]:
"map_graph_fn G (f o g) = map_graph_fn (map_graph_fn G g) f"
  unfolding on_graph_comp by auto

lemma map_graph_fn_id[simp]:
"map_graph_fn X id = restrict X"
"map_graph (Id_on (vertices X)) X = restrict X"
  unfolding BNF_Def.Gr_def map_graph_def on_triple_def restrict_def by (cases X,force)+

lemma graph_homo[intro!]:
  assumes "graph G"
  shows "graph_homomorphism G (map_graph_fn G f) (on_graph G f)"
  using assms unfolding map_graph_homo_simp BNF_Def.Gr_def univalent_def by auto

lemma graph_homo_inv[intro!]:
  assumes "graph G" "inj_on f (vertices G)"
  shows "graph_homomorphism (map_graph_fn G f) G (converse (on_graph G f))"
proof(rule graph_homomorphismI)
  show "univalent ((on_graph G f)\<inverse>)" using assms(2)
    unfolding univalent_def BNF_Def.Gr_def inj_on_def by auto
  show "edge_preserving ((on_graph G f)\<inverse>) (edges (map_graph_fn G f)) (edges G)"
    using assms unfolding edge_preserving inj_on_def by auto auto
qed (insert assms(1),auto)

lemma edge_preserving_on_graphI[intro]:
  assumes "\<And> l x y. (l,x,y)\<in>edges X \<Longrightarrow> x\<in>vertices X \<Longrightarrow> y \<in> vertices X \<Longrightarrow> (l,f x,f y) \<in> Y"
  shows "edge_preserving (on_graph X f) (edges X) Y"
  using assms unfolding edge_preserving_def BNF_Def.Gr_def by auto

lemma subgraph_subset:
  assumes "subgraph G\<^sub>1 G\<^sub>2"
  shows "vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2" "edges (restrict G\<^sub>1) \<subseteq> edges G\<^sub>2"
proof -
  have vrt:"Id_on (vertices G\<^sub>1) `` vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2"
    and ep:"edge_preserving (Id_on (vertices G\<^sub>1)) (edges G\<^sub>1) (edges G\<^sub>2)"
    using assms unfolding graph_homomorphism_def by auto
  hence "edges (restrict G\<^sub>1) \<subseteq> edges G\<^sub>2"
    using assms unfolding edge_preserving by auto
  thus "vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2" "edges (restrict G\<^sub>1) \<subseteq> edges G\<^sub>2"
    using vrt by auto
qed

text \<open>Our definition of subgraph is equivalent to definition 7.\<close>
lemma subgraph_def2:
  assumes "graph G\<^sub>1" "graph G\<^sub>2"
  shows "subgraph G\<^sub>1 G\<^sub>2 \<longleftrightarrow> vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2 \<and> edges G\<^sub>1 \<subseteq> edges G\<^sub>2"
proof
  assume "vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2 \<and> edges G\<^sub>1 \<subseteq> edges G\<^sub>2"
  hence v:"vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2" and "edges G\<^sub>1 \<subseteq> edges G\<^sub>2" by auto
  hence ep:"edge_preserving (Id_on (vertices G\<^sub>1)) (edges G\<^sub>1) (edges G\<^sub>2)"
    unfolding edge_preserving_def by auto
  show "subgraph G\<^sub>1 G\<^sub>2"
    using assms(2) v ep graph_homomorphism_Id[of "G\<^sub>1",folded assms]
    unfolding graph_homomorphism_def by auto
next
  assume sg:"subgraph G\<^sub>1 G\<^sub>2"
  hence vrt:"Id_on (vertices G\<^sub>1) `` vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2"
    and ep:"edge_preserving (Id_on (vertices G\<^sub>1)) (edges G\<^sub>1) (edges G\<^sub>2)"
    unfolding graph_homomorphism_def by auto
  hence "edges G\<^sub>1 \<subseteq> edges G\<^sub>2"
    using assms unfolding edge_preserving by auto
  thus "vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2 \<and> edges G\<^sub>1 \<subseteq> edges G\<^sub>2"
    using vrt by auto
qed

text \<open>We also define @{term graph_union}. In contrast to the paper, our definition ignores the labels.
      The corresponding definition in the paper is written just above Definition 7.
      Adding labels to graphs would require a lot of unnecessary additional bookkeeping.
      Nowhere in the paper is the union actually used on different sets of labels,
      in which case these definitions coincide.\<close>

(* Since the set of labels is an implicit type, the notion of graph_union does not completely correspond to the one in the paper *)
definition graph_union where
"graph_union G\<^sub>1 G\<^sub>2 = LG (edges G\<^sub>1 \<union> edges G\<^sub>2) (vertices G\<^sub>1 \<union> vertices G\<^sub>2)"

lemma graph_unionI[intro]:
  assumes "edges G\<^sub>1 \<subseteq> edges G\<^sub>2"
          "vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2"
  shows "graph_union G\<^sub>1 G\<^sub>2 = G\<^sub>2"
  using assms unfolding graph_union_def by (cases "G\<^sub>2",auto)

lemma graph_union_iff:
  shows "graph_union G\<^sub>1 G\<^sub>2 = G\<^sub>2 \<longleftrightarrow> (edges G\<^sub>1 \<subseteq> edges G\<^sub>2 \<and> vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2)"
  unfolding graph_union_def by (cases "G\<^sub>2",auto)

lemma graph_union_idemp[simp]:
"graph_union A A = A"
"graph_union A (graph_union A B) = (graph_union A B)"
"graph_union A (graph_union B A) = (graph_union B A)"
unfolding graph_union_def by auto

lemma graph_union_vertices[simp]:
"vertices (graph_union G\<^sub>1 G\<^sub>2) = vertices G\<^sub>1 \<union> vertices G\<^sub>2"
  unfolding graph_union_def by auto
lemma graph_union_edges[simp]:
"edges (graph_union G\<^sub>1 G\<^sub>2) = edges G\<^sub>1 \<union> edges G\<^sub>2"
  unfolding graph_union_def by auto

lemma graph_union_preserves_restrict[intro]:
  assumes "G\<^sub>1 = restrict G\<^sub>1" "G\<^sub>2 = restrict G\<^sub>2"
  shows "graph_union G\<^sub>1 G\<^sub>2 = restrict (graph_union G\<^sub>1 G\<^sub>2)"
proof -
  let ?e = "edges G\<^sub>1 \<union> edges G\<^sub>2"
  let ?v = "vertices G\<^sub>1 \<union> vertices G\<^sub>2"
  let ?r = "{(l, v1, v2). (l, v1, v2) \<in> ?e \<and> v1 \<in> ?v \<and> v2 \<in> ?v}" (* restricted edges *)
  { fix l v1 v2
    assume a:"(l,v1,v2) \<in> ?e"
    have "(l,v1,v2) \<in> ?r" proof(cases "(l,v1,v2) \<in> edges (restrict G\<^sub>1)")
      case True
      hence "(l,v1,v2) \<in> edges G\<^sub>1" "v1 \<in> vertices G\<^sub>1" "v2 \<in> vertices G\<^sub>1"
         by (auto simp:restrict_def)+
      thus ?thesis by auto
    next
      case False hence "(l,v1,v2) \<in> edges (restrict G\<^sub>2)" using a assms by auto
      hence "(l,v1,v2) \<in> edges G\<^sub>2" "v1 \<in> vertices G\<^sub>2" "v2 \<in> vertices G\<^sub>2"
         by (auto simp:restrict_def)+
      then show ?thesis by auto
    qed
  }
  hence "?e = ?r" by auto
  thus ?thesis unfolding graph_union_def by auto
qed

lemma graph_map_union[intro]:
  assumes "\<And> i::nat. graph_union (map_graph (g i) X) Y = Y" "\<And> i j. i \<le> j \<Longrightarrow> g i \<subseteq> g j"
  shows "graph_union (map_graph (\<Union>i. g i) X) Y = Y"
proof
  from assms have e:"edges (map_graph (g i) X) \<subseteq> edges Y"
              and v:"vertices (map_graph (g i) X) \<subseteq> vertices Y" for i by (auto simp:graph_union_iff)
  { fix a ac ba aa b x xa
    assume a:"(a, ac, ba) \<in> edges X" "(ac, aa) \<in> g x" "(ba, b) \<in> g xa"
    have "(a, aa, b) \<in> edges Y"
    proof(cases "x < xa")
      case True
      hence "(a, ac, ba) \<in> edges X" "(ac, aa) \<in> g xa" "(ba, b) \<in> g xa"
        using a assms(2)[of x xa] by auto
      then show ?thesis using e[of xa] by auto
    next
      case False
      hence "(a, ac, ba) \<in> edges X" "(ac, aa) \<in> g x" "(ba, b) \<in> g x"
        using a assms(2)[of xa x] by auto
      then show ?thesis using e[of x] by auto
    qed
  }
  thus "edges (map_graph (\<Union>i. g i) X) \<subseteq> edges Y" by auto
  show "vertices (map_graph (\<Union>i. g i) X) \<subseteq> vertices Y" using v by auto
qed

text \<open>We show that @{term subgraph} indeed matches the definition in the paper (Definition 7).\<close>

lemma subgraph_def:
"subgraph G\<^sub>1 G\<^sub>2 = (G\<^sub>1 = restrict G\<^sub>1 \<and> G\<^sub>2 = restrict G\<^sub>2 \<and> graph_union G\<^sub>1 G\<^sub>2 = G\<^sub>2)"
proof
  assume assms:"subgraph G\<^sub>1 G\<^sub>2"
  hence r:"G\<^sub>2 = restrict G\<^sub>2" "G\<^sub>1 = restrict G\<^sub>1"
    unfolding graph_homomorphism_def by auto
  from subgraph_subset[OF assms]
  have ss:"vertices (restrict G\<^sub>1) \<subseteq> vertices G\<^sub>2" "edges (restrict G\<^sub>1) \<subseteq> edges G\<^sub>2" by auto
  show "G\<^sub>1 = restrict G\<^sub>1 \<and> G\<^sub>2 = restrict G\<^sub>2 \<and> graph_union G\<^sub>1 G\<^sub>2 = G\<^sub>2"
  proof(cases G\<^sub>2)
    case (LG x1 x2) show ?thesis using ss r
    unfolding graph_union_def LG by auto
  qed next
  assume gu: "G\<^sub>1 = restrict G\<^sub>1 \<and> G\<^sub>2 = restrict G\<^sub>2 \<and> graph_union G\<^sub>1 G\<^sub>2 = G\<^sub>2"
  hence sub:"(edges G\<^sub>1 \<union> edges G\<^sub>2) \<subseteq> edges G\<^sub>2"
    "vertices G\<^sub>1 \<subseteq> vertices G\<^sub>2"
    unfolding graph_union_def by (cases G\<^sub>2;auto)+
  have r:"G\<^sub>1 = restrict G\<^sub>1" "G\<^sub>2 = restrict G\<^sub>2" using gu by auto
  show "subgraph G\<^sub>1 G\<^sub>2" unfolding subgraph_def2[OF r] using sub by auto
qed

lemma subgraph_refl[simp]:
"subgraph G G = (G = restrict G)"
  unfolding subgraph_def graph_union_def by(cases G,auto)

lemma subgraph_restrict[simp]:
  "subgraph G (restrict G) = graph G"
  using subgraph_refl subgraph_def by auto

text \<open>Definition 10. We write @{term graph_homomorphism} instead of embedding.\<close>
lemma graph_homomorphism_def2: (* Shows a graph homomorphism is an embedding as in the paper *)
  shows "graph_homomorphism G\<^sub>1 G\<^sub>2 f =
   (vertices G\<^sub>1 = Domain f \<and> univalent f \<and> G\<^sub>1 = restrict G\<^sub>1 \<and> G\<^sub>2 = restrict G\<^sub>2 \<and> graph_union (map_graph f G\<^sub>1) G\<^sub>2 = G\<^sub>2)"
   (is "?lhs = ?rhs")
proof
  let ?m = "map_graph f G\<^sub>1"
  assume ?rhs
  hence assms : "vertices G\<^sub>1 = Domain f" "univalent f" "G\<^sub>1 = restrict G\<^sub>1"
    and sg: "subgraph ?m G\<^sub>2"
    and f_id:"f O Id_on (f `` vertices G\<^sub>1) = f" unfolding subgraph_def by auto
  hence "edge_preserving (Id_on (vertices ?m)) (edges ?m) (edges G\<^sub>2)"
    unfolding graph_homomorphism_def by auto
  hence "on_triple (f O Id_on (f `` vertices G\<^sub>1)) `` edges G\<^sub>1 \<subseteq> edges G\<^sub>2"  (* rewriting peak *)
    unfolding relcomp_Image edge_preserving map_graph_selectors relcomp_on_triple.
  hence "edge_preserving f (edges G\<^sub>1) (edges G\<^sub>2)"
    unfolding edge_preserving f_id.
  thus ?lhs
    using sg assms unfolding graph_homomorphism_def
    by auto next
  assume ih:?lhs
  hence "vertices G\<^sub>1 = Domain f \<and> univalent f \<and> G\<^sub>1 = restrict G\<^sub>1 \<and> subgraph (map_graph f G\<^sub>1) G\<^sub>2"
    unfolding graph_homomorphism_def edge_preserving
    by auto
  thus ?rhs unfolding subgraph_def by auto
qed

lemma map_graph_preserves_subgraph[intro]:
  assumes "subgraph A B"
  shows "subgraph (map_graph f A) (map_graph f B)"
  using assms unfolding subgraph_def by (auto simp:graph_union_iff)

lemma graph_homomorphism_concr_graph:
  assumes "graph G" "graph (LG e v)"
  shows "graph_homomorphism (LG e v) G x \<longleftrightarrow>
         x `` v \<subseteq> vertices G \<and> on_triple x `` e \<subseteq> edges G \<and> univalent x \<and> Domain x = v"
  using assms unfolding graph_homomorphism_def2 graph_union_iff by auto

lemma subgraph_preserves_hom:
  assumes "subgraph A B"
          "graph_homomorphism X A h"
  shows "graph_homomorphism X B h"
  using assms by (meson graph_homomorphism_def2 map_graph_preserves_restricted subgraph_def subgraph_trans)

lemma graph_homo_union_id:
assumes "graph_homomorphism (graph_union A B) G f"
shows "graph A \<Longrightarrow> graph_homomorphism A G (Id_on (vertices A) O f)"
      "graph B \<Longrightarrow> graph_homomorphism B G (Id_on (vertices B) O f)"
  using assms unfolding graph_homomorphism_def edge_preserving
  by (auto dest:edge_preserving_atomic)

lemma graph_homo_union[intro]:
  assumes
   "graph_homomorphism A G f_a"
   "graph_homomorphism B G f_b"
   "Domain f_a \<inter> Domain f_b = Domain (f_a \<inter> f_b)"
  shows "graph_homomorphism (graph_union A B) G (f_a \<union> f_b)"
proof(rule graph_homomorphismI)
  have v0:"f_a `` vertices A \<subseteq> vertices G" "f_b `` vertices B \<subseteq> vertices G"
          "vertices A = Domain f_a" "vertices B = Domain f_b"
          "graph A" "graph B"
          "univalent f_a" "univalent f_b"
          "edge_preserving f_a (edges A) (edges G)"
          "edge_preserving f_b (edges B) (edges G)"
    using assms(1,2) unfolding graph_homomorphism_def by blast+
  hence v: "f_a `` vertices (graph_union A B) \<subseteq> vertices G"
           "f_b `` vertices (graph_union A B) \<subseteq> vertices G" by auto
  show uni:"univalent (f_a \<union> f_b)" using assms(3) v0 by auto
  show "(f_a \<union> f_b) `` vertices (graph_union A B) \<subseteq> vertices G" using v by auto
  have f_a:"Id_on (vertices A) O (f_a \<union> f_b) = f_a"
        using uni v0(3)
        by (cases A,auto simp:univalent_def on_triple_def Image_def)
  have onA:"on_triple (f_a \<union> f_b) `` edges A = on_triple (Id_on (vertices A) O (f_a \<union> f_b)) `` edges A"
    unfolding relcomp_on_triple relcomp_Image on_triple_ID_restrict v0(5)[symmetric] ..
  have f_b:"Id_on (vertices B) O (f_a \<union> f_b) = f_b"
        using uni v0(4) unfolding Un_commute[of f_a _]
        by (cases B,auto simp:univalent_def on_triple_def Image_def)
  have onB:"on_triple (f_a \<union> f_b) `` edges B = on_triple (Id_on (vertices B) O (f_a \<union> f_b)) `` edges B"
    unfolding relcomp_on_triple relcomp_Image on_triple_ID_restrict v0(6)[symmetric] ..
  have "edge_preserving (f_a \<union> f_b) (edges A) (edges G)"
       "edge_preserving (f_a \<union> f_b) (edges B) (edges G)"
    using v0(9,10) unfolding edge_preserving onA[unfolded f_a] onB[unfolded f_b] by auto
  thus "edge_preserving (f_a \<union> f_b) (edges (graph_union A B)) (edges G)"
    by auto
qed (insert assms[unfolded graph_homomorphism_def],auto)

lemma graph_homomorphism_on_graph:
  assumes "graph_homomorphism A B R"
  shows "graph_homomorphism A (map_graph_fn B f) (R O on_graph B f)"
proof -
  from assms have "Range R \<subseteq> vertices B"
    and ep: "edge_preserving R (edges A) (edges B)" unfolding graph_homomorphism_def by auto
  hence d:"Domain R \<subseteq> Domain (R O on_graph B f)" unfolding Domain_id_on by auto
  have v:"vertices (map_graph (R O on_graph B f) A) \<subseteq> vertices (map_graph_fn B f)"
    unfolding BNF_Def.Gr_def map_graph_selectors by auto
  have e:"edges (map_graph (R O on_graph B f) A) \<subseteq> edges (map_graph_fn B f)" using ep
    unfolding BNF_Def.Gr_def map_graph_selectors edge_preserving by auto
  have u:"graph_union (map_graph (R O on_graph B f) A) (map_graph_fn B f) = map_graph_fn B f"
    using e v graph_unionI by metis
  from d assms u show "graph_homomorphism A (map_graph_fn B f) (R O on_graph B f)"
    unfolding graph_homomorphism_def2 by auto
qed

end


theory PartialMonoid
  imports Main
begin

section {* Partial monoid *}

no_notation
  one_class.one ("1") and
  times (infixl "*" 70)

notation bot ("\<bottom>")

text {* Signature of our classes *}

class pmult =
  fixes pmult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<oplus>" 80)

class pmult_defined =
  fixes pmult_defined :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "##" 55)

class pmult_one =
  fixes pmult_one :: "'a" ("1")

text {* Domain theoretical way of defining pmult semigroups, i.e., adding a \<bottom> (seeking) element. *}

class partial_semigroup_bot = pmult + bot +
  assumes pbot_assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  and botl [simp]: "x \<oplus> \<bottom> = \<bottom>"
  and botr [simp]: "\<bottom> \<oplus> x = \<bottom>"

text {*
  Let the binary relation ## be: x ## y \<longleftrightarrow> x + y \<noteq> \<bottom>, one can naturally define the
  following class based on the pmult semigroup with bottom element.
*}

class partial_semigroup_var = pmult + pmult_defined +
  assumes pmult_defr: "x ## (y \<oplus> z) \<Longrightarrow> y ## z"
  and pmult_defl: "(x \<oplus> y) ## z \<Longrightarrow> x ## y"
  and pmult_def_assoc: "x ## (y \<oplus> z) = (x \<oplus> y) ## z"
  and pmult_assoc_var: "x ## (y \<oplus> z) \<Longrightarrow> (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"

text {*
  A simpler pmult semigroup can be defined where it states that if x * y and (x * y) * z
  are defined, then y * z is also defined.
*}

class partial_semigroup = pmult + pmult_defined +
  assumes pmult_def: "(x \<oplus> y) ## z \<and> x ## y \<longleftrightarrow> x ## (y \<oplus> z) \<and> y ## z"
  and pmult_assoc: "\<lbrakk>x ## (y \<oplus> z); x ## y\<rbrakk> \<Longrightarrow> (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"

class totality = pmult_defined +
  assumes totality[simp]: "x ## y"

class total_semigroup = partial_semigroup + totality
begin

lemma total_assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  by (metis pmult_assoc totality)

sublocale semigroup "op \<oplus>"
  by default (simp add: total_assoc)

end

text {*
  As expected, the pmult semigroup with bottom element is the strongest, where one can
  derive the other classes.
*}

sublocale partial_semigroup_bot \<subseteq> partial_semigroup_var "op \<oplus>" "\<lambda>x y. x \<oplus> y \<noteq> \<bottom>"
  by (default, metis botl, metis botr, (metis pbot_assoc)+)

sublocale partial_semigroup_var \<subseteq> partial_semigroup
  by default (metis pmult_def_assoc pmult_defl pmult_defr, metis pmult_assoc_var)

sublocale partial_semigroup_bot \<subseteq> partial_semigroup "op \<oplus>" "\<lambda>x y. x \<oplus> y \<noteq> \<bottom>" ..

text {*
  We select the weakest pmult semigroup to continue our hierarchy up to commutative monoid.
*}

class partial_ab_semigroup = pmult + pmult_defined +
  assumes pmult_ab_def: "(x \<oplus> y) ## z \<and> x ## y \<Longrightarrow> x ## (y \<oplus> z) \<and> y ## z"
  and pmult_ab_assoc: "\<lbrakk>x ## (y \<oplus> z); x ## y\<rbrakk> \<Longrightarrow> (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  and pmult_comm_def: "x ## y \<Longrightarrow> y ## x"
  and pmult_comm: "x ## y \<Longrightarrow> x \<oplus> y = y \<oplus> x"
begin

lemma pmult_ab1: "(x \<oplus> y) ## z \<Longrightarrow> x ## y \<Longrightarrow> x ## (y \<oplus> z)"
  by (metis pmult_ab_def)

lemma pmult_ab2: "(x \<oplus> y) ## z \<and> x ## y \<Longrightarrow> y ## z"
  by (metis pmult_ab_def)

lemma "x ## y = y ## x"
  by (metis pmult_comm_def)

lemma pmult_def_eq: "(x \<oplus> y) ## z \<and> x ## y \<longleftrightarrow> x ## (y \<oplus> z) \<and> y ## z"
  by (metis pmult_comm_def pmult_ab_def)

lemma pmult_ab3: "x ## (y \<oplus> z) \<Longrightarrow> y ## z \<Longrightarrow> (x \<oplus> y) ## z"
  by (metis pmult_def_eq)

lemma pmult_ab4: "x ## (y \<oplus> z) \<Longrightarrow> y ## z \<Longrightarrow> x ## y"
  by (metis pmult_def_eq)

subclass partial_semigroup
  by default (metis pmult_def_eq, metis pmult_ab_assoc)

end

class total_ab_semigroup = partial_ab_semigroup + totality
begin

lemma total_assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  by (metis pmult_assoc totality)

lemma total_comm: "x \<oplus> y = y \<oplus> x"
  by (metis pmult_comm totality)

subclass total_semigroup ..

end

class partial_monoid = partial_semigroup + pmult_one +
  assumes pmult_one_defr [simp]: "x ## 1"
  and pmult_one_defl [simp]: "1 ## x"
  and pmult_oner: "x \<oplus> 1 = x"
  and pmult_onel: "1 \<oplus> x = x"

class total_monoid = partial_monoid + totality
begin
subclass total_semigroup ..

sublocale monoid "op \<oplus>" 1
  by default (simp_all add: pmult_oner pmult_onel)

end

class partial_comm_monoid = partial_ab_semigroup + pmult_one +
  assumes pone_defr: "x ## 1"
  and poner: "x \<oplus> 1 = x"
begin

subclass partial_monoid
  by default (auto simp: pone_defr poner pmult_comm pmult_comm_def)

end

class total_comm_monoid = partial_comm_monoid + totality
begin
subclass total_ab_semigroup ..
subclass total_monoid ..

sublocale comm_monoid "op \<oplus>" 1
  by default (simp_all add: total_comm)
end

section {* Models of partial monoids *}

text {*
  Binary Pairs
*}

typedef 'a pair = "UNIV :: ('a \<times> 'a) set" ..
setup_lifting type_definition_pair

instantiation pair :: (type) partial_semigroup
begin
lift_definition pmult_pair :: "'a pair \<Rightarrow> 'a pair \<Rightarrow> 'a pair" is "\<lambda>(a, b) (c, d). (a, d)" .
lift_definition pmult_defined_pair :: "'a pair \<Rightarrow> 'a pair \<Rightarrow> bool" is "\<lambda>(a, b) (c, d). b = c" .
instance
  by default (transfer, fastforce)+
end

text {*
  Partial functions.
*}

typedef ('a, 'b) pfun = "UNIV :: ('a \<Rightarrow> 'b option) set" ..
setup_lifting type_definition_pfun

instantiation pfun :: (type, type) partial_semigroup
begin
lift_definition pmult_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" is map_add .
lift_definition pmult_defined_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" is "\<lambda>x y. dom x \<inter> dom y = {}" .
instance
  by default (transfer, fastforce)+
end

instantiation pfun :: (type, type) partial_monoid
begin
lift_definition pmult_one_pfun :: "('a, 'b) pfun" is empty .
instance
  by default (transfer, fastforce)+
end

text {*
  We can also have a model where we add a new bottom element.
*}

typedef ('a, 'b) pfun_bot = "UNIV :: ('a \<Rightarrow> ('b option) option) set" ..
setup_lifting type_definition_pfun_bot

instantiation pfun_bot :: (type, type) partial_semigroup_bot
begin
lift_definition bot_pfun_bot :: "('a, 'b) pfun_bot" is "\<lambda>x. Some None" .
lift_definition pmult_pfun_bot :: "('a, 'b) pfun_bot \<Rightarrow> ('a, 'b) pfun_bot \<Rightarrow> ('a, 'b) pfun_bot"
  is "\<lambda>x y. if dom x \<inter> dom y = {} then map_add x y else (\<lambda>x. Some None)" .

instance
  by default (transfer, fastforce)+
end

text {*
  And obviously, it is also a model for our weaker semigroup.
*}

instantiation pfun_bot :: (type, type) partial_semigroup
begin
lift_definition pmult_defined_pfun_bot :: "('a, 'b) pfun_bot \<Rightarrow> ('a, 'b) pfun_bot \<Rightarrow> bool" is
  "\<lambda>x y. dom x \<inter> dom y = {}" .
instance
  by default (transfer, auto)+
end

text {*
  We could instantiate the heap as a partial function from nat to nat
*}

notation one_class.one ("1")
no_notation bot ("\<bottom>")

end


(*
  Copyright (c) 2014-2019 by Clemens Ballarin
  This file is licensed under the 3-clause BSD license.
*)

theory Set_Theory imports "HOL-Library.FuncSet" begin

hide_const map
hide_const partition

no_notation divide (infixl "'/" 70)
no_notation inverse_divide (infixl "'/" 70)

text \<open>
  Each statement in the formal text is annotated with the location of the originating statement
  in Jacobson's text \<^cite>\<open>Jacobson1985\<close>.  Each fact that Jacobson states explicitly is marked
  as @{command theorem} unless it is translated to a @{command sublocale} declaration.
  Literal quotations from Jacobson's text are reproduced in double quotes.

  Auxiliary results needed for the formalisation that cannot be found in Jacobson's text are marked
  as @{command lemma} or are @{command interpretation}s.  Such results are annotated with the
  location of a related statement.  For example, the introduction rule of a constant is annotated
  with the location of the definition of the corresponding operation.
\<close>

section \<open>Concepts from Set Theory.  The Integers\<close>

subsection \<open>The Cartesian Product Set.  Maps\<close>

text \<open>Maps as extensional HOL functions\<close>
text \<open>p 5, ll 21--25\<close>
locale map =
  fixes \<alpha> and S and T
  assumes graph [intro, simp]: "\<alpha> \<in> S \<rightarrow>\<^sub>E T"
begin

text \<open>p 5, ll 21--25\<close>
lemma map_closed [intro, simp]:
  "a \<in> S \<Longrightarrow> \<alpha> a \<in> T"
using graph by fast

text \<open>p 5, ll 21--25\<close>
lemma map_undefined [intro]:
  "a \<notin> S \<Longrightarrow> \<alpha> a = undefined"
using graph by fast

end (* map *)

text \<open>p 7, ll 7--8\<close>
locale surjective_map = map + assumes surjective [intro]: "\<alpha> ` S = T"

text \<open>p 7, ll 8--9\<close>
locale injective_map = map + assumes injective [intro, simp]: "inj_on \<alpha> S"

text \<open>Enables locale reasoning about the inverse @{term "restrict (inv_into S \<alpha>) T"} of @{term \<alpha>}.\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective =
  fixes \<alpha> and S and T
  assumes bijective [intro, simp]: "bij_betw \<alpha> S T"

text \<open>
  Exploit existing knowledge about @{term bij_betw} rather than extending @{locale surjective_map}
  and @{locale injective_map}.
\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective_map = map + bijective begin

text \<open>p 7, ll 9--10\<close>
sublocale surjective_map by unfold_locales (simp add: bij_betw_imp_surj_on)

text \<open>p 7, ll 9--10\<close>
sublocale injective_map using bij_betw_def by unfold_locales fast

text \<open>p 9, ll 12--13\<close>
sublocale inverse: map "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: inv_into_into surjective)

text \<open>p 9, ll 12--13\<close>
sublocale inverse: bijective "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: bij_betw_inv_into surjective)

end (* bijective_map *)

text \<open>p 8, ll 14--15\<close>
abbreviation "identity S \<equiv> (\<lambda>x \<in> S. x)"

context map begin

text \<open>p 8, ll 18--20; p 9, ll 1--8\<close>
theorem bij_betw_iff_has_inverse:
  "bij_betw \<alpha> S T \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. compose S \<beta> \<alpha> = identity S \<and> compose T \<alpha> \<beta> = identity T)"
    (is "_ \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>)")
proof
  let ?inv = "restrict (inv_into S \<alpha>) T"
  assume "bij_betw \<alpha> S T"
  then have "?INV ?inv" and "?inv \<in> T \<rightarrow>\<^sub>E S"
    by (simp_all add: compose_inv_into_id bij_betw_imp_surj_on compose_id_inv_into bij_betw_imp_funcset bij_betw_inv_into)
  then show "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>" ..
next
  assume "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>"
  then obtain \<beta> where "\<alpha> \<in> S \<rightarrow> T" "\<beta> \<in> T \<rightarrow> S" "\<And>x. x \<in> S \<Longrightarrow> \<beta> (\<alpha> x) = x" "\<And>y. y \<in> T \<Longrightarrow> \<alpha> (\<beta> y) = y"
    by (metis PiE_restrict compose_eq graph restrict_PiE restrict_apply)
  then show "bij_betw \<alpha> S T" by (rule bij_betwI)
qed

end (* map *)

subsection \<open>Equivalence Relations.  Factoring a Map Through an Equivalence Relation\<close>

text \<open>p 11, ll 6--11\<close>
locale equivalence =
  fixes S and E
  assumes closed [intro, simp]: "E \<subseteq> S \<times> S"
    and reflexive [intro, simp]: "a \<in> S \<Longrightarrow> (a, a) \<in> E"
    and symmetric [sym]: "(a, b) \<in> E \<Longrightarrow> (b, a) \<in> E"
    and transitive [trans]: "\<lbrakk> (a, b) \<in> E; (b, c) \<in> E \<rbrakk> \<Longrightarrow> (a, c) \<in> E"
begin

text \<open>p 11, ll 6--11\<close>
lemma left_closed [intro]: (* inefficient as a simp rule *)
  "(a, b) \<in> E \<Longrightarrow> a \<in> S"
  using closed by blast

text \<open>p 11, ll 6--11\<close>

end (* equivalence *)

text \<open>p 11, ll 16--20\<close>
locale partition =
  fixes S and P
  assumes subset: "P \<subseteq> Pow S"
    and non_vacuous: "{} \<notin> P"
    and complete: "\<Union>P = S"
    and disjoint: "\<lbrakk> A \<in> P; B \<in> P; A \<noteq> B \<rbrakk> \<Longrightarrow> A \<inter> B = {}"

context equivalence begin

text \<open>p 11, ll 24--26\<close>
definition "Class = (\<lambda>a \<in> S. {b \<in> S. (b, a) \<in> E})"

text \<open>p 11, ll 24--26\<close>
lemma Class_closed [dest]:
  "\<lbrakk> a \<in> Class b; b \<in> S \<rbrakk> \<Longrightarrow> a \<in> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_closed2 [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<subseteq> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Class a = undefined"
  unfolding Class_def by simp

text \<open>p 11, ll 24--26\<close>
lemma ClassI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> a \<in> Class b"
  unfolding Class_def by (simp add: left_closed right_closed)

text \<open>p 11, ll 24--26\<close>
lemma Class_revI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> b \<in> Class a"
  by (blast intro: symmetric)

text \<open>p 11, ll 24--26\<close>
lemma ClassD [dest]:
  "\<lbrakk> b \<in> Class a; a \<in> S \<rbrakk> \<Longrightarrow> (b, a) \<in> E"
  unfolding Class_def by simp

text \<open>p 11, ll 30--31\<close>
theorem Class_self [intro, simp]:
  "a \<in> S \<Longrightarrow> a \<in> Class a"
  unfolding Class_def by simp

text \<open>p 11, l 31; p 12, l 1\<close>
theorem Class_Union [simp]:
  "(\<Union>a\<in>S. Class a) = S"
  by blast

text \<open>p 11, ll 2--3\<close>
theorem Class_subset:
  "(a, b) \<in> E \<Longrightarrow> Class a \<subseteq> Class b"
proof
  fix a and b and c
  assume "(a, b) \<in> E" and "c \<in> Class a"
  then have "(c, a) \<in> E" by auto
  also note \<open>(a, b) \<in> E\<close>
  finally have "(c, b) \<in> E" by simp
  then show "c \<in> Class b" by auto
qed

text \<open>p 11, ll 3--4\<close>
theorem Class_eq:
  "(a, b) \<in> E \<Longrightarrow> Class a = Class b"
  by (auto intro!: Class_subset intro: symmetric)

text \<open>p 12, ll 1--5\<close>
theorem Class_equivalence:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> (a, b) \<in> E"
proof
  fix a and b
  assume "a \<in> S" "b \<in> S" "Class a = Class b"
  then have "a \<in> Class a" by auto
  also note \<open>Class a = Class b\<close>
  finally show "(a, b) \<in> E" by (fast intro: \<open>b \<in> S\<close>)
qed (rule Class_eq)

text \<open>p 12, ll 5--7\<close>
theorem not_disjoint_implies_equal:
  assumes not_disjoint: "Class a \<inter> Class b \<noteq> {}"
  assumes closed: "a \<in> S" "b \<in> S"
  shows "Class a = Class b"
proof -
  from not_disjoint and closed obtain c where witness: "c \<in> Class a \<inter> Class b" by fast
  with closed have "(a, c) \<in> E" by (blast intro: symmetric)
  also from witness and closed have "(c, b) \<in> E" by fast
  finally show ?thesis by (rule Class_eq)
qed

text \<open>p 12, ll 7--8\<close>
definition "Partition = Class ` S"

text \<open>p 12, ll 7--8\<close>
lemma Class_in_Partition [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<in> Partition"
  unfolding Partition_def by fast

text \<open>p 12, ll 7--8\<close>
theorem partition:
  "partition S Partition"
proof
  fix A and B
  assume closed: "A \<in> Partition" "B \<in> Partition"
  then obtain a and b where eq: "A = Class a" "B = Class b" and ab: "a \<in> S" "b \<in> S"
  unfolding Partition_def by auto
  assume distinct: "A \<noteq> B"
  then show "A \<inter> B = {}"
  proof (rule contrapos_np)
    assume not_disjoint: "A \<inter> B \<noteq> {}"
    then show "A = B" by (simp add: eq) (metis not_disjoint_implies_equal ab)
  qed
qed (auto simp: Partition_def)

end (* equivalence *)

context partition begin

text \<open>p 12, ll 9--10\<close>
theorem block_exists:
  "a \<in> S \<Longrightarrow> \<exists>A. a \<in> A \<and> A \<in> P"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
theorem block_unique:
  "\<lbrakk> a \<in> A; A \<in> P; a \<in> B; B \<in> P \<rbrakk> \<Longrightarrow> A = B"
  using disjoint by blast

text \<open>p 12, ll 9--10\<close>
lemma block_closed [intro]: (* inefficient as a simp rule *)
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> a \<in> S"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
lemma element_exists:
  "A \<in> P \<Longrightarrow> \<exists>a \<in> S. a \<in> A"
  by (metis non_vacuous block_closed all_not_in_conv)

text \<open>p 12, ll 9--10\<close>
definition "Block = (\<lambda>a \<in> S. THE A. a \<in> A \<and> A \<in> P)"

text \<open>p 12, ll 9--10\<close>
lemma Block_closed [intro, simp]:
  assumes [intro]: "a \<in> S" shows "Block a \<in> P"
proof -
  obtain A where "a \<in> A" "A \<in> P" using block_exists by blast
  then show ?thesis
    apply (auto simp: Block_def)
    apply (rule theI2)
      apply (auto dest: block_unique)
    done
qed

text \<open>p 12, ll 9--10\<close>
lemma Block_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Block a = undefined"
  unfolding Block_def by simp

text \<open>p 12, ll 9--10\<close>
lemma Block_self:
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> Block a = A"
  apply (simp add: Block_def block_closed)
  apply (rule the_equality)
   apply (auto dest: block_unique)
  done

text \<open>p 12, ll 10--11\<close>
definition "Equivalence = {(a, b) . \<exists>A \<in> P. a \<in> A \<and> b \<in> A}"

text \<open>p 12, ll 11--12\<close>
theorem equivalence: "equivalence S Equivalence"
proof
  show "Equivalence \<subseteq> S \<times> S" unfolding Equivalence_def using subset by auto
next
  fix a
  assume "a \<in> S"
  then show "(a, a) \<in> Equivalence" unfolding Equivalence_def using complete by auto
next
  fix a and b
  assume "(a, b) \<in> Equivalence"
  then show "(b, a) \<in> Equivalence" unfolding Equivalence_def by auto
next
  fix a and b and c
  assume "(a, b) \<in> Equivalence" "(b, c) \<in> Equivalence"
  then show "(a, c) \<in> Equivalence" unfolding Equivalence_def using disjoint by auto
qed

text \<open>Temporarily introduce equivalence associated to partition.\<close>
text \<open>p 12, ll 12--14\<close>
interpretation equivalence S Equivalence by (rule equivalence)

text \<open>p 12, ll 12--14\<close>
theorem Class_is_Block:
  assumes "a \<in> S" shows "Class a = Block a"
proof -
  from \<open>a \<in> S\<close> and block_exists obtain A where block: "a \<in> A \<and> A \<in> P" by blast
  show ?thesis
    apply (simp add: Block_def Class_def)
    apply (rule theI2)
      apply (rule block)
     apply (metis block block_unique)
    apply (auto dest: block_unique simp: Equivalence_def)
    done
qed

text \<open>p 12, l 14\<close>
lemma Class_equals_Block:
  "Class = Block"
proof
  fix x show "Class x = Block x"
  by (cases "x \<in> S") (auto simp: Class_is_Block)
qed

text \<open>p 12, l 14\<close>
theorem partition_of_equivalence:
  "Partition = P"
  by (auto simp add: Partition_def Class_equals_Block image_iff) (metis Block_self element_exists)

end (* partition *)

context equivalence begin

text \<open>p 12, ll 14--17\<close>
interpretation partition S Partition by (rule partition)

text \<open>p 12, ll 14--17\<close>
theorem equivalence_of_partition:
  "Equivalence = E"
  unfolding Equivalence_def unfolding Partition_def by auto (metis ClassD Class_closed Class_eq)

end (* equivalence *)

text \<open>p 12, l 14\<close>
sublocale partition \<subseteq> equivalence S Equivalence
  rewrites "equivalence.Partition S Equivalence = P" and "equivalence.Class S Equivalence = Block"
    apply (rule equivalence)
   apply (rule partition_of_equivalence)
  apply (rule Class_equals_Block)
  done

text \<open>p 12, ll 14--17\<close>
sublocale equivalence \<subseteq> partition S Partition
  rewrites "partition.Equivalence Partition = E" and "partition.Block S Partition = Class"
    apply (rule partition)
   apply (rule equivalence_of_partition)
  apply (metis equivalence_of_partition partition partition.Class_equals_Block)
  done

text \<open>Unfortunately only effective on input\<close>
text \<open>p 12, ll 18--20\<close>
notation equivalence.Partition (infixl "'/" 75)

context equivalence begin

text \<open>p 12, ll 18--20\<close>
lemma representant_exists [dest]: "A \<in> S / E \<Longrightarrow> \<exists>a\<in>S. a \<in> A \<and> A = Class a"
  by (metis Block_self element_exists)

text \<open>p 12, ll 18--20\<close>
lemma quotient_ClassE: "A \<in> S / E \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> P (Class a)) \<Longrightarrow> P A"
  using representant_exists by blast

end (* equivalence *)

text \<open>p 12, ll 21--23\<close>
sublocale equivalence \<subseteq> natural: surjective_map Class S "S / E"
  by unfold_locales force+

text \<open>Technical device to achieve Jacobson's syntax; context where @{text \<alpha>} is not a parameter.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation_notation = fixes S :: "'a set" begin

text \<open>p 12, ll 25--26\<close>
definition Fiber_Relation ("E'(_')") where "Fiber_Relation \<alpha> = {(x, y). x \<in> S \<and> y \<in> S \<and> \<alpha> x = \<alpha> y}"

end (* fiber_relation_notation *)

text \<open>
  Context where classes and the induced map are defined through the fiber relation.
  This will be the case for monoid homomorphisms but not group homomorphisms.
\<close>
text \<open>Avoids infinite interpretation chain.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation = map begin

text \<open>Install syntax\<close>
text \<open>p 12, ll 25--26\<close>
sublocale fiber_relation_notation .

text \<open>p 12, ll 26--27\<close>
sublocale equivalence where E = "E(\<alpha>)"
  unfolding Fiber_Relation_def by unfold_locales auto

text \<open>``define $\bar{\alpha}$ by $\bar{\alpha}(\bar{a}) = \alpha(a)$''\<close>
text \<open>p 13, ll 8--9\<close>
definition "induced = (\<lambda>A \<in> S / E(\<alpha>). THE b. \<exists>a \<in> A. b = \<alpha> a)"

text \<open>p 13, l 10\<close>
theorem Fiber_equality:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> \<alpha> a = \<alpha> b"
  unfolding Class_equivalence unfolding Fiber_Relation_def by simp

text \<open>p 13, ll 8--9\<close>
theorem induced_Fiber_simp [simp]:
  assumes [intro, simp]: "a \<in> S" shows "induced (Class a) = \<alpha> a"
proof -
  have "(THE b. \<exists>a\<in>Class a. b = \<alpha> a) = \<alpha> a"
    by (rule the_equality) (auto simp: Fiber_equality [symmetric] Block_self block_closed)
  then show ?thesis unfolding induced_def by simp
qed

text \<open>p 13, ll 10--11\<close>
interpretation induced: map induced "S / E(\<alpha>)" T
proof (unfold_locales, rule)
  fix A
  assume [intro, simp]: "A \<in> S / E(\<alpha>)"
  obtain a where a: "a \<in> S" "a \<in> A" using element_exists by auto
  have "(THE b. \<exists>a\<in>A. b = \<alpha> a) \<in> T"
    apply (rule theI2)
    using a apply (auto simp: Fiber_equality [symmetric] Block_self block_closed)
    done
  then show "induced A \<in> T" unfolding induced_def by simp
qed (simp add: induced_def)

text \<open>p 13, ll 12--13\<close>
sublocale induced: injective_map induced "S / E(\<alpha>)" T
proof
  show "inj_on induced Partition"
    unfolding inj_on_def
    by (metis Fiber_equality Block_self element_exists induced_Fiber_simp)
qed

text \<open>p 13, ll 16--19\<close>
theorem factorization_lemma:
  "a \<in> S \<Longrightarrow> compose S induced Class a = \<alpha> a"
  by (simp add: compose_eq)

text \<open>p 13, ll 16--19\<close>
theorem factorization [simp]: "compose S induced Class = \<alpha>"
  by (rule ext) (simp add: compose_def map_undefined)

text \<open>p 14, ll 2--4\<close>
theorem uniqueness:
  assumes map: "\<beta> \<in> S / E(\<alpha>) \<rightarrow>\<^sub>E T"
    and factorization: "compose S \<beta> Class = \<alpha>"
  shows "\<beta> = induced"
proof
  fix A
  show "\<beta> A = induced A"
  proof (cases "A \<in> S / E(\<alpha>)")
    case True
    then obtain a where [simp]: "A = Class a" "a \<in> S" by fast
    then have "\<beta> (Class a) = \<alpha> a" by (metis compose_eq factorization)
    also have "\<dots> = induced (Class a)" by simp
    finally show ?thesis by simp
  qed (simp add: induced_def PiE_arb [OF map])
qed

end (* fiber_relation *)

end


theory Chapter12_5
imports "HOL-IMP.Hoare_Total"
begin

text{*
\exercise
Prove total correctness of the commands in exercises~\ref{exe:Hoare:sumeq} to
\ref{exe:Hoare:sqrt}.
*}

text{*
\endexercise

\exercise
Modify the VCG to take termination into account. First modify type @{text acom}
by annotating  @{text WHILE} with a measure function in addition to an
invariant:
*}
datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile assn "state \<Rightarrow> nat" bexp acom
    ("({_, _}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_,_} WHILE b DO C) = (WHILE b DO strip C)"

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I,f} WHILE b DO C) Q = I"

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
(* your definition/proof here *)

text{*
Functions @{const strip} and @{const pre} remain almost unchanged.
The only significant change is in the @{text WHILE} case for @{const vc}.
Modify the old soundness proof to obtain
*}

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
(* your definition/proof here *)

text{*
You may need the combined soundness and completeness of @{text"\<turnstile>\<^sub>t"}:
@{thm hoaret_sc}
\endexercise
*}

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>LTL (in Negation-Normal-Form, FGXU-Syntax)\<close>

theory LTL_FGXU
  imports Main "HOL-Library.Omega_Words_Fun"
begin

text \<open>Inspired/Based on schimpf/LTL\<close>

subsection \<open>Syntax\<close>

datatype (vars: 'a) ltl  =
    LTLTrue                       ("true")
  | LTLFalse                      ("false")
  | LTLProp 'a                    ("p'(_')")
  | LTLPropNeg 'a                 ("np'(_')" [86] 85)
  | LTLAnd "'a ltl" "'a ltl"      ("_ and _" [83,83] 82)
  | LTLOr "'a ltl" "'a ltl"       ("_ or _" [82,82] 81)
  | LTLNext "'a ltl"              ("X _" [88] 87)
  | LTLGlobal (theG: "'a ltl")    ("G _" [85] 84)
  | LTLFinal "'a ltl"             ("F _" [84] 83)
  | LTLUntil "'a ltl" "'a ltl"    ("_ U _" [87,87] 86)

subsection \<open>Semantics\<close>

fun ltl_semantics :: "['a set word, 'a ltl] \<Rightarrow> bool" (infix "\<Turnstile>" 80)
where
  "w \<Turnstile> true = True"
| "w \<Turnstile> false = False"
| "w \<Turnstile> p(q) = (q \<in> w 0)"
| "w \<Turnstile> np(q) = (q \<notin> w 0)"
| "w \<Turnstile> \<phi> and \<psi> = (w \<Turnstile> \<phi> \<and> w \<Turnstile> \<psi>)"
| "w \<Turnstile> \<phi> or \<psi> = (w \<Turnstile> \<phi> \<or> w \<Turnstile> \<psi>)"
| "w \<Turnstile> X \<phi> = (suffix 1 w \<Turnstile> \<phi>)"
| "w \<Turnstile> G \<phi> = (\<forall>k. suffix k w \<Turnstile> \<phi>)"
| "w \<Turnstile> F \<phi> = (\<exists>k. suffix k w \<Turnstile> \<phi>)"
| "w \<Turnstile> \<phi> U \<psi> = (\<exists>k. suffix k w \<Turnstile> \<psi> \<and> (\<forall>j < k. suffix j w \<Turnstile> \<phi>))"

fun ltl_prop_entailment :: "['a ltl set, 'a ltl] \<Rightarrow> bool" (infix "\<Turnstile>\<^sub>P" 80)
where
  "\<A> \<Turnstile>\<^sub>P true = True"
| "\<A> \<Turnstile>\<^sub>P false = False"
| "\<A> \<Turnstile>\<^sub>P \<phi> and \<psi> = (\<A> \<Turnstile>\<^sub>P \<phi> \<and> \<A> \<Turnstile>\<^sub>P \<psi>)"
| "\<A> \<Turnstile>\<^sub>P \<phi> or \<psi> = (\<A> \<Turnstile>\<^sub>P \<phi> \<or> \<A> \<Turnstile>\<^sub>P \<psi>)"
| "\<A> \<Turnstile>\<^sub>P \<phi> = (\<phi> \<in> \<A>)"

subsubsection \<open>Properties\<close>

lemma LTL_G_one_step_unfolding:
  "w \<Turnstile> G \<phi> \<longleftrightarrow> (w \<Turnstile> \<phi> \<and> w \<Turnstile> X (G \<phi>))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  hence "w \<Turnstile> \<phi>"
    using suffix_0[of w] ltl_semantics.simps(8)[of w \<phi>] by metis
  moreover
  from \<open>?lhs\<close> have "w \<Turnstile> X (G \<phi>)"
    by simp
  ultimately
  show ?rhs by simp
next
  assume ?rhs
  hence "w \<Turnstile> X (G \<phi>)" by simp
  hence "\<forall>k. suffix (k + 1) w \<Turnstile> \<phi>" by force
  hence "\<forall>k > 0. suffix k w \<Turnstile> \<phi>"
    by (metis Suc_eq_plus1 gr0_implies_Suc)
  moreover
  from \<open>?rhs\<close> have "(suffix 0 w) \<Turnstile> \<phi>" by simp
  ultimately
  show ?lhs
    using neq0_conv ltl_semantics.simps(8)[of w \<phi>] by blast
qed

lemma LTL_F_one_step_unfolding:
  "w \<Turnstile> F \<phi> \<longleftrightarrow> (w \<Turnstile> \<phi> \<or> w \<Turnstile> X (F \<phi>))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain k where "suffix k w \<Turnstile> \<phi>" by fastforce
  thus ?rhs by (cases k) auto
next
  assume ?rhs
  thus ?lhs
    using suffix_0[of w] suffix_suffix[of _ 1 w] by (metis ltl_semantics.simps(7) ltl_semantics.simps(9))
qed

lemma LTL_U_one_step_unfolding:
  "w \<Turnstile> \<phi> U \<psi> \<longleftrightarrow> (w \<Turnstile> \<psi> \<or> (w \<Turnstile> \<phi> \<and> w \<Turnstile> X (\<phi> U \<psi>)))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain k where "suffix k w \<Turnstile> \<psi>" and "\<forall>j<k. suffix j w \<Turnstile> \<phi>"
    by force
  thus ?rhs
    by (cases k) auto
next
  assume ?rhs
  thus ?lhs
  proof (cases "w \<Turnstile> \<psi>")
    case False
      hence "w \<Turnstile> \<phi> \<and> w \<Turnstile> X (\<phi> U \<psi>)"
        using \<open>?rhs\<close> by blast
      obtain k where "suffix k (suffix 1 w) \<Turnstile> \<psi>" and "\<forall>j<k. suffix j (suffix 1 w) \<Turnstile> \<phi>"
        using False \<open>?rhs\<close> by force
      moreover
      {
        fix j assume "j < 1 + k"
        hence "suffix j w \<Turnstile> \<phi>"
          using \<open>w \<Turnstile> \<phi> \<and> w \<Turnstile> X (\<phi> U \<psi>)\<close> \<open>\<forall>j<k. suffix j (suffix 1 w) \<Turnstile> \<phi>\<close>[unfolded suffix_suffix]
          by (cases j) simp+
      }
      ultimately
      show ?thesis
        by auto
  qed force
qed

lemma LTL_GF_infinitely_many_suffixes:
  "w \<Turnstile> G (F \<phi>) = (\<exists>\<^sub>\<infinity>i. suffix i w \<Turnstile> \<phi>)"
  (is "?lhs = ?rhs")
proof
  let ?S = "{i | i j. suffix (i + j) w \<Turnstile> \<phi>}"
  let ?S' = "{i + j | i j. suffix (i + j) w \<Turnstile> \<phi>}"

  assume ?lhs
  hence "infinite ?S"
    by auto
  moreover
  have "\<forall>s \<in> ?S. \<exists>s' \<in> ?S'. s \<le> s'"
    by fastforce
  ultimately
  have "infinite ?S'"
    using infinite_nat_iff_unbounded_le le_trans by meson
  moreover
  have "?S' = {k | k. suffix k w \<Turnstile> \<phi>}"
    using monoid_add_class.add.left_neutral by metis
  ultimately
  have "infinite {k | k. suffix k w \<Turnstile> \<phi>}"
    by metis
  thus ?rhs unfolding Inf_many_def by force
next
  assume ?rhs
  {
    fix i
    from \<open>?rhs\<close> obtain k where "i \<le> k" and "suffix k w \<Turnstile> \<phi>"
      using INFM_nat_le[of "\<lambda>n. suffix n w \<Turnstile> \<phi>"] by blast
    then obtain j where "k = i + j"
      using le_iff_add[of i k] by fast
    hence "suffix j (suffix i w) \<Turnstile> \<phi>"
      using \<open>suffix k w \<Turnstile> \<phi>\<close> suffix_suffix by fastforce
    hence "suffix i w \<Turnstile> F \<phi>" by auto
  }
  thus ?lhs by auto
qed

lemma LTL_FG_almost_all_suffixes:
  "w \<Turnstile> F G \<phi> = (\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile> \<phi>)"
  (is "?lhs = ?rhs")
proof
  let ?S = "{k. \<not> suffix k w \<Turnstile> \<phi>}"

  assume ?lhs
  then obtain i where "suffix i w \<Turnstile> G \<phi>"
    by fastforce
  hence "\<And>j. j \<ge> i \<Longrightarrow> (suffix j w \<Turnstile> \<phi>)"
    using le_iff_add[of i] by auto
  hence "\<And>j. \<not>suffix j w \<Turnstile> \<phi> \<Longrightarrow> j < i"
    using le_less_linear by blast
  hence "?S \<subseteq> {k. k < i}"
    by blast
  hence "finite ?S"
    using finite_subset by fast
  thus ?rhs
    unfolding Alm_all_def Inf_many_def by presburger
next
  assume ?rhs
  obtain S where S_def: "S = {k. \<not> suffix k w \<Turnstile> \<phi>}" by blast
  hence "finite S"
    using \<open>?rhs\<close> unfolding Alm_all_def Inf_many_def by fast
  then obtain i where "i = Max S" by blast
  {
    fix j
    assume "i < j"
    hence "j \<notin> S"
      using \<open>i = Max S\<close> Max.coboundedI[OF \<open>finite S\<close>] less_le_not_le by blast
    hence "suffix j w \<Turnstile> \<phi>" using S_def by fast
  }
  hence "\<forall>j > i. (suffix j w \<Turnstile> \<phi>)" by simp
  hence "suffix (Suc i) w \<Turnstile> G \<phi>" by auto
  thus ?lhs
    using ltl_semantics.simps(9)[of w "G \<phi>"] by blast
qed

lemma LTL_FG_suffix:
  "(suffix i w) \<Turnstile> F (G \<phi>) = w \<Turnstile> F (G \<phi>)"
proof -
  have "(\<exists>m. \<forall>n\<ge>m. suffix n w \<Turnstile> \<phi>) = (\<exists>m. \<forall>n\<ge>m. suffix n (suffix i w) \<Turnstile> \<phi>)" (is "?l = ?r")
  proof
    assume ?r
    then obtain m where "\<forall>n\<ge>m. suffix n (suffix i w) \<Turnstile> \<phi>"
      by blast
    hence "\<forall>n\<ge>i+m. suffix n w \<Turnstile> \<phi>"
      unfolding suffix_suffix by (metis le_iff_add add_leE add_le_cancel_left)
    thus ?l
      by auto
  qed (metis suffix_suffix trans_le_add2)
  thus ?thesis
    unfolding LTL_FG_almost_all_suffixes MOST_nat_le ..
qed

lemma LTL_GF_suffix:
  "(suffix i w) \<Turnstile> G (F \<phi>) = w \<Turnstile> G (F \<phi>)"
proof -
  have "(\<forall>m. \<exists>n\<ge>m. suffix n w \<Turnstile> \<phi>) = (\<forall>m. \<exists>n\<ge>m. suffix n (suffix i w) \<Turnstile> \<phi>)" (is "?l = ?r")
  proof
    assume ?l
    thus ?r
      by (metis suffix_suffix add_leE add_le_cancel_left le_Suc_ex)
  qed (metis suffix_suffix trans_le_add2)
  thus ?thesis
    unfolding LTL_GF_infinitely_many_suffixes INFM_nat_le ..
qed

lemma LTL_suffix_G:
  "w \<Turnstile> G \<phi> \<Longrightarrow> suffix i w \<Turnstile> G \<phi>"
  using suffix_0 suffix_suffix by (induction i) simp_all

lemma LTL_prop_entailment_monotonI[intro]:
  "S \<Turnstile>\<^sub>P \<phi> \<Longrightarrow> S \<subseteq> S' \<Longrightarrow> S' \<Turnstile>\<^sub>P \<phi>"
  by (induction rule: ltl_prop_entailment.induct) auto

lemma ltl_models_equiv_prop_entailment:
  "w \<Turnstile> \<phi> = {\<chi>. w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

subsubsection \<open>Limit Behaviour of the G-operator\<close>

abbreviation Only_G
where
  "Only_G S \<equiv> \<forall>x \<in> S. \<exists>y. x = G y"

lemma ltl_G_stabilize:
  assumes "finite \<G>"
  assumes "Only_G \<G>"
  obtains i where "\<And>\<chi> j. \<chi> \<in> \<G> \<Longrightarrow> suffix i w \<Turnstile> \<chi> = suffix (i + j) w \<Turnstile> \<chi>"
proof -
  have "finite \<G> \<Longrightarrow> Only_G \<G> \<Longrightarrow> \<exists>i. \<forall>\<chi> \<in> \<G>. \<forall>j. suffix i w \<Turnstile> \<chi> = suffix (i + j) w \<Turnstile> \<chi>"
  proof (induction rule: finite_induct)
    case (insert \<chi> \<G>)
      then obtain i\<^sub>1  where "\<And>\<chi> j. \<chi> \<in> \<G> \<Longrightarrow> suffix i\<^sub>1 w \<Turnstile> \<chi> = suffix (i\<^sub>1 + j) w \<Turnstile> \<chi>"
        by blast
      moreover
      from insert obtain \<psi> where "\<chi> = G \<psi>"
        by blast
      have "\<exists>i. \<forall>j. suffix i w \<Turnstile> G \<psi> = suffix (i + j) w \<Turnstile> G \<psi>"
        by (metis LTL_suffix_G plus_nat.add_0 suffix_0 suffix_suffix)
      then obtain i\<^sub>2 where "\<And>j. suffix i\<^sub>2 w \<Turnstile> \<chi> = suffix (i\<^sub>2 + j) w \<Turnstile> \<chi>"
        unfolding \<open>\<chi> = G \<psi>\<close> by blast
      ultimately
      have "\<And>\<chi>' j. \<chi>' \<in> \<G> \<union> {\<chi>} \<Longrightarrow> suffix (i\<^sub>1 + i\<^sub>2) w \<Turnstile> \<chi>' = suffix (i\<^sub>1 + i\<^sub>2 + j) w \<Turnstile> \<chi>'"
        unfolding Un_iff singleton_iff by (metis add.commute add.left_commute)
      thus ?case
        by blast
  qed simp
  with assms obtain i where "\<And>\<chi> j. \<chi> \<in> \<G> \<Longrightarrow> suffix i w \<Turnstile> \<chi> = suffix (i + j) w \<Turnstile> \<chi>"
    by blast
  thus ?thesis
    using that by blast
qed

lemma ltl_G_stabilize_property:
  assumes "finite \<G>"
  assumes "Only_G \<G>"
  assumes "\<And>\<chi> j. \<chi> \<in> \<G> \<Longrightarrow> suffix i w \<Turnstile> \<chi> = suffix (i + j) w \<Turnstile> \<chi>"
  assumes "G \<psi> \<in> \<G> \<inter> {\<chi>. w \<Turnstile> F \<chi>}"
  shows "suffix i w \<Turnstile> G \<psi>"
proof -
  obtain j where "suffix j w \<Turnstile> G \<psi>"
    using assms by fastforce
  thus "suffix i w \<Turnstile> G \<psi>"
    by (cases "i \<le> j", insert assms, unfold le_iff_add, blast,
        metis (erased, lifting) LTL_suffix_G \<open>suffix j w \<Turnstile> G \<psi>\<close> le_add_diff_inverse nat_le_linear suffix_suffix)
qed

subsection \<open>Subformulae\<close>

subsubsection \<open>Propositions\<close>

fun propos :: "'a ltl \<Rightarrow>'a ltl set"
where
  "propos true = {}"
| "propos false = {}"
| "propos (\<phi> and \<psi>) = propos \<phi> \<union> propos \<psi>"
| "propos (\<phi> or \<psi>) = propos \<phi> \<union> propos \<psi>"
| "propos \<phi> = {\<phi>}"

fun nested_propos :: "'a ltl \<Rightarrow>'a ltl set"
where
  "nested_propos true = {}"
| "nested_propos false = {}"
| "nested_propos (\<phi> and \<psi>) = nested_propos \<phi> \<union> nested_propos \<psi>"
| "nested_propos (\<phi> or \<psi>) = nested_propos \<phi> \<union> nested_propos \<psi>"
| "nested_propos (F \<phi>) = {F \<phi>} \<union> nested_propos \<phi>"
| "nested_propos (G \<phi>) = {G \<phi>} \<union> nested_propos \<phi>"
| "nested_propos (X \<phi>) = {X \<phi>} \<union> nested_propos \<phi>"
| "nested_propos (\<phi> U \<psi>) = {\<phi> U \<psi>} \<union> nested_propos \<phi> \<union> nested_propos \<psi>"
| "nested_propos \<phi> = {\<phi>}"

lemma finite_propos:
  "finite (propos \<phi>)" "finite (nested_propos \<phi>)"
  by (induction \<phi>) simp+

lemma propos_subset:
  "propos \<phi> \<subseteq> nested_propos \<phi>"
  by (induction \<phi>) auto

lemma LTL_prop_entailment_restrict_to_propos:
  "S \<Turnstile>\<^sub>P \<phi> = (S \<inter> propos \<phi>) \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) auto

lemma propos_foldl:
  assumes "\<And>x y. propos (f x y) = propos x \<union> propos y"
  shows "\<Union>{propos y |y. y = i \<or> y \<in> set xs} = propos (foldl f i xs)"
proof (induction xs rule: rev_induct)
  case (snoc x xs)
    have "\<Union>{propos y |y. y = i \<or> y \<in> set (xs@[x])} = \<Union>{propos y |y. y = i \<or> y \<in> set xs} \<union> propos x"
      by auto
    also
    have "\<dots> = propos (foldl f i xs) \<union> propos x"
      using snoc by auto
    also
    have "\<dots> = propos (foldl f i (xs@[x]))"
      using assms by simp
    finally
    show ?case .
qed simp

subsubsection \<open>G-Subformulae\<close>

text \<open>Notation for paper: mathds{G}\<close>

fun G_nested_propos :: "'a ltl \<Rightarrow>'a ltl set" ("\<^bold>G")
where
  "\<^bold>G (\<phi> and \<psi>) = \<^bold>G \<phi> \<union> \<^bold>G \<psi>"
| "\<^bold>G (\<phi> or \<psi>) = \<^bold>G \<phi> \<union> \<^bold>G \<psi>"
| "\<^bold>G (F \<phi>) = \<^bold>G \<phi>"
| "\<^bold>G (G \<phi>) = \<^bold>G \<phi> \<union> {G \<phi>}"
| "\<^bold>G (X \<phi>) = \<^bold>G \<phi>"
| "\<^bold>G (\<phi> U \<psi>) = \<^bold>G \<phi> \<union> \<^bold>G \<psi>"
| "\<^bold>G \<phi> = {}"

lemma G_nested_finite:
  "finite (\<^bold>G \<phi>)"
  by (induction \<phi>) auto

lemma G_nested_propos_alt_def:
  "\<^bold>G \<phi> = nested_propos \<phi> \<inter> {\<psi>. (\<exists>x. \<psi> = G x)}"
  by (induction \<phi>) auto

lemma G_nested_propos_Only_G:
  "Only_G (\<^bold>G \<phi>)"
  unfolding G_nested_propos_alt_def by blast

lemma G_not_in_G:
  "G \<phi> \<notin> \<^bold>G \<phi>"
proof -
  have "\<And>\<chi>. \<chi> \<in> \<^bold>G \<phi> \<Longrightarrow> size \<phi> \<ge> size \<chi>"
    by (induction \<phi>) fastforce+
  thus ?thesis
    by fastforce
qed

lemma G_subset_G:
  "\<psi> \<in> \<^bold>G \<phi> \<Longrightarrow> \<^bold>G \<psi> \<subseteq> \<^bold>G \<phi>"
  "G \<psi> \<in> \<^bold>G \<phi> \<Longrightarrow> \<^bold>G \<psi> \<subseteq> \<^bold>G \<phi>"
  by (induction \<phi>) auto

lemma \<G>_properties:
  assumes "\<G> \<subseteq> \<^bold>G \<phi>"
  shows \<G>_finite: "finite \<G>" and \<G>_elements: "Only_G \<G>"
  using assms G_nested_finite G_nested_propos_alt_def by (blast dest: finite_subset)+

subsection \<open>Propositional Implication and Equivalence\<close>

definition ltl_prop_implies :: "['a ltl, 'a ltl] \<Rightarrow> bool" (infix "\<longrightarrow>\<^sub>P" 75)
where
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<equiv> \<forall>\<A>. \<A> \<Turnstile>\<^sub>P \<phi> \<longrightarrow> \<A> \<Turnstile>\<^sub>P \<psi>"

definition ltl_prop_equiv :: "['a ltl, 'a ltl] \<Rightarrow> bool" (infix "\<equiv>\<^sub>P" 75)
where
  "\<phi> \<equiv>\<^sub>P \<psi> \<equiv> \<forall>\<A>. \<A> \<Turnstile>\<^sub>P \<phi> \<longleftrightarrow> \<A> \<Turnstile>\<^sub>P \<psi>"

lemma ltl_prop_implies_equiv:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<and> \<psi> \<longrightarrow>\<^sub>P \<phi> \<longleftrightarrow> \<phi> \<equiv>\<^sub>P \<psi>"
  unfolding ltl_prop_implies_def ltl_prop_equiv_def by meson

lemma ltl_prop_equiv_equivp:
  "equivp (\<equiv>\<^sub>P)"
  by (blast intro: equivpI[of "(\<equiv>\<^sub>P)", simplified transp_def symp_def reflp_def ltl_prop_equiv_def])

lemma [trans]:
  "\<phi> \<equiv>\<^sub>P \<psi> \<Longrightarrow> \<psi> \<equiv>\<^sub>P \<chi> \<Longrightarrow> \<phi> \<equiv>\<^sub>P \<chi>"
  using ltl_prop_equiv_equivp[THEN equivp_transp] .

subsubsection \<open>Quotient Type for Propositional Equivalence\<close>

quotient_type 'a ltl_prop_equiv_quotient = "'a ltl" / "(\<equiv>\<^sub>P)"
  morphisms Rep Abs
  by (simp add: ltl_prop_equiv_equivp)

type_synonym 'a ltl\<^sub>P = "'a ltl_prop_equiv_quotient"

instantiation ltl_prop_equiv_quotient :: (type) equal begin

lift_definition ltl_prop_equiv_quotient_eq_test :: "'a ltl\<^sub>P \<Rightarrow> 'a ltl\<^sub>P \<Rightarrow> bool" is "\<lambda>x y. x \<equiv>\<^sub>P y"
  by (metis ltl_prop_equiv_quotient.abs_eq_iff)

definition
  eq: "equal_class.equal \<equiv> ltl_prop_equiv_quotient_eq_test"

instance
  by (standard; simp add: eq ltl_prop_equiv_quotient_eq_test.rep_eq, metis Quotient_ltl_prop_equiv_quotient Quotient_rel_rep)

end

lemma ltl\<^sub>P_abs_rep: "Abs (Rep \<phi>) = \<phi>"
  by (meson Quotient3_abs_rep Quotient3_ltl_prop_equiv_quotient)

lift_definition ltl_prop_entails_abs :: "'a ltl set \<Rightarrow> 'a ltl\<^sub>P \<Rightarrow> bool" ("_ \<up>\<Turnstile>\<^sub>P _") is "(\<Turnstile>\<^sub>P)"
  by (simp add: ltl_prop_equiv_def)

lift_definition ltl_prop_implies_abs :: "'a ltl\<^sub>P \<Rightarrow> 'a ltl\<^sub>P \<Rightarrow> bool" ("_ \<up>\<longrightarrow>\<^sub>P _") is "(\<longrightarrow>\<^sub>P)"
  by (simp add: ltl_prop_equiv_def ltl_prop_implies_def)

subsubsection \<open>Propositional Equivalence implies LTL Equivalence\<close>

lemma ltl_prop_implication_implies_ltl_implication:
  "w \<Turnstile> \<phi> \<Longrightarrow> \<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> w \<Turnstile> \<psi>"
  using [[unfold_abs_def = false]]
  unfolding ltl_prop_implies_def ltl_models_equiv_prop_entailment by simp

lemma ltl_prop_equiv_implies_ltl_equiv:
  "\<phi> \<equiv>\<^sub>P \<psi> \<Longrightarrow> w \<Turnstile> \<phi> = w \<Turnstile> \<psi>"
  using ltl_prop_implication_implies_ltl_implication ltl_prop_implies_equiv by blast

subsection \<open>Substitution\<close>

fun subst :: "'a ltl \<Rightarrow> ('a ltl \<rightharpoonup> 'a ltl) \<Rightarrow> 'a ltl"
where
  "subst true m = true"
| "subst false m = false"
| "subst (\<phi> and \<psi>) m = subst \<phi> m and subst \<psi> m"
| "subst (\<phi> or \<psi>) m = subst \<phi> m or subst \<psi> m"
| "subst \<phi> m = (case m \<phi> of Some \<phi>' \<Rightarrow> \<phi>' | None \<Rightarrow> \<phi>)"

text \<open>Based on Uwe Schoening's Translation Lemma (Logic for CS, p. 54)\<close>

lemma ltl_prop_equiv_subst_S:
  "S \<Turnstile>\<^sub>P subst \<phi> m = ((S - dom m) \<union> {\<chi> | \<chi> \<chi>'. \<chi> \<in> dom m \<and> m \<chi> = Some \<chi>' \<and> S \<Turnstile>\<^sub>P \<chi>'}) \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>) (auto split: option.split)

lemma subst_respects_ltl_prop_entailment:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> subst \<phi> m \<longrightarrow>\<^sub>P subst \<psi> m"
  "\<phi> \<equiv>\<^sub>P \<psi> \<Longrightarrow> subst \<phi> m \<equiv>\<^sub>P subst \<psi> m"
  unfolding ltl_prop_equiv_def ltl_prop_implies_def ltl_prop_equiv_subst_S by blast+

lemma subst_respects_ltl_prop_entailment_generalized:
  "(\<And>\<A>. (\<And>x. x \<in> S \<Longrightarrow> \<A> \<Turnstile>\<^sub>P x) \<Longrightarrow> \<A> \<Turnstile>\<^sub>P y) \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> \<A> \<Turnstile>\<^sub>P subst x m) \<Longrightarrow> \<A> \<Turnstile>\<^sub>P subst y m"
  unfolding ltl_prop_equiv_subst_S by simp

lemma decomposable_function_subst:
  "\<lbrakk>f true = true; f false = false; \<And>\<phi> \<psi>. f (\<phi> and \<psi>) = f \<phi> and f \<psi>; \<And>\<phi> \<psi>. f (\<phi> or \<psi>) = f \<phi> or f \<psi>\<rbrakk> \<Longrightarrow> f \<phi> = subst \<phi> (\<lambda>\<chi>. Some (f \<chi>))"
  by (induction \<phi>) auto

subsection \<open>Additional Operators\<close>

subsubsection \<open>And\<close>

lemma foldl_LTLAnd_prop_entailment:
  "S \<Turnstile>\<^sub>P foldl LTLAnd i xs = (S \<Turnstile>\<^sub>P i \<and> (\<forall>y \<in> set xs. S \<Turnstile>\<^sub>P y))"
  by (induction xs arbitrary: i) auto

fun And :: "'a ltl list \<Rightarrow> 'a ltl"
where
  "And [] = true"
| "And (x#xs) = foldl LTLAnd x xs"

lemma And_prop_entailment:
  "S \<Turnstile>\<^sub>P And xs = (\<forall>x \<in> set xs. S \<Turnstile>\<^sub>P x)"
  using foldl_LTLAnd_prop_entailment by (cases xs) auto

lemma And_propos:
  "propos (And xs) = \<Union>{propos x| x. x \<in> set xs}"
proof (cases xs)
  case Nil
    thus ?thesis by simp
next
  case (Cons x xs)
    thus ?thesis
      using propos_foldl[of LTLAnd x] by auto
qed

lemma And_semantics:
  "w \<Turnstile> And xs = (\<forall>x \<in> set xs. w \<Turnstile> x)"
proof -
  have And_propos': "\<And>x. x \<in> set xs \<Longrightarrow> propos x \<subseteq> propos (And xs)"
    using And_propos by blast

  have "w \<Turnstile> And xs = {\<chi>. \<chi> \<in> propos (And xs) \<and> w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P (And xs)"
    using ltl_models_equiv_prop_entailment LTL_prop_entailment_restrict_to_propos by blast
  also
  have "\<dots> = (\<forall>x \<in> set xs. {\<chi>. \<chi> \<in> propos (And xs) \<and> w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P x)"
    using And_prop_entailment by auto
  also
  have "\<dots> = (\<forall>x \<in> set xs. {\<chi>. \<chi> \<in> propos x \<and> w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P x)"
    using LTL_prop_entailment_restrict_to_propos And_propos' by blast
  also
  have "\<dots> = (\<forall>x \<in> set xs. w \<Turnstile> x)"
    using ltl_models_equiv_prop_entailment LTL_prop_entailment_restrict_to_propos by blast
  finally
  show ?thesis .
qed

lemma And_append_syntactic:
  "xs \<noteq> [] \<Longrightarrow> And (xs @ ys) = And ((And xs)#ys)"
  by (induction xs rule: list_nonempty_induct) simp+

lemma And_append_S:
  "S \<Turnstile>\<^sub>P And (xs @ ys) = S \<Turnstile>\<^sub>P And xs and And ys"
  using And_prop_entailment[of S] by auto

lemma And_append:
  "And (xs @ ys) \<equiv>\<^sub>P And xs and And ys"
  unfolding ltl_prop_equiv_def using And_append_S by blast

subsubsection \<open>Lifted Variant\<close>

lift_definition and_abs :: "'a ltl\<^sub>P \<Rightarrow> 'a ltl\<^sub>P \<Rightarrow> 'a ltl\<^sub>P" ("_ \<up>and _") is "\<lambda>x y. x and y"
  unfolding ltl_prop_equiv_def by simp

fun And_abs :: "'a ltl\<^sub>P list \<Rightarrow> 'a ltl\<^sub>P" ("\<up>And")
where
  "\<up>And xs = foldl and_abs (Abs true) xs"

lemma foldl_LTLAnd_prop_entailment_abs:
  "S \<up>\<Turnstile>\<^sub>P foldl and_abs i xs = (S \<up>\<Turnstile>\<^sub>P i \<and> (\<forall>y\<in>set xs. S \<up>\<Turnstile>\<^sub>P y))"
  by (induction xs arbitrary: i)
     (simp_all add: and_abs_def ltl_prop_entails_abs.abs_eq, metis ltl_prop_entails_abs.rep_eq)

lemma And_prop_entailment_abs:
  "S \<up>\<Turnstile>\<^sub>P \<up>And xs = (\<forall>x \<in> set xs. S \<up>\<Turnstile>\<^sub>P x)"
  by (simp add: foldl_LTLAnd_prop_entailment_abs ltl_prop_entails_abs.abs_eq)

lemma and_abs_conjunction:
  "S \<up>\<Turnstile>\<^sub>P \<phi> \<up>and \<psi> \<longleftrightarrow> S \<up>\<Turnstile>\<^sub>P \<phi> \<and> S \<up>\<Turnstile>\<^sub>P \<psi>"
  by (metis and_abs.abs_eq ltl\<^sub>P_abs_rep ltl_prop_entailment.simps(3) ltl_prop_entails_abs.abs_eq)

subsubsection \<open>Or\<close>

lemma foldl_LTLOr_prop_entailment:
  "S \<Turnstile>\<^sub>P foldl LTLOr i xs = (S \<Turnstile>\<^sub>P i \<or> (\<exists>y \<in> set xs. S \<Turnstile>\<^sub>P y))"
  by (induction xs arbitrary: i) auto

fun Or :: "'a ltl list \<Rightarrow> 'a ltl"
where
  "Or [] = false"
| "Or (x#xs) = foldl LTLOr x xs"

lemma Or_prop_entailment:
  "S \<Turnstile>\<^sub>P Or xs = (\<exists>x \<in> set xs. S \<Turnstile>\<^sub>P x)"
  using foldl_LTLOr_prop_entailment by (cases xs) auto

lemma Or_propos:
  "propos (Or xs) = \<Union>{propos x| x. x \<in> set xs}"
proof (cases xs)
  case Nil
    thus ?thesis by simp
next
  case (Cons x xs)
    thus ?thesis
      using propos_foldl[of LTLOr x] by auto
qed

lemma Or_semantics:
  "w \<Turnstile> Or xs = (\<exists>x \<in> set xs. w \<Turnstile> x)"
proof -
  have Or_propos': "\<And>x. x \<in> set xs \<Longrightarrow> propos x \<subseteq> propos (Or xs)"
    using Or_propos by blast

  have "w \<Turnstile> Or xs = {\<chi>. \<chi> \<in> propos (Or xs) \<and> w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P (Or xs)"
    using ltl_models_equiv_prop_entailment LTL_prop_entailment_restrict_to_propos by blast
  also
  have "\<dots> = (\<exists>x \<in> set xs. {\<chi>. \<chi> \<in> propos (Or xs) \<and> w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P x)"
    using Or_prop_entailment by auto
  also
  have "\<dots> = (\<exists>x \<in> set xs. {\<chi>. \<chi> \<in> propos x \<and> w \<Turnstile> \<chi>} \<Turnstile>\<^sub>P x)"
    using LTL_prop_entailment_restrict_to_propos Or_propos' by blast
  also
  have "\<dots> = (\<exists>x \<in> set xs. w \<Turnstile> x)"
    using ltl_models_equiv_prop_entailment LTL_prop_entailment_restrict_to_propos by blast
  finally
  show ?thesis .
qed

lemma Or_append_syntactic:
  "xs \<noteq> [] \<Longrightarrow> Or (xs @ ys) = Or ((Or xs)#ys)"
  by (induction xs rule: list_nonempty_induct) simp+

lemma Or_append_S:
  "S \<Turnstile>\<^sub>P Or (xs @ ys) = S \<Turnstile>\<^sub>P Or xs or Or ys"
  using Or_prop_entailment[of S] by auto

lemma Or_append:
  "Or (xs @ ys) \<equiv>\<^sub>P Or xs or Or ys"
  unfolding ltl_prop_equiv_def using Or_append_S by blast

subsubsection \<open>$eval_G$\<close>

\<comment> \<open>Partly evaluate a formula by only considering G-subformulae\<close>

fun eval\<^sub>G
where
  "eval\<^sub>G S (\<phi> and \<psi>) = eval\<^sub>G S \<phi> and eval\<^sub>G S \<psi>"
| "eval\<^sub>G S (\<phi> or \<psi>) = eval\<^sub>G S \<phi> or eval\<^sub>G S \<psi>"
| "eval\<^sub>G S (G \<phi>) = (if G \<phi> \<in> S then true else false)"
| "eval\<^sub>G S \<phi> = \<phi>"

\<comment> \<open>Syntactic Properties\<close>

lemma eval\<^sub>G_And_map:
  "eval\<^sub>G S (And xs) = And (map (eval\<^sub>G S) xs)"
proof (induction xs rule: rev_induct)
  case (snoc x xs)
    thus ?case
      by (cases xs) simp+
qed simp

lemma eval\<^sub>G_Or_map:
  "eval\<^sub>G S (Or xs) = Or (map (eval\<^sub>G S) xs)"
proof (induction xs rule: rev_induct)
  case (snoc x xs)
    thus ?case
      by (cases xs) simp+
qed simp

lemma eval\<^sub>G_G_nested:
  "\<^bold>G (eval\<^sub>G \<G> \<phi>) \<subseteq> \<^bold>G \<phi>"
  by (induction \<phi>) (simp_all, blast+)

lemma eval\<^sub>G_subst:
  "eval\<^sub>G S \<phi> = subst \<phi> (\<lambda>\<chi>. Some (eval\<^sub>G S \<chi>))"
  by (induction \<phi>) simp_all

\<comment> \<open>Semantic Properties\<close>

lemma eval\<^sub>G_prop_entailment:
  "S \<Turnstile>\<^sub>P eval\<^sub>G S \<phi> \<longleftrightarrow> S \<Turnstile>\<^sub>P \<phi>"
  by (induction \<phi>, auto)

lemma eval\<^sub>G_respectfulness:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> eval\<^sub>G S \<phi> \<longrightarrow>\<^sub>P eval\<^sub>G S \<psi>"
  "\<phi> \<equiv>\<^sub>P \<psi> \<Longrightarrow> eval\<^sub>G S \<phi> \<equiv>\<^sub>P eval\<^sub>G S \<psi>"
  using subst_respects_ltl_prop_entailment eval\<^sub>G_subst by metis+

lemma eval\<^sub>G_respectfulness_generalized:
  "(\<And>\<A>. (\<And>x. x \<in> S \<Longrightarrow> \<A> \<Turnstile>\<^sub>P x) \<Longrightarrow> \<A> \<Turnstile>\<^sub>P y) \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> \<A> \<Turnstile>\<^sub>P eval\<^sub>G P x) \<Longrightarrow> \<A> \<Turnstile>\<^sub>P eval\<^sub>G P y"
  using subst_respects_ltl_prop_entailment_generalized[of S y \<A>] eval\<^sub>G_subst[of P] by metis

lift_definition eval\<^sub>G_abs :: "'a ltl set \<Rightarrow> 'a ltl\<^sub>P \<Rightarrow> 'a ltl\<^sub>P" ("\<up>eval\<^sub>G") is eval\<^sub>G
  by (insert eval\<^sub>G_respectfulness(2))

subsection \<open>Finite Quotient Set\<close>

text \<open>If we restrict formulas to a finite set of propositions, the set of quotients of these is finite\<close>

lemma Rep_Abs_prop_entailment[simp]:
  "A \<Turnstile>\<^sub>P Rep (Abs \<phi>) = A \<Turnstile>\<^sub>P \<phi>"
  using Quotient3_ltl_prop_equiv_quotient[THEN rep_abs_rsp]
  by (auto simp add: ltl_prop_equiv_def)

fun sat_models :: "'a ltl_prop_equiv_quotient \<Rightarrow> 'a ltl set set"
where
  "sat_models a = {A. A \<Turnstile>\<^sub>P Rep(a)}"

lemma sat_models_invariant:
  "A \<in> sat_models (Abs \<phi>) = A \<Turnstile>\<^sub>P \<phi>"
  using Rep_Abs_prop_entailment by auto

lemma sat_models_inj:
  "inj sat_models"
  using Quotient3_ltl_prop_equiv_quotient[THEN Quotient3_rel_rep]
  by (auto simp add: ltl_prop_equiv_def inj_on_def)

lemma sat_models_finite_image:
  assumes "finite P"
  shows "finite (sat_models ` {Abs \<phi> | \<phi>. nested_propos \<phi> \<subseteq> P})"
proof -
  have "sat_models (Abs \<phi>) = {A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P}" (is "?lhs = ?rhs")
    if "nested_propos \<phi> \<subseteq> P" for \<phi>
  proof
    have "\<And>A B. A \<in> sat_models (Abs \<phi>) \<Longrightarrow> A \<union> B \<in> sat_models (Abs \<phi>)"
      unfolding sat_models_invariant by blast
    moreover
    have "{A | A. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi>} \<subseteq> sat_models (Abs \<phi>)"
      using sat_models_invariant by fast
    ultimately
    show "?rhs \<subseteq> ?lhs"
      by blast
  next
    have "propos \<phi> \<subseteq> P"
      using that propos_subset by blast
    have "A \<in> {A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P}"
      if "A \<in> sat_models (Abs \<phi>)" for A
    proof (standard, goal_cases prems)
      case prems
        then have "A \<Turnstile>\<^sub>P \<phi>"
          using that sat_models_invariant by blast
        then obtain C D where "C = (A \<inter> P)" and "D = A - P" and "A = C \<union> D"
          by blast
        then have "C \<Turnstile>\<^sub>P \<phi>" and "C \<subseteq> P" and "D \<subseteq> UNIV - P"
          using \<open>A \<Turnstile>\<^sub>P \<phi>\<close> LTL_prop_entailment_restrict_to_propos \<open>propos \<phi> \<subseteq> P\<close> by blast+
        then have "C \<union> D \<in> {A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P}"
          by blast
        thus ?case
          using \<open>A = C \<union> D\<close> by simp
    qed
    thus "?lhs \<subseteq> ?rhs"
      by blast
  qed
  hence Equal: "{sat_models (Abs \<phi>) | \<phi>. nested_propos \<phi> \<subseteq> P} = {{A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P} | \<phi>. nested_propos \<phi> \<subseteq> P}"
    by (metis (lifting, no_types))

  have Finite: "finite {{A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P} | \<phi>. nested_propos \<phi> \<subseteq> P}"
  proof -
    let ?map = "\<lambda>P S. {A \<union> B | A B. A \<in> S \<and> B \<subseteq> UNIV - P}"
    obtain S' where S'_def: "S' = {{A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P} | \<phi>. nested_propos \<phi> \<subseteq> P}"
      by blast
    obtain S where S_def: "S = {{A | A. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi>} | \<phi>. nested_propos \<phi> \<subseteq> P}"
      by blast

    \<comment> \<open>Prove S and ?map applied to it is finite\<close>
    hence "S \<subseteq> Pow (Pow P)"
      by blast
    hence "finite S"
      using \<open>finite P\<close> finite_Pow_iff infinite_super by fast
    hence "finite {?map P A | A. A \<in> S}"
      by fastforce

    \<comment> \<open>Prove that S' can be embedded into S using ?map\<close>

    have "S' \<subseteq> {?map P A | A. A \<in> S}"
    proof
      fix A
      assume "A \<in> S'"
      then obtain \<phi> where "nested_propos \<phi> \<subseteq> P"
        and "A = {A \<union> B | A B. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi> \<and> B \<subseteq> UNIV - P}"
        using S'_def by blast
      then have "?map P {A | A. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi>} = A"
        by simp
      moreover
      have "{A | A. A \<subseteq> P \<and> A \<Turnstile>\<^sub>P \<phi>} \<in> S"
        using \<open>nested_propos \<phi> \<subseteq> P\<close> S_def by auto
      ultimately
      show "A \<in> {?map P A | A. A \<in> S}"
        by blast
    qed

    show ?thesis
      using rev_finite_subset[OF \<open>finite {?map P A | A. A \<in> S}\<close> \<open>S' \<subseteq> {?map P A | A. A \<in> S}\<close>]
      unfolding S'_def .
  qed

  have Finite2: "finite {sat_models (Abs \<phi>) | \<phi>. nested_propos \<phi> \<subseteq> P}"
    unfolding Equal using Finite by blast
  have Equal2: "sat_models ` {Abs \<phi> | \<phi>. nested_propos \<phi> \<subseteq> P} = {sat_models (Abs \<phi>) | \<phi>. nested_propos \<phi> \<subseteq> P}"
    by blast

  show ?thesis
    unfolding Equal2 using Finite2 by blast
qed

lemma ltl_prop_equiv_quotient_restricted_to_P_finite:
  assumes "finite P"
  shows "finite {Abs \<phi> | \<phi>. nested_propos \<phi> \<subseteq> P}"
proof -
  have "inj_on sat_models {Abs \<phi> |\<phi>. nested_propos \<phi> \<subseteq> P}"
    using sat_models_inj subset_inj_on by auto
  thus ?thesis
    using finite_imageD[OF sat_models_finite_image[OF assms]] by fast
qed

locale lift_ltl_transformer =
  fixes
    f :: "'a ltl \<Rightarrow> 'b \<Rightarrow> 'a ltl"
  assumes
    respectfulness: "\<phi> \<equiv>\<^sub>P \<psi> \<Longrightarrow> f \<phi> \<nu> \<equiv>\<^sub>P f \<psi> \<nu>"
  assumes
    nested_propos_bounded: "nested_propos (f \<phi> \<nu>) \<subseteq> nested_propos \<phi>"
begin

lift_definition f_abs :: "'a ltl\<^sub>P \<Rightarrow> 'b \<Rightarrow> 'a ltl\<^sub>P" is f
  using respectfulness .

lift_definition f_foldl_abs :: "'a ltl\<^sub>P \<Rightarrow> 'b list \<Rightarrow> 'a ltl\<^sub>P" is "foldl f"
proof -
  fix \<phi> \<psi> :: "'a ltl" fix w :: "'b list" assume "\<phi> \<equiv>\<^sub>P \<psi>"
  thus "foldl f \<phi> w \<equiv>\<^sub>P foldl f \<psi> w"
    using respectfulness by (induction w arbitrary: \<phi> \<psi>) simp+
qed

lemma f_foldl_abs_alt_def:
  "f_foldl_abs (Abs \<phi>) w = foldl f_abs (Abs \<phi>) w"
  by (induction w rule: rev_induct) (unfold f_foldl_abs.abs_eq foldl.simps foldl_append, (metis f_abs.abs_eq)+)

definition abs_reach :: "'a ltl_prop_equiv_quotient \<Rightarrow> 'a ltl_prop_equiv_quotient set"
where
  "abs_reach \<Phi> = {foldl f_abs \<Phi> w |w. True}"

lemma finite_abs_reach:
  "finite (abs_reach (Abs \<phi>))"
proof -
  {
    fix w
    have "nested_propos (foldl f \<phi> w) \<subseteq> nested_propos \<phi>"
      by (induction w arbitrary: \<phi>) (simp, metis foldl_Cons nested_propos_bounded subset_trans)
  }
  hence "abs_reach (Abs \<phi>) \<subseteq> {Abs \<chi> | \<chi>. nested_propos \<chi> \<subseteq> nested_propos \<phi>}"
    unfolding abs_reach_def f_foldl_abs_alt_def[symmetric] f_foldl_abs.abs_eq by blast
  thus ?thesis
    using ltl_prop_equiv_quotient_restricted_to_P_finite finite_propos
    by (blast dest: finite_subset)
qed

end

end