(*  Author: Tobias Nipkow  *)

header{* Isomorphisms Between Plane Graphs *}

theory PlaneGraphIso
imports Main Quasi_Order
begin

(* FIXME globalize *)
lemma image_image_id_if[simp]: "(!!x. f(f x) = x) \<Longrightarrow> f ` f ` M = M"
by (auto simp: image_iff)

declare not_None_eq [iff] not_Some_eq [iff]

text{* The symbols @{text "\<cong>"} and @{text "\<simeq>"} are overloaded.  They
denote congruence and isomorphism on arbitrary types. On lists
(representing faces of graphs), @{text "\<cong>"} means congruence modulo
rotation; @{text "\<simeq>"} is currently unused. On graphs, @{text "\<simeq>"}
means isomorphism and is a weaker version of @{text "\<cong>"} (proper
isomorphism): @{text "\<simeq>"} also allows to reverse the orientation of
all faces. *}

consts
 pr_isomorphic  :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<cong>" 60)
(* isomorphic :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<simeq>" 60)
*)
(*
definition "congs"  :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infix "\<cong>" 60) where
 "F\<^sub>1 \<cong> (F\<^sub>2::'a list) \<equiv> \<exists>n. F\<^sub>2 = rotate n F\<^sub>1"
*)
definition Iso :: "('a list * 'a list) set" ("{\<cong>}") where
 "{\<cong>} \<equiv> {(F\<^sub>1, F\<^sub>2). F\<^sub>1 \<cong> F\<^sub>2}"

text{* A plane graph is a set or list (for executability) of faces
(hence @{text Fgraph} and @{text fgraph}) and a face is a list of
nodes: *}

type_synonym 'a Fgraph = "'a list set"
type_synonym 'a fgraph = "'a list list"

subsection{* Equivalence of faces *}

text{* Two faces are equivalent modulo rotation: *}

defs (overloaded) congs_def:
 "F\<^sub>1 \<cong> (F\<^sub>2::'a list) \<equiv> \<exists>n. F\<^sub>2 = rotate n F\<^sub>1"

lemma congs_refl[iff]: "(xs::'a list) \<cong> xs"
apply(simp add:congs_def)
apply(rule_tac x = 0 in exI)
apply (simp)
done

lemma congs_sym: assumes A: "(xs::'a list) \<cong> ys" shows "ys \<cong> xs"
proof (simp add:congs_def)
  let ?l = "length xs"
  from A obtain n where ys: "ys = rotate n xs" by(fastforce simp add:congs_def)
  have "xs = rotate ?l xs" by simp
  also have "\<dots> = rotate (?l - n mod ?l + n mod ?l) xs"
  proof (cases)
    assume "xs = []" thus ?thesis by simp
  next
    assume "xs \<noteq> []"
    hence "n mod ?l < ?l" by simp
    hence "?l = ?l - n mod ?l + n mod ?l" by arith
    thus ?thesis by simp
  qed
  also have "\<dots> = rotate (?l - n mod ?l) (rotate (n mod ?l) xs)"
    by(simp add:rotate_rotate)
  also have "rotate (n mod ?l) xs = rotate n xs"
    by(rule rotate_conv_mod[symmetric])
  finally show "\<exists>m. xs = rotate m ys" by(fastforce simp add:ys)
qed

lemma congs_trans: "(xs::'a list) \<cong> ys \<Longrightarrow> ys \<cong> zs \<Longrightarrow> xs \<cong> zs"
apply(clarsimp simp:congs_def rotate_def)
apply(rename_tac m n)
apply(rule_tac x = "n+m" in exI)
apply (simp add:funpow_add)
done

lemma equiv_EqF: "equiv (UNIV::'a list set) {\<cong>}"
apply(unfold equiv_def sym_def trans_def refl_on_def)
apply(rule conjI)
 apply simp
apply(rule conjI)
 apply(fastforce intro:congs_sym)
apply(fastforce intro:congs_trans)
done

lemma congs_distinct:
  "F\<^sub>1 \<cong> F\<^sub>2 \<Longrightarrow> distinct F\<^sub>2 = distinct F\<^sub>1"
by (auto simp: congs_def)

lemma congs_length:
  "F\<^sub>1 \<cong> F\<^sub>2 \<Longrightarrow> length F\<^sub>2 = length F\<^sub>1"
by (auto simp: congs_def)

lemma congs_pres_nodes: "F\<^sub>1 \<cong> F\<^sub>2 \<Longrightarrow> set F\<^sub>1 = set F\<^sub>2"
by(clarsimp simp:congs_def)

lemma congs_map:
  "F\<^sub>1 \<cong> F\<^sub>2 \<Longrightarrow> map f F\<^sub>1 \<cong> map f F\<^sub>2"
by (auto simp: congs_def rotate_map)

lemma congs_map_eq_iff:
 "inj_on f (set xs \<union> set ys) \<Longrightarrow> (map f xs \<cong> map f ys) = (xs \<cong> ys)"
apply(simp add:congs_def)
apply(rule iffI)
 apply(clarsimp simp: rotate_map)
 apply(drule map_inj_on)
  apply(simp add:Un_commute)
 apply (fastforce)
apply clarsimp
apply(fastforce simp: rotate_map)
done

lemma list_cong_rev_iff[simp]:
  "(rev xs \<cong> rev ys) = (xs \<cong> ys)"
apply(simp add:congs_def rotate_rev)
apply(rule iffI)
 apply fast
apply clarify
apply(cases "length xs = 0")
 apply simp
apply(case_tac "n mod length xs = 0")
 apply(rule_tac x = "n" in exI)
 apply simp
apply(subst rotate_conv_mod)
apply(rule_tac x = "length xs - n mod length xs" in exI)
apply simp
done

lemma singleton_list_cong_eq_iff[simp]:
  "({xs::'a list} // {\<cong>} = {ys} // {\<cong>}) = (xs \<cong> ys)"
by(simp add: eq_equiv_class_iff2[OF equiv_EqF])

subsection{* Homomorphism and isomorphism *}

definition is_pr_Hom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Fgraph \<Rightarrow> 'b Fgraph \<Rightarrow> bool" where
"is_pr_Hom \<phi> Fs\<^sub>1 Fs\<^sub>2 \<equiv> (map \<phi> ` Fs\<^sub>1)//{\<cong>} = Fs\<^sub>2 //{\<cong>}"

definition is_pr_Iso :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Fgraph \<Rightarrow> 'b Fgraph \<Rightarrow> bool" where
"is_pr_Iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<equiv> is_pr_Hom \<phi> Fs\<^sub>1 Fs\<^sub>2 \<and> inj_on \<phi> (\<Union>F \<in> Fs\<^sub>1. set F)"

definition is_pr_iso :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
"is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<equiv> is_pr_Iso \<phi> (set Fs\<^sub>1) (set Fs\<^sub>2)"

text{* Homomorphisms preserve the set of nodes. *}

lemma UN_subset_iff: "((\<Union>i\<in>I. f i) \<subseteq> B) = (\<forall>i\<in>I. f i \<subseteq> B)"
by blast

declare Image_Collect_split[simp del]

lemma pr_Hom_pres_face_nodes:
 "is_pr_Hom \<phi> Fs\<^sub>1 Fs\<^sub>2 \<Longrightarrow> (\<Union>F\<in>Fs\<^sub>1. {\<phi> ` (set F)}) = (\<Union>F\<in>Fs\<^sub>2. {set F})"
apply(clarsimp simp:is_pr_Hom_def quotient_def)
apply auto
apply(subgoal_tac "EX F' : Fs\<^sub>2. {\<cong>} `` {map \<phi> F} = {\<cong>} `` {F'}")
 prefer 2 apply blast
apply (fastforce simp: eq_equiv_class_iff[OF equiv_EqF] dest!:congs_pres_nodes)
apply(subgoal_tac "EX F' : Fs\<^sub>1. {\<cong>} `` {map \<phi> F'} = {\<cong>} `` {F}")
 apply (fastforce simp: eq_equiv_class_iff[OF equiv_EqF] dest!:congs_pres_nodes)
apply (erule equalityE)
apply(fastforce simp:UN_subset_iff)
done

lemma pr_Hom_pres_nodes:
  "is_pr_Hom \<phi> Fs\<^sub>1 Fs\<^sub>2 \<Longrightarrow> \<phi> ` (\<Union>F\<in>Fs\<^sub>1. set F) = (\<Union>F\<in>Fs\<^sub>2. set F)"
apply(drule pr_Hom_pres_face_nodes)
apply(rule equalityI)
 apply blast
apply(clarsimp)
apply(subgoal_tac "set F : (\<Union>F\<in>Fs\<^sub>2. {set F})")
 prefer 2 apply blast
apply(subgoal_tac "set F : (\<Union>F\<in>Fs\<^sub>1. {\<phi> ` set F})")
 prefer 2 apply blast
apply(subgoal_tac "EX F':Fs\<^sub>1. \<phi> ` set F' = set F")
 prefer 2 apply blast
apply blast
done

text{* Therefore isomorphisms preserve cardinality of node set. *}

lemma pr_Iso_same_no_nodes:
  "\<lbrakk> is_pr_Iso \<phi> Fs\<^sub>1 Fs\<^sub>2; finite Fs\<^sub>1 \<rbrakk>
   \<Longrightarrow> card(\<Union>F\<in>Fs\<^sub>1. set F) = card(\<Union>F\<in>Fs\<^sub>2. set F)"
by(clarsimp simp add: is_pr_Iso_def pr_Hom_pres_nodes[symmetric] card_image)

lemma pr_iso_same_no_nodes:
  "is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<Longrightarrow> card(\<Union>F\<in>set Fs\<^sub>1. set F) = card(\<Union>F\<in>set Fs\<^sub>2. set F)"
by(simp add: is_pr_iso_def pr_Iso_same_no_nodes)

text{* Isomorphisms preserve the number of faces. *}

lemma pr_iso_same_no_faces:
  assumes dist1: "distinct Fs\<^sub>1" and dist2: "distinct Fs\<^sub>2"
  and inj1: "inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1)"
  and inj2: "inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2)" and iso: "is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2"
  shows "length Fs\<^sub>1 = length Fs\<^sub>2"
proof -
  have injphi: "\<forall>F\<in>set Fs\<^sub>1. \<forall>F'\<in>set Fs\<^sub>1. inj_on \<phi> (set F \<union> set F')" using iso
    by(auto simp:is_pr_iso_def is_pr_Iso_def is_pr_Hom_def inj_on_def)
  have inj1': "inj_on (%xs. {xs} // {\<cong>}) (map \<phi> ` set Fs\<^sub>1)"
    apply(rule inj_on_imageI)
    apply(simp add:inj_on_def quotient_def eq_equiv_class_iff[OF equiv_EqF])
    apply(simp add: congs_map_eq_iff injphi)
    using inj1
    apply(simp add:inj_on_def quotient_def eq_equiv_class_iff[OF equiv_EqF])
    done
  have "length Fs\<^sub>1 = card(set Fs\<^sub>1)" by(simp add:distinct_card[OF dist1])
  also have "\<dots> = card(map \<phi> ` set Fs\<^sub>1)" using iso
    by(auto simp:is_pr_iso_def is_pr_Iso_def is_pr_Hom_def inj_on_mapI card_image)
  also have "\<dots> = card((map \<phi> ` set Fs\<^sub>1) // {\<cong>})"
    by(simp add: card_quotient_disjoint[OF _ inj1'])
  also have "(map \<phi> ` set Fs\<^sub>1)//{\<cong>} = set Fs\<^sub>2 // {\<cong>}"
    using iso by(simp add: is_pr_iso_def is_pr_Iso_def is_pr_Hom_def)
  also have "card(\<dots>) = card(set Fs\<^sub>2)"
    by(simp add: card_quotient_disjoint[OF _ inj2])
  also have "\<dots> = length Fs\<^sub>2" by(simp add:distinct_card[OF dist2])
  finally show ?thesis .
qed

lemma is_Hom_distinct:
 "\<lbrakk> is_pr_Hom \<phi> Fs\<^sub>1 Fs\<^sub>2; \<forall>F\<in>Fs\<^sub>1. distinct F; \<forall>F\<in>Fs\<^sub>2. distinct F \<rbrakk>
  \<Longrightarrow> \<forall>F\<in>Fs\<^sub>1. distinct(map \<phi> F)"
apply(clarsimp simp add:is_pr_Hom_def)
apply(subgoal_tac "\<exists> F' \<in> Fs\<^sub>2. (map \<phi> F, F') : {\<cong>}")
 apply(fastforce simp add: congs_def)
apply(subgoal_tac "\<exists> F' \<in> Fs\<^sub>2. {map \<phi> F}//{\<cong>} = {F'}//{\<cong>}")
 apply clarify
 apply(rule_tac x = F' in bexI)
  apply(rule eq_equiv_class[OF _ equiv_EqF])
   apply(simp add:singleton_quotient)
  apply blast
 apply assumption
apply(simp add:quotient_def)
apply(rotate_tac 1)
apply blast
done

lemma Collect_congs_eq_iff[simp]:
  "Collect (op \<cong> x) = Collect (op \<cong> y) \<longleftrightarrow> (x \<cong> (y::'a list))"
using eq_equiv_class_iff2[OF equiv_EqF]
apply(simp add: quotient_def Iso_def)
apply blast
done

lemma is_pr_Hom_trans: assumes f: "is_pr_Hom f A B" and g: "is_pr_Hom g B C"
shows "is_pr_Hom (g o f) A C"
proof-
  from f have f1: "ALL a:A. EX b:B. map f a \<cong> b"
    apply(simp add: is_pr_Hom_def quotient_def Iso_def)
    apply(erule equalityE)
    apply blast
    done
  from f have f2: "ALL b:B. EX a:A. map f a \<cong> b"
    apply(simp add: is_pr_Hom_def quotient_def Iso_def)
    apply(erule equalityE)
    apply blast
    done
  from g have g1: "ALL b:B. EX c:C. map g b \<cong> c"
    apply(simp add: is_pr_Hom_def quotient_def Iso_def)
    apply(erule equalityE)
    apply blast
    done
  from g have g2: "ALL c:C. EX b:B. map g b \<cong> c"
    apply(simp add: is_pr_Hom_def quotient_def Iso_def)
    apply(erule equalityE)
    apply blast
    done
  show ?thesis
    apply(auto simp add: is_pr_Hom_def quotient_def Iso_def Image_def
      map_comp_map[symmetric] image_comp simp del: map_map map_comp_map)
    apply (metis congs_map[of _ _ g] congs_trans f1 g1)
    by (metis congs_map[of _ _ g] congs_sym congs_trans f2 g2)
qed

lemma is_pr_Hom_rev:
  "is_pr_Hom \<phi> A B \<Longrightarrow> is_pr_Hom \<phi> (rev ` A) (rev ` B)"
apply(auto simp add: is_pr_Hom_def quotient_def Image_def Iso_def rev_map[symmetric])
 apply(erule equalityE)
 apply blast
apply(erule equalityE)
apply blast
done

text{* A kind of recursion rule, a first step towards executability: *}

lemma is_pr_Iso_rec:
 "\<lbrakk> inj_on (%xs. {xs}//{\<cong>}) Fs\<^sub>1; inj_on (%xs. {xs}//{\<cong>}) Fs\<^sub>2; F\<^sub>1 \<in> Fs\<^sub>1 \<rbrakk> \<Longrightarrow>
 is_pr_Iso \<phi> Fs\<^sub>1 Fs\<^sub>2 =
 (\<exists>F\<^sub>2 \<in> Fs\<^sub>2. length F\<^sub>1 = length F\<^sub>2 \<and> is_pr_Iso \<phi> (Fs\<^sub>1 - {F\<^sub>1}) (Fs\<^sub>2 - {F\<^sub>2})
    \<and> (\<exists>n. map \<phi> F\<^sub>1 = rotate n F\<^sub>2)
    \<and> inj_on \<phi> (\<Union>F\<in>Fs\<^sub>1. set F))"
apply(drule mk_disjoint_insert[of F\<^sub>1])
apply clarify
apply(rename_tac Fs\<^sub>1')
apply(rule iffI)

apply (clarsimp simp add:is_pr_Iso_def)
apply(clarsimp simp:is_pr_Hom_def quotient_diff1)
apply(drule_tac s="?a // ?b" in sym)
apply(clarsimp)
apply(subgoal_tac "{\<cong>} `` {map \<phi> F\<^sub>1} : Fs\<^sub>2 // {\<cong>}")
 prefer 2 apply(simp add:quotient_def)
apply(erule quotientE)
apply(rename_tac F\<^sub>2)
apply(drule eq_equiv_class[OF _ equiv_EqF])
 apply blast
apply(rule_tac x = F\<^sub>2 in bexI)
 prefer 2 apply assumption
apply(rule conjI)
 apply(clarsimp simp: congs_def)
apply(rule conjI)
 apply(subgoal_tac "{\<cong>} `` {F\<^sub>2} = {\<cong>} `` {map \<phi> F\<^sub>1}")
  prefer 2
  apply(rule equiv_class_eq[OF equiv_EqF])
  apply(fastforce intro: congs_sym)
 apply(subgoal_tac "{F\<^sub>2}//{\<cong>} = {map \<phi> F\<^sub>1}//{\<cong>}")
  prefer 2 apply(simp add:singleton_quotient)
 apply(subgoal_tac "\<forall>F\<in>Fs\<^sub>1'. \<not> (map \<phi> F) \<cong> (map \<phi> F\<^sub>1)")
  apply(fastforce simp:Iso_def quotient_def Image_Collect_split simp del: Collect_congs_eq_iff
                 dest!: eq_equiv_class[OF _ equiv_EqF])
 apply clarify
 apply(subgoal_tac "inj_on \<phi> (set F \<union> set F\<^sub>1)")
  prefer 2
  apply(erule subset_inj_on)
  apply(blast)
 apply(clarsimp simp add:congs_map_eq_iff)
 apply(subgoal_tac "{\<cong>} `` {F\<^sub>1} = {\<cong>} `` {F}")
  apply(simp add:singleton_quotient)
 apply(rule equiv_class_eq[OF equiv_EqF])
 apply(blast intro:congs_sym)
apply(subgoal_tac "F\<^sub>2 \<cong> (map \<phi> F\<^sub>1)")
 apply (simp add:congs_def inj_on_Un)
apply(clarsimp intro!:congs_sym)

apply(clarsimp simp add: is_pr_Iso_def is_pr_Hom_def quotient_diff1)
apply (simp add:singleton_quotient)
apply(subgoal_tac "F\<^sub>2 \<cong> (map \<phi> F\<^sub>1)")
 prefer 2 apply(fastforce simp add:congs_def)
apply(subgoal_tac "{\<cong>}``{map \<phi> F\<^sub>1} = {\<cong>}``{F\<^sub>2}")
 prefer 2
 apply(rule equiv_class_eq[OF equiv_EqF])
 apply(fastforce intro:congs_sym)
apply(subgoal_tac "{\<cong>}``{F\<^sub>2} \<in> Fs\<^sub>2 // {\<cong>}")
 prefer 2 apply(erule quotientI)
apply (simp add:insert_absorb quotient_def)
done

lemma is_iso_Cons:
 "\<lbrakk> distinct (F\<^sub>1#Fs\<^sub>1'); distinct Fs\<^sub>2;
    inj_on (%xs.{xs}//{\<cong>}) (set(F\<^sub>1#Fs\<^sub>1')); inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk>
  \<Longrightarrow>
 is_pr_iso \<phi> (F\<^sub>1#Fs\<^sub>1') Fs\<^sub>2 =
 (\<exists>F\<^sub>2 \<in> set Fs\<^sub>2. length F\<^sub>1 = length F\<^sub>2 \<and> is_pr_iso \<phi> Fs\<^sub>1' (remove1 F\<^sub>2 Fs\<^sub>2)
    \<and> (\<exists>n. map \<phi> F\<^sub>1 = rotate n F\<^sub>2)
    \<and> inj_on \<phi> (set F\<^sub>1 \<union> (\<Union>F\<in>set Fs\<^sub>1'. set F)))"
apply(simp add:is_pr_iso_def)
apply(subst is_pr_Iso_rec[where ?F\<^sub>1.0 = F\<^sub>1])
apply(simp_all)
done

subsection{* Isomorphism tests *}

lemma map_upd_submap:
  "x \<notin> dom m \<Longrightarrow> (m(x \<mapsto> y) \<subseteq>\<^sub>m m') = (m' x = Some y \<and> m \<subseteq>\<^sub>m m')"
apply(simp add:map_le_def dom_def)
apply(rule iffI)
 apply(rule conjI) apply (blast intro:sym)
 apply clarify
 apply(case_tac "a=x")
  apply auto
done

lemma map_of_zip_submap: "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
 (map_of (zip xs ys) \<subseteq>\<^sub>m Some \<circ> f) = (map f xs = ys)"
apply(induct rule: list_induct2)
 apply(simp)
apply (clarsimp simp: map_upd_submap simp del:o_apply fun_upd_apply)
apply simp
done

primrec pr_iso_test0 :: "('a ~=> 'b) \<Rightarrow> 'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
  "pr_iso_test0 m [] Fs\<^sub>2 = (Fs\<^sub>2 = [])"
| "pr_iso_test0 m (F\<^sub>1#Fs\<^sub>1) Fs\<^sub>2 =
   (\<exists>F\<^sub>2 \<in> set Fs\<^sub>2. length F\<^sub>1 = length F\<^sub>2 \<and>
      (\<exists>n. let m' = map_of(zip F\<^sub>1 (rotate n F\<^sub>2)) in
          if m \<subseteq>\<^sub>m m ++ m' \<and> inj_on (m++m') (dom(m++m'))
          then pr_iso_test0 (m ++ m') Fs\<^sub>1 (remove1 F\<^sub>2 Fs\<^sub>2) else False))"

lemma map_compatI: "\<lbrakk> f \<subseteq>\<^sub>m Some o h; g \<subseteq>\<^sub>m Some o h \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>m f++g"
by (fastforce simp add: map_le_def map_add_def dom_def split:option.splits)

lemma inj_on_map_addI1:
 "\<lbrakk> inj_on m A; m \<subseteq>\<^sub>m m++m'; A \<subseteq> dom m \<rbrakk> \<Longrightarrow> inj_on (m++m') A"
apply (clarsimp simp add: inj_on_def map_add_def map_le_def dom_def
                split:option.splits)
apply(rule conjI)
 apply fastforce
apply auto
 apply fastforce
apply (rename_tac x a y)
apply(subgoal_tac "m x = Some a")
 prefer 2 apply (fastforce)
apply(subgoal_tac "m y = Some a")
 prefer 2 apply (fastforce)
apply(subgoal_tac "m x = m y")
 prefer 2 apply simp
apply (blast)
done

lemma map_image_eq: "\<lbrakk> A \<subseteq> dom m; m \<subseteq>\<^sub>m m' \<rbrakk> \<Longrightarrow> m ` A = m' ` A"
by(force simp:map_le_def dom_def split:option.splits)

lemma inj_on_map_add_Un:
 "\<lbrakk> inj_on m (dom m); inj_on m' (dom m'); m \<subseteq>\<^sub>m Some o f; m' \<subseteq>\<^sub>m Some o f;
    inj_on f (dom m' \<union> dom m); A = dom m'; B = dom m \<rbrakk>
  \<Longrightarrow> inj_on (m ++ m') (A \<union> B)"
apply(simp add:inj_on_Un)
apply(rule conjI)
 apply(fastforce intro!: inj_on_map_addI1 map_compatI)
apply(clarify)
apply(subgoal_tac "m ++ m' \<subseteq>\<^sub>m Some \<circ> f")
 prefer 2 apply(fast intro:map_add_le_mapI map_compatI)
apply(subgoal_tac "dom m' - dom m \<subseteq> dom(m++m')")
 prefer 2 apply(fastforce)
apply(insert map_image_eq[of "dom m' - dom m" "m++m'" "Some o f"])
apply(subgoal_tac "dom m - dom m' \<subseteq> dom(m++m')")
 prefer 2 apply(fastforce)
apply(insert map_image_eq[of "dom m - dom m'" "m++m'" "Some o f"])
apply (clarsimp simp add: image_comp [symmetric])
apply blast
done

lemma map_of_zip_eq_SomeD: "length xs = length ys \<Longrightarrow>
  map_of (zip xs ys) x = Some y \<Longrightarrow> y \<in> set ys"
apply(induct rule:list_induct2)
 apply simp
apply (auto split:if_splits)
done

lemma inj_on_map_of_zip:
  "\<lbrakk> length xs = length ys; distinct ys \<rbrakk>
   \<Longrightarrow> inj_on (map_of (zip xs ys)) (set xs)"
apply(induct rule:list_induct2)
 apply simp
apply clarsimp
apply(rule conjI)
 apply(erule inj_on_fun_updI)
 apply(simp add:image_def)
 apply clarsimp
 apply(drule (1) map_of_zip_eq_SomeD[OF _ sym])
 apply fast
apply(clarsimp simp add:image_def)
apply(drule (1) map_of_zip_eq_SomeD[OF _ sym])
apply fast
done

lemma pr_iso_test0_correct: "\<And>m Fs\<^sub>2.
 \<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2); inj_on m (dom m) \<rbrakk> \<Longrightarrow>
       pr_iso_test0 m Fs\<^sub>1 Fs\<^sub>2 =
       (\<exists>\<phi>. is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<and> m \<subseteq>\<^sub>m Some o \<phi> \<and>
            inj_on \<phi> (dom m \<union> (\<Union>F\<in>set Fs\<^sub>1. set F)))"
apply(induct Fs\<^sub>1)
 apply(simp add:inj_on_def dom_def)
 apply(rule iffI)
  apply (simp add:is_pr_iso_def is_pr_Iso_def is_pr_Hom_def)
  apply(rule_tac x = "the o m" in exI)
  apply (fastforce simp: map_le_def)
 apply (clarsimp simp:is_pr_iso_def is_pr_Iso_def is_pr_Hom_def)
apply(rename_tac F\<^sub>1 Fs\<^sub>1' m Fs\<^sub>2)
apply(clarsimp simp:Let_def Ball_def)
apply(simp add: is_iso_Cons)
apply(rule iffI)

apply clarify
apply(clarsimp simp add:map_of_zip_submap inj_on_diff)
apply(rule_tac x = \<phi> in exI)
apply(rule conjI)
 apply(rule_tac x = F\<^sub>2 in bexI)
  prefer 2 apply assumption
 apply(frule map_add_le_mapE)
 apply(simp add:map_of_zip_submap is_pr_iso_def is_pr_Iso_def)
 apply(rule conjI)
  apply blast
 apply(erule subset_inj_on)
 apply blast
 apply(rule conjI)
  apply(blast intro: map_le_trans)
 apply(erule subset_inj_on)
 apply blast

apply(clarsimp simp: inj_on_diff)
apply(rule_tac x = F\<^sub>2 in bexI)
 prefer 2 apply assumption
apply simp
apply(rule_tac x = n in exI)
apply(rule conjI)
apply clarsimp
apply(rule_tac x = \<phi> in exI)
apply simp
apply(rule conjI)
 apply(fastforce intro!:map_add_le_mapI simp:map_of_zip_submap)
apply(simp add:Un_ac)
apply(rule context_conjI)
apply(simp add:map_of_zip_submap[symmetric])
apply(erule (1) map_compatI)
apply(simp add:map_of_zip_submap[symmetric])
apply(erule inj_on_map_add_Un)
     apply(simp add:inj_on_map_of_zip)
    apply assumption
   apply assumption
  apply simp
  apply(erule subset_inj_on)
  apply fast
 apply simp
apply(rule refl)
done

corollary pr_iso_test0_corr:
 "\<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk> \<Longrightarrow>
       pr_iso_test0 empty Fs\<^sub>1 Fs\<^sub>2 = (\<exists>\<phi>. is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2)"
apply(subst pr_iso_test0_correct)
 apply assumption+
 apply simp
apply (simp add:is_pr_iso_def is_pr_Iso_def)
done

text{* Now we bound the number of rotations needed. We have to exclude
the empty face @{term"[]"} to be able to restrict the search to
@{prop"n < length xs"} (which would otherwise be vacuous). *}

primrec pr_iso_test1 :: "('a ~=> 'b) \<Rightarrow> 'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
  "pr_iso_test1 m [] Fs\<^sub>2 = (Fs\<^sub>2 = [])"
| "pr_iso_test1 m (F\<^sub>1#Fs\<^sub>1) Fs\<^sub>2 =
   (\<exists>F\<^sub>2 \<in> set Fs\<^sub>2. length F\<^sub>1 = length F\<^sub>2 \<and>
      (\<exists>n < length F\<^sub>2. let m' = map_of(zip F\<^sub>1 (rotate n F\<^sub>2)) in
          if  m \<subseteq>\<^sub>m m ++ m' \<and> inj_on (m++m') (dom(m++m'))
          then pr_iso_test1 (m ++ m') Fs\<^sub>1 (remove1 F\<^sub>2 Fs\<^sub>2) else False))"

lemma test0_conv_test1:
 "!!m Fs\<^sub>2. [] \<notin> set Fs\<^sub>2 \<Longrightarrow> pr_iso_test1 m Fs\<^sub>1 Fs\<^sub>2 = pr_iso_test0 m Fs\<^sub>1 Fs\<^sub>2"
apply(induct Fs\<^sub>1)
 apply simp
apply simp
apply(rule iffI)
 apply blast
apply (clarsimp simp:Let_def)
apply(rule_tac x = F\<^sub>2 in bexI)
 prefer 2 apply assumption
apply simp
apply(subgoal_tac "F\<^sub>2 \<noteq> []")
 prefer 2 apply blast
apply(rule_tac x = "n mod length F\<^sub>2" in exI)
apply(simp add:rotate_conv_mod[symmetric])
done

text{* Thus correctness carries over to @{text pr_iso_test1}: *}

corollary pr_iso_test1_corr:
 "\<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F; [] \<notin> set Fs\<^sub>2;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk> \<Longrightarrow>
       pr_iso_test1 empty Fs\<^sub>1 Fs\<^sub>2 = (\<exists>\<phi>. is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2)"
by(simp add: test0_conv_test1 pr_iso_test0_corr)

subsubsection{* Implementing maps by lists *}

text{* The representation are lists of pairs with no repetition in the
first or second component. *}

definition oneone :: "('a * 'b)list \<Rightarrow> bool" where
"oneone xys  \<equiv>  distinct(map fst xys) \<and> distinct(map snd xys)"
declare oneone_def[simp]

type_synonym
  ('a,'b)tester = "('a * 'b)list \<Rightarrow> ('a * 'b)list \<Rightarrow> bool"
type_synonym
  ('a,'b)merger = "('a * 'b)list \<Rightarrow> ('a * 'b)list \<Rightarrow> ('a * 'b)list"

primrec pr_iso_test2 :: "('a,'b)tester \<Rightarrow> ('a,'b)merger \<Rightarrow>
                ('a * 'b)list \<Rightarrow> 'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
  "pr_iso_test2 tst mrg I [] Fs\<^sub>2 = (Fs\<^sub>2 = [])"
| "pr_iso_test2 tst mrg I (F\<^sub>1#Fs\<^sub>1) Fs\<^sub>2 =
   (\<exists>F\<^sub>2 \<in> set Fs\<^sub>2. length F\<^sub>1 = length F\<^sub>2 \<and>
      (\<exists>n < length F\<^sub>2. let I' = zip F\<^sub>1 (rotate n F\<^sub>2) in
          if  tst I' I
          then pr_iso_test2 tst mrg (mrg I' I) Fs\<^sub>1 (remove1 F\<^sub>2 Fs\<^sub>2) else False))"

lemma notin_range_map_of:
 "y \<notin> snd ` set xys \<Longrightarrow> Some y \<notin> range(map_of xys)"
apply(induct xys)
 apply (simp add:image_def)
apply(clarsimp split:if_splits)
done

lemma inj_on_map_upd:
  "\<lbrakk> inj_on m (dom m); Some y \<notin> range m \<rbrakk> \<Longrightarrow> inj_on (m(x\<mapsto>y)) (dom m)"
apply(simp add:inj_on_def dom_def image_def)
apply (blast intro:sym)
done

lemma lem: "Ball (set xs) P \<Longrightarrow> Ball (set (remove1 x xs)) P = True"
by(induct xs) simp_all

lemma pr_iso_test2_conv_1:
  "!!I Fs\<^sub>2.
  \<lbrakk> \<forall>I I'. oneone I \<longrightarrow> oneone I' \<longrightarrow>
           tst I' I = (let m = map_of I; m' = map_of I'
                       in m \<subseteq>\<^sub>m m ++ m' \<and> inj_on (m++m') (dom(m++m')));
   \<forall>I I'. oneone I \<longrightarrow> oneone I' \<longrightarrow> tst I' I
          \<longrightarrow> map_of(mrg I' I) = map_of I ++ map_of I';
   \<forall>I I'. oneone I & oneone I' \<longrightarrow> tst I' I \<longrightarrow> oneone (mrg I' I);
   oneone I;
   \<forall>F \<in> set Fs\<^sub>1. distinct F; \<forall>F \<in> set Fs\<^sub>2. distinct F \<rbrakk> \<Longrightarrow>
  pr_iso_test2 tst mrg I Fs\<^sub>1 Fs\<^sub>2 = pr_iso_test1 (map_of I) Fs\<^sub>1 Fs\<^sub>2"
apply(induct Fs\<^sub>1)
 apply simp
apply(simp add:Let_def lem inj_on_map_of_zip del: mod_less cong: conj_cong)
done

text{* A simple implementation *}

definition compat :: "('a,'b)tester" where
 "compat I I' ==
  \<forall>(x,y) \<in> set I. \<forall>(x',y') \<in> set I'. (x = x') = (y = y')"

lemma image_map_upd:
  "x \<notin> dom m \<Longrightarrow> m(x\<mapsto>y) ` A = m ` (A-{x}) \<union> (if x \<in> A then {Some y} else {})"
by(auto simp:image_def dom_def)

lemma image_map_of_conv_Image:
 "!!A. \<lbrakk> distinct(map fst xys) \<rbrakk>
 \<Longrightarrow> map_of xys ` A = Some ` (set xys `` A) \<union> (if A \<subseteq> fst ` set xys then {} else {None})"
apply (induct xys)
 apply (simp add:image_def Image_def Collect_conv_if)
apply (simp add:image_map_upd dom_map_of_conv_image_fst)
apply(erule thin_rl)
apply (clarsimp simp:image_def Image_def)
apply((rule conjI, clarify)+, fastforce)
apply fastforce
apply(clarify)
apply((rule conjI, clarify)+, fastforce)
apply fastforce
apply fastforce
apply fastforce
done

lemma [simp]: "m++m' ` (dom m' - A) = m' ` (dom m' - A)"
apply(clarsimp simp add:map_add_def image_def dom_def inj_on_def split:option.splits)
apply auto
apply (blast intro:sym)
apply (blast intro:sym)
apply (rule_tac x = xa in bexI)
prefer 2 apply blast
apply simp
done

declare Diff_subset [iff]

lemma compat_correct:
 "\<lbrakk> oneone I; oneone I' \<rbrakk> \<Longrightarrow>
  compat I' I = (let m = map_of I; m' = map_of I'
                 in m \<subseteq>\<^sub>m m ++ m' \<and> inj_on (m++m') (dom(m++m')))"
apply(simp add: compat_def Let_def map_le_iff_map_add_commute)
apply(rule iffI)
 apply(rule context_conjI)
  apply(rule ext)
  apply (fastforce simp add:map_add_def split:option.split)
 apply(simp add:inj_on_Un)
 apply(drule sym)
 apply simp
 apply(simp add: dom_map_of_conv_image_fst image_map_of_conv_Image)
 apply(simp add: image_def Image_def)
 apply fastforce
apply clarsimp
apply(rename_tac a b aa ba)
apply(rule iffI)
 apply (clarsimp simp: fun_eq_iff)
 apply(erule_tac x = aa in allE)
 apply (simp add:map_add_def)
apply (clarsimp simp:dom_map_of_conv_image_fst)
apply(simp (no_asm_use) add:inj_on_def)
apply(drule_tac x = a in bspec)
 apply force
apply(drule_tac x = aa in bspec)
 apply force
apply(erule mp)
apply simp
apply(drule sym)
apply simp
done

corollary compat_corr:
 "\<forall>I I'. oneone I \<longrightarrow> oneone I' \<longrightarrow>
         compat I' I = (let m = map_of I; m' = map_of I'
                      in m \<subseteq>\<^sub>m m ++ m' \<and> inj_on (m++m') (dom(m++m')))"
by(simp add: compat_correct)

definition merge0 :: "('a,'b)merger" where
"merge0 I' I  \<equiv>  [xy \<leftarrow> I'. fst xy \<notin> fst ` set I] @ I"

lemma help1:
"distinct(map fst xys) \<Longrightarrow> map_of (filter P xys) =
 map_of xys |` {x. \<exists>y. (x,y) \<in> set xys \<and> P(x,y)}"
apply(induct xys)
 apply simp
apply(rule ext)
apply (simp add:restrict_map_def)
apply force
done

lemma merge0_correct:
  "\<forall>I I'. oneone I \<longrightarrow> oneone I' \<longrightarrow> compat I' I
  \<longrightarrow> map_of(merge0 I' I) = map_of I ++ map_of I'"
apply(simp add:compat_def merge0_def help1 fun_eq_iff map_add_def restrict_map_def split:option.split)
apply fastforce
done

lemma merge0_inv:
  "\<forall>I I'. oneone I \<and> oneone I' \<longrightarrow> compat I' I \<longrightarrow> oneone (merge0 I' I)"
apply(auto simp add:merge0_def distinct_map compat_def split_def)
apply(blast intro:subset_inj_on)+
done

corollary pr_iso_test2_corr:
 "\<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F; [] \<notin> set Fs\<^sub>2;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk> \<Longrightarrow>
       pr_iso_test2 compat merge0 [] Fs\<^sub>1 Fs\<^sub>2 = (\<exists>\<phi>. is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2)"
by(simp add: pr_iso_test2_conv_1[OF compat_corr merge0_correct merge0_inv]
             pr_iso_test1_corr)

text{* Implementing merge as a recursive function: *}

primrec merge :: "('a,'b)merger" where
  "merge [] I = I"
| "merge (xy#xys) I = (let (x,y) = xy in
    if \<forall> (x',y') \<in> set I. x \<noteq> x' then xy # merge xys I else merge xys I)"

lemma merge_conv_merge0: "merge I' I = merge0 I' I"
apply(induct I')
 apply(simp add:merge0_def)
apply(force simp add:Let_def list_all_iff merge0_def)
done

primrec pr_iso_test_rec :: "('a * 'b)list \<Rightarrow> 'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
  "pr_iso_test_rec I [] Fs\<^sub>2 = (Fs\<^sub>2 = [])"
| "pr_iso_test_rec I (F\<^sub>1#Fs\<^sub>1) Fs\<^sub>2 =
   (\<exists> F\<^sub>2 \<in> set Fs\<^sub>2. length F\<^sub>1 = length F\<^sub>2 \<and>
      (\<exists>n < length F\<^sub>2. let I' = zip F\<^sub>1 (rotate n F\<^sub>2) in
          compat I' I \<and> pr_iso_test_rec (merge I' I) Fs\<^sub>1 (remove1 F\<^sub>2 Fs\<^sub>2)))"

lemma pr_iso_test_rec_conv_2:
  "!!I Fs\<^sub>2. pr_iso_test_rec I Fs\<^sub>1 Fs\<^sub>2 = pr_iso_test2 compat merge0 I Fs\<^sub>1 Fs\<^sub>2"
apply(induct Fs\<^sub>1)
 apply simp
apply(auto simp: merge_conv_merge0 list_ex_iff Bex_def Let_def)
done

corollary pr_iso_test_rec_corr:
 "\<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F; [] \<notin> set Fs\<^sub>2;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk> \<Longrightarrow>
       pr_iso_test_rec [] Fs\<^sub>1 Fs\<^sub>2 = (\<exists>\<phi>. is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2)"
by(simp add: pr_iso_test_rec_conv_2 pr_iso_test2_corr)

definition pr_iso_test :: "'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
"pr_iso_test Fs\<^sub>1 Fs\<^sub>2 = pr_iso_test_rec [] Fs\<^sub>1 Fs\<^sub>2"

corollary pr_iso_test_correct:
 "\<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F; [] \<notin> set Fs\<^sub>2;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk> \<Longrightarrow>
  pr_iso_test Fs\<^sub>1 Fs\<^sub>2 = (\<exists>\<phi>. is_pr_iso \<phi> Fs\<^sub>1 Fs\<^sub>2)"
apply(simp add:pr_iso_test_def pr_iso_test_rec_corr)
done

subsubsection{* `Improper' Isomorphisms *}

definition is_Iso :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Fgraph \<Rightarrow> 'b Fgraph \<Rightarrow> bool" where
"is_Iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<equiv> is_pr_Iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<or> is_pr_Iso \<phi> Fs\<^sub>1 (rev ` Fs\<^sub>2)"

definition is_iso :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
"is_iso \<phi> Fs\<^sub>1 Fs\<^sub>2 \<equiv> is_Iso \<phi> (set Fs\<^sub>1) (set Fs\<^sub>2)"

definition iso_fgraph :: "'a fgraph \<Rightarrow> 'a fgraph \<Rightarrow> bool" (infix "\<simeq>" 60) where
"g\<^sub>1 \<simeq> g\<^sub>2  \<equiv>  \<exists>\<phi>. is_iso \<phi> g\<^sub>1 g\<^sub>2"

lemma iso_fgraph_trans: assumes "f \<simeq> (g::'a fgraph)" and "g \<simeq> h" shows "f \<simeq> h"
proof-
  { fix \<phi> \<phi>' assume "is_pr_Hom \<phi> (set f) (set g)" "inj_on \<phi> (\<Union>F\<in>set f. set F)"
    "is_pr_Hom \<phi>' (set g) (set h)" "inj_on \<phi>' (\<Union>F\<in>set g. set F)"
    hence "is_pr_Hom (\<phi>' \<circ> \<phi>) (set f) (set h) \<and>
          inj_on (\<phi>' \<circ> \<phi>) (\<Union>F\<in>set f. set F)"
      by(simp add: is_pr_Hom_trans comp_inj_on pr_Hom_pres_nodes)
  } moreover
  { fix \<phi> \<phi>' assume "is_pr_Hom \<phi> (set f) (set g)" "inj_on \<phi> (\<Union>F\<in>set f. set F)"
    "is_pr_Hom \<phi>' (set g) (rev ` set h)" "inj_on \<phi>' (\<Union>F\<in>set g. set F)"
    hence "is_pr_Hom (\<phi>' \<circ> \<phi>) (set f) (rev ` set h) \<and>
          inj_on (\<phi>' \<circ> \<phi>) (\<Union>F\<in>set f. set F)"
      by(simp add: is_pr_Hom_trans comp_inj_on pr_Hom_pres_nodes)
  } moreover
  { fix \<phi> \<phi>' assume "is_pr_Hom \<phi> (set f) (rev ` set g)" "inj_on \<phi> (\<Union>F\<in>set f. set F)"
    "is_pr_Hom \<phi>' (set g) (set h)" "inj_on \<phi>' (\<Union>F\<in>set g. set F)"
    with this(3)[THEN is_pr_Hom_rev]
    have "is_pr_Hom (\<phi>' \<circ> \<phi>) (set f) (rev ` set h) \<and>
          inj_on (\<phi>' \<circ> \<phi>) (\<Union>F\<in>set f. set F)"
      by(simp add: is_pr_Hom_trans comp_inj_on pr_Hom_pres_nodes)
  } moreover
  { fix \<phi> \<phi>' assume "is_pr_Hom \<phi> (set f) (rev ` set g)" "inj_on \<phi> (\<Union>F\<in>set f. set F)"
    "is_pr_Hom \<phi>' (set g) (rev ` set h)" "inj_on \<phi>' (\<Union>F\<in>set g. set F)"
    with this(3)[THEN is_pr_Hom_rev]
    have "is_pr_Hom (\<phi>' \<circ> \<phi>) (set f) (set h) \<and>
          inj_on (\<phi>' \<circ> \<phi>) (\<Union>F\<in>set f. set F)"
      by(simp add: is_pr_Hom_trans comp_inj_on pr_Hom_pres_nodes)
  } ultimately show ?thesis using assms
    by(simp add: iso_fgraph_def is_iso_def is_Iso_def is_pr_Iso_def) blast
qed

definition iso_test :: "'a fgraph \<Rightarrow> 'b fgraph \<Rightarrow> bool" where
"iso_test g\<^sub>1 g\<^sub>2 \<longleftrightarrow> pr_iso_test g\<^sub>1 g\<^sub>2 \<or> pr_iso_test g\<^sub>1 (map rev g\<^sub>2)"

theorem iso_correct:
 "\<lbrakk> \<forall>F\<in>set Fs\<^sub>1. distinct F; \<forall>F\<in>set Fs\<^sub>2. distinct F; [] \<notin> set Fs\<^sub>2;
   distinct Fs\<^sub>1; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>1);
   distinct Fs\<^sub>2; inj_on (%xs.{xs}//{\<cong>}) (set Fs\<^sub>2) \<rbrakk> \<Longrightarrow>
  iso_test Fs\<^sub>1 Fs\<^sub>2 = (Fs\<^sub>1 \<simeq> Fs\<^sub>2)"
apply(simp add:iso_test_def pr_iso_test_correct iso_fgraph_def)
apply(subst pr_iso_test_correct)
       apply simp
      apply simp
     apply (simp add:image_def)
    apply simp
   apply simp
  apply (simp add:distinct_map)
 apply (simp add:inj_on_image_iff)
apply(simp add:is_iso_def is_Iso_def is_pr_iso_def)
apply blast
done

lemma iso_fgraph_refl[iff]: "g \<simeq> g"
apply(simp add: iso_fgraph_def)
apply(rule_tac x = "id" in exI)
apply(simp add: is_iso_def is_Iso_def is_pr_Iso_def is_pr_Hom_def id_def)
done

subsection{* Elementhood and containment modulo *}

interpretation qle_gr: quasi_order "op \<simeq>"
proof qed (auto intro:iso_fgraph_trans)

abbreviation qle_gr_in :: "'a fgraph \<Rightarrow> 'a fgraph set \<Rightarrow> bool"  (infix "\<in>\<^sub>\<simeq>" 60)
where "x \<in>\<^sub>\<simeq> M \<equiv> qle_gr.in_qle x M"
abbreviation qle_gr_sub :: "'a fgraph set \<Rightarrow> 'a fgraph set \<Rightarrow> bool"  (infix "\<subseteq>\<^sub>\<simeq>" 60)
where "x \<subseteq>\<^sub>\<simeq> M \<equiv> qle_gr.subseteq_qle x M"
abbreviation qle_gr_eq :: "'a fgraph set \<Rightarrow> 'a fgraph set \<Rightarrow> bool"  (infix "=\<^sub>\<simeq>" 60)
where "x =\<^sub>\<simeq> M \<equiv> qle_gr.seteq_qle x M"

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>A Concrete Unification Algorithm\<close>

theory Unification
  imports
    Abstract_Unification
    Option_Monad
begin

definition
  "decompose s t =
    (case (s, t) of
      (Fun f ss, Fun g ts) \<Rightarrow> if f = g then zip_option ss ts else None
    | _ \<Rightarrow> None)"

lemma decompose_same_Fun[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "decompose (Fun f ss) (Fun f ss) = Some (zip ss ss)"
  by (simp add: decompose_def)

lemma decompose_Some [dest]:
  "decompose (Fun f ss) (Fun g ts) = Some E \<Longrightarrow>
    f = g \<and> length ss = length ts \<and> E = zip ss ts"
  by (cases "f = g") (auto simp: decompose_def)

lemma decompose_None [dest]:
  "decompose (Fun f ss) (Fun g ts) = None \<Longrightarrow> f \<noteq> g \<or> length ss \<noteq> length ts"
  by (cases "f = g") (auto simp: decompose_def)

text \<open>Applying a substitution to a list of equations.\<close>
definition
  subst_list :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equation list \<Rightarrow> ('f, 'v) equation list"
  where
    "subst_list \<sigma> ys = map (\<lambda>p. (fst p \<cdot> \<sigma>, snd p \<cdot> \<sigma>)) ys"

lemma mset_subst_list [simp]:
  "mset (subst_list (subst x t) ys) = subst_mset (subst x t) (mset ys)"
  by (auto simp: subst_mset_def subst_list_def)

lemma subst_list_append:
  "subst_list \<sigma> (xs @ ys) = subst_list \<sigma> xs @ subst_list \<sigma> ys"
by (auto simp: subst_list_def)

function (sequential)
  unify ::
    "('f, 'v) equation list \<Rightarrow> ('v \<times> ('f, 'v) term) list \<Rightarrow> ('v \<times> ('f, 'v) term) list option"
where
  "unify [] bs = Some bs"
| "unify ((Fun f ss, Fun g ts) # E) bs =
    (case decompose (Fun f ss) (Fun g ts) of
      None \<Rightarrow> None
    | Some us \<Rightarrow> unify (us @ E) bs)"
| "unify ((Var x, t) # E) bs =
    (if t = Var x then unify E bs
    else if x \<in> vars_term t then None
    else unify (subst_list (subst x t) E) ((x, t) # bs))"
| "unify ((t, Var x) # E) bs =
    (if x \<in> vars_term t then None
    else unify (subst_list (subst x t) E) ((x, t) # bs))"
  by pat_completeness auto
termination
  by (standard, rule wf_inv_image [of "unif\<inverse>" "mset \<circ> fst", OF wf_converse_unif])
     (force intro: UNIF1.intros simp: unif_def union_commute)+

lemma unify_append_prefix_same: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "(\<forall>e \<in> set es1. fst e = snd e) \<Longrightarrow> unify (es1 @ es2) bs = unify es2 bs"
proof (induction "es1 @ es2" bs arbitrary: es1 es2 bs rule: unify.induct)
  case (1 bs)
  thus ?case by simp
next
  case (2 f ss g ts E bs)
  show ?case
  proof (cases es1)
    case Nil
    thus ?thesis by simp
  next
    case (Cons e es1')
    hence e_def: "e = (Fun f ss, Fun g ts)" and E_def: "E = es1' @ es2"
      using "2" by simp_all
    hence "f = g" and "ss = ts"
      using "2.prems" local.Cons by auto
    hence "unify (es1 @ es2) bs = unify ((zip ts ts @ es1') @ es2) bs"
      by (simp add: Cons e_def)
    also have "\<dots> = unify es2 bs"
    proof (rule "2.hyps"(1))
      show "decompose (Fun f ss) (Fun g ts) = Some (zip ts ts)"
        by (simp add: \<open>f = g\<close> \<open>ss = ts\<close>)
    next
      show "zip ts ts @ E = (zip ts ts @ es1') @ es2"
        by (simp add: E_def)
    next
      show "\<forall>e\<in>set (zip ts ts @ es1'). fst e = snd e"
        using "2.prems" by (auto simp: Cons zip_same)
    qed
    finally show ?thesis .
  qed
next
  case (3 x t E bs)
  show ?case
  proof (cases es1)
    case Nil
    thus ?thesis by simp
  next
    case (Cons e es1')
    hence e_def: "e = (Var x, t)" and E_def: "E = es1' @ es2"
      using 3 by simp_all
    show ?thesis
    proof (cases "t = Var x")
      case True
      show ?thesis
        using 3(1)[OF True E_def]
        using "3.hyps"(3) "3.prems" local.Cons by fastforce
    next
      case False
      thus ?thesis
        using "3.prems" e_def local.Cons by force
    qed
  qed
next
  case (4 v va x E bs)
  then show ?case
  proof (cases es1)
    case Nil
    thus ?thesis by simp
  next
    case (Cons e es1')
    hence e_def: "e = (Fun v va, Var x)" and E_def: "E = es1' @ es2"
      using 4 by simp_all
    thus ?thesis
      using "4.prems" local.Cons by fastforce
  qed
qed

corollary unify_Cons_same: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "fst e = snd e \<Longrightarrow> unify (e # es) bs = unify es bs"
  by (rule unify_append_prefix_same[of "[_]", simplified])

corollary unify_same: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "(\<forall>e \<in> set es. fst e = snd e) \<Longrightarrow> unify es bs = Some bs"
  by (rule unify_append_prefix_same[of _ "[]", simplified])

definition subst_of :: "('v \<times> ('f, 'v) term) list \<Rightarrow> ('f, 'v) subst"
  where
    "subst_of ss = List.foldr (\<lambda>(x, t) \<sigma>. \<sigma> \<circ>\<^sub>s subst x t) ss Var"

text \<open>Computing the mgu of two terms.\<close>
definition mgu :: "('f, 'v) term \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) subst option" where
  "mgu s t =
    (case unify [(s, t)] [] of
      None \<Rightarrow> None
    | Some res \<Rightarrow> Some (subst_of res))"

lemma subst_of_simps [simp]:
  "subst_of [] = Var"
  "subst_of ((x, Var x) # ss) = subst_of ss"
  "subst_of (b # ss) = subst_of ss \<circ>\<^sub>s subst (fst b) (snd b)"
  by (simp_all add: subst_of_def split: prod.splits)

lemma subst_of_append [simp]:
  "subst_of (ss @ ts) = subst_of ts \<circ>\<^sub>s subst_of ss"
  by (induct ss) (auto simp: ac_simps)

text \<open>The concrete algorithm \<open>unify\<close> can be simulated by the inference
  rules of \<open>UNIF\<close>.\<close>
lemma unify_Some_UNIF:
  assumes "unify E bs = Some cs"
  shows "\<exists>ds ss. cs = ds @ bs \<and> subst_of ds = compose ss \<and> UNIF ss (mset E) {#}"
using assms
proof (induction E bs arbitrary: cs rule: unify.induct)
  case (2 f ss g ts E bs)
  then obtain us where "decompose (Fun f ss) (Fun g ts) = Some us"
    and [simp]: "f = g" "length ss = length ts" "us = zip ss ts"
    and "unify (us @ E) bs = Some cs" by (auto split: option.splits)
  from "2.IH" [OF this(1, 5)] obtain xs ys
    where "cs = xs @ bs"
    and [simp]: "subst_of xs = compose ys"
    and *: "UNIF ys (mset (us @ E)) {#}" by auto
  then have "UNIF (Var # ys) (mset ((Fun f ss, Fun g ts) # E)) {#}"
    by (force intro: UNIF1.decomp simp: ac_simps)
  moreover have "cs = xs @ bs" by fact
  moreover have "subst_of xs = compose (Var # ys)" by simp
  ultimately show ?case by blast
next
  case (3 x t E bs)
  show ?case
  proof (cases "t = Var x")
    assume "t = Var x"
    then show ?case
      using 3 by auto (metis UNIF.step compose_simps(2) UNIF1.trivial)
  next
    assume "t \<noteq> Var x"
    with 3 obtain xs ys
      where [simp]: "cs = (ys @ [(x, t)]) @ bs"
      and [simp]: "subst_of ys = compose xs"
      and "x \<notin> vars_term t"
      and "UNIF xs (mset (subst_list (subst x t) E)) {#}"
        by (cases "x \<in> vars_term t") force+
    then have "UNIF (subst x t # xs) (mset ((Var x, t) # E)) {#}"
      by (force intro: UNIF1.Var_left simp: ac_simps)
    moreover have "cs = (ys @ [(x, t)]) @ bs" by simp
    moreover have "subst_of (ys @ [(x, t)]) = compose (subst x t # xs)" by simp
    ultimately show ?case by blast
  qed
next
  case (4 f ss x E bs)
  with 4 obtain xs ys
    where [simp]: "cs = (ys @ [(x, Fun f ss)]) @ bs"
    and [simp]: "subst_of ys = compose xs"
    and "x \<notin> vars_term (Fun f ss)"
    and "UNIF xs (mset (subst_list (subst x (Fun f ss)) E)) {#}"
      by (cases "x \<in> vars_term (Fun f ss)") force+
  then have "UNIF (subst x (Fun f ss) # xs) (mset ((Fun f ss, Var x) # E)) {#}"
    by (force intro: UNIF1.Var_right simp: ac_simps)
  moreover have "cs = (ys @ [(x, Fun f ss)]) @ bs" by simp
  moreover have "subst_of (ys @ [(x, Fun f ss)]) = compose (subst x (Fun f ss) # xs)" by simp
  ultimately show ?case by blast
qed force

lemma unify_sound:
  assumes "unify E [] = Some cs"
  shows "is_imgu (subst_of cs) (set E)"
proof -
  from unify_Some_UNIF [OF assms] obtain ss
    where "subst_of cs = compose ss"
    and "UNIF ss (mset E) {#}" by auto
  with UNIF_empty_imp_is_mgu_compose [OF this(2)]
    and UNIF_idemp [OF this(2)]
    show ?thesis
      by (auto simp add: is_imgu_def is_mgu_def)
         (metis subst_compose_assoc)
qed

lemma mgu_sound:
  assumes "mgu s t = Some \<sigma>"
  shows "is_imgu \<sigma> {(s, t)}"
proof -
  obtain ss where "unify [(s, t)] [] = Some ss"
    and "\<sigma> = subst_of ss"
    using assms by (auto simp: mgu_def split: option.splits)
  then have "is_imgu \<sigma> (set [(s, t)])" by (metis unify_sound)
  then show ?thesis by simp
qed

text \<open>If \<open>unify\<close> gives up, then the given set of equations
  cannot be reduced to the empty set by \<open>UNIF\<close>.\<close>
lemma unify_None:
  assumes "unify E ss = None"
  shows "\<exists>E'. E' \<noteq> {#} \<and> (mset E, E') \<in> unif\<^sup>!"
using assms
proof (induction E ss rule: unify.induct)
  case (1 bs)
  then show ?case by simp
next
  case (2 f ss g ts E bs)
  moreover
  { assume *: "decompose (Fun f ss) (Fun g ts) = None"
    have ?case
    proof (cases "unifiable (set E)")
      case True
      then have "(mset E, {#}) \<in> unif\<^sup>*"
        by (simp add: unifiable_imp_empty)
      from unif_rtrancl_mono [OF this, of "{#(Fun f ss, Fun g ts)#}"] obtain \<sigma>
        where "(mset E + {#(Fun f ss, Fun g ts)#}, {#(Fun f ss \<cdot> \<sigma>, Fun g ts \<cdot> \<sigma>)#}) \<in> unif\<^sup>*"
        by (auto simp: subst_mset_def)
      moreover have "{#(Fun f ss \<cdot> \<sigma>, Fun g ts \<cdot> \<sigma>)#} \<in> NF unif"
        using decompose_None [OF *]
        by (auto simp: single_is_union NF_def unif_def elim!: UNIF1.cases)
           (metis length_map)
      ultimately show ?thesis
        by auto (metis normalizability_I add_mset_not_empty)
    next
      case False
      moreover have "\<not> unifiable {(Fun f ss, Fun g ts)}"
        using * by (auto simp: unifiable_def)
      ultimately have "\<not> unifiable (set ((Fun f ss, Fun g ts) # E))" by (auto simp: unifiable_def unifiers_def)
      then show ?thesis by (simp add: not_unifiable_imp_not_empty_NF)
    qed }
  moreover
  { fix us
    assume *: "decompose (Fun f ss) (Fun g ts) = Some us"
      and "unify (us @ E) bs = None"
    from "2.IH" [OF this] obtain E'
      where "E' \<noteq> {#}" and "(mset (us @ E), E') \<in> unif\<^sup>!" by blast
    moreover have "(mset ((Fun f ss, Fun g ts) # E), mset (us @ E)) \<in> unif"
    proof -
      have "g = f" and "length ss = length ts" and "us = zip ss ts"
        using * by auto
      then show ?thesis
        by (auto intro: UNIF1.decomp simp: unif_def ac_simps)
    qed
    ultimately have ?case by auto }
  ultimately show ?case by (auto split: option.splits)
next
  case (3 x t E bs)
  { assume [simp]: "t = Var x"
    obtain E' where "E' \<noteq> {#}" and "(mset E, E') \<in> unif\<^sup>!" using 3 by auto
    moreover have "(mset ((Var x, t) # E), mset E) \<in> unif"
      by (auto intro: UNIF1.trivial simp: unif_def)
    ultimately have ?case by auto }
  moreover
  { assume *: "t \<noteq> Var x" "x \<notin> vars_term t"
    then obtain E' where "E' \<noteq> {#}"
      and "(mset (subst_list (subst x t) E), E') \<in> unif\<^sup>!" using 3 by auto
    moreover have "(mset ((Var x, t) # E), mset (subst_list (subst x t) E)) \<in> unif"
      using * by (auto intro: UNIF1.Var_left simp: unif_def)
    ultimately have ?case by auto }
  moreover
  { assume *: "t \<noteq> Var x" "x \<in> vars_term t"
    then have "x \<in> vars_term t" "is_Fun t" by auto
    then have "\<not> unifiable {(Var x, t)}" by (rule in_vars_is_Fun_not_unifiable)
    then have **: "\<not> unifiable {(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)}" for \<sigma> :: "('b, 'a) subst"
      using subst_set_reflects_unifiable [of \<sigma> "{(Var x, t)}"] by (auto simp: subst_set_def)
    have ?case
    proof (cases "unifiable (set E)")
      case True
      then have "(mset E, {#}) \<in> unif\<^sup>*"
        by (simp add: unifiable_imp_empty)
      from unif_rtrancl_mono [OF this, of "{#(Var x, t)#}"] obtain \<sigma>
        where "(mset E + {#(Var x, t)#}, {#(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)#}) \<in> unif\<^sup>*"
        by (auto simp: subst_mset_def)
      moreover obtain E' where "E' \<noteq> {#}"
        and "({#(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)#}, E') \<in> unif\<^sup>!"
        using not_unifiable_imp_not_empty_NF and **
          by (metis set_mset_single)
      ultimately show ?thesis by auto
    next
      case False
      moreover have "\<not> unifiable {(Var x, t)}"
        using * by (force simp: unifiable_def)
      ultimately have "\<not> unifiable (set ((Var x, t) # E))" by (auto simp: unifiable_def unifiers_def)
      then show ?thesis
        by (simp add: not_unifiable_imp_not_empty_NF)
    qed }
  ultimately show ?case by blast
next
  case (4 f ss x E bs)
  define t where "t = Fun f ss"
  { assume *: "x \<notin> vars_term t"
    then obtain E' where "E' \<noteq> {#}"
      and "(mset (subst_list (subst x t) E), E') \<in> unif\<^sup>!" using 4 by (auto simp: t_def)
    moreover have "(mset ((t, Var x) # E), mset (subst_list (subst x t) E)) \<in> unif"
      using * by (auto intro: UNIF1.Var_right simp: unif_def)
    ultimately have ?case by (auto simp: t_def) }
  moreover
  { assume "x \<in> vars_term t"
    then have *: "x \<in> vars_term t" "t \<noteq> Var x" by (auto simp: t_def)
    then have "x \<in> vars_term t" "is_Fun t" by auto
    then have "\<not> unifiable {(Var x, t)}" by (rule in_vars_is_Fun_not_unifiable)
    then have **: "\<not> unifiable {(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)}" for \<sigma> :: "('b, 'a) subst"
      using subst_set_reflects_unifiable [of \<sigma> "{(Var x, t)}"] by (auto simp: subst_set_def)
    have ?case
    proof (cases "unifiable (set E)")
      case True
      then have "(mset E, {#}) \<in> unif\<^sup>*"
        by (simp add: unifiable_imp_empty)
      from unif_rtrancl_mono [OF this, of "{#(t, Var x)#}"] obtain \<sigma>
        where "(mset E + {#(t, Var x)#}, {#(t \<cdot> \<sigma>, Var x \<cdot> \<sigma>)#}) \<in> unif\<^sup>*"
        by (auto simp: subst_mset_def)
      moreover obtain E' where "E' \<noteq> {#}"
        and "({#(t \<cdot> \<sigma>, Var x \<cdot> \<sigma>)#}, E') \<in> unif\<^sup>!"
        using not_unifiable_imp_not_empty_NF and **
          by (metis unifiable_insert_swap set_mset_single)
      ultimately show ?thesis by (auto simp: t_def)
    next
      case False
      moreover have "\<not> unifiable {(t, Var x)}"
        using * by (simp add: unifiable_def)
      ultimately have "\<not> unifiable (set ((t, Var x) # E))" by (auto simp: unifiable_def unifiers_def)
      then show ?thesis by (simp add: not_unifiable_imp_not_empty_NF t_def)
    qed }
  ultimately show ?case by blast
qed

lemma unify_complete:
  assumes "unify E bs = None"
  shows "unifiers (set E) = {}"
proof -
  from unify_None [OF assms] obtain E'
    where "E' \<noteq> {#}" and "(mset E, E') \<in> unif\<^sup>!" by blast
  then have "\<not> unifiable (set E)"
    using irreducible_reachable_imp_not_unifiable by force
  then show ?thesis
    by (auto simp: unifiable_def)
qed

corollary ex_unify_if_unifiers_not_empty: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "unifiers es \<noteq> {} \<Longrightarrow> set xs = es \<Longrightarrow> \<exists>ys. unify xs [] = Some ys"
  using unify_complete by auto

lemma mgu_complete:
  "mgu s t = None \<Longrightarrow> unifiers {(s, t)} = {}"
proof -
  assume "mgu s t = None"
  then have "unify [(s, t)] [] = None" by (cases "unify [(s, t)] []", auto simp: mgu_def)
  then have "unifiers (set [(s, t)]) = {}" by (rule unify_complete)
  then show ?thesis by simp
qed

corollary ex_mgu_if_unifiers_not_empty: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "unifiers {(t,u)} \<noteq> {} \<Longrightarrow> \<exists>\<mu>. mgu t u = Some \<mu>"
  using mgu_complete by auto

corollary ex_mgu_if_subst_apply_term_eq_subst_apply_term: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes t u :: "('f, 'v) Term.term" and \<sigma> :: "('f, 'v) subst"
  assumes t_eq_u: "t \<cdot> \<sigma> = u \<cdot> \<sigma>"
  shows "\<exists>\<mu> :: ('f, 'v) subst. Unification.mgu t u = Some \<mu>"
proof -
  from t_eq_u have "unifiers {(t, u)} \<noteq> {}"
    unfolding unifiers_def by auto
  thus ?thesis
    by (rule ex_mgu_if_unifiers_not_empty)
qed

lemma finite_subst_domain_subst_of:
  "finite (subst_domain (subst_of xs))"
proof (induct xs)
  case (Cons x xs)
  moreover have "finite (subst_domain (subst (fst x) (snd x)))" by (metis finite_subst_domain_subst)
  ultimately show ?case
    using subst_domain_compose [of "subst_of xs" "subst (fst x) (snd x)"]
    by (simp del: subst_subst_domain) (metis finite_subset infinite_Un)
qed simp

lemma unify_subst_domain: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes unif: "unify E [] = Some xs"
  shows "subst_domain (subst_of xs) \<subseteq> (\<Union>e \<in> set E. vars_term (fst e) \<union> vars_term (snd e))"
proof -
  from unify_Some_UNIF[OF unif] obtain xs' where
    "subst_of xs = compose xs'" and "UNIF xs' (mset E) {#}"
    by auto
  thus ?thesis
    using UNIF_subst_domain_subset
    by (metis (mono_tags, lifting) multiset.set_map set_mset_mset vars_mset_def)
qed

lemma mgu_subst_domain:
  assumes "mgu s t = Some \<sigma>"
  shows "subst_domain \<sigma> \<subseteq> vars_term s \<union> vars_term t"
proof -
  obtain xs where "unify [(s, t)] [] = Some xs" and "\<sigma> = subst_of xs"
    using assms by (simp add: mgu_def split: option.splits)
  thus ?thesis
    using unify_subst_domain by fastforce
qed

lemma mgu_finite_subst_domain:
  "mgu s t = Some \<sigma> \<Longrightarrow> finite (subst_domain \<sigma>)"
  by (drule mgu_subst_domain) (simp add: finite_subset)

lemma unify_range_vars: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes unif: "unify E [] = Some xs"
  shows "range_vars (subst_of xs) \<subseteq> (\<Union>e \<in> set E. vars_term (fst e) \<union> vars_term (snd e))"
proof -
  from unify_Some_UNIF[OF unif] obtain xs' where
    "subst_of xs = compose xs'" and "UNIF xs' (mset E) {#}"
    by auto
  thus ?thesis
    using UNIF_range_vars_subset
    by (metis (mono_tags, lifting) multiset.set_map set_mset_mset vars_mset_def)
qed

lemma mgu_range_vars: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "mgu s t = Some \<mu>"
  shows "range_vars \<mu> \<subseteq> vars_term s \<union> vars_term t"
proof -
  obtain xs where "unify [(s, t)] [] = Some xs" and "\<mu> = subst_of xs"
    using assms by (simp add: mgu_def split: option.splits)
  thus ?thesis
    using unify_range_vars by fastforce
qed

lemma unify_subst_domain_range_vars_disjoint: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes unif: "unify E [] = Some xs"
  shows "subst_domain (subst_of xs) \<inter> range_vars (subst_of xs) = {}"
proof -
  from unify_Some_UNIF[OF unif] obtain xs' where
    "subst_of xs = compose xs'" and "UNIF xs' (mset E) {#}"
    by auto
  thus ?thesis
    using UNIF_subst_domain_range_vars_Int by metis
qed

lemma mgu_subst_domain_range_vars_disjoint: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes "mgu s t = Some \<mu>"
  shows "subst_domain \<mu> \<inter> range_vars \<mu> = {}"
proof -
  obtain xs where "unify [(s, t)] [] = Some xs" and "\<mu> = subst_of xs"
    using assms by (simp add: mgu_def split: option.splits)
  thus ?thesis
    using unify_subst_domain_range_vars_disjoint by metis
qed

corollary subst_apply_term_eq_subst_apply_term_if_mgu: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  assumes mgu_t_u: "mgu t u = Some \<mu>"
  shows "t \<cdot> \<mu> = u \<cdot> \<mu>"
  using mgu_sound[OF mgu_t_u]
  by (simp add: is_imgu_def unifiers_def)

lemma mgu_same: "mgu t t = Some Var" \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  by (simp add: mgu_def unify_same)

lemma mgu_is_Var_if_not_in_equations: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes \<mu> :: "('f, 'v) subst" and E :: "('f, 'v) equations" and x :: 'v
  assumes
    mgu_\<mu>: "is_mgu \<mu> E" and
    x_not_in: "x \<notin> (\<Union>e\<in>E. vars_term (fst e) \<union> vars_term (snd e))"
  shows "is_Var (\<mu> x)"
proof -
  from mgu_\<mu> have unif_\<mu>: "\<mu> \<in> unifiers E" and minimal_\<mu>: "\<forall>\<tau> \<in> unifiers E. \<exists>\<gamma>. \<tau> = \<mu> \<circ>\<^sub>s \<gamma>"
    by (simp_all add: is_mgu_def)

  define \<tau> :: "('f, 'v) subst" where
    "\<tau> = (\<lambda>x. if x \<in> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e)) then \<mu> x else Var x)"

  have \<open>\<tau> \<in> unifiers E\<close>
    unfolding unifiers_def mem_Collect_eq
  proof (rule ballI)
    fix e assume "e \<in> E"
    with unif_\<mu> have "fst e \<cdot> \<mu> = snd e \<cdot> \<mu>"
      by blast
    moreover from \<open>e \<in> E\<close> have "fst e \<cdot> \<tau> = fst e \<cdot> \<mu>" and "snd e \<cdot> \<tau> = snd e \<cdot> \<mu>"
      unfolding term_subst_eq_conv
      by (auto simp: \<tau>_def)
    ultimately show "fst e \<cdot> \<tau> = snd e \<cdot> \<tau>"
      by simp
  qed
  with minimal_\<mu> obtain \<gamma> where "\<mu> \<circ>\<^sub>s \<gamma> = \<tau>"
    by auto
  with x_not_in have "(\<mu> \<circ>\<^sub>s \<gamma>) x = Var x"
    by (simp add: \<tau>_def)
  thus "is_Var (\<mu> x)"
    by (metis subst_apply_eq_Var subst_compose term.disc(1))
qed

corollary mgu_ball_is_Var: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "is_mgu \<mu> E \<Longrightarrow> \<forall>x \<in> - (\<Union>e\<in>E. vars_term (fst e) \<union> vars_term (snd e)). is_Var (\<mu> x)"
  by (rule ballI) (rule mgu_is_Var_if_not_in_equations[folded Compl_iff])

lemma mgu_inj_on: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes \<mu> :: "('f, 'v) subst" and E :: "('f, 'v) equations"
  assumes mgu_\<mu>: "is_mgu \<mu> E"
  shows "inj_on \<mu> (- (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e)))"
proof (rule inj_onI)
  fix x y
  assume
    x_in: "x \<in> - (\<Union>e\<in>E. vars_term (fst e) \<union> vars_term (snd e))" and
    y_in: "y \<in> - (\<Union>e\<in>E. vars_term (fst e) \<union> vars_term (snd e))" and
    "\<mu> x = \<mu> y"

  from mgu_\<mu> have unif_\<mu>: "\<mu> \<in> unifiers E" and minimal_\<mu>: "\<forall>\<tau> \<in> unifiers E. \<exists>\<gamma>. \<tau> = \<mu> \<circ>\<^sub>s \<gamma>"
    by (simp_all add: is_mgu_def)

  define \<tau> :: "('f, 'v) subst" where
    "\<tau> = (\<lambda>x. if x \<in> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e)) then \<mu> x else Var x)"

  have \<open>\<tau> \<in> unifiers E\<close>
    unfolding unifiers_def mem_Collect_eq
  proof (rule ballI)
    fix e assume "e \<in> E"
    with unif_\<mu> have "fst e \<cdot> \<mu> = snd e \<cdot> \<mu>"
      by blast
    moreover from \<open>e \<in> E\<close> have "fst e \<cdot> \<tau> = fst e \<cdot> \<mu>" and "snd e \<cdot> \<tau> = snd e \<cdot> \<mu>"
      unfolding term_subst_eq_conv
      by (auto simp: \<tau>_def)
    ultimately show "fst e \<cdot> \<tau> = snd e \<cdot> \<tau>"
      by simp
  qed
  with minimal_\<mu> obtain \<gamma> where "\<mu> \<circ>\<^sub>s \<gamma> = \<tau>"
    by auto
  hence "(\<mu> \<circ>\<^sub>s \<gamma>) x = Var x" and "(\<mu> \<circ>\<^sub>s \<gamma>) y = Var y"
    using ComplD[OF x_in] ComplD[OF y_in]
    by (simp_all add: \<tau>_def)
  with \<open>\<mu> x = \<mu> y\<close> show "x = y"
    by (simp add: subst_compose_def)
qed

lemma imgu_subst_domain_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes \<mu> :: "('f, 'v) subst" and E :: "('f, 'v) equations" and Evars :: "'v set"
  assumes imgu_\<mu>: "is_imgu \<mu> E" and fin_E: "finite E"
  defines "Evars \<equiv> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e))"
  shows "subst_domain \<mu> \<subseteq> Evars"
proof (intro Set.subsetI)
  from imgu_\<mu> have unif_\<mu>: "\<mu> \<in> unifiers E" and minimal_\<mu>: "\<forall>\<tau> \<in> unifiers E. \<mu> \<circ>\<^sub>s \<tau> = \<tau>"
    by (simp_all add: is_imgu_def)

  from fin_E obtain es :: "('f, 'v) equation list" where
    "set es = E"
    using finite_list by auto
  then obtain xs :: "('v \<times> ('f, 'v) Term.term) list" where
    unify_es: "unify es [] = Some xs"
    using unif_\<mu> ex_unify_if_unifiers_not_empty by blast

  define \<tau> :: "('f, 'v) subst" where
    "\<tau> = subst_of xs"

  have dom_\<tau>: "subst_domain \<tau> \<subseteq> Evars"
    using unify_subst_domain[OF unify_es, unfolded \<open>set es = E\<close>, folded Evars_def \<tau>_def] .
  have range_vars_\<tau>: "range_vars \<tau> \<subseteq> Evars"
    using unify_range_vars[OF unify_es, unfolded \<open>set es = E\<close>, folded Evars_def \<tau>_def] .

  have "\<tau> \<in> unifiers E"
    using \<open>set es = E\<close> unify_es \<tau>_def is_imgu_def unify_sound by blast
  with minimal_\<mu> have \<mu>_comp_\<tau>: "\<And>x. (\<mu> \<circ>\<^sub>s \<tau>) x = \<tau> x"
    by auto

  fix x :: 'v assume "x \<in> subst_domain \<mu>"
  hence "\<mu> x \<noteq> Var x"
    by (simp add: subst_domain_def)

  show "x \<in> Evars"
  proof (cases "x \<in> subst_domain \<tau>")
    case True
    thus ?thesis
      using dom_\<tau> by auto
  next
    case False
    hence "\<tau> x = Var x"
      by (simp add: subst_domain_def)
    hence "\<mu> x \<cdot> \<tau> = Var x"
      using \<mu>_comp_\<tau>[of x] by (simp add: subst_compose)
    thus ?thesis
    proof (rule subst_apply_eq_Var[of "\<mu> x" \<tau> x])
      show "\<And>y. \<mu> x = Var y \<Longrightarrow> \<tau> y = Var x \<Longrightarrow> ?thesis"
        using \<open>\<mu> x \<noteq> Var x\<close> range_vars_\<tau> mem_range_varsI[of \<tau> _ x] by auto
    qed
  qed
qed

lemma imgu_range_vars_of_equations_vars_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes \<mu> :: "('f, 'v) subst" and E :: "('f, 'v) equations" and Evars :: "'v set"
  assumes imgu_\<mu>: "is_imgu \<mu> E" and fin_E: "finite E"
  defines "Evars \<equiv> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e))"
  shows "(\<Union>x \<in> Evars. vars_term (\<mu> x)) \<subseteq> Evars"
proof (rule Set.subsetI)
  from imgu_\<mu> have unif_\<mu>: "\<mu> \<in> unifiers E" and minimal_\<mu>: "\<forall>\<tau> \<in> unifiers E. \<mu> \<circ>\<^sub>s \<tau> = \<tau>"
    by (simp_all add: is_imgu_def)

  from fin_E obtain es :: "('f, 'v) equation list" where
    "set es = E"
    using finite_list by auto
  then obtain xs :: "('v \<times> ('f, 'v) Term.term) list" where
    unify_es: "unify es [] = Some xs"
    using unif_\<mu> ex_unify_if_unifiers_not_empty by blast

  define \<tau> :: "('f, 'v) subst" where
    "\<tau> = subst_of xs"

  have dom_\<tau>: "subst_domain \<tau> \<subseteq> Evars"
    using unify_subst_domain[OF unify_es, unfolded \<open>set es = E\<close>, folded Evars_def \<tau>_def] .
  have range_vars_\<tau>: "range_vars \<tau> \<subseteq> Evars"
    using unify_range_vars[OF unify_es, unfolded \<open>set es = E\<close>, folded Evars_def \<tau>_def] .
  hence ball_vars_apply_\<tau>_subset: "\<forall>x \<in> subst_domain \<tau>. vars_term (\<tau> x) \<subseteq> Evars"
    unfolding range_vars_def
    by (simp add: SUP_le_iff)

  have "\<tau> \<in> unifiers E"
    using \<open>set es = E\<close> unify_es \<tau>_def is_imgu_def unify_sound by blast
  with minimal_\<mu> have \<mu>_comp_\<tau>: "\<And>x. (\<mu> \<circ>\<^sub>s \<tau>) x = \<tau> x"
    by auto

  fix y :: 'v assume "y \<in> (\<Union>x \<in> Evars. vars_term (\<mu> x))"
  then obtain x :: 'v where
    x_in: "x \<in> Evars" and y_in: "y \<in> vars_term (\<mu> x)"
    by (auto simp: subst_domain_def)
  have vars_\<tau>_x: "vars_term (\<tau> x) \<subseteq> Evars"
    using ball_vars_apply_\<tau>_subset subst_domain_def x_in by fastforce

  show "y \<in> Evars"
  proof (rule ccontr)
    assume "y \<notin> Evars"
    hence "y \<notin> vars_term (\<tau> x)"
      using vars_\<tau>_x by blast
    moreover have "y \<in> vars_term ((\<mu> \<circ>\<^sub>s \<tau>) x)"
    proof -
      have "\<tau> y = Var y"
        using \<open>y \<notin> Evars\<close> dom_\<tau>
        by (auto simp add: subst_domain_def)
      thus ?thesis
        unfolding subst_compose_def vars_term_subst_apply_term UN_iff
        using y_in by force
    qed
    ultimately show False
      using \<mu>_comp_\<tau>[of x] by simp
  qed
qed

lemma imgu_range_vars_subset: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  fixes \<mu> :: "('f, 'v) subst" and E :: "('f, 'v) equations"
  assumes imgu_\<mu>: "is_imgu \<mu> E" and fin_E: "finite E"
  shows "range_vars \<mu> \<subseteq> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e))"
proof -
  have "range_vars \<mu> = (\<Union>x \<in> subst_domain \<mu>. vars_term (\<mu> x))"
    by (simp add: range_vars_def)
  also have "\<dots> \<subseteq> (\<Union>x \<in> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e)). vars_term (\<mu> x))"
    using imgu_subst_domain_subset[OF imgu_\<mu> fin_E] by fast
  also have "\<dots> \<subseteq> (\<Union>e \<in> E. vars_term (fst e) \<union> vars_term (snd e))"
    using imgu_range_vars_of_equations_vars_subset[OF imgu_\<mu> fin_E] by metis
  finally show ?thesis .
qed

end


(*  Title:      HOL/ex/Set_Comprehension_Pointfree_Examples.thy
    Author:     Lukas Bulwahn, Rafal Kolanski
    Copyright   2012 TU Muenchen
*)

section \<open>Examples for the set comprehension to pointfree simproc\<close>

theory Set_Comprehension_Pointfree_Examples
imports Main
begin

declare [[simproc add: finite_Collect]]

lemma
  "finite (UNIV::'a set) \<Longrightarrow> finite {p. \<exists>x::'a. p = (x, x)}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> b \<in> B}"
  by simp

lemma
  "finite B \<Longrightarrow> finite A' \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> a \<in> A' \<and> b \<in> B}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> b \<in> B \<and> b \<in> B'}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite {f a b c| a b c. a \<in> A \<and> b \<in> B \<and> c \<in> C}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite D \<Longrightarrow>
     finite {f a b c d| a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite D \<Longrightarrow> finite E \<Longrightarrow>
    finite {f a b c d e | a b c d e. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D \<and> e \<in> E}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite D \<Longrightarrow> finite E \<Longrightarrow>
    finite {f a d c b e | e b c d a. b \<in> B \<and> a \<in> A \<and> e \<in> E' \<and> c \<in> C \<and> d \<in> D \<and> e \<in> E \<and> b \<in> B'}"
  by simp

lemma
  "\<lbrakk> finite A ; finite B ; finite C ; finite D \<rbrakk>
  \<Longrightarrow> finite ({f a b c d| a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D})"
  by simp

lemma
  "finite ((\<lambda>(a,b,c,d). f a b c d) ` (A \<times> B \<times> C \<times> D))
  \<Longrightarrow> finite ({f a b c d| a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D})"
  by simp

lemma
  "finite S \<Longrightarrow> finite {s'. \<exists>s\<in>S. s' = f a e s}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> b \<in> B \<and> a \<notin> Z}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite R \<Longrightarrow> finite {f a b x y| a b x y. a \<in> A \<and> b \<in> B \<and> (x,y) \<in> R}"
by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite R \<Longrightarrow> finite {f a b x y| a b x y. a \<in> A \<and> (x,y) \<in> R \<and> b \<in> B}"
by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite R \<Longrightarrow> finite {f a (x, b) y| y b x a. a \<in> A \<and> (x,y) \<in> R \<and> b \<in> B}"
by simp

lemma
  "finite A \<Longrightarrow> finite AA \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. (a \<in> A \<or> a \<in> AA) \<and> b \<in> B \<and> a \<notin> Z}"
by simp

lemma
  "finite A1 \<Longrightarrow> finite A2 \<Longrightarrow> finite A3 \<Longrightarrow> finite A4 \<Longrightarrow> finite A5 \<Longrightarrow> finite B \<Longrightarrow>
     finite {f a b c | a b c. ((a \<in> A1 \<and> a \<in> A2) \<or> (a \<in> A3 \<and> (a \<in> A4 \<or> a \<in> A5))) \<and> b \<in> B \<and> a \<notin> Z}"
apply simp
oops

lemma "finite B \<Longrightarrow> finite {c. \<exists>x. x \<in> B \<and> c = a * x}"
by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a * g b |a b. a \<in> A \<and> b \<in> B}"
by simp

lemma
  "finite S \<Longrightarrow> inj (\<lambda>(x, y). g x y) \<Longrightarrow> finite {f x y| x y. g x y \<in> S}"
  by (auto intro: finite_vimageI)

lemma
  "finite A \<Longrightarrow> finite S \<Longrightarrow> inj (\<lambda>(x, y). g x y) \<Longrightarrow> finite {f x y z | x y z. g x y \<in> S & z \<in> A}"
  by (auto intro: finite_vimageI)

lemma
  "finite S \<Longrightarrow> finite A \<Longrightarrow> inj (\<lambda>(x, y). g x y) \<Longrightarrow> inj (\<lambda>(x, y). h x y)
    \<Longrightarrow> finite {f a b c d | a b c d. g a c \<in> S \<and> h b d \<in> A}"
  by (auto intro: finite_vimageI)

lemma
  assumes "finite S" shows "finite {(a,b,c,d). ([a, b], [c, d]) \<in> S}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)
  (* injectivity to be automated with further rules and automation *)

schematic_goal (* check interaction with schematics *)
  "finite {x :: ?'A \<Rightarrow> ?'B \<Rightarrow> bool. \<exists>a b. x = Pair_Rep a b}
   = finite ((\<lambda>(b :: ?'B, a:: ?'A). Pair_Rep a b) ` (UNIV \<times> UNIV))"
  by simp

declare [[simproc del: finite_Collect]]

section \<open>Testing simproc in code generation\<close>

definition union :: "nat set => nat set => nat set"
where
  "union A B = {x. x \<in> A \<or> x \<in> B}"

definition common_subsets :: "nat set \<Rightarrow> nat set \<Rightarrow> nat set set"
where
  "common_subsets S1 S2 = {S. S \<subseteq> S1 \<and> S \<subseteq> S2}"

definition products :: "nat set => nat set => nat set"
where
  "products A B = {c. \<exists>a b. a \<in> A \<and> b \<in> B \<and> c = a * b}"

export_code union common_subsets products checking SML

end