/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro

! This file was ported from Lean 3 source module logic.embedding.set
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Embedding.Basic
import Mathbin.Data.Set.Image

/-!
# Interactions between embeddings and sets.

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

-/

universe u v w x

section Equiv

variable {α : Sort u} {β : Sort v} (f : α ≃ β)

/- warning: equiv.as_embedding_range -> Equiv.asEmbedding_range is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Type.{u2}} {p : β -> Prop} (e : Equiv.{u1, succ u2} α (Subtype.{succ u2} β p)), Eq.{succ u2} (Set.{u2} β) (Set.range.{u2, u1} β α (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α β) (fun (_x : Function.Embedding.{u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{u1, succ u2} α β) (Equiv.asEmbedding.{u1, succ u2} α β p e))) (setOf.{u2} β p)
but is expected to have type
  forall {α : Sort.{u2}} {β : Type.{u1}} {p : β -> Prop} (e : Equiv.{u2, succ u1} α (Subtype.{succ u1} β p)), Eq.{succ u1} (Set.{u1} β) (Set.range.{u1, u2} β α (FunLike.coe.{max (max 1 u2) (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max (max 1 u2) (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α β (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α β)) (Equiv.asEmbedding.{succ u1, u2} β α p e))) (setOf.{u1} β p)
Case conversion may be inaccurate. Consider using '#align equiv.as_embedding_range Equiv.asEmbedding_rangeₓ'. -/
@[simp]
theorem Equiv.asEmbedding_range {α β : Sort _} {p : β → Prop} (e : α ≃ Subtype p) :
    Set.range e.asEmbedding = setOf p :=
  Set.ext fun x => ⟨fun ⟨y, h⟩ => h ▸ Subtype.coe_prop (e y), fun hs => ⟨e.symm ⟨x, hs⟩, by simp⟩⟩
#align equiv.as_embedding_range Equiv.asEmbedding_range

end Equiv

namespace Function

namespace Embedding

#print Function.Embedding.coeWithTop /-
/-- Embedding into `with_top α`. -/
@[simps]
def coeWithTop {α} : α ↪ WithTop α :=
  { Embedding.some with toFun := coe }
#align function.embedding.coe_with_top Function.Embedding.coeWithTop
-/

#print Function.Embedding.optionElim /-
/-- Given an embedding `f : α ↪ β` and a point outside of `set.range f`, construct an embedding
`option α ↪ β`. -/
@[simps]
def optionElim {α β} (f : α ↪ β) (x : β) (h : x ∉ Set.range f) : Option α ↪ β :=
  ⟨Option.elim' x f, Option.injective_iff.2 ⟨f.2, h⟩⟩
#align function.embedding.option_elim Function.Embedding.optionElim
-/

/- warning: function.embedding.option_embedding_equiv -> Function.Embedding.optionEmbeddingEquiv is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) (β : Type.{u2}), Equiv.{max 1 (succ u1) (succ u2), max (succ (max u1 u2)) (succ u2)} (Function.Embedding.{succ u1, succ u2} (Option.{u1} α) β) (Sigma.{max u1 u2, u2} (Function.Embedding.{succ u1, succ u2} α β) (fun (f : Function.Embedding.{succ u1, succ u2} α β) => coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) (HasCompl.compl.{u2} (Set.{u2} β) (BooleanAlgebra.toHasCompl.{u2} (Set.{u2} β) (Set.booleanAlgebra.{u2} β)) (Set.range.{u2, succ u1} β α (coeFn.{max 1 (succ u1) (succ u2), max (succ u1) (succ u2)} (Function.Embedding.{succ u1, succ u2} α β) (fun (_x : Function.Embedding.{succ u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{succ u1, succ u2} α β) f)))))
but is expected to have type
  forall (α : Type.{u1}) (β : Type.{u2}), Equiv.{max (succ u2) (succ u1), max (succ u2) (succ (max u1 u2))} (Function.Embedding.{succ u1, succ u2} (Option.{u1} α) β) (Sigma.{max u1 u2, u2} (Function.Embedding.{succ u1, succ u2} α β) (fun (f : Function.Embedding.{succ u1, succ u2} α β) => Set.Elem.{u2} β (HasCompl.compl.{u2} (Set.{u2} β) (BooleanAlgebra.toHasCompl.{u2} (Set.{u2} β) (Set.instBooleanAlgebraSet.{u2} β)) (Set.range.{u2, succ u1} β α (FunLike.coe.{max (succ u2) (succ u1), succ u1, succ u2} (Function.Embedding.{succ u1, succ u2} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max (succ u2) (succ u1), succ u1, succ u2} (Function.Embedding.{succ u1, succ u2} α β) α β (Function.instEmbeddingLikeEmbedding.{succ u1, succ u2} α β)) f)))))
Case conversion may be inaccurate. Consider using '#align function.embedding.option_embedding_equiv Function.Embedding.optionEmbeddingEquivₓ'. -/
/-- Equivalence between embeddings of `option α` and a sigma type over the embeddings of `α`. -/
@[simps]
def optionEmbeddingEquiv (α β) : (Option α ↪ β) ≃ Σf : α ↪ β, ↥(Set.range fᶜ)
    where
  toFun f := ⟨some.trans f, f none, fun ⟨x, hx⟩ => Option.some_ne_none x <| f.Injective hx⟩
  invFun f := f.1.optionElim f.2 f.2.2
  left_inv f := ext <| by rintro (_ | _) <;> simp [Option.coe_def]
  right_inv := fun ⟨f, y, hy⟩ => by ext <;> simp [Option.coe_def]
#align function.embedding.option_embedding_equiv Function.Embedding.optionEmbeddingEquiv

#print Function.Embedding.codRestrict /-
/-- Restrict the codomain of an embedding. -/
def codRestrict {α β} (p : Set β) (f : α ↪ β) (H : ∀ a, f a ∈ p) : α ↪ p :=
  ⟨fun a => ⟨f a, H a⟩, fun a b h => f.Injective (@congr_arg _ _ _ _ Subtype.val h)⟩
#align function.embedding.cod_restrict Function.Embedding.codRestrict
-/

/- warning: function.embedding.cod_restrict_apply -> Function.Embedding.codRestrict_apply is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Type.{u2}} (p : Set.{u2} β) (f : Function.Embedding.{u1, succ u2} α β) (H : forall (a : α), Membership.Mem.{u2, u2} β (Set.{u2} β) (Set.hasMem.{u2} β) (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α β) (fun (_x : Function.Embedding.{u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{u1, succ u2} α β) f a) p) (a : α), Eq.{succ u2} (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p) (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) (fun (_x : Function.Embedding.{u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) => α -> (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) (Function.Embedding.hasCoeToFun.{u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) p)) (Function.Embedding.codRestrict.{u1, u2} α β p f H) a) (Subtype.mk.{succ u2} β (fun (x : β) => Membership.Mem.{u2, u2} β (Set.{u2} β) (Set.hasMem.{u2} β) x p) (coeFn.{max 1 u1 (succ u2), max u1 (succ u2)} (Function.Embedding.{u1, succ u2} α β) (fun (_x : Function.Embedding.{u1, succ u2} α β) => α -> β) (Function.Embedding.hasCoeToFun.{u1, succ u2} α β) f a) (H a))
but is expected to have type
  forall {α : Sort.{u2}} {β : Type.{u1}} (p : Set.{u1} β) (f : Function.Embedding.{u2, succ u1} α β) (H : forall (a : α), Membership.mem.{u1, u1} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) a) (Set.{u1} β) (Set.instMembershipSet.{u1} β) (FunLike.coe.{max (succ u1) u2, u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max (succ u1) u2, u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α β (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α β)) f a) p) (a : α), Eq.{succ u1} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => Set.Elem.{u1} β p) a) (FunLike.coe.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α (Set.Elem.{u1} β p)) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => Set.Elem.{u1} β p) _x) (EmbeddingLike.toFunLike.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α (Set.Elem.{u1} β p)) α (Set.Elem.{u1} β p) (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α (Set.Elem.{u1} β p))) (Function.Embedding.codRestrict.{u2, u1} α β p f H) a) (Subtype.mk.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Set.{u1} β) (Set.instMembershipSet.{u1} β) x p) (FunLike.coe.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{max u2 (succ u1), u2, succ u1} (Function.Embedding.{u2, succ u1} α β) α β (Function.instEmbeddingLikeEmbedding.{u2, succ u1} α β)) f a) (H a))
Case conversion may be inaccurate. Consider using '#align function.embedding.cod_restrict_apply Function.Embedding.codRestrict_applyₓ'. -/
@[simp]
theorem codRestrict_apply {α β} (p) (f : α ↪ β) (H a) : codRestrict p f H a = ⟨f a, H a⟩ :=
  rfl
#align function.embedding.cod_restrict_apply Function.Embedding.codRestrict_apply

open Set

#print Function.Embedding.image /-
/-- `set.image` as an embedding `set α ↪ set β`. -/
@[simps apply]
protected def image {α β} (f : α ↪ β) : Set α ↪ Set β :=
  ⟨image f, f.2.image_injective⟩
#align function.embedding.image Function.Embedding.image
-/

end Embedding

end Function

namespace Set

#print Set.embeddingOfSubset /-
/-- The injection map is an embedding between subsets. -/
@[simps apply]
def embeddingOfSubset {α} (s t : Set α) (h : s ⊆ t) : s ↪ t :=
  ⟨fun x => ⟨x.1, h x.2⟩, fun ⟨x, hx⟩ ⟨y, hy⟩ h =>
    by
    congr
    injection h⟩
#align set.embedding_of_subset Set.embeddingOfSubset
-/

end Set

section Subtype

variable {α : Type _}

#print subtypeOrEquiv /-
/-- A subtype `{x // p x ∨ q x}` over a disjunction of `p q : α → Prop` is equivalent to a sum of
subtypes `{x // p x} ⊕ {x // q x}` such that `¬ p x` is sent to the right, when
`disjoint p q`.

See also `equiv.sum_compl`, for when `is_compl p q`.  -/
@[simps apply]
def subtypeOrEquiv (p q : α → Prop) [DecidablePred p] (h : Disjoint p q) :
    { x // p x ∨ q x } ≃ Sum { x // p x } { x // q x }
    where
  toFun := subtypeOrLeftEmbedding p q
  invFun :=
    Sum.elim (Subtype.impEmbedding _ _ fun x hx => (Or.inl hx : p x ∨ q x))
      (Subtype.impEmbedding _ _ fun x hx => (Or.inr hx : p x ∨ q x))
  left_inv x := by
    by_cases hx : p x
    · rw [subtypeOrLeftEmbedding_apply_left _ hx]
      simp [Subtype.ext_iff]
    · rw [subtypeOrLeftEmbedding_apply_right _ hx]
      simp [Subtype.ext_iff]
  right_inv x := by
    cases x
    · simp only [Sum.elim_inl]
      rw [subtypeOrLeftEmbedding_apply_left]
      · simp
      · simpa using x.prop
    · simp only [Sum.elim_inr]
      rw [subtypeOrLeftEmbedding_apply_right]
      · simp
      · suffices ¬p x by simpa
        intro hp
        simpa using h.le_bot x ⟨hp, x.prop⟩
#align subtype_or_equiv subtypeOrEquiv
-/

#print subtypeOrEquiv_symm_inl /-
@[simp]
theorem subtypeOrEquiv_symm_inl (p q : α → Prop) [DecidablePred p] (h : Disjoint p q)
    (x : { x // p x }) : (subtypeOrEquiv p q h).symm (Sum.inl x) = ⟨x, Or.inl x.Prop⟩ :=
  rfl
#align subtype_or_equiv_symm_inl subtypeOrEquiv_symm_inl
-/

#print subtypeOrEquiv_symm_inr /-
@[simp]
theorem subtypeOrEquiv_symm_inr (p q : α → Prop) [DecidablePred p] (h : Disjoint p q)
    (x : { x // q x }) : (subtypeOrEquiv p q h).symm (Sum.inr x) = ⟨x, Or.inr x.Prop⟩ :=
  rfl
#align subtype_or_equiv_symm_inr subtypeOrEquiv_symm_inr
-/

end Subtype


namespace deduction_basic
  class has_Hyp (Form : Type) :=
    (Hyp : Type)
    [emptyHyp : has_emptyc Hyp]
    [insertHyp : has_insert Form Hyp]
  instance singleHyp {Form : Type} [hasHyp : has_Hyp Form] : has_singleton Form hasHyp.Hyp :=
    {singleton := λ φ, hasHyp.insertHyp.insert φ hasHyp.emptyHyp.emptyc}

  instance lawfulSingleHyp {Form : Type} [hasHyp : has_Hyp Form] :
  @is_lawful_singleton Form (has_Hyp.Hyp Form) hasHyp.emptyHyp hasHyp.insertHyp deduction_basic.singleHyp :=
  { insert_emptyc_eq := begin assume φ, refl end }

  class has_derives (Form : Type) extends has_Hyp Form :=
    (derives : Hyp → Form → Prop)
    (derive_Trans : ∀ {Φ : Hyp} (ψ) {θ : Form}, derives Φ ψ → derives {ψ} θ → derives Φ θ)

  def der {Form : Type} [Der : has_derives Form] : Form → Form → Prop :=
    λ φ ψ, has_derives.derives {φ} ψ

  infix `⊢`:60 := der

  lemma derive_trans {Form : Type} [Der : has_derives Form] :
    ∀ {φ : Form} (ψ) {θ}, (φ ⊢ ψ) → (ψ ⊢ θ) → (φ ⊢ θ) :=
  begin
    assume φ,
    apply Der.derive_Trans,
  end

  class has_struct_derives (Form : Type) extends has_derives Form :=
    [memHyp : has_mem Form Hyp]
    (inInsert : ∀ {φ : Form} {Φ : Hyp}, φ ∈ insert φ Φ)
    (hyp : ∀ {Φ} {φ}, (φ ∈ Φ) → derives Φ φ)
    (weak1 : ∀ {Φ} {φ} (ψ), derives Φ φ → derives (insert ψ Φ) φ)

  lemma derive_refl {Form : Type} [Der : has_struct_derives Form] :
    ∀ φ : Form, φ ⊢ φ :=
  begin
    assume φ,
    apply Der.hyp,
    apply Der.inInsert,
  end

end deduction_basic


import data.stream

import unitb.scheduling
import unitb.logic

import util.data.bijection
import util.data.finite
import util.data.countable

namespace det

open predicate

structure program (lbl : Type) (α : Type) : Type :=
  (first : α)
  (step : lbl → α → α)

@[reducible]
def pred (α : Sort*) := pred' α

variables {lbl α : Type}

def program.init (s : program lbl α) (p : pred α) : Prop :=
(s^.first) ⊨ p

def program.take_step (s : program lbl α) : option lbl → α → α
  | none := id
  | (some e) := s^.step e

def program.action_of (s : program lbl α) (e : option lbl) (σ σ' : α) : Prop :=
σ' = s^.take_step e σ

def is_step (s : program lbl α) (σ σ' : α) : Prop :=
∃ ev, s.action_of ev σ σ'

def program.falsify (s : program lbl α) (ev : option lbl) (p q : pred α) : Prop :=
∀ σ, σ ⊨ q → (s^.take_step ev σ) ⊨ - q

def program.transient (s : program lbl α) (p q : pred α) : Prop :=
∃ ev, s.falsify ev p q

def program.falsify_action (s : program lbl α) (p q : pred α) (ev : option lbl)
  (h : s.falsify ev p q)
: •q ⟹ ( ⟦ s.action_of ev ⟧ ⟶ ⊙ - •q ) :=
begin [temporal]
  action {
    intros Hq H₁,
    unfold program.action_of at H₁,
    rw H₁,
    apply (h _ Hq) },
end

lemma program.falsify.negate
   {s : program lbl α} {act : option lbl} {p q : pred' α}
   (H : s.falsify act p q)
:  •q ⋀ ⟦ s^.action_of act ⟧ ⟹ ◇-•q :=
begin [temporal]
  intros H',
  strengthen_to ⊙-• _ ,
  exact program.falsify_action s p q act H Γ H'.left H'.right,
end

lemma program.transient_impl (s : program lbl α) (p : pred' α)
: s.transient p False :=
begin
  unfold program.transient False,
  existsi @none lbl,
  intros σ h,
  cases h
end

lemma program.transient_antimono (s : program lbl α) {p q p' q' : pred α}
  (hp : p' ⟹ p)
  (hq : q' ⟹ q)
  (T₀ : s.transient p q)
: s.transient p' q' :=
begin
  unfold program.transient,
  cases T₀ with ev T₁,
  existsi ev,
  intros σ,
  imp_transitivity [σ ⊨ q,program.take_step s ev σ ⊨ -q], simp,
  intros_mono, apply ew_str hq,
  apply T₁, apply ew_str hq,
end

instance prog_is_system : unitb.system (program lbl α) :=
  { σ := α
  , init := program.init
  , step := is_step
  , transient := program.transient
  , transient_false := λ s p, program.transient_impl s _
  , transient_antimono := program.transient_antimono
  }

open temporal

structure ex (p : program lbl α) (τ : stream α) : Prop :=
    (init : τ 0 = p^.first)
    (safety : τ ⊨ unitb.saf_ex p)
    (liveness : ∀ e, τ ⊨ ◻ ◇ ⟦ p.action_of e ⟧)

open unitb
open nat

section soundness

variables (s : program lbl α)
variables (Γ : cpred α)
variables {p q : pred' α}
variables h : Γ ⊢ ex s

lemma safety : Γ ⊢ ex s ⟶ unitb.saf_ex s :=
by { apply p_imp_ext,
     introv _, apply ex.safety, }
lemma liveness : Γ ⊢ ex s ⟶ ∀∀ e, ◻ ◇ ⟦ s.action_of e ⟧ :=
by { apply p_imp_ext,
     introv _, apply ex.liveness, }

variables {s}
include h

lemma init_sem
  (I₀ : init s p)
: Γ ⊢ •p :=
begin [temporal]
  explicit τ {
    rw h.init,
    apply I₀ }
end

lemma transient.semantics
  (T₀ : s.transient p q)
: Γ ⊢ ◻◇•p ⟶ ◻◇-•q :=
begin [temporal]
  intro,
  simp [program.transient] at T₀,
  cases T₀ with ev T₀,
  assume_negation with hq ,
  simp [p_not_p_not_iff_self] at hq,
  have occ := coincidence hq (liveness s Γ h ev),
  clear h,
  henceforth at occ ⊢,
  eventually occ,
  apply T₀.negate Γ occ
end

end soundness

open scheduling scheduling.unitb

def object (p : program lbl α) : target_mch (option lbl) :=
{ σ := α
, s₀ := p.first
, next := λ l s P, p.take_step l s
, req := ↑λ _ : α, @set.univ (option lbl)
, req_nemp := by { intros _, rw [set.ne_empty_iff_exists_mem], existsi none, trivial, } }

lemma program.witness [sched lbl] (s : program lbl α)
: ∃ (τ : stream (state (program lbl α))), ex s τ :=
begin
  apply exists_imp_exists _ (sched.sched_str (object s)),
  intros τ h,
  have H : ∀ e, •(↑e ∊ (object s).req) ⋀ ⟦target_mch.action (object s) e⟧
              ⟹ ⟦s.action_of e⟧,
  { simp [init_eq_action,action_and_action],
    intro e,
    apply action_entails_action,
    intros σ σ',
    unfold target_mch.action,
    rw [exists_and,exists_imp_iff_forall_imp],
    intro, apply and.left },
  apply ex.mk,
  { rw h.init, refl },
  replace h := h.valid,
  begin [temporal]
    simp [saf_ex],
    henceforth at h ⊢,
    cases h with l h,
    have := (H l Γ h),
    revert this,
    action {
      simp [unitb.step,has_safety.step,is_step],
      intro h, exact ⟨_,h⟩ },
  end,
  intro e, have H' := h.fair e,
  begin [temporal]
    note H'' : •(↑e ∊ (object s).req) = True,
    { simp [temporal.init], congr, },
    simp [H''] at H',
    revert H', monotonicity,
    intros H', apply H e Γ _,
    simp [H''], apply H',
  end
end

instance {α} [sched lbl] : system_sem (program lbl α) :=
  { (_ : system (program lbl α)) with
    ex := λ p, (↑(ex p) : cpred _)
  , safety := safety
  , inhabited := program.witness
  , init_sem := @init_sem _ _
  , transient_sem := @transient.semantics _ _  }

end det


-- http://leanprover.github.io/ijcar16/examples/

/-
This is a file from the Lean standard library.
We use it to demonstrate/test the congruence closure procedure
described in the paper:
  "Congruence Closure for Intensional Type Theory"
   Daniel Selsam and Leonardo de Moura

The lemmas proved using `by inst_simp` are using the congruence closure
procedure described in the paper above.

The lemmas proved using `by rec_inst_simp` are also using the congruence closure
procedure described in the paper above. They first apply induction, and then use
`inst_simp`.

The tactic inst_simp uses E-matching to heuristically instantiate
lemmas tagged as simplification rules (i.e., `[simp]` tag in Lean).

There are 15 instances `by inst_simp` and `by rec_inst_simp` in this file.
-/
import EggTactic

macro mods:declModifiers "lemma" n:declId sig:declSig val:declVal : command => `($mods:declModifiers theorem $n $sig $val)

theorem cons_eq {α : Type} (a : α) (t : List α) : List.cons a t = List.cons a t :=
  by rfl

lemma nil_eq {α : Type} : (List.nil : List α) = (List.nil : List α) :=
  by rfl

#print nil_eq

lemma head_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : List A} :
      (h₁::t₁) = (h₂::t₂) → h₁ = h₂ :=
--by inst_simp
  by
  intros
  rawEgg [cons_eq, nil_eq]

#print head_eq_of_cons_eq

lemma tail_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : List A} :
      (h₁::t₁) = (h₂::t₂) → t₁ = t₂ :=
by inst_simp

/- append -/

definition append : List T → List T → List T
| []       l := l
| (h :: s) t := h :: (append s t)

notation l₁ ++ l₂ := append l₁ l₂

theorem append_nil_left [simp] (t : List T) : [] ++ t = t :=
rfl

theorem append_cons [simp] (x : T) (s t : List T) : (x::s) ++ t = x::(s ++ t) :=
rfl

theorem append_nil_right [simp] : ∀ (t : List T), t ++ [] = t :=
by rec_inst_simp

theorem append.assoc [simp] : ∀ (s t u : List T), s ++ t ++ u = s ++ (t ++ u) :=
by rec_inst_simp

/- length -/
definition length : List T → nat
| []       := 0
| (a :: l) := length l + 1

theorem length_nil [simp] : length (@nil T) = 0 :=
rfl

theorem length_cons [simp] (x : T) (t : List T) : length (x::t) = length t + 1 :=
rfl

theorem length_append [simp] : ∀ (s t : List T), length (s ++ t) = length s + length t :=
by rec_inst_simp

theorem eq_nil_of_length_eq_zero : ∀ {l : List T}, length l = 0 → l = []
| []     H := rfl
| (a::s) H := by contradiction

theorem ne_nil_of_length_eq_succ : ∀ {l : List T} {n : nat}, length l = succ n → l ≠ []
| []     n h := by contradiction
| (a::l) n h := by contradiction

/- concat -/

definition concat : Π (x : T), List T → List T
| a []       := [a]
| a (b :: l) := b :: concat a l

theorem concat_nil [simp] (x : T) : concat x [] = [x] :=
rfl

theorem concat_cons [simp] (x y : T) (l : List T) : concat x (y::l)  = y::(concat x l) :=
rfl

theorem concat_eq_append [simp] (a : T) : ∀ (l : List T), concat a l = l ++ [a] :=
by rec_inst_simp

theorem concat_ne_nil [simp] (a : T) : ∀ (l : List T), concat a l ≠ [] :=
by intro l; induction l; repeat contradiction

theorem length_concat [simp] (a : T) : ∀ (l : List T), length (concat a l) = length l + 1 :=
by rec_inst_simp

theorem concat_append [simp] (a : T) : ∀ (l₁ l₂ : List T), concat a l₁ ++ l₂ = l₁ ++ a :: l₂ :=
by rec_inst_simp

theorem append_concat (a : T)  : ∀(l₁ l₂ : List T), l₁ ++ concat a l₂ = concat a (l₁ ++ l₂) :=
by rec_inst_simp

/- last -/

definition last : Π l : List T, l ≠ [] → T
| []          h := absurd rfl h
| [a]         h := a
| (a₁::a₂::l) h := last (a₂::l) !cons_ne_nil

lemma last_singleton [simp] (a : T) (h : [a] ≠ []) : last [a] h = a :=
rfl

lemma last_cons_cons [simp] (a₁ a₂ : T) (l : List T) (h : a₁::a₂::l ≠ []) : last (a₁::a₂::l) h = last (a₂::l) !cons_ne_nil :=
rfl

theorem last_congr {l₁ l₂ : List T} (h₁ : l₁ ≠ []) (h₂ : l₂ ≠ []) (h₃ : l₁ = l₂) : last l₁ h₁ = last l₂ h₂ :=
by subst l₁

theorem last_concat [simp] {x : T} : ∀ {l : List T} (h : concat x l ≠ []), last (concat x l) h = x :=
by rec_simp

-- add_rewrite append_nil append_cons

/- reverse -/

definition reverse : List T → List T
| []       := []
| (a :: l) := concat a (reverse l)

theorem reverse_nil [simp] : reverse (@nil T) = [] :=
rfl

theorem reverse_cons [simp] (x : T) (l : List T) : reverse (x::l) = concat x (reverse l) :=
rfl

theorem reverse_singleton [simp] (x : T) : reverse [x] = [x] :=
rfl

theorem reverse_append [simp] : ∀ (s t : List T), reverse (s ++ t) = (reverse t) ++ (reverse s) :=
by rec_inst_simp

theorem reverse_reverse [simp] : ∀ (l : List T), reverse (reverse l) = l :=
by rec_inst_simp

theorem concat_eq_reverse_cons (x : T) (l : List T) : concat x l = reverse (x :: reverse l) :=
by inst_simp

theorem length_reverse : ∀ (l : List T), length (reverse l) = length l :=
by rec_inst_simp

/- head and tail -/

definition head [h : inhabited T] : List T → T
| []       := arbitrary T
| (a :: l) := a

theorem head_cons [simp] [h : inhabited T] (a : T) (l : List T) : head (a::l) = a :=
rfl

theorem head_append [simp] [h : inhabited T] (t : List T) : ∀ {s : List T}, s ≠ [] → head (s ++ t) = head s :=
by rec_inst_simp

definition tail : List T → List T
| []       := []
| (a :: l) := l

theorem tail_nil [simp] : tail (@nil T) = [] :=
rfl

theorem tail_cons [simp] (a : T) (l : List T) : tail (a::l) = l :=
rfl

theorem cons_head_tail [h : inhabited T] {l : List T} : l ≠ [] → (head l)::(tail l) = l :=
by rec_inst_simp

/-
This is a file from the Lean standard library.
We use it to demonstrate/test the congruence closure procedure
described in the paper:
  "Congruence Closure for Intensional Type Theory"
   Daniel Selsam and Leonardo de Moura

The lemmas proved using `by inst_simp` are using the congruence closure
procedure described in the paper above.

The tactic inst_simp uses E-matching to heuristically instantiate
lemmas tagged as simplification rules (i.e., `[simp]` tag in Lean).

There are more than 100 instances of `by inst_simp` in this file.
-/
import algebra.binary algebra.priority

variable {A : Type}

/- semigroup -/

attribute inv [light 3]
attribute neg [light 3]

structure semigroup [class] (A : Type) extends has_mul A :=
(mul_assoc : ∀a b c, mul (mul a b) c = mul a (mul b c))

-- We add pattern hints to the following lemma because we want it to be used in both directions
-- at inst_simp strategy.
theorem mul.assoc [simp] [semigroup A] (a b c : A) : (: a * b * c :) = (: a * (b * c) :) :=
!semigroup.mul_assoc

structure comm_semigroup [class] (A : Type) extends semigroup A :=
(mul_comm : ∀a b, mul a b = mul b a)

theorem mul.comm [simp] [comm_semigroup A] (a b : A) : a * b = b * a :=
!comm_semigroup.mul_comm

theorem mul.left_comm [simp] [comm_semigroup A] (a b c : A) : a * (b * c) = b * (a * c) :=
binary.left_comm (@mul.comm A _) (@mul.assoc A _) a b c

theorem mul.right_comm [comm_semigroup A] (a b c : A) : (a * b) * c = (a * c) * b :=
by inst_simp

structure left_cancel_semigroup [class] (A : Type) extends semigroup A :=
(mul_left_cancel : ∀a b c, mul a b = mul a c → b = c)

theorem mul.left_cancel [left_cancel_semigroup A] {a b c : A} : a * b = a * c → b = c :=
!left_cancel_semigroup.mul_left_cancel

abbreviation eq_of_mul_eq_mul_left' := @mul.left_cancel

structure right_cancel_semigroup [class] (A : Type) extends semigroup A :=
(mul_right_cancel : ∀a b c, mul a b = mul c b → a = c)

theorem mul.right_cancel [right_cancel_semigroup A] {a b c : A} : a * b = c * b → a = c :=
!right_cancel_semigroup.mul_right_cancel

abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel

/- additive semigroup -/

structure add_semigroup [class] (A : Type) extends has_add A :=
(add_assoc : ∀a b c, add (add a b) c = add a (add b c))

theorem add.assoc [simp] [add_semigroup A] (a b c : A) : (: a + b + c :) = (: a + (b + c) :) :=
!add_semigroup.add_assoc

structure add_comm_semigroup [class] (A : Type) extends add_semigroup A :=
(add_comm : ∀a b, add a b = add b a)

theorem add.comm [simp] [add_comm_semigroup A] (a b : A) : a + b = b + a :=
!add_comm_semigroup.add_comm

theorem add.left_comm [simp] [add_comm_semigroup A] (a b c : A) : a + (b + c) = b + (a + c) :=
binary.left_comm (@add.comm A _) (@add.assoc A _) a b c

theorem add.right_comm [add_comm_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b :=
by inst_simp

structure add_left_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
(add_left_cancel : ∀a b c, add a b = add a c → b = c)

theorem add.left_cancel [add_left_cancel_semigroup A] {a b c : A} : a + b = a + c → b = c :=
!add_left_cancel_semigroup.add_left_cancel

abbreviation eq_of_add_eq_add_left := @add.left_cancel

structure add_right_cancel_semigroup [class] (A : Type) extends add_semigroup A :=
(add_right_cancel : ∀a b c, add a b = add c b → a = c)

theorem add.right_cancel [add_right_cancel_semigroup A] {a b c : A} : a + b = c + b → a = c :=
!add_right_cancel_semigroup.add_right_cancel

abbreviation eq_of_add_eq_add_right := @add.right_cancel

/- monoid -/

structure monoid [class] (A : Type) extends semigroup A, has_one A :=
(one_mul : ∀a, mul one a = a) (mul_one : ∀a, mul a one = a)

theorem one_mul [simp] [monoid A] (a : A) : 1 * a = a := !monoid.one_mul

theorem mul_one [simp] [monoid A] (a : A) : a * 1 = a := !monoid.mul_one

structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A

/- additive monoid -/

structure add_monoid [class] (A : Type) extends add_semigroup A, has_zero A :=
(zero_add : ∀a, add zero a = a) (add_zero : ∀a, add a zero = a)

theorem zero_add [simp] [add_monoid A] (a : A) : 0 + a = a := !add_monoid.zero_add

theorem add_zero [simp] [add_monoid A] (a : A) : a + 0 = a := !add_monoid.add_zero

structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semigroup A

definition add_monoid.to_monoid {A : Type} [add_monoid A] : monoid A :=
⦃ monoid,
  mul         := add_monoid.add,
  mul_assoc   := add_monoid.add_assoc,
  one         := add_monoid.zero A,
  mul_one     := add_monoid.add_zero,
  one_mul     := add_monoid.zero_add
⦄

definition add_comm_monoid.to_comm_monoid {A : Type} [add_comm_monoid A] : comm_monoid A :=
⦃ comm_monoid,
  add_monoid.to_monoid,
  mul_comm    := add_comm_monoid.add_comm
⦄

section add_comm_monoid
  variables [add_comm_monoid A]

  theorem add_comm_three  (a b c : A) : a + b + c = c + b + a :=
  by inst_simp

  theorem add.comm4 : ∀ (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
  by inst_simp
end add_comm_monoid

/- group -/

structure group [class] (A : Type) extends monoid A, has_inv A :=
(mul_left_inv : ∀a, mul (inv a) a = one)

-- Note: with more work, we could derive the axiom one_mul

section group
  variable [group A]

  theorem mul.left_inv [simp] (a : A) : a⁻¹ * a = 1 := !group.mul_left_inv

  theorem inv_mul_cancel_left [simp] (a b : A) : a⁻¹ * (a * b) = b :=
  by inst_simp

  theorem inv_mul_cancel_right [simp] (a b : A) : a * b⁻¹ * b = a :=
  by inst_simp

  theorem inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b :=
  assert a⁻¹ * 1 = b, by inst_simp,
  by inst_simp

  theorem one_inv [simp] : 1⁻¹ = (1 : A) :=
  inv_eq_of_mul_eq_one (one_mul 1)

  theorem inv_inv [simp] (a : A) : (a⁻¹)⁻¹ = a :=
  inv_eq_of_mul_eq_one (mul.left_inv a)

  theorem inv.inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b :=
  assert a = a⁻¹⁻¹, by simp_nohyps,
  by inst_simp

  theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b :=
  iff.intro (assume H, inv.inj H) (by simp)

  theorem inv_eq_one_iff_eq_one (a : A) : a⁻¹ = 1 ↔ a = 1 :=
  assert a⁻¹ = 1⁻¹ ↔ a = 1, from inv_eq_inv_iff_eq a 1,
  by inst_simp

  theorem eq_one_of_inv_eq_one (a : A) : a⁻¹ = 1 → a = 1 :=
  iff.mp !inv_eq_one_iff_eq_one

  theorem eq_inv_of_eq_inv {a b : A} (H : a = b⁻¹) : b = a⁻¹ :=
  by inst_simp

  theorem eq_inv_iff_eq_inv (a b : A) : a = b⁻¹ ↔ b = a⁻¹ :=
  iff.intro !eq_inv_of_eq_inv !eq_inv_of_eq_inv

  theorem eq_inv_of_mul_eq_one {a b : A} (H : a * b = 1) : a = b⁻¹ :=
  assert a⁻¹ = b, from inv_eq_of_mul_eq_one H,
  by inst_simp

  theorem mul.right_inv [simp] (a : A) : a * a⁻¹ = 1 :=
  assert a = a⁻¹⁻¹, by simp,
  by inst_simp

  theorem mul_inv_cancel_left [simp] (a b : A) : a * (a⁻¹ * b) = b :=
  by inst_simp

  theorem mul_inv_cancel_right [simp] (a b : A) : a * b * b⁻¹ = a :=
  by inst_simp

  theorem mul_inv [simp] (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ :=
  inv_eq_of_mul_eq_one (by inst_simp)

  theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b :=
  assert a⁻¹ * 1 = a⁻¹, by inst_simp,
  by inst_simp

  theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * c = b) : a = b * c⁻¹ :=
  by inst_simp

  theorem eq_inv_mul_of_mul_eq {a b c : A} (H : b * a = c) : a = b⁻¹ * c :=
  by inst_simp

  theorem inv_mul_eq_of_eq_mul {a b c : A} (H : b = a * c) : a⁻¹ * b = c :=
  by inst_simp

  theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = c * b) : a * b⁻¹ = c :=
  by inst_simp

  theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * c⁻¹ = b) : a = b * c :=
  by inst_simp

  theorem eq_mul_of_inv_mul_eq {a b c : A} (H : b⁻¹ * a = c) : a = b * c :=
  by inst_simp

  theorem mul_eq_of_eq_inv_mul {a b c : A} (H : b = a⁻¹ * c) : a * b = c :=
  by inst_simp

  theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = c * b⁻¹) : a * b = c :=
  by inst_simp

  theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c :=
  iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul

  theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ :=
  iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv

  theorem mul_left_cancel {a b c : A} (H : a * b = a * c) : b = c :=
  assert a⁻¹ * (a * b) = b, by inst_simp,
  by inst_simp

  theorem mul_right_cancel {a b c : A} (H : a * b = c * b) : a = c :=
  assert a * b * b⁻¹ = a, by inst_simp,
  by inst_simp

  theorem mul_eq_one_of_mul_eq_one {a b : A} (H : b * a = 1) : a * b = 1 :=
  by rewrite [-inv_eq_of_mul_eq_one H, mul.left_inv]

  theorem mul_eq_one_iff_mul_eq_one (a b : A) : a * b = 1 ↔ b * a = 1 :=
  iff.intro !mul_eq_one_of_mul_eq_one !mul_eq_one_of_mul_eq_one

  definition conj_by (g a : A) := g * a * g⁻¹
  definition is_conjugate (a b : A) := ∃ x, conj_by x b = a

  local infixl ` ~ ` := is_conjugate
  local infixr ` ∘c `:55 := conj_by

  local attribute conj_by [reducible]

  lemma conj_compose [simp] (f g a : A) : f ∘c g ∘c a = f*g ∘c a :=
  by inst_simp

  lemma conj_id [simp] (a : A) : 1 ∘c a = a :=
  by inst_simp

  lemma conj_one [simp] (g : A) : g ∘c 1 = 1 :=
  by inst_simp

  lemma conj_inv_cancel [simp] (g : A) : ∀ a, g⁻¹ ∘c g ∘c a = a :=
  by inst_simp

  lemma conj_inv [simp] (g : A) : ∀ a, (g ∘c a)⁻¹ = g ∘c a⁻¹ :=
  by inst_simp

  lemma is_conj.refl (a : A) : a ~ a := exists.intro 1 (conj_id a)

  lemma is_conj.symm (a b : A) : a ~ b → b ~ a :=
  assume Pab, obtain x (Pconj : x ∘c b = a), from Pab,
  assert Pxinv : x⁻¹ ∘c x ∘c b = x⁻¹ ∘c a,   by simp,
  exists.intro x⁻¹ (by inst_simp)

  lemma is_conj.trans (a b c : A) : a ~ b → b ~ c → a ~ c :=
  assume Pab, assume Pbc,
  obtain x (Px : x ∘c b = a), from Pab,
  obtain y (Py : y ∘c c = b), from Pbc,
  exists.intro (x*y) (by inst_simp)

end group

definition group.to_left_cancel_semigroup [trans_instance] [reducible] [s : group A] :
    left_cancel_semigroup A :=
⦃ left_cancel_semigroup, s,
  mul_left_cancel := @mul_left_cancel A s ⦄

definition group.to_right_cancel_semigroup [trans_instance] [reducible] [s : group A] :
    right_cancel_semigroup A :=
⦃ right_cancel_semigroup, s,
  mul_right_cancel := @mul_right_cancel A s ⦄

structure comm_group [class] (A : Type) extends group A, comm_monoid A

/- additive group -/

structure add_group [class] (A : Type) extends add_monoid A, has_neg A :=
(add_left_inv : ∀a, add (neg a) a = zero)

definition add_group.to_group {A : Type} [add_group A] : group A :=
⦃ group, add_monoid.to_monoid,
  mul_left_inv := add_group.add_left_inv ⦄

section add_group
  variables [s : add_group A]
  include s

  theorem add.left_inv [simp] (a : A) : -a + a = 0 := !add_group.add_left_inv

  theorem neg_add_cancel_left [simp] (a b : A) : -a + (a + b) = b :=
  calc -a + (a + b) = (-a + a) + b : by rewrite add.assoc
               ...  = b            : by simp

  theorem neg_add_cancel_right [simp] (a b : A) : a + -b + b = a :=
  by inst_simp

  theorem neg_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b :=
  assert -a + 0 = b, by inst_simp,
  by inst_simp

  theorem neg_zero [simp] : -0 = (0 : A) := neg_eq_of_add_eq_zero (zero_add 0)

  theorem neg_neg [simp] (a : A) : -(-a) = a := neg_eq_of_add_eq_zero (add.left_inv a)

  theorem eq_neg_of_add_eq_zero {a b : A} (H : a + b = 0) : a = -b :=
  assert -a = b, from neg_eq_of_add_eq_zero H,
  by inst_simp

  theorem neg.inj {a b : A} (H : -a = -b) : a = b :=
  assert a = -(-a), by simp_nohyps,
  by inst_simp

  theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b :=
  iff.intro (assume H, neg.inj H) (by simp)

  theorem eq_of_neg_eq_neg {a b : A} : -a = -b → a = b :=
  iff.mp !neg_eq_neg_iff_eq

  theorem neg_eq_zero_iff_eq_zero (a : A) : -a = 0 ↔ a = 0 :=
  assert -a = -0 ↔ a = 0, from neg_eq_neg_iff_eq a 0,
  by inst_simp

  theorem eq_zero_of_neg_eq_zero {a : A} : -a = 0 → a = 0 :=
  iff.mp !neg_eq_zero_iff_eq_zero

  theorem eq_neg_of_eq_neg {a b : A} (H : a = -b) : b = -a :=
  by inst_simp

  theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a :=
  iff.intro !eq_neg_of_eq_neg !eq_neg_of_eq_neg

  theorem add.right_inv [simp] (a : A) : a + -a = 0 :=
  assert a = -(-a), by simp,
  by inst_simp

  theorem add_neg_cancel_left [simp] (a b : A) : a + (-a + b) = b :=
  by inst_simp

  theorem add_neg_cancel_right [simp] (a b : A) : a + b + -b = a :=
  by inst_simp

  theorem neg_add_rev [simp] (a b : A) : -(a + b) = -b + -a :=
  neg_eq_of_add_eq_zero (by inst_simp)

  -- TODO: delete these in favor of sub rules?
  theorem eq_add_neg_of_add_eq {a b c : A} (H : a + c = b) : a = b + -c :=
  by inst_simp

  theorem eq_neg_add_of_add_eq {a b c : A} (H : b + a = c) : a = -b + c :=
  by inst_simp

  theorem neg_add_eq_of_eq_add {a b c : A} (H : b = a + c) : -a + b = c :=
  by inst_simp

  theorem add_neg_eq_of_eq_add {a b c : A} (H : a = c + b) : a + -b = c :=
  by inst_simp

  theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -c = b) : a = b + c :=
  by inst_simp

  theorem eq_add_of_neg_add_eq {a b c : A} (H : -b + a = c) : a = b + c :=
  by inst_simp

  theorem add_eq_of_eq_neg_add {a b c : A} (H : b = -a + c) : a + b = c :=
  by inst_simp

  theorem add_eq_of_eq_add_neg {a b c : A} (H : a = c + -b) : a + b = c :=
  by inst_simp

  theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c :=
  iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add

  theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b :=
  iff.intro eq_add_neg_of_add_eq add_eq_of_eq_add_neg

  theorem add_left_cancel {a b c : A} (H : a + b = a + c) : b = c :=
  assert -a + (a + b) = b, by inst_simp,
  by inst_simp

  theorem add_right_cancel {a b c : A} (H : a + b = c + b) : a = c :=
  assert a + b + -b = a, by inst_simp,
  by inst_simp

  definition add_group.to_left_cancel_semigroup [trans_instance] [reducible] :
    add_left_cancel_semigroup A :=
  ⦃ add_left_cancel_semigroup, s,
    add_left_cancel := @add_left_cancel A s ⦄

  definition add_group.to_add_right_cancel_semigroup [trans_instance] [reducible] :
    add_right_cancel_semigroup A :=
  ⦃ add_right_cancel_semigroup, s,
    add_right_cancel := @add_right_cancel A s ⦄

  theorem add_neg_eq_neg_add_rev {a b : A} : a + -b = -(b + -a) :=
  by inst_simp

  theorem ne_add_of_ne_zero_right (a : A) {b : A} (H : b ≠ 0) : a ≠ b + a :=
    begin
      intro Heq,
      apply H,
      rewrite [-zero_add a at Heq{1}],
      let Heq' := eq_of_add_eq_add_right Heq,
      apply eq.symm Heq'
    end

  theorem ne_add_of_ne_zero_left (a : A) {b : A} (H : b ≠ 0) : a ≠ a + b :=
    begin
      intro Heq,
      apply H,
      rewrite [-add_zero a at Heq{1}],
      let Heq' := eq_of_add_eq_add_left Heq,
      apply eq.symm Heq'
    end

  /- sub -/

  -- TODO: derive corresponding facts for div in a field
  protected definition algebra.sub [reducible] (a b : A) : A := a + -b

  definition add_group_has_sub [reducible] [instance] : has_sub A :=
  has_sub.mk algebra.sub

  theorem sub_eq_add_neg [simp] (a b : A) : a - b = a + -b := rfl

  theorem sub_self (a : A) : a - a = 0 := !add.right_inv

  theorem sub_add_cancel (a b : A) : a - b + b = a := !neg_add_cancel_right

  theorem add_sub_cancel (a b : A) : a + b - b = a := !add_neg_cancel_right

  theorem add_sub_assoc (a b c : A) : a + b - c = a + (b - c) :=
    by rewrite [sub_eq_add_neg, add.assoc, -sub_eq_add_neg]

  theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b :=
  assert -a + 0 = -a, by inst_simp,
  by inst_simp

  theorem eq_iff_sub_eq_zero (a b : A) : a = b ↔ a - b = 0 :=
  iff.intro (assume H, eq.subst H !sub_self) (assume H, eq_of_sub_eq_zero H)

  theorem zero_sub (a : A) : 0 - a = -a := !zero_add

  theorem sub_zero (a : A) : a - 0 = a :=
  by inst_simp

  theorem sub_ne_zero_of_ne {a b : A} (H : a ≠ b) : a - b ≠ 0 :=
    begin
      intro Hab,
      apply H,
      apply eq_of_sub_eq_zero Hab
    end

  theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b :=
  by inst_simp

  theorem neg_sub (a b : A) : -(a - b) = b - a :=
  neg_eq_of_add_eq_zero (by inst_simp)

  theorem add_sub (a b c : A) : a + (b - c) = a + b - c :=
  by inst_simp

  theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b :=
  by inst_simp

  theorem sub_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b :=
  iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H)

  theorem eq_sub_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b :=
  iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neg_of_add_eq H)

  theorem eq_iff_eq_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d :=
  calc
    a = b ↔ a - b = 0   : eq_iff_sub_eq_zero
      ... = (c - d = 0) : H
      ... ↔ c = d       : iff.symm (eq_iff_sub_eq_zero c d)

  theorem eq_sub_of_add_eq {a b c : A} (H : a + c = b) : a = b - c :=
  by inst_simp

  theorem sub_eq_of_eq_add {a b c : A} (H : a = c + b) : a - b = c :=
  by inst_simp

  theorem eq_add_of_sub_eq {a b c : A} (H : a - c = b) : a = b + c :=
  by inst_simp

  theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c :=
  by inst_simp

end add_group

structure add_comm_group [class] (A : Type) extends add_group A, add_comm_monoid A

section add_comm_group
  variable [s : add_comm_group A]
  include s

  theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c :=
  by inst_simp

  theorem neg_add_eq_sub (a b : A) : -a + b = b - a :=
  by inst_simp

  theorem neg_add (a b : A) : -(a + b) = -a + -b :=
  by inst_simp

  theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b :=
  by inst_simp

  theorem sub_sub (a b c : A) : a - b - c = a - (b + c) :=
  by inst_simp

  theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b :=
  by inst_simp

  theorem eq_sub_of_add_eq' {a b c : A} (H : c + a = b) : a = b - c :=
  by inst_simp

  theorem sub_eq_of_eq_add' {a b c : A} (H : a = b + c) : a - b = c :=
  by inst_simp

  theorem eq_add_of_sub_eq' {a b c : A} (H : a - b = c) : a = b + c :=
  by inst_simp

  theorem add_eq_of_eq_sub' {a b c : A} (H : b = c - a) : a + b = c :=
  by inst_simp

  theorem sub_sub_self (a b : A) : a - (a - b) = b :=
  by inst_simp

  theorem add_sub_comm (a b c d : A) : a + b - (c + d) = (a - c) + (b - d) :=
  by inst_simp

  theorem sub_eq_sub_add_sub (a b c : A) : a - b = c - b + (a - c) :=
  by inst_simp

  theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b :=
  by inst_simp

end add_comm_group

definition group_of_add_group (A : Type) [G : add_group A] : group A :=
⦃group,
  mul             := has_add.add,
  mul_assoc       := add.assoc,
  one             := !has_zero.zero,
  one_mul         := zero_add,
  mul_one         := add_zero,
  inv             := has_neg.neg,
  mul_left_inv    := add.left_inv⦄

namespace norm_num
reveal add.assoc

definition add1 [has_add A] [has_one A] (a : A) : A := add a one

local attribute add1 bit0 bit1 [reducible]

theorem add_comm_four [add_comm_semigroup A] (a b : A) : a + a + (b + b) = (a + b) + (a + b) :=
by inst_simp

theorem add_comm_middle [add_comm_semigroup A] (a b c : A) : a + b + c = a + c + b :=
by inst_simp

theorem bit0_add_bit0 [add_comm_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) :=
by inst_simp

theorem bit0_add_bit0_helper [add_comm_semigroup A] (a b t : A) (H : a + b = t) :
        bit0 a + bit0 b = bit0 t :=
by rewrite -H; simp

theorem bit1_add_bit0 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit1 a + bit0 b = bit1 (a + b) :=
by inst_simp

theorem bit1_add_bit0_helper [add_comm_semigroup A] [has_one A] (a b t : A)
        (H : a + b = t) : bit1 a + bit0 b = bit1 t :=
by rewrite -H; simp

theorem bit0_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit0 a + bit1 b = bit1 (a + b) :=
by inst_simp

theorem bit0_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t : A)
        (H : a + b = t) : bit0 a + bit1 b = bit1 t :=
by rewrite -H; simp

theorem bit1_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) :
        bit1 a + bit1 b = bit0 (add1 (a + b)) :=
by inst_simp

theorem bit1_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t s: A)
        (H : (a + b) = t) (H2 : add1 t = s) : bit1 a + bit1 b = bit0 s :=
by inst_simp

theorem bin_add_zero [add_monoid A] (a : A) : a + zero = a :=
by inst_simp

theorem bin_zero_add [add_monoid A] (a : A) : zero + a = a :=
by inst_simp

theorem one_add_bit0 [add_comm_semigroup A] [has_one A] (a : A) : one + bit0 a = bit1 a :=
by inst_simp

theorem bit0_add_one [has_add A] [has_one A] (a : A) : bit0 a + one = bit1 a :=
rfl

theorem bit1_add_one [has_add A] [has_one A] (a : A) : bit1 a + one = add1 (bit1 a) :=
rfl

theorem bit1_add_one_helper [has_add A] [has_one A] (a t : A) (H : add1 (bit1 a) = t) :
        bit1 a + one = t :=
by inst_simp

theorem one_add_bit1 [add_comm_semigroup A] [has_one A] (a : A) : one + bit1 a = add1 (bit1 a) :=
by inst_simp

theorem one_add_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A)
        (H : add1 (bit1 a) = t) : one + bit1 a = t :=
by inst_simp

theorem add1_bit0 [has_add A] [has_one A] (a : A) : add1 (bit0 a) = bit1 a :=
rfl

theorem add1_bit1 [add_comm_semigroup A] [has_one A] (a : A) :
        add1 (bit1 a) = bit0 (add1 a) :=
by inst_simp

theorem add1_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A) (H : add1 a = t) :
        add1 (bit1 a) = bit0 t :=
by inst_simp

theorem add1_one [has_add A] [has_one A] : add1 (one : A) = bit0 one :=
rfl

theorem add1_zero [add_monoid A] [has_one A] : add1 (zero : A) = one :=
by inst_simp

theorem one_add_one [has_add A] [has_one A] : (one : A) + one = bit0 one :=
rfl

theorem subst_into_sum [has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr)
        (prt : tl + tr = t) : l + r = t :=
by inst_simp

theorem neg_zero_helper [add_group A] (a : A) (H : a = 0) : - a = 0 :=
by inst_simp

end norm_num

attribute [simp]
  zero_add add_zero one_mul mul_one
  at simplifier.unit

attribute [simp]
  neg_neg sub_eq_add_neg
  at simplifier.neg

attribute [simp]
  add.assoc add.comm add.left_comm
  mul.left_comm mul.comm mul.assoc
  at simplifier.ac

import data.real
open real

namespace example2

/- Assume we have an exp (exponential) function, and state basic properties using axioms. -/
constant exp : ℝ → ℝ
/- The annotation (: t :) is used to indicate that `t` is a pattern for the E-matching procedure. -/
axiom exp_add : ∀ x y : ℝ, (: exp (x + y) :) = exp x * exp y
/- The [forward] attribute instructs lean to use the following axioms for E-matching. -/
attribute [forward] exp_add

/- Define t² as notation for t*t -/
definition sq (x : ℝ) := x * x
notation a `²` := sq a
/- (sq x) and (x * x) are equal by definition, and we can prove it using reflexivity. -/
lemma sq_def [forward] : ∀ x : ℝ, sq x = x * x :=
  take x, rfl
lemma sq_add [forward] : ∀ x y : ℝ, sq (x + y) = (: sq x + 2 * x * y + sq y :) :=
  take x y, by unfold sq; rewrite add_mul_self_eq

/- Define predicate pos and state basic properties using axioms. -/
definition pos (x : ℝ) := x > 0
axiom pos_1    : pos (1:ℝ)
axiom pos_bit1 : ∀ x : ℝ,   pos x → pos (bit1 x)
axiom pos_bit0 : ∀ x : ℝ,   pos x → pos (bit0 x)
axiom pos_sq   : ∀ x : ℝ,   pos x → pos (sq x)
axiom pos_add  : ∀ x y : ℝ, pos x → pos y → (: pos (x + y) :)
axiom pos_mul  : ∀ x y : ℝ, pos x → pos y → (: pos (x * y) :)
axiom pos_exp  : ∀ x : ℝ,   pos (exp x)

/- The [intro!] attribute instructs lean to use the following axioms for backward chaining. -/
attribute [intro!]  pos_bit1 pos_bit0 pos_1 pos_add pos_mul pos_sq pos_exp
attribute [forward] pos_add pos_mul

/- Define predicate nzero and state basic properties using axioms. -/
definition nzero (x : ℝ) := x ≠ 0
axiom nzero_of_pos : ∀ x : ℝ, pos x → nzero x
axiom nzero_of_neg : ∀ x : ℝ, pos x → nzero (- x)

attribute [intro!] nzero_of_pos nzero_of_neg

/- Assume we have safe_log and safe_inv functions. -/
constant safe_log : Π (x : ℝ), pos x → ℝ
constant safe_inv : Π (x : ℝ), nzero x → ℝ

/-
Define notation (log x), (x ⁻¹) and (x / y) for safe_log and safe_inv.
We discharge the preconditions pos and nzero using tactics.
The grind tactic is based on backward chaining, and uses all axioms/lemmas
marked with the `[intro!]` attribute.
-/
notation `log`:max x:max := (@safe_log x (by grind))
/-
  We use priority greater than the default to avoid a conflict with existing
  notation defined in Lean.
-/
notation [priority std.priority.default+1] x ⁻¹ := (@safe_inv x (by grind))
notation [priority std.priority.default+1] x `/` y := (@safe_inv y (by grind) * x)

/- Assume basic properties about safe_inf and safe_log as axioms -/

axiom inv_pos         : ∀ x : ℝ,   pos x → pos (x⁻¹)
axiom inv_mul         : ∀ x y : ℝ, pos x → pos y →  (x * y)⁻¹ = (x⁻¹) * (y⁻¹)
axiom inv_cancel_left : ∀ x y : ℝ, pos x →  x⁻¹ * (x * y) = y
axiom inv_neg         : ∀ x : ℝ,   pos x →  (- x)⁻¹ = - (x⁻¹)

attribute [intro!] inv_pos
attribute [forward] inv_pos inv_mul inv_cancel_left inv_neg

axiom log_mul : ∀ x y : ℝ, pos x → pos y → log (x * y) = log x + log y
axiom log_sq  : ∀ x : ℝ,   pos x → log (sq x) = 2 * log x
axiom log_inv : ∀ x : ℝ,   pos x → log (x⁻¹)  = - log x

attribute [forward] log_mul log_sq log_inv

/- To prove the main lemma, we also need the following basic properties from the standard library. -/
lemma rdistrib [forward]    : ∀ x y z : ℝ, (x + y) * z = x * z + y * z   :=
  right_distrib
lemma addcomm [forward]     : ∀ x y : ℝ, x + y = y + x                   :=
  add.comm
lemma sub_def [forward]     : ∀ x y : ℝ, x - y = x + -y                  :=
  take x y, rfl
lemma mul_two_sum [forward] : ∀ x : ℝ, (: 2 * x :) = x + x               :=
  take x, show (1 + 1) * x = x + x,
  by rewrite [rdistrib, one_mul]
lemma neg_mul [forward]     : ∀ x y : ℝ, (: (- x) * y :) = - (x * y)     :=
  take x y, by rewrite neg_mul_eq_neg_mul

set_option blast.strategy "ematch"

example : ∀ x y z w : ℝ, pos x → pos y → pos z → pos w → x * y = exp z + w →
          log (2 * w * exp z + w² + exp (2*z)) / -2 = log (y⁻¹) - log x :=
begin
  have pos 2, by grind, /- Discharge auxiliary fact using backward chaining. -/
  blast                 /- Use congruence closure and ematching to prove main goal. -/
end

end example2


import topology.maps topology.subset_properties

example : ℕ := 691

open_locale classical

-- x ∈ closure S if and only if x ∈ C for all closed sets containing S.
lemma mem_closure_iff' {X : Type*} [topological_space X] {S : set X} {x : X} :
  x ∈ closure S ↔ ∀ C : set X, is_closed C → S ⊆ C → x ∈ C :=
begin
  rw mem_closure_iff,
  split,
  { intros h C hC hSC,
    replace h := h C.compl hC,
    by_contra hx,
    apply set.ne_empty_iff_nonempty.2 (h hx), clear h hx,
    rw set.eq_empty_iff_forall_not_mem,
    rintros x ⟨hxC, hxS⟩,
    apply hxC,
    apply hSC,
    assumption},
  { intros h U hU hxU,
    replace h := h (-U : set X) (is_closed_compl_iff.2 hU),
    rw ←set.ne_empty_iff_nonempty,
    intro hUS,
    apply h _ hxU,
    intros x hx hU,
    apply set.not_mem_empty x,
    rw ←hUS,
    split; assumption},
end

open set

/-- If X is compact then pr₂ : X × Y → Y is a closed map -/
theorem closed_pr2_of_compact
  {X : Type*} [topological_space X] [compact_space X]
  {Y : Type*} [topological_space Y] :
  is_closed_map (prod.snd : X × Y → Y) :=
-- Let C be a closed set in X × Y
λ C hC, begin
  -- It suffices to prove that every y in the complement of pr₂(C)
  -- is contained in an open neighbourhood which misses pr₂(C)
  rw [←is_open_compl_iff, is_open_iff_forall_mem_open],
  -- so take y in the complement
  intros y hy,
  -- and apply the generalised tube lemma to X × {y}
  -- which tells us that there exists a basic open U × V containing X × {y}
  -- which is disjoint from C (this is where we use compactness of X)
  rcases generalized_tube_lemma compact_univ
    (compact_singleton : compact {y}) (is_open_compl_iff.2 hC) _ with
    ⟨U, V, hU, hV, hXU, hyV, hUV⟩,
  { -- The set V is the neighbourhood of y we seek.
    use V,
    split,
    { rintros v hvV ⟨uv, huv, rfl⟩,
      exact hUV ⟨hXU (set.mem_univ _), hvV⟩ huv,
    },
    exact ⟨hV, hyV (set.mem_singleton _)⟩,
  },
  { -- and the proof is complete once we note that y ∉ pr₂(C) implies
    -- X × {y} is disjoint from C
    rintros xy ⟨hx, hyC⟩ hxyC,
    apply hy,
    existsi xy,
    exact ⟨hxyC, mem_singleton_iff.1 hyC⟩,
  }
end

def filter_topology {X : Type*} (F : filter X) : topological_space (option X) :=
{ is_open := λ U, if none ∈ U then some ⁻¹' U ∈ F else true,
  is_open_univ := begin
    rw [if_pos, preimage_univ],
      exact filter.univ_mem_sets,
    exact mem_univ (none : option X),
  end,
  is_open_inter := λ U V hU hV,
    begin
    split_ifs, swap, trivial,
    cases h with h0U h0V,
    rw if_pos at hU, swap, exact h0U,
    rw if_pos at hV, swap, exact h0V,
    show some ⁻¹' (U ∩ V) ∈ F,
    rw preimage_inter,
    exact F.inter_sets hU hV,
  end,
  is_open_sUnion := λ I hI, begin
    split_ifs, swap, trivial,
    rcases h with ⟨U, hU, h0U⟩,
    replace hI := hI U hU,
    rw preimage_sUnion,
    rw if_pos at hI,
      exact filter.mem_sets_of_superset hI (subset_bUnion_of_mem hU),
    exact h0U,
  end
}

/-- If F is not ⊥ then the closure of X in option X is all of option X -/
lemma closure_range_sum_eq_univ {X : Type*} {F : filter X} (hF : F ≠ ⊥) :
  @closure (option X) (filter_topology F) (range some) = univ :=
begin
  letI := filter_topology F,
  apply eq_univ_of_forall,
  rintro (_| x),
  -- Clearly X is a subset of the closure of X
  -- so it suffices to prove that the extra point is in the closure
    swap, exact subset_closure ⟨x, rfl⟩,
  -- Assume for a contradiction that it is not.
  by_contra hnone,
  -- Then the complement of the closure is open and contains the extra point
  set U := -(closure (range some) : set (option X)) with hUc,
  have HUO : is_open U := is_open_compl_iff.2 is_closed_closure,
  change if none ∈ U then some ⁻¹' U ∈ F else true at HUO,
  -- so the intersection of this complement with X must be in F
  rw if_pos at HUO, swap, rwa hUc,
  apply hF,
  rw ←filter.empty_in_sets_eq_bot,
  -- If this intersection is empty this contradicts the fact that F ≠ ⊥
  convert HUO, symmetry, rw eq_empty_iff_forall_not_mem,
  -- but the intersection is empty because X is a subset of its closure
  intros x hx,
  rw hUc at hx,
  refine hx (subset_closure _),
  use x,
end

universe u

theorem compact_space_of_closed_pr2 {X : Type u} [topological_space X]
  (hclosed : ∀ (Y : Type u) [topological_space Y], is_closed_map (prod.snd : X × Y → Y)) :
  compact_space X :=
  -- we will show that every proper filter has an adherent point
⟨λ F hF h0, begin
  -- Let Y be the topological space defined above (X + extra point with nhds F)
  -- (we'll just call it `option X` here)
  letI := filter_topology F,
  -- Let D be the closure of {(x,x)} in X × Y.
  set D := closure (set.range (λ x : X, (⟨x, some x⟩ : X × option X))) with hD,
  -- Its image in Y is closed.
  replace hclosed := hclosed (option X) D (is_closed_closure),
  -- Now clearly the projection contains X
  have hX : range some ⊆ prod.snd '' D,
  { rintros _ ⟨x, rfl⟩,
    use ⟨x, some x⟩,
    split, swap, refl,
    refine subset_closure _,
    exact ⟨x, rfl⟩,
  },
  -- and it's closed, so by `closure_range_sum_eq_univ` the projection is everything
  -- and in particular contains the extra point
  have hnone : none ∈ prod.snd '' D,
    apply (closure_subset_iff_subset_of_is_closed hclosed).2 hX,
    rw closure_range_sum_eq_univ hF,
    exact mem_univ _,
  -- Hence (x, extra point) is in the closure of the diagonal
  rcases hnone with ⟨xy, hxy, hy⟩,
  -- and we claim this x works
  use xy.fst,
  split, exact mem_univ _,
  -- We have to show that every element of F meets every neighbourhood of X
  intro hbot,
  rw [←filter.empty_in_sets_eq_bot, filter.mem_inf_sets] at hbot,
  -- so let A be an element of the filter, and let U be a neighbourhood of x (=xy.fst)
  rcases hbot with ⟨A, hA, U, hU, hAU⟩,
  rw subset_empty_iff at hAU,
  revert hAU,
  -- and let's show A ∩ U is non-empty.
  change A ∩ U ≠ ∅,
  rw set.ne_empty_iff_nonempty,
  rw mem_nhds_sets_iff at hU,
  -- U is a neighbourhood of x so it contains an open neighbourhood U' of x
  rcases hU with ⟨U', hU'U, hU', hxyU'⟩,
  -- Let V be the basic open set U' x (point union A)
  set V : set (X × option X) := set.prod U' (insert none (some '' A)),
  have hV : is_open V,
  { apply is_open_prod hU',
    change if none ∈ (insert none (some '' A)) then some ⁻¹' (insert none (some '' A)) ∈ F else true,
    rw if_pos (mem_insert none _),
    convert hA using 1,
    ext a,
    simp,
  },
  -- Clearly (x,extra point) is in V
  have hxyV : xy ∈ V,
  { split, exact hxyU',
    rw hy,
    apply mem_insert
  },
  -- so V meets D and hence (because V is open) meets the diagonal
  rw [hD, mem_closure_iff] at hxy,
  replace hxy := hxy V hV hxyV,
  -- so say it meets the diagonal at (p,p)
  rcases hxy with ⟨_, hp, p, rfl⟩,
  -- then p is easily checked to be in the intersection and we're done
  use p,
  cases hp with hpU hpA,
  split,
    change some p ∈ _ at hpA,
    rw mem_insert_iff at hpA,
    cases hpA, cases hpA,
    rcases hpA with ⟨p', hp', hpp'⟩,
    convert hp',
    exact option.some_inj.1 hpp'.symm,
  exact hU'U hpU,
end⟩


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/
import linear_algebra.multilinear.basis
import linear_algebra.matrix.reindex
import ring_theory.algebra_tower
import tactic.field_simp
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.matrix.basis

/-!
# Determinant of families of vectors

This file defines the determinant of an endomorphism, and of a family of vectors
with respect to some basis. For the determinant of a matrix, see the file
`linear_algebra.matrix.determinant`.

## Main definitions

In the list below, and in all this file, `R` is a commutative ring (semiring
is sometimes enough), `M` and its variations are `R`-modules, `ι`, `κ`, `n` and `m` are finite
types used for indexing.

 * `basis.det`: the determinant of a family of vectors with respect to a basis,
   as a multilinear map
 * `linear_map.det`: the determinant of an endomorphism `f : End R M` as a
   multiplicative homomorphism (if `M` does not have a finite `R`-basis, the
   result is `1` instead)
 * `linear_equiv.det`: the determinant of an isomorphism `f : M ≃ₗ[R] M` as a
   multiplicative homomorphism (if `M` does not have a finite `R`-basis, the
   result is `1` instead)

## Tags

basis, det, determinant
-/

noncomputable theory

open_locale big_operators
open_locale matrix

open linear_map
open submodule

universes u v w

open linear_map matrix set function

variables {R : Type*} [comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]
variables {M' : Type*} [add_comm_group M'] [module R M']
variables {ι : Type*} [decidable_eq ι] [fintype ι]
variables (e : basis ι R M)

section conjugate

variables {A : Type*} [comm_ring A]
variables {m n : Type*} [fintype m] [fintype n]

/-- If `R^m` and `R^n` are linearly equivalent, then `m` and `n` are also equivalent. -/
def equiv_of_pi_lequiv_pi {R : Type*} [comm_ring R] [nontrivial R]
  (e : (m → R) ≃ₗ[R] (n → R)) : m ≃ n :=
basis.index_equiv (basis.of_equiv_fun e.symm) (pi.basis_fun _ _)

namespace matrix

/-- If `M` and `M'` are each other's inverse matrices, they are square matrices up to
equivalence of types. -/
def index_equiv_of_inv [nontrivial A] [decidable_eq m] [decidable_eq n]
  {M : matrix m n A} {M' : matrix n m A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  m ≃ n :=
equiv_of_pi_lequiv_pi (to_lin'_of_inv hMM' hM'M)

lemma det_comm [decidable_eq n] (M N : matrix n n A) : det (M ⬝ N) = det (N ⬝ M) :=
by rw [det_mul, det_mul, mul_comm]

/-- If there exists a two-sided inverse `M'` for `M` (indexed differently),
then `det (N ⬝ M) = det (M ⬝ N)`. -/
lemma det_comm' [decidable_eq m] [decidable_eq n]
  {M : matrix n m A} {N : matrix m n A} {M' : matrix m n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  det (M ⬝ N) = det (N ⬝ M) :=
begin
  nontriviality A,
  -- Although `m` and `n` are different a priori, we will show they have the same cardinality.
  -- This turns the problem into one for square matrices, which is easy.
  let e := index_equiv_of_inv hMM' hM'M,
  rw [← det_minor_equiv_self e, ← minor_mul_equiv _ _ _ (equiv.refl n) _, det_comm,
    minor_mul_equiv, equiv.coe_refl, minor_id_id]
end

/-- If `M'` is a two-sided inverse for `M` (indexed differently), `det (M ⬝ N ⬝ M') = det N`.

See `matrix.det_conj` and `matrix.det_conj'` for the case when `M' = M⁻¹` or vice versa. -/
lemma det_conj_of_mul_eq_one [decidable_eq m] [decidable_eq n]
  {M : matrix m n A} {M' : matrix n m A} {N : matrix n n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  det (M ⬝ N ⬝ M') = det N :=
by rw [← det_comm' hM'M hMM', ← matrix.mul_assoc, hM'M, matrix.one_mul]

end matrix

end conjugate

namespace linear_map

/-! ### Determinant of a linear map -/

variables {A : Type*} [comm_ring A] [module A M]
variables {κ : Type*} [fintype κ]

/-- The determinant of `linear_map.to_matrix` does not depend on the choice of basis. -/
lemma det_to_matrix_eq_det_to_matrix [decidable_eq κ]
  (b : basis ι A M) (c : basis κ A M) (f : M →ₗ[A] M) :
  det (linear_map.to_matrix b b f) = det (linear_map.to_matrix c c f) :=
by rw [← linear_map_to_matrix_mul_basis_to_matrix c b c,
       ← basis_to_matrix_mul_linear_map_to_matrix b c b,
       matrix.det_conj_of_mul_eq_one]; rw [basis.to_matrix_mul_to_matrix, basis.to_matrix_self]

/-- The determinant of an endomorphism given a basis.

See `linear_map.det` for a version that populates the basis non-computably.

Although the `trunc (basis ι A M)` parameter makes it slightly more convenient to switch bases,
there is no good way to generalize over universe parameters, so we can't fully state in `det_aux`'s
type that it does not depend on the choice of basis. Instead you can use the `det_aux_def'` lemma,
or avoid mentioning a basis at all using `linear_map.det`.
-/
def det_aux : trunc (basis ι A M) → (M →ₗ[A] M) →* A :=
trunc.lift
  (λ b : basis ι A M,
    (det_monoid_hom).comp (to_matrix_alg_equiv b : (M →ₗ[A] M) →* matrix ι ι A))
  (λ b c, monoid_hom.ext $ det_to_matrix_eq_det_to_matrix b c)

/-- Unfold lemma for `det_aux`.

See also `det_aux_def'` which allows you to vary the basis.
-/
lemma det_aux_def (b : basis ι A M) (f : M →ₗ[A] M) :
  linear_map.det_aux (trunc.mk b) f = matrix.det (linear_map.to_matrix b b f) :=
rfl

-- Discourage the elaborator from unfolding `det_aux` and producing a huge term.
attribute [irreducible] linear_map.det_aux

lemma det_aux_def' {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (tb : trunc $ basis ι A M) (b' : basis ι' A M) (f : M →ₗ[A] M) :
  linear_map.det_aux tb f = matrix.det (linear_map.to_matrix b' b' f) :=
by { apply trunc.induction_on tb, intro b, rw [det_aux_def, det_to_matrix_eq_det_to_matrix b b'] }

@[simp]
lemma det_aux_id (b : trunc $ basis ι A M) : linear_map.det_aux b (linear_map.id) = 1 :=
(linear_map.det_aux b).map_one

@[simp]
lemma det_aux_comp (b : trunc $ basis ι A M) (f g : M →ₗ[A] M) :
  linear_map.det_aux b (f.comp g) = linear_map.det_aux b f * linear_map.det_aux b g :=
(linear_map.det_aux b).map_mul f g

section
open_locale classical

-- Discourage the elaborator from unfolding `det` and producing a huge term by marking it
-- as irreducible.
/-- The determinant of an endomorphism independent of basis.

If there is no finite basis on `M`, the result is `1` instead.
-/
@[irreducible] protected def det : (M →ₗ[A] M) →* A :=
if H : ∃ (s : finset M), nonempty (basis s A M)
then linear_map.det_aux (trunc.mk H.some_spec.some)
else 1

lemma coe_det [decidable_eq M] : ⇑(linear_map.det : (M →ₗ[A] M) →* A) =
  if H : ∃ (s : finset M), nonempty (basis s A M)
  then linear_map.det_aux (trunc.mk H.some_spec.some)
  else 1 :=
by { ext, unfold linear_map.det,
     split_ifs,
     { congr }, -- use the correct `decidable_eq` instance
     refl }

end

-- Auxiliary lemma, the `simp` normal form goes in the other direction
-- (using `linear_map.det_to_matrix`)
lemma det_eq_det_to_matrix_of_finset [decidable_eq M]
  {s : finset M} (b : basis s A M) (f : M →ₗ[A] M) :
  f.det = matrix.det (linear_map.to_matrix b b f) :=
have ∃ (s : finset M), nonempty (basis s A M),
from ⟨s, ⟨b⟩⟩,
by rw [linear_map.coe_det, dif_pos, det_aux_def' _ b]; assumption

@[simp] lemma det_to_matrix
  (b : basis ι A M) (f : M →ₗ[A] M) :
  matrix.det (to_matrix b b f) = f.det :=
by { haveI := classical.dec_eq M,
     rw [det_eq_det_to_matrix_of_finset b.reindex_finset_range, det_to_matrix_eq_det_to_matrix b] }

@[simp] lemma det_to_matrix' {ι : Type*} [fintype ι] [decidable_eq ι]
  (f : (ι → A) →ₗ[A] (ι → A)) :
  det f.to_matrix' = f.det :=
by simp [← to_matrix_eq_to_matrix']

/-- To show `P f.det` it suffices to consider `P (to_matrix _ _ f).det` and `P 1`. -/
@[elab_as_eliminator]
lemma det_cases [decidable_eq M] {P : A → Prop} (f : M →ₗ[A] M)
  (hb : ∀ (s : finset M) (b : basis s A M), P (to_matrix b b f).det) (h1 : P 1) :
  P f.det :=
begin
  unfold linear_map.det,
  split_ifs with h,
  { convert hb _ h.some_spec.some,
    apply det_aux_def' },
  { exact h1 }
end

@[simp]
lemma det_comp (f g : M →ₗ[A] M) : (f.comp g).det = f.det * g.det :=
linear_map.det.map_mul f g

@[simp]
lemma det_id : (linear_map.id : M →ₗ[A] M).det = 1 :=
linear_map.det.map_one

/-- Multiplying a map by a scalar `c` multiplies its determinant by `c ^ dim M`. -/
@[simp] lemma det_smul {𝕜 : Type*} [field 𝕜] {M : Type*} [add_comm_group M] [module 𝕜 M]
  (c : 𝕜) (f : M →ₗ[𝕜] M) :
  linear_map.det (c • f) = c ^ (finite_dimensional.finrank 𝕜 M) * linear_map.det f :=
begin
  by_cases H : ∃ (s : finset M), nonempty (basis s 𝕜 M),
  { haveI : finite_dimensional 𝕜 M,
    { rcases H with ⟨s, ⟨hs⟩⟩, exact finite_dimensional.of_finset_basis hs },
    simp only [← det_to_matrix (finite_dimensional.fin_basis 𝕜 M), linear_equiv.map_smul,
              fintype.card_fin, det_smul] },
  { classical,
    have : finite_dimensional.finrank 𝕜 M = 0 := finrank_eq_zero_of_not_exists_basis H,
    simp [coe_det, H, this] }
end

lemma det_zero' {ι : Type*} [fintype ι] [nonempty ι] (b : basis ι A M) :
  linear_map.det (0 : M →ₗ[A] M) = 0 :=
by { haveI := classical.dec_eq ι,
     rw [← det_to_matrix b, linear_equiv.map_zero, det_zero],
     assumption }

/-- In a finite-dimensional vector space, the zero map has determinant `1` in dimension `0`,
and `0` otherwise. We give a formula that also works in infinite dimension, where we define
the determinant to be `1`. -/
@[simp] lemma det_zero {𝕜 : Type*} [field 𝕜] {M : Type*} [add_comm_group M] [module 𝕜 M] :
  linear_map.det (0 : M →ₗ[𝕜] M) = (0 : 𝕜) ^ (finite_dimensional.finrank 𝕜 M) :=
by simp only [← zero_smul 𝕜 (1 : M →ₗ[𝕜] M), det_smul, mul_one, monoid_hom.map_one]

/-- Conjugating a linear map by a linear equiv does not change its determinant. -/
@[simp] lemma det_conj {N : Type*} [add_comm_group N] [module A N]
  (f : M →ₗ[A] M) (e : M ≃ₗ[A] N) :
  linear_map.det ((e : M →ₗ[A] N) ∘ₗ (f ∘ₗ (e.symm : N →ₗ[A] M))) = linear_map.det f :=
begin
  classical,
  by_cases H : ∃ (s : finset M), nonempty (basis s A M),
  { rcases H with ⟨s, ⟨b⟩⟩,
    rw [← det_to_matrix b f, ← det_to_matrix (b.map e), to_matrix_comp (b.map e) b (b.map e),
        to_matrix_comp (b.map e) b b, ← matrix.mul_assoc, matrix.det_conj_of_mul_eq_one],
    { rw [← to_matrix_comp, linear_equiv.comp_coe, e.symm_trans_self,
          linear_equiv.refl_to_linear_map, to_matrix_id] },
    { rw [← to_matrix_comp, linear_equiv.comp_coe, e.self_trans_symm,
          linear_equiv.refl_to_linear_map, to_matrix_id] } },
  { have H' : ¬ (∃ (t : finset N), nonempty (basis t A N)),
    { contrapose! H,
      rcases H with ⟨s, ⟨b⟩⟩,
      exact ⟨_, ⟨(b.map e.symm).reindex_finset_range⟩⟩ },
    simp only [coe_det, H, H', pi.one_apply, dif_neg, not_false_iff] }
end

/-- If a linear map is invertible, so is its determinant. -/
lemma is_unit_det {A : Type*} [comm_ring A] [module A M]
  (f : M →ₗ[A] M) (hf : is_unit f) : is_unit f.det :=
begin
  obtain ⟨g, hg⟩ : ∃ g, f.comp g = 1 := hf.exists_right_inv,
  have : linear_map.det f * linear_map.det g = 1,
    by simp only [← linear_map.det_comp, hg, monoid_hom.map_one],
  exact is_unit_of_mul_eq_one _ _ this,
end

/-- If a linear map has determinant different from `1`, then the space is finite-dimensional. -/

/-- If the determinant of a map vanishes, then the map is not onto. -/
lemma range_lt_top_of_det_eq_zero {𝕜 : Type*} [field 𝕜] [module 𝕜 M]
  {f : M →ₗ[𝕜] M} (hf : f.det = 0) : f.range < ⊤ :=
begin
  haveI : finite_dimensional 𝕜 M, by simp [f.finite_dimensional_of_det_ne_one, hf],
  contrapose hf,
  simp only [lt_top_iff_ne_top, not_not, ← is_unit_iff_range_eq_top] at hf,
  exact is_unit_iff_ne_zero.1 (f.is_unit_det hf)
end

/-- If the determinant of a map vanishes, then the map is not injective. -/
lemma bot_lt_ker_of_det_eq_zero {𝕜 : Type*} [field 𝕜] [module 𝕜 M]
  {f : M →ₗ[𝕜] M} (hf : f.det = 0) : ⊥ < f.ker :=
begin
  haveI : finite_dimensional 𝕜 M, by simp [f.finite_dimensional_of_det_ne_one, hf],
  contrapose hf,
  simp only [bot_lt_iff_ne_bot, not_not, ← is_unit_iff_ker_eq_bot] at hf,
  exact is_unit_iff_ne_zero.1 (f.is_unit_det hf)
end

end linear_map

namespace linear_equiv

/-- On a `linear_equiv`, the domain of `linear_map.det` can be promoted to `Rˣ`. -/
protected def det : (M ≃ₗ[R] M) →* Rˣ :=
(units.map (linear_map.det : (M →ₗ[R] M) →* R)).comp
  (linear_map.general_linear_group.general_linear_equiv R M).symm.to_monoid_hom

@[simp] lemma coe_det (f : M ≃ₗ[R] M) : ↑f.det = linear_map.det (f : M →ₗ[R] M) := rfl
@[simp] lemma coe_inv_det (f : M ≃ₗ[R] M) : ↑(f.det⁻¹) = linear_map.det (f.symm : M →ₗ[R] M) := rfl

@[simp] lemma det_refl : (linear_equiv.refl R M).det = 1 := units.ext $ linear_map.det_id

@[simp] lemma det_trans (f g : M ≃ₗ[R] M) : (f.trans g).det = g.det * f.det := map_mul _ g f

@[simp] lemma det_symm (f : M ≃ₗ[R] M) : f.symm.det = f.det⁻¹ := map_inv _ f

/-- Conjugating a linear equiv by a linear equiv does not change its determinant. -/
@[simp] lemma det_conj (f : M ≃ₗ[R] M) (e : M ≃ₗ[R] M') :
  ((e.symm.trans f).trans e).det = f.det :=
by rw [←units.eq_iff, coe_det, coe_det, ←comp_coe, ←comp_coe, linear_map.det_conj]

end linear_equiv

/-- The determinants of a `linear_equiv` and its inverse multiply to 1. -/
@[simp] lemma linear_equiv.det_mul_det_symm {A : Type*} [comm_ring A] [module A M]
  (f : M ≃ₗ[A] M) : (f : M →ₗ[A] M).det * (f.symm : M →ₗ[A] M).det = 1 :=
by simp [←linear_map.det_comp]

/-- The determinants of a `linear_equiv` and its inverse multiply to 1. -/
@[simp] lemma linear_equiv.det_symm_mul_det {A : Type*} [comm_ring A] [module A M]
  (f : M ≃ₗ[A] M) : (f.symm : M →ₗ[A] M).det * (f : M →ₗ[A] M).det = 1 :=
by simp [←linear_map.det_comp]

-- Cannot be stated using `linear_map.det` because `f` is not an endomorphism.
lemma linear_equiv.is_unit_det (f : M ≃ₗ[R] M') (v : basis ι R M) (v' : basis ι R M') :
  is_unit (linear_map.to_matrix v v' f).det :=
begin
  apply is_unit_det_of_left_inverse,
  simpa using (linear_map.to_matrix_comp v v' v f.symm f).symm
end

/-- Specialization of `linear_equiv.is_unit_det` -/
lemma linear_equiv.is_unit_det' {A : Type*} [comm_ring A] [module A M]
  (f : M ≃ₗ[A] M) : is_unit (linear_map.det (f : M →ₗ[A] M)) :=
is_unit_of_mul_eq_one _ _ f.det_mul_det_symm

/-- The determinant of `f.symm` is the inverse of that of `f` when `f` is a linear equiv. -/
lemma linear_equiv.det_coe_symm {𝕜 : Type*} [field 𝕜] [module 𝕜 M]
  (f : M ≃ₗ[𝕜] M) : (f.symm : M →ₗ[𝕜] M).det = (f : M →ₗ[𝕜] M).det ⁻¹ :=
by field_simp [is_unit.ne_zero f.is_unit_det']

/-- Builds a linear equivalence from a linear map whose determinant in some bases is a unit. -/
@[simps]
def linear_equiv.of_is_unit_det {f : M →ₗ[R] M'} {v : basis ι R M} {v' : basis ι R M'}
  (h : is_unit (linear_map.to_matrix v v' f).det) : M ≃ₗ[R] M' :=
{ to_fun := f,
  map_add' := f.map_add,
  map_smul' := f.map_smul,
  inv_fun := to_lin v' v (to_matrix v v' f)⁻¹,
  left_inv := λ x,
    calc to_lin v' v (to_matrix v v' f)⁻¹ (f x)
        = to_lin v v ((to_matrix v v' f)⁻¹ ⬝ to_matrix v v' f) x :
      by { rw [to_lin_mul v v' v, to_lin_to_matrix, linear_map.comp_apply] }
    ... = x : by simp [h],
  right_inv := λ x,
    calc f (to_lin v' v (to_matrix v v' f)⁻¹ x)
        = to_lin v' v' (to_matrix v v' f ⬝ (to_matrix v v' f)⁻¹) x :
      by { rw [to_lin_mul v' v v', linear_map.comp_apply, to_lin_to_matrix v v'] }
    ... = x : by simp [h] }

@[simp] lemma linear_equiv.coe_of_is_unit_det {f : M →ₗ[R] M'} {v : basis ι R M} {v' : basis ι R M'}
  (h : is_unit (linear_map.to_matrix v v' f).det) :
  (linear_equiv.of_is_unit_det h : M →ₗ[R] M') = f :=
by { ext x, refl }

/-- Builds a linear equivalence from a linear map on a finite-dimensional vector space whose
determinant is nonzero. -/
@[reducible] def linear_map.equiv_of_det_ne_zero
  {𝕜 : Type*} [field 𝕜] {M : Type*} [add_comm_group M] [module 𝕜 M]
  [finite_dimensional 𝕜 M] (f : M →ₗ[𝕜] M) (hf : linear_map.det f ≠ 0) :
  M ≃ₗ[𝕜] M :=
have is_unit (linear_map.to_matrix (finite_dimensional.fin_basis 𝕜 M)
  (finite_dimensional.fin_basis 𝕜 M) f).det :=
    by simp only [linear_map.det_to_matrix, is_unit_iff_ne_zero.2 hf],
linear_equiv.of_is_unit_det this

/-- The determinant of a family of vectors with respect to some basis, as an alternating
multilinear map. -/
def basis.det : alternating_map R M R ι :=
{ to_fun := λ v, det (e.to_matrix v),
  map_add' := begin
    intros v i x y,
    simp only [e.to_matrix_update, linear_equiv.map_add],
    apply det_update_column_add
  end,
  map_smul' := begin
    intros u i c x,
    simp only [e.to_matrix_update, algebra.id.smul_eq_mul, linear_equiv.map_smul],
    apply det_update_column_smul
  end,
  map_eq_zero_of_eq' := begin
    intros v i j h hij,
    rw [←function.update_eq_self i v, h, ←det_transpose, e.to_matrix_update,
        ←update_row_transpose, ←e.to_matrix_transpose_apply],
    apply det_zero_of_row_eq hij,
    rw [update_row_ne hij.symm, update_row_self],
  end }

lemma basis.det_apply (v : ι → M) : e.det v = det (e.to_matrix v) := rfl

lemma basis.det_self : e.det e = 1 :=
by simp [e.det_apply]

/-- `basis.det` is not the zero map. -/
lemma basis.det_ne_zero [nontrivial R] : e.det ≠ 0 :=
λ h, by simpa [h] using e.det_self

lemma is_basis_iff_det {v : ι → M} :
  linear_independent R v ∧ span R (set.range v) = ⊤ ↔ is_unit (e.det v) :=
begin
  split,
  { rintro ⟨hli, hspan⟩,
    set v' := basis.mk hli hspan with v'_eq,
    rw e.det_apply,
    convert linear_equiv.is_unit_det (linear_equiv.refl _ _) v' e using 2,
    ext i j,
    simp },
  { intro h,
    rw [basis.det_apply, basis.to_matrix_eq_to_matrix_constr] at h,
    set v' := basis.map e (linear_equiv.of_is_unit_det h) with v'_def,
    have : ⇑ v' = v,
    { ext i, rw [v'_def, basis.map_apply, linear_equiv.of_is_unit_det_apply, e.constr_basis] },
    rw ← this,
    exact ⟨v'.linear_independent, v'.span_eq⟩ },
end

lemma basis.is_unit_det (e' : basis ι R M) : is_unit (e.det e') :=
(is_basis_iff_det e).mp ⟨e'.linear_independent, e'.span_eq⟩

/-- Any alternating map to `R` where `ι` has the cardinality of a basis equals the determinant
map with respect to that basis, multiplied by the value of that alternating map on that basis. -/
lemma alternating_map.eq_smul_basis_det (f : alternating_map R M R ι) : f = f e • e.det :=
begin
  refine basis.ext_alternating e (λ i h, _),
  let σ : equiv.perm ι := equiv.of_bijective i (fintype.injective_iff_bijective.1 h),
  change f (e ∘ σ) = (f e • e.det) (e ∘ σ),
  simp [alternating_map.map_perm, basis.det_self]
end

@[simp] lemma alternating_map.map_basis_eq_zero_iff (f : alternating_map R M R ι) :
  f e = 0 ↔ f = 0 :=
⟨λ h, by simpa [h] using f.eq_smul_basis_det e, λ h, h.symm ▸ alternating_map.zero_apply _⟩

lemma alternating_map.map_basis_ne_zero_iff (f : alternating_map R M R ι) :
  f e ≠ 0 ↔ f ≠ 0 :=
not_congr $ f.map_basis_eq_zero_iff e

variables {A : Type*} [comm_ring A] [module A M]

@[simp] lemma basis.det_comp (e : basis ι A M) (f : M →ₗ[A] M) (v : ι → M) :
  e.det (f ∘ v) = f.det * e.det v :=
by { rw [basis.det_apply, basis.det_apply, ← f.det_to_matrix e, ← matrix.det_mul,
         e.to_matrix_eq_to_matrix_constr (f ∘ v), e.to_matrix_eq_to_matrix_constr v,
         ← to_matrix_comp, e.constr_comp] }

lemma basis.det_reindex {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (b : basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
  (b.reindex e).det v = b.det (v ∘ e) :=
by rw [basis.det_apply, basis.to_matrix_reindex', det_reindex_alg_equiv, basis.det_apply]

lemma basis.det_reindex_symm {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (b : basis ι R M) (v : ι → M) (e : ι' ≃ ι) :
  (b.reindex e.symm).det (v ∘ e) = b.det v :=
by rw [basis.det_reindex, function.comp.assoc, e.self_comp_symm, function.comp.right_id]

@[simp]
lemma basis.det_map (b : basis ι R M) (f : M ≃ₗ[R] M') (v : ι → M') :
  (b.map f).det v = b.det (f.symm ∘ v) :=
by { rw [basis.det_apply, basis.to_matrix_map, basis.det_apply] }

lemma basis.det_map' (b : basis ι R M) (f : M ≃ₗ[R] M') :
  (b.map f).det = b.det.comp_linear_map f.symm :=
alternating_map.ext $ b.det_map f

@[simp] lemma pi.basis_fun_det : (pi.basis_fun R ι).det = matrix.det_row_alternating :=
begin
  ext M,
  rw [basis.det_apply, basis.coe_pi_basis_fun.to_matrix_eq_transpose, det_transpose],
end

/-- If we fix a background basis `e`, then for any other basis `v`, we can characterise the
coordinates provided by `v` in terms of determinants relative to `e`. -/
lemma basis.det_smul_mk_coord_eq_det_update {v : ι → M}
  (hli : linear_independent R v) (hsp : span R (range v) = ⊤) (i : ι) :
  (e.det v) • (basis.mk hli hsp).coord i = e.det.to_multilinear_map.to_linear_map v i :=
begin
  apply (basis.mk hli hsp).ext,
  intros k,
  rcases eq_or_ne k i with rfl | hik;
  simp only [algebra.id.smul_eq_mul, basis.coe_mk, linear_map.smul_apply, linear_map.coe_mk,
    multilinear_map.to_linear_map_apply],
  { rw [basis.mk_coord_apply_eq, mul_one, update_eq_self], congr, },
  { rw [basis.mk_coord_apply_ne hik, mul_zero, eq_comm],
    exact e.det.map_eq_zero_of_eq _ (by simp [hik, function.update_apply]) hik, },
end

/-- The determinant of a basis constructed by `units_smul` is the product of the given units. -/
@[simp] lemma basis.det_units_smul (w : ι → Rˣ) : e.det (e.units_smul w) = ∏ i, w i :=
by simp [basis.det_apply]

/-- The determinant of a basis constructed by `is_unit_smul` is the product of the given units. -/
@[simp] lemma basis.det_is_unit_smul {w : ι → R} (hw : ∀ i, is_unit (w i)) :
  e.det (e.is_unit_smul hw) = ∏ i, w i :=
e.det_units_smul _


import o_minimal.definable

-- Definability of algebraic operations on definable types.

namespace o_minimal

variables {R : Type*} (S : struc R)
variables {X : Type*} [has_coordinates R X] [is_definable S X]
variables {Y : Type*} [has_coordinates R Y] [is_definable S Y]

variables (X)

class is_definable_add [has_add X] : Prop :=
(definable_add : def_fun S (λ p : X × X, p.1 + p.2))

@[to_additive]
class is_definable_mul [has_mul X] : Prop :=
(definable_mul : def_fun S (λ p : X × X, p.1 * p.2))

variables {X S}

section has_mul

variables [has_mul X] [is_definable_mul S X]

@[to_additive]
lemma definable_mul : def_fun S (λ p : X × X, p.1 * p.2) :=
is_definable_mul.definable_mul

@[to_additive]
lemma definable.mul {f : Y → X} (hf : def_fun S f) {g : Y → X} (hg : def_fun S g) :
  def_fun S (λ y, f y * g y) :=
definable_mul.comp (hf.prod' hg)

end has_mul

section monoid

variables [monoid X] [is_definable_mul S X]

@[to_additive]
lemma definable_one : def_val S (1 : X) :=
begin
  suffices : {(1 : X)} = {x | ∀ y, x * y = y},
  { unfold def_val,
    rw this,
    refine def_set.forall _,
    apply_instance,             -- TODO: Huh?
    exact def_set_eq definable_mul def_fun.snd },
  ext x,
  split; intro h,
  { cases h,
    intro y,
    apply one_mul },
  { simpa using h 1 }
end

end monoid

-- TODO: theorem: in a group OR group_with_zero,
-- the inverse is definable if multiplication is.

end o_minimal


example (P Q F : Type) : (P → Q) → ((Q → F) → (P → F)) :=
begin
intros g f p,
exact f(g(p)),
end


/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Squareovers
-/

import .square

universe u
hott_theory

namespace hott
open eq hott.equiv hott.is_equiv hott.sigma

namespace eq

  -- we give the argument B explicitly, because Lean would find (λa, B a) by itself, which
  -- makes the type uglier (of course the two terms are definitionally equal)
  inductive squareover {A : Type _} (B : A → Type _) {a₀₀ : A} {b₀₀ : B a₀₀} :
    Π{a₂₀ a₀₂ a₂₂ : A}
     {p₁₀ : a₀₀ = a₂₀} {p₁₂ : a₀₂ = a₂₂} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂}
     (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
     {b₂₀ : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂}
     (q₁₀ : b₀₀ =[p₁₀; B] b₂₀) (q₁₂ : b₀₂ =[p₁₂; B] b₂₂)
     (q₀₁ : b₀₀ =[p₀₁; B] b₀₂) (q₂₁ : b₂₀ =[p₂₁; B] b₂₂),
     Type _
  | idsquareo : squareover ids idpo idpo idpo idpo

  variables {A : Type _} {A' : Type _} {B : A → Type _}
            {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ : A}
            /-a₀₀-/ {p₁₀ : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
       {p₀₁ : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
            /-a₀₂-/ {p₁₂ : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
            /-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
            {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁} {s₃₁ : square p₃₀ p₃₂ p₂₁ p₄₁}
            {s₁₃ : square p₁₂ p₁₄ p₀₃ p₂₃} {s₃₃ : square p₃₂ p₃₄ p₂₃ p₄₃}

            {b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₄₀ : B a₄₀}
            {b₀₂ : B a₀₂} {b₂₂ : B a₂₂} {b₄₂ : B a₄₂}
            {b₀₄ : B a₀₄} {b₂₄ : B a₂₄} {b₄₄ : B a₄₄}
            /-b₀₀-/ {q₁₀ : b₀₀ =[p₁₀] b₂₀} /-b₂₀-/ {q₃₀ : b₂₀ =[p₃₀] b₄₀} /-b₄₀-/
   {q₀₁ : b₀₀ =[p₀₁] b₀₂} /-t₁₁-/ {q₂₁ : b₂₀ =[p₂₁] b₂₂} /-t₃₁-/ {q₄₁ : b₄₀ =[p₄₁] b₄₂}
            /-b₀₂-/ {q₁₂ : b₀₂ =[p₁₂] b₂₂} /-b₂₂-/ {q₃₂ : b₂₂ =[p₃₂] b₄₂} /-b₄₂-/
   {q₀₃ : b₀₂ =[p₀₃] b₀₄} /-t₁₃-/ {q₂₃ : b₂₂ =[p₂₃] b₂₄} /-t₃₃-/ {q₄₃ : b₄₂ =[p₄₃] b₄₄}
            /-b₀₄-/ {q₁₄ : b₀₄ =[p₁₄] b₂₄} /-b₂₄-/ {q₃₄ : b₂₄ =[p₃₄] b₄₄} /-b₄₄-/

  @[hott] def squareo := @squareover A B a₀₀
  @[hott, reducible] def idsquareo (b₀₀ : B a₀₀) := @squareover.idsquareo A B a₀₀ b₀₀
  @[hott, reducible] def idso                    := @squareover.idsquareo A B a₀₀ b₀₀

  @[hott] def apds (f : Πa, B a) (s : square p₁₀ p₁₂ p₀₁ p₂₁)
    : squareover B s (apd f p₁₀) (apd f p₁₂) (apd f p₀₁) (apd f p₂₁) :=
  by induction s; constructor

  @[hott] def vrflo : squareover B vrfl q₁₀ q₁₀ idpo idpo :=
  by induction q₁₀; exact idso

  @[hott] def hrflo : squareover B hrfl idpo idpo q₁₀ q₁₀ :=
  by induction q₁₀; exact idso

  @[hott] def vdeg_squareover {p₁₀'} {s : p₁₀ = p₁₀'} {q₁₀' : b₀₀ =[p₁₀'] b₂₀}
    (r : change_path s q₁₀ = q₁₀')
    : squareover B (vdeg_square s) q₁₀ q₁₀' idpo idpo :=
  by induction s; induction r; exact vrflo

  @[hott] def hdeg_squareover {p₀₁'} {s : p₀₁ = p₀₁'} {q₀₁' : b₀₀ =[p₀₁'] b₀₂}
    (r : change_path s q₀₁ = q₀₁')
    : squareover B (hdeg_square s) idpo idpo q₀₁ q₀₁' :=
  by induction s; induction r; exact hrflo

  @[hott] def hconcato
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (t₃₁ : squareover B s₃₁ q₃₀ q₃₂ q₂₁ q₄₁)
    : squareover B (hconcat s₁₁ s₃₁) (q₁₀ ⬝o q₃₀) (q₁₂ ⬝o q₃₂) q₀₁ q₄₁ :=
  by induction t₃₁; exact t₁₁

  @[hott] def vconcato
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (t₁₃ : squareover B s₁₃ q₁₂ q₁₄ q₀₃ q₂₃)
    : squareover B (vconcat s₁₁ s₁₃) q₁₀ q₁₄ (q₀₁ ⬝o q₀₃) (q₂₁ ⬝o q₂₃) :=
  by induction t₁₃; exact t₁₁

  @[hott] def hinverseo (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B (hinverse s₁₁) q₁₀⁻¹ᵒ q₁₂⁻¹ᵒ q₂₁ q₀₁ :=
  by induction t₁₁; constructor

  @[hott] def vinverseo (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B (vinverse s₁₁) q₁₂ q₁₀ q₀₁⁻¹ᵒ q₂₁⁻¹ᵒ :=
  by induction t₁₁; constructor

  @[hott] def eq_vconcato {q : b₀₀ =[p₁₀] b₂₀}
    (r : q = q₁₀) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) : squareover B s₁₁ q q₁₂ q₀₁ q₂₁ :=
  by induction r; exact t₁₁

  @[hott] def vconcato_eq {q : b₀₂ =[p₁₂] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : q₁₂ = q) : squareover B s₁₁ q₁₀ q q₀₁ q₂₁ :=
  by induction r; exact t₁₁

  @[hott] def eq_hconcato {q : b₀₀ =[p₀₁] b₀₂}
    (r : q = q₀₁) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) : squareover B s₁₁ q₁₀ q₁₂ q q₂₁ :=
  by induction r; exact t₁₁

  @[hott] def hconcato_eq {q : b₂₀ =[p₂₁] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : q₂₁ = q) : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q :=
  by induction r; exact t₁₁

  @[hott] def pathover_vconcato {p : a₀₀ = a₂₀} {sp : p = p₁₀} {q : b₀₀ =[p] b₂₀}
    (r : change_path sp q = q₁₀) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B (sp ⬝pv s₁₁) q q₁₂ q₀₁ q₂₁ :=
  by induction sp; induction r; exact t₁₁

  @[hott] def vconcato_pathover {p : a₀₂ = a₂₂} {sp : p₁₂ = p} {q : b₀₂ =[p] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₁₂ = q)
    : squareover B (s₁₁ ⬝vp sp) q₁₀ q q₀₁ q₂₁ :=
  by induction sp; induction r; exact t₁₁

  @[hott] def pathover_hconcato {p : a₀₀ = a₀₂} {sp : p = p₀₁} {q : b₀₀ =[p] b₀₂}
    (r : change_path sp q = q₀₁) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
    squareover B (sp ⬝ph s₁₁) q₁₀ q₁₂ q q₂₁ :=
  by induction sp; induction r; exact t₁₁

  @[hott] def hconcato_pathover {p : a₂₀ = a₂₂} {sp : p₂₁ = p} {q : b₂₀ =[p] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₂₁ = q) :
    squareover B (s₁₁ ⬝hp sp) q₁₀ q₁₂ q₀₁ q :=
  by induction sp; induction r; exact t₁₁

  infix ` ⬝ho `:69 := hconcato --type using \tr
  infix ` ⬝vo `:70 := vconcato --type using \tr
  infix ` ⬝hop `:72 := hconcato_eq --type using \tr
  infix ` ⬝vop `:74 := vconcato_eq --type using \tr
  infix ` ⬝pho `:71 := eq_hconcato --type using \tr
  infix ` ⬝pvo `:73 := eq_vconcato --type using \tr

  @[hott] def square_of_squareover (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
    square (con_tr p₁₀ p₂₁ b₀₀ ⬝ ap (λa : B a₂₀, p₂₁ ▸ a) (tr_eq_of_pathover q₁₀))
           (tr_eq_of_pathover q₁₂)
           (transport2 _ (eq_of_square s₁₁) b₀₀ ⬝ con_tr _ _ _ ⬝ ap (λa : B a₀₂, p₁₂ ▸ a) (tr_eq_of_pathover q₀₁))
           (tr_eq_of_pathover q₂₁) :=
  by induction t₁₁; constructor

  variable (B)
  @[hott] def square_of_squareover_ids {b₀₀ b₀₂ b₂₀ b₂₂ : B a}
    {t : b₀₀ = b₂₀} {b : b₀₂ = b₂₂} {l : b₀₀ = b₀₂} {r : b₂₀ = b₂₂}
    (so : squareover B ids (pathover_idp_of_eq B t)
                           (pathover_idp_of_eq B b)
                           (pathover_idp_of_eq B l)
                           (pathover_idp_of_eq B r)) : square t b l r :=
  begin
    let H := square_of_squareover so, hsimp at H,
    exact whisker_square (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _)
                         (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _)
                         (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _)
                         (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _) H
  end

  @[hott] def squareover_ids_of_square {b₀₀ b₀₂ b₂₀ b₂₂ : B a}
    {t : b₀₀ = b₂₀} {b : b₀₂ = b₂₂} {l : b₀₀ = b₀₂} {r : b₂₀ = b₂₂} (q : square t b l r)
    : squareover B ids (pathover_idp_of_eq B t)
                       (pathover_idp_of_eq B b)
                       (pathover_idp_of_eq B l)
                       (pathover_idp_of_eq B r) :=
  by induction q; constructor

  -- relating pathovers to squareovers
  variable {B}
  @[hott] def pathover_of_squareover' (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : q₁₀ ⬝o q₂₁ =[eq_of_square s₁₁; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂ :=
  by induction t₁₁; constructor

  @[hott] def pathover_of_squareover {s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂}
    (t₁₁ : squareover B (square_of_eq s) q₁₀ q₁₂ q₀₁ q₂₁)
    : q₁₀ ⬝o q₂₁ =[s; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂ :=
  begin
    revert s t₁₁,
    refine equiv_rect' (square_equiv_eq p₁₀ p₁₂ p₀₁ p₂₁)⁻¹ᵉ
      (λa b, squareover B b q₁₀ q₁₂ q₀₁ q₂₁ → q₁₀ ⬝o q₂₁ =[a; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂) _,
    intro s, exact pathover_of_squareover'
  end

  @[hott] def squareover_of_pathover {s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂}
    (r : q₁₀ ⬝o q₂₁ =[s; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂) :
    squareover B (square_of_eq s) q₁₀ q₁₂ q₀₁ q₂₁ :=
  by induction q₁₂; hsimp at r; induction r; induction q₁₀; induction q₂₁; constructor

  @[hott] def pathover_top_of_squareover (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : q₁₀ =[eq_top_of_square s₁₁; λp, b₀₀ =[p] b₂₀] q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ :=
  by induction t₁₁; constructor

  @[hott] def squareover_of_pathover_top {s : p₁₀ = p₀₁ ⬝ p₁₂ ⬝ p₂₁⁻¹}
  (r : q₁₀ =[s; λp, b₀₀ =[p] b₂₀] q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ)
    : squareover B (square_of_eq_top s) q₁₀ q₁₂ q₀₁ q₂₁ :=
  by induction q₂₁; induction q₁₂; dsimp at r; induction r; induction q₁₀; constructor

  @[hott] def pathover_of_hdeg_squareover {p₀₁' : a₀₀ = a₀₂} {r : p₀₁ = p₀₁'} {q₀₁' : b₀₀ =[p₀₁'] b₀₂}
    (t : squareover B (hdeg_square r) idpo idpo q₀₁ q₀₁') : q₀₁ =[r; λp, b₀₀ =[p] b₀₂] q₀₁' :=
  by induction r; induction q₀₁'; exact (pathover_of_squareover' t)⁻¹ᵒ

  @[hott] def pathover_of_vdeg_squareover {p₁₀' : a₀₀ = a₂₀} {r : p₁₀ = p₁₀'} {q₁₀' : b₀₀ =[p₁₀'] b₂₀}
    (t : squareover B (vdeg_square r) q₁₀ q₁₀' idpo idpo) : q₁₀ =[r; λp, b₀₀ =[p] b₂₀] q₁₀' :=
  by induction r; induction q₁₀'; exact pathover_of_squareover' t

  @[hott] def squareover_of_eq_top (r : change_path (eq_top_of_square s₁₁) q₁₀ = q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ)
    : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁ :=
  begin
    induction s₁₁, revert q₁₂ q₁₀ r,
    refine idp_rec_on q₂₁ _, clear q₂₁,
    intro q₁₂,
    refine idp_rec_on q₁₂ _, clear q₁₂,
    dsimp, intros,
    induction r, eapply idp_rec_on q₁₀,
    constructor
  end

  @[hott] def eq_top_of_squareover (r : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : change_path (eq_top_of_square s₁₁) q₁₀ = q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ :=
  by induction r; reflexivity

  @[hott] def change_square {s₁₁'} (p : s₁₁ = s₁₁') (r : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B s₁₁' q₁₀ q₁₂ q₀₁ q₂₁ :=
  by induction p; exact r -- in Lean 2 defined using transport

  @[hott] lemma eq_of_vdeg_squareover {q₁₀' : b₀₀ =[p₁₀] b₂₀}
    (p : squareover B vrfl q₁₀ q₁₀' idpo idpo) : q₁₀ = q₁₀' :=
  begin
    let H := square_of_squareover p,
    induction p₁₀,
    hsimp at H,
    let H' := eq_of_vdeg_square H,
    exact eq_of_fn_eq_fn (pathover_equiv_tr_eq _ _ _) H'
  end

  /- A version of eq_pathover where the type of the equality also varies -/
  @[hott] lemma eq_pathover_dep {f g : Πa, B a} {p : a = a'} {q : f a = g a}
    {r : f a' = g a'} (s : squareover B hrfl (pathover_idp_of_eq B q) (pathover_idp_of_eq B r)
                                             (apd f p) (apd g p)) : q =[p; λx, f x = g x] r :=
  begin
    induction p, apply pathover_idp_of_eq, apply eq_of_vdeg_square, exact square_of_squareover_ids _ s
  end

  /- charcaterization of pathovers in pathovers -/
  -- in this version the fibration (B) of the pathover does not depend on the variable (a)
   @[hott] lemma pathover_pathover {a' a₂' : A'} {p : a' = a₂'} {f g : A' → A}
    {b : Πa, B (f a)} {b₂ : Πa, B (g a)} {q : Π(a' : A'), f a' = g a'}
    (r : b a' =[q a'; B] b₂ a')
    (r₂ : b a₂' =[q a₂'; B] b₂ a₂')
    (s : squareover B (natural_square q p) r r₂
                      (pathover_ap B f (apd b p)) (pathover_ap B g (apd b₂ p))) :
    r =[p; λa, b a =[q a; B] b₂ a] r₂ :=
  begin
    induction p, apply pathover_idp_of_eq, apply eq_of_vdeg_squareover, exact s
  end

  @[hott] def squareover_change_path_left {p₀₁' : a₀₀ = a₀₂} (r : p₀₁' = p₀₁)
    {q₀₁ : b₀₀ =[p₀₁'] b₀₂} (t : squareover B (r ⬝ph s₁₁) q₁₀ q₁₂ q₀₁ q₂₁)
  : squareover B s₁₁ q₁₀ q₁₂ (change_path r q₀₁) q₂₁ :=
  by induction r; exact t

  @[hott] def squareover_change_path_right {p₂₁' : a₂₀ = a₂₂} (r : p₂₁' = p₂₁)
    {q₂₁ : b₂₀ =[p₂₁'] b₂₂} (t : squareover B (s₁₁ ⬝hp r⁻¹) q₁₀ q₁₂ q₀₁ q₂₁)
  : squareover B s₁₁ q₁₀ q₁₂ q₀₁ (change_path r q₂₁) :=
  by induction r; exact t

  @[hott] def squareover_change_path_right' {p₂₁' : a₂₀ = a₂₂} (r : p₂₁ = p₂₁')
    {q₂₁ : b₂₀ =[p₂₁'] b₂₂} (t : squareover B (s₁₁ ⬝hp r) q₁₀ q₁₂ q₀₁ q₂₁)
  : squareover B s₁₁ q₁₀ q₁₂ q₀₁ (change_path r⁻¹ q₂₁) :=
  by induction r; exact t

  /- You can construct a square in a sigma-type by giving a squareover -/
  @[hott] def square_dpair_eq_dpair {a₀₀ a₂₀ a₀₂ a₂₂ : A}
    {p₁₀ : a₀₀ = a₂₀} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂} {p₁₂ : a₀₂ = a₂₂}
    (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) {b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂}
    {q₁₀ : b₀₀ =[p₁₀] b₂₀} {q₀₁ : b₀₀ =[p₀₁] b₀₂} {q₂₁ : b₂₀ =[p₂₁] b₂₂} {q₁₂ : b₀₂ =[p₁₂] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
    square (sigma.dpair_eq_dpair p₁₀ q₁₀) (dpair_eq_dpair p₁₂ q₁₂)
           (dpair_eq_dpair p₀₁ q₀₁) (dpair_eq_dpair p₂₁ q₂₁) :=
  by induction t₁₁; constructor

  @[hott] lemma sigma_square {v₀₀ v₂₀ v₀₂ v₂₂ : Σa, B a}
    {p₁₀ : v₀₀ = v₂₀} {p₀₁ : v₀₀ = v₀₂} {p₂₁ : v₂₀ = v₂₂} {p₁₂ : v₀₂ = v₂₂}
    (s₁₁ : square p₁₀..1 p₁₂..1 p₀₁..1 p₂₁..1)
    (t₁₁ : squareover B s₁₁ p₁₀..2 p₁₂..2 p₀₁..2 p₂₁..2) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
  begin
    induction v₀₀, induction v₂₀, induction v₀₂, induction v₂₂,
    rwr [(sigma_eq_eta p₁₀)⁻¹, (sigma_eq_eta p₀₁)⁻¹, (sigma_eq_eta p₁₂)⁻¹, (sigma_eq_eta p₂₁)⁻¹],
    exact square_dpair_eq_dpair s₁₁ t₁₁
  end

end eq
end hott