(*  Title:      ZF/UNITY/GenPrefix.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

<xs,ys>:gen_prefix(r)
  if ys = xs' @ zs where length(xs) = length(xs')
  and corresponding elements of xs, xs' are pairwise related by r

Based on Lex/Prefix
*)

section\<open>Charpentier's Generalized Prefix Relation\<close>

theory GenPrefix
imports Main
begin

definition (*really belongs in ZF/Trancl*)
  part_order :: "[i, i] => o"  where
  "part_order(A, r) == refl(A,r) & trans[A](r) & antisym(r)"

consts
  gen_prefix :: "[i, i] => i"

inductive
  (* Parameter A is the domain of zs's elements *)

  domains "gen_prefix(A, r)" \<subseteq> "list(A)*list(A)"

  intros
    Nil:     "<[],[]>:gen_prefix(A, r)"

    prepend: "[| <xs,ys>:gen_prefix(A, r);  <x,y>:r; x \<in> A; y \<in> A |]
              ==> <Cons(x,xs), Cons(y,ys)>: gen_prefix(A, r)"

    append:  "[| <xs,ys>:gen_prefix(A, r); zs:list(A) |]
              ==> <xs, ys@zs>:gen_prefix(A, r)"
    type_intros app_type list.Nil list.Cons

definition
  prefix :: "i=>i"  where
  "prefix(A) == gen_prefix(A, id(A))"

definition
  strict_prefix :: "i=>i"  where
  "strict_prefix(A) == prefix(A) - id(list(A))"

(* less or equal and greater or equal over prefixes *)

abbreviation
  pfixLe :: "[i, i] => o"  (infixl "pfixLe" 50)  where
  "xs pfixLe ys == <xs, ys>:gen_prefix(nat, Le)"

abbreviation
  pfixGe :: "[i, i] => o"  (infixl "pfixGe" 50)  where
  "xs pfixGe ys == <xs, ys>:gen_prefix(nat, Ge)"

lemma reflD:
 "[| refl(A, r); x \<in> A |] ==> <x,x>:r"
apply (unfold refl_def, auto)
done

(*** preliminary lemmas ***)

lemma Nil_gen_prefix: "xs \<in> list(A) ==> <[], xs> \<in> gen_prefix(A, r)"
by (drule gen_prefix.append [OF gen_prefix.Nil], simp)
declare Nil_gen_prefix [simp]

lemma gen_prefix_length_le: "<xs,ys> \<in> gen_prefix(A, r) ==> length(xs) \<le> length(ys)"
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "ys \<in> list (A) ")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: le_trans simp add: length_app)
done

lemma Cons_gen_prefix_aux:
  "[| <xs', ys'> \<in> gen_prefix(A, r) |]
   ==> (\<forall>x xs. x \<in> A \<longrightarrow> xs'= Cons(x,xs) \<longrightarrow>
       (\<exists>y ys. y \<in> A & ys' = Cons(y,ys) &
       <x,y>:r & <xs, ys> \<in> gen_prefix(A, r)))"
apply (erule gen_prefix.induct)
prefer 3 apply (force intro: gen_prefix.append, auto)
done

lemma Cons_gen_prefixE:
  "[| <Cons(x,xs), zs> \<in> gen_prefix(A, r);
    !!y ys. [|zs = Cons(y, ys); y \<in> A; x \<in> A; <x,y>:r;
      <xs,ys> \<in> gen_prefix(A, r) |] ==> P |] ==> P"
apply (frule gen_prefix.dom_subset [THEN subsetD], auto)
apply (blast dest: Cons_gen_prefix_aux)
done
declare Cons_gen_prefixE [elim!]

lemma Cons_gen_prefix_Cons:
"(<Cons(x,xs),Cons(y,ys)> \<in> gen_prefix(A, r))
  \<longleftrightarrow> (x \<in> A & y \<in> A & <x,y>:r & <xs,ys> \<in> gen_prefix(A, r))"
apply (auto intro: gen_prefix.prepend)
done
declare Cons_gen_prefix_Cons [iff]

(** Monotonicity of gen_prefix **)

lemma gen_prefix_mono2: "r<=s ==> gen_prefix(A, r) \<subseteq> gen_prefix(A, s)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule gen_prefix.induct)
apply (auto intro: gen_prefix.append)
done

lemma gen_prefix_mono1: "A<=B ==>gen_prefix(A, r) \<subseteq> gen_prefix(B, r)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule_tac P = "y \<in> list (A) " in rev_mp)
apply (erule_tac P = "xa \<in> list (A) " in rev_mp)
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply clarify
apply (erule ConsE)+
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: gen_prefix.append list_mono [THEN subsetD])
done

lemma gen_prefix_mono: "[| A \<subseteq> B; r \<subseteq> s |] ==> gen_prefix(A, r) \<subseteq> gen_prefix(B, s)"
apply (rule subset_trans)
apply (rule gen_prefix_mono1)
apply (rule_tac [2] gen_prefix_mono2, auto)
done

(*** gen_prefix order ***)

(* reflexivity *)
lemma refl_gen_prefix: "refl(A, r) ==> refl(list(A), gen_prefix(A, r))"
apply (unfold refl_def, auto)
apply (induct_tac "x", auto)
done
declare refl_gen_prefix [THEN reflD, simp]

(* Transitivity *)
(* A lemma for proving gen_prefix_trans_comp *)

lemma append_gen_prefix [rule_format (no_asm)]: "xs \<in> list(A) ==>
   \<forall>zs. <xs @ ys, zs> \<in> gen_prefix(A, r) \<longrightarrow> <xs, zs>: gen_prefix(A, r)"
apply (erule list.induct)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

(* Lemma proving transitivity and more*)

lemma gen_prefix_trans_comp [rule_format (no_asm)]:
     "<x, y>: gen_prefix(A, r) ==>
   (\<forall>z \<in> list(A). <y,z> \<in> gen_prefix(A, s)\<longrightarrow><x, z> \<in> gen_prefix(A, s O r))"
apply (erule gen_prefix.induct)
apply (auto elim: ConsE simp add: Nil_gen_prefix)
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac xs = ys and r = s in append_gen_prefix, auto)
done

lemma trans_comp_subset: "trans(r) ==> r O r \<subseteq> r"
by (auto dest: transD)

lemma trans_gen_prefix: "trans(r) ==> trans(gen_prefix(A,r))"
apply (simp (no_asm) add: trans_def)
apply clarify
apply (rule trans_comp_subset [THEN gen_prefix_mono2, THEN subsetD], assumption)
apply (rule gen_prefix_trans_comp)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma trans_on_gen_prefix:
 "trans(r) ==> trans[list(A)](gen_prefix(A, r))"
apply (drule_tac A = A in trans_gen_prefix)
apply (unfold trans_def trans_on_def, blast)
done

lemma prefix_gen_prefix_trans:
    "[| <x,y> \<in> prefix(A); <y, z> \<in> gen_prefix(A, r); r<=A*A |]
      ==>  <x, z> \<in> gen_prefix(A, r)"
apply (unfold prefix_def)
apply (rule_tac P = "%r. <x,z> \<in> gen_prefix (A, r) " in right_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

lemma gen_prefix_prefix_trans:
"[| <x,y> \<in> gen_prefix(A,r); <y, z> \<in> prefix(A); r<=A*A |]
  ==>  <x, z> \<in> gen_prefix(A, r)"
apply (unfold prefix_def)
apply (rule_tac P = "%r. <x,z> \<in> gen_prefix (A, r) " in left_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

(** Antisymmetry **)

lemma nat_le_lemma [rule_format]: "n \<in> nat ==> \<forall>b \<in> nat. n #+ b \<le> n \<longrightarrow> b = 0"
by (induct_tac "n", auto)

lemma antisym_gen_prefix: "antisym(r) ==> antisym(gen_prefix(A, r))"
apply (simp (no_asm) add: antisym_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule gen_prefix.induct, blast)
apply (simp add: antisym_def, blast)
txt\<open>append case is hardest\<close>
apply clarify
apply (subgoal_tac "length (zs) = 0")
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<ys @ zs, xs> \<in> gen_prefix (A,r) " in asm_rl)
apply simp
apply (subgoal_tac "length (ys @ zs) = length (ys) #+ length (zs) &ys \<in> list (A) &xs \<in> list (A) ")
prefer 2 apply (blast intro: length_app dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule gen_prefix_length_le)+
apply clarify
apply simp
apply (drule_tac j = "length (xs) " in le_trans)
apply blast
apply (auto intro: nat_le_lemma)
done

(*** recursion equations ***)

lemma gen_prefix_Nil: "xs \<in> list(A) ==> <xs, []> \<in> gen_prefix(A,r) \<longleftrightarrow> (xs = [])"
by (induct_tac "xs", auto)
declare gen_prefix_Nil [simp]

lemma same_gen_prefix_gen_prefix:
 "[| refl(A, r);  xs \<in> list(A) |] ==>
    <xs@ys, xs@zs>: gen_prefix(A, r) \<longleftrightarrow> <ys,zs> \<in> gen_prefix(A, r)"
apply (unfold refl_def)
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
done
declare same_gen_prefix_gen_prefix [simp]

lemma gen_prefix_Cons: "[| xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
    <xs, Cons(y,ys)> \<in> gen_prefix(A,r)  \<longleftrightarrow>
      (xs=[] | (\<exists>z zs. xs=Cons(z,zs) & z \<in> A & <z,y>:r & <zs,ys> \<in> gen_prefix(A,r)))"
apply (induct_tac "xs", auto)
done

lemma gen_prefix_take_append: "[| refl(A,r);  <xs,ys> \<in> gen_prefix(A, r); zs \<in> list(A) |]
      ==>  <xs@zs, take(length(xs), ys) @ zs> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply (frule_tac [!] gen_prefix.dom_subset [THEN subsetD], auto)
apply (frule gen_prefix_length_le)
apply (subgoal_tac "take (length (xs), ys) \<in> list (A) ")
apply (simp_all (no_asm_simp) add: diff_is_0_iff [THEN iffD2] take_type)
done

lemma gen_prefix_append_both: "[| refl(A, r);  <xs,ys> \<in> gen_prefix(A,r);
         length(xs) = length(ys); zs \<in> list(A) |]
      ==>  <xs@zs, ys @ zs> \<in> gen_prefix(A, r)"
apply (drule_tac zs = zs in gen_prefix_take_append, assumption+)
apply (subgoal_tac "take (length (xs), ys) =ys")
apply (auto intro!: take_all dest: gen_prefix.dom_subset [THEN subsetD])
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_conv: "xs \<in> list(A) ==> xs @ Cons(y, ys) = (xs @ [y]) @ ys"
by (auto simp add: app_assoc)

lemma append_one_gen_prefix_lemma [rule_format]:
     "[| <xs,ys> \<in> gen_prefix(A, r);  refl(A, r) |]
      ==> length(xs) < length(ys) \<longrightarrow>
          <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct, blast)
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (simp_all add: length_type)
(* Append case is hardest *)
apply (frule gen_prefix_length_le [THEN le_iff [THEN iffD1]])
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (subgoal_tac "length (xs) :nat&length (ys) :nat &length (zs) :nat")
prefer 2 apply (blast intro: length_type, clarify)
apply (simp_all add: nth_append length_type length_app)
apply (rule conjI)
apply (blast intro: gen_prefix.append)
apply (erule_tac V = "length (xs) < length (ys) \<longrightarrow>u" for u in thin_rl)
apply (erule_tac a = zs in list.cases, auto)
apply (rule_tac P1 = "%x. <u(x), v>:w" for u v w in nat_diff_split [THEN iffD2])
apply auto
apply (simplesubst append_cons_conv)
apply (rule_tac [2] gen_prefix.append)
apply (auto elim: ConsE simp add: gen_prefix_append_both)
done

lemma append_one_gen_prefix: "[| <xs,ys>: gen_prefix(A, r);  length(xs) < length(ys);  refl(A, r) |]
      ==> <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (blast intro: append_one_gen_prefix_lemma)
done

(** Proving the equivalence with Charpentier's definition **)

lemma gen_prefix_imp_nth_lemma [rule_format]: "xs \<in> list(A) ==>
  \<forall>ys \<in> list(A). \<forall>i \<in> nat. i < length(xs)
          \<longrightarrow> <xs, ys>: gen_prefix(A, r) \<longrightarrow> <nth(i, xs), nth(i, ys)>:r"
apply (induct_tac "xs", simp, clarify)
apply simp
apply (erule natE, auto)
done

lemma gen_prefix_imp_nth: "[| <xs,ys> \<in> gen_prefix(A,r); i < length(xs)|]
      ==> <nth(i, xs), nth(i, ys)>:r"
apply (cut_tac A = A in gen_prefix.dom_subset)
apply (rule gen_prefix_imp_nth_lemma)
apply (auto simp add: lt_nat_in_nat)
done

lemma nth_imp_gen_prefix [rule_format]: "xs \<in> list(A) ==>
  \<forall>ys \<in> list(A). length(xs) \<le> length(ys)
      \<longrightarrow> (\<forall>i. i < length(xs) \<longrightarrow> <nth(i, xs), nth(i,ys)>:r)
      \<longrightarrow> <xs, ys> \<in> gen_prefix(A, r)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
apply clarify
apply (erule_tac a = ys in list.cases, simp)
apply (force intro!: nat_0_le simp add: lt_nat_in_nat)
done

lemma gen_prefix_iff_nth: "(<xs,ys> \<in> gen_prefix(A,r)) \<longleftrightarrow>
      (xs \<in> list(A) & ys \<in> list(A) & length(xs) \<le> length(ys) &
      (\<forall>i. i < length(xs) \<longrightarrow> <nth(i,xs), nth(i, ys)>: r))"
apply (rule iffI)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le, auto)
apply (rule_tac [2] nth_imp_gen_prefix)
apply (drule gen_prefix_imp_nth)
apply (auto simp add: lt_nat_in_nat)
done

(** prefix is a partial order: **)

lemma refl_prefix: "refl(list(A), prefix(A))"
apply (unfold prefix_def)
apply (rule refl_gen_prefix)
apply (auto simp add: refl_def)
done
declare refl_prefix [THEN reflD, simp]

lemma trans_prefix: "trans(prefix(A))"
apply (unfold prefix_def)
apply (rule trans_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans = trans_prefix [THEN transD]

lemma trans_on_prefix: "trans[list(A)](prefix(A))"
apply (unfold prefix_def)
apply (rule trans_on_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans_on = trans_on_prefix [THEN trans_onD]

(* Monotonicity of "set" operator WRT prefix *)

lemma set_of_list_prefix_mono:
"<xs,ys> \<in> prefix(A) ==> set_of_list(xs) \<subseteq> set_of_list(ys)"

apply (unfold prefix_def)
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "xs \<in> list (A) &ys \<in> list (A) ")
prefer 4 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (auto simp add: set_of_list_append)
done

(** recursion equations **)

lemma Nil_prefix: "xs \<in> list(A) ==> <[],xs> \<in> prefix(A)"

apply (unfold prefix_def)
apply (simp (no_asm_simp) add: Nil_gen_prefix)
done
declare Nil_prefix [simp]

lemma prefix_Nil: "<xs, []> \<in> prefix(A) \<longleftrightarrow> (xs = [])"

apply (unfold prefix_def, auto)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<xs, []> \<in> gen_prefix (A, id (A))" in asm_rl)
apply (simp add: gen_prefix_Nil)
done
declare prefix_Nil [iff]

lemma Cons_prefix_Cons:
"<Cons(x,xs), Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow> (x=y & <xs,ys> \<in> prefix(A) & y \<in> A)"
apply (unfold prefix_def, auto)
done
declare Cons_prefix_Cons [iff]

lemma same_prefix_prefix:
"xs \<in> list(A)==> <xs@ys,xs@zs> \<in> prefix(A) \<longleftrightarrow> (<ys,zs> \<in> prefix(A))"
apply (unfold prefix_def)
apply (subgoal_tac "refl (A,id (A))")
apply (simp (no_asm_simp))
apply (auto simp add: refl_def)
done
declare same_prefix_prefix [simp]

lemma same_prefix_prefix_Nil: "xs \<in> list(A) ==> <xs@ys,xs> \<in> prefix(A) \<longleftrightarrow> (<ys,[]> \<in> prefix(A))"
apply (rule_tac P = "%x. <u, x>:v \<longleftrightarrow> w(x)" for u v w in app_right_Nil [THEN subst])
apply (rule_tac [2] same_prefix_prefix, auto)
done
declare same_prefix_prefix_Nil [simp]

lemma prefix_appendI:
"[| <xs,ys> \<in> prefix(A); zs \<in> list(A) |] ==> <xs,ys@zs> \<in> prefix(A)"
apply (unfold prefix_def)
apply (erule gen_prefix.append, assumption)
done
declare prefix_appendI [simp]

lemma prefix_Cons:
"[| xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
  <xs,Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow>
  (xs=[] | (\<exists>zs. xs=Cons(y,zs) & <zs,ys> \<in> prefix(A)))"
apply (unfold prefix_def)
apply (auto simp add: gen_prefix_Cons)
done

lemma append_one_prefix:
  "[| <xs,ys> \<in> prefix(A); length(xs) < length(ys) |]
  ==> <xs @ [nth(length(xs),ys)], ys> \<in> prefix(A)"
apply (unfold prefix_def)
apply (subgoal_tac "refl (A, id (A))")
apply (simp (no_asm_simp) add: append_one_gen_prefix)
apply (auto simp add: refl_def)
done

lemma prefix_length_le:
"<xs,ys> \<in> prefix(A) ==> length(xs) \<le> length(ys)"
apply (unfold prefix_def)
apply (blast dest: gen_prefix_length_le)
done

lemma prefix_type: "prefix(A)<=list(A)*list(A)"
apply (unfold prefix_def)
apply (blast intro!: gen_prefix.dom_subset)
done

lemma strict_prefix_type:
"strict_prefix(A) \<subseteq> list(A)*list(A)"
apply (unfold strict_prefix_def)
apply (blast intro!: prefix_type [THEN subsetD])
done

lemma strict_prefix_length_lt_aux:
     "<xs,ys> \<in> prefix(A) ==> xs\<noteq>ys \<longrightarrow> length(xs) < length(ys)"
apply (unfold prefix_def)
apply (erule gen_prefix.induct, clarify)
apply (subgoal_tac [!] "ys \<in> list(A) & xs \<in> list(A)")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            simp add: length_type)
apply (subgoal_tac "length (zs) =0")
apply (drule_tac [2] not_lt_imp_le)
apply (rule_tac [5] j = "length (ys) " in lt_trans2)
apply auto
done

lemma strict_prefix_length_lt:
     "<xs,ys>:strict_prefix(A) ==> length(xs) < length(ys)"
apply (unfold strict_prefix_def)
apply (rule strict_prefix_length_lt_aux [THEN mp])
apply (auto dest: prefix_type [THEN subsetD])
done

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff:
    "<xs,zs> \<in> prefix(A) \<longleftrightarrow> (\<exists>ys \<in> list(A). zs = xs@ys) & xs \<in> list(A)"
apply (unfold prefix_def)
apply (auto simp add: gen_prefix_iff_nth lt_nat_in_nat nth_append nth_type app_type length_app)
apply (subgoal_tac "drop (length (xs), zs) \<in> list (A) ")
apply (rule_tac x = "drop (length (xs), zs) " in bexI)
apply safe
 prefer 2 apply (simp add: length_type drop_type)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append app_type drop_type length_app length_drop)
apply (rule nat_diff_split [THEN iffD2], simp_all, clarify)
apply (drule_tac i = "length (zs) " in leI)
apply (force simp add: le_subset_iff, safe)
apply (subgoal_tac "length (xs) #+ (i #- length (xs)) = i")
apply (subst nth_drop)
apply (simp_all (no_asm_simp) add: leI split: nat_diff_split)
done

lemma prefix_snoc:
"[|xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
   <xs, ys@[y]> \<in> prefix(A) \<longleftrightarrow> (xs = ys@[y] | <xs,ys> \<in> prefix(A))"
apply (simp (no_asm) add: prefix_iff)
apply (rule iffI, clarify)
apply (erule_tac xs = ysa in rev_list_elim, simp)
apply (simp add: app_type app_assoc [symmetric])
apply (auto simp add: app_assoc app_type)
done
declare prefix_snoc [simp]

lemma prefix_append_iff [rule_format]: "zs \<in> list(A) ==> \<forall>xs \<in> list(A). \<forall>ys \<in> list(A).
   (<xs, ys@zs> \<in> prefix(A)) \<longleftrightarrow>
  (<xs,ys> \<in> prefix(A) | (\<exists>us. xs = ys@us & <us,zs> \<in> prefix(A)))"
apply (erule list_append_induct, force, clarify)
apply (rule iffI)
apply (simp add: add: app_assoc [symmetric])
apply (erule disjE)
apply (rule disjI2)
apply (rule_tac x = "y @ [x]" in exI)
apply (simp add: add: app_assoc [symmetric], force+)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear_lemma [rule_format]: "[| zs \<in> list(A); xs \<in> list(A); ys \<in> list(A) |]
   ==> <xs, zs> \<in> prefix(A) \<longrightarrow> <ys,zs> \<in> prefix(A)
  \<longrightarrow><xs,ys> \<in> prefix(A) | <ys,xs> \<in> prefix(A)"
apply (erule list_append_induct, auto)
done

lemma common_prefix_linear: "[|<xs, zs> \<in> prefix(A); <ys,zs> \<in> prefix(A) |]
      ==> <xs,ys> \<in> prefix(A) | <ys,xs> \<in> prefix(A)"
apply (cut_tac prefix_type)
apply (blast del: disjCI intro: common_prefix_linear_lemma)
done

(*** pfixLe, pfixGe \<in> properties inherited from the translations ***)

(** pfixLe **)

lemma refl_Le: "refl(nat,Le)"

apply (unfold refl_def, auto)
done
declare refl_Le [simp]

lemma antisym_Le: "antisym(Le)"
apply (unfold antisym_def)
apply (auto intro: le_anti_sym)
done
declare antisym_Le [simp]

lemma trans_on_Le: "trans[nat](Le)"
apply (unfold trans_on_def, auto)
apply (blast intro: le_trans)
done
declare trans_on_Le [simp]

lemma trans_Le: "trans(Le)"
apply (unfold trans_def, auto)
apply (blast intro: le_trans)
done
declare trans_Le [simp]

lemma part_order_Le: "part_order(nat,Le)"
by (unfold part_order_def, auto)
declare part_order_Le [simp]

lemma pfixLe_refl: "x \<in> list(nat) ==> x pfixLe x"
by (blast intro: refl_gen_prefix [THEN reflD] refl_Le)
declare pfixLe_refl [simp]

lemma pfixLe_trans: "[| x pfixLe y; y pfixLe z |] ==> x pfixLe z"
by (blast intro: trans_gen_prefix [THEN transD] trans_Le)

lemma pfixLe_antisym: "[| x pfixLe y; y pfixLe x |] ==> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE] antisym_Le)

lemma prefix_imp_pfixLe:
"<xs,ys>:prefix(nat)==> xs pfixLe ys"

apply (unfold prefix_def)
apply (rule gen_prefix_mono [THEN subsetD], auto)
done

lemma refl_Ge: "refl(nat, Ge)"
by (unfold refl_def Ge_def, auto)
declare refl_Ge [iff]

lemma antisym_Ge: "antisym(Ge)"
apply (unfold antisym_def Ge_def)
apply (auto intro: le_anti_sym)
done
declare antisym_Ge [iff]

lemma trans_Ge: "trans(Ge)"
apply (unfold trans_def Ge_def)
apply (auto intro: le_trans)
done
declare trans_Ge [iff]

lemma pfixGe_refl: "x \<in> list(nat) ==> x pfixGe x"
by (blast intro: refl_gen_prefix [THEN reflD])
declare pfixGe_refl [simp]

lemma pfixGe_trans: "[| x pfixGe y; y pfixGe z |] ==> x pfixGe z"
by (blast intro: trans_gen_prefix [THEN transD])

lemma pfixGe_antisym: "[| x pfixGe y; y pfixGe x |] ==> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE])

lemma prefix_imp_pfixGe:
  "<xs,ys>:prefix(nat) ==> xs pfixGe ys"
apply (unfold prefix_def Ge_def)
apply (rule gen_prefix_mono [THEN subsetD], auto)
done
(* Added by Sidi \<in> prefix and take *)

lemma prefix_imp_take:
"<xs, ys> \<in> prefix(A) ==> xs = take(length(xs), ys)"

apply (unfold prefix_def)
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "length (xs) :nat")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: length_type)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le)
apply (auto simp add: take_append)
apply (subgoal_tac "length (xs) #- length (ys) =0")
apply (simp_all (no_asm_simp) add: diff_is_0_iff)
done

lemma prefix_length_equal: "[|<xs,ys> \<in> prefix(A); length(xs)=length(ys)|] ==> xs = ys"
apply (cut_tac A = A in prefix_type)
apply (drule subsetD, auto)
apply (drule prefix_imp_take)
apply (erule trans, simp)
done

lemma prefix_length_le_equal: "[|<xs,ys> \<in> prefix(A); length(ys) \<le> length(xs)|] ==> xs = ys"
by (blast intro: prefix_length_equal le_anti_sym prefix_length_le)

lemma take_prefix [rule_format]: "xs \<in> list(A) ==> \<forall>n \<in> nat. <take(n, xs), xs> \<in> prefix(A)"
apply (unfold prefix_def)
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma prefix_take_iff: "<xs,ys> \<in> prefix(A) \<longleftrightarrow> (xs=take(length(xs), ys) & xs \<in> list(A) & ys \<in> list(A))"
apply (rule iffI)
apply (frule prefix_type [THEN subsetD])
apply (blast intro: prefix_imp_take, clarify)
apply (erule ssubst)
apply (blast intro: take_prefix length_type)
done

lemma prefix_imp_nth: "[| <xs,ys> \<in> prefix(A); i < length(xs)|] ==> nth(i,xs) = nth(i,ys)"
by (auto dest!: gen_prefix_imp_nth simp add: prefix_def)

lemma nth_imp_prefix:
     "[|xs \<in> list(A); ys \<in> list(A); length(xs) \<le> length(ys);
        !!i. i < length(xs) ==> nth(i, xs) = nth(i,ys)|]
      ==> <xs,ys> \<in> prefix(A)"
apply (auto simp add: prefix_def nth_imp_gen_prefix)
apply (auto intro!: nth_imp_gen_prefix simp add: prefix_def)
apply (blast intro: nth_type lt_trans2)
done

lemma length_le_prefix_imp_prefix: "[|length(xs) \<le> length(ys);
        <xs,zs> \<in> prefix(A); <ys,zs> \<in> prefix(A)|] ==> <xs,ys> \<in> prefix(A)"
apply (cut_tac A = A in prefix_type)
apply (rule nth_imp_prefix, blast, blast)
 apply assumption
apply (rule_tac b = "nth (i,zs)" in trans)
 apply (blast intro: prefix_imp_nth)
apply (blast intro: sym prefix_imp_nth prefix_length_le lt_trans2)
done

end


(* Author: Florian Haftmann, TU Muenchen *)

section {* A simple cookbook example how to eliminate choice in programs. *}

theory Execute_Choice
imports Main "~~/src/HOL/Library/AList_Mapping"
begin

text {*
  A trivial example:
*}

definition valuesum :: "('a, 'b :: ab_group_add) mapping \<Rightarrow> 'b" where
  "valuesum m = (\<Sum>k \<in> Mapping.keys m. the (Mapping.lookup m k))"

text {*
  Not that instead of defining @{term valuesum} with choice, we define it
  directly and derive a description involving choice afterwards:
*}

lemma valuesum_rec:
  assumes fin: "finite (dom (Mapping.lookup m))"
  shows "valuesum m = (if Mapping.is_empty m then 0 else
    let l = (SOME l. l \<in> Mapping.keys m) in the (Mapping.lookup m l) + valuesum (Mapping.delete l m))"
proof (cases "Mapping.is_empty m")
  case True then show ?thesis by (simp add: is_empty_def keys_def valuesum_def)
next
  case False
  then have l: "\<exists>l. l \<in> dom (Mapping.lookup m)" unfolding is_empty_def by transfer auto
  then have "(let l = SOME l. l \<in> dom (Mapping.lookup m) in
     the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
       (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
  proof (rule someI2_ex)
    fix l
    note fin
    moreover assume "l \<in> dom (Mapping.lookup m)"
    moreover obtain A where "A = dom (Mapping.lookup m) - {l}" by simp
    ultimately have "dom (Mapping.lookup m) = insert l A" and "finite A" and "l \<notin> A" by auto
    then show "(let l = l
        in the (Mapping.lookup m l) + (\<Sum>k \<in> dom (Mapping.lookup m) - {l}. the (Mapping.lookup m k))) =
        (\<Sum>k \<in> dom (Mapping.lookup m). the (Mapping.lookup m k))"
      by simp
   qed
  then show ?thesis unfolding is_empty_def valuesum_def by transfer simp
qed

text {*
  In the context of the else-branch we can show that the exact choice is
  irrelvant; in practice, finding this point where choice becomes irrelevant is the
  most difficult thing!
*}

lemma valuesum_choice:
  "finite (Mapping.keys M) \<Longrightarrow> x \<in> Mapping.keys M \<Longrightarrow> y \<in> Mapping.keys M \<Longrightarrow>
    the (Mapping.lookup M x) + valuesum (Mapping.delete x M) =
    the (Mapping.lookup M y) + valuesum (Mapping.delete y M)"
  unfolding valuesum_def  by transfer (simp add: setsum_diff)

text {*
  Given @{text valuesum_rec} as initial description, we stepwise refine it to something executable;
  first, we formally insert the constructor @{term Mapping} and split the one equation into two,
  where the second one provides the necessary context:
*}

lemma valuesum_rec_Mapping:
  shows [code]: "valuesum (Mapping []) = 0"
  and "valuesum (Mapping (x # xs)) = (let l = (SOME l. l \<in> Mapping.keys (Mapping (x # xs))) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
  by (simp_all add: valuesum_rec finite_dom_map_of is_empty_Mapping null_def)

text {*
  As a side effect the precondition disappears (but note this has nothing to do with choice!).
  The first equation deals with the uncritical empty case and can already be used for code generation.

  Using @{text valuesum_choice}, we are able to prove an executable version of @{term valuesum}:
*}

lemma valuesum_rec_exec [code]:
  "valuesum (Mapping (x # xs)) = (let l = fst (hd (x # xs)) in
    the (Mapping.lookup (Mapping (x # xs)) l) + valuesum (Mapping.delete l (Mapping (x # xs))))"
proof -
  let ?M = "Mapping (x # xs)"
  let ?l1 = "(SOME l. l \<in> Mapping.keys ?M)"
  let ?l2 = "fst (hd (x # xs))"
  have "finite (Mapping.keys ?M)" by (simp add: keys_Mapping)
  moreover have "?l1 \<in> Mapping.keys ?M"
    by (rule someI) (auto simp add: keys_Mapping)
  moreover have "?l2 \<in> Mapping.keys ?M"
    by (simp add: keys_Mapping)
  ultimately have "the (Mapping.lookup ?M ?l1) + valuesum (Mapping.delete ?l1 ?M) =
    the (Mapping.lookup ?M ?l2) + valuesum (Mapping.delete ?l2 ?M)"
    by (rule valuesum_choice)
  then show ?thesis by (simp add: valuesum_rec_Mapping)
qed

text {*
  See how it works:
*}

value "valuesum (Mapping [(''abc'', (42::int)), (''def'', 1705)])"

end


(* Author: Tobias Nipkow, Florian Haftmann, TU Muenchen *)

section \<open>Character and string types\<close>

theory String
imports Enum Bit_Operations Code_Numeral
begin

subsection \<open>Strings as list of bytes\<close>

text \<open>
  When modelling strings, we follow the approach given
  in \<^url>\<open>https://utf8everywhere.org/\<close>:

  \<^item> Strings are a list of bytes (8 bit).

  \<^item> Byte values from 0 to 127 are US-ASCII.

  \<^item> Byte values from 128 to 255 are uninterpreted blobs.
\<close>

subsubsection \<open>Bytes as datatype\<close>

datatype char =
  Char (digit0: bool) (digit1: bool) (digit2: bool) (digit3: bool)
       (digit4: bool) (digit5: bool) (digit6: bool) (digit7: bool)

context comm_semiring_1
begin

definition of_char :: \<open>char \<Rightarrow> 'a\<close>
  where \<open>of_char c = horner_sum of_bool 2 [digit0 c, digit1 c, digit2 c, digit3 c, digit4 c, digit5 c, digit6 c, digit7 c]\<close>

lemma of_char_Char [simp]:
  \<open>of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) =
    horner_sum of_bool 2 [b0, b1, b2, b3, b4, b5, b6, b7]\<close>
  by (simp add: of_char_def)

end

lemma (in comm_semiring_1) of_nat_of_char:
  \<open>of_nat (of_char c) = of_char c\<close>
  by (cases c) simp

lemma (in comm_ring_1) of_int_of_char:
  \<open>of_int (of_char c) = of_char c\<close>
  by (cases c) simp

lemma nat_of_char [simp]:
  \<open>nat (of_char c) = of_char c\<close>
  by (cases c) (simp only: of_char_Char nat_horner_sum)

context unique_euclidean_semiring_with_bit_operations
begin

definition char_of :: \<open>'a \<Rightarrow> char\<close>
  where \<open>char_of n = Char (bit n 0) (bit n 1) (bit n 2) (bit n 3) (bit n 4) (bit n 5) (bit n 6) (bit n 7)\<close>

lemma char_of_take_bit_eq:
  \<open>char_of (take_bit n m) = char_of m\<close> if \<open>n \<ge> 8\<close>
  using that by (simp add: char_of_def bit_take_bit_iff)

lemma char_of_char [simp]:
  \<open>char_of (of_char c) = c\<close>
  by (simp only: of_char_def char_of_def bit_horner_sum_bit_iff) simp

lemma char_of_comp_of_char [simp]:
  "char_of \<circ> of_char = id"
  by (simp add: fun_eq_iff)

lemma inj_of_char:
  \<open>inj of_char\<close>
proof (rule injI)
  fix c d
  assume "of_char c = of_char d"
  then have "char_of (of_char c) = char_of (of_char d)"
    by simp
  then show "c = d"
    by simp
qed

lemma of_char_eqI:
  \<open>c = d\<close> if \<open>of_char c = of_char d\<close>
  using that inj_of_char by (simp add: inj_eq)

lemma of_char_eq_iff [simp]:
  \<open>of_char c = of_char d \<longleftrightarrow> c = d\<close>
  by (auto intro: of_char_eqI)

lemma of_char_of [simp]:
  \<open>of_char (char_of a) = a mod 256\<close>
proof -
  have \<open>[0..<8] = [0, Suc 0, 2, 3, 4, 5, 6, 7 :: nat]\<close>
    by (simp add: upt_eq_Cons_conv)
  then have \<open>[bit a 0, bit a 1, bit a 2, bit a 3, bit a 4, bit a 5, bit a 6, bit a 7] = map (bit a) [0..<8]\<close>
    by simp
  then have \<open>of_char (char_of a) = take_bit 8 a\<close>
    by (simp only: char_of_def of_char_def char.sel horner_sum_bit_eq_take_bit)
  then show ?thesis
    by (simp add: take_bit_eq_mod)
qed

lemma char_of_mod_256 [simp]:
  \<open>char_of (n mod 256) = char_of n\<close>
  by (rule of_char_eqI) simp

lemma of_char_mod_256 [simp]:
  \<open>of_char c mod 256 = of_char c\<close>
proof -
  have \<open>of_char (char_of (of_char c)) mod 256 = of_char (char_of (of_char c))\<close>
    by (simp only: of_char_of) simp
  then show ?thesis
    by simp
qed

lemma char_of_quasi_inj [simp]:
  \<open>char_of m = char_of n \<longleftrightarrow> m mod 256 = n mod 256\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?Q
  then show ?P
    by (auto intro: of_char_eqI)
next
  assume ?P
  then have \<open>of_char (char_of m) = of_char (char_of n)\<close>
    by simp
  then show ?Q
    by simp
qed

lemma char_of_eq_iff:
  \<open>char_of n = c \<longleftrightarrow> take_bit 8 n = of_char c\<close>
  by (auto intro: of_char_eqI simp add: take_bit_eq_mod)

lemma char_of_nat [simp]:
  \<open>char_of (of_nat n) = char_of n\<close>
  by (simp add: char_of_def String.char_of_def drop_bit_of_nat bit_simps possible_bit_def)

end

lemma inj_on_char_of_nat [simp]:
  "inj_on char_of {0::nat..<256}"
  by (rule inj_onI) simp

lemma nat_of_char_less_256 [simp]:
  "of_char c < (256 :: nat)"
proof -
  have "of_char c mod (256 :: nat) < 256"
    by arith
  then show ?thesis by simp
qed

lemma range_nat_of_char:
  "range of_char = {0::nat..<256}"
proof (rule; rule)
  fix n :: nat
  assume "n \<in> range of_char"
  then show "n \<in> {0..<256}"
    by auto
next
  fix n :: nat
  assume "n \<in> {0..<256}"
  then have "n = of_char (char_of n)"
    by simp
  then show "n \<in> range of_char"
    by (rule range_eqI)
qed

lemma UNIV_char_of_nat:
  "UNIV = char_of ` {0::nat..<256}"
proof -
  have "range (of_char :: char \<Rightarrow> nat) = of_char ` char_of ` {0::nat..<256}"
    by (auto simp add: range_nat_of_char intro!: image_eqI)
  with inj_of_char [where ?'a = nat] show ?thesis
    by (simp add: inj_image_eq_iff)
qed

lemma card_UNIV_char:
  "card (UNIV :: char set) = 256"
  by (auto simp add: UNIV_char_of_nat card_image)

context
  includes lifting_syntax integer.lifting natural.lifting
begin

lemma [transfer_rule]:
  \<open>((=) ===> pcr_integer) of_char of_char\<close>
  by (unfold of_char_def) transfer_prover

lemma [transfer_rule]:
  \<open>(pcr_natural ===> (=)) char_of char_of\<close>
  by (unfold char_of_def) transfer_prover

lemma [transfer_rule]:
  \<open>((=) ===> pcr_natural) of_char of_char\<close>
  by (unfold of_char_def) transfer_prover

end

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

lemma size_char_eq_0 [simp, code]:
  \<open>size c = 0\<close> for c :: char
  by (cases c) simp

lemma size'_char_eq_0 [simp, code]:
  \<open>size_char c = 0\<close>
  by (cases c) simp

syntax
  "_Char" :: "str_position \<Rightarrow> char"    ("CHR _")
  "_Char_ord" :: "num_const \<Rightarrow> char"   ("CHR _")

type_synonym string = "char list"

syntax
  "_String" :: "str_position \<Rightarrow> string"    ("_")

ML_file \<open>Tools/string_syntax.ML\<close>

instantiation char :: enum
begin

definition
  "Enum.enum = [
    CHR 0x00, CHR 0x01, CHR 0x02, CHR 0x03,
    CHR 0x04, CHR 0x05, CHR 0x06, CHR 0x07,
    CHR 0x08, CHR 0x09, CHR ''\<newline>'', CHR 0x0B,
    CHR 0x0C, CHR 0x0D, CHR 0x0E, CHR 0x0F,
    CHR 0x10, CHR 0x11, CHR 0x12, CHR 0x13,
    CHR 0x14, CHR 0x15, CHR 0x16, CHR 0x17,
    CHR 0x18, CHR 0x19, CHR 0x1A, CHR 0x1B,
    CHR 0x1C, CHR 0x1D, CHR 0x1E, CHR 0x1F,
    CHR '' '', CHR ''!'', CHR 0x22, CHR ''#'',
    CHR ''$'', CHR ''%'', CHR ''&'', CHR 0x27,
    CHR ''('', CHR '')'', CHR ''*'', CHR ''+'',
    CHR '','', CHR ''-'', CHR ''.'', CHR ''/'',
    CHR ''0'', CHR ''1'', CHR ''2'', CHR ''3'',
    CHR ''4'', CHR ''5'', CHR ''6'', CHR ''7'',
    CHR ''8'', CHR ''9'', CHR '':'', CHR '';'',
    CHR ''<'', CHR ''='', CHR ''>'', CHR ''?'',
    CHR ''@'', CHR ''A'', CHR ''B'', CHR ''C'',
    CHR ''D'', CHR ''E'', CHR ''F'', CHR ''G'',
    CHR ''H'', CHR ''I'', CHR ''J'', CHR ''K'',
    CHR ''L'', CHR ''M'', CHR ''N'', CHR ''O'',
    CHR ''P'', CHR ''Q'', CHR ''R'', CHR ''S'',
    CHR ''T'', CHR ''U'', CHR ''V'', CHR ''W'',
    CHR ''X'', CHR ''Y'', CHR ''Z'', CHR ''['',
    CHR 0x5C, CHR '']'', CHR ''^'', CHR ''_'',
    CHR 0x60, CHR ''a'', CHR ''b'', CHR ''c'',
    CHR ''d'', CHR ''e'', CHR ''f'', CHR ''g'',
    CHR ''h'', CHR ''i'', CHR ''j'', CHR ''k'',
    CHR ''l'', CHR ''m'', CHR ''n'', CHR ''o'',
    CHR ''p'', CHR ''q'', CHR ''r'', CHR ''s'',
    CHR ''t'', CHR ''u'', CHR ''v'', CHR ''w'',
    CHR ''x'', CHR ''y'', CHR ''z'', CHR ''{'',
    CHR ''|'', CHR ''}'', CHR ''~'', CHR 0x7F,
    CHR 0x80, CHR 0x81, CHR 0x82, CHR 0x83,
    CHR 0x84, CHR 0x85, CHR 0x86, CHR 0x87,
    CHR 0x88, CHR 0x89, CHR 0x8A, CHR 0x8B,
    CHR 0x8C, CHR 0x8D, CHR 0x8E, CHR 0x8F,
    CHR 0x90, CHR 0x91, CHR 0x92, CHR 0x93,
    CHR 0x94, CHR 0x95, CHR 0x96, CHR 0x97,
    CHR 0x98, CHR 0x99, CHR 0x9A, CHR 0x9B,
    CHR 0x9C, CHR 0x9D, CHR 0x9E, CHR 0x9F,
    CHR 0xA0, CHR 0xA1, CHR 0xA2, CHR 0xA3,
    CHR 0xA4, CHR 0xA5, CHR 0xA6, CHR 0xA7,
    CHR 0xA8, CHR 0xA9, CHR 0xAA, CHR 0xAB,
    CHR 0xAC, CHR 0xAD, CHR 0xAE, CHR 0xAF,
    CHR 0xB0, CHR 0xB1, CHR 0xB2, CHR 0xB3,
    CHR 0xB4, CHR 0xB5, CHR 0xB6, CHR 0xB7,
    CHR 0xB8, CHR 0xB9, CHR 0xBA, CHR 0xBB,
    CHR 0xBC, CHR 0xBD, CHR 0xBE, CHR 0xBF,
    CHR 0xC0, CHR 0xC1, CHR 0xC2, CHR 0xC3,
    CHR 0xC4, CHR 0xC5, CHR 0xC6, CHR 0xC7,
    CHR 0xC8, CHR 0xC9, CHR 0xCA, CHR 0xCB,
    CHR 0xCC, CHR 0xCD, CHR 0xCE, CHR 0xCF,
    CHR 0xD0, CHR 0xD1, CHR 0xD2, CHR 0xD3,
    CHR 0xD4, CHR 0xD5, CHR 0xD6, CHR 0xD7,
    CHR 0xD8, CHR 0xD9, CHR 0xDA, CHR 0xDB,
    CHR 0xDC, CHR 0xDD, CHR 0xDE, CHR 0xDF,
    CHR 0xE0, CHR 0xE1, CHR 0xE2, CHR 0xE3,
    CHR 0xE4, CHR 0xE5, CHR 0xE6, CHR 0xE7,
    CHR 0xE8, CHR 0xE9, CHR 0xEA, CHR 0xEB,
    CHR 0xEC, CHR 0xED, CHR 0xEE, CHR 0xEF,
    CHR 0xF0, CHR 0xF1, CHR 0xF2, CHR 0xF3,
    CHR 0xF4, CHR 0xF5, CHR 0xF6, CHR 0xF7,
    CHR 0xF8, CHR 0xF9, CHR 0xFA, CHR 0xFB,
    CHR 0xFC, CHR 0xFD, CHR 0xFE, CHR 0xFF]"

definition
  "Enum.enum_all P \<longleftrightarrow> list_all P (Enum.enum :: char list)"

definition
  "Enum.enum_ex P \<longleftrightarrow> list_ex P (Enum.enum :: char list)"

lemma enum_char_unfold:
  "Enum.enum = map char_of [0..<256]"
proof -
  have "map (of_char :: char \<Rightarrow> nat) Enum.enum = [0..<256]"
    by (simp add: enum_char_def of_char_def upt_conv_Cons_Cons numeral_2_eq_2 [symmetric])
  then have "map char_of (map (of_char :: char \<Rightarrow> nat) Enum.enum) =
    map char_of [0..<256]"
    by simp
  then show ?thesis
    by simp
qed

instance proof
  show UNIV: "UNIV = set (Enum.enum :: char list)"
    by (simp add: enum_char_unfold UNIV_char_of_nat atLeast0LessThan)
  show "distinct (Enum.enum :: char list)"
    by (auto simp add: enum_char_unfold distinct_map intro: inj_onI)
  show "\<And>P. Enum.enum_all P \<longleftrightarrow> Ball (UNIV :: char set) P"
    by (simp add: UNIV enum_all_char_def list_all_iff)
  show "\<And>P. Enum.enum_ex P \<longleftrightarrow> Bex (UNIV :: char set) P"
    by (simp add: UNIV enum_ex_char_def list_ex_iff)
qed

end

lemma linorder_char:
  "class.linorder (\<lambda>c d. of_char c \<le> (of_char d :: nat)) (\<lambda>c d. of_char c < (of_char d :: nat))"
  by standard auto

text \<open>Optimized version for execution\<close>

definition char_of_integer :: "integer \<Rightarrow> char"
  where [code_abbrev]: "char_of_integer = char_of"

definition integer_of_char :: "char \<Rightarrow> integer"
  where [code_abbrev]: "integer_of_char = of_char"

lemma char_of_integer_code [code]:
  "char_of_integer k = (let
     (q0, b0) = bit_cut_integer k;
     (q1, b1) = bit_cut_integer q0;
     (q2, b2) = bit_cut_integer q1;
     (q3, b3) = bit_cut_integer q2;
     (q4, b4) = bit_cut_integer q3;
     (q5, b5) = bit_cut_integer q4;
     (q6, b6) = bit_cut_integer q5;
     (_, b7) = bit_cut_integer q6
    in Char b0 b1 b2 b3 b4 b5 b6 b7)"
  by (simp add: bit_cut_integer_def char_of_integer_def char_of_def div_mult2_numeral_eq bit_iff_odd_drop_bit drop_bit_eq_div)

lemma integer_of_char_code [code]:
  "integer_of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) =
    ((((((of_bool b7 * 2 + of_bool b6) * 2 +
      of_bool b5) * 2 + of_bool b4) * 2 +
        of_bool b3) * 2 + of_bool b2) * 2 +
          of_bool b1) * 2 + of_bool b0"
  by (simp add: integer_of_char_def of_char_def)

subsection \<open>Strings as dedicated type for target language code generation\<close>

subsubsection \<open>Logical specification\<close>

context
begin

qualified definition ascii_of :: "char \<Rightarrow> char"
  where "ascii_of c = Char (digit0 c) (digit1 c) (digit2 c) (digit3 c) (digit4 c) (digit5 c) (digit6 c) False"

qualified lemma ascii_of_Char [simp]:
  "ascii_of (Char b0 b1 b2 b3 b4 b5 b6 b7) = Char b0 b1 b2 b3 b4 b5 b6 False"
  by (simp add: ascii_of_def)

qualified lemma digit0_ascii_of_iff [simp]:
  "digit0 (String.ascii_of c) \<longleftrightarrow> digit0 c"
  by (simp add: String.ascii_of_def)

qualified lemma digit1_ascii_of_iff [simp]:
  "digit1 (String.ascii_of c) \<longleftrightarrow> digit1 c"
  by (simp add: String.ascii_of_def)

qualified lemma digit2_ascii_of_iff [simp]:
  "digit2 (String.ascii_of c) \<longleftrightarrow> digit2 c"
  by (simp add: String.ascii_of_def)

qualified lemma digit3_ascii_of_iff [simp]:
  "digit3 (String.ascii_of c) \<longleftrightarrow> digit3 c"
  by (simp add: String.ascii_of_def)

qualified lemma digit4_ascii_of_iff [simp]:
  "digit4 (String.ascii_of c) \<longleftrightarrow> digit4 c"
  by (simp add: String.ascii_of_def)

qualified lemma digit5_ascii_of_iff [simp]:
  "digit5 (String.ascii_of c) \<longleftrightarrow> digit5 c"
  by (simp add: String.ascii_of_def)

qualified lemma digit6_ascii_of_iff [simp]:
  "digit6 (String.ascii_of c) \<longleftrightarrow> digit6 c"
  by (simp add: String.ascii_of_def)

qualified lemma not_digit7_ascii_of [simp]:
  "\<not> digit7 (ascii_of c)"
  by (simp add: ascii_of_def)

qualified lemma ascii_of_idem:
  "ascii_of c = c" if "\<not> digit7 c"
  using that by (cases c) simp

qualified typedef literal = "{cs. \<forall>c\<in>set cs. \<not> digit7 c}"
  morphisms explode Abs_literal
proof
  show "[] \<in> {cs. \<forall>c\<in>set cs. \<not> digit7 c}"
    by simp
qed

qualified setup_lifting type_definition_literal

qualified lift_definition implode :: "string \<Rightarrow> literal"
  is "map ascii_of"
  by auto

qualified lemma implode_explode_eq [simp]:
  "String.implode (String.explode s) = s"
proof transfer
  fix cs
  show "map ascii_of cs = cs" if "\<forall>c\<in>set cs. \<not> digit7 c"
    using that
      by (induction cs) (simp_all add: ascii_of_idem)
qed

qualified lemma explode_implode_eq [simp]:
  "String.explode (String.implode cs) = map ascii_of cs"
  by transfer rule

end

context unique_euclidean_semiring_with_bit_operations
begin

context
begin

qualified lemma char_of_ascii_of [simp]:
  \<open>of_char (String.ascii_of c) = take_bit 7 (of_char c)\<close>
  by (cases c) (simp only: String.ascii_of_Char of_char_Char take_bit_horner_sum_bit_eq, simp)

qualified lemma ascii_of_char_of:
  \<open>String.ascii_of (char_of a) = char_of (take_bit 7 a)\<close>
  by (simp add: char_of_def bit_simps)

end

end

subsubsection \<open>Syntactic representation\<close>

text \<open>
  Logical ground representations for literals are:

  \<^enum> \<open>0\<close> for the empty literal;

  \<^enum> \<open>Literal b0 \<dots> b6 s\<close> for a literal starting with one
    character and continued by another literal.

  Syntactic representations for literals are:

  \<^enum> Printable text as string prefixed with \<open>STR\<close>;

  \<^enum> A single ascii value as numerical hexadecimal value prefixed with \<open>STR\<close>.
\<close>

instantiation String.literal :: zero
begin

context
begin

qualified lift_definition zero_literal :: String.literal
  is Nil
  by simp

instance ..

end

end

context
begin

qualified abbreviation (output) empty_literal :: String.literal
  where "empty_literal \<equiv> 0"

qualified lift_definition Literal :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is "\<lambda>b0 b1 b2 b3 b4 b5 b6 cs. Char b0 b1 b2 b3 b4 b5 b6 False # cs"
  by auto

qualified lemma Literal_eq_iff [simp]:
  "Literal b0 b1 b2 b3 b4 b5 b6 s = Literal c0 c1 c2 c3 c4 c5 c6 t
     \<longleftrightarrow> (b0 \<longleftrightarrow> c0) \<and> (b1 \<longleftrightarrow> c1) \<and> (b2 \<longleftrightarrow> c2) \<and> (b3 \<longleftrightarrow> c3)
         \<and> (b4 \<longleftrightarrow> c4) \<and> (b5 \<longleftrightarrow> c5) \<and> (b6 \<longleftrightarrow> c6) \<and> s = t"
  by transfer simp

qualified lemma empty_neq_Literal [simp]:
  "empty_literal \<noteq> Literal b0 b1 b2 b3 b4 b5 b6 s"
  by transfer simp

qualified lemma Literal_neq_empty [simp]:
  "Literal b0 b1 b2 b3 b4 b5 b6 s \<noteq> empty_literal"
  by transfer simp

end

code_datatype "0 :: String.literal" String.Literal

syntax
  "_Literal" :: "str_position \<Rightarrow> String.literal"   ("STR _")
  "_Ascii" :: "num_const \<Rightarrow> String.literal"        ("STR _")

ML_file \<open>Tools/literal.ML\<close>

subsubsection \<open>Operations\<close>

instantiation String.literal :: plus
begin

context
begin

qualified lift_definition plus_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is "(@)"
  by auto

instance ..

end

end

instance String.literal :: monoid_add
  by (standard; transfer) simp_all

instantiation String.literal :: size
begin

context
  includes literal.lifting
begin

lift_definition size_literal :: "String.literal \<Rightarrow> nat"
  is length .

end

instance ..

end

instantiation String.literal :: equal
begin

context
begin

qualified lift_definition equal_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is HOL.equal .

instance
  by (standard; transfer) (simp add: equal)

end

end

instantiation String.literal :: linorder
begin

context
begin

qualified lift_definition less_eq_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp_eq (\<lambda>c d. of_char c < (of_char d :: nat))"
  .

qualified lift_definition less_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp (\<lambda>c d. of_char c < (of_char d :: nat))"
  .

instance proof -
  from linorder_char interpret linorder "ord.lexordp_eq (\<lambda>c d. of_char c < (of_char d :: nat))"
    "ord.lexordp (\<lambda>c d. of_char c < (of_char d :: nat)) :: string \<Rightarrow> string \<Rightarrow> bool"
    by (rule linorder.lexordp_linorder)
  show "PROP ?thesis"
    by (standard; transfer) (simp_all add: less_le_not_le linear)
qed

end

end

lemma infinite_literal:
  "infinite (UNIV :: String.literal set)"
proof -
  define S where "S = range (\<lambda>n. replicate n CHR ''A'')"
  have "inj_on String.implode S"
  proof (rule inj_onI)
    fix cs ds
    assume "String.implode cs = String.implode ds"
    then have "String.explode (String.implode cs) = String.explode (String.implode ds)"
      by simp
    moreover assume "cs \<in> S" and "ds \<in> S"
    ultimately show "cs = ds"
      by (auto simp add: S_def)
  qed
  moreover have "infinite S"
    by (auto simp add: S_def dest: finite_range_imageI [of _ length])
  ultimately have "infinite (String.implode ` S)"
    by (simp add: finite_image_iff)
  then show ?thesis
    by (auto intro: finite_subset)
qed

subsubsection \<open>Executable conversions\<close>

context
begin

qualified lift_definition asciis_of_literal :: "String.literal \<Rightarrow> integer list"
  is "map of_char"
  .

qualified lemma asciis_of_zero [simp, code]:
  "asciis_of_literal 0 = []"
  by transfer simp

qualified lemma asciis_of_Literal [simp, code]:
  "asciis_of_literal (String.Literal b0 b1 b2 b3 b4 b5 b6 s) =
    of_char (Char b0 b1 b2 b3 b4 b5 b6 False) # asciis_of_literal s "
  by transfer simp

qualified lift_definition literal_of_asciis :: "integer list \<Rightarrow> String.literal"
  is "map (String.ascii_of \<circ> char_of)"
  by auto

qualified lemma literal_of_asciis_Nil [simp, code]:
  "literal_of_asciis [] = 0"
  by transfer simp

qualified lemma literal_of_asciis_Cons [simp, code]:
  "literal_of_asciis (k # ks) = (case char_of k
    of Char b0 b1 b2 b3 b4 b5 b6 b7 \<Rightarrow> String.Literal b0 b1 b2 b3 b4 b5 b6 (literal_of_asciis ks))"
  by (simp add: char_of_def) (transfer, simp add: char_of_def)

qualified lemma literal_of_asciis_of_literal [simp]:
  "literal_of_asciis (asciis_of_literal s) = s"
proof transfer
  fix cs
  assume "\<forall>c\<in>set cs. \<not> digit7 c"
  then show "map (String.ascii_of \<circ> char_of) (map of_char cs) = cs"
    by (induction cs) (simp_all add: String.ascii_of_idem)
qed

qualified lemma explode_code [code]:
  "String.explode s = map char_of (asciis_of_literal s)"
  by transfer simp

qualified lemma implode_code [code]:
  "String.implode cs = literal_of_asciis (map of_char cs)"
  by transfer simp

qualified lemma equal_literal [code]:
  "HOL.equal (String.Literal b0 b1 b2 b3 b4 b5 b6 s)
    (String.Literal a0 a1 a2 a3 a4 a5 a6 r)
    \<longleftrightarrow> (b0 \<longleftrightarrow> a0) \<and> (b1 \<longleftrightarrow> a1) \<and> (b2 \<longleftrightarrow> a2) \<and> (b3 \<longleftrightarrow> a3)
      \<and> (b4 \<longleftrightarrow> a4) \<and> (b5 \<longleftrightarrow> a5) \<and> (b6 \<longleftrightarrow> a6) \<and> (s = r)"
  by (simp add: equal)

end

subsubsection \<open>Technical code generation setup\<close>

text \<open>Alternative constructor for generated computations\<close>

context
begin

qualified definition Literal' :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> String.literal \<Rightarrow> String.literal"
  where [simp]: "Literal' = String.Literal"

lemma [code_computation_unfold]:
  "String.Literal = Literal'"
  by simp

end

code_reserved SML string String Char Str_Literal
code_reserved OCaml string String Char Str_Literal
code_reserved Haskell Prelude
code_reserved Scala string

code_identifier
  code_module String \<rightharpoonup>
    (SML) Str and (OCaml) Str and (Haskell) Str and (Scala) Str

code_printing
  type_constructor String.literal \<rightharpoonup>
    (SML) "string"
    and (OCaml) "string"
    and (Haskell) "String"
    and (Scala) "String"
| constant "STR ''''" \<rightharpoonup>
    (SML) "\"\""
    and (OCaml) "\"\""
    and (Haskell) "\"\""
    and (Scala) "\"\""

setup \<open>
  fold Literal.add_code ["SML", "OCaml", "Haskell", "Scala"]
\<close>

code_printing
  code_module "Str_Literal" \<rightharpoonup>
    (SML) \<open>structure Str_Literal =
struct

fun map f [] = []
  | map f (x :: xs) = f x :: map f xs; (* deliberate clone not relying on List._ module *)

fun check_ascii (k : IntInf.int) =
  if 0 <= k andalso k < 128
  then k
  else raise Fail "Non-ASCII character in literal";

val char_of_ascii = Char.chr o IntInf.toInt o check_ascii;

val ascii_of_char = check_ascii o IntInf.fromInt o Char.ord;

val literal_of_asciis = String.implode o map char_of_ascii;

val asciis_of_literal = map ascii_of_char o String.explode;

end;\<close> for constant String.literal_of_asciis String.asciis_of_literal
    and (OCaml) \<open>module Str_Literal =
struct

let implode f xs =
  let rec length xs = match xs with
      [] -> 0
    | x :: xs -> 1 + length xs in
  let rec nth xs n = match xs with
    (x :: xs) -> if n <= 0 then x else nth xs (n - 1)
  in String.init (length xs) (fun n -> f (nth xs n));;

let explode f s =
  let rec map_range f n =
    if n <= 0 then [] else map_range f (n - 1) @ [f n]
  in map_range (fun n -> f (String.get s n)) (String.length s);;

let z_128 = Z.of_int 128;;

let check_ascii (k : Z.t) =
  if Z.leq Z.zero k && Z.lt k z_128
  then k
  else failwith "Non-ASCII character in literal";;

let char_of_ascii k = Char.chr (Z.to_int (check_ascii k));;

let ascii_of_char c = check_ascii (Z.of_int (Char.code c));;

let literal_of_asciis ks = implode char_of_ascii ks;;

let asciis_of_literal s = explode ascii_of_char s;;

end;;\<close> for constant String.literal_of_asciis String.asciis_of_literal
| constant "(+) :: String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal" \<rightharpoonup>
    (SML) infixl 18 "^"
    and (OCaml) infixr 6 "^"
    and (Haskell) infixr 5 "++"
    and (Scala) infixl 7 "+"
| constant String.literal_of_asciis \<rightharpoonup>
    (SML) "Str'_Literal.literal'_of'_asciis"
    and (OCaml) "Str'_Literal.literal'_of'_asciis"
    and (Haskell) "map/ (let chr k | (0 <= k && k < 128) = Prelude.toEnum k :: Prelude.Char in chr . Prelude.fromInteger)"
    and (Scala) "\"\"/ ++/ _.map((k: BigInt) => if (BigInt(0) <= k && k < BigInt(128)) k.charValue else sys.error(\"Non-ASCII character in literal\"))"
| constant String.asciis_of_literal \<rightharpoonup>
    (SML) "Str'_Literal.asciis'_of'_literal"
    and (OCaml) "Str'_Literal.asciis'_of'_literal"
    and (Haskell) "map/ (let ord k | (k < 128) = Prelude.toInteger k in ord . (Prelude.fromEnum :: Prelude.Char -> Prelude.Int))"
    and (Scala) "!(_.toList.map(c => { val k: Int = c.toInt; if (k < 128) BigInt(k) else sys.error(\"Non-ASCII character in literal\") }))"
| class_instance String.literal :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) = _)"
    and (OCaml) "!((_ : string) = _)"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="
| constant "(\<le>) :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) <= _)"
    and (OCaml) "!((_ : string) <= _)"
    and (Haskell) infix 4 "<="
    \<comment> \<open>Order operations for \<^typ>\<open>String.literal\<close> work in Haskell only
          if no type class instance needs to be generated, because String = [Char] in Haskell
          and \<^typ>\<open>char list\<close> need not have the same order as \<^typ>\<open>String.literal\<close>.\<close>
    and (Scala) infixl 4 "<="
    and (Eval) infixl 6 "<="
| constant "(<) :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) < _)"
    and (OCaml) "!((_ : string) < _)"
    and (Haskell) infix 4 "<"
    and (Scala) infixl 4 "<"
    and (Eval) infixl 6 "<"

subsubsection \<open>Code generation utility\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "Code")\<close>

definition abort :: "String.literal \<Rightarrow> (unit \<Rightarrow> 'a) \<Rightarrow> 'a"
  where [simp]: "abort _ f = f ()"

declare [[code drop: Code.abort]]

lemma abort_cong:
  "msg = msg' \<Longrightarrow> Code.abort msg f = Code.abort msg' f"
  by simp

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm Code.abort_cong})\<close>

code_printing
  constant Code.abort \<rightharpoonup>
    (SML) "!(raise/ Fail/ _)"
    and (OCaml) "failwith"
    and (Haskell) "!(error/ ::/ forall a./ String -> (() -> a) -> a)"
    and (Scala) "!{/ sys.error((_));/ ((_)).apply(())/ }"

subsubsection \<open>Finally\<close>

lifting_update literal.lifting
lifting_forget literal.lifting

end


theory FreeGroupMain
imports Main "HOL-Algebra.Group"
begin

(*
 group_spanset \<rightarrow> words_on_S
 spanset \<rightarrow> freewords_on
 reduct \<rightarrow> reduce
 lift_append \<rightarrow> proj_append
 reln_set \<rightarrow> reln_tuple
*)
type_synonym ('a,'b) monoidgentype = "'a \<times> 'b"

type_synonym ('a,'b) groupgentype = "('a,'b) monoidgentype \<times> bool"

type_synonym ('a,'b) word = "(('a,'b) groupgentype) list"

fun inverse::"('a,'b) groupgentype \<Rightarrow> ('a,'b) groupgentype"
  where
"inverse (x, True) = (x, False)"
|"inverse (x, False) = (x, True)"

lemma inverse_of_inverse:
  assumes "g = inverse h"
  shows "h = inverse g"
  using assms inverse.simps
  by (metis inverse.elims)

primrec wordinverse::"('a,'b) word \<Rightarrow> ('a, 'b) word"
  where
"wordinverse [] = []"
|"wordinverse (x#xs) =  (wordinverse xs)@[inverse x]"

lemma overlapleftexist:assumes "(a@b) = (y@x)" "length y > length a" shows "(\<exists>z.(a@z) = y)"
proof-
let ?v = "take (length y) (a@b)"
  have "?v = y" by (simp add: assms(1))
  moreover then have "take ( length a) ?v = a" by (metis append_eq_append_conv_if assms(1) assms(2) less_imp_le_nat)
  ultimately have " a @ (drop (length a) ?v)= y" by (metis append_take_drop_id)
  then show ?thesis  by blast
qed

lemma overlaprightexist:assumes "(b@a) = (x@y)" "length y > length a" shows "(\<exists>z.(z@a) = y)"
proof-
let ?v = "drop (length x) (b@a)"
  have "?v = y" by (simp add: assms(1))
  moreover then have "drop (length ?v - length a) ?v = a" using  append_eq_append_conv_if assms(2) by fastforce
  ultimately have "(take (length ?v - length a) ?v) @ a = y" by (metis append_take_drop_id)
  then show ?thesis  by blast
qed

lemma wordinverse_redef1: "wordinverse xs = rev (map inverse xs)"
proof(induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  have 1:"wordinverse (a#xs) = wordinverse xs @ [inverse a]" by auto
  have "rev (map inverse (a#xs)) = rev((inverse a#( map inverse xs)))" by simp
  then have 2: "rev (map inverse (a#xs)) = rev (map inverse (xs)) @ [inverse a]" by simp
  then show ?case using 1 2 Cons.IH by simp
qed

lemma wordinverse_redef2: "wordinverse xs = map inverse (rev xs)"
proof(induction xs)
case Nil
  then show ?case by simp
next
  case (Cons a xs)
  have 1:"wordinverse (a#xs) = wordinverse xs @ [inverse a]" by auto
  have "map inverse (rev (a#xs)) = map inverse (rev xs @ [a])"  by simp
  then have 2: "map inverse (rev (a#xs)) = map inverse (rev xs) @ [inverse a]"  by simp
  then show ?case using 1 2 Cons.IH by auto
qed

definition invgen ::  "('a,'b) monoidgentype set \<Rightarrow> ('a,'b) groupgentype set" ("_\<^sup>\<plusminus>")
  where
"S \<^sup>\<plusminus> = S \<times> {True,False}"

inductive_set words_on::"('a,'b) groupgentype set \<Rightarrow> ('a,'b) word set" ("_\<^sup>\<star>")
  for S::"('a,'b) groupgentype set"
  where
empty:"[] \<in> (S\<^sup>\<star>)"
|gen:"x \<in> S \<Longrightarrow> xs \<in> (S\<^sup>\<star>) \<Longrightarrow> (x#xs) \<in> (S\<^sup>\<star>)"

lemma cons_span: assumes "(x#xs) \<in> (words_on S)" shows "[x] \<in> (words_on S)"
proof(induction xs)
  case Nil
  then show ?case using assms words_on.cases words_on.empty words_on.gen
    by (metis list.distinct(1) list.sel(1))
next
  case (Cons y xs)
  then show ?case  by auto
qed

lemma span_append:assumes "a \<in> (words_on S)" "b \<in> (words_on S)" shows "(a@b) \<in> (words_on S)"
  using assms
proof(induction a)
  case empty
  then show ?case by simp
next
  case (gen x)
  then show ?case using  words_on.gen  by (metis Cons_eq_appendI)
qed

lemma span_cons: assumes "(x#xs) \<in> (words_on S)" shows "xs \<in> (words_on S)"
  using assms
proof(induction xs)
  case Nil
  then show ?case  by (simp add: words_on.empty)
next
  case (Cons a xs)
  then show ?case  using words_on.cases  words_on.gen  by blast
qed

lemma leftappend_span: assumes "(a@b) \<in> (words_on S)" shows "a \<in> (words_on S)"
  using assms
proof(induction a)
  case Nil
  then show ?case using words_on.empty by simp
next
  case (Cons a1 a2)
  then have 1: "(a1#(a2 @ b)) \<in> (words_on S)" by auto
  then have 2:"[a1] \<in> (words_on S)" using cons_span by blast
  have "(a2 @ b) \<in> (words_on S)" using span_cons Cons 1 by blast
  then have "a2 \<in> (words_on S)" using Cons by simp
  moreover have "(a1#a2)  = [a1] @ a2" by simp
  ultimately show ?case using 1 2 span_append  by metis
qed

lemma rightappend_span: assumes "(a@b) \<in> (words_on S)" shows "b \<in>  (words_on S)"
  using assms
proof(induction a)
case Nil
  then show ?case using empty by simp
next
  case (Cons a1 a2)
 then have 1: "(a1#(a2 @ b)) \<in> (words_on S)" by auto
  then have 2:"[a1] \<in> (words_on S)" using cons_span by blast
  have "(a2 @ b) \<in> (words_on S)" using span_cons Cons 1 by blast
  then show ?case using Cons by blast
qed

definition freewords_on::"('a,'b) monoidgentype set \<Rightarrow> ('a,'b) word set" ("\<langle>_\<rangle>")
  where
"\<langle>S\<rangle>  = words_on (invgen S)"

lemma span_inverse: assumes "x \<in> invgen  S" shows "inverse x \<in> invgen  S"
proof-
  let ?g = "fst x"
  let ?b = "snd x"
  have x: "x = (?g, ?b)" by simp
  have g:"?g \<in> S"using assms invgen_def by (metis eq_fst_iff mem_Sigma_iff)
  show ?thesis
  proof(cases "?b = False")
    case True
    have "(?g, True) \<in> invgen  S" using g by (simp add: invgen_def)
    then show ?thesis using True inverse.simps(2) x by metis
  next
    case False
    have "(?g, False) \<in> invgen  S" using g by (simp add: invgen_def)
    then show ?thesis using False inverse.simps(1) x  by metis
  qed
qed

lemma span_wordinverse: assumes "xs \<in> \<langle>S\<rangle>" shows "wordinverse xs \<in> \<langle>S\<rangle>"
  using assms unfolding freewords_on_def
proof(induction xs)
  case empty
  then show ?case by (simp add: words_on.empty)
next
  case (gen x xs)
  then have "inverse x \<in> invgen  S"  by (simp add: span_inverse)
  then have "[inverse x] \<in> (words_on (invgen S))" using words_on.empty words_on.gen by blast
  then have "wordinverse xs @ [inverse x] \<in> (words_on (invgen S))" using gen span_append by auto
  moreover have "wordinverse (x#xs) = wordinverse xs @ [inverse x]" by simp
  ultimately show ?case  by simp
qed

fun reduced::"('a,'b) word \<Rightarrow> bool"
  where
"reduced [] = True"
|"reduced [g] = True"
|"reduced (g#h#wrd) = (if (g \<noteq> inverse h) then reduced (h#wrd) else False)"

inductive reln::"('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool" (infixr "~" 65)
  where
refl[intro!]: "a ~ a" |
sym: "a ~ b \<Longrightarrow> b ~ a" |
trans: "a ~ b \<Longrightarrow> b ~ c \<Longrightarrow> a ~ c" |
base: "[g, inverse g] ~ []" |
mult: "xs ~ xs' \<Longrightarrow> ys ~ ys' \<Longrightarrow> (xs@ys) ~ (xs'@ys')"

definition reln_tuple :: "(('a,'b) word) set \<Rightarrow>(('a,'b) word \<times> ('a,'b) word) set"
  where
"reln_tuple S = {(x,y).x~y \<and> x \<in> S \<and> y \<in> S}"

lemma wordinverse_inverse: "(xs @ (wordinverse xs)) ~ []"
proof(induction xs)
  case Nil
  have "[] = []" by simp
  then show ?case by (simp add: reln.refl)
next
  case (Cons a xs)
  have "wordinverse (a#xs) = (wordinverse xs) @ [inverse a]"  by simp
  moreover have "(a#xs) = [a] @ xs" by simp
  ultimately have 1: "((a # xs) @ wordinverse (a # xs)) = [a] @ xs @ (wordinverse xs) @  [inverse a]" by (metis append_assoc)
  have "([a] @ xs @ (wordinverse xs)) ~ [a] @ []"  using Cons.IH mult by blast
  then have "([a] @ xs @ (wordinverse xs)) ~ [a]"  by auto
  moreover have "[inverse a] ~ [inverse a]" by (simp add: reln.refl)
  ultimately have "([a] @ xs @ (wordinverse xs) @  [inverse a]) ~ [a] @ [inverse a]" using mult by (metis append_assoc)
  then have "([a] @ xs @ (wordinverse xs) @  [inverse a]) ~ []" by (simp add: base reln.trans)
  then show ?case using 1  by auto
qed

lemma wordinverse_append: "(wordinverse x) @ (wordinverse y) = (wordinverse (y@x))"
proof(induction y)
  case Nil
  have "wordinverse [] = []" by simp
  then show ?case by simp
next
  case (Cons a y)
  have "(wordinverse x) @ (wordinverse (a # y)) = (wordinverse x) @ (wordinverse y) @ [inverse a]" by simp
  moreover have "(wordinverse ((a#y)@x)) = (wordinverse (y@x)) @ [inverse a]" by simp
  ultimately show ?case using "Cons.IH" by simp
qed

lemma wordinverse_of_wordinverse:  "wordinverse (wordinverse xs) = xs"
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  have 1: "wordinverse (a#xs) = (wordinverse xs) @ [inverse a]" by auto
  have "wordinverse [inverse a] = [a]" using inverse_of_inverse  by (metis append.left_neutral wordinverse.simps(1) wordinverse.simps(2))
  then have 2:"wordinverse ((wordinverse xs) @ [inverse a]) = [a] @ wordinverse (wordinverse xs)" using wordinverse_append by metis
  then have "[a] @ wordinverse (wordinverse xs) = [a] @ xs" using Cons by auto
  moreover have "[a] @ xs = (a#xs)" by simp
  ultimately show ?case using 1 2 by simp
qed

lemma wordinverse_symm :assumes "wordinverse xs = ys" shows "xs = wordinverse ys"
proof-
  have "wordinverse (wordinverse xs) = wordinverse ys"  using assms by auto
  then show ?thesis using wordinverse_of_wordinverse by metis
qed

lemma inverse_wordinverse: "((wordinverse xs) @  xs) ~ []"
proof-
  let ?ys = "wordinverse xs"
  have "(wordinverse ?ys = xs)" by (simp add: wordinverse_of_wordinverse)
  moreover have "(?ys @ wordinverse ?ys) ~ []" using wordinverse_inverse by blast
  ultimately show ?thesis using wordinverse_of_wordinverse by simp
qed

definition wordeq::"(('a, 'b) word) set \<Rightarrow>('a,'b) word \<Rightarrow> ('a,'b) word set" ("[[_]]")
  where
"wordeq  S wrd = {wrds. wrd ~ wrds \<and> wrds \<in> S}"

definition Congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool"
  where
"Congruent2 r f \<longleftrightarrow> (\<forall> y1 z1 y2 z2. (y1, z1) \<in> r \<and> (y2, z2) \<in> r \<longrightarrow> (f y1 y2, f z1 z2)  \<in> r)"

lemma append_congruent: "Congruent2 (reln_tuple \<langle>S\<rangle>) (@)"
proof-
  have "\<And>y1 z1 y2 z2 .\<lbrakk> (y1, z1) \<in> reln_tuple \<langle>S\<rangle> ; (y2, z2) \<in> reln_tuple \<langle>S\<rangle>\<rbrakk> \<Longrightarrow> (y1 @ y2, z1 @ z2) \<in> reln_tuple \<langle>S\<rangle>"
  proof-
    fix y1 z1 y2 z2 assume 1:"(y1, z1) \<in> (reln_tuple \<langle>S\<rangle>)" "(y2, z2) \<in> (reln_tuple \<langle>S\<rangle>)"
  have "y1 \<in>  \<langle>S\<rangle> \<and> z1 \<in> \<langle>S\<rangle>" using 1 reln_tuple_def by auto
  moreover have "y2 \<in>  \<langle>S\<rangle> \<and> z2 \<in> \<langle>S\<rangle>" using 1 reln_tuple_def by auto
  ultimately have A:"(y1@y2) \<in>  \<langle>S\<rangle> \<and> (z1@z2) \<in> \<langle>S\<rangle>" unfolding freewords_on_def by (simp add: span_append)
  have "y1 ~ z1" using 1 reln_tuple_def by auto
  moreover have "y2 ~ z2" using 1 reln_tuple_def by auto
  ultimately have "(y1@y2) ~ (z1@z2)" using mult by auto
  then show "((y1@y2) , (z1@z2)) \<in> (reln_tuple \<langle>S\<rangle>)" using A reln_tuple_def by auto
qed
  thus ?thesis  using Congruent2_def by blast
qed

definition ProjFun2 :: "'a set \<Rightarrow> ('a\<times>'a) set \<Rightarrow> ('a\<Rightarrow>'a \<Rightarrow>'a) \<Rightarrow> ('a set \<Rightarrow> 'a set \<Rightarrow> 'a set) " where
"ProjFun2 A r f =  (\<lambda>p q. (\<Union>x\<in>(p\<times>q) .r `` {f (fst x) (snd x)}))"

definition proj_append ::  "(('a,'b) word) set \<Rightarrow> (('a,'b) word) set \<Rightarrow> (('a,'b) word) set \<Rightarrow> (('a,'b) word) set"
  where
"proj_append S a b =  (ProjFun2 S (reln_tuple S) append) a b"

definition freegroup :: "('a,'b) monoidgentype set \<Rightarrow> (('a,'b) word set) monoid" ("F\<index>")
  where
"freegroup S \<equiv> \<lparr>
     carrier =  quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>),
     mult = proj_append \<langle>S\<rangle>,
     one = (reln_tuple \<langle>S\<rangle>) `` {[]}
  \<rparr>"

lemma reln_refl: "refl_on \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)"
proof-
  have "(\<And>x. x \<in> (reln_tuple \<langle>S\<rangle>) \<Longrightarrow> x \<in> \<langle>S\<rangle> \<times> \<langle>S\<rangle>)"
  proof-
    fix x assume 1: "x \<in> (reln_tuple \<langle>S\<rangle>)"
    let ?a = "(fst x)"
    let ?b = "(snd x)"
    have "(?a, ?b) \<in> (reln_tuple \<langle>S\<rangle>)" by (simp add: "1")
    then have "(?a, ?b) \<in> \<langle>S\<rangle> \<times> \<langle>S\<rangle>" using reln_tuple_def by (metis (no_types, lifting) Product_Type.Collect_case_prodD SigmaI prod.collapse)
    then show "x \<in> \<langle>S\<rangle> \<times> \<langle>S\<rangle>" by simp
  qed
  then have A:"reln_tuple \<langle>S\<rangle> \<subseteq> \<langle>S\<rangle> \<times> \<langle>S\<rangle>" by (simp add: subsetI)
  have "(\<And>x. x\<in>\<langle>S\<rangle> \<Longrightarrow> (x, x) \<in> reln_tuple \<langle>S\<rangle>)"
  proof-
    fix x assume "x\<in>\<langle>S\<rangle>"
    moreover have "x ~ x" by (simp add: reln.refl)
    ultimately show "(x, x) \<in> reln_tuple \<langle>S\<rangle>" by (simp add: reln_tuple_def)
  qed
  then have "(\<forall>x\<in>\<langle>S\<rangle>. (x, x) \<in> reln_tuple \<langle>S\<rangle>)" by simp
  then show ?thesis using A unfolding refl_on_def  by simp
qed

lemma reln_sym: "sym (reln_tuple \<langle>S\<rangle>)"
proof-
  have "(\<And>x y. (x, y) \<in> (reln_tuple \<langle>S\<rangle>) \<Longrightarrow> (y, x) \<in> (reln_tuple \<langle>S\<rangle>))"
  proof-
    fix x y assume 1:"(x,y)\<in>(reln_tuple \<langle>S\<rangle>)"
    then have 2:"x ~ y" using reln_tuple_def 1 by (metis (no_types, lifting) case_prodD mem_Collect_eq)
    then have "y ~ x" by (simp add: 2 reln.sym)
    then show "(y, x) \<in> reln_tuple \<langle>S\<rangle>"
      using 1 by (simp add: reln_tuple_def)
  qed
  then have "(\<forall>x y . (x, y) \<in> (reln_tuple \<langle>S\<rangle>) \<longrightarrow> (y, x) \<in> (reln_tuple \<langle>S\<rangle>))" by simp
  then show ?thesis unfolding sym_def  by simp
qed

lemma reln_trans: "trans (reln_tuple \<langle>S\<rangle>)"
proof-
  have "(\<And>x y z. (x, y) \<in> (reln_tuple \<langle>S\<rangle>) \<Longrightarrow> (y, z) \<in> (reln_tuple \<langle>S\<rangle>) \<Longrightarrow> (x, z) \<in> (reln_tuple \<langle>S\<rangle>))"
  proof-
    fix x y z assume 1:"(x,y)\<in>(reln_tuple \<langle>S\<rangle>)" assume 2: "(y, z) \<in> (reln_tuple \<langle>S\<rangle>)"
    have "x ~ y" using reln_tuple_def 1 by (metis (no_types, lifting) case_prodD mem_Collect_eq)
    moreover have "y ~ z" using reln_tuple_def 2 by (metis (no_types, lifting) case_prodD mem_Collect_eq)
    ultimately have "x ~ z" using reln.trans by auto
    then show "(x, z) \<in> reln_tuple \<langle>S\<rangle>" using 1 2 by (simp add: reln_tuple_def)
  qed
  then have "(\<forall>x y z. (x, y) \<in> (reln_tuple \<langle>S\<rangle>) \<longrightarrow> (y, z) \<in> (reln_tuple \<langle>S\<rangle>) \<longrightarrow> (x, z) \<in> (reln_tuple \<langle>S\<rangle>))" by simp
  then show ?thesis unfolding trans_def  by simp
qed

lemma reln_equiv: "equiv \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)"
  by (simp add: equivI reln_refl reln_sym reln_trans)

lemma equiv_2f_con: assumes "equiv A r"  "Congruent2 r f" "C1\<in>A//r" "C2\<in>A//r"  "y1\<in>C1"  "z1\<in>C1" "y2 \<in>C2" "z2\<in>C2"
  shows  "r `` {(f y1 y2)} = r `` {(f z1 z2)}"
proof-
  have "(y1, z1) \<in> r" by (meson assms(1) assms(3) assms(5) assms(6) quotient_eq_iff)
  moreover have "(y2, z2) \<in> r" by (meson assms(1) assms(4) assms(7) assms(8) quotient_eq_iff)
  ultimately have "((f y1 y2),(f z1 z2)) \<in> r"  using Congruent2_def assms(2) by fastforce
  then show ?thesis  by (meson assms(1) equiv_class_eq)
qed

lemma equiv_2f_clos: assumes "equiv A r"  "Congruent2 r f" "C1\<in>A//r"  "C2\<in>A//r"  "y1\<in>C1"  "y2\<in>C2"
  shows  "(f y1 y2) \<in> A"
proof-
  have y:"y1 \<in> A" using Union_quotient assms(1) assms(3) assms(5) by auto
  have z:"y2 \<in> A" using Union_quotient assms(1) assms(4) assms(6) by auto
  have yy: "(y1,y1) \<in> r" by (metis assms(1) assms(3) assms(5) quotient_eq_iff)
  have zz:  "(y2,y2) \<in> r" by (metis assms(1) assms(4) assms(6) quotient_eq_iff)
  have "(f y1 y2, f y1 y2) \<in> r" using yy zz using Congruent2_def assms(2) by fastforce
  then show ?thesis by (metis assms(1) equiv_class_eq_iff)
qed

lemma union_eq_2f_in:
  assumes "C1\<times>C2\<noteq>{}"  "\<forall>x\<in>C1\<times>C2. r``{ (b (fst x) (snd x))}\<in>A//r"  "\<forall>x y. x\<in>C1\<times>C2\<and>y\<in>C1\<times>C2\<longrightarrow> r``{(b (fst x) (snd x))}= r``{(b (fst y) (snd y))}" shows  "(\<Union>x\<in>C1\<times>C2. r``{(b (fst x) (snd x))} )\<in>A//r"
proof-
  obtain x where A:"x\<in>C1\<times>C2" using assms(1) by auto
  then have "\<forall>y\<in>C1\<times>C2. r``{(b (fst x) (snd x))}= r``{(b (fst y) (snd y))}" using assms(3) by blast
  then have "(\<Union>y\<in>C1\<times>C2. r``{(b (fst y) (snd y))}) = r``{(b (fst x) (snd x))}"  using assms(1) by blast
    then show ?thesis using A  by (simp add: assms(2))
  qed

lemma proj2fun_clos:
  assumes "equiv A r"  "Congruent2 r f" "C1\<in>A//r" "C2\<in>A//r"
  shows "((ProjFun2 A r f) C1 C2) \<in> A//r"
proof-
  have "\<And>z. z\<in>C1\<times>C2 \<Longrightarrow> f (fst z) (snd z)\<in>A"
  proof-
    fix z assume z: "z\<in>C1\<times>C2"
    show "f (fst z) (snd z) \<in> A" using equiv_2f_clos using assms(1) assms(2) assms(3) assms(4) z by fastforce
  qed
  then have "\<forall>z\<in>C1\<times>C2. f (fst z) (snd z)\<in>A" by simp
  then have "\<forall>z\<in>C1\<times>C2. r``{f (fst z) (snd z)}\<in>A//r" by (simp add: quotientI)
  moreover have "\<forall>z1 z2. z1\<in>C1\<times>C2\<and>z2\<in>C1\<times>C2\<longrightarrow>  r ``{f (fst(z1)) (snd(z1))} = r `` {f (fst(z2)) (snd(z2))}"
  proof-
    have "\<And>z1 z2. z1\<in>C1\<times>C2\<and>z2\<in>C1\<times>C2 \<Longrightarrow>  r ``{f (fst(z1)) (snd(z1))} = r `` {f (fst(z2)) (snd(z2))}"
    proof-
      fix z1 z2 assume 1:"z1\<in>C1\<times>C2\<and>z2\<in>C1\<times>C2"
      have 2:"(fst(z1)) \<in>C1" using 1 by auto
      have 3:"(fst(z2)) \<in>C1" using 1 by auto
      have 4:"(snd(z1)) \<in>C2" using 1 by auto
      have 5:"(snd(z2)) \<in>C2" using 1 by auto
      show " r ``{f (fst(z1)) (snd(z1))} = r `` {f (fst(z2)) (snd(z2))}" using equiv_2f_con[of "A" "r" "f" "C1" "C2" "(fst(z1))" "(fst(z2))" "(snd(z1))" "(snd(z2))"]   1 2 3 4 5  assms(1) assms(2) assms(3) assms(4) by simp
    qed
    then show ?thesis by simp
  qed
  moreover have "C1\<times>C2\<noteq>{}"  using assms(1) assms(3) assms(4) in_quotient_imp_non_empty by auto
  ultimately have "(\<Union>x\<in>C1\<times>C2. r``{(f (fst x) (snd x))} )\<in>A//r" using union_eq_2f_in[of "C1" "C2" "r" "f" "A"] by fastforce
  then show ?thesis unfolding ProjFun2_def by auto
qed

lemma proj_append_clos:
  assumes "C1\<in> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" "C2\<in> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)"
  shows "(proj_append \<langle>S\<rangle> C1 C2) \<in>  (quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>))"
proof-
  show ?thesis using assms(1) assms(2) reln_equiv[of "S"] append_congruent[of "S"] proj2fun_clos[of "\<langle>S\<rangle>" "(reln_tuple \<langle>S\<rangle>)" "append" "C1" "C2"] unfolding proj_append_def by fastforce
qed

lemma union_eq_2f_eq:
  assumes "C1\<times>C2\<noteq>{}"  "\<forall>x\<in>C1\<times>C2. r``{ (b (fst x) (snd x))} = X"
  shows  "(\<Union>y\<in>C1\<times>C2 .r``{ (b (fst y) (snd y))})=X"
    by (metis (no_types, lifting) SUP_eq_const assms(1) assms(2))

lemma equiv_2f_wd:
  assumes "equiv A r" "Congruent2 r f"  "x\<in>A"  "y\<in>A"
  shows "(ProjFun2 A r f) (r``{x}) (r``{y}) = r ``{(f x y)}"
proof-
  have "(r``{x})\<times> (r``{y}) \<noteq> {}"  by (metis Sigma_empty_iff assms(1) assms(3) assms(4) equals0D equiv_class_self)
  moreover have "\<forall>z\<in>r``{x}\<times>r``{y}. r ``{f (fst z) (snd z)}=r ``{f x y}"
  proof-
    have "\<And>z. z \<in> r``{x}\<times>r``{y} \<Longrightarrow> r ``{f (fst z) (snd z)}=r ``{f x y}"
    proof-
      fix z assume 1:"z \<in> r``{x}\<times>r``{y}"
      have "(fst z) \<in> r``{x}" using 1 by auto
      moreover have  "(snd z) \<in> r``{y}" using 1 by auto
      moreover have "r``{x}\<in>A//r" by (simp add: assms(3) quotientI)
      moreover have "r``{y}\<in>A//r" by (simp add: assms(4) quotientI)
      moreover have "x\<in>r``{x}" using assms(1) assms(3) equiv_class_self by force
     moreover have "y \<in>r``{y}" using assms(1) assms(4) equiv_class_self by force
     ultimately show "r ``{f (fst z) (snd z)}=r ``{f x y}" using assms(1) assms(2)  equiv_2f_con[of "A" "r" "f" "r `` {x}" "r `` {y}" "(fst z)" "x" "(snd z)" "y"]   by fastforce
   qed
   then show ?thesis by simp
 qed
  ultimately have "(\<Union>z\<in>r``{x}\<times>r``{y}. r``{(f (fst z) (snd z))} ) = r ``{f x y}" using union_eq_2f_eq by simp
  then show ?thesis unfolding ProjFun2_def by simp
qed

lemma proj_append_wd:
  assumes "x \<in> \<langle>S\<rangle>" "y \<in> \<langle>S\<rangle>"
  shows "(proj_append \<langle>S\<rangle> ((reln_tuple \<langle>S\<rangle>)``{x}) ((reln_tuple \<langle>S\<rangle>)``{y})) = (reln_tuple \<langle>S\<rangle>) `` {append x y}"
proof-
  show ?thesis
    using reln_equiv[of "S"] append_congruent[of "S"] assms equiv_2f_wd[of "\<langle>S\<rangle>" "(reln_tuple \<langle>S\<rangle>)" "append" "x" "y"] unfolding proj_append_def  by simp
qed

lemma projfun2_assoc:assumes "equiv A r" and "Congruent2 r f" and "\<forall>x \<in> A. \<forall> y \<in> A. \<forall> z \<in> A. f x (f y z) = f (f x y) z" "C1\<in>A//r" "C2\<in>A//r" "C3\<in>A//r" "g=(ProjFun2 A r f)" shows "(g (g C1 C2) C3) = (g C1 (g C2 C3))"
proof-
  obtain x y z where A:"C1=r``{x} \<and> C2=r``{y} \<and>  C3=r``{z} \<and>  x\<in>A \<and>  y\<in>A \<and>  z\<in>A" by (meson assms(4) assms(5) assms(6) quotientE)
  moreover then have B: "(f x y) \<in> A \<and> (f y z)  \<in> A"  using assms(1) assms(2) assms(4) assms(5) assms(6) equiv_2f_clos equiv_class_self by fastforce
  ultimately have "g (g C1 C2) C3 = r``{f (f x y) z}"  by (simp add: assms(1) assms(2) assms(7) equiv_2f_wd)
  moreover have "... = r``{f  x (f y z)}" by (simp add: A assms(3))
  moreover have "... = g  C1 (g C2 C3)" by (simp add: A B assms(1) assms(2) assms(7) equiv_2f_wd)
  ultimately show ?thesis by simp
qed

lemma append_assoc2: "\<forall>x \<in> A. \<forall> y \<in> A. \<forall> z \<in> A. append x (append y z) = append (append x y) z"
  by simp

lemma proj_append_assoc: assumes  "C1\<in>quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" "C2\<in>quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" "C3\<in>quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" shows "(proj_append \<langle>S\<rangle> C1 (proj_append \<langle>S\<rangle> C2 C3)) = (proj_append \<langle>S\<rangle> (proj_append \<langle>S\<rangle> C1 C2) C3)"
proof-
  show ?thesis using assms reln_equiv[of "S"] append_congruent[of "S"] append_assoc2[of "\<langle>S\<rangle>"] projfun2_assoc[of "\<langle>S\<rangle>" "(reln_tuple \<langle>S\<rangle>)" "append" "C1" "C2" "C3"] unfolding proj_append_def by simp
qed

lemma freegroup_is_group: "group (freegroup S)"
proof
  fix x y
  assume "x \<in> carrier (freegroup S)" hence x: "x \<in>(quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>))" by(auto simp add:freegroup_def)
  assume "y \<in> carrier (freegroup S)" hence y: "y \<in> (quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>))" by(auto simp add:freegroup_def)
  from x and y
  have "x \<otimes>\<^bsub>freegroup S\<^esub> y \<in> (quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>))" by (simp add: freegroup_def proj_append_clos)
  thus "x \<otimes>\<^bsub>freegroup S\<^esub> y \<in> carrier (freegroup S)"
    by (auto simp add:freegroup_def)
next
  fix x y z assume x:"x \<in> carrier (freegroup S)" assume y: "y \<in> carrier (freegroup S)" assume z: "z \<in> carrier (freegroup S)"
  from x and y and z
  show  "x \<otimes>\<^bsub>freegroup S\<^esub> y \<otimes>\<^bsub>freegroup S\<^esub> z = x \<otimes>\<^bsub>freegroup S\<^esub> (y \<otimes>\<^bsub>freegroup S\<^esub> z)" by (simp add: freegroup_def proj_append_assoc)
next
  have "[] \<in> \<langle>S\<rangle>" unfolding freewords_on_def using empty by auto
  then have "(reln_tuple \<langle>S\<rangle>) `` {[]} \<in> quotient \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" by (simp add: quotientI)
  then show "\<one>\<^bsub>freegroup S\<^esub> \<in> carrier (freegroup S)"  by (auto simp add:freegroup_def)
next
  fix x assume "x \<in> carrier (freegroup S)"
  moreover then obtain x1 where x:"(reln_tuple \<langle>S\<rangle>)``{x1} = x" by (metis freegroup_def partial_object.select_convs(1) quotientE)
  ultimately have "x1 \<in> \<langle>S\<rangle>"   by (metis freegroup_def partial_object.select_convs(1) proj_def proj_in_iff reln_equiv)
  moreover have "[] \<in> \<langle>S\<rangle>" using empty freewords_on_def by auto
  ultimately have "proj_append \<langle>S\<rangle> ((reln_tuple \<langle>S\<rangle>) `` {[]}) ((reln_tuple \<langle>S\<rangle>)``{x1}) = ((reln_tuple \<langle>S\<rangle>)``{x1})" by (simp add: proj_append_wd)
  then show "\<one>\<^bsub>freegroup S\<^esub> \<otimes>\<^bsub>freegroup S\<^esub> x = x" using x by (simp add: freegroup_def)
next
 fix x assume "x \<in> carrier (freegroup S)"
  moreover then obtain x1 where x:"(reln_tuple \<langle>S\<rangle>)``{x1} = x" by (metis freegroup_def partial_object.select_convs(1) quotientE)
  ultimately have "x1 \<in> \<langle>S\<rangle>"   by (metis freegroup_def partial_object.select_convs(1) proj_def proj_in_iff reln_equiv)
  moreover have "[] \<in> \<langle>S\<rangle>" using empty freewords_on_def by auto
  ultimately have "proj_append \<langle>S\<rangle>  ((reln_tuple \<langle>S\<rangle>)``{x1}) ((reln_tuple \<langle>S\<rangle>) `` {[]}) = ((reln_tuple \<langle>S\<rangle>)``{x1})" by (simp add: proj_append_wd)
  then show "x \<otimes>\<^bsub>freegroup S\<^esub> \<one>\<^bsub>freegroup S\<^esub> = x" using x by (simp add: freegroup_def)
next
  show "carrier (freegroup S) \<subseteq> Units (freegroup S)"
  proof (simp add:freegroup_def Units_def, rule subsetI)
    fix x assume 1:"x \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>"
    moreover then obtain x1 where x:"(reln_tuple \<langle>S\<rangle>)``{x1} = x" by (metis quotientE)
    ultimately have x1:"x1 \<in> \<langle>S\<rangle>"  by (metis  proj_def proj_in_iff reln_equiv)
    then have ix1:"wordinverse x1 \<in> \<langle>S\<rangle>" by (simp add: span_wordinverse)
    then have 2:"(reln_tuple \<langle>S\<rangle>)``{wordinverse x1} \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" by (simp add: quotientI)
    have nil: "[] \<in> \<langle>S\<rangle>" using empty freewords_on_def by auto
    have "proj_append \<langle>S\<rangle> ((reln_tuple \<langle>S\<rangle>)``{x1}) ((reln_tuple \<langle>S\<rangle>)``{wordinverse x1}) = reln_tuple \<langle>S\<rangle> `` {x1@(wordinverse x1)}"  by (simp add: ix1 proj_append_wd x1)
    moreover have "x1@(wordinverse x1) \<in> \<langle>S\<rangle>" using ix1 span_append freewords_on_def x1 by blast
    moreover then have "((x1@(wordinverse x1)), []) \<in> reln_tuple \<langle>S\<rangle>" using nil wordinverse_inverse reln_tuple_def by auto
    moreover then have "reln_tuple \<langle>S\<rangle> `` {x1@(wordinverse x1)} = reln_tuple \<langle>S\<rangle> `` {[]}" by (metis equiv_class_eq reln_equiv)
    ultimately have 3:"proj_append \<langle>S\<rangle> ((reln_tuple \<langle>S\<rangle>)``{x1}) ((reln_tuple \<langle>S\<rangle>)``{wordinverse x1}) = reln_tuple \<langle>S\<rangle> `` {[]}" by simp
    have "proj_append \<langle>S\<rangle>  ((reln_tuple \<langle>S\<rangle>)``{wordinverse x1}) ((reln_tuple \<langle>S\<rangle>)``{x1}) = reln_tuple \<langle>S\<rangle> `` {(wordinverse x1)@x1}"  by (simp add: ix1 proj_append_wd x1)
    moreover have "(wordinverse x1)@x1 \<in> \<langle>S\<rangle>" using ix1 span_append freewords_on_def x1 by blast
    moreover then have "(((wordinverse x1)@x1), []) \<in> reln_tuple \<langle>S\<rangle>" using nil inverse_wordinverse reln_tuple_def by auto
    moreover then have "reln_tuple \<langle>S\<rangle> `` {(wordinverse x1)@x1} = reln_tuple \<langle>S\<rangle> `` {[]}" by (metis equiv_class_eq reln_equiv)
    ultimately have 4:"proj_append \<langle>S\<rangle> ((reln_tuple \<langle>S\<rangle>)``{wordinverse x1}) ((reln_tuple \<langle>S\<rangle>)``{x1}) = reln_tuple \<langle>S\<rangle> `` {[]}" by simp
    show "x \<in> {y \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>.\<exists>x\<in>\<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>.proj_append \<langle>S\<rangle> x y = reln_tuple \<langle>S\<rangle> `` {[]} \<and> proj_append \<langle>S\<rangle> y x = reln_tuple \<langle>S\<rangle> `` {[]}}"  using 1 2 3 4 x by auto
  qed
qed

end


theory prop_54
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  (*hipster plus minus *)
(*hipster minus*)
lemma lemma_am [thy_expl]: "minus x2 x2 = Z"
apply (hipster_induct_schemes minus.simps)
done

lemma lemma_aam [thy_expl]: "minus x3 Z = x3"
by (hipster_induct_schemes minus.simps)

lemma lemma_abm [thy_expl]: "minus x2 (S x2) = Z"
by (hipster_induct_schemes)

lemma lemma_acm [thy_expl]: "minus (S x2) x2 = S Z"
by (hipster_induct_schemes)

lemma lemma_adm [thy_expl]: "minus (minus x3 y3) (minus y3 x3) = minus x3 y3"
by (hipster_induct_schemes minus.simps)

lemma lemma_aem [thy_expl]: "minus (minus x3 y3) (S Z) = minus x3 (S y3)"
by (hipster_induct_schemes minus.simps)

lemma lemma_afm [thy_expl]: "minus (minus x4 y4) x4 = Z"
by (hipster_induct_schemes minus.simps)

(*hipster plus*)
lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_aa [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps Nat.exhaust)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

  theorem x0 :
    "(minus (plus m n) n) = m"
    by (hipster_induct_schemes plus.simps minus.simps)
    (*
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_34
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun min :: "Nat => Nat => Nat" where
"min (Z) z = Z"
| "min (S z2) (Z) = Z"
| "min (S z2) (S y1) = S (min z2 y1)"

fun t2 :: "Nat => Nat => bool" where
"t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((x (min a b) b) = (t2 b a))"
  oops

end


theory int_mul_ident_right
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Sign = Pos | Neg

datatype Nat = Zero | Succ "Nat"

datatype Z = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Z" where
"toInteger (Pos) y = P y"
| "toInteger (Neg) (Zero) = P Zero"
| "toInteger (Neg) (Succ m) = N m"

fun sign2 :: "Z => Sign" where
"sign2 (P y) = Pos"
| "sign2 (N z) = Neg"

fun plus :: "Nat => Nat => Nat" where
"plus (Zero) y = y"
| "plus (Succ n) y = Succ (plus n y)"

fun opposite :: "Sign => Sign" where
"opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
"timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun one :: "Z" where
"one = P (Succ Zero)"

fun mult :: "Nat => Nat => Nat" where
"mult (Zero) y = Zero"
| "mult (Succ n) y = plus y (mult n y)"

fun absVal :: "Z => Nat" where
"absVal (P n) = n"
| "absVal (N m) = Succ m"

fun times :: "Z => Z => Z" where
"times x y =
   toInteger
     (timesSign (sign2 x) (sign2 y)) (mult (absVal x) (absVal y))"

(*hipster toInteger
          sign2
          plus
          opposite
          timesSign
          one
          mult
          absVal
          times *)

theorem x0 :
  "!! (x :: Z) . x = (times x one)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory T0
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T113
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end