theory week08B_demo
imports "~~/src/HOL/Hoare/HeapSyntax"
begin

primrec
  fac :: "nat \<Rightarrow> nat"
where
  "fac 0 = 1"
| "fac (Suc n) = (Suc n) * fac n"

lemma "VARS B { True } B := x { B = x }"
  apply vcg
  done

lemma
  " VARS (x::nat) y r
    {True}
    IF x>y THEN r:=x ELSE r:=y FI
    {r \<ge> x \<and> r \<ge>y \<and> (r=x \<or> r=y)}"
  apply vcg
  apply simp
  done

lemma
  "VARS (A::int) B
   { A = 0 \<and> B = 0 }
    WHILE A \<noteq> a
    INV { B = A * b } DO
      B := B + b;
      A := A + 1
    OD
    {B = a * b }"
  apply vcg
    apply simp
   apply clarsimp
   apply (simp add: semiring_normalization_rules(2))
  apply simp
  done

lemma factorial_sound:
  "VARS A B
  { A = n}
  B := 1;
  WHILE A \<noteq> 0 INV { fac n = B * fac A } DO
    B := B * A;
    A := A - 1
  OD
  { B = fac n }"
  apply (vcg; clarsimp)
  apply (case_tac A; simp)
  done

-- ----------------------------------------------------------------------------------

-- "Arrays"

(* define a program that looks for a key in an array *)
(*think about the loop invariant *)

lemma
 "VARS I L
 { True }
  I := 0;
  WHILE I < length L \<and> L!I \<noteq> key
  INV { I \<le> length L \<and> (\<forall>j < I. L!j \<noteq> key)} DO
    I := I+1
  OD
  { (I < length L \<longrightarrow> L!I = key) \<and> (I=length L \<longrightarrow> key \<notin> set L)}"
  apply (vcg)
    apply clarsimp
   apply clarsimp
   apply (case_tac "I = j"; simp?)
   apply (metis linorder_neqE_nat not_less_eq)
  apply clarsimp
  apply (clarsimp simp: in_set_conv_nth)
  apply auto
  done

-- "Pointers"
thm List_def Path.simps

(* "List nxt p Ps" represents a linked list, starting
    at pointer p, with 'nxt' being the function to find
    the next pointer, and Ps the list of all the content
    of the linked list *)

(* define a function that takes X, p and nxt function,
   assuming that X is in the set of the linked list,
   then it returns the pointer to that element *)

(* think about its loop invariant *)

lemma "VARS nxt p
  { List nxt p Ps \<and> X \<in> set Ps }
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X  INV { \<exists>xs. Path nxt p xs (Ref X) }
  DO p := p^.nxt OD
  { p = Ref X }"
  apply vcg
    apply (clarsimp simp: List_def)
    apply (clarsimp simp: in_set_conv_decomp)
    apply auto
  done

(* define a function that "splices" 2 disjoint linked lists together *)

(* think about its loop invariant *)

lemma "VARS tl p q pp qq
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and> size Qs \<le> size Ps}
  pp := p;
  WHILE q \<noteq> Null
  INV { TODO }
  DO qq := q^.tl; q^.tl := pp^.tl; pp^.tl := q; pp := q^.tl; q := qq OD
  {List tl p (splice Ps Qs)}"
  sorry

end


section \<open>Isomorphisms of Free Groups\<close>

theory "Isomorphisms"
imports
   UnitGroup
   "HOL-Algebra.IntRing"
   FreeGroups
   C2
   "HOL-Cardinals.Cardinal_Order_Relation"
begin

subsection \<open>The Free Group over the empty set\<close>

text \<open>The Free Group over an empty set of generators is isomorphic to the trivial
group.\<close>

lemma free_group_over_empty_set: "\<exists>h. h \<in> iso \<F>\<^bsub>{}\<^esub> unit_group"
proof(rule group.unit_group_unique)
  show "group \<F>\<^bsub>{}\<^esub>" by (rule free_group_is_group)
next
  have "carrier \<F>\<^bsub>{}::'a set\<^esub> = {[]}"
    by (auto simp add:free_group_def)
  thus "card (carrier \<F>\<^bsub>{}::'a set\<^esub>) = 1"
    by simp
qed

subsection \<open>The Free Group over one generator\<close>

text \<open>The Free Group over one generator is isomorphic to the free abelian group
over one element, also known as the integers.\<close>

abbreviation "int_group"
  where "int_group \<equiv> \<lparr> carrier = carrier \<Z>, monoid.mult = (+), one = 0::int \<rparr>"

lemma replicate_set_eq[simp]: "\<forall>x \<in> set xs. x = y \<Longrightarrow> xs = replicate (length xs) y"
  by(induct xs)auto

lemma int_group_gen_by_one: "\<langle>{1}\<rangle>\<^bsub>int_group\<^esub> = carrier int_group"
proof
  show "\<langle>{1}\<rangle>\<^bsub>int_group\<^esub> \<subseteq> carrier int_group"
    by auto
  show "carrier int_group \<subseteq> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
  proof
    interpret int: group int_group
      using int.a_group by auto
    fix x
    have plus1: "1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (auto intro:gen_span.gen_gens)
    hence "inv\<^bsub>int_group\<^esub> 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (auto intro:gen_span.gen_inv)
    moreover
    have "-1 = inv\<^bsub>int_group\<^esub> 1"
      by (rule sym, rule int.inv_equality) simp_all
    ultimately
    have minus1: "-1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (simp)

    show "x \<in> \<langle>{1::int}\<rangle>\<^bsub>int_group\<^esub>" (*
    It does not work directly, unfortunately:
    apply(induct x rule:int_induct[of _ "0::int"])
    apply (auto simp add: int_arith_rules intro:gen_span.intros[of int_group])
    *)
    proof(induct x rule:int_induct[of _ "0::int"])
    case base
      have "\<one>\<^bsub>int_group\<^esub> \<in> \<langle>{1::int}\<rangle>\<^bsub>int_group\<^esub>"
        by (rule gen_span.gen_one)
      thus"0 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by simp
    next
    case (step1 i)
      from \<open>i \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>\<close> and plus1
      have "i \<otimes>\<^bsub>int_group\<^esub> 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by (rule gen_span.gen_mult)
      thus "i + 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>" by simp
    next
    case (step2 i)
      from \<open>i \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>\<close> and minus1
      have "i \<otimes>\<^bsub>int_group\<^esub> -1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by (rule gen_span.gen_mult)
      thus "i - 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by simp
    qed
  qed
qed

lemma free_group_over_one_gen: "\<exists>h. h \<in> iso \<F>\<^bsub>{()}\<^esub> int_group"
proof-
  interpret int: group int_group
    using int.a_group by auto
  define f :: "unit \<Rightarrow> int" where "f x = 1" for x
  have "f \<in> {()} \<rightarrow> carrier int_group"
    by auto
  hence "int.lift f \<in> hom \<F>\<^bsub>{()}\<^esub> int_group"
    by (rule int.lift_is_hom)
  then
  interpret hom: group_hom "\<F>\<^bsub>{()}\<^esub>" int_group "int.lift f"
    unfolding group_hom_def group_hom_axioms_def
    using int.a_group by(auto intro: free_group_is_group)

  { (* This shows injectiveness of the given map *)
    fix x
    assume "x \<in> carrier \<F>\<^bsub>{()}\<^esub>"
    hence "canceled x" by (auto simp add:free_group_def)
    assume "int.lift f x = (0::int)"
    have "x = []"
    proof(rule ccontr)
      assume "x \<noteq> []"
      then obtain a and xs where "x = a # xs" by (cases x, auto)
      hence "length (takeWhile (\<lambda>y. y = a) x) > 0" by auto
      then obtain i where i: "length (takeWhile (\<lambda>y. y = a) x) = Suc i"
        by (cases "length (takeWhile (\<lambda>y. y = a) x)", auto)
      have "Suc i \<ge> length x"
      proof(rule ccontr)
        assume "\<not> length x \<le> Suc i"
        hence "length (takeWhile (\<lambda>y. y = a) x) < length x" using i by simp
        hence "\<not> (\<lambda>y. y = a) (x ! length (takeWhile (\<lambda>y. y = a) x))"
          by (rule nth_length_takeWhile)
        hence "\<not> (\<lambda>y. y = a) (x ! Suc i)" using i by simp
        hence "fst (x ! Suc i) \<noteq> fst a" by (cases "x ! Suc i", cases "a", auto)
        moreover
        {
          have "takeWhile (\<lambda>y. y = a) x ! i = x ! i"
            using i by (auto intro: takeWhile_nth)
          moreover
          have "(takeWhile (\<lambda>y. y = a) x) ! i \<in> set (takeWhile (\<lambda>y. y = a) x)"
            using i by auto
          ultimately
          have "(\<lambda>y. y = a) (x ! i)"
            by (auto dest:set_takeWhileD)
        }
        hence "fst (x ! i) = fst a" by auto
        moreover
        have "snd (x ! i) = snd (x ! Suc i)" by simp
        ultimately
        have "canceling (x ! i) (x ! Suc i)" unfolding canceling_def by auto
        hence "cancels_to_1_at i x (cancel_at i x)"
          using \<open>\<not> length x \<le> Suc i\<close> unfolding cancels_to_1_at_def
          by (auto simp add:length_takeWhile_le)
        hence "cancels_to_1 x (cancel_at i x)" unfolding cancels_to_1_def by auto
        hence "\<not> canceled x" unfolding canceled_def by auto
        thus False using \<open>canceled x\<close> by contradiction
      qed
      hence "length (takeWhile (\<lambda>y. y = a) x) = length x"
        using i[THEN sym] by (auto dest:le_antisym simp add:length_takeWhile_le)
      hence "takeWhile (\<lambda>y. y = a) x = x"
        by (subst takeWhile_eq_take, simp)
      moreover
      have "\<forall>y \<in> set (takeWhile (\<lambda>y. y = a) x). y = a"
        by (auto dest: set_takeWhileD)
      ultimately
      have "\<forall>y \<in> set x. y = a" by auto
      hence "x = replicate (length x) a" by simp
      hence "int.lift f x = int.lift f (replicate (length x) a)" by simp
      also have "... = pow int_group (int.lift_gi f a) (length x)"
        apply (induct x)
        using local.int.nat_pow_Suc local.int.nat_pow_0
         apply (auto simp: int.lift_def [simplified])
        done
      also have "... = (int.lift_gi f a) * int (length x)"
        apply (induct x)
        using local.int.nat_pow_Suc local.int.nat_pow_0
        by (auto simp: int_distrib)
      finally have "\<dots> = 0" using \<open>int.lift f x = 0\<close> by simp
      hence "nat (abs (group.lift_gi int_group f a * int (length x))) = 0" by simp
      hence "nat (abs (group.lift_gi int_group f a)) * length x = 0" by simp
      hence "nat (abs (group.lift_gi int_group f a)) = 0"
        using \<open>x \<noteq> []\<close> by auto
      moreover
      have "inv\<^bsub>int_group\<^esub> 1 = -1"
        using int.inv_equality by auto
      hence "abs (group.lift_gi int_group f a) = 1"
      using int.is_group
        by(auto simp add: group.lift_gi_def f_def)
      ultimately
      show False by simp
    qed
  }
  hence "\<forall>x\<in>carrier \<F>\<^bsub>{()}\<^esub>. int.lift f x = \<one>\<^bsub>int_group\<^esub> \<longrightarrow> x = \<one>\<^bsub>\<F>\<^bsub>{()}\<^esub>\<^esub>"
    by (auto simp add:free_group_def)
  moreover
  {
    have "carrier \<F>\<^bsub>{()}\<^esub> = \<langle>insert`{()}\<rangle>\<^bsub>\<F>\<^bsub>{()}\<^esub>\<^esub>"
      by (rule gens_span_free_group[THEN sym])
    moreover
    have "carrier int_group = \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (rule int_group_gen_by_one[THEN sym])
    moreover
    have "int.lift f ` insert ` {()} = {1}"
      by (auto simp add: int.lift_def [simplified] insert_def f_def int.lift_gi_def [simplified])
    moreover
    have  "int.lift f ` \<langle>insert`{()}\<rangle>\<^bsub>\<F>\<^bsub>{()}\<^esub>\<^esub> = \<langle>int.lift f ` (insert `{()})\<rangle>\<^bsub>int_group\<^esub>"
      by (rule hom.hom_span, auto intro:insert_closed)
    ultimately
    have "int.lift f ` carrier \<F>\<^bsub>{()}\<^esub> = carrier int_group"
      by simp
  }
  ultimately
  have "int.lift f \<in> iso \<F>\<^bsub>{()}\<^esub> int_group"
    using \<open>int.lift f \<in> hom \<F>\<^bsub>{()}\<^esub> int_group\<close>
    using hom.hom_mult int.is_group
    by (auto intro:group_isoI simp add: free_group_is_group)
  thus ?thesis by auto
qed

subsection \<open>Free Groups over isomorphic sets of generators\<close>

text \<open>Free Groups are isomorphic if their set of generators are isomorphic.\<close>

definition lift_generator_function :: "('a \<Rightarrow> 'b) \<Rightarrow> (bool \<times> 'a) list \<Rightarrow> (bool \<times> 'b) list"
where "lift_generator_function f = map (map_prod id f)"

theorem isomorphic_free_groups:
  assumes "bij_betw f gens1 gens2"
  shows "lift_generator_function f \<in> iso \<F>\<^bsub>gens1\<^esub> \<F>\<^bsub>gens2\<^esub>"
unfolding lift_generator_function_def
proof(rule group_isoI)
  show "\<forall>x\<in>carrier \<F>\<^bsub>gens1\<^esub>.
       map (map_prod id f) x = \<one>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> \<longrightarrow> x = \<one>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub>"
    by(auto simp add:free_group_def)
next
  from \<open>bij_betw f gens1 gens2\<close> have "inj_on f gens1" by (auto simp:bij_betw_def)
  show "map (map_prod id f) ` carrier \<F>\<^bsub>gens1\<^esub> = carrier \<F>\<^bsub>gens2\<^esub>"
  proof(rule Set.set_eqI,rule iffI)
    from \<open>bij_betw f gens1 gens2\<close> have "f ` gens1 = gens2" by (auto simp:bij_betw_def)
    fix x :: "(bool \<times> 'b) list"
    assume "x \<in> image (map (map_prod id f)) (carrier \<F>\<^bsub>gens1\<^esub>)"
    then obtain y :: "(bool \<times> 'a) list" where "x = map (map_prod id f) y"
                    and "y \<in> carrier \<F>\<^bsub>gens1\<^esub>" by auto
    from \<open>y \<in> carrier \<F>\<^bsub>gens1\<^esub>\<close>
    have "canceled y" and "y \<in> lists(UNIV\<times>gens1)" by (auto simp add:free_group_def)

    from \<open>y \<in> lists (UNIV\<times>gens1)\<close>
      and \<open>x = map (map_prod id f) y\<close>
      and \<open>image f gens1 = gens2\<close>
    have "x \<in> lists (UNIV\<times>gens2)"
      by (auto iff:lists_eq_set)
    moreover

    from \<open>x = map (map_prod id f) y\<close>
     and \<open>y \<in> lists (UNIV\<times>gens1)\<close>
     and \<open>canceled y\<close>
     and \<open>inj_on f gens1\<close>
    have "canceled x"
      by (auto intro!:rename_gens_canceled subset_inj_on[OF \<open>inj_on f gens1\<close>] iff:lists_eq_set)
    ultimately
    show "x \<in> carrier \<F>\<^bsub>gens2\<^esub>" by (simp add:free_group_def)
  next
    fix x
    assume "x \<in> carrier \<F>\<^bsub>gens2\<^esub>"
    hence "canceled x" and "x \<in> lists (UNIV\<times>gens2)"
      unfolding free_group_def by auto
    define y where "y = map (map_prod id (the_inv_into gens1 f)) x"
    have "map (map_prod id f) y =
          map (map_prod id f) (map (map_prod id (the_inv_into gens1 f)) x)"
      by (simp add:y_def)
    also have "\<dots> = map (map_prod id f \<circ> map_prod id (the_inv_into gens1 f)) x"
      by simp
    also have "\<dots> = map (map_prod id (f \<circ> the_inv_into gens1 f)) x"
      by auto
    also have "\<dots> = map id x"
    proof(rule map_ext, rule impI)
      fix xa :: "bool \<times> 'b"
      assume "xa \<in> set x"
      from \<open>x \<in> lists (UNIV\<times>gens2)\<close>
      have "set (map snd x) \<subseteq> gens2"  by auto
      hence "snd ` set x \<subseteq> gens2" by (simp add: set_map)
      with \<open>xa \<in> set x\<close> have "snd xa \<in> gens2" by auto
      with \<open>bij_betw f gens1 gens2\<close> have "snd xa \<in> f`gens1"
        by (auto simp add: bij_betw_def)

      have "map_prod id (f \<circ> the_inv_into gens1 f) xa
            = map_prod id (f \<circ> the_inv_into gens1 f) (fst xa, snd xa)" by simp
      also have "\<dots> = (fst xa, f (the_inv_into gens1 f (snd xa)))"
        by (auto simp del:prod.collapse)
      also
      from \<open>snd xa \<in> image f gens1\<close> and \<open>inj_on f gens1\<close>
      have "\<dots> = (fst xa, snd xa)"
        by (auto elim:f_the_inv_into_f simp del:prod.collapse)
      also have "\<dots> = id xa" by simp
      finally show "map_prod id (f \<circ> the_inv_into gens1 f) xa = id xa".
    qed
    also have "\<dots> = x" unfolding id_def by auto
    finally have "map (map_prod id f) y = x".
    moreover
    {
      from \<open>bij_betw f gens1 gens2\<close>
      have "bij_betw (the_inv_into gens1 f) gens2 gens1" by (rule bij_betw_the_inv_into)
      hence "inj_on (the_inv_into gens1 f) gens2" by (rule bij_betw_imp_inj_on)

      with \<open>canceled x\<close>
       and \<open>x \<in> lists (UNIV\<times>gens2)\<close>
      have "canceled y"
        by (auto intro!:rename_gens_canceled[OF subset_inj_on] simp add:y_def)
      moreover
      {
        from \<open>bij_betw (the_inv_into gens1 f) gens2 gens1\<close>
         and \<open>x\<in>lists(UNIV\<times>gens2)\<close>
        have "y \<in> lists(UNIV\<times>gens1)"
          unfolding y_def and bij_betw_def
          by (auto iff:lists_eq_set dest!:subsetD)
      }
      ultimately
      have "y \<in> carrier \<F>\<^bsub>gens1\<^esub>" by (simp add:free_group_def)
    }
    ultimately
    show "x \<in> map (map_prod id f) ` carrier \<F>\<^bsub>gens1\<^esub>" by auto
  qed
next
  from \<open>bij_betw f gens1 gens2\<close> have "inj_on f gens1" by (auto simp:bij_betw_def)
  {
  fix x
  assume "x \<in> carrier \<F>\<^bsub>gens1\<^esub>"
  fix y
  assume "y \<in> carrier \<F>\<^bsub>gens1\<^esub>"

  from \<open>x \<in> carrier \<F>\<^bsub>gens1\<^esub>\<close> and \<open>y \<in> carrier \<F>\<^bsub>gens1\<^esub>\<close>
  have "x \<in> lists(UNIV\<times>gens1)" and "y \<in> lists(UNIV\<times>gens1)"
    by (auto simp add:occuring_gens_in_element)
(*  hence "occuring_generators (x@y) \<subseteq> gens1"
    by(auto simp add:occuring_generators_def)
  with `inj_on f gens1` have "inj_on f (occuring_generators (x@y))"
    by (rule subset_inj_on) *)

  have "map (map_prod id f) (x \<otimes>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub> y)
       = map (map_prod id f) (normalize (x@y))" by (simp add:free_group_def)
  also (* from `inj_on f (occuring_generators (x@y))` *)
       from \<open>x \<in> lists(UNIV\<times>gens1)\<close> and \<open>y \<in> lists(UNIV\<times>gens1)\<close>
        and \<open>inj_on f gens1\<close>
       have "\<dots> = normalize (map (map_prod id f) (x@y))"
         by -(rule rename_gens_normalize[THEN sym],
              auto intro!: subset_inj_on[OF \<open>inj_on f gens1\<close>] iff:lists_eq_set)
  also have "\<dots> = normalize (map (map_prod id f) x @ map (map_prod id f) y)"
       by (auto)
  also have "\<dots> = map (map_prod id f) x \<otimes>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> map (map_prod id f) y"
       by (simp add:free_group_def)
  finally have "map (map_prod id f) (x \<otimes>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub> y) =
                map (map_prod id f) x \<otimes>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> map (map_prod id f) y".
  }
  thus "\<forall>x\<in>carrier \<F>\<^bsub>gens1\<^esub>.
       \<forall>y\<in>carrier \<F>\<^bsub>gens1\<^esub>.
          map (map_prod id f) (x \<otimes>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub> y) =
          map (map_prod id f) x \<otimes>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> map (map_prod id f) y"
   by auto
qed (auto intro: free_group_is_group)

subsection \<open>Bases of isomorphic free groups\<close>

text \<open>
Isomorphic free groups have bases of same cardinality. The proof is very different
for infinite bases and for finite bases.

The proof for the finite case uses the set of of homomorphisms from the free
group to the group with two elements, as suggested by Christian Sievers. The
definition of @{term hom} is not suitable for proofs about the cardinality of that
set, as its definition does not require extensionality. This is amended by the
following definition:
\<close>

definition homr
  where "homr G H = {h. h \<in> hom G H \<and> h \<in> extensional (carrier G)}"

lemma (in group_hom) restrict_hom[intro!]:
  shows "restrict h (carrier G) \<in> homr G H"
  unfolding homr_def and hom_def
  by (auto)

lemma hom_F_C2_Powerset:
  "\<exists> f. bij_betw f (Pow X) (homr (\<F>\<^bsub>X\<^esub>) C2)"
proof
  interpret F: group "\<F>\<^bsub>X\<^esub>" by (rule free_group_is_group)
  interpret C2: group C2 by (rule C2_is_group)
  let ?f = "\<lambda>S . restrict (C2.lift (\<lambda>x. x \<in> S)) (carrier \<F>\<^bsub>X\<^esub>)"
  let ?f' = "\<lambda>h . X \<inter> Collect(h \<circ> insert)"
  show "bij_betw ?f (Pow X) (homr (\<F>\<^bsub>X\<^esub>) C2)"
  proof(induct rule: bij_betwI[of ?f _ _ ?f'])
  case 1 show ?case
    proof
      fix S assume "S \<in> Pow X"
      interpret h: group_hom "\<F>\<^bsub>X\<^esub>" C2 "C2.lift (\<lambda>x. x \<in> S)"
        by unfold_locales (auto intro: C2.lift_is_hom)
      show "?f S \<in> homr \<F>\<^bsub>X\<^esub> C2"
        by (rule h.restrict_hom)
     qed
  next
  case 2 show ?case by auto next
  case (3 S) show ?case
    proof (induct rule: Set.set_eqI)
      case (1 x) show ?case
      proof(cases "x \<in> X")
      case True thus ?thesis using insert_closed[of x X]
         by (auto simp add:insert_def C2.lift_def C2.lift_gi_def)
      next case False thus ?thesis using 3 by auto
    qed
  qed
  next
  case (4 h)
    hence hom: "h \<in> hom \<F>\<^bsub>X\<^esub> C2"
      and extn: "h \<in> extensional (carrier \<F>\<^bsub>X\<^esub>)"
      unfolding homr_def by auto
    have "\<forall>x \<in> carrier \<F>\<^bsub>X\<^esub> . h x = group.lift C2 (\<lambda>z. z \<in> X & (h \<circ> FreeGroups.insert) z) x"
     by (rule C2.lift_is_unique[OF C2_is_group _ hom, of "(\<lambda>z. z \<in> X & (h \<circ> FreeGroups.insert) z)"],
             auto)
    thus ?case
    by -(rule extensionalityI[OF restrict_extensional extn], auto)
  qed
qed

lemma group_iso_betw_hom:
  assumes "group G1" and "group G2"
      and iso: "i \<in> iso G1 G2"
  shows   "\<exists> f . bij_betw f (homr G2 H) (homr G1 H)"
proof-
  interpret G2: group G2 by (rule \<open>group G2\<close>)
  let ?i' = "restrict (inv_into (carrier G1) i) (carrier G2)"
  have "inv_into (carrier G1) i \<in> iso G2 G1"
    by (simp add: \<open>group G1\<close> group.iso_set_sym iso)
  hence iso': "?i' \<in> iso G2 G1"
    by (auto simp add:Group.iso_def hom_def G2.m_closed)
  show ?thesis
  proof(rule, induct rule: bij_betwI[of "(\<lambda>h. compose (carrier G1) h i)" _ _ "(\<lambda>h. compose (carrier G2) h ?i')"])
  case 1
    show ?case
    proof
      fix h assume "h \<in> homr G2 H"
      hence "compose (carrier G1) h i \<in> hom G1 H"
        using iso
        by (auto intro: group.hom_compose[OF \<open>group G1\<close>, of _ G2] simp add:Group.iso_def homr_def)
      thus "compose (carrier G1) h i \<in> homr G1 H"
        unfolding homr_def by simp
     qed
  next
  case 2
    show ?case
    proof
      fix h assume "h \<in> homr G1 H"
      hence "compose (carrier G2) h ?i' \<in> hom G2 H"
        using iso'
        by (auto intro: group.hom_compose[OF \<open>group G2\<close>, of _ G1] simp add:Group.iso_def homr_def)
      thus "compose (carrier G2) h ?i' \<in> homr G2 H"
        unfolding homr_def by simp
     qed
  next
  case (3 x)
    hence "compose (carrier G2) (compose (carrier G1) x i) ?i'
          = compose (carrier G2) x (compose (carrier G2) i ?i')"
      using iso iso'
      by (auto intro: compose_assoc[THEN sym]   simp add:Group.iso_def hom_def homr_def)
    also have "\<dots> = compose (carrier G2) x (\<lambda>y\<in>carrier G2. y)"
      using iso
      by (subst compose_id_inv_into, auto simp add:Group.iso_def hom_def bij_betw_def)
    also have "\<dots> = x"
      using 3
      by (auto intro:compose_Id simp add:homr_def)
    finally
    show ?case .
  next
  case (4 y)
    hence "compose (carrier G1) (compose (carrier G2) y ?i') i
          = compose (carrier G1) y (compose (carrier G1) ?i' i)"
      using iso iso'
      by (auto intro: compose_assoc[THEN sym] simp add:Group.iso_def hom_def homr_def)
    also have "\<dots> = compose (carrier G1) y (\<lambda>x\<in>carrier G1. x)"
      using iso
      by (subst compose_inv_into_id, auto simp add:Group.iso_def hom_def bij_betw_def)
    also have "\<dots> = y"
      using 4
      by (auto intro:compose_Id simp add:homr_def)
    finally
    show ?case .
  qed
qed

lemma isomorphic_free_groups_bases_finite:
  assumes iso: "i \<in> iso \<F>\<^bsub>X\<^esub> \<F>\<^bsub>Y\<^esub>"
      and finite: "finite X"
  shows "\<exists>f. bij_betw f X Y"
proof-
  obtain f
    where "bij_betw f (homr \<F>\<^bsub>Y\<^esub> C2) (homr \<F>\<^bsub>X\<^esub> C2)"
    using group_iso_betw_hom[OF free_group_is_group free_group_is_group iso]
    by auto
  moreover
  obtain g'
    where "bij_betw g' (Pow X) (homr (\<F>\<^bsub>X\<^esub>) C2)"
    using hom_F_C2_Powerset by auto
  then obtain g
    where "bij_betw g (homr (\<F>\<^bsub>X\<^esub>) C2) (Pow X)"
    by (auto intro: bij_betw_inv_into)
  moreover
  obtain h
    where "bij_betw h (Pow Y) (homr (\<F>\<^bsub>Y\<^esub>) C2)"
    using hom_F_C2_Powerset by auto
  ultimately
  have "bij_betw (g \<circ> f \<circ> h) (Pow Y) (Pow X)"
    by (auto intro: bij_betw_trans)
  hence eq_card: "card (Pow Y) = card (Pow X)"
    by (rule bij_betw_same_card)
  with finite
  have "finite (Pow Y)"
   by -(rule card_ge_0_finite, auto simp add:card_Pow)
  hence finite': "finite Y" by simp

  with eq_card finite
  have "card X = card Y"
   by (auto simp add:card_Pow)
  with finite finite'
  show ?thesis
   by (rule finite_same_card_bij)
qed

text \<open>
The proof for the infinite case is trivial once the fact that the free group
over an infinite set has the same cardinality is established.
\<close>

lemma free_group_card_infinite:
  assumes "\<not> finite X"
  shows "|X| =o |carrier \<F>\<^bsub>X\<^esub>|"
proof-
  have "inj_on insert X"
    by (rule inj_onI) (auto simp add: insert_def)
  moreover have "insert ` X \<subseteq> carrier \<F>\<^bsub>X\<^esub>"
    by (auto intro: insert_closed)
  ultimately have "\<exists>f. inj_on f X \<and> f ` X \<subseteq> carrier \<F>\<^bsub>X\<^esub>"
    by auto
  then have "|X| \<le>o |carrier \<F>\<^bsub>X\<^esub>|"
    by (simp add: card_of_ordLeq)
  moreover
  have "|carrier \<F>\<^bsub>X\<^esub>| \<le>o |lists ((UNIV::bool set)\<times>X)|"
    by (auto intro!:card_of_mono1 simp add:free_group_def)
  moreover
  have "|lists ((UNIV::bool set)\<times>X)| =o |(UNIV::bool set)\<times>X|"
    using \<open>\<not> finite X\<close>
    by (auto intro:card_of_lists_infinite dest!:finite_cartesian_productD2)
  moreover
  have  "|(UNIV::bool set)\<times>X| =o |X|"
    using \<open>\<not> finite X\<close>
    by (auto intro: card_of_Times_infinite[OF _ _ ordLess_imp_ordLeq[OF finite_ordLess_infinite2], THEN conjunct2])
  ultimately
  show "|X| =o |carrier \<F>\<^bsub>X\<^esub>|"
    by (subst ordIso_iff_ordLeq, auto intro: ord_trans)
qed

theorem isomorphic_free_groups_bases:
  assumes iso: "i \<in> iso \<F>\<^bsub>X\<^esub> \<F>\<^bsub>Y\<^esub>"
  shows "\<exists>f. bij_betw f X Y"
proof(cases "finite X")
case True
  thus ?thesis using iso by -(rule isomorphic_free_groups_bases_finite)
next
case False show ?thesis
  proof(cases "finite Y")
  case True
  from iso obtain i' where "i' \<in> iso \<F>\<^bsub>Y\<^esub> \<F>\<^bsub>X\<^esub>"
    using free_group_is_group group.iso_set_sym by blast
  with \<open>finite Y\<close>
  have "\<exists>f. bij_betw f Y X" by -(rule isomorphic_free_groups_bases_finite)
  thus "\<exists>f. bij_betw f X Y" by (auto intro: bij_betw_the_inv_into) next
case False
  from \<open>\<not> finite X\<close> have "|X| =o |carrier \<F>\<^bsub>X\<^esub>|"
    by (rule free_group_card_infinite)
  moreover
  from \<open>\<not> finite Y\<close> have "|Y| =o |carrier \<F>\<^bsub>Y\<^esub>|"
    by (rule free_group_card_infinite)
  moreover
  from iso have "|carrier \<F>\<^bsub>X\<^esub>| =o |carrier \<F>\<^bsub>Y\<^esub>|"
    by (auto simp add:Group.iso_def iff:card_of_ordIso[THEN sym])
  ultimately
  have "|X| =o |Y|" by (auto intro: ordIso_equivalence)
  thus ?thesis by (subst card_of_ordIso)
qed
qed

end


(*
  File:   Master_Theorem.thy
  Author: Manuel Eberl <manuel@pruvisto.org>

  The Master theorem in a generalised form as derived from the Akra-Bazzi theorem.
*)
section \<open>The Master theorem\<close>
theory Master_Theorem
imports
  "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
  Akra_Bazzi_Library
  Akra_Bazzi
begin

lemma fundamental_theorem_of_calculus_real:
  "a \<le> b \<Longrightarrow> \<forall>x\<in>{a..b}. (f has_real_derivative f' x) (at x within {a..b}) \<Longrightarrow>
      (f' has_integral (f b - f a)) {a..b}"
  by (intro fundamental_theorem_of_calculus ballI)
     (simp_all add: has_real_derivative_iff_has_vector_derivative[symmetric])

lemma integral_powr:
  "y \<noteq> -1 \<Longrightarrow> a \<le> b \<Longrightarrow> a > 0 \<Longrightarrow> integral {a..b} (\<lambda>x. x powr y :: real) =
     inverse (y + 1) * (b powr (y + 1) - a powr (y + 1))"
  by (subst right_diff_distrib, intro integral_unique fundamental_theorem_of_calculus_real)
     (auto intro!: derivative_eq_intros)

lemma integral_ln_powr_over_x:
  "y \<noteq> -1 \<Longrightarrow> a \<le> b \<Longrightarrow> a > 1 \<Longrightarrow> integral {a..b} (\<lambda>x. ln x powr y / x :: real) =
     inverse (y + 1) * (ln b powr (y + 1) - ln a powr (y + 1))"
  by (subst right_diff_distrib, intro integral_unique fundamental_theorem_of_calculus_real)
     (auto intro!: derivative_eq_intros)

lemma integral_one_over_x_ln_x:
  "a \<le> b \<Longrightarrow> a > 1 \<Longrightarrow> integral {a..b} (\<lambda>x. inverse (x * ln x) :: real) = ln (ln b) - ln (ln a)"
  by (intro integral_unique fundamental_theorem_of_calculus_real)
     (auto intro!: derivative_eq_intros simp: field_simps)

lemma akra_bazzi_integral_kurzweil_henstock:
  "akra_bazzi_integral (\<lambda>f a b. f integrable_on {a..b}) (\<lambda>f a b. integral {a..b} f)"
apply unfold_locales
apply (rule integrable_const_ivl)
apply simp
apply (erule integrable_subinterval_real, simp)
apply (blast intro!: integral_le)
apply (rule integral_combine, simp_all) []
done

locale master_theorem_function = akra_bazzi_recursion +
  fixes g :: "nat \<Rightarrow> real"
  assumes f_nonneg_base: "x \<ge> x\<^sub>0 \<Longrightarrow> x < x\<^sub>1 \<Longrightarrow> f x \<ge> 0"
  and     f_rec:         "x \<ge> x\<^sub>1 \<Longrightarrow> f x = g x + (\<Sum>i<k. as!i * f ((ts!i) x))"
  and     g_nonneg:      "x \<ge> x\<^sub>1 \<Longrightarrow> g x \<ge> 0"
  and     ex_pos_a:      "\<exists>a\<in>set as. a > 0"
begin

interpretation akra_bazzi_integral "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f"
  by (rule akra_bazzi_integral_kurzweil_henstock)

sublocale akra_bazzi_function x\<^sub>0 x\<^sub>1 k as bs ts f "\<lambda>f a b. f integrable_on {a..b}"
            "\<lambda>f a b. integral {a..b} f" g
  using f_nonneg_base f_rec g_nonneg ex_pos_a by unfold_locales

context
begin

private lemma g_nonneg': "eventually (\<lambda>x. g x \<ge> 0) at_top"
  using g_nonneg by (force simp: eventually_at_top_linorder)

private lemma g_pos:
  assumes "g \<in> \<Omega>(h)"
  assumes "eventually (\<lambda>x. h x > 0) at_top"
  shows   "eventually (\<lambda>x. g x > 0) at_top"
proof-
  from landau_omega.bigE_nonneg_real[OF assms(1) g_nonneg'] guess c . note c = this
  from assms(2) c(2) show ?thesis
    by eventually_elim (rule less_le_trans[OF mult_pos_pos[OF c(1)]], simp_all)
qed

private lemma f_pos:
  assumes "g \<in> \<Omega>(h)"
  assumes "eventually (\<lambda>x. h x > 0) at_top"
  shows   "eventually (\<lambda>x. f x > 0) at_top"
  using g_pos[OF assms(1,2)] eventually_ge_at_top[of x\<^sub>1]
  by (eventually_elim) (subst f_rec, insert step_ge_x0,
         auto intro!: add_pos_nonneg sum_nonneg mult_nonneg_nonneg[OF a_ge_0] f_nonneg)

lemma bs_lower_bound: "\<exists>C>0. \<forall>b\<in>set bs. C < b"
proof (intro exI conjI ballI)
  from b_pos show A: "Min (set bs) / 2 > 0" by auto
  fix b assume b: "b \<in> set bs"
  from A have "Min (set bs) / 2 < Min (set bs)" by simp
  also from b have "... \<le> b" by simp
  finally show "Min (set bs) / 2 < b" .
qed

private lemma powr_growth2:
  "\<exists>C c2. 0 < c2 \<and> C < Min (set bs) \<and>
      eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c2 * x powr p' \<ge> u powr p') at_top"
proof (intro exI conjI allI ballI)
  define C where "C = Min (set bs) / 2"
  from b_bounds bs_nonempty have C_pos: "C > 0" unfolding C_def by auto
  thus "C < Min (set bs)" unfolding C_def by simp
  show "max (C powr p') 1 > 0" by simp
  show "eventually (\<lambda>x. \<forall>u\<in>{C * x..x}.
    max ((Min (set bs)/2) powr p') 1 * x powr p' \<ge> u powr p') at_top"
    using eventually_gt_at_top[of "0::real"] apply eventually_elim
  proof clarify
    fix x u assume x: "x > 0" and "u \<in> {C*x..x}"
    hence u: "u \<ge> C*x" "u \<le> x" unfolding C_def by  simp_all
    from u have "u powr p' \<le> max ((C*x) powr p') (x powr p')" using C_pos x
      by (intro powr_upper_bound mult_pos_pos) simp_all
    also from u x C_pos have "max ((C*x) powr p') (x powr p') = x powr p' * max (C powr p') 1"
      by (subst max_mult_left) (simp_all add: powr_mult algebra_simps)
    finally show "u powr p' \<le> max ((Min (set bs)/2) powr p') 1 * x powr p'"
      by (simp add: C_def algebra_simps)
  qed
qed

private lemma powr_growth1:
  "\<exists>C c1. 0 < c1 \<and> C < Min (set bs) \<and>
      eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c1 * x powr p' \<le> u powr p') at_top"
proof (intro exI conjI allI ballI)
  define C where "C = Min (set bs) / 2"
  from b_bounds bs_nonempty have C_pos: "C > 0" unfolding C_def by auto
  thus "C < Min (set bs)" unfolding C_def by simp
  from C_pos show "min (C powr p') 1 > 0" by simp
  show "eventually (\<lambda>x. \<forall>u\<in>{C * x..x}.
          min ((Min (set bs)/2) powr p') 1 * x powr p' \<le> u powr p') at_top"
    using eventually_gt_at_top[of "0::real"] apply eventually_elim
  proof clarify
    fix x u assume x: "x > 0" and "u \<in> {C*x..x}"
    hence u: "u \<ge> C*x" "u \<le> x" unfolding C_def by  simp_all
    from u x C_pos have "x powr p' * min (C powr p') 1 = min ((C*x) powr p') (x powr p')"
      by (subst min_mult_left) (simp_all add: powr_mult algebra_simps)
    also from u have "u powr p' \<ge> min ((C*x) powr p') (x powr p')" using C_pos x
      by (intro powr_lower_bound mult_pos_pos) simp_all
    finally show "u powr p' \<ge> min ((Min (set bs)/2) powr p') 1 * x powr p'"
      by (simp add: C_def algebra_simps)
  qed
qed

private lemma powr_ln_powr_lower_bound:
  "a > 1 \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow>
     min (a powr p) (b powr p) * min (ln a powr p') (ln b powr p') \<le> x powr p * ln x powr p'"
  by (intro mult_mono powr_lower_bound) (auto intro: min.coboundedI1)

private lemma powr_ln_powr_upper_bound:
  "a > 1 \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow>
     max (a powr p) (b powr p) * max (ln a powr p') (ln b powr p') \<ge> x powr p * ln x powr p'"
  by (intro mult_mono powr_upper_bound) (auto intro: max.coboundedI1)

private lemma powr_ln_powr_upper_bound':
  "eventually (\<lambda>a. \<forall>b>a. \<exists>c. \<forall>x\<in>{a..b}. x powr p * ln x powr p' \<le> c) at_top"
  by (subst eventually_at_top_dense) (force intro: powr_ln_powr_upper_bound)

private lemma powr_upper_bound':
  "eventually (\<lambda>a::real. \<forall>b>a. \<exists>c. \<forall>x\<in>{a..b}. x powr p' \<le> c) at_top"
  by (subst eventually_at_top_dense) (force intro: powr_upper_bound)

lemmas bounds =
  powr_ln_powr_lower_bound powr_ln_powr_upper_bound powr_ln_powr_upper_bound' powr_upper_bound'

private lemma eventually_ln_const:
  assumes "(C::real) > 0"
  shows   "eventually (\<lambda>x. ln (C*x) / ln x > 1/2) at_top"
proof-
  from tendstoD[OF tendsto_ln_over_ln[of C 1], of "1/2"] assms
    have "eventually (\<lambda>x. \<bar>ln (C*x) / ln x - 1\<bar> < 1/2) at_top" by (simp add: dist_real_def)
  thus ?thesis by eventually_elim linarith
qed

private lemma powr_ln_powr_growth1: "\<exists>C c1. 0 < c1 \<and> C < Min (set bs) \<and>
  eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c1 * (x powr r * ln x powr r') \<le> u powr r * ln u powr r') at_top"
proof (intro exI conjI)
  let ?C = "Min (set bs) / 2" and ?f = "\<lambda>x. x powr r * ln x powr r'"
  define C where "C = ?C"
  from b_bounds have C_pos: "C > 0" unfolding C_def by simp
  let ?T = "min (C powr r) (1 powr r) * min ((1/2) powr r') (1 powr r')"
  from C_pos show "?T > 0" unfolding min_def by (auto split: if_split)
  from bs_nonempty b_bounds have C_pos: "C > 0" unfolding C_def by simp
  thus "C < Min (set bs)" by (simp add: C_def)

  show "eventually (\<lambda>x. \<forall>u\<in>{C*x..x}. ?T * ?f x \<le> ?f u) at_top"
    using eventually_gt_at_top[of "max 1 (inverse C)"] eventually_ln_const[OF C_pos]
    apply eventually_elim
  proof clarify
    fix x u assume x: "x > max 1 (inverse C)" and u: "u \<in> {C*x..x}"
    hence x': "x > 1" by (simp add: field_simps)
    with C_pos have x_pos: "x > 0" by (simp add: field_simps)
    from x u C_pos have u': "u > 1" by (simp add: field_simps)
    assume A: "ln (C*x) / ln x > 1/2"
    have "min (C powr r) (1 powr r) \<le> (u/x) powr r"
      using x u u' C_pos by (intro powr_lower_bound) (simp_all add: field_simps)
    moreover {
      note A
      also from C_pos x' u u' have "ln (C*x) \<le> ln u" by (subst ln_le_cancel_iff) simp_all
      with x' have "ln (C*x) / ln x \<le> ln u / ln x" by (simp add: field_simps)
      finally have "min ((1/2) powr r') (1 powr r') \<le> (ln u / ln x) powr r'"
        using x u u' C_pos A by (intro powr_lower_bound) simp_all
    }
    ultimately have "?T \<le> (u/x) powr r * (ln u / ln x) powr r'"
      using x_pos by (intro mult_mono) simp_all
    also from x u u' have "... = ?f u / ?f x" by (simp add: powr_divide)
    finally show "?T * ?f x \<le> ?f u" using x' by (simp add: field_simps)
  qed
qed

private lemma powr_ln_powr_growth2: "\<exists>C c1. 0 < c1 \<and> C < Min (set bs) \<and>
  eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c1 * (x powr r * ln x powr r') \<ge> u powr r * ln u powr r') at_top"
proof (intro exI conjI)
  let ?C = "Min (set bs) / 2" and ?f = "\<lambda>x. x powr r * ln x powr r'"
  define C where "C = ?C"
  let ?T = "max (C powr r) (1 powr r) * max ((1/2) powr r') (1 powr r')"
  show "?T > 0" by simp
  from b_bounds bs_nonempty have C_pos: "C > 0" unfolding C_def by simp
  thus "C < Min (set bs)" by (simp add: C_def)

  show "eventually (\<lambda>x. \<forall>u\<in>{C*x..x}. ?T * ?f x \<ge> ?f u) at_top"
    using eventually_gt_at_top[of "max 1 (inverse C)"] eventually_ln_const[OF C_pos]
    apply eventually_elim
  proof clarify
    fix x u assume x: "x > max 1 (inverse C)" and u: "u \<in> {C*x..x}"
    hence x': "x > 1" by (simp add: field_simps)
    with C_pos have x_pos: "x > 0" by (simp add: field_simps)
    from x u C_pos have u': "u > 1" by (simp add: field_simps)
    assume A: "ln (C*x) / ln x > 1/2"
    from x u u' have "?f u / ?f x = (u/x) powr r * (ln u/ln x) powr r'" by (simp add: powr_divide)
    also {
      have "(u/x) powr r \<le> max (C powr r) (1 powr r)"
        using x u u' C_pos by (intro powr_upper_bound) (simp_all add: field_simps)
      moreover {
        note A
        also from C_pos x' u u' have "ln (C*x) \<le> ln u" by (subst ln_le_cancel_iff) simp_all
        with x' have "ln (C*x) / ln x \<le> ln u / ln x" by (simp add: field_simps)
        finally have "(ln u / ln x) powr r' \<le> max ((1/2) powr r') (1 powr r')"
          using x u u' C_pos A by (intro powr_upper_bound) simp_all
      } ultimately have "(u/x) powr r * (ln u / ln x) powr r' \<le> ?T"
        using x_pos by (intro mult_mono) simp_all
    }
    finally show "?T * ?f x \<ge> ?f u" using x' by (simp add: field_simps)
  qed
qed

lemmas growths = powr_growth1 powr_growth2 powr_ln_powr_growth1 powr_ln_powr_growth2

private lemma master_integrable:
  "\<exists>a::real. \<forall>b\<ge>a. (\<lambda>u. u powr r * ln u powr s / u powr t) integrable_on {a..b}"
  "\<exists>a::real. \<forall>b\<ge>a. (\<lambda>u. u powr r / u powr s) integrable_on {a..b}"
  by (rule exI[of _ 2], force intro!: integrable_continuous_real continuous_intros)+

private lemma master_integral:
  fixes a p p' :: real
  assumes p: "p \<noteq> p'" and a: "a > 0"
  obtains c d where "c \<noteq> 0" "p > p' \<longrightarrow> d \<noteq> 0"
    "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p' / u powr (p+1)))) \<in>
             \<Theta>(\<lambda>x::nat. d * x powr p + c * x powr p')"
proof-
  define e where "e = a powr (p' - p)"
  from assms have e: "e \<ge> 0" by (simp add: e_def)
  define c where "c = inverse (p' - p)"
  define d where "d = 1 - inverse (p' - p) * e"
  have "c \<noteq> 0" and "p > p' \<longrightarrow> d \<noteq> 0"
    using e p a unfolding c_def d_def by (auto simp: field_simps)
  thus ?thesis
    apply (rule that) apply (rule bigtheta_real_nat_transfer, rule bigthetaI_cong)
    using eventually_ge_at_top[of a]
  proof eventually_elim
    fix x assume x: "x \<ge> a"
    hence "integral {a..x} (\<lambda>u. u powr p' / u powr (p+1)) =
               integral {a..x} (\<lambda>u. u powr (p' - (p + 1)))"
      by (intro Henstock_Kurzweil_Integration.integral_cong) (simp_all add: powr_diff [symmetric] )
    also have "... = inverse (p' - p) * (x powr (p' - p) - a powr (p' - p))"
      using p x0_less_x1 a x by (simp add: integral_powr)
    also have "x powr p * (1 + ...) = d * x powr p + c * x powr p'"
      using p unfolding c_def d_def by (simp add: algebra_simps powr_diff e_def)
    finally show "x powr p * (1 + integral {a..x} (\<lambda>u. u powr p' / u powr (p+1))) =
                      d * x powr p + c * x powr p'" .
  qed
qed

private lemma master_integral':
  fixes a p p' :: real
  assumes p': "p' \<noteq> 0" and a: "a > 1"
  obtains c d :: real where "p' < 0 \<longrightarrow> c \<noteq> 0" "d \<noteq> 0"
    "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr (p'-1) / u powr (p+1)))) \<in>
       \<Theta>(\<lambda>x::nat. c * x powr p + d * x powr p * ln x powr p')"
proof-
  define e where "e = ln a powr p'"
  from assms have e: "e > 0" by (simp add: e_def)
  define c where "c = 1 - inverse p' * e"
  define d where "d = inverse p'"
  from assms e have "p' < 0 \<longrightarrow> c \<noteq> 0" "d \<noteq> 0" unfolding c_def d_def by (auto simp: field_simps)
  thus ?thesis
    apply (rule that) apply (rule landau_real_nat_transfer, rule bigthetaI_cong)
    using eventually_ge_at_top[of a]
  proof eventually_elim
    fix x :: real assume x: "x \<ge> a"
    have "integral {a..x} (\<lambda>u. u powr p * ln u powr (p' - 1) / u powr (p + 1)) =
          integral {a..x} (\<lambda>u. ln u powr (p' - 1) / u)" using x a x0_less_x1
      by (intro Henstock_Kurzweil_Integration.integral_cong) (simp_all add: powr_add)
    also have "... = inverse p' * (ln x powr p' - ln a powr p')"
      using p' x0_less_x1 a(1) x by (simp add: integral_ln_powr_over_x)
    also have "x powr p * (1 + ...) = c * x powr p + d * x powr p * ln x powr p'"
      using p' by (simp add: algebra_simps c_def d_def e_def)
    finally show "x powr p * (1+integral {a..x} (\<lambda>u. u powr p * ln u powr (p'-1) / u powr (p+1))) =
                  c * x powr p + d * x powr p * ln x powr p'" .
  qed
qed

private lemma master_integral'':
  fixes a p p' :: real
  assumes a: "a > 1"
  shows "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr - 1/u powr (p+1)))) \<in>
           \<Theta>(\<lambda>x::nat. x powr p * ln (ln x))"
proof (rule landau_real_nat_transfer)
  have "(\<lambda>x::real. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr - 1/u powr (p+1)))) \<in>
          \<Theta>(\<lambda>x::real. (1 - ln (ln a)) * x powr p + x powr p * ln (ln x))" (is "?f \<in> _")
    apply (rule bigthetaI_cong) using eventually_ge_at_top[of a]
  proof eventually_elim
    fix x assume x: "x \<ge> a"
    have "integral {a..x} (\<lambda>u. u powr p * ln u powr -1 / u powr (p + 1)) =
          integral {a..x} (\<lambda>u. inverse (u * ln u))" using x a x0_less_x1
      by (intro Henstock_Kurzweil_Integration.integral_cong) (simp_all add: powr_add powr_minus field_simps)
    also have "... = ln (ln x) - ln (ln a)"
      using x0_less_x1 a(1) x by (subst integral_one_over_x_ln_x) simp_all
    also have "x powr p * (1 + ...) = (1 - ln (ln a)) * x powr p + x powr p * ln (ln x)"
      by (simp add: algebra_simps)
    finally show "x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr - 1 / u powr (p+1))) =
                    (1 - ln (ln a)) * x powr p + x powr p * ln (ln x)" .
  qed
  also have "(\<lambda>x. (1 - ln (ln a)) * x powr p + x powr p * ln (ln x)) \<in>
                \<Theta>(\<lambda>x. x powr p * ln (ln x))" by simp
  finally show "?f \<in> \<Theta>(\<lambda>a. a powr p * ln (ln a))" .
qed

lemma master1_bigo:
  assumes g_bigo: "g \<in> O(\<lambda>x. real x powr p')"
  assumes less_p': "(\<Sum>i<k. as!i * bs!i powr p') > 1"
  shows "f \<in> O(\<lambda>x. real x powr p)"
proof-
  interpret akra_bazzi_upper x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p'"
    using assms growths g_bigo master_integrable by unfold_locales (assumption | simp)+
  from less_p' have less_p: "p' < p" by (rule p_greaterI)
  from bigo_f[of "0"] guess a . note a = this
  note a(2)
  also from a(1) less_p x0_less_x1 have "p \<noteq> p'" by simp_all
  from master_integral[OF this a(1)] guess c d . note cd = this
  note cd(3)
  also from cd(1,2) less_p
    have "(\<lambda>x::nat. d * real x powr p + c * real x powr p') \<in> \<Theta>(\<lambda>x. real x powr p)" by force
  finally show "f \<in> O(\<lambda>x::nat. x powr p)" .
qed

lemma master1:
  assumes g_bigo: "g \<in> O(\<lambda>x. real x powr p')"
  assumes less_p': "(\<Sum>i<k. as!i * bs!i powr p') > 1"
  assumes f_pos:  "eventually (\<lambda>x. f x > 0) at_top"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p)"
proof (rule bigthetaI)
  interpret akra_bazzi_lower x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>_. 0"
    using assms(1,3) bs_lower_bound by unfold_locales (auto intro: always_eventually)
  from bigomega_f show "f \<in> \<Omega>(\<lambda>x. real x powr p)" by force
qed (fact master1_bigo[OF g_bigo less_p'])

lemma master2_3:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr (p' - 1))"
  assumes p': "p' > 0"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr p')"
proof-
  have "eventually (\<lambda>x::real. x powr p * ln x powr (p' - 1) > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  then interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p * ln x powr (p' - 1)"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from bigtheta_f[of "1"] guess a . note a = this
  note a(2)
  also from a(1) p' have "p' \<noteq> 0" by simp_all
  from master_integral'[OF this a(1), of p] guess c d . note cd = this
  note cd(3)
  also have "(\<lambda>x::nat. c * real x powr p + d * real x powr p * ln (real x) powr p') \<in>
                 \<Theta>(\<lambda>x::nat. x powr p * ln x powr p')" using cd(1,2) p' by force
  finally show "f \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr p')" .
qed

lemma master2_1:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr p')"
  assumes p': "p' < -1"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p)"
proof-
  have "eventually (\<lambda>x::real. x powr p * ln x powr p' > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  then interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p * ln x powr p'"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from bigtheta_f[of "1"] guess a . note a = this
  note a(2)
  also from a(1) p' have A: "p' + 1 \<noteq> 0" by simp_all
  obtain c d :: real where cd: "c \<noteq> 0" "d \<noteq> 0" and
    "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr p'/ u powr (p+1)))) \<in>
       \<Theta>(\<lambda>x::nat. c * x powr p + d * x powr p * ln x powr (p' + 1))"
    by (rule master_integral'[OF A a(1), of p]) (insert p', simp)
  note this(3)
  also have "(\<lambda>x::nat. c * real x powr p + d * real x powr p * ln (real x) powr (p' + 1)) \<in>
                 \<Theta>(\<lambda>x::nat. x powr p)" using cd(1,2) p' by force
  finally show "f \<in> \<Theta>(\<lambda>x::nat. x powr p)" .
qed

lemma master2_2:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p / ln (real x))"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p * ln (ln (real x)))"
proof-
  have "eventually (\<lambda>x::real. x powr p / ln x > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  moreover from g_bigtheta have g_bigtheta': "g \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr -1)"
    by (rule landau_theta.trans, intro landau_real_nat_transfer) simp
  ultimately interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p * ln x powr -1"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from bigtheta_f[of 1] guess a . note a = this
  note a(2)
  also note master_integral''[OF a(1)]
  finally show "f \<in> \<Theta>(\<lambda>x::nat. x powr p * ln (ln x))" .
qed

lemma master3:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p')"
  assumes p'_greater': "(\<Sum>i<k. as!i * bs!i powr p') < 1"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p')"
proof-
  have "eventually (\<lambda>x::real. x powr p' > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  then interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p'"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from p'_greater' have p'_greater: "p' > p" by (rule p_lessI)
  from bigtheta_f[of 0] guess a . note a = this
  note a(2)
  also from p'_greater have "p \<noteq> p'" by simp
  from master_integral[OF this a(1)] guess c d . note cd = this
  note cd(3)
  also have "(\<lambda>x::nat. d * x powr p + c * x powr p') \<in> \<Theta>(\<lambda>x::real. x powr p')"
    using p'_greater cd(1,2) by force
  finally show "f \<in> \<Theta>(\<lambda>x. real x powr p')" .
qed

end
end

end


(*  Title:      HOL/Library/Fraction_Field.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section\<open>A formalization of the fraction field of any integral domain;
         generalization of theory Rat from int to any integral domain\<close>

theory Fraction_Field
imports Main
begin

subsection \<open>General fractions construction\<close>

subsubsection \<open>Construction of the type of fractions\<close>

context idom begin

definition fractrel :: "'a \<times> 'a \<Rightarrow> 'a * 'a \<Rightarrow> bool" where
  "fractrel = (\<lambda>x y. snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x)"

lemma fractrel_iff [simp]:
  "fractrel x y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"
  by (simp add: fractrel_def)

lemma symp_fractrel: "symp fractrel"
  by (simp add: symp_def)

lemma transp_fractrel: "transp fractrel"
proof (rule transpI, unfold split_paired_all)
  fix a b a' b' a'' b'' :: 'a
  assume A: "fractrel (a, b) (a', b')"
  assume B: "fractrel (a', b') (a'', b'')"
  have "b' * (a * b'') = b'' * (a * b')" by (simp add: ac_simps)
  also from A have "a * b' = a' * b" by auto
  also have "b'' * (a' * b) = b * (a' * b'')" by (simp add: ac_simps)
  also from B have "a' * b'' = a'' * b'" by auto
  also have "b * (a'' * b') = b' * (a'' * b)" by (simp add: ac_simps)
  finally have "b' * (a * b'') = b' * (a'' * b)" .
  moreover from B have "b' \<noteq> 0" by auto
  ultimately have "a * b'' = a'' * b" by simp
  with A B show "fractrel (a, b) (a'', b'')" by auto
qed

lemma part_equivp_fractrel: "part_equivp fractrel"
using _ symp_fractrel transp_fractrel
by(rule part_equivpI)(rule exI[where x="(0, 1)"]; simp)

end

quotient_type (overloaded) 'a fract = "'a :: idom \<times> 'a" / partial: "fractrel"
by(rule part_equivp_fractrel)

subsubsection \<open>Representation and basic operations\<close>

lift_definition Fract :: "'a :: idom \<Rightarrow> 'a \<Rightarrow> 'a fract"
  is "\<lambda>a b. if b = 0 then (0, 1) else (a, b)"
  by simp

lemma Fract_cases [cases type: fract]:
  obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0"
by transfer simp

lemma Fract_induct [case_names Fract, induct type: fract]:
  "(\<And>a b. b \<noteq> 0 \<Longrightarrow> P (Fract a b)) \<Longrightarrow> P q"
  by (cases q) simp

lemma eq_fract:
  shows "\<And>a b c d. b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b = Fract c d \<longleftrightarrow> a * d = c * b"
    and "\<And>a. Fract a 0 = Fract 0 1"
    and "\<And>a c. Fract 0 a = Fract 0 c"
by(transfer; simp)+

instantiation fract :: (idom) comm_ring_1
begin

lift_definition zero_fract :: "'a fract" is "(0, 1)" by simp

lemma Zero_fract_def: "0 = Fract 0 1"
by transfer simp

lift_definition one_fract :: "'a fract" is "(1, 1)" by simp

lemma One_fract_def: "1 = Fract 1 1"
by transfer simp

lift_definition plus_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract"
  is "\<lambda>q r. (fst q * snd r + fst r * snd q, snd q * snd r)"
by(auto simp add: algebra_simps)

lemma add_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b + Fract c d = Fract (a * d + c * b) (b * d)"
by transfer simp

lift_definition uminus_fract :: "'a fract \<Rightarrow> 'a fract"
  is "\<lambda>x. (- fst x, snd x)"
by simp

lemma minus_fract [simp]:
  fixes a b :: "'a::idom"
  shows "- Fract a b = Fract (- a) b"
by transfer simp

lemma minus_fract_cancel [simp]: "Fract (- a) (- b) = Fract a b"
  by (cases "b = 0") (simp_all add: eq_fract)

definition diff_fract_def: "q - r = q + - (r::'a fract)"

lemma diff_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
  by (simp add: diff_fract_def)

lift_definition times_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract"
  is "\<lambda>q r. (fst q * fst r, snd q * snd r)"
by(simp add: algebra_simps)

lemma mult_fract [simp]: "Fract (a::'a::idom) b * Fract c d = Fract (a * c) (b * d)"
by transfer simp

lemma mult_fract_cancel:
  "c \<noteq> 0 \<Longrightarrow> Fract (c * a) (c * b) = Fract a b"
by transfer simp

instance
proof
  fix q r s :: "'a fract"
  show "(q * r) * s = q * (r * s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q * r = r * q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "1 * q = q"
    by (cases q) (simp add: One_fract_def eq_fract)
  show "(q + r) + s = q + (r + s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q + r = r + q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "0 + q = q"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "- q + q = 0"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "q - r = q + - r"
    by (cases q, cases r) (simp add: eq_fract)
  show "(q + r) * s = q * s + r * s"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "(0::'a fract) \<noteq> 1"
    by (simp add: Zero_fract_def One_fract_def eq_fract)
qed

end

lemma of_nat_fract: "of_nat k = Fract (of_nat k) 1"
  by (induct k) (simp_all add: Zero_fract_def One_fract_def)

lemma Fract_of_nat_eq: "Fract (of_nat k) 1 = of_nat k"
  by (rule of_nat_fract [symmetric])

lemma fract_collapse:
  "Fract 0 k = 0"
  "Fract 1 1 = 1"
  "Fract k 0 = 0"
by(transfer; simp)+

lemma fract_expand:
  "0 = Fract 0 1"
  "1 = Fract 1 1"
  by (simp_all add: fract_collapse)

lemma Fract_cases_nonzero:
  obtains (Fract) a b where "q = Fract a b" and "b \<noteq> 0" and "a \<noteq> 0"
    | (0) "q = 0"
proof (cases "q = 0")
  case True
  then show thesis using 0 by auto
next
  case False
  then obtain a b where "q = Fract a b" and "b \<noteq> 0" by (cases q) auto
  with False have "0 \<noteq> Fract a b" by simp
  with \<open>b \<noteq> 0\<close> have "a \<noteq> 0" by (simp add: Zero_fract_def eq_fract)
  with Fract \<open>q = Fract a b\<close> \<open>b \<noteq> 0\<close> show thesis by auto
qed

subsubsection \<open>The field of rational numbers\<close>

context idom
begin

subclass ring_no_zero_divisors ..

end

instantiation fract :: (idom) field
begin

lift_definition inverse_fract :: "'a fract \<Rightarrow> 'a fract"
  is "\<lambda>x. if fst x = 0 then (0, 1) else (snd x, fst x)"
by(auto simp add: algebra_simps)

lemma inverse_fract [simp]: "inverse (Fract a b) = Fract (b::'a::idom) a"
by transfer simp

definition divide_fract_def: "q div r = q * inverse (r:: 'a fract)"

lemma divide_fract [simp]: "Fract a b div Fract c d = Fract (a * d) (b * c)"
  by (simp add: divide_fract_def)

instance
proof
  fix q :: "'a fract"
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by (cases q rule: Fract_cases_nonzero)
      (simp_all add: fract_expand eq_fract mult.commute)
next
  fix q r :: "'a fract"
  show "q div r = q * inverse r" by (simp add: divide_fract_def)
next
  show "inverse 0 = (0:: 'a fract)"
    by (simp add: fract_expand) (simp add: fract_collapse)
qed

end

subsubsection \<open>The ordered field of fractions over an ordered idom\<close>

instantiation fract :: (linordered_idom) linorder
begin

lemma less_eq_fract_respect:
  fixes a b a' b' c d c' d' :: 'a
  assumes neq: "b \<noteq> 0"  "b' \<noteq> 0"  "d \<noteq> 0"  "d' \<noteq> 0"
  assumes eq1: "a * b' = a' * b"
  assumes eq2: "c * d' = c' * d"
  shows "((a * d) * (b * d) \<le> (c * b) * (b * d)) \<longleftrightarrow> ((a' * d') * (b' * d') \<le> (c' * b') * (b' * d'))"
proof -
  let ?le = "\<lambda>a b c d. ((a * d) * (b * d) \<le> (c * b) * (b * d))"
  {
    fix a b c d x :: 'a
    assume x: "x \<noteq> 0"
    have "?le a b c d = ?le (a * x) (b * x) c d"
    proof -
      from x have "0 < x * x"
        by (auto simp add: zero_less_mult_iff)
      then have "?le a b c d =
          ((a * d) * (b * d) * (x * x) \<le> (c * b) * (b * d) * (x * x))"
        by (simp add: mult_le_cancel_right)
      also have "... = ?le (a * x) (b * x) c d"
        by (simp add: ac_simps)
      finally show ?thesis .
    qed
  } note le_factor = this

  let ?D = "b * d" and ?D' = "b' * d'"
  from neq have D: "?D \<noteq> 0" by simp
  from neq have "?D' \<noteq> 0" by simp
  then have "?le a b c d = ?le (a * ?D') (b * ?D') c d"
    by (rule le_factor)
  also have "... = ((a * b') * ?D * ?D' * d * d' \<le> (c * d') * ?D * ?D' * b * b')"
    by (simp add: ac_simps)
  also have "... = ((a' * b) * ?D * ?D' * d * d' \<le> (c' * d) * ?D * ?D' * b * b')"
    by (simp only: eq1 eq2)
  also have "... = ?le (a' * ?D) (b' * ?D) c' d'"
    by (simp add: ac_simps)
  also from D have "... = ?le a' b' c' d'"
    by (rule le_factor [symmetric])
  finally show "?le a b c d = ?le a' b' c' d'" .
qed

lift_definition less_eq_fract :: "'a fract \<Rightarrow> 'a fract \<Rightarrow> bool"
  is "\<lambda>q r. (fst q * snd r) * (snd q * snd r) \<le> (fst r * snd q) * (snd q * snd r)"
by (clarsimp simp add: less_eq_fract_respect)

definition less_fract_def: "z < (w::'a fract) \<longleftrightarrow> z \<le> w \<and> \<not> w \<le> z"

lemma le_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
  by transfer simp

lemma less_fract [simp]:
  "\<lbrakk> b \<noteq> 0; d \<noteq> 0 \<rbrakk> \<Longrightarrow> Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
  by (simp add: less_fract_def less_le_not_le ac_simps)

instance
proof
  fix q r s :: "'a fract"
  assume "q \<le> r" and "r \<le> s"
  then show "q \<le> s"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract e f"
    show "Fract a b \<le> Fract e f"
    proof -
      from neq obtain bb: "0 < b * b" and dd: "0 < d * d" and ff: "0 < f * f"
        by (auto simp add: zero_less_mult_iff linorder_neq_iff)
      have "(a * d) * (b * d) * (f * f) \<le> (c * b) * (b * d) * (f * f)"
      proof -
        from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
          by simp
        with ff show ?thesis by (simp add: mult_le_cancel_right)
      qed
      also have "... = (c * f) * (d * f) * (b * b)"
        by (simp only: ac_simps)
      also have "... \<le> (e * d) * (d * f) * (b * b)"
      proof -
        from neq 2 have "(c * f) * (d * f) \<le> (e * d) * (d * f)"
          by simp
        with bb show ?thesis by (simp add: mult_le_cancel_right)
      qed
      finally have "(a * f) * (b * f) * (d * d) \<le> e * b * (b * f) * (d * d)"
        by (simp only: ac_simps)
      with dd have "(a * f) * (b * f) \<le> (e * b) * (b * f)"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by simp
    qed
  qed
next
  fix q r :: "'a fract"
  assume "q \<le> r" and "r \<le> q"
  then show "q = r"
  proof (induct q, induct r)
    fix a b c d :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract a b"
    show "Fract a b = Fract c d"
    proof -
      from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      also have "... \<le> (a * d) * (b * d)"
      proof -
        from neq 2 have "(c * b) * (d * b) \<le> (a * d) * (d * b)"
          by simp
        then show ?thesis by (simp only: ac_simps)
      qed
      finally have "(a * d) * (b * d) = (c * b) * (b * d)" .
      moreover from neq have "b * d \<noteq> 0" by simp
      ultimately have "a * d = c * b" by simp
      with neq show ?thesis by (simp add: eq_fract)
    qed
  qed
next
  fix q r :: "'a fract"
  show "q \<le> q"
    by (induct q) simp
  show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
    by (simp only: less_fract_def)
  show "q \<le> r \<or> r \<le> q"
    by (induct q, induct r)
       (simp add: mult.commute, rule linorder_linear)
qed

end

instantiation fract :: (linordered_idom) linordered_field
begin

definition abs_fract_def2:
  "\<bar>q\<bar> = (if q < 0 then -q else (q::'a fract))"

definition sgn_fract_def:
  "sgn (q::'a fract) = (if q = 0 then 0 else if 0 < q then 1 else - 1)"

theorem abs_fract [simp]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
  unfolding abs_fract_def2 not_le [symmetric]
  by transfer (auto simp add: zero_less_mult_iff le_less)

instance proof
  fix q r s :: "'a fract"
  assume "q \<le> r"
  then show "s + q \<le> s + r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b \<le> Fract c d"
    show "Fract e f + Fract a b \<le> Fract e f + Fract c d"
    proof -
      let ?F = "f * f" from neq have F: "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      from neq le have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      with F have "(a * d) * (b * d) * ?F * ?F \<le> (c * b) * (b * d) * ?F * ?F"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by (simp add: field_simps)
    qed
  qed
next
  fix q r s :: "'a fract"
  assume "q < r" and "0 < s"
  then show "s * q < s * r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b < Fract c d"
    assume gt: "0 < Fract e f"
    show "Fract e f * Fract a b < Fract e f * Fract c d"
    proof -
      let ?E = "e * f" and ?F = "f * f"
      from neq gt have "0 < ?E"
        by (auto simp add: Zero_fract_def order_less_le eq_fract)
      moreover from neq have "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      moreover from neq le have "(a * d) * (b * d) < (c * b) * (b * d)"
        by simp
      ultimately have "(a * d) * (b * d) * ?E * ?F < (c * b) * (b * d) * ?E * ?F"
        by (simp add: mult_less_cancel_right)
      with neq show ?thesis
        by (simp add: ac_simps)
    qed
  qed
qed (fact sgn_fract_def abs_fract_def2)+

end

instantiation fract :: (linordered_idom) distrib_lattice
begin

definition inf_fract_def:
  "(inf :: 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = min"

definition sup_fract_def:
  "(sup :: 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = max"

instance
  by standard (simp_all add: inf_fract_def sup_fract_def max_min_distrib2)

end

lemma fract_induct_pos [case_names Fract]:
  fixes P :: "'a::linordered_idom fract \<Rightarrow> bool"
  assumes step: "\<And>a b. 0 < b \<Longrightarrow> P (Fract a b)"
  shows "P q"
proof (cases q)
  case (Fract a b)
  {
    fix a b :: 'a
    assume b: "b < 0"
    have "P (Fract a b)"
    proof -
      from b have "0 < - b" by simp
      then have "P (Fract (- a) (- b))"
        by (rule step)
      then show "P (Fract a b)"
        by (simp add: order_less_imp_not_eq [OF b])
    qed
  }
  with Fract show "P q"
    by (auto simp add: linorder_neq_iff step)
qed

lemma zero_less_Fract_iff: "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
  by (auto simp add: Zero_fract_def zero_less_mult_iff)

lemma Fract_less_zero_iff: "0 < b \<Longrightarrow> Fract a b < 0 \<longleftrightarrow> a < 0"
  by (auto simp add: Zero_fract_def mult_less_0_iff)

lemma zero_le_Fract_iff: "0 < b \<Longrightarrow> 0 \<le> Fract a b \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: Zero_fract_def zero_le_mult_iff)

lemma Fract_le_zero_iff: "0 < b \<Longrightarrow> Fract a b \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (auto simp add: Zero_fract_def mult_le_0_iff)

lemma one_less_Fract_iff: "0 < b \<Longrightarrow> 1 < Fract a b \<longleftrightarrow> b < a"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma Fract_less_one_iff: "0 < b \<Longrightarrow> Fract a b < 1 \<longleftrightarrow> a < b"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma one_le_Fract_iff: "0 < b \<Longrightarrow> 1 \<le> Fract a b \<longleftrightarrow> b \<le> a"
  by (auto simp add: One_fract_def mult_le_cancel_right)

lemma Fract_le_one_iff: "0 < b \<Longrightarrow> Fract a b \<le> 1 \<longleftrightarrow> a \<le> b"
  by (auto simp add: One_fract_def mult_le_cancel_right)

end


theory prog_prov_ch04 imports Main
begin

lemma "\<not> surj(f::'a \<Rightarrow> 'a set)"
proof
assume "surj f"
hence "\<forall> A. \<exists> a. A = f a" by(simp add:surj_def)
hence "\<exists> a. {x. x \<notin> f x} = f a" by blast
thus "False" by blast
qed

lemma
fixes f:: "'a \<Rightarrow> 'a set"
assumes s: "surj f"
shows "False"
proof -
have "\<exists> a.  {x. x \<notin> f x} = f a" using s
  by(auto simp: surj_def)
thus "False" by blast
qed

lemma "\<not> surj(f:: 'a \<Rightarrow> 'a set)"
proof
assume "surj f"
hence "\<exists> a. {x. x\<notin>f x} = f a" by (auto simp:surj_def)
then obtain a where "{x. x \<notin> f x} = f a" by blast
hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
thus "False" by blast
qed

(*exercise 4.1 *)
lemma assumes T: "\<forall> x y. T x y \<or> T y x"
  and A: "\<forall> x y. A x y = A y x \<longrightarrow> x = y"
  and TA: "\<forall> x y. T x y \<longrightarrow> A x y"
  and Axy: "A x y"
shows "T x y"
proof cases
  assume "T x y"
  thus "T x y" by simp
next
  assume "\<not> (T x y)"
  hence "T y x" using T by blast
  hence "A y x" using TA by blast
  hence "x = y" using A and Axy by blast
  thus "T x y" using T by blast
qed

(* exercise 4.2 *)
lemma "(\<exists> ys zs. xs =  ys @ zs \<and> length ys = length zs)
      \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "even (length xs)"
    hence "\<exists> n. length xs = 2 * n" by (auto simp add: dvd_def)
    then  obtain n where "length xs = 2 * n" by blast
    let ?ys = "take n xs"
    let ?zs = "drop n xs"
    have "length ?ys = length ?zs" by (simp add: `length xs = 2 * n`)
    hence "xs = ?ys @ ?zs \<and> length ?ys = length ?zs" by (simp)
    hence "\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs" by blast
    thus ?thesis by blast
  next
  assume "odd (length xs)"
    hence "\<exists> n. length xs = 2 * n + 1" by (presburger)
    then obtain n where "length xs = 2*n+1" by blast
    let ?ys = "take (n+1) xs"
    let ?zs = "drop (n+1) xs"
    have "length ?ys = length ?zs + 1" by (simp add: `length xs = 2 * n + 1`)
    hence "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" by auto
    hence "\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1" by blast
    thus ?thesis by blast
  qed

lemma "length(tl xs) = length xs -1"
proof (cases xs)
  assume "xs = []"
    thus ?thesis by simp
  next
    fix y ys
    assume "xs = y#ys"
    thus ?thesis by simp
  qed

lemma "length (tl xs) = length xs -1"
proof (cases xs)
  case Nil
  thus ?thesis by simp
  next
  case (Cons y ys)
  thus ?thesis by simp
qed

lemma "\<Sum> {0..n::nat} = n*(n+1) div 2"
proof (induction n)
  show "\<Sum>{0..0::nat} = 0 * (0+1) div 2" by simp
next
  fix n
  assume "\<Sum>{0..n::nat} = n*(n+1) div 2"
  thus "\<Sum>{0..(Suc n)::nat} = (Suc n)*(Suc n + 1) div 2" by simp
qed

lemma "\<Sum> {0..n::nat} = n * (n+1) div 2" (is "?P n")
proof (induction n)
 show "?P 0" by simp
next
 fix n
 assume "?P n"
 thus "?P (Suc n)" by simp
qed

lemma "\<Sum> {0..n::nat} = n*(n+1) div 2"
proof (induction n)
 case 0
 show ?case by simp
next
 case (Suc n)
 thus ?case by simp
qed

inductive ev:: "nat\<Rightarrow>bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn:: "nat\<Rightarrow>bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

lemma "ev n \<Longrightarrow> evn n"
proof (induction rule: ev.induct)
case ev0
show ?case by simp
next
case evSS
thus ?case by simp
qed

lemma "ev n \<Longrightarrow> evn n"
proof (induction rule:ev.induct)
 case ev0 show ?case by simp
next
 case (evSS m)
 have "evn (Suc (Suc m)) = evn m" by simp
 thus ?case using `evn m` by blast
qed

lemma "ev  n \<Longrightarrow> ev (n - 2)"
proof -
assume "ev n"
hence "ev (n-2)"
proof cases
 case ev0
 thus "ev (n-2)" by (simp add: ev.ev0)
 next
 case (evSS k)
 thus "ev (n-2)" by (simp add: ev.evSS)
qed
thus ?thesis by blast
qed

lemma "\<not> ev (Suc 0)"
proof
 assume "ev (Suc 0)"
 thus "False" by cases
qed

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
 assume "ev (Suc (Suc (Suc 0)))"
 thus False
 proof cases
  assume "ev (Suc 0)"
  hence "False" by cases
  thus "False" by blast
 qed
qed

lemma "ev (Suc m) \<Longrightarrow> \<not> (ev m)"
proof(induction "Suc m" arbitrary: m rule:ev.induct)
fix n
assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not> ev m"
show "\<not> ev (Suc n)"
proof -- contradiction
assume "ev (Suc n)"
thus False
 proof (cases "Suc n" -- rule)
  fix k
  assume "n = Suc k" and "ev k"
  thus False using IH by auto
 qed
qed
qed

(* exercise 4.3 TODO *)

(* exercise 4.4 TODO *)

(* exercise 4.5 TODO *)

(* exercise 4.6 TODO *)

(* exercise 4.7 TODO *)

end


theory Permutation
imports Main
begin

type_synonym 'a swp = "'a \<times> 'a"
type_synonym 'a preprm = "'a swp list"

definition preprm_id :: "'a preprm" where "preprm_id = []"

fun swp_apply :: "'a swp \<Rightarrow> 'a \<Rightarrow> 'a" where
  "swp_apply (a, b) x = (if x = a then b else (if x = b then a else x))"

fun preprm_apply :: "'a preprm \<Rightarrow> 'a \<Rightarrow> 'a" where
  "preprm_apply [] x = x"
| "preprm_apply (s # ss) x = swp_apply s (preprm_apply ss x)"

definition preprm_compose :: "'a preprm \<Rightarrow> 'a preprm \<Rightarrow> 'a preprm" where
  "preprm_compose f g \<equiv> f @ g"

definition preprm_unit :: "'a \<Rightarrow> 'a \<Rightarrow> 'a preprm" where
  "preprm_unit a b \<equiv> [(a, b)]"

definition preprm_ext :: "'a preprm \<Rightarrow> 'a preprm \<Rightarrow> bool" (infix "=p" 100) where
  "\<pi> =p \<sigma> \<equiv> \<forall>x. preprm_apply \<pi> x = preprm_apply \<sigma> x"

definition preprm_inv :: "'a preprm \<Rightarrow> 'a preprm" where
  "preprm_inv \<pi> \<equiv> rev \<pi>"

lemma swp_apply_unequal:
  assumes "x \<noteq> y"
  shows "swp_apply s x \<noteq> swp_apply s y"
proof(cases s)
  case (Pair a b)
    consider "x = a" | "x = b" | "x \<noteq> a \<and> x \<noteq> b" by auto
    thus ?thesis proof(cases)
      case 1
        have "swp_apply s x = b" using \<open>s = (a, b)\<close> \<open>x = a\<close> by simp
        moreover have "swp_apply s y \<noteq> b" using \<open>s = (a, b)\<close> \<open>x = a\<close> \<open>x \<noteq> y\<close>
          by(cases "y = b", simp_all)
        ultimately show ?thesis by metis
      next
      case 2
        have "swp_apply s x = a" using \<open>s = (a, b)\<close> \<open>x = b\<close> by simp
        moreover have "swp_apply s y \<noteq> a" using \<open>s = (a, b)\<close> \<open>x = b\<close> \<open>x \<noteq> y\<close>
          by(cases "y = a", simp_all)
        ultimately show ?thesis by metis
      next
      case 3
        have "swp_apply s x = x" using \<open>s = (a, b)\<close> \<open>x \<noteq> a \<and> x \<noteq> b\<close> by simp
        consider "y = a" | "y = b" | "y \<noteq> a \<and> y \<noteq> b" by auto
        hence "swp_apply s y \<noteq> x" proof(cases)
          case 1
            hence "swp_apply s y = b" using \<open>s = (a, b)\<close> by simp
            thus ?thesis using \<open>x \<noteq> a \<and> x \<noteq> b\<close> by metis
          next
          case 2
            hence "swp_apply s y = a" using \<open>s = (a, b)\<close> by simp
            thus ?thesis using \<open>x \<noteq> a \<and> x \<noteq> b\<close> by metis
          next
          case 3
            hence "swp_apply s y = y" using \<open>s = (a, b)\<close> by simp
            thus ?thesis using \<open>x \<noteq> y\<close> by metis
          next
        qed
        thus ?thesis using \<open>swp_apply s x = x\<close> \<open>x \<noteq> y\<close> by metis
      next
    qed
  next
qed

lemma preprm_ext_reflexive:
  shows "x =p x"
unfolding preprm_ext_def by auto

corollary preprm_ext_reflp:
  shows "reflp preprm_ext"
unfolding reflp_def using preprm_ext_reflexive by auto

lemma preprm_ext_symmetric:
  assumes "x =p y"
  shows "y =p x"
using assms unfolding preprm_ext_def by auto

corollary preprm_ext_symp:
  shows "symp preprm_ext"
unfolding symp_def using preprm_ext_symmetric by auto

lemma preprm_ext_transitive:
  assumes "x =p y" and "y =p z"
  shows "x =p z"
using assms unfolding preprm_ext_def by auto

corollary preprm_ext_transp:
  shows "transp preprm_ext"
unfolding transp_def using preprm_ext_transitive by auto

lemma preprm_apply_composition:
  shows "preprm_apply (preprm_compose f g) x = preprm_apply f (preprm_apply g x)"
unfolding preprm_compose_def
by(induction f, simp_all)

lemma preprm_apply_unequal:
  assumes "x \<noteq> y"
  shows "preprm_apply \<pi> x \<noteq> preprm_apply \<pi> y"
using assms proof(induction \<pi>, simp)
  case (Cons s ss)
    have  "preprm_apply (s # ss) x = swp_apply s (preprm_apply ss x)"
      and "preprm_apply (s # ss) y = swp_apply s (preprm_apply ss y)" by auto
    thus ?case using Cons.IH \<open>x \<noteq> y\<close> swp_apply_unequal by metis
  next
qed

lemma preprm_unit_equal_id:
  shows "preprm_unit a a =p preprm_id"
unfolding preprm_ext_def preprm_unit_def preprm_id_def
by simp

lemma preprm_unit_inaction:
  assumes "x \<noteq> a" and "x \<noteq> b"
  shows "preprm_apply (preprm_unit a b) x = x"
unfolding preprm_unit_def using assms by simp

lemma preprm_unit_action:
  shows "preprm_apply (preprm_unit a b) a = b"
unfolding preprm_unit_def by simp

lemma preprm_unit_commutes:
  shows "preprm_unit a b =p preprm_unit b a"
unfolding preprm_ext_def preprm_unit_def
by simp

lemma preprm_singleton_involution:
  shows "preprm_compose [s] [s] =p preprm_id"
unfolding preprm_ext_def preprm_compose_def preprm_unit_def preprm_id_def
proof -
  obtain s1 s2 where "s1 = fst s" "s2 = snd s" by auto
  hence "s = (s1, s2)" by simp
  thus "\<forall>x. preprm_apply ([s] @ [s]) x = preprm_apply [] x"
    by simp
qed

lemma preprm_unit_involution:
  shows "preprm_compose (preprm_unit a b) (preprm_unit a b) =p preprm_id"
unfolding preprm_unit_def
using preprm_singleton_involution.

lemma preprm_apply_id:
  shows "preprm_apply preprm_id x = x"
unfolding preprm_id_def
by simp

lemma preprm_apply_injective:
  shows "inj (preprm_apply \<pi>)"
unfolding inj_on_def proof(rule+)
  fix x y
  assume "preprm_apply \<pi> x = preprm_apply \<pi> y"
  thus "x = y" proof(induction \<pi>)
    case Nil
      thus ?case by auto
    next
    case (Cons s ss)
      hence "swp_apply s (preprm_apply ss x) = swp_apply s (preprm_apply ss y)" by auto
      thus ?case using swp_apply_unequal Cons.IH by metis
    next
  qed
qed

lemma preprm_disagreement_composition:
  assumes "a \<noteq> b" "b \<noteq> c" "a \<noteq> c"
  shows "{x.
    preprm_apply (preprm_compose (preprm_unit a b) (preprm_unit b c)) x \<noteq>
    preprm_apply (preprm_unit a c) x
  } = {a, b}"
unfolding preprm_unit_def preprm_compose_def proof
  show "{x. preprm_apply ([(a, b)] @ [(b, c)]) x \<noteq> preprm_apply [(a, c)] x} \<subseteq> {a, b}"
  proof
    fix x
    have "x \<notin> {a, b} \<Longrightarrow> x \<notin> {x. preprm_apply ([(a, b)] @ [(b, c)]) x \<noteq> preprm_apply [(a, c)] x}"
    proof -
      assume "x \<notin> {a, b}"
      hence "x \<noteq> a \<and> x \<noteq> b" by auto
      hence "preprm_apply ([(a, b)] @ [(b, c)]) x = preprm_apply [(a, c)] x" by simp
      thus "x \<notin> {x. preprm_apply ([(a, b)] @ [(b, c)]) x \<noteq> preprm_apply [(a, c)] x}" by auto
    qed
    thus "x \<in> {x. preprm_apply ([(a, b)] @ [(b, c)]) x \<noteq> preprm_apply [(a, c)] x} \<Longrightarrow> x \<in> {a, b}"
      by blast
  qed
  show "{a, b} \<subseteq> {x. preprm_apply ([(a, b)] @ [(b, c)]) x \<noteq> preprm_apply [(a, c)] x}"
  proof
    fix x
    assume "x \<in> {a, b}"
    from this consider "x = a" | "x = b" by auto
    thus "x \<in> {x. preprm_apply ([(a, b)] @ [(b, c)]) x \<noteq> preprm_apply [(a, c)] x}"
      using assms by(cases, simp_all)
  qed
qed

lemma preprm_compose_push:
  shows "
    preprm_compose \<pi> (preprm_unit a b) =p
    preprm_compose (preprm_unit (preprm_apply \<pi> a) (preprm_apply \<pi> b)) \<pi>
  "
unfolding preprm_ext_def preprm_unit_def
by (simp add: inj_eq preprm_apply_composition preprm_apply_injective)

lemma preprm_ext_compose_left:
  assumes "P =p S"
  shows "preprm_compose \<pi> P =p preprm_compose \<pi> S"
using assms unfolding preprm_ext_def
using preprm_apply_composition by metis

lemma preprm_ext_compose_right:
  assumes "P =p S"
  shows "preprm_compose P \<pi> =p preprm_compose S \<pi>"
using assms unfolding preprm_ext_def
using preprm_apply_composition by metis

lemma preprm_ext_uncompose:
  assumes "\<pi> =p \<sigma>" "preprm_compose \<pi> P =p preprm_compose \<sigma> S"
  shows "P =p S"
using assms unfolding preprm_ext_def
proof -
  assume *: "\<forall>x. preprm_apply \<pi> x = preprm_apply \<sigma> x"

  assume "\<forall>x. preprm_apply (preprm_compose \<pi> P) x = preprm_apply (preprm_compose \<sigma> S) x"
  hence "\<forall>x. preprm_apply \<pi> (preprm_apply P x) = preprm_apply \<sigma> (preprm_apply S x)"
    using preprm_apply_composition by metis
  hence "\<forall>x. preprm_apply \<pi> (preprm_apply P x) = preprm_apply \<pi> (preprm_apply S x)"
    using * by metis
  thus "\<forall>x. preprm_apply P x = preprm_apply S x"
    using preprm_apply_injective unfolding inj_on_def by fastforce
qed

lemma preprm_inv_compose:
  shows "preprm_compose (preprm_inv \<pi>) \<pi> =p preprm_id"
unfolding preprm_inv_def
proof(induction \<pi>, simp add: preprm_ext_def preprm_id_def preprm_compose_def)
  case (Cons p ps)
    hence IH: "(preprm_compose (rev ps) ps) =p preprm_id" by auto

    have "(preprm_compose (rev (p # ps)) (p # ps)) =p (preprm_compose (rev ps) (preprm_compose (preprm_compose [p] [p]) ps))"
      unfolding preprm_compose_def using preprm_ext_reflexive by simp
    moreover have "... =p (preprm_compose (rev ps) (preprm_compose preprm_id ps))"
      using preprm_singleton_involution preprm_ext_compose_left preprm_ext_compose_right by metis
    moreover have "... =p (preprm_compose (rev ps) ps)"
      unfolding preprm_compose_def preprm_id_def using preprm_ext_reflexive by simp
    moreover have "... =p preprm_id" using IH.
    ultimately show ?case using preprm_ext_transitive by metis
  next
qed

lemma preprm_inv_involution:
  shows "preprm_inv (preprm_inv \<pi>) = \<pi>"
unfolding preprm_inv_def by simp

lemma preprm_inv_ext:
  assumes "\<pi> =p \<sigma>"
  shows "preprm_inv \<pi> =p preprm_inv \<sigma>"
proof -
  have
    "(preprm_compose (preprm_inv (preprm_inv \<pi>)) (preprm_inv \<pi>)) =p preprm_id"
    "(preprm_compose (preprm_inv (preprm_inv \<sigma>)) (preprm_inv \<sigma>)) =p preprm_id"
    using preprm_inv_compose by metis+
  hence
    "(preprm_compose \<pi> (preprm_inv \<pi>)) =p preprm_id"
    "(preprm_compose \<sigma> (preprm_inv \<sigma>)) =p preprm_id"
    using preprm_inv_involution by metis+
  hence "(preprm_compose \<pi> (preprm_inv \<pi>)) =p (preprm_compose \<sigma> (preprm_inv \<sigma>))"
    using preprm_ext_transitive preprm_ext_symmetric by metis
  thus "preprm_inv \<pi> =p preprm_inv \<sigma>"
    using preprm_ext_uncompose assms by metis
qed

quotient_type 'a prm = "'a preprm" / preprm_ext
proof(rule equivpI)
  show "reflp preprm_ext" using preprm_ext_reflp.
  show "symp preprm_ext" using preprm_ext_symp.
  show "transp preprm_ext" using preprm_ext_transp.
qed

lift_definition prm_id :: "'a prm" ("\<epsilon>") is preprm_id.

lift_definition prm_apply :: "'a prm \<Rightarrow> 'a \<Rightarrow> 'a" (infix "$" 140) is preprm_apply
unfolding preprm_ext_def
using preprm_apply.simps by auto

lift_definition prm_compose :: "'a prm \<Rightarrow> 'a prm \<Rightarrow> 'a prm" (infixr "\<diamondop>" 145) is preprm_compose
unfolding preprm_ext_def
by(simp only: preprm_apply_composition, simp)

lift_definition prm_unit :: "'a \<Rightarrow> 'a \<Rightarrow> 'a prm" ("[_ \<leftrightarrow> _]") is preprm_unit.

lift_definition prm_inv :: "'a prm \<Rightarrow> 'a prm" is preprm_inv
using preprm_inv_ext.

lemma prm_apply_composition:
  fixes f g :: "'a prm" and x :: 'a
  shows "f \<diamondop> g $ x = f $ (g $ x)"
by(transfer, metis preprm_apply_composition)

lemma prm_apply_unequal:
  fixes \<pi> :: "'a prm" and x y :: 'a
  assumes "x \<noteq> y"
  shows "\<pi> $ x \<noteq> \<pi> $ y"
using assms by (transfer, metis preprm_apply_unequal)

lemma prm_unit_equal_id:
  fixes a :: 'a
  shows "[a \<leftrightarrow> a] = \<epsilon>"
by (transfer, metis preprm_unit_equal_id)

lemma prm_unit_inaction:
  fixes a b x :: 'a
  assumes "x \<noteq> a" and "x \<noteq> b"
  shows "[a \<leftrightarrow> b] $ x = x"
using assms
by (transfer, metis preprm_unit_inaction)

lemma prm_unit_action:
  fixes a b :: 'a
  shows "[a \<leftrightarrow> b] $ a = b"
by (transfer, metis preprm_unit_action)

lemma prm_unit_commutes:
  fixes a b :: 'a
  shows "[a \<leftrightarrow> b] = [b \<leftrightarrow> a]"
by (transfer, metis preprm_unit_commutes)

lemma prm_unit_involution:
  fixes a b :: 'a
  shows "[a \<leftrightarrow> b] \<diamondop> [a \<leftrightarrow> b] = \<epsilon>"
by (transfer, metis preprm_unit_involution)

lemma prm_apply_id:
  fixes x :: 'a
  shows "\<epsilon> $ x = x"
by(transfer, metis preprm_apply_id)

lemma prm_apply_injective:
  shows "inj (prm_apply \<pi>)"
by(transfer, metis preprm_apply_injective)

lemma prm_inv_compose:
  shows "(prm_inv \<pi>) \<diamondop> \<pi> = \<epsilon>"
by(transfer, metis preprm_inv_compose)

interpretation "'a prm": semigroup prm_compose
unfolding semigroup_def by(transfer, simp add: preprm_compose_def preprm_ext_def)

interpretation "'a prm": group prm_compose prm_id prm_inv
unfolding group_def group_axioms_def
proof -
  have "semigroup (\<diamondop>)" using "'a prm.semigroup_axioms".
  moreover have "\<forall>a. \<epsilon> \<diamondop> a = a" by(transfer, simp add: preprm_id_def preprm_compose_def preprm_ext_def)
  moreover have "\<forall>a. prm_inv a \<diamondop> a = \<epsilon>" using prm_inv_compose by blast
  ultimately show "semigroup (\<diamondop>) \<and> (\<forall>a. \<epsilon> \<diamondop> a = a) \<and> (\<forall>a. prm_inv a \<diamondop> a = \<epsilon>)" by blast
qed

definition prm_set :: "'a prm \<Rightarrow> 'a set \<Rightarrow> 'a set" (infix "{$}" 140) where
  "prm_set \<pi> S \<equiv> image (prm_apply \<pi>) S"

lemma prm_set_apply_compose:
  shows "\<pi> {$} (\<sigma> {$} S) = (\<pi> \<diamondop> \<sigma>) {$} S"
unfolding prm_set_def proof -
  have "($) \<pi> ` ($) \<sigma> ` S = (\<lambda>x. \<pi> $ x) ` (\<lambda>x. \<sigma> $ x) ` S" by simp
  moreover have "... = (\<lambda>x. \<pi> $ (\<sigma> $ x)) ` S" by auto
  moreover have "... = (\<lambda>x. (\<pi> \<diamondop> \<sigma>) $ x) ` S" using prm_apply_composition by metis
  moreover have "... = (\<pi> \<diamondop> \<sigma>) {$} S" using prm_set_def by metis
  ultimately show "($) \<pi> ` ($) \<sigma> ` S = ($) (\<pi> \<diamondop> \<sigma>) ` S" by metis
qed

lemma prm_set_membership:
  assumes "x \<in> S"
  shows "\<pi> $ x \<in> \<pi> {$} S"
using assms unfolding prm_set_def by simp

lemma prm_set_notmembership:
  assumes "x \<notin> S"
  shows "\<pi> $ x \<notin> \<pi> {$} S"
using assms unfolding prm_set_def
by (simp add: inj_image_mem_iff prm_apply_injective)

lemma prm_set_singleton:
  shows "\<pi> {$} {x} = {\<pi> $ x}"
unfolding prm_set_def by auto

lemma prm_set_id:
  shows "\<epsilon> {$} S = S"
unfolding prm_set_def
proof -
  have "($) \<epsilon> ` S = (\<lambda>x. \<epsilon> $ x) ` S" by simp
  moreover have "... = (\<lambda>x. x) ` S" using prm_apply_id by metis
  moreover have "... = S" by auto
  ultimately show "($) \<epsilon> ` S = S" by metis
qed

lemma prm_set_unit_inaction:
  assumes "a \<notin> S" and "b \<notin> S"
  shows "[a \<leftrightarrow> b] {$} S = S"
proof
  show "[a \<leftrightarrow> b] {$} S \<subseteq> S" proof
    fix x
    assume H: "x \<in> [a \<leftrightarrow> b] {$} S"
    from this obtain y where "x = [a \<leftrightarrow> b] $ y" unfolding prm_set_def using imageE by metis
    hence "y \<in> S" using H inj_image_mem_iff prm_apply_injective prm_set_def by metis
    hence "y \<noteq> a" and "y \<noteq> b" using assms by auto
    hence "x = y" using prm_unit_inaction \<open>x = [a \<leftrightarrow> b] $ y\<close> by metis
    thus "x \<in> S" using \<open>y \<in> S\<close> by auto
  qed
  show "S \<subseteq> [a \<leftrightarrow> b] {$} S" proof
    fix x
    assume H: "x \<in> S"
    hence "x \<noteq> a" and "x \<noteq> b" using assms by auto
    hence "x = [a \<leftrightarrow> b] $ x" using prm_unit_inaction by metis
    thus "x \<in> [a \<leftrightarrow> b] {$} S" unfolding prm_set_def using H by simp
  qed
qed

lemma prm_set_unit_action:
  assumes "a \<in> S" and "b \<notin> S"
  shows "[a \<leftrightarrow> b] {$} S = S - {a} \<union> {b}"
proof
  show "[a \<leftrightarrow> b] {$} S \<subseteq> S - {a} \<union> {b}" proof
    fix x
    assume H: "x \<in> [a \<leftrightarrow> b] {$} S"
    from this obtain y where "x = [a \<leftrightarrow> b] $ y" unfolding prm_set_def using imageE by metis
    hence "y \<in> S" using H inj_image_mem_iff prm_apply_injective prm_set_def by metis
    hence "y \<noteq> b" using assms by auto
    consider "y = a" | "y \<noteq> a" by auto
    thus "x \<in> S - {a} \<union> {b}" proof(cases)
      case 1
        hence "x = b" using \<open>x = [a \<leftrightarrow> b] $ y\<close> using prm_unit_action by metis
        thus ?thesis by auto
      next
      case 2
        hence "x = y" using \<open>x = [a \<leftrightarrow> b] $ y\<close> using prm_unit_inaction \<open>y \<noteq> b\<close> by metis
        hence "x \<in> S" and "x \<noteq> a" using \<open>y \<in> S\<close> \<open>y \<noteq> a\<close> by auto
        thus ?thesis by auto
      next
    qed
  qed
  show "S - {a} \<union> {b} \<subseteq> [a \<leftrightarrow> b] {$} S" proof
    fix x
    assume H: "x \<in> S - {a} \<union> {b}"
    hence "x \<noteq> a" using assms by auto
    consider "x = b" | "x \<noteq> b" by auto
    thus "x \<in> [a \<leftrightarrow> b] {$} S" proof(cases)
      case 1
        hence "x = [a \<leftrightarrow> b] $ a" using prm_unit_action by metis
        thus ?thesis using \<open>a \<in> S\<close> prm_set_membership by metis
      next
      case 2
        hence "x \<in> S" using H by auto
        moreover have "x = [a \<leftrightarrow> b] $ x" using prm_unit_inaction \<open>x \<noteq> a\<close> \<open>x \<noteq> b\<close> by metis
        ultimately show ?thesis using prm_set_membership by metis
      next
    qed
  qed
qed

lemma prm_set_distributes_union:
  shows "\<pi> {$} (S \<union> T) = (\<pi> {$} S) \<union> (\<pi> {$} T)"
unfolding prm_set_def by auto

lemma prm_set_distributes_difference:
  shows "\<pi> {$} (S - T) = (\<pi> {$} S) - (\<pi> {$} T)"
unfolding prm_set_def using prm_apply_injective image_set_diff by metis

definition prm_disagreement :: "'a prm \<Rightarrow> 'a prm \<Rightarrow> 'a set" ("ds") where
  "prm_disagreement \<pi> \<sigma> \<equiv> {x. \<pi> $ x \<noteq> \<sigma> $ x}"

lemma prm_disagreement_ext:
  shows "x \<in> ds \<pi> \<sigma> \<equiv> \<pi> $ x \<noteq> \<sigma> $ x"
unfolding prm_disagreement_def by simp

lemma prm_disagreement_composition:
  assumes "a \<noteq> b" "b \<noteq> c" "a \<noteq> c"
  shows "ds ([a \<leftrightarrow> b] \<diamondop> [b \<leftrightarrow> c]) [a \<leftrightarrow> c] = {a, b}"
using assms unfolding prm_disagreement_def by(transfer, metis preprm_disagreement_composition)

lemma prm_compose_push:
  shows "\<pi> \<diamondop> [a \<leftrightarrow> b] = [\<pi> $ a \<leftrightarrow> \<pi> $ b] \<diamondop> \<pi>"
by(transfer, metis preprm_compose_push)

end