(*  Title:       Conflict analysis/List Interleaving Operator
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
header "List Interleaving Operator"
theory Interleave
imports Main "~~/src/HOL/Library/Permutation" Misc
begin
text_raw {*\label{thy:Interleave}*}

text {*
  This theory defines an operator to return the set of all possible interleavings of two lists.
*}

(*
  Is \<Otimes>-operator needed ?
    Should we better do a reformulation of \<otimes> on sets of lists, to get an associative, commutative operator with identity (ACI ?) ?
*)

subsection "Definitions"

subsubsection "Prepend and concatenate lifted to sets"

definition list_set_cons :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<cdot>" 65)
  where [simp]: "a\<cdot>S = op # a ` S"

definition list_set_append :: "'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<odot>" 65)
  where [simp]: "a\<odot>S = op @ a ` S"

subsubsection "The interleaving operator"

function
  interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" (infixr "\<otimes>" 64)
where
  "[]\<otimes>b = {b}"
  | "a\<otimes>[] = {a}"
  | "a#l \<otimes> b#r = ((a\<cdot>(l \<otimes> b#r)) \<union> (b\<cdot>(a#l \<otimes> r)))"
by pat_completeness auto
termination by lexicographic_order

subsection "Properties"

subsubsection "Lifted prepend and concatenate operators"
lemma cons_set_cons_eq: "a#l \<in> b\<cdot>S = (a=b & l\<in>S)"
  by auto
lemma append_set_append_eq: "\<lbrakk>length a = length b\<rbrakk> \<Longrightarrow> a@l \<in> b\<odot>S = (a=b & l\<in>S)"
  by auto

lemma list_set_cons_cases[cases set]: "\<lbrakk>w\<in>a\<cdot>S; !!w'. \<lbrakk> w=a#w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by auto
lemma list_set_append_cases[cases set]: "\<lbrakk>w\<in>a\<odot>S; !!w'. \<lbrakk> w=a@w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by auto

subsubsection "Standard simplification-, introduction-, elimination-, and induction rules"
lemma interleave_cons1: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> x#a \<otimes> b"
  apply(case_tac b)
  apply(auto)
done

lemma interleave_cons2: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> a \<otimes> x#b"
  apply(case_tac a)
  apply(auto)
done

lemmas interleave_cons = interleave_cons1 interleave_cons2

lemma interleave_empty[simp]: "[]\<in>a\<otimes>b = (a=[] & b=[])"
  apply(case_tac a)
  apply(case_tac b)
  apply(simp)
  apply(simp)
  apply(case_tac b)
  apply(auto)
done

(* TODO: Is this wise as default simp ?*)
lemma interleave_length[rule_format, simp]: "ALL x : a\<otimes>b . length x = length a + length b"
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma interleave_same[simp]: "y\<in>l\<otimes>y = (l=[])"
  apply (rule iffI)
  apply (subgoal_tac "length y = length l + length y")
  apply (simp del: interleave_length)
  apply (erule interleave_length)
  apply simp
done

lemma interleave_comm[simp]: "a\<otimes>b = b\<otimes>a" (is "?P f a b")
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma interleave_cont_conc[rule_format, simp]: "ALL b . a@b \<in> a\<otimes>b"
  apply(induct_tac a)
  apply(auto simp add: interleave_cons)
done

lemma interleave_cont_rev_conc[simp]: "b@a \<in> a\<otimes>b"
  apply (subgoal_tac "b@a \<in> b\<otimes>a")
  apply(simp)
  apply(simp only: interleave_cont_conc)
done

lemma interleave_not_empty: "a\<otimes>b ~= {}"
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma cons_interleave_split: "\<lbrakk>a#l \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=a#lh & l \<in> lh\<otimes>l2 | l2=a#lh & l \<in> l1\<otimes>lh )"
  apply(case_tac l1)
  apply(auto)
  apply(case_tac l2)
  apply(auto)
done

lemma cons_interleave_cases[cases set, case_names left right]: "\<lbrakk>a#l \<in> l1\<otimes>l2; !!lh . \<lbrakk>l1=a#lh; l \<in> lh\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!lh. \<lbrakk>l2=a#lh; l \<in> l1\<otimes>lh\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: cons_interleave_split)

lemma interleave_cases[cases set, case_names empty left right]: "\<lbrakk>l\<in>l1\<otimes>l2; \<lbrakk> l=[]; l1=[]; l2=[] \<rbrakk> \<Longrightarrow> P; !!a l' l1'. \<lbrakk>l=a#l'; l1=a#l1'; l'\<in>l1'\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!a l' l2'. \<lbrakk>l=a#l'; l2=a#l2'; l'\<in>l1\<otimes>l2'\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (cases l)
  apply (simp)
  apply simp
  apply (erule cons_interleave_cases)
  apply simp_all
  done

lemma interleave_elem_induct[induct set, case_names empty left right]:
  "!!w1 w2. \<lbrakk> w\<in>w1\<otimes>w2; P [] [] []; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) (e#w1) w2; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) w1 (e#w2) \<rbrakk> \<Longrightarrow> P w w1 w2"
  by (induct w) (auto elim!: cons_interleave_cases intro!: interleave_cons)

lemma interleave_rev_cons1[rule_format]: "ALL a b . l \<in> a\<otimes>b \<longrightarrow> l@[x] \<in> a@[x] \<otimes> b" (is "?P l")
proof (induct l)
  case Nil show ?case by (simp)
  case (Cons e l)
    assume IH[rule_format]: "?P l"
    show "?P (e#l)" proof (intro allI impI)
      fix a b
      assume "e#l \<in> a\<otimes>b"
      then obtain c where SPLIT: "a=e#c & l\<in>c\<otimes>b | b=e#c & l\<in>a\<otimes>c" by (blast dest: cons_interleave_split)
      with IH have "a=e#c & l@[x]\<in>c@[x]\<otimes>b | b=e#c & l@[x]\<in>a@[x]\<otimes>c" by auto
      hence "a=e#c & e#l@[x]\<in>e#c@[x]\<otimes>b | b=e#c & e#l@[x]\<in>a@[x]\<otimes>e#c" by (auto simp add: interleave_cons)
      thus "(e#l)@[x]\<in>a@[x]\<otimes>b" by auto
    qed
qed

corollary interleave_rev_cons2: "l \<in> a\<otimes>b \<Longrightarrow> l@[x] \<in> a \<otimes> b@[x]"
proof -
  assume "l \<in> a\<otimes>b"
  hence "l\<in>b\<otimes>a" by auto
  hence "l@[x] \<in> b@[x] \<otimes> a" by (blast dest: interleave_rev_cons1)
  thus ?thesis by auto
qed

lemmas interleave_rev_cons = interleave_rev_cons1 interleave_rev_cons2

subsubsection "Interleaving and list concatenation"

lemma interleave_append1: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> x@a \<otimes> b" proof -
  have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> x@a \<otimes> b" (is "?P x") proof (induct x)
    show "?P []" by simp
  next
    fix e
    fix x::"'a list"
    assume IH: "?P x"
    show "?P (e#x)" proof (intro impI allI)
      fix l::"'a list"
      fix a b
      assume "l \<in> a \<otimes> b"
      with IH have "x@l \<in> x@a \<otimes> b" by auto
      with interleave_cons1 show "(e # x) @ l \<in> (e # x) @ a \<otimes> b" by force
    qed
  qed
  moreover assume "l \<in> a \<otimes> b"
  ultimately show ?thesis by blast
qed

lemma interleave_append2: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> a \<otimes> x@b" proof -
  have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> a \<otimes> x@b" (is "?P x") proof (induct x)
    show "?P []" by simp
  next
    fix a
    fix x::"'a list"
    assume IH: "\<forall>l a b. l \<in> a \<otimes> b \<longrightarrow> x @ l \<in> a \<otimes> x @ b"
    show "\<forall>l aa b. l \<in> aa \<otimes> b \<longrightarrow> (a # x) @ l \<in> aa \<otimes> (a # x) @ b" proof (intro impI allI)
      fix l::"'a list"
      fix aa b
      assume "l \<in> aa \<otimes> b"

      with IH have "x@l \<in> aa \<otimes> x@b" by auto
      with interleave_cons2 show "(a # x) @ l \<in> aa \<otimes> (a # x) @ b" by force
    qed
  qed
  moreover assume "l \<in> a \<otimes> b"
  ultimately show ?thesis by blast
qed

lemmas interleave_append = interleave_append1 interleave_append2

lemma interleave_rev_append1: "!!a b w. w\<in>a\<otimes>b \<Longrightarrow> w@w' \<in> a@w' \<otimes> b"
proof (induct w' rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc e w') note IHP=this
  hence "w@w'\<in>a@w'\<otimes>b" by auto
  thus ?case using interleave_rev_cons1[of "w@w'" "a@w'" "b"] by (simp)
qed

lemma interleave_rev1[rule_format]: "ALL w1 w2 . (w\<in>w1\<otimes>w2) \<longrightarrow> (rev w \<in> rev w1 \<otimes> rev w2)" (is "?P w")
proof (induct w)
  case Nil show ?case by (simp)
  case (Cons e w)
    assume IH[rule_format]: "?P w"
    show ?case proof (clarsimp)
      fix w1 w2
      assume "e # w \<in> w1 \<otimes> w2"
      then obtain w' where "w1=e#w' & w\<in>w'\<otimes>w2 | w2=e#w' & w\<in>w1\<otimes>w'" by (blast dest: cons_interleave_split)
      with IH have "w1=e#w' & rev w\<in>rev w' \<otimes> rev w2 | w2=e#w' & rev w \<in> rev w1 \<otimes> rev w'" by auto
      thus "rev w @ [e]\<in>rev w1 \<otimes> rev w2" by (auto simp add: interleave_rev_cons)
    qed
qed

corollary interleave_rev2: "(rev w \<in> rev w1 \<otimes> rev w2) \<Longrightarrow> (w\<in>w1\<otimes>w2)"
  apply (subgoal_tac "(rev w\<in>rev w1\<otimes>rev w2) = (rev (rev w) \<in> rev (rev w1) \<otimes> rev (rev w2))")
  apply(simp)
  apply (blast dest: interleave_rev1)
done

lemmas interleave_rev = interleave_rev1 interleave_rev2

lemma rev_cons_interleave_split: "\<lbrakk>l@[a] \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=lh@[a] & l \<in> lh\<otimes>l2 | l2=lh@[a] & l \<in> l1\<otimes>lh )"
proof -
  assume "l@[a] \<in> l1\<otimes>l2"
  hence "a#rev l \<in> rev l1 \<otimes> rev l2" by (auto dest: interleave_rev)
  then obtain lh where "rev l1 = a#lh & rev l \<in> lh\<otimes>rev l2 | rev l2 = a#lh & rev l \<in> rev l1 \<otimes> lh" by (blast dest: cons_interleave_split)
  hence "rev l1 = a#lh & l \<in> rev lh \<otimes> l2 | rev l2 = a#lh & l \<in> l1 \<otimes> rev lh" by (auto dest: interleave_rev)
  hence "l1 = rev lh @ [a] & l \<in> rev lh \<otimes> l2 | l2 = rev lh @ [a] & l \<in> l1 \<otimes> rev lh" by (simp add: rev_swap)
  thus ?thesis by blast
qed

subsubsection "Associativity"

lemma interleave_s_assoc1[rule_format]: "ALL w1 ws w2 w3 . (w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3))" proof (induct w)
  case Nil show ?case by (auto)
  case (Cons e w)
    assume IH: "ALL w1 ws w2 w3 . w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3)"
    show ?case proof (intro impI allI)
      fix w1 ws w2 w3
      assume A: "e#w \<in> w1 \<otimes> ws \<and> ws \<in> w2 \<otimes> w3"
      then obtain wh where CASES: "w1=e#wh & w\<in>wh\<otimes>ws | ws=e#wh & w\<in>w1\<otimes>wh" by (blast dest!: cons_interleave_split)
      moreover {
        assume CASE: "w1=e#wh & w\<in>wh\<otimes>ws"
        with A IH obtain ws' where "ws'\<in>wh\<otimes>w2 & w\<in>ws'\<otimes>w3" by (blast)
        hence "e#ws'\<in> (e#wh)\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
        with CASE have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
      } moreover {
        assume CASE: "ws=e#wh & w\<in>w1\<otimes>wh"
        with A obtain whh where "w2=e#whh & wh\<in>whh\<otimes>w3 | w3=e#whh & wh\<in>w2\<otimes>whh" by (blast dest!: cons_interleave_split)
        moreover {
          assume SCASE: "w2=e#whh & wh\<in>whh\<otimes>w3"
          with CASE IH obtain ws' where "ws'\<in>w1\<otimes>whh & w\<in>ws'\<otimes>w3" by blast
          with SCASE have "e#ws'\<in>w1\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
          hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
        } moreover {
          assume SCASE: "w3=e#whh & wh\<in>w2\<otimes>whh"
          with CASE IH obtain ws' where "ws'\<in>w1\<otimes>w2 & w\<in>ws'\<otimes>whh" by blast
          with SCASE have "ws'\<in>w1\<otimes>w2 & e#w \<in> ws'\<otimes>w3" by (auto simp add: interleave_cons)
          hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
        } ultimately have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
      } ultimately show "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
    qed
qed

lemma interleave_s_assoc2: "\<lbrakk>w\<in>ws\<otimes>w3; ws\<in>w1\<otimes>w2\<rbrakk> \<Longrightarrow> EX ws' : w2\<otimes>w3 . w \<in> w1\<otimes>ws'" proof -
  assume "w \<in> ws \<otimes> w3" "ws \<in> w1 \<otimes> w2"
  hence "w \<in> w3 \<otimes> ws & ws \<in> w2 \<otimes> w1" by simp
  hence "EX ws':w3\<otimes>w2 . w\<in>ws'\<otimes>w1" by (simp only: interleave_s_assoc1)
  thus ?thesis by simp
qed

lemmas interleave_s_assoc = interleave_s_assoc1 interleave_s_assoc2

subsubsection "Relation to other standard list operations"

lemma interleave_set: "w\<in>w1\<otimes>w2 \<Longrightarrow> set w = set w1 \<union> set w2"
  by (induct rule: interleave_elem_induct) auto
lemma interleave_map: "w\<in>w1\<otimes>w2 \<Longrightarrow> map f w \<in> map f w1 \<otimes> map f w2"
  by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)
lemma interleave_filter: "w\<in>w1\<otimes>w2 \<Longrightarrow> filter f w \<in> filter f w1 \<otimes> filter f w2"
  by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)

subsubsection "Relation to sublist order"

lemma ileq_interleave_alt: "l'\<preceq>l == \<exists>lb. l\<in>lb \<otimes> l'" proof (rule eq_reflection)
  {fix l' l have "l'\<preceq>l \<Longrightarrow> \<exists>lb. l\<in>lb \<otimes> l'" by (induct rule: less_eq_list_induct) (simp, (blast intro: interleave_cons)+)}
  moreover {fix l have "!!lb l'. l\<in>lb\<otimes>l' \<Longrightarrow> l'\<preceq>l" by (induct l) (auto intro: less_eq_list_drop elim!: cons_interleave_cases)}
  ultimately show "(l'\<preceq>l) = (\<exists>lb. l\<in>lb \<otimes> l')" by blast
qed

lemma ileq_interleave: "w\<in>w1\<otimes>w2 \<Longrightarrow> w1\<preceq>w & w2\<preceq>w"
  by (unfold ileq_interleave_alt, auto)

lemma ilt_ex_notempty: "x < y \<longleftrightarrow> (\<exists>xs. xs \<noteq> [] \<and> y \<in> xs \<otimes> x)"
  apply (auto simp add: order_less_le ileq_interleave_alt)
  apply (case_tac lb)
  apply auto
done

lemma ilt_interleave1: "\<lbrakk>w\<in>w1\<otimes>w2; w1~=[]\<rbrakk> \<Longrightarrow> w2<w"
  by (simp only: ilt_ex_notempty, blast)
lemma ilt_interleave2: "\<lbrakk>w\<in>w1\<otimes>w2; w2~=[]\<rbrakk> \<Longrightarrow> w1<w"
  by (simp only: ilt_ex_notempty interleave_comm[of w1 w2], blast)
lemmas ilt_interleave = ilt_interleave1 ilt_interleave2

subsubsection "Exotic/specialized lemmas"
-- {* Recover structure of @{text w} wrt. to structure of @{text "w1"} *}
lemma interleave_recover1[rule_format]: "ALL w1a w1b w2 . w\<in>(w1a@w1b)\<otimes>w2 \<longrightarrow> (EX wa wb w2a w2b . w=wa@wb & w2=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b)"
  (is "?P w" is "ALL w1a w1b w2 . ?PRE w w1a w1b w2 \<longrightarrow> ?CONS w w1a w1b w2")
proof (induct w)
  case Nil show ?case by (auto)
  case (Cons e w)
    assume IH[rule_format]: "?P w"
    show "?P (e#w)" proof (intro allI impI)
      fix w1a w1b w2
      assume PRE: "e # w \<in> w1a @ w1b \<otimes> w2"
      {
        assume CASE: "w1a=[]"
        with PRE have "e#w=[]@(e#w) & w2=[]@w2 & []\<in>w1a\<otimes>[] & e#w\<in>w1b\<otimes>w2" by (auto)
        hence "?CONS (e#w) w1a w1b w2" by blast
      } moreover {
        assume CASE: "w1a~=[]"
        with PRE obtain wh where SCASES: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2 | w2=e#wh & w\<in>w1a@w1b\<otimes>wh" by (blast dest: cons_interleave_split)
        moreover {
          assume SCASE: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2"
          with CASE obtain w1ah where W1AFMT: "w1a=e#w1ah & w1ah@w1b=wh" by (cases w1a, auto)
          with SCASE have "w\<in>w1ah@w1b\<otimes>w2" by auto
          with IH[of w1ah w1b w2] obtain wa wb w2a w2b where "w=wa@wb & w2=w2a@w2b & wa\<in>w1ah\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (blast)
          with W1AFMT have "e#w=(e#wa)@wb & e#w\<in>e#wa\<otimes>wb & w2=w2a@w2b & e#wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
          hence "?CONS (e#w) w1a w1b w2" by blast
        } moreover {
          assume SCASE: "w2=e#wh & w\<in>w1a@w1b\<otimes>wh"
          with IH[of w1a w1b wh] obtain wa wb w2a w2b where "w=wa@wb & wh=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by blast
          with SCASE have "e#w=(e#wa)@wb & w2=(e#w2a)@w2b & e#wa\<in>w1a\<otimes>e#w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
          hence "?CONS (e#w) w1a w1b w2" by blast
        }
        ultimately have "?CONS (e#w) w1a w1b w2" by blast
      }
      ultimately show "?CONS (e#w) w1a w1b w2" by blast
    qed
qed

lemma interleave_recover2: "w\<in>w1\<otimes>(w2a@w2b) \<Longrightarrow> EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b"
proof -
  assume "w\<in>w1\<otimes>(w2a@w2b)"
  hence "w\<in>(w2a@w2b)\<otimes>w1" by auto
  hence "EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w2a\<otimes>w1a & wb\<in>w2b\<otimes>w1b" by (blast dest: interleave_recover1)
  thus ?thesis by auto
qed

lemmas interleave_recover = interleave_recover1 interleave_recover2

-- "Split operands according to element of result"
lemma interleave_unconc: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 \<Longrightarrow> \<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22"
proof (induct l1)
  case Nil hence "w1=[]@w1 & w2=[]@w2 & []\<in>[]\<otimes>[] & l2\<in>w1\<otimes>w2" by auto
  thus ?case by fast
next
  case (Cons e l1') note IHP=this
  hence "e#(l1'@l2)\<in>w1\<otimes>w2" by auto
  with cons_interleave_split obtain w' where "(w1=e#w' & l1'@l2\<in>w'\<otimes>w2) | (w2=e#w' & l1'@l2\<in>w1\<otimes>w')" (is "?C1 | ?C2") by (fast)
  moreover {
    assume CASE: ?C1
    moreover then obtain w11' w12' w21 w22 where "w'=w11'@w12' \<and> w2=w21@w22 \<and> l1'\<in>w11'\<otimes>w21 \<and> l2\<in>w12'\<otimes>w22" by (fast dest: IHP(1))
    moreover hence "e#w'=(e#w11')@w12' & e#l1'\<in>(e#w11')\<otimes>w21" by (auto dest: interleave_cons)
    ultimately have ?case by fast
  } moreover {
    assume CASE: ?C2
    moreover then obtain w11 w12 w21' w22' where "w1=w11@w12 \<and> w'=w21'@w22' \<and> l1'\<in>w11\<otimes>w21' \<and> l2\<in>w12\<otimes>w22'" by (fast dest: IHP(1))
    moreover hence "e#w'=(e#w21')@w22' & e#l1'\<in>w11\<otimes>(e#w21')" by (auto dest: interleave_cons)
    ultimately have ?case by fast
  } ultimately show ?case by fast
qed

-- {* Reverse direction of @{thm [source] "interleave_unconc"} *}
lemma interleave_reconc: "!!w11 w21 l2 w12 w22 . \<lbrakk>l1\<in>w11\<otimes>w21;l2\<in>w12\<otimes>w22\<rbrakk> \<Longrightarrow> l1@l2\<in>(w11@w12)\<otimes>(w21@w22)"
proof (induct l1)
  case Nil thus ?case by (auto)
next
  case (Cons e l1') note IHP=this
  then obtain w' where "(w11=e#w' & l1'\<in>w'\<otimes>w21) | (w21=e#w' & l1'\<in>w11\<otimes>w')" (is "?C1 | ?C2") by (fast dest: cons_interleave_split)
  moreover {
    assume CASE: ?C1
    moreover with IHP have "l1'@l2\<in>(w'@w12)\<otimes>(w21@w22)" by auto
    ultimately have ?case by (auto dest: interleave_cons)
  } moreover {
    assume CASE: ?C2
    moreover with IHP have "l1'@l2\<in>(w11@w12)\<otimes>(w'@w22)" by auto
    ultimately have ?case by (auto dest: interleave_cons)
  } ultimately show ?case by fast
qed

(* interleave_unconc and interleave_reconc as equivalence *)
lemma interleave_unconc_eq: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 = (\<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22)"
  by (fast dest: interleave_reconc interleave_unconc)

end


section \<open>Lens instances\<close>

theory Lens_Instances
  imports Lens_Order
  keywords "alphabet" :: "thy_decl_block"
begin

text \<open>In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.\<close>

subsection \<open>Function lens\<close>

text \<open>We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.\<close>

definition fun_lens :: "'a \<Rightarrow> ('b::two \<Longrightarrow> ('a \<Rightarrow> 'b))" where
[lens_defs]: "fun_lens x = \<lparr> lens_get = (\<lambda> f. f x), lens_put = (\<lambda> f u. f(x := u)) \<rparr>"

lemma fun_wb_lens: "wb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

lemma fun_lens_indep:
  "fun_lens x \<bowtie> fun_lens y \<longleftrightarrow> x \<noteq> y"
proof -
  obtain u v :: "'a::two" where "u \<noteq> v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

text \<open>The function range lens allows us to focus on a particular region on a functions range.\<close>

definition fun_ran_lens :: "('c \<Longrightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Longrightarrow> '\<alpha>) \<Rightarrow> (('a \<Rightarrow> 'c) \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "fun_ran_lens X Y = \<lparr> lens_get = \<lambda> s. get\<^bsub>X\<^esub> \<circ> get\<^bsub>Y\<^esub> s
                                 , lens_put = \<lambda> s v. put\<^bsub>Y\<^esub> s (\<lambda> x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \<rparr>"

lemma fun_ran_mwb_lens: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection \<open>Map lens\<close>

definition map_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a \<rightharpoonup> 'b))" where
[lens_defs]: "map_lens x = \<lparr> lens_get = (\<lambda> f. the (f x)), lens_put = (\<lambda> f u. f(x \<mapsto> u)) \<rparr>"

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

subsection \<open>List lens\<close>

definition list_pad_out :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

definition list_augment :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

definition nth' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

lemma list_update_append_lemma1: "i < length xs \<Longrightarrow> xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys \<Longrightarrow> xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = list_pad_out xs (max i j)[i := u, j := v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

lemma list_augment_commute:
  "i \<noteq> j \<Longrightarrow> list_augment (list_augment \<sigma> j v) i u = list_augment (list_augment \<sigma> i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i \<noteq> j \<Longrightarrow> nth' (list_augment \<sigma> i v) j = nth' \<sigma> j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

definition list_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a list)" where
[lens_defs]: "list_lens i = \<lparr> lens_get = (\<lambda> xs. nth' xs i)
                            , lens_put = (\<lambda> xs x. list_augment xs i x) \<rparr>"

abbreviation "hd_lens \<equiv> list_lens 0"

definition tl_lens :: "'a list \<Longrightarrow> 'a list" where
[lens_defs]: "tl_lens = \<lparr> lens_get = (\<lambda> xs. tl xs)
                        , lens_put = (\<lambda> xs xs'. hd xs # xs') \<rparr>"

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

lemma tail_lens_mwb:
  "mwb_lens tl_lens"
  by (unfold_locales, simp_all add: tl_lens_def)

lemma list_lens_indep:
  "i \<noteq> j \<Longrightarrow> list_lens i \<bowtie> list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hd_lens \<bowtie> tl_lens"
  apply (rule lens_indepI)
  apply (simp_all add: list_lens_def tl_lens_def)
  apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
  apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis Nitpick.size_list_simp(2) One_nat_def add_Suc_right append.simps(1) append_Nil2 diff_Suc_Suc diff_zero hd_Cons_tl list.inject list.size(4) list_augment_0 list_augment_def list_augment_same_twice list_pad_out_def nth_list_augment replicate.simps(1) replicate.simps(2) tl_Nil)
done

subsection \<open>Record field lenses\<close>

abbreviation (input) "fld_put f \<equiv> (\<lambda> \<sigma> u. f (\<lambda>_. u) \<sigma>)"

syntax "_FLDLENS" :: "id \<Rightarrow> ('a \<Longrightarrow> 'r)"  ("FLDLENS _")
translations "FLDLENS x" => "\<lparr> lens_get = x, lens_put = CONST fld_put (_update_name x) \<rparr>"

text {* Introduce the alphabet command that creates a record with lenses for each field *}

ML_file "Lens_Record.ML"

text {* The following theorem attribute stores splitting theorems for alphabet types *}

named_theorems alpha_splits

(*
alphabet mylens =
  x :: nat
  y :: string

lemma mylens_bij_lens:
  "bij_lens (x +\<^sub>L y +\<^sub>L mylens_child_lens)"
  by (unfold_locales, simp_all add: lens_plus_def x_def y_def mylens_child_lens_def id_lens_def sublens_def lens_comp_def prod.case_eq_if)

alphabet mylens_2 = mylens +
  z :: int
  k :: "string list"

alphabet mylens_3 = mylens_2 +
  n :: real
  h :: nat
*)

subsection {* Lens Interpretation *}

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]
end
end


(*  Title:      HOL/Cardinals/Wellorder_Embedding.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order embeddings.
*)

section {* Well-Order Embeddings *}

theory Wellorder_Embedding
imports BNF_Wellorder_Embedding Fun_More Wellorder_Relation
begin

subsection {* Auxiliaries *}

lemma UNION_bij_betw_ofilter:
assumes WELL: "Well_order r" and
        OF: "\<And> i. i \<in> I \<Longrightarrow> ofilter r (A i)" and
       BIJ: "\<And> i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
shows "bij_betw f (\<Union> i \<in> I. A i) (\<Union> i \<in> I. A' i)"
proof-
  have "wo_rel r" using WELL by (simp add: wo_rel_def)
  hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i \<le> A j \<or> A j \<le> A i"
  using wo_rel.ofilter_linord[of r] OF by blast
  with WELL BIJ show ?thesis
  by (auto simp add: bij_betw_UNION_chain)
qed

subsection {* (Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
functions *}

lemma embed_halfcong:
assumes EQ: "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a" and
        EMB: "embed r r' f"
shows "embed r r' g"
proof(unfold embed_def, auto)
  fix a assume *: "a \<in> Field r"
  hence "bij_betw f (under r a) (under r' (f a))"
  using EMB unfolding embed_def by simp
  moreover
  {have "under r a \<le> Field r"
   by (auto simp add: under_Field)
   hence "\<And> b. b \<in> under r a \<Longrightarrow> f b = g b"
   using EQ by blast
  }
  moreover have "f a = g a" using * EQ by auto
  ultimately show "bij_betw g (under r a) (under r' (g a))"
  using bij_betw_cong[of "under r a" f g "under r' (f a)"] by auto
qed

lemma embed_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "embed r r' f = embed r r' g"
using assms embed_halfcong[of r f g r']
            embed_halfcong[of r g f r'] by auto

lemma embedS_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "embedS r r' f = embedS r r' g"
unfolding embedS_def using assms
embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma iso_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "iso r r' f = iso r r' g"
unfolding iso_def using assms
embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma id_compat: "compat r r id"
by(auto simp add: id_def compat_def)

lemma comp_compat:
"\<lbrakk>compat r r' f; compat r' r'' f'\<rbrakk> \<Longrightarrow> compat r r'' (f' o f)"
by(auto simp add: comp_def compat_def)

corollary one_set_greater:
"(\<exists>f::'a \<Rightarrow> 'a'. f ` A \<le> A' \<and> inj_on f A) \<or> (\<exists>g::'a' \<Rightarrow> 'a. g ` A' \<le> A \<and> inj_on g A')"
proof-
  obtain r where "well_order_on A r" by (fastforce simp add: well_order_on)
  hence 1: "A = Field r \<and> Well_order r"
  using well_order_on_Well_order by auto
  obtain r' where 2: "well_order_on A' r'" by (fastforce simp add: well_order_on)
  hence 2: "A' = Field r' \<and> Well_order r'"
  using well_order_on_Well_order by auto
  hence "(\<exists>f. embed r r' f) \<or> (\<exists>g. embed r' r g)"
  using 1 2 by (auto simp add: wellorders_totally_ordered)
  moreover
  {fix f assume "embed r r' f"
   hence "f`A \<le> A' \<and> inj_on f A"
   using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  moreover
  {fix g assume "embed r' r g"
   hence "g`A' \<le> A \<and> inj_on g A'"
   using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  ultimately show ?thesis by blast
qed

corollary one_type_greater:
"(\<exists>f::'a \<Rightarrow> 'a'. inj f) \<or> (\<exists>g::'a' \<Rightarrow> 'a. inj g)"
using one_set_greater[of UNIV UNIV] by auto

subsection {* Uniqueness of embeddings *}

lemma comp_embedS:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embedS r r' f" and EMB': "embedS r' r'' f'"
shows "embedS r r'' (f' o f)"
proof-
  have "embed r' r'' f'" using EMB' unfolding embedS_def by simp
  thus ?thesis using assms by (auto simp add: embedS_comp_embed)
qed

lemma iso_iff4:
assumes WELL: "Well_order r"  and WELL': "Well_order r'"
shows "iso r r' f = (embed r r' f \<and> embed r' r (inv_into (Field r) f))"
using assms embed_bothWays_iso
by(unfold iso_def, auto simp add: inv_into_Field_embed_bij_betw)

lemma embed_embedS_iso:
"embed r r' f = (embedS r r' f \<or> iso r r' f)"
unfolding embedS_def iso_def by blast

lemma not_embedS_iso:
"\<not> (embedS r r' f \<and> iso r r' f)"
unfolding embedS_def iso_def by blast

lemma embed_embedS_iff_not_iso:
assumes "embed r r' f"
shows "embedS r r' f = (\<not> iso r r' f)"
using assms unfolding embedS_def iso_def by blast

lemma iso_inv_into:
assumes WELL: "Well_order r" and ISO: "iso r r' f"
shows "iso r' r (inv_into (Field r) f)"
using assms unfolding iso_def
using bij_betw_inv_into inv_into_Field_embed_bij_betw by blast

lemma embedS_or_iso:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "(\<exists>g. embedS r r' g) \<or> (\<exists>h. embedS r' r h) \<or> (\<exists>f. iso r r' f)"
proof-
  {fix f assume *: "embed r r' f"
   {assume "bij_betw f (Field r) (Field r')"
    hence ?thesis using * by (auto simp add: iso_def)
   }
   moreover
   {assume "\<not> bij_betw f (Field r) (Field r')"
    hence ?thesis using * by (auto simp add: embedS_def)
   }
   ultimately have ?thesis by auto
  }
  moreover
  {fix f assume *: "embed r' r f"
   {assume "bij_betw f (Field r') (Field r)"
    hence "iso r' r f" using * by (auto simp add: iso_def)
    hence "iso r r' (inv_into (Field r') f)"
    using WELL' by (auto simp add: iso_inv_into)
    hence ?thesis by blast
   }
   moreover
   {assume "\<not> bij_betw f (Field r') (Field r)"
    hence ?thesis using * by (auto simp add: embedS_def)
   }
   ultimately have ?thesis by auto
  }
  ultimately show ?thesis using WELL WELL'
  wellorders_totally_ordered[of r r'] by blast
qed

end


(*  Title:      HOL/ex/Adhoc_Overloading_Examples.thy
    Author:     Christian Sternagel
*)

section \<open>Ad Hoc Overloading\<close>

theory Adhoc_Overloading_Examples
imports
  Main
  "HOL-Library.Infinite_Set"
  "HOL-Library.Adhoc_Overloading"
begin

text \<open>Adhoc overloading allows to overload a constant depending on
its type. Typically this involves to introduce an uninterpreted
constant (used for input and output) and then add some variants (used
internally).\<close>

subsection \<open>Plain Ad Hoc Overloading\<close>

text \<open>Consider the type of first-order terms.\<close>
datatype ('a, 'b) "term" =
  Var 'b |
  Fun 'a "('a, 'b) term list"

text \<open>The set of variables of a term might be computed as follows.\<close>
fun term_vars :: "('a, 'b) term \<Rightarrow> 'b set" where
  "term_vars (Var x) = {x}" |
  "term_vars (Fun f ts) = \<Union>set (map term_vars ts)"

text \<open>However, also for \emph{rules} (i.e., pairs of terms) and term
rewrite systems (i.e., sets of rules), the set of variables makes
sense. Thus we introduce an unspecified constant \<open>vars\<close>.\<close>

consts vars :: "'a \<Rightarrow> 'b set"

text \<open>Which is then overloaded with variants for terms, rules, and TRSs.\<close>
adhoc_overloading
  vars term_vars

value [nbe] "vars (Fun ''f'' [Var 0, Var 1])"

fun rule_vars :: "('a, 'b) term \<times> ('a, 'b) term \<Rightarrow> 'b set" where
  "rule_vars (l, r) = vars l \<union> vars r"

adhoc_overloading
  vars rule_vars

value [nbe] "vars (Var 1, Var 0)"

definition trs_vars :: "(('a, 'b) term \<times> ('a, 'b) term) set \<Rightarrow> 'b set" where
  "trs_vars R = \<Union>(rule_vars ` R)"

adhoc_overloading
  vars trs_vars

value [nbe] "vars {(Var 1, Var 0)}"

text \<open>Sometimes it is necessary to add explicit type constraints
before a variant can be determined.\<close>
(*value "vars R" (*has multiple instances*)*)
value "vars (R :: (('a, 'b) term \<times> ('a, 'b) term) set)"

text \<open>It is also possible to remove variants.\<close>
no_adhoc_overloading
  vars term_vars rule_vars

(*value "vars (Var 1)" (*does not have an instance*)*)

text \<open>As stated earlier, the overloaded constant is only used for
input and output. Internally, always a variant is used, as can be
observed by the configuration option \<open>show_variants\<close>.\<close>

adhoc_overloading
  vars term_vars

declare [[show_variants]]

term "vars (Var 1)" (*which yields: "term_vars (Var 1)"*)

subsection \<open>Adhoc Overloading inside Locales\<close>

text \<open>As example we use permutations that are parametrized over an
atom type @{typ "'a"}.\<close>

definition perms :: "('a \<Rightarrow> 'a) set" where
  "perms = {f. bij f \<and> finite {x. f x \<noteq> x}}"

typedef 'a perm = "perms :: ('a \<Rightarrow> 'a) set"
  by standard (auto simp: perms_def)

text \<open>First we need some auxiliary lemmas.\<close>
lemma permsI [Pure.intro]:
  assumes "bij f" and "MOST x. f x = x"
  shows "f \<in> perms"
  using assms by (auto simp: perms_def) (metis MOST_iff_finiteNeg)

lemma perms_imp_bij:
  "f \<in> perms \<Longrightarrow> bij f"
  by (simp add: perms_def)

lemma perms_imp_MOST_eq:
  "f \<in> perms \<Longrightarrow> MOST x. f x = x"
  by (simp add: perms_def) (metis MOST_iff_finiteNeg)

lemma id_perms [simp]:
  "id \<in> perms"
  "(\<lambda>x. x) \<in> perms"
  by (auto simp: perms_def bij_def)

lemma perms_comp [simp]:
  assumes f: "f \<in> perms" and g: "g \<in> perms"
  shows "(f \<circ> g) \<in> perms"
  apply (intro permsI bij_comp)
  apply (rule perms_imp_bij [OF g])
  apply (rule perms_imp_bij [OF f])
  apply (rule MOST_rev_mp [OF perms_imp_MOST_eq [OF g]])
  apply (rule MOST_rev_mp [OF perms_imp_MOST_eq [OF f]])
  by simp

lemma perms_inv:
  assumes f: "f \<in> perms"
  shows "inv f \<in> perms"
  apply (rule permsI)
  apply (rule bij_imp_bij_inv)
  apply (rule perms_imp_bij [OF f])
  apply (rule MOST_mono [OF perms_imp_MOST_eq [OF f]])
  apply (erule subst, rule inv_f_f)
  apply (rule bij_is_inj [OF perms_imp_bij [OF f]])
  done

lemma bij_Rep_perm: "bij (Rep_perm p)"
  using Rep_perm [of p] unfolding perms_def by simp

instantiation perm :: (type) group_add
begin

definition "0 = Abs_perm id"
definition "- p = Abs_perm (inv (Rep_perm p))"
definition "p + q = Abs_perm (Rep_perm p \<circ> Rep_perm q)"
definition "(p1::'a perm) - p2 = p1 + - p2"

lemma Rep_perm_0: "Rep_perm 0 = id"
  unfolding zero_perm_def by (simp add: Abs_perm_inverse)

lemma Rep_perm_add:
  "Rep_perm (p1 + p2) = Rep_perm p1 \<circ> Rep_perm p2"
  unfolding plus_perm_def by (simp add: Abs_perm_inverse Rep_perm)

lemma Rep_perm_uminus:
  "Rep_perm (- p) = inv (Rep_perm p)"
  unfolding uminus_perm_def by (simp add: Abs_perm_inverse perms_inv Rep_perm)

instance
  apply standard
  unfolding Rep_perm_inject [symmetric]
  unfolding minus_perm_def
  unfolding Rep_perm_add
  unfolding Rep_perm_uminus
  unfolding Rep_perm_0
  apply (simp_all add: o_assoc inv_o_cancel [OF bij_is_inj [OF bij_Rep_perm]])
  done

end

lemmas Rep_perm_simps =
  Rep_perm_0
  Rep_perm_add
  Rep_perm_uminus

section \<open>Permutation Types\<close>

text \<open>We want to be able to apply permutations to arbitrary types. To
this end we introduce a constant \<open>PERMUTE\<close> together with
convenient infix syntax.\<close>

consts PERMUTE :: "'a perm \<Rightarrow> 'b \<Rightarrow> 'b" (infixr "\<bullet>" 75)

text \<open>Then we add a locale for types @{typ 'b} that support
appliciation of permutations.\<close>
locale permute =
  fixes permute :: "'a perm \<Rightarrow> 'b \<Rightarrow> 'b"
  assumes permute_zero [simp]: "permute 0 x = x"
    and permute_plus [simp]: "permute (p + q) x = permute p (permute q x)"
begin

adhoc_overloading
  PERMUTE permute

end

text \<open>Permuting atoms.\<close>
definition permute_atom :: "'a perm \<Rightarrow> 'a \<Rightarrow> 'a" where
  "permute_atom p a = (Rep_perm p) a"

adhoc_overloading
  PERMUTE permute_atom

interpretation atom_permute: permute permute_atom
  by standard (simp_all add: permute_atom_def Rep_perm_simps)

text \<open>Permuting permutations.\<close>
definition permute_perm :: "'a perm \<Rightarrow> 'a perm \<Rightarrow> 'a perm" where
  "permute_perm p q = p + q - p"

adhoc_overloading
  PERMUTE permute_perm

interpretation perm_permute: permute permute_perm
  apply standard
  unfolding permute_perm_def
  apply simp
  apply (simp only: diff_conv_add_uminus minus_add add.assoc)
  done

text \<open>Permuting functions.\<close>
locale fun_permute =
  dom: permute perm1 + ran: permute perm2
  for perm1 :: "'a perm \<Rightarrow> 'b \<Rightarrow> 'b"
  and perm2 :: "'a perm \<Rightarrow> 'c \<Rightarrow> 'c"
begin

adhoc_overloading
  PERMUTE perm1 perm2

definition permute_fun :: "'a perm \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'c)" where
  "permute_fun p f = (\<lambda>x. p \<bullet> (f (-p \<bullet> x)))"

adhoc_overloading
  PERMUTE permute_fun

end

sublocale fun_permute \<subseteq> permute permute_fun
  by (unfold_locales, auto simp: permute_fun_def)
     (metis dom.permute_plus minus_add)

lemma "(Abs_perm id :: nat perm) \<bullet> Suc 0 = Suc 0"
  unfolding permute_atom_def
  by (metis Rep_perm_0 id_apply zero_perm_def)

interpretation atom_fun_permute: fun_permute permute_atom permute_atom
  by (unfold_locales)

adhoc_overloading
  PERMUTE atom_fun_permute.permute_fun

lemma "(Abs_perm id :: 'a perm) \<bullet> id = id"
  unfolding atom_fun_permute.permute_fun_def
  unfolding permute_atom_def
  by (metis Rep_perm_0 id_def inj_imp_inv_eq inj_on_id uminus_perm_def zero_perm_def)

end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Parallel.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Parallel composition.
*)

section {* Parallel Composition *}

theory Parallel
imports DTree
begin

no_notation plus_class.plus (infixl "+" 65)

consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)

axiomatization where
    Nplus_comm: "(a::N) + b = b + (a::N)"
and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"

subsection{* Corecursive Definition of Parallel Composition *}

fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
fun par_c where
"par_c (tr1,tr2) =
 Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
 Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"

declare par_r.simps[simp del]  declare par_c.simps[simp del]

definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
"par \<equiv> unfold par_r par_c"

abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"

lemma finite_par_c: "finite (par_c (tr1, tr2))"
unfolding par_c.simps apply(rule finite_UnI)
  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
  using finite_cont by auto

lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp

lemma cont_par:
"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
unfolding par_def ..

lemma Inl_cont_par[simp]:
"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
unfolding cont_par par_c.simps by auto

lemma Inr_cont_par[simp]:
"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
unfolding cont_par par_c.simps by auto

lemma Inl_in_cont_par:
"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto

lemma Inr_in_cont_par:
"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto

subsection{* Structural Coinduction Proofs *}

lemma rel_set_rel_sum_eq[simp]:
"rel_set (rel_sum (op =) \<phi>) A1 A2 \<longleftrightarrow>
 Inl -` A1 = Inl -` A2 \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
unfolding rel_set_rel_sum rel_set_eq ..

(* Detailed proofs of commutativity and associativity: *)
theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
proof-
  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
  {fix trA trB
   assume "?\<theta> trA trB" hence "trA = trB"
   apply (induct rule: dtree_coinduct)
   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
     unfolding root_par by (rule Nplus_comm)
   next
     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
     unfolding Inl_in_cont_par by auto
   next
     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
     unfolding Inl_in_cont_par by auto
   next
     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     unfolding Inr_in_cont_par by auto
     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   next
     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     unfolding Inr_in_cont_par by auto
     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
   qed
  }
  thus ?thesis by blast
qed

lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
proof-
  let ?\<theta> =
  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  {fix trA trB
   assume "?\<theta> trA trB" hence "trA = trB"
   apply (induct rule: dtree_coinduct)
   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
     unfolding root_par by (rule Nplus_assoc)
   next
     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   next
     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   next
     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
     unfolding Inr_in_cont_par by auto
   next
     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
     unfolding Inr_in_cont_par by auto
   qed
  }
  thus ?thesis by blast
qed

end


(*  Title:      ZF/Cardinal_AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

These results help justify infinite-branching datatypes
*)

section\<open>Cardinal Arithmetic Using AC\<close>

theory Cardinal_AC imports CardinalArith Zorn begin

subsection\<open>Strengthened Forms of Existing Theorems on Cardinals\<close>

lemma cardinal_eqpoll: "|A| \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_cardinal_eqpoll)
done

text\<open>The theorem \<^term>\<open>||A|| = |A|\<close>\<close>
lemmas cardinal_idem = cardinal_eqpoll [THEN cardinal_cong, simp]

lemma cardinal_eqE: "|X| = |Y| \<Longrightarrow> X \<approx> Y"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cardinal_eqE, assumption+)
done

lemma cardinal_eqpoll_iff: "|X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong cardinal_eqE)

lemma cardinal_disjoint_Un:
     "\<lbrakk>|A|=|B|;  |C|=|D|;  A \<inter> C = 0;  B \<inter> D = 0\<rbrakk>
      \<Longrightarrow> |A \<union> C| = |B \<union> D|"
by (simp add: cardinal_eqpoll_iff eqpoll_disjoint_Un)

lemma lepoll_imp_cardinal_le: "A \<lesssim> B \<Longrightarrow> |A| \<le> |B|"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_lepoll_imp_cardinal_le, assumption)
done

lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_assoc, assumption+)
done

lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cmult_assoc, assumption+)
done

lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_cmult_distrib, assumption+)
done

lemma InfCard_square_eq: "InfCard(|A|) \<Longrightarrow> A*A \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_InfCard_square_eq, assumption)
done

subsection \<open>The relationship between cardinality and le-pollence\<close>

lemma Card_le_imp_lepoll:
  assumes "|A| \<le> |B|" shows "A \<lesssim> B"
proof -
  have "A \<approx> |A|"
    by (rule cardinal_eqpoll [THEN eqpoll_sym])
  also have "... \<lesssim> |B|"
    by (rule le_imp_subset [THEN subset_imp_lepoll]) (rule assms)
  also have "... \<approx> B"
    by (rule cardinal_eqpoll)
  finally show ?thesis .
qed

lemma le_Card_iff: "Card(K) \<Longrightarrow> |A| \<le> K \<longleftrightarrow> A \<lesssim> K"
apply (erule Card_cardinal_eq [THEN subst], rule iffI,
       erule Card_le_imp_lepoll)
apply (erule lepoll_imp_cardinal_le)
done

lemma cardinal_0_iff_0 [simp]: "|A| = 0 \<longleftrightarrow> A = 0"
apply auto
apply (drule cardinal_0 [THEN ssubst])
apply (blast intro: eqpoll_0_iff [THEN iffD1] cardinal_eqpoll_iff [THEN iffD1])
done

lemma cardinal_lt_iff_lesspoll:
  assumes i: "Ord(i)" shows "i < |A| \<longleftrightarrow> i \<prec> A"
proof
  assume "i < |A|"
  hence  "i \<prec> |A|"
    by (blast intro: lt_Card_imp_lesspoll Card_cardinal)
  also have "...  \<approx> A"
    by (rule cardinal_eqpoll)
  finally show "i \<prec> A" .
next
  assume "i \<prec> A"
  also have "...  \<approx> |A|"
    by (blast intro: cardinal_eqpoll eqpoll_sym)
  finally have "i \<prec> |A|" .
  thus  "i < |A|" using i
    by (force intro: cardinal_lt_imp_lt lesspoll_cardinal_lt)
qed

lemma cardinal_le_imp_lepoll: " i \<le> |A| \<Longrightarrow> i \<lesssim> A"
  by (blast intro: lt_Ord Card_le_imp_lepoll Ord_cardinal_le le_trans)

subsection\<open>Other Applications of AC\<close>

lemma surj_implies_inj:
  assumes f: "f \<in> surj(X,Y)" shows "\<exists>g. g \<in> inj(Y,X)"
proof -
  from f AC_Pi [of Y "\<lambda>y. f-``{y}"]
  obtain z where z: "z \<in> (\<Prod>y\<in>Y. f -`` {y})"
    by (auto simp add: surj_def) (fast dest: apply_Pair)
  show ?thesis
    proof
      show "z \<in> inj(Y, X)" using z surj_is_fun [OF f]
        by (blast dest: apply_type Pi_memberD
                  intro: apply_equality Pi_type f_imp_injective)
    qed
qed

text\<open>Kunen's Lemma 10.20\<close>
lemma surj_implies_cardinal_le:
  assumes f: "f \<in> surj(X,Y)" shows "|Y| \<le> |X|"
proof (rule lepoll_imp_cardinal_le)
  from f [THEN surj_implies_inj] obtain g where "g \<in> inj(Y,X)" ..
  thus "Y \<lesssim> X"
    by (auto simp add: lepoll_def)
qed

text\<open>Kunen's Lemma 10.21\<close>
lemma cardinal_UN_le:
  assumes K: "InfCard(K)"
  shows "(\<And>i. i\<in>K \<Longrightarrow> |X(i)| \<le> K) \<Longrightarrow> |\<Union>i\<in>K. X(i)| \<le> K"
proof (simp add: K InfCard_is_Card le_Card_iff)
  have [intro]: "Ord(K)" by (blast intro: InfCard_is_Card Card_is_Ord K)
  assume "\<And>i. i\<in>K \<Longrightarrow> X(i) \<lesssim> K"
  hence "\<And>i. i\<in>K \<Longrightarrow> \<exists>f. f \<in> inj(X(i), K)" by (simp add: lepoll_def)
  with AC_Pi obtain f where f: "f \<in> (\<Prod>i\<in>K. inj(X(i), K))"
    by force
  { fix z
    assume z: "z \<in> (\<Union>i\<in>K. X(i))"
    then obtain i where i: "i \<in> K" "Ord(i)" "z \<in> X(i)"
      by (blast intro: Ord_in_Ord [of K])
    hence "(\<mu> i. z \<in> X(i)) \<le> i" by (fast intro: Least_le)
    hence "(\<mu> i. z \<in> X(i)) < K" by (best intro: lt_trans1 ltI i)
    hence "(\<mu> i. z \<in> X(i)) \<in> K" and "z \<in> X(\<mu> i. z \<in> X(i))"
      by (auto intro: LeastI ltD i)
  } note mems = this
  have "(\<Union>i\<in>K. X(i)) \<lesssim> K \<times> K"
    proof (unfold lepoll_def)
      show "\<exists>f. f \<in> inj(\<Union>RepFun(K, X), K \<times> K)"
        apply (rule exI)
        apply (rule_tac c = "\<lambda>z. \<langle>\<mu> i. z \<in> X(i), f ` (\<mu> i. z \<in> X(i)) ` z\<rangle>"
                    and d = "\<lambda>\<langle>i,j\<rangle>. converse (f`i) ` j" in lam_injective)
        apply (force intro: f inj_is_fun mems apply_type Perm.left_inverse)+
        done
    qed
  also have "... \<approx> K"
    by (simp add: K InfCard_square_eq InfCard_is_Card Card_cardinal_eq)
  finally show "(\<Union>i\<in>K. X(i)) \<lesssim> K" .
qed

text\<open>The same again, using \<^term>\<open>csucc\<close>\<close>
lemma cardinal_UN_lt_csucc:
     "\<lbrakk>InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> |X(i)| < csucc(K)\<rbrakk>
      \<Longrightarrow> |\<Union>i\<in>K. X(i)| < csucc(K)"
by (simp add: Card_lt_csucc_iff cardinal_UN_le InfCard_is_Card Card_cardinal)

text\<open>The same again, for a union of ordinals.  In use, j(i) is a bit like rank(i),
  the least ordinal j such that i:Vfrom(A,j).\<close>
lemma cardinal_UN_Ord_lt_csucc:
     "\<lbrakk>InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> j(i) < csucc(K)\<rbrakk>
      \<Longrightarrow> (\<Union>i\<in>K. j(i)) < csucc(K)"
apply (rule cardinal_UN_lt_csucc [THEN Card_lt_imp_lt], assumption)
apply (blast intro: Ord_cardinal_le [THEN lt_trans1] elim: ltE)
apply (blast intro!: Ord_UN elim: ltE)
apply (erule InfCard_is_Card [THEN Card_is_Ord, THEN Card_csucc])
done

subsection\<open>The Main Result for Infinite-Branching Datatypes\<close>

text\<open>As above, but the index set need not be a cardinal. Work
backwards along the injection from \<^term>\<open>W\<close> into \<^term>\<open>K\<close>, given
that \<^term>\<open>W\<noteq>0\<close>.\<close>

lemma inj_UN_subset:
  assumes f: "f \<in> inj(A,B)" and a: "a \<in> A"
  shows "(\<Union>x\<in>A. C(x)) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))"
proof (rule UN_least)
  fix x
  assume x: "x \<in> A"
  hence fx: "f ` x \<in> B" by (blast intro: f inj_is_fun [THEN apply_type])
  have "C(x) \<subseteq> C(if f ` x \<in> range(f) then converse(f) ` (f ` x) else a)"
    using f x by (simp add: inj_is_fun [THEN apply_rangeI])
  also have "... \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f) ` y else a))"
    by (rule UN_upper [OF fx])
  finally show "C(x) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))" .
qed

theorem le_UN_Ord_lt_csucc:
  assumes IK: "InfCard(K)" and WK: "|W| \<le> K" and j: "\<And>w. w\<in>W \<Longrightarrow> j(w) < csucc(K)"
  shows "(\<Union>w\<in>W. j(w)) < csucc(K)"
proof -
  have CK: "Card(K)"
    by (simp add: InfCard_is_Card IK)
  then obtain f where f: "f \<in> inj(W, K)" using WK
    by(auto simp add: le_Card_iff lepoll_def)
  have OU: "Ord(\<Union>w\<in>W. j(w))" using j
    by (blast elim: ltE)
  note lt_subset_trans [OF _ _ OU, trans]
  show ?thesis
    proof (cases "W=0")
      case True  \<comment> \<open>solve the easy 0 case\<close>
      thus ?thesis by (simp add: CK Card_is_Ord Card_csucc Ord_0_lt_csucc)
    next
      case False
        then obtain x where x: "x \<in> W" by blast
        have "(\<Union>x\<in>W. j(x)) \<subseteq> (\<Union>k\<in>K. j(if k \<in> range(f) then converse(f) ` k else x))"
          by (rule inj_UN_subset [OF f x])
        also have "... < csucc(K)" using IK
          proof (rule cardinal_UN_Ord_lt_csucc)
            fix k
            assume "k \<in> K"
            thus "j(if k \<in> range(f) then converse(f) ` k else x) < csucc(K)" using f x j
              by (simp add: inj_converse_fun [THEN apply_type])
          qed
        finally show ?thesis .
    qed
qed

end