/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

! This file was ported from Lean 3 source module init.meta.well_founded_tactics
! leanprover-community/mathlib commit 5885f626d8db2f03abe21c45749d8e3995f0988e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Meta.Default
import Leanbin.Init.Data.Sigma.Lex
import Leanbin.Init.Data.Nat.Lemmas
import Leanbin.Init.Data.List.Instances
import Leanbin.Init.Data.List.Qsort

#print Nat.lt_add_of_zero_lt_left /-
-- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer.
-- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer.
theorem Nat.lt_add_of_zero_lt_left (a b : Nat) (h : 0 < b) : a < a + b :=
  show a + 0 < a + b by
    apply Nat.add_lt_add_left
    assumption
#align nat.lt_add_of_zero_lt_left Nat.lt_add_of_zero_lt_left
-/

#print Nat.zero_lt_one_add /-
-- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer.
theorem Nat.zero_lt_one_add (a : Nat) : 0 < 1 + a :=
  suffices 0 < a + 1 by
    simp [Nat.add_comm]
    assumption
  Nat.zero_lt_succ _
#align nat.zero_lt_one_add Nat.zero_lt_one_add
-/

#print Nat.lt_add_right /-
-- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer.
theorem Nat.lt_add_right (a b c : Nat) : a < b → a < b + c := fun h =>
  lt_of_lt_of_le h (Nat.le_add_right _ _)
#align nat.lt_add_right Nat.lt_add_right
-/

#print Nat.lt_add_left /-
-- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer.
theorem Nat.lt_add_left (a b c : Nat) : a < b → a < c + b := fun h =>
  lt_of_lt_of_le h (Nat.le_add_left _ _)
#align nat.lt_add_left Nat.lt_add_left
-/

protected def PSum.Alt.sizeof.{u, v} {α : Type u} {β : Type v} [SizeOf α] [SizeOf β] : PSum α β → ℕ
  | PSum.inl a => SizeOf.sizeOf a
  | PSum.inr b => SizeOf.sizeOf b
#align psum.alt.sizeof PSum.Alt.sizeof

@[reducible]
protected def PSum.hasSizeofAlt.{u, v} (α : Type u) (β : Type v) [SizeOf α] [SizeOf β] :
    SizeOf (PSum α β) :=
  ⟨PSum.Alt.sizeof⟩
#align psum.has_sizeof_alt PSum.hasSizeofAlt

namespace WellFoundedTactics

open Tactic

def IdTag.wf : Unit :=
  ()
#align well_founded_tactics.id_tag.wf WellFoundedTactics.IdTag.wf

unsafe def mk_alt_sizeof : expr → expr
  | expr.app (expr.app (expr.app (expr.app (expr.const `` PSum.hasSizeof l) α) β) iα) iβ =>
    (expr.const `` PSum.hasSizeofAlt l : expr) α β iα (mk_alt_sizeof iβ)
  | e => e
#align well_founded_tactics.mk_alt_sizeof well_founded_tactics.mk_alt_sizeof

unsafe def default_rel_tac (e : expr) (eqns : List expr) : tactic Unit := do
  let tgt ← target
  let rel ← mk_instance tgt
  exact <|
      match e, Rel with
      | expr.local_const _ (Name.mk_string "_mutual" _) _ _,
        expr.app (e@q(@hasWellFoundedOfHasSizeof _)) sz => e (mk_alt_sizeof sz)
      | _, _ => Rel
#align well_founded_tactics.default_rel_tac well_founded_tactics.default_rel_tac

private unsafe def clear_wf_rec_goal_aux : List expr → tactic Unit
  | [] => return ()
  | h :: hs =>
    clear_wf_rec_goal_aux hs >>
      try (guard (h.local_pp_name.is_internal || h.is_aux_decl) >> clear h)
#align well_founded_tactics.clear_wf_rec_goal_aux well_founded_tactics.clear_wf_rec_goal_aux

unsafe def clear_internals : tactic Unit :=
  local_context >>= clear_wf_rec_goal_aux
#align well_founded_tactics.clear_internals well_founded_tactics.clear_internals

unsafe def unfold_wf_rel : tactic Unit :=
  dunfold_target [`` WellFoundedRelation.R] { failIfUnchanged := false }
#align well_founded_tactics.unfold_wf_rel well_founded_tactics.unfold_wf_rel

unsafe def is_psigma_mk : expr → tactic (expr × expr)
  | q(PSigma.mk $(a) $(b)) => return (a, b)
  | _ => failed
#align well_founded_tactics.is_psigma_mk well_founded_tactics.is_psigma_mk

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def process_lex : tactic Unit → tactic Unit
  | tac => do
    let t ← target >>= whnf
    if t `psigma.lex 6 then
        let a := t
        let b := t
        do
        let (a₁, a₂) ← is_psigma_mk a
        let (b₁, b₂) ← is_psigma_mk b
        (is_def_eq a₁ b₁ >> sorry) >> process_lex tac <|> sorry >> tac
      else tac
#align well_founded_tactics.process_lex well_founded_tactics.process_lex

private unsafe def unfold_sizeof_measure : tactic Unit :=
  dunfold_target [`` SizeofMeasure, `` Measure, `` InvImage] { failIfUnchanged := false }
#align well_founded_tactics.unfold_sizeof_measure well_founded_tactics.unfold_sizeof_measure

private unsafe def add_simps : simp_lemmas → List Name → tactic simp_lemmas
  | s, [] => return s
  | s, n :: ns => do
    let s' ← s.add_simp n false
    add_simps s' ns
#align well_founded_tactics.add_simps well_founded_tactics.add_simps

private unsafe def collect_sizeof_lemmas (e : expr) : tactic simp_lemmas :=
  e.mfold simp_lemmas.mk fun c d s =>
    if c.is_constant then
      match c.const_name with
      | Name.mk_string "sizeof" p => do
        let eqns ← get_eqn_lemmas_for true c.const_name
        add_simps s eqns
      | _ => return s
    else return s
#align well_founded_tactics.collect_sizeof_lemmas well_founded_tactics.collect_sizeof_lemmas

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
private unsafe def unfold_sizeof_loop : tactic Unit := do
  dunfold_target [`` SizeOf.sizeOf, `` SizeOf.sizeOf] { failIfUnchanged := ff }
  let S ← target >>= collect_sizeof_lemmas
  simp_target S >> unfold_sizeof_loop <|> try sorry
#align well_founded_tactics.unfold_sizeof_loop well_founded_tactics.unfold_sizeof_loop

unsafe def unfold_sizeof : tactic Unit :=
  unfold_sizeof_measure >> unfold_sizeof_loop
#align well_founded_tactics.unfold_sizeof well_founded_tactics.unfold_sizeof

/- The following section should be removed as soon as we implement the
   algebraic normalizer. -/
section SimpleDecTac

open Tactic Expr

-- failed to format: unknown constant 'term.pseudo.antiquot'
private unsafe
  def
    collect_add_args
    : expr → List expr
    | q( $ ( a ) + $ ( b ) ) => collect_add_args a ++ collect_add_args b | e => [ e ]
#align well_founded_tactics.collect_add_args well_founded_tactics.collect_add_args

-- failed to format: unknown constant 'term.pseudo.antiquot'
private unsafe
  def
    mk_nat_add
    : List expr → tactic expr
    | [ ] => to_expr ` `( 0 )
      | [ a ] => return a
      | a :: as => do let rs ← mk_nat_add as to_expr ` `( $ ( a ) + $ ( rs ) )
#align well_founded_tactics.mk_nat_add well_founded_tactics.mk_nat_add

-- failed to format: unknown constant 'term.pseudo.antiquot'
private unsafe
  def
    mk_nat_add_add
    : List expr → List expr → tactic expr
    | [ ] , b => mk_nat_add b
      | a , [ ] => mk_nat_add a
      | a , b => do let t ← mk_nat_add a let s ← mk_nat_add b to_expr ` `( $ ( t ) + $ ( s ) )
#align well_founded_tactics.mk_nat_add_add well_founded_tactics.mk_nat_add_add

private unsafe def get_add_fn (e : expr) : expr :=
  if is_napp_of e `has_add.add 4 then e.app_fn.app_fn else e
#align well_founded_tactics.get_add_fn well_founded_tactics.get_add_fn

private unsafe def prove_eq_by_perm (a b : expr) : tactic expr :=
  is_def_eq a b >> to_expr ``(Eq.refl $(a)) <|>
    perm_ac (get_add_fn a) q(Nat.add_assoc) q(Nat.add_comm) a b
#align well_founded_tactics.prove_eq_by_perm well_founded_tactics.prove_eq_by_perm

private unsafe def num_small_lt (a b : expr) : Bool :=
  if a = b then false
  else
    if is_napp_of a `has_one.one 2 then true
    else if is_napp_of b `has_one.one 2 then false else a.lt b
#align well_founded_tactics.num_small_lt well_founded_tactics.num_small_lt

private unsafe def sort_args (args : List expr) : List expr :=
  args.qsort num_small_lt
#align well_founded_tactics.sort_args well_founded_tactics.sort_args

private def tagged_proof.wf : Unit :=
  ()
#align well_founded_tactics.tagged_proof.wf well_founded_tactics.tagged_proof.wf

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
unsafe
  def
    cancel_nat_add_lt
    : tactic Unit
    :=
      do
        let q( $ ( lhs ) < $ ( rhs ) ) ← target
          let ty ← infer_type lhs >>= whnf
          guard ( ty = q( Nat ) )
          let lhs_args := collect_add_args lhs
          let rhs_args := collect_add_args rhs
          let common := lhs_args . bagInterₓ rhs_args
          if
            common = [ ]
            then
            return ( )
            else
            do
              let lhs_rest := lhs_args common
                let rhs_rest := rhs_args common
                let new_lhs ← mk_nat_add_add common ( sort_args lhs_rest )
                let new_rhs ← mk_nat_add_add common ( sort_args rhs_rest )
                let lhs_pr ← prove_eq_by_perm lhs new_lhs
                let rhs_pr ← prove_eq_by_perm rhs new_rhs
                let
                  target_pr ← to_expr ` `( congr ( congr_arg ( · < · ) $ ( lhs_pr ) ) $ ( rhs_pr ) )
                let new_target ← to_expr ` `( $ ( new_lhs ) < $ ( new_rhs ) )
                replace_target new_target target_pr ` ` id_tag.wf
                sorry <|> sorry
#align well_founded_tactics.cancel_nat_add_lt well_founded_tactics.cancel_nat_add_lt

-- failed to format: unknown constant 'term.pseudo.antiquot'
unsafe
  def check_target_is_value_lt : tactic Unit := do let q( $ ( lhs ) < $ ( rhs ) ) ← target guard lhs
#align well_founded_tactics.check_target_is_value_lt well_founded_tactics.check_target_is_value_lt

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
unsafe def trivial_nat_lt : tactic Unit :=
  comp_val <|>
    sorry <|>
      sorry <|>
        assumption <|>
          (do
              check_target_is_value_lt
              sorry >> trivial_nat_lt <|> sorry >> trivial_nat_lt) <|>
            failed
#align well_founded_tactics.trivial_nat_lt well_founded_tactics.trivial_nat_lt

end SimpleDecTac

unsafe def default_dec_tac : tactic Unit :=
  abstract do
    clear_internals
    unfold_wf_rel
    -- The next line was adapted from code in mathlib by Scott Morrison.
          -- Because `unfold_sizeof` could actually discharge the goal, add a test
          -- using `done` to detect this.
          process_lex
          (unfold_sizeof >>
            (done <|>
              cancel_nat_add_lt >>
                trivial_nat_lt)) <|>-- Clean up the goal state but not too much before printing the error
          unfold_sizeof >>
          fail "default_dec_tac failed"
#align well_founded_tactics.default_dec_tac well_founded_tactics.default_dec_tac

end WellFoundedTactics

/-- Argument for using_well_founded

  The tactic `rel_tac` has to synthesize an element of type (has_well_founded A).
  The two arguments are: a local representing the function being defined by well
  founded recursion, and a list of recursive equations.
  The equations can be used to decide which well founded relation should be used.

  The tactic `dec_tac` has to synthesize decreasing proofs.
-/
unsafe structure well_founded_tactics where
  rel_tac : expr → List expr → tactic Unit := well_founded_tactics.default_rel_tac
  dec_tac : tactic Unit := well_founded_tactics.default_dec_tac
#align well_founded_tactics well_founded_tactics

unsafe def well_founded_tactics.default : well_founded_tactics where
#align well_founded_tactics.default well_founded_tactics.default


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.big_operators.multiset.basic

/-!
# Bind operation for multisets

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines a few basic operations on `multiset`, notably the monadic bind.

## Main declarations

* `multiset.join`: The join, aka union or sum, of multisets.
* `multiset.bind`: The bind of a multiset-indexed family of multisets.
* `multiset.product`: Cartesian product of two multisets.
* `multiset.sigma`: Disjoint sum of multisets in a sigma type.
-/

variables {α β γ δ : Type*}

namespace multiset

/-! ### Join -/

/-- `join S`, where `S` is a multiset of multisets, is the lift of the list join
  operation, that is, the union of all the sets.
     join {{1, 2}, {1, 2}, {0, 1}} = {0, 1, 1, 1, 2, 2} -/
def join : multiset (multiset α) → multiset α := sum

lemma coe_join : ∀ L : list (list α),
  join (L.map (@coe _ (multiset α) _) : multiset (multiset α)) = L.join
| []       := rfl
| (l :: L) := congr_arg (λ s : multiset α, ↑l + s) (coe_join L)

@[simp]

@[simp] lemma mem_join {a S} : a ∈ @join α S ↔ ∃ s ∈ S, a ∈ s :=
multiset.induction_on S (by simp) $
  by simp [or_and_distrib_right, exists_or_distrib] {contextual := tt}

@[simp] lemma card_join (S) : card (@join α S) = sum (map card S) :=
multiset.induction_on S (by simp) (by simp)

lemma rel_join {r : α → β → Prop} {s t} (h : rel (rel r) s t) : rel r s.join t.join :=
begin
  induction h,
  case rel.zero { simp },
  case rel.cons : a b s t hab hst ih { simpa using hab.add ih }
end

/-! ### Bind -/

section bind
variables (a : α) (s t : multiset α) (f g : α → multiset β)

/-- `s.bind f` is the monad bind operation, defined as `(s.map f).join`. It is the union of `f a` as
`a` ranges over `s`. -/
def bind (s : multiset α) (f : α → multiset β) : multiset β := (s.map f).join

@[simp] lemma coe_bind (l : list α) (f : α → list β) : @bind α β l (λ a, f a) = l.bind f :=
by rw [list.bind, ←coe_join, list.map_map]; refl

@[simp] lemma zero_bind : bind 0 f = 0 := rfl
@[simp] lemma cons_bind : (a ::ₘ s).bind f = f a + s.bind f := by simp [bind]
@[simp] lemma singleton_bind : bind {a} f = f a := by simp [bind]
@[simp] lemma add_bind : (s + t).bind f = s.bind f + t.bind f := by simp [bind]
@[simp] lemma bind_zero : s.bind (λ a, 0 : α → multiset β) = 0 := by simp [bind, join, nsmul_zero]
@[simp] lemma bind_add : s.bind (λ a, f a + g a) = s.bind f + s.bind g := by simp [bind, join]

@[simp] lemma bind_cons (f : α → β) (g : α → multiset β) :
  s.bind (λ a, f a ::ₘ g a) = map f s + s.bind g :=
multiset.induction_on s (by simp) (by simp [add_comm, add_left_comm] {contextual := tt})

@[simp] lemma bind_singleton (f : α → β) : s.bind (λ x, ({f x} : multiset β)) = map f s :=
multiset.induction_on s (by rw [zero_bind, map_zero]) (by simp [singleton_add])

@[simp] lemma mem_bind {b s} {f : α → multiset β} : b ∈ bind s f ↔ ∃ a ∈ s, b ∈ f a :=
by simp [bind]; simp [-exists_and_distrib_right, exists_and_distrib_right.symm];
   rw exists_swap; simp [and_assoc]

@[simp] lemma card_bind : (s.bind f).card = (s.map (card ∘ f)).sum := by simp [bind]

lemma bind_congr {f g : α → multiset β} {m : multiset α} :
  (∀ a ∈ m, f a = g a) → bind m f = bind m g :=
by simp [bind] {contextual := tt}

lemma bind_hcongr {β' : Type*} {m : multiset α} {f : α → multiset β} {f' : α → multiset β'}
  (h : β = β') (hf : ∀a ∈ m, f a == f' a) :
  bind m f == bind m f' :=
begin subst h, simp at hf, simp [bind_congr hf] end

lemma map_bind (m : multiset α) (n : α → multiset β) (f : β → γ) :
  map f (bind m n) = bind m (λ a, map f (n a)) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

lemma bind_map (m : multiset α) (n : β → multiset γ) (f : α → β) :
  bind (map f m) n = bind m (λ a, n (f a)) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

lemma bind_assoc {s : multiset α} {f : α → multiset β} {g : β → multiset γ} :
  (s.bind f).bind g = s.bind (λ a, (f a).bind g) :=
multiset.induction_on s (by simp) (by simp {contextual := tt})

lemma bind_bind (m : multiset α) (n : multiset β) {f : α → β → multiset γ} :
  (bind m $ λ a, bind n $ λ b, f a b) = (bind n $ λ b, bind m $ λ a, f a b) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

lemma bind_map_comm (m : multiset α) (n : multiset β) {f : α → β → γ} :
  (bind m $ λ a, n.map $ λ b, f a b) = (bind n $ λ b, m.map $ λ a, f a b) :=
multiset.induction_on m (by simp) (by simp {contextual := tt})

@[simp, to_additive]
lemma prod_bind [comm_monoid β] (s : multiset α) (t : α → multiset β) :
  (s.bind t).prod = (s.map $ λ a, (t a).prod).prod :=
multiset.induction_on s (by simp) (assume a s ih, by simp [ih, cons_bind])

lemma rel_bind {r : α → β → Prop} {p : γ → δ → Prop} {s t} {f : α → multiset γ} {g : β → multiset δ}
  (h : (r ⇒ rel p) f g) (hst : rel r s t) :
  rel p (s.bind f) (t.bind g) :=
by { apply rel_join, rw rel_map, exact hst.mono (λ a ha b hb hr, h hr) }

lemma count_sum [decidable_eq α] {m : multiset β} {f : β → multiset α} {a : α} :
  count a (map f m).sum = sum (m.map $ λ b, count a $ f b) :=
multiset.induction_on m (by simp) ( by simp)

lemma count_bind [decidable_eq α] {m : multiset β} {f : β → multiset α} {a : α} :
  count a (bind m f) = sum (m.map $ λ b, count a $ f b) := count_sum

lemma le_bind {α β : Type*} {f : α → multiset β} (S : multiset α) {x : α} (hx : x ∈ S) :
  f x ≤ S.bind f :=
begin
  classical,
  rw le_iff_count, intro a,
  rw count_bind, apply le_sum_of_mem,
  rw mem_map, exact ⟨x, hx, rfl⟩
end

@[simp] theorem attach_bind_coe (s : multiset α) (f : α → multiset β) :
  s.attach.bind (λ i, f i) = s.bind f :=
congr_arg join $ attach_map_coe' _ _

end bind

/-! ### Product of two multisets -/

section product
variables (a : α) (b : β) (s : multiset α) (t : multiset β)

/-- The multiplicity of `(a, b)` in `s ×ˢ t` is
  the product of the multiplicity of `a` in `s` and `b` in `t`. -/
def product (s : multiset α) (t : multiset β) : multiset (α × β) := s.bind $ λ a, t.map $ prod.mk a

/- This notation binds more strongly than (pre)images, unions and intersections. -/
infixr (name := multiset.product) ` ×ˢ `:82 := multiset.product

@[simp] lemma coe_product (l₁ : list α) (l₂ : list β) : @product α β l₁ l₂ = l₁.product l₂ :=
by { rw [product, list.product, ←coe_bind], simp }

@[simp] lemma zero_product : @product α β 0 t = 0 := rfl
@[simp] lemma cons_product : (a ::ₘ s) ×ˢ t = map (prod.mk a) t + s ×ˢ t := by simp [product]
@[simp] lemma product_zero : s ×ˢ (0 : multiset β) = 0 := by simp [product]
@[simp] lemma product_cons : s ×ˢ (b ::ₘ t) = s.map (λ a, (a, b)) + s ×ˢ t := by simp [product]

@[simp] lemma product_singleton : ({a} : multiset α) ×ˢ ({b} : multiset β) = {(a, b)} :=
by simp only [product, bind_singleton, map_singleton]

@[simp] lemma add_product (s t : multiset α) (u : multiset β) : (s + t) ×ˢ u = s ×ˢ u + t ×ˢ u :=
by simp [product]

@[simp] lemma product_add (s : multiset α) : ∀ t u : multiset β, s ×ˢ (t + u) = s ×ˢ t + s ×ˢ u :=
multiset.induction_on s (λ t u, rfl) $ λ a s IH t u,
  by rw [cons_product, IH]; simp; cc

@[simp] lemma mem_product {s t} : ∀ {p : α × β}, p ∈ @product α β s t ↔ p.1 ∈ s ∧ p.2 ∈ t
| (a, b) := by simp [product, and.left_comm]

@[simp] lemma card_product : (s ×ˢ t).card = s.card * t.card := by simp [product]

end product

/-! ### Disjoint sum of multisets -/

section sigma
variables {σ : α → Type*} (a : α) (s : multiset α) (t : Π a, multiset (σ a))

/-- `sigma s t` is the dependent version of `product`. It is the sum of
  `(a, b)` as `a` ranges over `s` and `b` ranges over `t a`. -/
protected def sigma (s : multiset α) (t : Π a, multiset (σ a)) : multiset (Σ a, σ a) :=
s.bind $ λ a, (t a).map $ sigma.mk a

@[simp] lemma coe_sigma (l₁ : list α) (l₂ : Π a, list (σ a)) :
  @multiset.sigma α σ l₁ (λ a, l₂ a) = l₁.sigma l₂ :=
by rw [multiset.sigma, list.sigma, ←coe_bind]; simp

@[simp] lemma zero_sigma : @multiset.sigma α σ 0 t = 0 := rfl

@[simp] lemma cons_sigma : (a ::ₘ s).sigma t = (t a).map (sigma.mk a) + s.sigma t :=
by simp [multiset.sigma]

@[simp] lemma sigma_singleton (b : α → β) :
  ({a} : multiset α).sigma (λ a, ({b a} : multiset β)) = {⟨a, b a⟩} := rfl

@[simp] lemma add_sigma (s t : multiset α) (u : Π a, multiset (σ a)) :
  (s + t).sigma u = s.sigma u + t.sigma u :=
by simp [multiset.sigma]

@[simp] lemma sigma_add : ∀ t u : Π a, multiset (σ a),
  s.sigma (λ a, t a + u a) = s.sigma t + s.sigma u :=
multiset.induction_on s (λ t u, rfl) $ λ a s IH t u,
  by rw [cons_sigma, IH]; simp; cc

@[simp] lemma mem_sigma {s t} : ∀ {p : Σ a, σ a},
  p ∈ @multiset.sigma α σ s t ↔ p.1 ∈ s ∧ p.2 ∈ t p.1
| ⟨a, b⟩ := by simp [multiset.sigma, and_assoc, and.left_comm]

@[simp] lemma card_sigma :
  card (s.sigma t) = sum (map (λ a, card (t a)) s) :=
by simp [multiset.sigma, (∘)]

end sigma
end multiset


import .vec_space
import group_theory.subgroup
import data.finset
import algebra.big_operators
import algebra.pointwise
--import ring_theory.polynomial.basic

open_locale big_operators classical

namespace vec_space

universes u v w x

open subgroup

structure subspace (F : Type u) (α : Type v) [field F] [add_comm_group α] [vec_space F α] extends add_subgroup α :=
(smul_mem : ∀ (a : F) {x}, x ∈ carrier → a • x ∈ carrier)

namespace subspace

variables (F : Type u) (α : Type v) [field F] [add_comm_group α] [vec_space F α] (β : subspace F α)

--instance : has_coe_t (subspace F β) (set β) := ⟨λ s, s.carrier⟩
instance : has_coe (subspace F α) (add_subgroup α) := { coe := subspace.to_add_subgroup }

/-instance : has_coe_t (subspace F β) (set β) := ⟨λ s, s.carrier⟩
instance : has_mem M (submodule R M) := ⟨λ x p, x ∈ (p : set M)⟩
instance : has_coe_to_sort (submodule R M) := ⟨_, λ p, {x : M // x ∈ p}⟩

instance : has_add β := ⟨λx y, ⟨x.1 + y.1, add_mem _ x.2 y.2⟩⟩
instance : has_zero p := ⟨⟨0, zero_mem _⟩⟩
instance : inhabited p := ⟨0⟩
instance : has_scalar R p := ⟨λ c x, ⟨c • x.1, smul_mem _ c x.2⟩⟩-/

/-begin
    intros a b,
    refine ⟨a • b, _⟩,
    exact subspace.smul_mem β a b.2, -- b.2 proving that a thing is a subtype
end,-/

instance to_vec_space (F : Type u) (α : Type v) [field F] [add_comm_group α] [vec_space F α](β : subspace F α) : vec_space F β :=
{ smul := λ a b, ⟨a • b, β.smul_mem a b.2⟩,
  smul_add := λ r a b, subtype.eq (vec_space.smul_add r a b),
  add_smul := λ r s a, subtype.eq (vec_space.add_smul r s a),
  mul_smul := λ r s a, subtype.eq (vec_space.mul_smul r s a),
  one_smul := λ a, subtype.eq (vec_space.one_smul a) }

lemma sum_mem_sum (S : finset (subspace F α)) (f : subspace F α → α)
  (hf : ∀ x ∈ S, f x ∈ x.carrier) :
  (∑ x in S, f x) ∈ (∑ x in S, x : set α) :=
begin
    -- ∀ Uᵢ ∈ {U₁, ..., U_m}, f(x) ∈ Uᵢ
    -- u₁ + ... + u_m ∈ U₁ + ... + U_m
    revert hf,
    apply finset.induction_on S,
    rw finset.sum_empty,
    rw finset.sum_empty,
    intro hyp,
    exact set.zero_mem_zero,
    intros β s hyp IH hyp2,
    rw finset.forall_mem_insert at hyp2,
    cases hyp2 with hyp2 hyp3,
    rw finset.sum_insert hyp,
    rw finset.sum_insert hyp,
    apply set.add_mem_add,
    exact hyp2,
    apply IH,
    exact hyp3,
    --sorry,
end

/-lemma sum_mem_sum' (S : finset (subspace F α)) (u : α)
  (hu : u ∈ (∑ x in S, x : set α)) :
  ∃ (f : subspace F α → α), (∀ x ∈ S, f x ∈ x.carrier) ∧ u = (∑ x in S, f x) :=
begin -- u ∈ U₁ + ... + U_m then u = ∑ uᵢ for uᵢ ∈ Uᵢ
-- ∀ Uᵢ, ∃ uᵢ s.t.
    revert hu,
    revert u,
    apply finset.induction_on S,
    rw finset.sum_empty,
    --rw finset.sum_empty,
    intros u hyp3,
    use λ x, 0,
    split,
    intros x hyp2,
    exact add_subgroup.zero_mem x,

    rw finset.sum_const_zero,
    rw set.mem_zero at hyp3,
    exact hyp3,

    intros a s hyp2 IH u hyp3,
    rw finset.sum_insert hyp2 at hyp3,
    rw set.mem_add at hyp3,
    rcases hyp3 with ⟨b, c, hyp3, hyp4, hyp5⟩,
    specialize IH c hyp4,
    refine ⟨_, _, _⟩,
    intro d,
    use b, -- function that maps a to b
    --intros x hyp6,
    intros x hyp7,
    rw finset.mem_insert,
    --have hyp7 : if x ∈ s then f x else b,
    --if x ∈ s then f x else b, if_pos, if_neg
end-/

/-def subspace_sum (S : finset (subspace F α)) : subspace F α :=
{
  carrier := ∑ x in S, x,
  --{y | ∃ f : (Π x : subspace F α, x ∈ S → x), (∑ x in S.attach, f x x.2 : α) = y} ,
  -- {u₁ + ... + u_m : u₁ ∈ U₁, ..., u_m ∈ U_m}
  zero_mem' :=
  begin
    convert sum_mem_sum F α S (λ x, 0) (λ x hyp, add_subgroup.zero_mem x),
    rw finset.sum_const_zero,
  end,
  add_mem' := λ a b hyp hyp2, _,
  neg_mem' := _,
  smul_mem := _ }-/

/-def add (s : finset (subspace F α)) : subspace F α :=
{y | ∃ (f : Π (i : (↑s : set (subspace F α))), i), y = ∑ x in (↑s : set (subspace F α)), f x}-/

end subspace

end vec_space


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Sébastien Gouëzel, Zhouhang Zhou, Reid Barton
-/
import logic.equiv.fin
import topology.dense_embedding
import topology.support

/-!
# Homeomorphisms

This file defines homeomorphisms between two topological spaces. They are bijections with both
directions continuous. We denote homeomorphisms with the notation `≃ₜ`.

# Main definitions

* `homeomorph α β`: The type of homeomorphisms from `α` to `β`.
  This type can be denoted using the following notation: `α ≃ₜ β`.

# Main results

* Pretty much every topological property is preserved under homeomorphisms.
* `homeomorph.homeomorph_of_continuous_open`: A continuous bijection that is
  an open map is a homeomorphism.

-/

open set filter
open_locale topological_space

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

/-- Homeomorphism between `α` and `β`, also called topological isomorphism -/
@[nolint has_inhabited_instance] -- not all spaces are homeomorphic to each other
structure homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends α ≃ β :=
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')
(continuous_inv_fun : continuous inv_fun . tactic.interactive.continuity')

infix ` ≃ₜ `:25 := homeomorph

namespace homeomorph
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

instance : has_coe_to_fun (α ≃ₜ β) (λ _, α → β) := ⟨λe, e.to_equiv⟩

@[simp] lemma homeomorph_mk_coe (a : equiv α β) (b c) :
  ((homeomorph.mk a b c) : α → β) = a :=
rfl

/-- Inverse of a homeomorphism. -/
protected def symm (h : α ≃ₜ β) : β ≃ₜ α :=
{ continuous_to_fun  := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  to_equiv := h.to_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : α ≃ₜ β) : α → β := h
/-- See Note [custom simps projection] -/
def simps.symm_apply (h : α ≃ₜ β) : β → α := h.symm

initialize_simps_projections homeomorph
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

@[simp] lemma coe_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv = h := rfl
@[simp] lemma coe_symm_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv.symm = h.symm := rfl

lemma to_equiv_injective : function.injective (to_equiv : α ≃ₜ β → α ≃ β)
| ⟨e, h₁, h₂⟩ ⟨e', h₁', h₂'⟩ rfl := rfl

@[ext] lemma ext {h h' : α ≃ₜ β} (H : ∀ x, h x = h' x) : h = h' :=
to_equiv_injective $ equiv.ext H

/-- Identity map as a homeomorphism. -/
@[simps apply {fully_applied := ff}]
protected def refl (α : Type*) [topological_space α] : α ≃ₜ α :=
{ continuous_to_fun := continuous_id,
  continuous_inv_fun := continuous_id,
  to_equiv := equiv.refl α }

/-- Composition of two homeomorphisms. -/
protected def trans (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
{ continuous_to_fun  := h₂.continuous_to_fun.comp h₁.continuous_to_fun,
  continuous_inv_fun := h₁.continuous_inv_fun.comp h₂.continuous_inv_fun,
  to_equiv := equiv.trans h₁.to_equiv h₂.to_equiv }

@[simp] lemma trans_apply (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) (a : α) : h₁.trans h₂ a = h₂ (h₁ a) := rfl

@[simp] lemma homeomorph_mk_coe_symm (a : equiv α β) (b c) :
  ((homeomorph.mk a b c).symm : β → α) = a.symm :=
rfl

@[simp] lemma refl_symm : (homeomorph.refl α).symm = homeomorph.refl α := rfl

@[continuity]
protected lemma continuous (h : α ≃ₜ β) : continuous h := h.continuous_to_fun

@[continuity] -- otherwise `by continuity` can't prove continuity of `h.to_equiv.symm`
protected lemma continuous_symm (h : α ≃ₜ β) : continuous (h.symm) := h.continuous_inv_fun

@[simp] lemma apply_symm_apply (h : α ≃ₜ β) (x : β) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (h : α ≃ₜ β) (x : α) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

protected lemma bijective (h : α ≃ₜ β) : function.bijective h := h.to_equiv.bijective
protected lemma injective (h : α ≃ₜ β) : function.injective h := h.to_equiv.injective
protected lemma surjective (h : α ≃ₜ β) : function.surjective h := h.to_equiv.surjective

/-- Change the homeomorphism `f` to make the inverse function definitionally equal to `g`. -/
def change_inv (f : α ≃ₜ β) (g : β → α) (hg : function.right_inverse g f) : α ≃ₜ β :=
have g = f.symm, from funext (λ x, calc g x = f.symm (f (g x)) : (f.left_inv (g x)).symm
                                        ... = f.symm x : by rw hg x),
{ to_fun := f,
  inv_fun := g,
  left_inv := by convert f.left_inv,
  right_inv := by convert f.right_inv,
  continuous_to_fun := f.continuous,
  continuous_inv_fun := by convert f.symm.continuous }

@[simp] lemma symm_comp_self (h : α ≃ₜ β) : ⇑h.symm ∘ ⇑h = id :=
funext h.symm_apply_apply

@[simp] lemma self_comp_symm (h : α ≃ₜ β) : ⇑h ∘ ⇑h.symm = id :=
funext h.apply_symm_apply

@[simp] lemma range_coe (h : α ≃ₜ β) : range h = univ :=
h.surjective.range_eq

lemma image_symm (h : α ≃ₜ β) : image h.symm = preimage h :=
funext h.symm.to_equiv.image_eq_preimage

lemma preimage_symm (h : α ≃ₜ β) : preimage h.symm = image h :=
(funext h.to_equiv.image_eq_preimage).symm

@[simp] lemma image_preimage (h : α ≃ₜ β) (s : set β) : h '' (h ⁻¹' s) = s :=
h.to_equiv.image_preimage s

@[simp] lemma preimage_image (h : α ≃ₜ β) (s : set α) : h ⁻¹' (h '' s) = s :=
h.to_equiv.preimage_image s

protected lemma inducing (h : α ≃ₜ β) : inducing h :=
inducing_of_inducing_compose h.continuous h.symm.continuous $
  by simp only [symm_comp_self, inducing_id]

lemma induced_eq (h : α ≃ₜ β) : topological_space.induced h ‹_› = ‹_› := h.inducing.1.symm

protected lemma quotient_map (h : α ≃ₜ β) : quotient_map h :=
quotient_map.of_quotient_map_compose h.symm.continuous h.continuous $
  by simp only [self_comp_symm, quotient_map.id]

lemma coinduced_eq (h : α ≃ₜ β) : topological_space.coinduced h ‹_› = ‹_› :=
h.quotient_map.2.symm

protected lemma embedding (h : α ≃ₜ β) : embedding h :=
⟨h.inducing, h.injective⟩

/-- Homeomorphism given an embedding. -/
noncomputable def of_embedding (f : α → β) (hf : embedding f) : α ≃ₜ (set.range f) :=
{ continuous_to_fun := continuous_subtype_mk _ hf.continuous,
  continuous_inv_fun := by simp [hf.continuous_iff, continuous_subtype_coe],
  .. equiv.of_injective f hf.inj }

protected lemma second_countable_topology [topological_space.second_countable_topology β]
  (h : α ≃ₜ β) :
  topological_space.second_countable_topology α :=
h.inducing.second_countable_topology

lemma compact_image {s : set α} (h : α ≃ₜ β) : is_compact (h '' s) ↔ is_compact s :=
h.embedding.is_compact_iff_is_compact_image.symm

lemma compact_preimage {s : set β} (h : α ≃ₜ β) : is_compact (h ⁻¹' s) ↔ is_compact s :=
by rw ← image_symm; exact h.symm.compact_image

@[simp] lemma comap_cocompact (h : α ≃ₜ β) : comap h (cocompact β) = cocompact α :=
(comap_cocompact_le h.continuous).antisymm $
  (has_basis_cocompact.le_basis_iff (has_basis_cocompact.comap h)).2 $ λ K hK,
    ⟨h ⁻¹' K, h.compact_preimage.2 hK, subset.rfl⟩

@[simp] lemma map_cocompact (h : α ≃ₜ β) : map h (cocompact α) = cocompact β :=
by rw [← h.comap_cocompact, map_comap_of_surjective h.surjective]

protected lemma compact_space [compact_space α] (h : α ≃ₜ β) : compact_space β :=
{ compact_univ := by { rw [← image_univ_of_surjective h.surjective, h.compact_image],
    apply compact_space.compact_univ } }

protected lemma t0_space [t0_space α] (h : α ≃ₜ β) : t0_space β :=
h.symm.embedding.t0_space

protected lemma t1_space [t1_space α] (h : α ≃ₜ β) : t1_space β :=
h.symm.embedding.t1_space

protected lemma t2_space [t2_space α] (h : α ≃ₜ β) : t2_space β :=
h.symm.embedding.t2_space

protected lemma regular_space [regular_space α] (h : α ≃ₜ β) : regular_space β :=
h.symm.embedding.regular_space

protected lemma dense_embedding (h : α ≃ₜ β) : dense_embedding h :=
{ dense   := h.surjective.dense_range,
  .. h.embedding }

@[simp] lemma is_open_preimage (h : α ≃ₜ β) {s : set β} : is_open (h ⁻¹' s) ↔ is_open s :=
h.quotient_map.is_open_preimage

@[simp] lemma is_open_image (h : α ≃ₜ β) {s : set α} : is_open (h '' s) ↔ is_open s :=
by rw [← preimage_symm, is_open_preimage]

protected lemma is_open_map (h : α ≃ₜ β) : is_open_map h := λ s, h.is_open_image.2

@[simp] lemma is_closed_preimage (h : α ≃ₜ β) {s : set β} : is_closed (h ⁻¹' s) ↔ is_closed s :=
by simp only [← is_open_compl_iff, ← preimage_compl, is_open_preimage]

@[simp] lemma is_closed_image (h : α ≃ₜ β) {s : set α} : is_closed (h '' s) ↔ is_closed s :=
by rw [← preimage_symm, is_closed_preimage]

protected lemma is_closed_map (h : α ≃ₜ β) : is_closed_map h := λ s, h.is_closed_image.2

protected lemma open_embedding (h : α ≃ₜ β) : open_embedding h :=
open_embedding_of_embedding_open h.embedding h.is_open_map

protected lemma closed_embedding (h : α ≃ₜ β) : closed_embedding h :=
closed_embedding_of_embedding_closed h.embedding h.is_closed_map

protected lemma normal_space [normal_space α] (h : α ≃ₜ β) : normal_space β :=
h.symm.closed_embedding.normal_space

lemma preimage_closure (h : α ≃ₜ β) (s : set β) : h ⁻¹' (closure s) = closure (h ⁻¹' s) :=
h.is_open_map.preimage_closure_eq_closure_preimage h.continuous _

lemma image_closure (h : α ≃ₜ β) (s : set α) : h '' (closure s) = closure (h '' s) :=
by rw [← preimage_symm, preimage_closure]

lemma image_interior (h : α ≃ₜ β) (s : set α) : h '' (interior s) = interior (h '' s) :=
by rw [← preimage_symm, preimage_interior]

lemma preimage_frontier (h : α ≃ₜ β) (s : set β) : h ⁻¹' (frontier s) = frontier (h ⁻¹' s) :=
h.is_open_map.preimage_frontier_eq_frontier_preimage h.continuous _

@[to_additive]
lemma _root_.has_compact_mul_support.comp_homeomorph {M} [has_one M] {f : β → M}
  (hf : has_compact_mul_support f) (φ : α ≃ₜ β) : has_compact_mul_support (f ∘ φ) :=
hf.comp_closed_embedding φ.closed_embedding

@[simp] lemma map_nhds_eq (h : α ≃ₜ β) (x : α) : map h (𝓝 x) = 𝓝 (h x) :=
h.embedding.map_nhds_of_mem _ (by simp)

lemma symm_map_nhds_eq (h : α ≃ₜ β) (x : α) : map h.symm (𝓝 (h x)) = 𝓝 x :=
by rw [h.symm.map_nhds_eq, h.symm_apply_apply]

lemma nhds_eq_comap (h : α ≃ₜ β) (x : α) : 𝓝 x = comap h (𝓝 (h x)) :=
h.embedding.to_inducing.nhds_eq_comap x

@[simp] lemma comap_nhds_eq (h : α ≃ₜ β) (y : β) : comap h (𝓝 y) = 𝓝 (h.symm y) :=
by rw [h.nhds_eq_comap, h.apply_symm_apply]

/-- If an bijective map `e : α ≃ β` is continuous and open, then it is a homeomorphism. -/
def homeomorph_of_continuous_open (e : α ≃ β) (h₁ : continuous e) (h₂ : is_open_map e) :
  α ≃ₜ β :=
{ continuous_to_fun := h₁,
  continuous_inv_fun := begin
    rw continuous_def,
    intros s hs,
    convert ← h₂ s hs using 1,
    apply e.image_eq_preimage
  end,
  to_equiv := e }

@[simp] lemma comp_continuous_on_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) :
  continuous_on (h ∘ f) s ↔ continuous_on f s :=
h.inducing.continuous_on_iff.symm

@[simp] lemma comp_continuous_iff (h : α ≃ₜ β) {f : γ → α} :
  continuous (h ∘ f) ↔ continuous f :=
h.inducing.continuous_iff.symm

@[simp] lemma comp_continuous_iff' (h : α ≃ₜ β) {f : β → γ} :
  continuous (f ∘ h) ↔ continuous f :=
h.quotient_map.continuous_iff.symm

lemma comp_continuous_at_iff (h : α ≃ₜ β) (f : γ → α) (x : γ) :
  continuous_at (h ∘ f) x ↔ continuous_at f x :=
h.inducing.continuous_at_iff.symm

lemma comp_continuous_at_iff' (h : α ≃ₜ β) (f : β → γ) (x : α) :
  continuous_at (f ∘ h) x ↔ continuous_at f (h x) :=
h.inducing.continuous_at_iff' (by simp)

lemma comp_continuous_within_at_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) (x : γ) :
  continuous_within_at f s x ↔ continuous_within_at (h ∘ f) s x :=
h.inducing.continuous_within_at_iff

@[simp] lemma comp_is_open_map_iff (h : α ≃ₜ β) {f : γ → α} :
  is_open_map (h ∘ f) ↔ is_open_map f :=
begin
  refine ⟨_, λ hf, h.is_open_map.comp hf⟩,
  intros hf,
  rw [← function.comp.left_id f, ← h.symm_comp_self, function.comp.assoc],
  exact h.symm.is_open_map.comp hf,
end

@[simp] lemma comp_is_open_map_iff' (h : α ≃ₜ β) {f : β → γ} :
  is_open_map (f ∘ h) ↔ is_open_map f :=
begin
  refine ⟨_, λ hf, hf.comp h.is_open_map⟩,
  intros hf,
  rw [← function.comp.right_id f, ← h.self_comp_symm, ← function.comp.assoc],
  exact hf.comp h.symm.is_open_map,
end

/-- If two sets are equal, then they are homeomorphic. -/
def set_congr {s t : set α} (h : s = t) : s ≃ₜ t :=
{ continuous_to_fun := continuous_subtype_mk _ continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ continuous_subtype_val,
  to_equiv := equiv.set_congr h }

/-- Sum of two homeomorphisms. -/
def sum_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α ⊕ γ ≃ₜ β ⊕ δ :=
{ continuous_to_fun  :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.continuous)
      (continuous_inr.comp h₂.continuous),
    ext x, cases x; refl,
  end,
  continuous_inv_fun :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.symm.continuous)
      (continuous_inr.comp h₂.symm.continuous),
    ext x, cases x; refl
  end,
  to_equiv := h₁.to_equiv.sum_congr h₂.to_equiv }

/-- Product of two homeomorphisms. -/
def prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α × γ ≃ₜ β × δ :=
{ continuous_to_fun  := (h₁.continuous.comp continuous_fst).prod_mk
    (h₂.continuous.comp continuous_snd),
  continuous_inv_fun := (h₁.symm.continuous.comp continuous_fst).prod_mk
    (h₂.symm.continuous.comp continuous_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (α β γ)

/-- `α × β` is homeomorphic to `β × α`. -/
def prod_comm : α × β ≃ₜ β × α :=
{ continuous_to_fun  := continuous_snd.prod_mk continuous_fst,
  continuous_inv_fun := continuous_snd.prod_mk continuous_fst,
  to_equiv := equiv.prod_comm α β }

@[simp] lemma prod_comm_symm : (prod_comm α β).symm = prod_comm β α := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm α β) = prod.swap := rfl

/-- `(α × β) × γ` is homeomorphic to `α × (β × γ)`. -/
def prod_assoc : (α × β) × γ ≃ₜ α × (β × γ) :=
{ continuous_to_fun  := (continuous_fst.comp continuous_fst).prod_mk
    ((continuous_snd.comp continuous_fst).prod_mk continuous_snd),
  continuous_inv_fun := (continuous_fst.prod_mk (continuous_fst.comp continuous_snd)).prod_mk
    (continuous_snd.comp continuous_snd),
  to_equiv := equiv.prod_assoc α β γ }

/-- `α × {*}` is homeomorphic to `α`. -/
@[simps apply {fully_applied := ff}]
def prod_punit : α × punit ≃ₜ α :=
{ to_equiv := equiv.prod_punit α,
  continuous_to_fun := continuous_fst,
  continuous_inv_fun := continuous_id.prod_mk continuous_const }

/-- `{*} × α` is homeomorphic to `α`. -/
def punit_prod : punit × α ≃ₜ α :=
(prod_comm _ _).trans (prod_punit _)

@[simp] lemma coe_punit_prod : ⇑(punit_prod α) = prod.snd := rfl

end

/-- `ulift α` is homeomorphic to `α`. -/
def {u v} ulift {α : Type u} [topological_space α] : ulift.{v u} α ≃ₜ α :=
{ continuous_to_fun := continuous_ulift_down,
  continuous_inv_fun := continuous_ulift_up,
  to_equiv := equiv.ulift }

section distrib

/-- `(α ⊕ β) × γ` is homeomorphic to `α × γ ⊕ β × γ`. -/
def sum_prod_distrib : (α ⊕ β) × γ ≃ₜ α × γ ⊕ β × γ :=
begin
  refine (homeomorph.homeomorph_of_continuous_open (equiv.sum_prod_distrib α β γ).symm _ _).symm,
  { convert continuous_sum_rec
      ((continuous_inl.comp continuous_fst).prod_mk continuous_snd)
      ((continuous_inr.comp continuous_fst).prod_mk continuous_snd),
    ext1 x, cases x; refl, },
  { exact (is_open_map_sum
    (open_embedding_inl.prod open_embedding_id).is_open_map
    (open_embedding_inr.prod open_embedding_id).is_open_map) }
end

/-- `α × (β ⊕ γ)` is homeomorphic to `α × β ⊕ α × γ`. -/
def prod_sum_distrib : α × (β ⊕ γ) ≃ₜ α × β ⊕ α × γ :=
(prod_comm _ _).trans $
sum_prod_distrib.trans $
sum_congr (prod_comm _ _) (prod_comm _ _)

variables {ι : Type*} {σ : ι → Type*} [Π i, topological_space (σ i)]

/-- `(Σ i, σ i) × β` is homeomorphic to `Σ i, (σ i × β)`. -/
def sigma_prod_distrib : ((Σ i, σ i) × β) ≃ₜ (Σ i, (σ i × β)) :=
homeomorph.symm $
homeomorph_of_continuous_open (equiv.sigma_prod_distrib σ β).symm
  (continuous_sigma $ λ i,
    (continuous_sigma_mk.comp continuous_fst).prod_mk continuous_snd)
  (is_open_map_sigma $ λ i,
    (open_embedding_sigma_mk.prod open_embedding_id).is_open_map)

end distrib

/-- If `ι` has a unique element, then `ι → α` is homeomorphic to `α`. -/
@[simps { fully_applied := ff }]
def fun_unique (ι α : Type*) [unique ι] [topological_space α] : (ι → α) ≃ₜ α :=
{ to_equiv := equiv.fun_unique ι α,
  continuous_to_fun := continuous_apply _,
  continuous_inv_fun := continuous_pi (λ _, continuous_id) }

/-- Homeomorphism between dependent functions `Π i : fin 2, α i` and `α 0 × α 1`. -/
@[simps { fully_applied := ff }]
def {u} pi_fin_two (α : fin 2 → Type u) [Π i, topological_space (α i)] : (Π i, α i) ≃ₜ α 0 × α 1 :=
{ to_equiv := pi_fin_two_equiv α,
  continuous_to_fun := (continuous_apply 0).prod_mk (continuous_apply 1),
  continuous_inv_fun := continuous_pi $ fin.forall_fin_two.2 ⟨continuous_fst, continuous_snd⟩ }

/-- Homeomorphism between `α² = fin 2 → α` and `α × α`. -/
@[simps { fully_applied := ff }] def fin_two_arrow : (fin 2 → α) ≃ₜ α × α :=
{ to_equiv := fin_two_arrow_equiv α, ..  pi_fin_two (λ _, α) }

/--
A subset of a topological space is homeomorphic to its image under a homeomorphism.
-/
@[simps] def image (e : α ≃ₜ β) (s : set α) : s ≃ₜ e '' s :=
{ continuous_to_fun := by continuity!,
  continuous_inv_fun := by continuity!,
  to_equiv := e.to_equiv.image s, }

/-- `set.univ α` is homeomorphic to `α`. -/
@[simps { fully_applied := ff }]
def set.univ (α : Type*) [topological_space α] : (univ : set α) ≃ₜ α :=
{ to_equiv := equiv.set.univ α,
  continuous_to_fun := continuous_subtype_coe,
  continuous_inv_fun := continuous_subtype_mk _ continuous_id }

end homeomorph

/-- An inducing equiv between topological spaces is a homeomorphism. -/
@[simps] def equiv.to_homeomorph_of_inducing [topological_space α] [topological_space β] (f : α ≃ β)
  (hf : inducing f) :
  α ≃ₜ β :=
{ continuous_to_fun := hf.continuous,
  continuous_inv_fun := hf.continuous_iff.2 $ by simpa using continuous_id,
  .. f }

namespace continuous
variables [topological_space α] [topological_space β]

lemma continuous_symm_of_equiv_compact_to_t2 [compact_space α] [t2_space β]
  {f : α ≃ β} (hf : continuous f) : continuous f.symm :=
begin
  rw continuous_iff_is_closed,
  intros C hC,
  have hC' : is_closed (f '' C) := (hC.is_compact.image hf).is_closed,
  rwa equiv.image_eq_preimage at hC',
end

/-- Continuous equivalences from a compact space to a T2 space are homeomorphisms.

This is not true when T2 is weakened to T1
(see `continuous.homeo_of_equiv_compact_to_t2.t1_counterexample`). -/
@[simps]
def homeo_of_equiv_compact_to_t2 [compact_space α] [t2_space β]
  {f : α ≃ β} (hf : continuous f) : α ≃ₜ β :=
{ continuous_to_fun := hf,
  continuous_inv_fun := hf.continuous_symm_of_equiv_compact_to_t2,
  ..f }

end continuous


/-
Copyright (c) 2022 Joachim Breitner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joachim Breitner
-/
import group_theory.order_of_element
import data.finset.noncomm_prod
import data.fintype.big_operators
import data.nat.gcd.big_operators
import order.sup_indep

/-!
# Canonical homomorphism from a finite family of monoids

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines the construction of the canonical homomorphism from a family of monoids.

Given a family of morphisms `ϕ i : N i →* M` for each `i : ι` where elements in the
images of different morphisms commute, we obtain a canonical morphism
`monoid_hom.noncomm_pi_coprod : (Π i, N i) →* M` that coincides with `ϕ`

## Main definitions

* `monoid_hom.noncomm_pi_coprod : (Π i, N i) →* M` is the main homomorphism
* `subgroup.noncomm_pi_coprod : (Π i, H i) →* G` is the specialization to `H i : subgroup G`
   and the subgroup embedding.

## Main theorems

* `monoid_hom.noncomm_pi_coprod` coincides with `ϕ i` when restricted to `N i`
* `monoid_hom.noncomm_pi_coprod_mrange`: The range of `monoid_hom.noncomm_pi_coprod` is
  `⨆ (i : ι), (ϕ i).mrange`
* `monoid_hom.noncomm_pi_coprod_range`: The range of `monoid_hom.noncomm_pi_coprod` is
  `⨆ (i : ι), (ϕ i).range`
* `subgroup.noncomm_pi_coprod_range`: The range of `subgroup.noncomm_pi_coprod` is `⨆ (i : ι), H i`.
* `monoid_hom.injective_noncomm_pi_coprod_of_independent`: in the case of groups, `pi_hom.hom` is
   injective if the `ϕ` are injective and the ranges of the `ϕ` are independent.
* `monoid_hom.independent_range_of_coprime_order`: If the `N i` have coprime orders, then the ranges
   of the `ϕ` are independent.
* `subgroup.independent_of_coprime_order`: If commuting normal subgroups `H i` have coprime orders,
   they are independent.

-/

open_locale big_operators

namespace subgroup

variables {G : Type*} [group G]

/-- `finset.noncomm_prod` is “injective” in `f` if `f` maps into independent subgroups.  This
generalizes (one direction of) `subgroup.disjoint_iff_mul_eq_one`. -/
@[to_additive "`finset.noncomm_sum` is “injective” in `f` if `f` maps into independent subgroups.
This generalizes (one direction of) `add_subgroup.disjoint_iff_add_eq_zero`. "]
lemma eq_one_of_noncomm_prod_eq_one_of_independent {ι : Type*} (s : finset ι) (f : ι → G) (comm)
  (K : ι → subgroup G) (hind : complete_lattice.independent K) (hmem : ∀ (x ∈ s), f x ∈ K x)
  (heq1 : s.noncomm_prod f comm = 1) : ∀ (i ∈ s), f i = 1 :=
begin
  classical,
  revert heq1,
  induction s using finset.induction_on with i s hnmem ih,
  { simp, },
  { have hcomm := comm.mono (finset.coe_subset.2 $ finset.subset_insert _ _),
    simp only [finset.forall_mem_insert] at hmem,
    have hmem_bsupr: s.noncomm_prod f hcomm ∈ ⨆ (i ∈ (s : set ι)), K i,
    { refine subgroup.noncomm_prod_mem _ _ _,
      intros x hx,
      have : K x ≤ ⨆ (i ∈ (s : set ι)), K i := le_supr₂ x hx,
      exact this (hmem.2 x hx), },
    intro heq1,
    rw finset.noncomm_prod_insert_of_not_mem _ _ _ _ hnmem at heq1,
    have hnmem' : i ∉ (s : set ι), by simpa,
    obtain ⟨heq1i : f i = 1, heq1S : s.noncomm_prod f _ = 1⟩ :=
      subgroup.disjoint_iff_mul_eq_one.mp (hind.disjoint_bsupr hnmem') hmem.1 hmem_bsupr heq1,
    intros i h,
    simp only [finset.mem_insert] at h,
    rcases h with ⟨rfl | _⟩,
    { exact heq1i },
    { exact ih hcomm hmem.2 heq1S _ h } }
end

end subgroup

section family_of_monoids

variables {M : Type*} [monoid M]

-- We have a family of monoids
-- The fintype assumption is not always used, but declared here, to keep things in order
variables {ι : Type*} [hdec : decidable_eq ι] [fintype ι]
variables {N : ι → Type*} [∀ i, monoid (N i)]

-- And morphisms ϕ into G
variables (ϕ : Π (i : ι), N i →* M)

-- We assume that the elements of different morphism commute
variables (hcomm : pairwise $ λ i j, ∀ x y, commute (ϕ i x) (ϕ j y))
include hcomm

-- We use `f` and `g` to denote elements of `Π (i : ι), N i`
variables (f g : Π (i : ι), N i)

namespace monoid_hom

/-- The canonical homomorphism from a family of monoids. -/
@[to_additive "The canonical homomorphism from a family of additive monoids.

See also `linear_map.lsum` for a linear version without the commutativity assumption."]
def noncomm_pi_coprod : (Π (i : ι), N i) →* M :=
{ to_fun := λ f, finset.univ.noncomm_prod (λ i, ϕ i (f i)) $ λ i _ j _ h, hcomm h _ _,
  map_one' := by {apply (finset.noncomm_prod_eq_pow_card _ _ _ _ _).trans (one_pow _), simp},
  map_mul' := λ f g,
  begin
    classical,
    convert @finset.noncomm_prod_mul_distrib _ _ _ _ (λ i, ϕ i (f i)) (λ i, ϕ i (g i)) _ _ _,
    { ext i, exact map_mul (ϕ i) (f i) (g i), },
    { rintros i - j - h, exact hcomm h _ _ },
  end }

variable {hcomm}

include hdec

@[simp, to_additive]
lemma noncomm_pi_coprod_mul_single (i : ι) (y : N i):
  noncomm_pi_coprod ϕ hcomm (pi.mul_single i y) = ϕ i y :=
begin
  change finset.univ.noncomm_prod (λ j, ϕ j (pi.mul_single i y j)) _ = ϕ i y,
  simp only [←finset.insert_erase (finset.mem_univ i)] {single_pass := tt},
  rw finset.noncomm_prod_insert_of_not_mem _ _ _ _ (finset.not_mem_erase i _),
  rw pi.mul_single_eq_same,
  rw finset.noncomm_prod_eq_pow_card,
  { rw one_pow, exact mul_one _  },
  { intros j hj, simp only [finset.mem_erase] at hj, simp [hj], },
end

omit hcomm

/-- The universal property of `noncomm_pi_coprod` -/
@[to_additive "The universal property of `noncomm_pi_coprod`"]
def noncomm_pi_coprod_equiv :
  {ϕ : Π i, N i →* M // pairwise (λ i j, ∀ x y, commute (ϕ i x) (ϕ j y)) }
    ≃ ((Π i, N i) →* M) :=
{ to_fun := λ ϕ, noncomm_pi_coprod ϕ.1 ϕ.2,
  inv_fun := λ f,
  ⟨ λ i, f.comp (monoid_hom.single N i),
    λ i j hij x y, commute.map (pi.mul_single_commute hij x y) f ⟩,
  left_inv := λ ϕ, by { ext, simp, },
  right_inv := λ f, pi_ext (λ i x, by simp) }

omit hdec

include hcomm

@[to_additive]
lemma noncomm_pi_coprod_mrange : (noncomm_pi_coprod ϕ hcomm).mrange = ⨆ i : ι, (ϕ i).mrange :=
begin
  classical,
  apply le_antisymm,
  { rintro x ⟨f, rfl⟩,
    refine submonoid.noncomm_prod_mem _ _ _ _ _,
    intros i hi,
    apply submonoid.mem_Sup_of_mem, { use i },
    simp, },
  { refine supr_le _,
    rintro i x ⟨y, rfl⟩,
    refine ⟨pi.mul_single i y, noncomm_pi_coprod_mul_single _ _ _⟩, },
end

end monoid_hom

end family_of_monoids

section family_of_groups

variables {G : Type*} [group G]
variables {ι : Type*} [hdec : decidable_eq ι] [hfin : fintype ι]
variables {H : ι → Type*} [∀ i, group (H i)]
variables (ϕ : Π (i : ι), H i →* G)
variables {hcomm : ∀ (i j : ι), i ≠ j → ∀ (x : H i) (y : H j), commute (ϕ i x) (ϕ j y)}
include hcomm

-- We use `f` and `g` to denote elements of `Π (i : ι), H i`
variables (f g : Π (i : ι), H i)

include hfin

namespace monoid_hom

-- The subgroup version of `noncomm_pi_coprod_mrange`
@[to_additive]
lemma noncomm_pi_coprod_range : (noncomm_pi_coprod ϕ hcomm).range = ⨆ i : ι, (ϕ i).range :=
begin
  classical,
  apply le_antisymm,
  { rintro x ⟨f, rfl⟩,
    refine subgroup.noncomm_prod_mem _ _ _,
    intros i hi,
    apply subgroup.mem_Sup_of_mem, { use i },
    simp, },
  { refine supr_le _,
    rintro i x ⟨y, rfl⟩,
    refine ⟨pi.mul_single i y, noncomm_pi_coprod_mul_single _ _ _⟩, },
end

@[to_additive]
lemma injective_noncomm_pi_coprod_of_independent
  (hind : complete_lattice.independent (λ i, (ϕ i).range))
  (hinj : ∀ i, function.injective (ϕ i)) :
  function.injective (noncomm_pi_coprod ϕ hcomm):=
begin
  classical,
  apply (monoid_hom.ker_eq_bot_iff _).mp,
  apply eq_bot_iff.mpr,
  intros f heq1,
  change finset.univ.noncomm_prod (λ i, ϕ i (f i)) _ = 1 at heq1,
  change f = 1,
  have : ∀ i, i ∈ finset.univ → ϕ i (f i) = 1 :=
    subgroup.eq_one_of_noncomm_prod_eq_one_of_independent _ _ _ _ hind (by simp) heq1,
  ext i,
  apply hinj,
  simp [this i (finset.mem_univ i)],
end

variable (hcomm)

omit hfin

@[to_additive]
lemma independent_range_of_coprime_order [finite ι] [Π i, fintype (H i)]
  (hcoprime : ∀ i j, i ≠ j → nat.coprime (fintype.card (H i)) (fintype.card (H j))) :
  complete_lattice.independent (λ i, (ϕ i).range) :=
begin
  casesI nonempty_fintype ι,
  classical,
  rintros i,
  rw disjoint_iff_inf_le,
  rintros f ⟨hxi, hxp⟩, dsimp at hxi hxp,
  rw [supr_subtype', ← noncomm_pi_coprod_range] at hxp,
  rotate, { intros _ _ hj, apply hcomm, exact hj ∘ subtype.ext },
  cases hxp with g hgf, cases hxi with g' hg'f,
  have hxi : order_of f ∣ fintype.card (H i),
  { rw ← hg'f, exact (order_of_map_dvd _ _).trans order_of_dvd_card_univ },
  have hxp : order_of f ∣ ∏ j : {j // j ≠ i}, fintype.card (H j),
  { rw [← hgf, ← fintype.card_pi], exact (order_of_map_dvd _ _).trans order_of_dvd_card_univ },
  change f = 1, rw [← pow_one f, ← order_of_dvd_iff_pow_eq_one],
  convert ← nat.dvd_gcd hxp hxi, rw ← nat.coprime_iff_gcd_eq_one,
  apply nat.coprime_prod_left, intros j _, apply hcoprime, exact j.2,
end

end monoid_hom

end family_of_groups

namespace subgroup

-- We have an family of subgroups
variables {G : Type*} [group G]
variables {ι : Type*} [hdec : decidable_eq ι] [hfin : fintype ι] {H : ι → subgroup G}

-- Elements of `Π (i : ι), H i` are called `f` and `g` here
variables (f g : Π (i : ι), H i)

section commuting_subgroups

-- We assume that the elements of different subgroups commute
variables (hcomm : ∀ (i j : ι), i ≠ j → ∀ (x y : G), x ∈ H i → y ∈ H j → commute x y)
include hcomm

@[to_additive]
lemma commute_subtype_of_commute (i j : ι) (hne : i ≠ j) :
  ∀ (x : H i) (y : H j), commute ((H i).subtype x) ((H j).subtype y) :=
by { rintros ⟨x, hx⟩ ⟨y, hy⟩, exact hcomm i j hne x y hx hy }

include hfin

/-- The canonical homomorphism from a family of subgroups where elements from different subgroups
commute -/
@[to_additive "The canonical homomorphism from a family of additive subgroups where elements from
different subgroups commute"]
def noncomm_pi_coprod : (Π (i : ι), H i) →* G :=
  monoid_hom.noncomm_pi_coprod (λ i, (H i).subtype) (commute_subtype_of_commute hcomm)

variable {hcomm}

include hdec

@[simp, to_additive]
lemma noncomm_pi_coprod_mul_single (i : ι) (y : H i) :
  noncomm_pi_coprod hcomm (pi.mul_single i y) = y :=
by apply monoid_hom.noncomm_pi_coprod_mul_single

omit hdec

@[to_additive]
lemma noncomm_pi_coprod_range : (noncomm_pi_coprod hcomm).range = ⨆ i : ι, H i :=
by simp [noncomm_pi_coprod, monoid_hom.noncomm_pi_coprod_range]

@[to_additive]
lemma injective_noncomm_pi_coprod_of_independent (hind : complete_lattice.independent H) :
  function.injective (noncomm_pi_coprod hcomm) :=
begin
  apply monoid_hom.injective_noncomm_pi_coprod_of_independent,
  { simpa using hind },
  { intro i, exact subtype.coe_injective }
end

variable (hcomm)

omit hfin

@[to_additive]
lemma independent_of_coprime_order [finite ι] [∀ i, fintype (H i)]
  (hcoprime : ∀ i j, i ≠ j → nat.coprime (fintype.card (H i)) (fintype.card (H j))) :
  complete_lattice.independent H :=
by simpa using monoid_hom.independent_range_of_coprime_order (λ i, (H i).subtype)
  (commute_subtype_of_commute hcomm) hcoprime

end commuting_subgroups

end subgroup


import SciLean.Data.ArrayType.Basic
import SciLean.Data.ArrayType.Notation
import SciLean.Data.ArrayType.MatrixOperations

namespace SciLean

/-- This class says that `T` is the canonical type to store `numOf I` element of `X`.

This class allows for the notation `X^I` and `T = X^I`. -/
class PowType (T : outParam Type) (I X : Type) extends ArrayType T I X

/-- Obtains the type of `X^I` by providing `X` and `I` -/
abbrev PowTypeCarrier (X I : Type) {T : outParam Type} [PowType T I X] := T

/-- This class says that `T n` is the canonical type to store `n` elements of `X`.

This class allows for the notation `X^{n}` and `T n = X^{n}`. -/
class LinearPowType (T : outParam (Nat → Type)) (X : Type) extends LinearArrayType T X

instance (T : Nat → Type) (X : Type) [LinearPowType T X] (n : Nat) : PowType (T n) (Fin n) X := PowType.mk

/-- Type that behaves like and array with values in `X` and indices in `I`.

For `x : X^I` you can:
  1. get a value: `x[i] : X` for `i : I`
  2. set a value: `setElem x i xi : X^I` for `x : X^I`, `i : I`, `xi : X`
     in do blocks: `x[i] := xi`, `x[i] += xi`, ...
  3. introduce new array:
     `let x : X^I := λ [i] => f i`
     for `f : I → X`

The precise type of `X^I` depends on `X` and `I` and it is determined by the typeclass `PowType`. Often `X^I` is internally `Array` or `DataArray` bundled with a proposition about its size e.g. `array.size = numOf I` for `array : Array` and `[Enumtype I]`.
-/
notation X "^" I => PowTypeCarrier X I

-- instance (T : Nat → Type) [∀ n, PowType (T n) (Fin n) X] [DropElem T X] [PushElem T X] [ReserveElem T X]
--   : LinearArrayType T X := LinearArrayType.mk (by infer_instance) sorry_proof sorry_proof sorry_proof

section CustomNotation

/-- Type that behaves like a multidimensional array with values in `X`.

For `x : X^{n₁,...,nₘ}` you can:
  1. get a value: `x[i₁,...,iₘ] : X` for `i₁ : Fin n₁`, ... , `iₘ : Fin nₘ`
  2. set a value in do blocks: `x[i₁,...,iₘ] := xi`, `x[i₁,...,iₘ] += xi`
     for `x : X^{n₁,...,nₘ}`, `i₁ : Fin n₁`, ... , `iₘ : Fin nₘ`, `xi : X`
  3. introduce new array:
     `let x : X^{n₁,...,nₘ} := λ [i₁,...,iₘ] => f i₁ ... iₘ`
     for `f : Fin n₁ → ... → Fin nₘ → X`

The type `X^{n₁,...,nₘ}` is just a notation for `X^(Fin n₁ × ... Fin nₘ)`
-/
syntax term "^{" term,* "}" : term
macro_rules
| `($X:term ^{ $n }) => do
  `($X ^ (Fin $n))
| `($X:term ^{ $ns,* }) => do
  if 0 < ns.getElems.size then
    let last := ns.getElems[ns.getElems.size-1]!
    let ns' := ns.getElems[:ns.getElems.size-1]
    let I ← ns'.foldrM (λ x y => `(Fin $x × $y)) (← `(Fin $last))
    `($X ^ $I)
  else
    `(Unit)

-- -- TODO: Generalize this
-- /-- `A[i,j]` is just a notation for `A[(i,j)]` -/
-- macro A:term  noWs "[" id1:term "," id2:term "]" : term => `($A[($id1, $id2)])
-- /-- `A[i,j,k]` is just a notation for `A[(i,j,k)]` -/
-- macro A:term  noWs "[" id1:term "," id2:term "," id3:term "]" : term => `($A[($id1, $id2, $id3)])
-- /-- `A[i,j,k,l]` is just a notation for `A[(i,j,k,l)]` -/
-- macro A:term  noWs "[" id1:term "," id2:term "," id3:term "," id4:term "]" : term => `($A[($id1, $id2, $id3, $id4)])

macro A:term  noWs "[" id:term "," ids:term,* "]" : term => `($A[($id,$ids:term,*)])

/-- `A[i,:]` is just a notation for `λ [j] => A[i,j]` -/
macro A:term  noWs "[" id1:term "," ":" "]" : term => `(λ [j] => $A[($id1, j)])
/-- `A[i,·]` is just a notation for `λ [j] => A[i,j]` -/
macro A:term  noWs "[" id1:term "," "·" "]" : term => `(λ j => $A[($id1, j)])
/-- `A[:,j]` is just a notation for `λ [i] => A[i,j]` -/
macro A:term  noWs "[" ":" "," id2:term "]" : term => `(λ [i] => $A[(i, $id2)])
/-- `A[·,j]` is just a notation for `λ i => A[i,j]` -/
macro A:term  noWs "[" "·" "," id2:term "]" : term => `(λ i => $A[(i, $id2)])

-- This should be improved such that we can specify the type of arguments
-- This clashes with typeclass arguments, but who in their right mind
-- starts a lambda arguments with a typeclass?
syntax (name:=powTypeIntroSyntax) "λ" Lean.Parser.Term.funBinder+  " ==> " term : term
syntax (name:=powTypeIntroSyntaxAlt) "⊞" Lean.Parser.Term.funBinder+  " , " term : term

-- Having this as an abbrev was causing some issues
def introPowElem {X I} {T : outParam Type} [Enumtype I] [PowType T I X] (f : I → X) : X^I := introElem λ i => f i

macro_rules (kind := powTypeIntroSyntax)
| `(λ $xs:funBinder* ==> $b:term) => `(introPowElem λ $xs* => $b)
macro_rules (kind := powTypeIntroSyntaxAlt)
| `(⊞ $xs:funBinder* , $b:term) => `(introPowElem λ $xs* => $b)

end CustomNotation

namespace PowTypeCarrier

section FixedSize

variable {X I} {T : outParam Type} [Enumtype I] [PowType T I X] -- [Inhabited X]

abbrev get (x : X^I) (i : I) : X := getElem x i True.intro
abbrev set (x : X^I) (i : I) (xi : X) : X^I := setElem x i xi
abbrev intro (f : I → X) : X^I := introElem f
abbrev modify (x : X^I) (i : I) (f : X → X) : X^I := ArrayType.modifyElem x i f
abbrev mapIdx (f : I → X → X) (x : X^I) : X^I := ArrayType.mapIdx f x
abbrev map (f : X → X) (x : X^I) : X^I := ArrayType.map f x

def toArray (v : X^I) : Array X := Id.run do
  let mut array : Array X := Array.mkEmpty (numOf I)
  for (i, _) in Enumtype.fullRange I do
    array := array.push v[i]
  return array

abbrev Index (_ : X^I) := I
abbrev Elem  (_ : X^I) := X

open Lean in
instance [ToJson X] : ToJson (X^I) where
  toJson v := toJson (v.toArray)

open Lean in
instance [FromJson X] : FromJson (X^I) where
  fromJson? json :=
    match fromJson? (α := Array X) json with
    | .error msg => .error msg
    | .ok array =>
      if h : (numOf I) = array.size then
        .ok (introElem λ i => array[h ▸ toFin i])
      else
        .error "Failed to convert to json to PowType X^{n}, json size does not match `n`"

end FixedSize

section VariableSize
variable {X} {T : outParam (Nat → Type)} [LinearPowType T X]

abbrev empty : X^{0} := ArrayType.empty
abbrev split {n m : Nat} (x : X^{n+m}) : X^{n} × X^{m} := ArrayType.split x
abbrev merge {n m : Nat} (x : X^{n}) (y : X^{m}) : X^{n+m} := ArrayType.append x y
abbrev append {n m : Nat} (x : X^{n}) (y : X^{m}) : X^{n+m} := ArrayType.append x y
abbrev drop (k : Nat := 1) (x : X^{n+k}) : X^{n} := dropElem k x
abbrev push (x : X^{n}) (xi : X) (k : Nat := 1) : X^{n+k} := pushElem k xi x

/-- Computes: `y[i] := a i * x[i] + b i * x[i+1]`

Special case for `i=n-1`: `y[n-1] := a (n-1) * x[n-1]` -/
abbrev generateUpperTriangularArray (f : (n' : Nat) → X^{n'+1} → X^{n'}) (x : X^{n}) : X^{(n*(n+1))/2} :=
  ArrayType.generateUpperTriangularArray f x
abbrev upper2DiagonalUpdate [Vec X] (a : Fin n → ℝ) (b : Fin (n-1) → ℝ) (x : X^{n}) : X^{n} :=
  ArrayType.upper2DiagonalUpdate a b x

/-- Computes: `y[i] := a i * x[i] + b (i-1) * x[i-1]`

Special case for `i=0`: `y[0] := a 0 * x[0]` -/
abbrev lower2DiagonalUpdate [Vec X] (a : Fin n → ℝ) (b : Fin (n-1) → ℝ) (x : X^{n}) : X^{n} :=
  ArrayType.lower2DiagonalUpdate a b x

/-- Computes: `y[i] := x[i+1] - x[i]` -/
abbrev differences [Vec X] (x : X^{n+1}) : X^{n} :=
  ArrayType.differences x

/-- Computes: `y[i] := (1-t) * x[i] + t * x[i+1]` -/
abbrev linearInterpolate [Vec X] (t : ℝ) (x : X^{n+1}) : X^{n} :=
  ArrayType.linearInterpolate t x

-- example [Vec X] : IsLin (λ x : X^{n} => x.upper2DiagonalUpdate (λ _ => 1) (λ _ => -1)) := by infer_instance
-- example [Vec X] : IsLin (λ x : X^{n+1} => x.drop) := by infer_instance
-- example [Vec X] (xi : X) : IsSmooth (λ x : X^{n} => x.push xi) := by infer_instance

-- example [Vec X] : IsSmooth (λ x : X^{n+1} => x.linearInterpolate) := by infer_instance
-- example [Vec X] (x : X^{n+1}) : IsSmooth (λ t => x.linearInterpolate t) := by infer_instance

end VariableSize

section Currying

variable {X I J}  [Enumtype I] [Enumtype J]
variable {T : outParam Type} [PowType T J X]
variable {T' : outParam Type} [PowType T' I (X^J)]
variable {T'' : outParam Type} [PowType T'' (I×J) X]

-- sometimes this should be effectivelly identity function
-- sometimes you have to reshuffle memory around, how to deal with this?
-- def curry : (X^(I×J)) → ((X^J)^I) := sorry
-- def uncurry : ((X^J)^I) → (X^(I×J)) := sorry

end Currying

end PowTypeCarrier


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import topology.category.Top.basic
import measure_theory.giry_monad
import category_theory.monad.algebra

/-!
# The category of measurable spaces

Measurable spaces and measurable functions form a (concrete) category `Meas`.

## Main definitions

* `Measure : Meas ⥤ Meas`: the functor which sends a measurable space `X`
to the space of measures on `X`; it is a monad (the "Giry monad").

* `Borel : Top ⥤ Meas`: sends a topological space `X` to `X` equipped with the
`σ`-algebra of Borel sets (the `σ`-algebra generated by the open subsets of `X`).

## Tags

measurable space, giry monad, borel
-/

noncomputable theory

open category_theory measure_theory
open_locale ennreal
universes u v

/-- The category of measurable spaces and measurable functions. -/
@[derive has_coe_to_sort]
def Meas : Type (u+1) := bundled measurable_space

namespace Meas

instance (X : Meas) : measurable_space X := X.str

/-- Construct a bundled `Meas` from the underlying type and the typeclass. -/
def of (α : Type u) [measurable_space α] : Meas := ⟨α⟩

@[simp] lemma coe_of (X : Type u) [measurable_space X] : (of X : Type u) = X := rfl

instance unbundled_hom : unbundled_hom @measurable := ⟨@measurable_id, @measurable.comp⟩

attribute [derive [large_category, concrete_category]] Meas

instance : inhabited Meas := ⟨Meas.of empty⟩

/-- `Measure X` is the measurable space of measures over the measurable space `X`. It is the
weakest measurable space, s.t. λμ, μ s is measurable for all measurable sets `s` in `X`. An
important purpose is to assign a monadic structure on it, the Giry monad. In the Giry monad,
the pure values are the Dirac measure, and the bind operation maps to the integral:
`(μ >>= ν) s = ∫ x. (ν x) s dμ`.

In probability theory, the `Meas`-morphisms `X → Prob X` are (sub-)Markov kernels (here `Prob` is
the restriction of `Measure` to (sub-)probability space.)
-/
def Measure : Meas ⥤ Meas :=
{ obj      := λX, ⟨@measure_theory.measure X.1 X.2⟩,
  map      := λX Y f, ⟨measure.map (f : X → Y), measure.measurable_map f f.2⟩,
  map_id'  := assume ⟨α, I⟩, subtype.eq $ funext $ assume μ, @measure.map_id α I μ,
  map_comp':=
    assume X Y Z ⟨f, hf⟩ ⟨g, hg⟩, subtype.eq $ funext $ assume μ, (measure.map_map hg hf).symm }

/-- The Giry monad, i.e. the monadic structure associated with `Measure`. -/
def Giry : category_theory.monad Meas :=
{ to_functor := Measure,
  η' :=
  { app         := λX, ⟨@measure.dirac X.1 X.2, measure.measurable_dirac⟩,
    naturality' :=
      assume X Y ⟨f, hf⟩, subtype.eq $ funext $ assume a, (measure.map_dirac hf a).symm },
  μ' :=
  { app         := λX, ⟨@measure.join X.1 X.2, measure.measurable_join⟩,
    naturality' :=
      assume X Y ⟨f, hf⟩, subtype.eq $ funext $ assume μ, measure.join_map_map hf μ },
  assoc' := assume α, subtype.eq $ funext $ assume μ, @measure.join_map_join _ _ _,
  left_unit' := assume α, subtype.eq $ funext $ assume μ, @measure.join_dirac _ _ _,
  right_unit' := assume α, subtype.eq $ funext $ assume μ, @measure.join_map_dirac _ _ _ }

/-- An example for an algebra on `Measure`: the nonnegative Lebesgue integral is a hom, behaving
nicely under the monad operations. -/
def Integral : Giry.algebra :=
{ A      := Meas.of ℝ≥0∞ ,
  a      := ⟨λm:measure ℝ≥0∞, ∫⁻ x, x ∂m, measure.measurable_lintegral measurable_id ⟩,
  unit'  := subtype.eq $ funext $ assume r:ℝ≥0∞, lintegral_dirac' _ measurable_id,
  assoc' := subtype.eq $ funext $ assume μ : measure (measure ℝ≥0∞),
    show ∫⁻ x, x ∂ μ.join = ∫⁻ x, x ∂ (measure.map (λm:measure ℝ≥0∞, ∫⁻ x, x ∂m) μ),
    by rw [measure.lintegral_join, lintegral_map];
      apply_rules [measurable_id, measure.measurable_lintegral] }

end Meas

instance Top.has_forget_to_Meas : has_forget₂ Top.{u} Meas.{u} :=
bundled_hom.mk_has_forget₂
  borel
  (λ X Y f, ⟨f.1, f.2.borel_measurable⟩)
  (by intros; refl)

/-- The Borel functor, the canonical embedding of topological spaces into measurable spaces. -/
@[reducible] def Borel : Top.{u} ⥤ Meas.{u} := forget₂ Top.{u} Meas.{u}


/-
Copyright 2022 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    https://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

Authors: Moritz Firsching
-/
import tactic
import data.finset.basic
import combinatorics.simple_graph.adj_matrix
import combinatorics.simple_graph.subgraph
import combinatorics.simple_graph.coloring
import combinatorics.simple_graph.connectivity
import order.well_founded_set
import data.set.basic
import analysis.special_functions.exp
import analysis.special_functions.log.base

open simple_graph
/-!
# Probability makes counting (sometimes) easy

## Structure
  - Theorem 1
    - proof
  - Ramsey Numbers
  - Theorem 2
    - proof
  - Triangle-free graphs with high chromatic number (TODO)
  - Theorem 3
    - proof
  - Theorem 4 (TODO : Define crossing number)
-/

section

variables {α : Type*} {X : finset α}
parameters {d : ℕ} {h_d : d ≥ 2}

/-- `𝓕` is a collection of `d`-sets of `X`-/

variables (𝓕 : finset (finset X)) (H_𝓕 : ∀ A : finset X, A ∈ 𝓕 → A.card = d)

def two_colorable :=
  ∃ c : X → fin 2, ∀ A : finset X, A ∈ 𝓕 → ∃ x y : A, c x = 0 ∧ c y = 0

include H_𝓕
theorem theorem_1 : 𝓕.card ≤ 2 ^ (d-1) → two_colorable 𝓕 :=
begin
  sorry,
end

end

/-! Ramsey Numbers and Theorem 2-/

/--
A complete graph `G` on `N` vertices has the Ramsey property `R(m, n)`, if for each two-coloring of
the edges of `G`, either there is a complete subgraph on `m` vertices  of the first color, or there
is a complete subgraph on `n` vertices in the second color. -/
def ramsey_property (m n : ℕ) (N : ℕ) :=
  ∀ c : (complete_graph (fin N)).edge_set → fin 2,
  ( ∃ g : complete_graph (fin m) →g complete_graph (fin N), ∀ e : (complete_graph (fin m)).edge_set,
      c (g.map_edge_set e) = 0 ) ∨
  ( ∃ h : complete_graph (fin n) →g complete_graph (fin N), ∀ e : (complete_graph (fin n)).edge_set,
    c (h.map_edge_set e) = 1 )

lemma ramsey_exists (m n : ℕ) (h_m : m ≥ 2) (h_n : n ≥ 2) : ∃ N, ramsey_property m n N :=
begin
  sorry,
end

/--
The Ramsey Numbers. Noe that this is only defined for `m, n ≥ 2`
Would it make sense to make this not noncomputable?
-/
noncomputable def ramsey (m n : ℕ) :=
   Inf {N : ℕ | ramsey_property m n N }

namespace ramsey

lemma symm (m n : ℕ) (h_m : m ≥ 2) (h_n : n ≥ 2) : ramsey m n = ramsey n m :=
begin
  sorry,
end

lemma two (m : ℕ) (h_m : m ≥ 2) : ramsey m 2 = m :=
begin
  sorry,
end

lemma bound (m n : ℕ) (h_m : m ≥ 3) (h_n : n ≥ 3) :
  ramsey m n ≤ ramsey (m - 1) n + ramsey m (n - 1) :=
begin
  sorry,
end

end ramsey

/--Theorem 2. Lower bound for `ramsey k k`-/
theorem ramsey_geq_two_pow_half (k : ℕ) (h_k : k ≥ 2) :
  (ramsey k k : ℝ) ≥ real.exp ((real.log 2) + (k: ℝ) / 2) :=
begin
  sorry,
end

/-! Theorem 3-/

/-- Chromatic Number of a graph -- Should be introduced in part about Kneser Graphs-/

noncomputable def girth {V : Type*} (G : simple_graph V) :=
  Inf {N : ℕ | N ≥ 1 ∧ ∃ (u : V) (W : G.walk u u), N = W.length ∧ W.is_cycle}

theorem theorem_3 (k : ℕ) (h_k : k ≥ 2) :
  ∃ (n : ℕ) (G : simple_graph (fin n)), G.chromatic_number > k ∧ girth G > k :=
begin
  sorry,
end

/-! Crossing Number and Theorem 4, TODO: Finish Def. of crossing numbers-/
noncomputable def crossing_number {V : Type*} (G: simple_graph V) :=
  Inf {N : ℕ | ∃ (c : V → ℝ × ℝ) (f : G.edge_set → (set.Icc (0:ℝ) 1) → ℝ × ℝ),
                  function.injective c ∧
                  ∀ (e : G.edge_set) (v : V) (h : v ∈ (e : sym2 V)),
                    ({v, sym2.mem.other h} :set V).image c = (coe ⁻¹' ({0,1} : set ℝ)).image (f e) ∧
                    true }
        -- We'd like that at every point in ℝ× ℝ, at most two paths intersect transversally

/-- Theorem 4, TODO: should infer [fintype G.edge_set]-/
theorem theorem_4 {V : Type*} [fintype V] (G : simple_graph V) [fintype G.edge_set] (m n : ℕ)
  (H : m ≥ 4 * n) (h_n : n = fintype.card V) (h_m : m = fintype.card G.edge_set) :
  crossing_number G ≥ m ^ 3 / n ^ 2 / 64 :=
begin
  sorry,
end


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.category.basic
import category_theory.equivalence
import category_theory.eq_to_hom

/-!
# Basic API for ulift

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file contains a very basic API for working with the categorical
instance on `ulift C` where `C` is a type with a category instance.

1. `category_theory.ulift.up` is the functorial version of the usual `ulift.up`.
2. `category_theory.ulift.down` is the functorial version of the usual `ulift.down`.
3. `category_theory.ulift.equivalence` is the categorical equivalence between
  `C` and `ulift C`.

# ulift_hom

Given a type `C : Type u`, `ulift_hom.{w} C` is just an alias for `C`.
If we have `category.{v} C`, then `ulift_hom.{w} C` is endowed with a category instance
whose morphisms are obtained by applying `ulift.{w}` to the morphisms from `C`.

This is a category equivalent to `C`. The forward direction of the equivalence is `ulift_hom.up`,
the backward direction is `ulift_hom.donw` and the equivalence is `ulift_hom.equiv`.

# as_small

This file also contains a construction which takes a type `C : Type u` with a
category instance `category.{v} C` and makes a small category
`as_small.{w} C : Type (max w v u)` equivalent to `C`.

The forward direction of the equivalence, `C ⥤ as_small C`, is denoted `as_small.up`
and the backward direction is `as_small.down`. The equivalence itself is `as_small.equiv`.
-/

universes w₁ v₁ v₂ u₁ u₂

namespace category_theory

variables {C : Type u₁} [category.{v₁} C]

/-- The functorial version of `ulift.up`. -/
@[simps]
def ulift.up_functor : C ⥤ (ulift.{u₂} C) :=
{ obj := ulift.up,
  map := λ X Y f, f }

/-- The functorial version of `ulift.down`. -/
@[simps]
def ulift.down_functor : (ulift.{u₂} C) ⥤ C :=
{ obj := ulift.down,
  map := λ X Y f, f }

/-- The categorical equivalence between `C` and `ulift C`. -/
@[simps]
def ulift.equivalence : C ≌ (ulift.{u₂} C) :=
{ functor := ulift.up_functor,
  inverse := ulift.down_functor,
  unit_iso :=
  { hom := 𝟙 _,
    inv := 𝟙 _ },
  counit_iso :=
  { hom :=
    { app := λ X, 𝟙 _,
      naturality' := λ X Y f, by {change f ≫ 𝟙 _ = 𝟙 _ ≫ f, simp} },
    inv :=
    { app := λ X, 𝟙 _,
      naturality' := λ X Y f, by {change f ≫ 𝟙 _ = 𝟙 _ ≫ f, simp} },
  hom_inv_id' := by {ext, change (𝟙 _) ≫ (𝟙 _) = 𝟙 _, simp},
  inv_hom_id' := by {ext, change (𝟙 _) ≫ (𝟙 _) = 𝟙 _, simp} },
  functor_unit_iso_comp' := λ X, by {change (𝟙 X) ≫ (𝟙 X) = 𝟙 X, simp} }

section ulift_hom

/-- `ulift_hom.{w} C` is an alias for `C`, which is endowed with a category instance
  whose morphisms are obtained by applying `ulift.{w}` to the morphisms from `C`.
-/
def {w u} ulift_hom (C : Type u) := C

instance {C} [inhabited C] : inhabited (ulift_hom C) := ⟨(arbitrary C : C)⟩

/-- The obvious function `ulift_hom C → C`. -/
def ulift_hom.obj_down {C} (A : ulift_hom C) : C := A

/-- The obvious function `C → ulift_hom C`. -/
def ulift_hom.obj_up {C} (A : C) : ulift_hom C := A

@[simp] lemma obj_down_obj_up {C} (A : C) : (ulift_hom.obj_up A).obj_down = A := rfl
@[simp] lemma obj_up_obj_down {C} (A : ulift_hom C) : ulift_hom.obj_up A.obj_down = A := rfl

instance : category.{max v₂ v₁} (ulift_hom.{v₂} C) :=
{ hom := λ A B, ulift.{v₂} $ A.obj_down ⟶ B.obj_down,
  id := λ A, ⟨𝟙 _⟩,
  comp := λ A B C f g, ⟨f.down ≫ g.down⟩}

/-- One half of the quivalence between `C` and `ulift_hom C`. -/
@[simps]
def ulift_hom.up : C ⥤ ulift_hom C :=
{ obj := ulift_hom.obj_up,
  map := λ X Y f, ⟨f⟩ }

/-- One half of the quivalence between `C` and `ulift_hom C`. -/
@[simps]
def ulift_hom.down : ulift_hom C ⥤ C :=
{ obj := ulift_hom.obj_down,
  map := λ X Y f, f.down }

/-- The equivalence between `C` and `ulift_hom C`. -/
def ulift_hom.equiv : C ≌ ulift_hom C :=
{ functor := ulift_hom.up,
  inverse := ulift_hom.down,
  unit_iso := nat_iso.of_components (λ A, eq_to_iso rfl) (by tidy),
  counit_iso := nat_iso.of_components (λ A, eq_to_iso rfl) (by tidy) }

end ulift_hom

/-- `as_small C` is a small category equivalent to `C`.
  More specifically, if `C : Type u` is endowed with `category.{v} C`, then
  `as_small.{w} C : Type (max w v u)` is endowed with an instance of a small category.

  The objects and morphisms of `as_small C` are defined by applying `ulift` to the
  objects and morphisms of `C`.

  Note: We require a category instance for this definition in order to have direct
  access to the universe level `v`.
-/
@[nolint unused_arguments]
def {w v u} as_small (C : Type u) [category.{v} C] := ulift.{max w v} C

instance : small_category (as_small.{w₁} C) :=
{ hom := λ X Y, ulift.{max w₁ u₁} $ X.down ⟶ Y.down,
  id := λ X, ⟨𝟙 _⟩,
  comp := λ X Y Z f g, ⟨f.down ≫ g.down⟩ }

/-- One half of the equivalence between `C` and `as_small C`. -/
@[simps]
def as_small.up : C ⥤ as_small C :=
{ obj := λ X, ⟨X⟩,
  map := λ X Y f, ⟨f⟩ }

/-- One half of the equivalence between `C` and `as_small C`. -/
@[simps]
def as_small.down : as_small C ⥤ C :=
{ obj := λ X, X.down,
  map := λ X Y f, f.down }

/-- The equivalence between `C` and `as_small C`. -/
@[simps]
def as_small.equiv : C ≌ as_small C :=
{ functor := as_small.up,
  inverse := as_small.down,
  unit_iso := nat_iso.of_components (λ X, eq_to_iso rfl) (by tidy),
  counit_iso := nat_iso.of_components (λ X, eq_to_iso $ by { ext, refl }) (by tidy) }

instance [inhabited C] : inhabited (as_small C) := ⟨⟨arbitrary _⟩⟩

/-- The equivalence between `C` and `ulift_hom (ulift C)`. -/
def {v' u' v u} ulift_hom_ulift_category.equiv (C : Type u) [category.{v} C] :
  C ≌ ulift_hom.{v'} (ulift.{u'} C) :=
ulift.equivalence.trans ulift_hom.equiv

end category_theory


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group.defs
import logic.equiv.defs
import logic.nontrivial

/-!
# Multiplicative opposite and algebraic operations on it

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we define `mul_opposite α = αᵐᵒᵖ` to be the multiplicative opposite of `α`. It inherits
all additive algebraic structures on `α` (in other files), and reverses the order of multipliers in
multiplicative structures, i.e., `op (x * y) = op y * op x`, where `mul_opposite.op` is the
canonical map from `α` to `αᵐᵒᵖ`.

We also define `add_opposite α = αᵃᵒᵖ` to be the additive opposite of `α`. It inherits all
multiplicative algebraic structures on `α` (in other files), and reverses the order of summands in
additive structures, i.e. `op (x + y) = op y + op x`, where `add_opposite.op` is the canonical map
from `α` to `αᵃᵒᵖ`.

## Notation

* `αᵐᵒᵖ = mul_opposite α`
* `αᵃᵒᵖ = add_opposite α`

## Tags

multiplicative opposite, additive opposite
-/

universes u v
open function

/-- Multiplicative opposite of a type. This type inherits all additive structures on `α` and
reverses left and right in multiplication.-/
@[to_additive "Additive opposite of a type. This type inherits all multiplicative structures on
`α` and reverses left and right in addition."]
def mul_opposite (α : Type u) : Type u := α

postfix `ᵐᵒᵖ`:std.prec.max_plus := mul_opposite
postfix `ᵃᵒᵖ`:std.prec.max_plus := add_opposite

variables {α : Type u}

namespace mul_opposite

/-- The element of `mul_opposite α` that represents `x : α`. -/
@[pp_nodot, to_additive "The element of `αᵃᵒᵖ` that represents `x : α`."]
def op : α → αᵐᵒᵖ := id

/-- The element of `α` represented by `x : αᵐᵒᵖ`. -/
@[pp_nodot, to_additive "The element of `α` represented by `x : αᵃᵒᵖ`."]
def unop : αᵐᵒᵖ → α := id

attribute [pp_nodot] add_opposite.op add_opposite.unop

@[simp, to_additive] lemma unop_op (x : α) : unop (op x) = x := rfl
@[simp, to_additive] lemma op_unop (x : αᵐᵒᵖ) : op (unop x) = x := rfl
@[simp, to_additive] lemma op_comp_unop : (op : α → αᵐᵒᵖ) ∘ unop = id := rfl
@[simp, to_additive] lemma unop_comp_op : (unop : αᵐᵒᵖ → α) ∘ op = id := rfl

attribute [irreducible] mul_opposite

/-- A recursor for `mul_opposite`. Use as `induction x using mul_opposite.rec`. -/
@[simp, to_additive "A recursor for `add_opposite`. Use as `induction x using add_opposite.rec`."]
protected def rec {F : Π (X : αᵐᵒᵖ), Sort v} (h : Π X, F (op X)) : Π X, F X :=
λ X, h (unop X)

/-- The canonical bijection between `α` and `αᵐᵒᵖ`. -/
@[to_additive "The canonical bijection between `α` and `αᵃᵒᵖ`.",
  simps apply symm_apply { fully_applied := ff }]
def op_equiv : α ≃ αᵐᵒᵖ := ⟨op, unop, unop_op, op_unop⟩

@[to_additive] lemma op_bijective : bijective (op : α → αᵐᵒᵖ) := op_equiv.bijective
@[to_additive] lemma unop_bijective : bijective (unop : αᵐᵒᵖ → α) := op_equiv.symm.bijective
@[to_additive] lemma op_injective : injective (op : α → αᵐᵒᵖ) := op_bijective.injective
@[to_additive] lemma op_surjective : surjective (op : α → αᵐᵒᵖ) := op_bijective.surjective
@[to_additive] lemma unop_injective : injective (unop : αᵐᵒᵖ → α) := unop_bijective.injective
@[to_additive] lemma unop_surjective : surjective (unop : αᵐᵒᵖ → α) := unop_bijective.surjective

@[simp, to_additive] lemma op_inj {x y : α} : op x = op y ↔ x = y := op_injective.eq_iff
@[simp, to_additive] lemma unop_inj {x y : αᵐᵒᵖ} : unop x = unop y ↔ x = y := unop_injective.eq_iff

variable (α)

@[to_additive] instance [nontrivial α] : nontrivial αᵐᵒᵖ := op_injective.nontrivial
@[to_additive] instance [inhabited α] : inhabited αᵐᵒᵖ := ⟨op default⟩
@[to_additive] instance [subsingleton α] : subsingleton αᵐᵒᵖ := unop_injective.subsingleton
@[to_additive] instance [unique α] : unique αᵐᵒᵖ := unique.mk' _
@[to_additive] instance [is_empty α] : is_empty αᵐᵒᵖ := function.is_empty unop

instance [has_zero α] : has_zero αᵐᵒᵖ := { zero := op 0 }

@[to_additive] instance [has_one α] : has_one αᵐᵒᵖ := { one := op 1 }

instance [has_add α] : has_add αᵐᵒᵖ :=
{ add := λ x y, op (unop x + unop y) }

instance [has_sub α] : has_sub αᵐᵒᵖ :=
{ sub := λ x y, op (unop x - unop y) }

instance [has_neg α] : has_neg αᵐᵒᵖ :=
{ neg := λ x, op $ -(unop x) }

instance [has_involutive_neg α] : has_involutive_neg αᵐᵒᵖ :=
{ neg_neg := λ a, unop_injective $ neg_neg _,
  ..mul_opposite.has_neg α }

@[to_additive] instance [has_mul α] : has_mul αᵐᵒᵖ :=
{ mul := λ x y, op (unop y * unop x) }

@[to_additive] instance [has_inv α] : has_inv αᵐᵒᵖ :=
{ inv := λ x, op $ (unop x)⁻¹ }

@[to_additive] instance [has_involutive_inv α] : has_involutive_inv αᵐᵒᵖ :=
{ inv_inv := λ a, unop_injective $ inv_inv _,
  ..mul_opposite.has_inv α }

@[to_additive] instance (R : Type*) [has_smul R α] : has_smul R αᵐᵒᵖ :=
{ smul := λ c x, op (c • unop x) }

section
variables (α)

@[simp] lemma op_zero [has_zero α] : op (0 : α) = 0 := rfl
@[simp]

@[simp, to_additive] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp, to_additive] lemma unop_one [has_one α] : unop (1 : αᵐᵒᵖ) = 1 := rfl

variable {α}

@[simp] lemma op_add [has_add α] (x y : α) : op (x + y) = op x + op y := rfl
@[simp] lemma unop_add [has_add α] (x y : αᵐᵒᵖ) : unop (x + y) = unop x + unop y := rfl

@[simp] lemma op_neg [has_neg α] (x : α) : op (-x) = -op x := rfl
@[simp] lemma unop_neg [has_neg α] (x : αᵐᵒᵖ) : unop (-x) = -unop x := rfl

@[simp, to_additive] lemma op_mul [has_mul α] (x y : α) : op (x * y) = op y * op x := rfl
@[simp, to_additive] lemma unop_mul [has_mul α] (x y : αᵐᵒᵖ) : unop (x * y) = unop y * unop x := rfl

@[simp, to_additive] lemma op_inv [has_inv α] (x : α) : op (x⁻¹) = (op x)⁻¹ := rfl
@[simp, to_additive] lemma unop_inv [has_inv α] (x : αᵐᵒᵖ) : unop (x⁻¹) = (unop x)⁻¹ := rfl

@[simp] lemma op_sub [has_sub α] (x y : α) : op (x - y) = op x - op y := rfl
@[simp] lemma unop_sub [has_sub α] (x y : αᵐᵒᵖ) : unop (x - y) = unop x - unop y := rfl

@[simp, to_additive] lemma op_smul {R : Type*} [has_smul R α] (c : R) (a : α) :
  op (c • a) = c • op a := rfl

@[simp, to_additive] lemma unop_smul {R : Type*} [has_smul R α] (c : R) (a : αᵐᵒᵖ) :
  unop (c • a) = c • unop a := rfl

end

variable {α}

@[simp] lemma unop_eq_zero_iff [has_zero α] (a : αᵐᵒᵖ) : a.unop = (0 : α) ↔ a = (0 : αᵐᵒᵖ) :=
unop_injective.eq_iff' rfl

@[simp] lemma op_eq_zero_iff [has_zero α] (a : α) : op a = (0 : αᵐᵒᵖ) ↔ a = (0 : α) :=
op_injective.eq_iff' rfl

lemma unop_ne_zero_iff [has_zero α] (a : αᵐᵒᵖ) : a.unop ≠ (0 : α) ↔ a ≠ (0 : αᵐᵒᵖ) :=
not_congr $ unop_eq_zero_iff a

lemma op_ne_zero_iff [has_zero α] (a : α) : op a ≠ (0 : αᵐᵒᵖ) ↔ a ≠ (0 : α) :=
not_congr $ op_eq_zero_iff a

@[simp, to_additive] lemma unop_eq_one_iff [has_one α] (a : αᵐᵒᵖ) : a.unop = 1 ↔ a = 1 :=
unop_injective.eq_iff' rfl

@[simp, to_additive] lemma op_eq_one_iff [has_one α] (a : α) : op a = 1 ↔ a = 1 :=
op_injective.eq_iff' rfl

end mul_opposite

namespace add_opposite

instance [has_one α] : has_one αᵃᵒᵖ := { one := op 1 }

@[simp] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp] lemma unop_one [has_one α] : unop 1 = (1 : α) := rfl

@[simp] lemma op_eq_one_iff [has_one α] {a : α} : op a = 1 ↔ a = 1 := op_injective.eq_iff' op_one

@[simp] lemma unop_eq_one_iff [has_one α] {a : αᵃᵒᵖ} : unop a = 1 ↔ a = 1 :=
unop_injective.eq_iff' unop_one

instance [has_mul α] : has_mul αᵃᵒᵖ := { mul := λ a b, op (unop a * unop b) }

@[simp] lemma op_mul [has_mul α] (a b : α) : op (a * b) = op a * op b := rfl
@[simp] lemma unop_mul [has_mul α] (a b : αᵃᵒᵖ) : unop (a * b) = unop a * unop b := rfl

instance [has_inv α] : has_inv αᵃᵒᵖ := { inv := λ a, op (unop a)⁻¹ }

instance [has_involutive_inv α] : has_involutive_inv αᵃᵒᵖ :=
{ inv_inv := λ a, unop_injective $ inv_inv _,
  ..add_opposite.has_inv }

@[simp] lemma op_inv [has_inv α] (a : α) : op a⁻¹ = (op a)⁻¹ := rfl
@[simp] lemma unop_inv [has_inv α] (a : αᵃᵒᵖ) : unop a⁻¹ = (unop a)⁻¹ := rfl

instance [has_div α] : has_div αᵃᵒᵖ := { div := λ a b, op (unop a / unop b) }

@[simp] lemma op_div [has_div α] (a b : α) : op (a / b) = op a / op b := rfl
@[simp] lemma unop_div [has_div α] (a b : αᵃᵒᵖ) : unop (a / b) = unop a / unop b := rfl

end add_opposite


import hilbert.wr.ad

namespace clfrags
    namespace hilbert
        namespace wr
            namespace ad

                theorem ad₂₆ {a b c : Prop} (h₁ : a) (h₂ : b) : ad a b c :=
                    have h₃ : ad (ad a b c) b a, from ad₂ h₂,
                    show ad a b c, from ad₁ h₁ h₃

                theorem ad₄' {a b c : Prop} (h₁ : a) : ad c a (ad c a (ad b a c)) :=
                    have h₂ : ad a a a, from ad₂₆ h₁ h₁,
                    have h₃ : ad (ad c a (ad c a (ad b a c))) a a, from ad₄ h₂,
                    show ad c a (ad c a (ad b a c)), from ad₁ h₁ h₃

                theorem ad₂₇ {a b c d e : Prop} (h₁ : ad (ad a b c) d e) : ad (ad a d e) b c :=
                    have h₂ : (ad a d e) or (ad a b c), from ad₁₀ h₁,
                    have h₃ : (ad a b c) or (ad a d e), from ad₁₃ h₂,
                    show ad (ad a d e) b c, from ad₁₁ h₃

                theorem ad₆' {a b : Prop} (h₁ : a) : a or b :=
                    ad₆ h₁

                theorem ad₁_ad {a b c d e : Prop} (h₁ : ad c d e) (h₂ : ad (ad a b c) d e) :
                    ad a d e :=
                    have h₃ : (ad (ad a b c) d e) → ((ad a d e) or (ad a b c)), from ad₁₀,
                    have h₄ : ad a d e → ad a d e, from R,
                    have h₅ : ad c d e → ad a b c → ad a d e, from ad₉,
                    have h₆ : ad c d e → ad a d e → ad a d e, from M₁ h₄,
                    have h₇ : ad c d e → ((ad a d e) or (ad a b c)) → ad a d e, from δ_or₂ h₆ h₅,
                    have h₈ : ad c d e → (ad (ad a b c) d e) → ((ad a d e) or (ad a b c)), from M₁ h₃,
                    show ad a d e, from (T₂ h₈ h₇) h₁ h₂

                theorem ad₂_ad {a b c d e : Prop} (h₁ : ad a d e) : ad (ad (ad c a b) a c) d e :=
                    let b' := ad c a b in
                        have h₂ : (ad a d e) → (((ad c a c) or b') or ((ad c d e) or b')),
                            from (assume h, ad₂₀ $ ad₁₃ $ ad₂₀ $ ad₁₀ $ ad₈ $ ad₁₃ $ ad₆' h),
                        have h₃ : ((ad c a c) or b') → ((ad b' d e) or (ad b' a c)),
                            from (assume h, ad₁₃ $ ad₆' $ ad₁₁ h),
                        have h₄ : ((ad c d e) or b') → ((ad b' d e) or (ad b' a c)),
                            from (assume h, ad₆' $ ad₁₁ h),
                        have h₅ : (((ad c a c) or b') or ((ad c d e) or b')) → ((ad b' d e) or (ad b' a c)),
                            from δ_or₁ h₃ h₄,
                        have h₆ : ad a d e → ((ad b' d e) or (ad b' a c)),
                            from T₁ h₂ h₅,
                        show ad (ad b' a c) d e,
                            from ad₁₁ (h₆ h₁)

                theorem ad₃_ad {a b c d e f g h : Prop} (h₁ : ad (ad a b c) g h) :
                    ad (ad (ad (ad (ad f a d) a (ad e a d)) a (ad (ad f a e) a d)) b c) g h :=
                    let j := ad (ad f a d) a (ad e a d), k := ad (ad f a e) a d, i := ad j a k in
                        have h₂ : (ad (ad a b c) g h) → ((ad a g h) or (ad a b c)),
                            from ad₁₀,
                        have h₃ : ad a g h → ad (ad i b c) g h,
                            from (assume h₃₁, ad₁₁ $ ad₆' $ ad₃ h₃₁),
                        have h₄ : ad a b c → ad (ad i b c) g h,
                            from (assume h₄₁, ad₆ $ ad₃ h₄₁),
                        have h₅ : ((ad a g h) or (ad a b c)) → ad (ad i b c) g h,
                            from (δ_or₁ h₃ h₄),
                        (T₁ h₂ h₅) h₁

                theorem ad₄_ad {a b c d e f g : Prop} (h₁ : ad (ad a b c) f g) :
                    ad (ad (ad d a (ad d a (ad e a d))) b c) f g :=
                    let h := ad d a (ad d a (ad e a d)) in
                        have h₂ : (ad (ad a b c) f g) → ((ad a f g) or (ad a b c)),
                            from ad₁₀,
                        have h₃ : ad a f g → ad (ad h b c) f g,
                            from (assume h₃₁, ad₁₁ $ ad₆' $ ad₄ h₃₁),
                        have h₄ : ad a b c → ad (ad h b c) f g,
                            from (assume h₄₁, ad₆ $ ad₄ h₄₁),
                        have h₅ : ((ad a f g) or (ad a b c)) → ad (ad h b c) f g,
                            from δ_or₁ h₃ h₄,
                        (T₁ h₂ h₅) h₁

                theorem ad₅_ad {a b c d e : Prop} (h₁ : ad (ad a b c) d e) : ad (b or a) d e :=
                    have h₂ : ad (ad a b c) d e → ((ad a d e) or (ad a b c)),
                        from ad₁₀,
                    have h₃ : (ad a d e) → (ad (b or a) d e),
                        from (assume h, ad₈ $ ad₁₃ $ ad₆' h),
                    have h₄ : (ad a b c) → (ad (b or a) d e),
                        from (assume h, ad₆ $ ad₅ h),
                    have h₅ : ((ad a d e) or (ad a b c)) → (ad (b or a) d e),
                        from δ_or₁ h₃ h₄,
                    (T₁ h₂ h₅) h₁

                theorem ad₆_ad {a b c d e : Prop} (h₁ : ad a d e) : ad (ad a b c) d e :=
                    ad₁₁ $ ad₆' h₁

                theorem ad₇_ad {a b c d e f : Prop} (h₁ : ad (ad (c or d) a b) e f) :
                    ad ((ad c a b) or (ad d a b)) e f :=
                    have h₂ : ad (ad (c or d) a b) e f → ((ad (c or d) e f) or (ad (c or d) a b)),
                        from ad₁₀,
                    have h₃ : ad (c or d) e f → ((ad c e f) or (ad d e f)),
                        from ad₇,
                    have h₄ : ad c e f → ad ((ad c a b) or (ad d a b)) e f,
                        from (assume h, ad₈ $ ad₆' $ ad₁₁ $ ad₆' h),
                    have h₅ : ad d e f → ad ((ad c a b) or (ad d a b)) e f,
                        from (assume h, ad₈ $ ad₁₃ $ ad₆' $ ad₁₁ $ ad₆' h),
                    have h₆ : ((ad c e f) or (ad d e f)) → ad ((ad c a b) or (ad d a b)) e f,
                        from δ_or₁ h₄ h₅,
                    have h₇ : ad (c or d) e f → ad ((ad c a b) or (ad d a b)) e f,
                        from T₁ h₃ h₆,
                    have h₈ : ad (c or d) a b → ad ((ad c a b) or (ad d a b)) e f,
                        from (assume h, ad₆ $ ad₇ h),
                    have h₉ : ((ad (c or d) e f) or (ad (c or d) a b)) → ad ((ad c a b) or (ad d a b)) e f,
                        from δ_or₁ h₇ h₈,
                    (T₁ h₂ h₉) h₁

                theorem ad₁₂_ad {a b c: Prop} (h₁ : ad (a or a) b c) : ad a b c :=
                    ad₁₂ $ ad₇ h₁

                theorem ad₁₃_ad {a b c d : Prop} (h₁ : ad (a or b) c d) : ad (b or a) c d :=
                    ad₈ $ ad₁₃ $ ad₇ h₁

                theorem ad₁₄_ad {a b c d e : Prop} (h₁ : ad (a or (b or c)) d e) : ad ((a or b) or c) d e :=
                    ad₈ $ ad₁₃ $ ad₂₂ $ ad₁₃ $ ad₁₄ $ ad₂₁ $ ad₇ h₁

                theorem ad₈' {a b c d e f : Prop} (h₁ : ad (ad c a b) e f) : ad (ad (c or d) a b) e f :=
                    have h₂ : (ad (ad c a b) e f) → ((ad c e f) or (ad c a b)), from ad₁₀,
                    have h₃ : (ad c e f) → (ad (ad (c or d) a b) e f), from (assume h, ad₂₇ $ ad₆ $ ad₆_ad h),
                    have h₄ : (ad c a b) → (ad (ad (c or d) a b) e f), from (assume h, ad₆ $ ad₆_ad h),
                    have h₅ : ((ad c e f) or (ad c a b)) → (ad (ad (c or d) a b) e f), from δ_or₁ h₃ h₄,
                    show ad (ad (c or d) a b) e f, from (T₁ h₂ h₅) h₁

                theorem ad₈'' {a b c d e f : Prop} (h₁ : ad (ad (c or d) a b) e f) : ad (ad (d or c) a b) e f :=
                    have h₃₁ : (ad (ad (c or d) a b) e f) → ((ad (c or d) e f) or (ad (c or d) a b)),
                        from ad₁₀,
                    have h₃₂ : ad (c or d) e f → ad (ad (d or c) a b) e f,
                        from (assume h, ad₂₇ $ ad₆ $ ad₁₃_ad h),
                    have h₃₃ : ad (c or d) a b → ad (ad (d or c) a b) e f,
                        from (assume h, ad₆ $ ad₁₃_ad h),
                    have h₃₄ : ((ad (c or d) e f) or (ad (c or d) a b)) → ad (ad (d or c) a b) e f,
                        from δ_or₁ h₃₂ h₃₃,
                    (T₁ h₃₁ h₃₄) h₁

                theorem ad₈_ad {a b c d e f : Prop} (h₁ : ad ((ad c a b) or (ad d a b)) e f) :
                    ad (ad (c or d) a b) e f :=
                    have h₂ : ad ((ad c a b) or (ad d a b)) e f → ((ad (ad c a b) e f) or (ad (ad d a b) e f)),
                        from ad₇,
                    have h₃ : ad (ad c a b) e f → ad (ad (c or d) a b) e f,
                        from ad₈',
                    have h₄ : ad (ad d a b) e f → ad (ad (c or d) a b) e f,
                        from (assume h, ad₈'' $ ad₈' h),
                    have h₅ : ((ad (ad c a b) e f) or (ad (ad d a b) e f)) → ad (ad (c or d) a b) e f,
                        from δ_or₁ h₃ h₄,
                    (T₁ h₂ h₅) h₁

                theorem ad₉_ad {a b c d e f g : Prop} (h₁ : ad (ad a b c) f g) (h₂ : ad (ad d e a) f g) : ad (ad d b c) f g :=
                    let g' := ad d f g, c' := ad d b c in
                        have h₃ : ad (ad a b c) f g → ((ad a f g) or (ad a b c)),
                            from ad₁₀,
                        have h₄ : ad (ad d e a) f g → (g' or (ad d e a)),
                            from ad₁₀,
                        have h₅ : ad a b c → ad d f g → (g' or c'),
                            from M₁ ad₆',
                        have h₆ : ad a b c → ad d e a → (g' or c'),
                            from (assume h, assume i, ad₁₃ $ ad₆' $ ad₉ h i),
                        have h₇ : ad a f g → ad d f g → (g' or c'),
                            from M₁ ad₆',
                        have h₈ : ad a f g → ad d e a → (g' or c'),
                            from (assume h, assume i, ad₆' $ ad₉ h i),
                        have h₉ : (g' or (ad d e a)) → ad a b c → (g' or c'),
                            from flip (δ_or₂ h₅ h₆),
                        have h₁₀ : (g' or (ad d e a)) → ad a f g  → (g' or c'),
                            from flip (δ_or₂ h₇ h₈),
                        have h₁₁ : (g' or (ad d e a)) → ((ad a f g) or (ad a b c)) → (g' or c'),
                            from δ_or₂ h₁₀ h₉,
                        have h₁₂ : (ad (ad a b c) f g) → (g' or (ad d e a)) → (g' or c'),
                            from flip (T₂ (M₁ h₃) h₁₁),
                        have h₁₃ : (ad (ad a b c) f g) → (ad (ad d e a) f g) → (g' or c'),
                            from T₂ (M₁ h₄) h₁₂,
                        ad₁₁ (h₁₃ h₁ h₂)

                theorem ad₁₀_ad {a b c d e f g : Prop} (h₁ : ad (ad (ad e d c) a b) f g)
                    : ad ((ad e a b) or (ad e d c)) f g :=
                    have h₂ : ad (ad (ad e d c) a b) f g → ((ad (ad e d c) f g) or (ad (ad e d c) a b)),
                        from ad₁₀,
                    have h₃ : ad (ad e d c) f g → ad ((ad e a b) or (ad e d c)) f g,
                        from (assume h, ad₈ $ ad₁₃ $ ad₆' h),
                    have h₄ : ad (ad e d c) a b → ad ((ad e a b) or (ad e d c)) f g,
                        from (assume h, ad₆ $ ad₁₀ h),
                    have h₅ : ((ad (ad e d c) f g) or (ad (ad e d c) a b)) → ad ((ad e a b) or (ad e d c)) f g,
                        from δ_or₁ h₃ h₄,
                    (T₁ h₂ h₅) h₁

                theorem ad₁₁_ad {a b c d e f g : Prop} (h₁ : ad ((ad e a b) or (ad e d c)) f g)
                    : ad (ad (ad e d c) a b) f g :=
                    have h₂ : ad ((ad e a b) or (ad e d c)) f g → ((ad (ad e a b) f g) or (ad (ad e d c) f g)),
                        from ad₇,
                    have h₃ : ad (ad e a b) f g → ((ad e f g) or (ad e a b)),
                        from ad₁₀,
                    have h₄ : ad e f g → ((ad e f g) or (ad e d c)),
                        from ad₆',
                    have h₅ : ((ad e f g) or (ad e d c)) → ad (ad (ad e d c) a b) f g,
                        from (assume h, ad₁₁ $ ad₁₃ $ ad₁₀ $ ad₆ $ ad₁₁ h),
                    have h₆ : ad e f g → ad (ad (ad e d c) a b) f g,
                        from T₁ h₄ h₅,
                    have h₇ : ((ad e a b) or (ad e d c)) → ad (ad (ad e d c) a b) f g,
                        from (assume h, ad₆ $ ad₁₁ h),
                    have h₈ : ad e a b → ((ad e a b) or (ad e d c)),
                        from ad₆',
                    have h₉ : ad e a b → ad (ad (ad e d c) a b) f g,
                        from T₁ h₈ h₇,
                    have h₁₀ : ((ad e f g) or (ad e a b)) → ad (ad (ad e d c) a b) f g,
                        from δ_or₁ h₆ h₉,
                    have h₁₁ : ad (ad e a b) f g → ad (ad (ad e d c) a b) f g,
                        from T₁ h₃ h₁₀,
                    have h₁₂ : ad (ad e d c) f g → ad (ad (ad e d c) a b) f g,
                        from (assume h, ad₂₇ $ ad₆ $ ad₁₁ $ ad₁₀ h),
                    have h₁₃ : ((ad (ad e a b) f g) or (ad (ad e d c) f g)) → ad (ad (ad e d c) a b) f g,
                        from δ_or₁ h₁₁ h₁₂,
                    (T₁ h₂ h₁₃) h₁
            end ad
        end wr
    end hilbert
end clfrags