--import data.set
import data.sym2
open set function

--open_locale classical

--universe u
--variable {U : Type u}

--def P₁ (A : set U) : set (set U) := { B : set U | ∃ a ∈ A, B = {a} }
--def P₂ (A : set U) : set (set U) := { B : set U | ∃ a b ∈ A, a ≠ b ∧ B = {a, b}}

--variables V E : set U
--variable ε : E → P₁(V) ∪ P₂(V)

--#check P₁ V

structure digraph :=
  mk :: (vertices : Type) (arrows : Type) (endpoints : arrows → vertices × vertices)

--#check (∅ : set U)

/-theorem empty_one : P₁((∅ : set U)) = ∅ :=
begin
  apply eq_of_subset_of_subset,
  {
    assume x,
    intro h₁,
    cases h₁ with a ha,
    rw mem_empty_eq,
    cases ha with H hH,
    rw ← mem_empty_eq a,
    exact H,
  },
  {
    exact empty_subset _,
  },
end-/

--variables a b : U
--variable G : graph

#check digraph

--def are_adjacent (G : digraph) (a b : G.vertices) : Prop := ∃ e : G.arrows, G.endpoints(e) = (a,b) ∨ G.endpoints(e) = (b,a)

/-def twist (α : Type × Type) : Type × Type :=
  prod.mk (prod.snd α) (prod.fst α)

#check twist
variable α : Type × Type
#reduce twist α

def rel (α : Type × Type) (β : Type × Type) : Prop :=
  β = α ∨ β = twist(α)

#check rel
#check quot rel
#reduce quot rel

variable V : Type
#check prod.mk V V
#check quot.mk rel
#check quot.mk rel (V,V)
-/

structure graph :=
  (vertices : Type)
  (edges : Type)
  (endpoints : edges → sym2 vertices)

#check graph

/-variable G : graph
#check G.vertices
variables a b : G.vertices
#check a
#check ⟦(a,b)⟧-/

theorem endpoint_sym (G : graph) (a b : G.vertices) : ⟦(a,b)⟧ = ⟦(b,a)⟧ :=
begin
  exact sym2.eq_swap,
end

def are_adjacent (G : graph) (a b : G.vertices) : Prop := ∃ e : G.edges, G.endpoints(e) = ⟦(a,b)⟧

structure morphism (G : graph) (H : graph) :=
  (vertex_map : G.vertices → H.vertices)
  (edge_map : G.edges → H.edges)
  (compatability : H.endpoints ∘ edge_map = sym2.map vertex_map ∘ G.endpoints)

variable G : graph
variable H : graph
variable K : graph
infix `↦` :50 := morphism

variable α : G ↦ H
variable β : morphism H K
#check α
#check β

#check K.endpoints ∘ β.edge_map ∘ α.edge_map
#check β.vertex_map ∘ α.vertex_map
#check G.endpoints
#check α.compatability
#check β.compatability

theorem compatability {G H K : graph} (α : G ↦ H) (β : H ↦ K) : K.endpoints ∘ β.edge_map ∘ α.edge_map = sym2.map (β.vertex_map ∘ α.vertex_map) ∘ G.endpoints :=
begin
  have h₁ : K.endpoints ∘ β.edge_map ∘ α.edge_map = sym2.map β.vertex_map ∘ H.endpoints ∘ α.edge_map,
  {
    rw ← comp.assoc K.endpoints β.edge_map α.edge_map,
    rw β.compatability,
  },
  have h₂ : sym2.map (β.vertex_map) ∘ H.endpoints ∘ α.edge_map = sym2.map (β.vertex_map) ∘ sym2.map (α.vertex_map) ∘ G.endpoints,
  {
    rw α.compatability,
  },
  have h₃ : sym2.map (β.vertex_map ∘ α.vertex_map) = sym2.map (β.vertex_map) ∘ sym2.map (α.vertex_map),
  {
    by exact sym2.map_comp,
  },
  rw h₁,
  rw h₂,
  rw h₃,
end

def compose {G H K : graph} (β : H ↦ K) (α : G ↦ H) : G ↦ K :=
  morphism.mk (β.vertex_map ∘ α.vertex_map) (β.edge_map ∘ α.edge_map) (by exact compatability α β)

#check compose β α
infix `⊚`:80 := compose
variable L : graph
variable γ : K ↦ L
#check γ
#check β ⊚ α
#check γ ⊚ β

theorem mor_assoc {G H K L : graph} (α : G ↦ H) (β : H ↦ K) (γ : K ↦ L) : γ ⊚ (β ⊚ α) = (γ ⊚ β) ⊚ α :=
begin
  refl,
end

theorem id_compatability (G : graph) : G.endpoints ∘ id = sym2.map id ∘ G.endpoints :=
begin
  rw sym2.map_id,
  refl,
end

#check id_compatability G

def 𝕀 (G : graph) : G ↦ G :=
  morphism.mk (id) (id) (by exact id_compatability G)

variable {U : Type}
variables {V E : set U}
#check V
variable {ε : E → sym2 V}
#check ε
#reduce 𝕀 G

def s := graph.mk (V) (E) (ε)
#check s

def isomorphism {G H : graph} (α : G ↦ H) : Prop :=
  ∃ β : H ↦ G, α ⊚ β = 𝕀 H ∧ β ⊚ α = 𝕀 G

theorem id_is_iso (G : graph) : isomorphism (𝕀 G) :=
begin
  use 𝕀 G,
  split,
  refl,
  refl,
end

#check id H.vertices
#check (𝕀 H).vertex_map
#reduce (𝕀 H).vertex_map

theorem mor_ext {G H : graph} (α : G ↦ H) (β : G ↦ H) (hv : α.vertex_map = β.vertex_map) (he : α.edge_map = β.edge_map) : α = β :=
begin
  cases α,
  cases β,
  rw morphism.mk.inj_eq,
  exact ⟨hv, he⟩,
end

theorem eq_mor_eq_vmap {G H : graph} (α : G ↦ H) (β : G ↦ H) (hyp : α = β) : α.vertex_map = β.vertex_map :=
begin
  cases α,
  cases β,
  rw morphism.mk.inj_eq at hyp,
  exact hyp.1,
end

theorem eq_mor_eq_emap {G H : graph} (α : G ↦ H) (β : G ↦ H) (hyp : α = β) : α.edge_map = β.edge_map :=
begin
  cases α,
  cases β,
  rw morphism.mk.inj_eq at hyp,
  exact hyp.2,
end

#reduce (β ⊚ α).vertex_map
#check eq_mor_eq_vmap (β ⊚ α) (β ⊚ α) (rfl)

theorem iso.bij {G H : graph} (α : G ↦ H) (hyp : isomorphism α) : bijective α.vertex_map ∧ bijective α.edge_map :=
begin
  cases hyp with β hβ,
  cases hβ with h₁ h₂,
  split,
  split,
  /-
  have h₃ := eq_mor_eq_vmap (β ⊚ α) (𝕀 G) (h₂),
  have h₄ : (𝕀 G).vertex_map = λ (x : G.vertices), x,
  {
    refl,
  },
  have h₅ : (β ⊚ α).vertex_map = β.vertex_map ∘ α.vertex_map,
  {
    refl,
  },
  have h₆ : left_inverse β.vertex_map α.vertex_map,
  {
    intro x,
    have h₇ : (β ⊚ α).vertex_map x = β.vertex_map (α.vertex_map x),
    {
      refl,
    },
    rw ← h₇,
    have h₈ : (β ⊚ α).vertex_map x = (𝕀 G).vertex_map x,
    {
      rw h₃,
    },
    rw h₈,
    rw h₄,
  },
  -/
  have h₃ : left_inverse β.vertex_map α.vertex_map,
  {
    intro x,
    calc β.vertex_map (α.vertex_map x) = (β ⊚ α).vertex_map x : by refl
                                   ... = (𝕀 G).vertex_map x : by rw eq_mor_eq_vmap (β ⊚ α) (𝕀 G) (h₂)
                                   ... = x : by refl,
  },
  apply left_inverse.injective h₃,

  have h₃ : right_inverse β.vertex_map α.vertex_map,
  {
    intro x,
    calc α.vertex_map (β.vertex_map x) = (α ⊚ β).vertex_map x : by refl
                                   ... = (𝕀 H).vertex_map x : by rw eq_mor_eq_vmap (α ⊚ β) (𝕀 H) (h₁)
                                   ... = x : by refl,
  },
  apply right_inverse.surjective h₃,

  split,
  have h₃ : left_inverse β.edge_map α.edge_map,
  {
    intro x,
    calc β.edge_map (α.edge_map x) = (β ⊚ α).edge_map x : by refl
                                   ... = (𝕀 G).edge_map x : by rw eq_mor_eq_emap (β ⊚ α) (𝕀 G) (h₂)
                                   ... = x : by refl,
  },
  apply left_inverse.injective h₃,

  have h₃ : right_inverse β.edge_map α.edge_map,
  {
    intro x,
    calc α.edge_map (β.edge_map x) = (α ⊚ β).edge_map x : by refl
                                   ... = (𝕀 H).edge_map x : by rw eq_mor_eq_emap (α ⊚ β) (𝕀 H) (h₁)
                                   ... = x : by refl,
  },
  apply right_inverse.surjective h₃,
end

theorem bij.iso {G H : graph} (α : G ↦ H) (hv : bijective α.vertex_map) (he : bijective α.edge_map) : isomorphism α :=
begin
  let φ := α.vertex_map,
  let ψ := α.edge_map,

  rw bijective_iff_has_inverse at hv,
  cases hv with φ' hφ',
  rw bijective_iff_has_inverse at he,
  cases he with ψ' hψ',

  have comp' : G.endpoints ∘ ψ' = sym2.map φ' ∘ H.endpoints,
  {
    calc G.endpoints ∘ ψ' = id ∘ G.endpoints ∘ ψ' : by refl
                      ... = sym2.map id ∘ G.endpoints ∘ ψ' : by rw sym2.map_id
                      ... = sym2.map (φ' ∘ φ) ∘ G.endpoints ∘ ψ' : by rw left_inverse.id hφ'.1
                      ... = sym2.map φ' ∘ sym2.map φ ∘ G.endpoints ∘ ψ' : by rw sym2.map_comp
                      ... = sym2.map φ' ∘ (H.endpoints ∘ ψ) ∘ ψ' : by rw α.compatability
                      ... = sym2.map φ' ∘ H.endpoints ∘ (ψ ∘ ψ') : by refl
                      ... = sym2.map φ' ∘ H.endpoints ∘ id : by rw right_inverse.id hψ'.2
                      ... = sym2.map φ' ∘ H.endpoints : by refl,
  },

  let β := morphism.mk (φ') (ψ') (comp'),
  use β,
  split,

  {
    apply mor_ext,
    {
      calc (α ⊚ β).vertex_map = α.vertex_map ∘ β.vertex_map : by refl
                          ... = φ ∘ φ' : by refl
                          ... = id : by exact left_inverse.id hφ'.2
                          ... = (𝕀 H).vertex_map : by refl,
    },
    {
      calc (α ⊚ β).edge_map = α.edge_map ∘ β.edge_map : by refl
                          ... = ψ ∘ ψ' : by refl
                          ... = id : by exact left_inverse.id hψ'.2
                          ... = (𝕀 H).edge_map : by refl,
    },
  },

  {
    apply mor_ext,
    {
      calc (β ⊚ α).vertex_map = β.vertex_map ∘ α.vertex_map : by refl
                          ... = φ' ∘ φ : by refl
                          ... = id : by exact left_inverse.id hφ'.1
                          ... = (𝕀 G).vertex_map : by refl,
    },
    {
      calc (β ⊚ α).edge_map = β.edge_map ∘ α.edge_map : by refl
                          ... = ψ' ∘ ψ : by refl
                          ... = id : by exact left_inverse.id hψ'.1
                          ... = (𝕀 G).edge_map : by refl,
    },
  },
end


import tactic

-- Local imports
import lang

/-!
# struc.lean

In this file, we define structures, substructures, embeddings, and
isomorphisms between two structures.

## Tags

model theory, structures
-/

/-! ## Structures -/

/-- We now define an L-structure to be mapping of functions, relations and
 constants to appropriate elements of a domain/universe type.-/
structure struc (L : lang) : Type 1 :=
(univ : Type)                       -- universe/domain
[univ_inhabited: inhabited univ]    -- we assume the universe is always inhabited
(F {n : ℕ+} (f : L.F n) : Func univ n)        -- interpretation of each function
(R {n : ℕ+} (r : L.R n) : set (vector univ n))-- interpretation of each relation
(C : L.C → univ)                              -- interpretation of each constant

namespace struc
instance inhabited {L : lang} : inhabited (struc L) :=
  {default := {univ := unit,  -- The domain must have at least one term
               F := λ _ _, Func.mk_of_total (function.const _ unit.star),
               R := λ _ _, ∅,
               C := function.const L.C unit.star}
  }

/-- The cardinality of a structure is the cardinality of its domain.-/
def card {L : lang} (M : struc L) : cardinal := cardinal.mk M.univ

end struc

/- Define an expanded language, given a struc M.

Idea: For every element of M.univ, we will add a new constant to the
language.

In Lou's book (more general): we start instead with C ⊂ M.univ, and then add
only elements of C as constants to the language. -/
@[reducible] def struc.expanded_lang {L : lang} (M : struc L) : lang :=
  {C := M.univ ⊕ L.C, .. L}

/-- Define expanded structures. -/
def struc.expanded_struc {L: lang} (M : struc L) : struc M.expanded_lang :=
  {C := λ c, sum.cases_on c id M.C,
   .. M}

local notation f^M := M.F f -- f^M denotes the interpretation of f in M.
local notation r`̂`M : 150 := M.R r -- r̂M denotes the interpretation of r in
                              -- M. (type as a variant of \^)

/-! ## Embeddings between Structures -/

/-- An L-embedding is a map between two L-structures that is injective
on the domain and preserves the interpretation of all the symbols of L.-/
structure embedding {L : lang} (M N : struc L) : Type :=
(η : M.univ → N.univ)                        -- map of underlying domains
(η_inj : function.injective η)               -- should be one-to-one
(η_F : ∀ n (f : L.F n) (v : vector M.univ n),
     η (f^M ⊗ v) = f^N ⊗ vector.map η v)    -- preserves action of each function
(η_R : ∀ n (r : L.R n) (v : vector M.univ n),
     v ∈ (r̂M) ↔ (vector.map η v) ∈ (r̂N))   -- preserves each relation
(η_C : ∀ c, η (M.C c) = N.C c)               -- preserves constants

namespace embedding
/-- We argue that every structure has an embedding, namely, the embedding
to itself via the identity map.-/
instance inhabited {L : lang} {M : struc L} : inhabited (embedding M M) :=
  {default := {η := id,
               η_inj := function.injective_id,
               η_F := by simp,
               η_R := by simp,
               η_C := λ _, rfl}}

/-- If η: M → N is an embedding, then the cardinality of N is at least the
  cardinality of M.-/
lemma le_card {L : lang} (M N : struc L) (η : embedding M N) :
  M.card ≤ N.card := cardinal.mk_le_of_injective η.η_inj

end embedding

/-- A bijective embedding between two `L`-structures is called an isomorphism.-/
structure isomorphism {L: lang} (M N : struc L) extends (embedding M N) : Type :=
(η_bij : function.bijective η)

/-- We argue that every structure has an isomorphism to itself via the identity
  map.-/
instance isomorphism.inhabited {L : lang} {M : struc L} : inhabited (isomorphism M M) :=
  {default := {η_bij := function.bijective_id,
               .. default (embedding M M)}}

/-- If `M ⊆ N` and the inclusion map is an `L`-embedding, we say either
  that `M` is a substructure of `N` or that `N` is an extension of `M`.

Note: the other conditions for `η` being an `L`-embedding follow from the
definition of `coe`.
-/
structure substruc {L : lang} (N : struc L) : Type :=
(univ : set N.univ)                        -- a subset of N.univ
[univ_inhabited : inhabited univ]          -- the subset should have a default
(univ_invar_F :  ∀ (n : ℕ+) (f : L.F n) (v : vector univ n),
                 f^N ⊗ (v.map coe) ∈ univ)  -- univ is invariant over f
(univ_invar_C : ∀ (c : L.C), N.C c ∈ univ) -- univ contains all constants

variables (L : lang) (M : struc L) (S₁ S₂ : substruc M)

namespace substruc
/- We can show that the intersection of 2 substructures is
a substructure. -/
def intersection {L : lang} {M : struc L}
 (S₁ S₂ : substruc M) [inhabited ↥(S₁.univ ∩ S₂.univ)] : substruc M :=
 {univ := S₁.univ ∩ S₂.univ,
  univ_invar_F := λ n f v', by {norm_num, split,
                                have v : vector S₁.univ n,
                                fconstructor,
                                have v'' := v'.val,
                                have x := S₁.univ_invar_F n f,
                                unfold_coes,
                                repeat {sorry}},
  univ_invar_C := λ c, ⟨S₁.univ_invar_C c, S₂.univ_invar_C c⟩}

/-- A substructure is finite if it has only finitely many domain elements.-/
class fin_substruc {L : lang} {N : struc L} (S : substruc N) :=
(finite : set.finite S.univ)

/-- Every substruc is a struc.-/
instance has_coe {L: lang} {M : struc L} :
  has_coe (substruc M) (struc L)
:= {coe := λ S, {univ := S.univ,
                 F := λ n f, (f^M).map (S.univ_invar_F n f),
                 R := λ _ r v, v.map coe ∈ (r̂M),
                 C := λ c, ⟨M.C c, S.univ_invar_C c⟩,
                 univ_inhabited := S.univ_inhabited}}

/- For a given structure N on a language L, an inhabited substructure can
   be generated from any subset of N.univ via substruc.closure -/
instance inhabited {L : lang} {N : struc L} {α : set N.univ} :
  inhabited (substruc N) :=
 {default := {univ := set.univ,
              univ_invar_F := by simp,
              univ_invar_C := by simp,
              univ_inhabited := ⟨⟨@default N.univ N.univ_inhabited, by simp⟩⟩}}
end substruc


import .term  tactic.basic .list .arity .tactic .logic .nat

open tactic

variables {α β : Type}

@[derive has_reflect]
inductive form : Type
| false : form
| true : form
| prd : nat → list term → form
| not : form → form
| or  : form → form → form
| and : form → form → form
| fa  : form → form
| ex  : form → form

notation  `⊤*` := form.true
notation  `⊥*` := form.false
notation  p `**` ts := form.prd p ts
notation  `¬*` := form.not
notation  p `∧*` q := form.and p q
notation  p `∨*` q := form.or p q
notation  `∀*` := form.fa
notation  `∃*` := form.ex

-- | ⊤*        := sorry
-- | ⊥*        := sorry
-- | (k ** ts) := sorry
-- | (¬* p)    := sorry
-- | (p ∧* q)  := sorry
-- | (p ∨* q)  := sorry
-- | (∀* p)  := sorry
-- | (∃* p)  := sorry

namespace form

meta def to_string : form → string
| ⊥* := "⊥"
| ⊤* := "⊤"
| (k ** ts) := "(" ++ (to_fmt k).to_string ++ (ts.map term.to_string).to_string ++ ")"
| (¬* φ)    := "¬" ++ φ.to_string
| (φ ∨* ψ) := "(" ++ (φ.to_string) ++ " ∨ " ++ (ψ.to_string) ++ ")"
| (φ ∧* ψ) := "(" ++ (φ.to_string) ++ " ∧ " ++ (ψ.to_string) ++ ")"
| (∀* φ) := "∀" ++ φ.to_string
| (∃* φ) := "∃" ++ φ.to_string

meta instance has_to_string : has_to_string form := ⟨form.to_string⟩
meta instance has_repr : has_to_string form := ⟨form.to_string⟩
meta instance has_to_format : has_to_format form := ⟨λ f, to_string f⟩

meta def induce (t : tactic unit := skip) : tactic unit :=
`[ intro p, induction p with k ts p ih p q ihp ihq p q ihp ihq p ih p ih; t ]

meta def induce_iff (t : tactic unit := skip) : tactic unit :=
induce t >>
focus [ skip, skip, skip,
  `[ apply not_iff_not_of_iff ],
  `[ apply or_iff_or   ],
  `[ apply and_iff_and ],
  `[ apply forall_iff_forall, intro ],
  `[ apply exists_iff_exists, intro ] ]

@[fol] def max_idx_lt : nat → form → Prop
| k ⊥*        := _root_.true
| k ⊤*        := _root_.true
| k (m ** ts) := ∀ t ∈ ts, term.max_idx_lt k t
| k (¬* p)    := p.max_idx_lt k
| k (p ∨* q)  := p.max_idx_lt k ∧ q.max_idx_lt k
| k (p ∧* q)  := p.max_idx_lt k ∧ q.max_idx_lt k
| k (∀* p)    := p.max_idx_lt (k+1)
| k (∃* p)    := p.max_idx_lt (k+1)

@[fol] def closed (p : form) : Prop := p.max_idx_lt 0

instance dec_max_idx_lt : ∀ p : form, ∀ k, decidable (p.max_idx_lt k) :=
begin
  induce `[intro k, try {simp_fol}, try {apply_instance},
    try {apply @and.decidable _ _ _ _}, try {apply ih},
    try {apply ihp}, try {apply ihq}],
end

instance dec_closed (p : form) : decidable (closed p) := p.dec_max_idx_lt 0

@[fol] def holds (M : model α) : (nat → α) → form → Prop
| v ⊤*        := _root_.true
| v ⊥*        := _root_.false
| v (k ** ts) :=
      M.rels k (ts.map (term.val M v))
| v (¬* p)   := ¬(p.holds v)
| v (p ∨* q) := (p.holds v) ∨ (q.holds v)
| v (p ∧* q) := (p.holds v) ∧ (q.holds v)
| v (∀* p)   := ∀ a : α, p.holds (a::v)
| v (∃* p)   := ∃ a : α, p.holds (a::v)

notation M `;` v `⊨` p := holds M v p

def equiv (α p q) : Prop :=
∀ M : model α, ∀ v, ((M ; v ⊨ p) ↔ (M ; v ⊨ q))

def valid (α p) : Prop :=
∀ M : model α, ∀ v, (M ; v ⊨ p)

def sat (α p) : Prop :=
∃ M : model α, ∀ v, (M ; v ⊨ p)

def unsat (α p) : Prop := ¬ sat α p

def rvalid [inhabited α] :
  list (bool × nat) → model α → form → Prop
| []            M p := M ; (λ _, @inhabited.default _ _) ⊨ p
| ((tt,k)::ars) M p := ∀ r : arity α Prop k, p.rvalid ars (r.app_list :r: M)
| ((ff,k)::ars) M p := ∀ f : arity α α k,    p.rvalid ars (f.app_list :f: M)

lemma rvalid_of_valid [inhabited α] {p} (h : valid α p) :
  ∀ {ars : list (bool × nat)} {M : model α}, rvalid ars M p
| [] M := by apply h
| ((b,k)::as) σ :=
  begin
    cases b; simp [rvalid];
    intro r; apply rvalid_of_valid
  end

lemma holds_iff_holds_of_max_idx_lt :
  ∀ (p : form) (M : model α) (v w : nat → α) k, p.max_idx_lt k →
  (∀ m < k, v m = w m) → ((M ; v ⊨ p) ↔ (M ; w ⊨ p)) :=
begin
  induce_iff `[intros M v w m h1 h2, split_ands], trivial, trivial,
  { simp_fol, apply iff_of_eq (congr_arg _ _),
    apply list.map_eq_map_of_forall_mem_eq,
    intros t h4, apply term.val_eq_val_of_max_idx_lt,
    apply h1 _ h4, apply h2 },
  { apply ih; assumption },
  { apply ihp; assumption },
  { apply ihq; assumption },
  { apply ihp; assumption },
  { apply ihq; assumption },
  { apply ih, apply h1, intro n, cases n with n; intro h3,
    refl, apply h2, rw ← nat.succ_lt_succ_iff, assumption },
  { apply ih, apply h1, intro n, cases n with n; intro h3,
    refl, apply h2, rw ← nat.succ_lt_succ_iff, assumption }
end

lemma holds_iff_holds_of_closed :
  ∀ (M : model α) v w p, closed p →
  ((M ; v ⊨ p) ↔ (M ; w ⊨ p)) :=
begin
  intros M v w p h1,
  apply holds_iff_holds_of_max_idx_lt,
  apply h1, intros m h2, cases h2
end

lemma valid_of_closed_of_unsat_neg [inhabited α] :
  ∀ {p : form}, closed p → unsat α (¬* p) → valid α p :=
begin
  simp only [valid, unsat, sat], intros p h1 h2 M v,
  apply classical.by_contradiction, intro h3,
  apply h2, refine ⟨M, _⟩, intro w,
  rw holds_iff_holds_of_closed _ _ w _ h1 at h3, assumption,
end

def fv_core : nat → form → list nat
| k ⊤*        := []
| k ⊥*        := []
| k (m ** ts) := ⋃ (ts.map (term.fv k))
| k (¬* p)    := fv_core k p
| k (p ∧* q)  := list.union (fv_core k p) (fv_core k q)
| k (p ∨* q)  := list.union (fv_core k p) (fv_core k q)
| k (∀* p)    := fv_core (k+1) p
| k (∃* p)    := fv_core (k+1) p

def fv (p) := fv_core 0 p

def fresh_func_idx : form → nat
| ⊤*        := 0
| ⊥*        := 0
| (m ** ts) := list.max (ts.map (term.fresh_func_idx))
| (¬* p)    := fresh_func_idx p
| (p ∧* q)  := max (fresh_func_idx p) (fresh_func_idx q)
| (p ∨* q)  := max (fresh_func_idx p) (fresh_func_idx q)
| (∀* p)    := fresh_func_idx p
| (∃* p)    := fresh_func_idx p

def subst : nat → term → form → form
| k s ⊤*        := ⊤*
| k s ⊥*        := ⊥*
| k s (m ** ts) := m ** (ts.map (term.subst k s))
| k s (¬* p)    := ¬*(subst k s p)
| k s (p ∨* q)  := (subst k s p) ∨* (subst k s q)
| k s (p ∧* q)  := (subst k s p) ∧* (subst k s q)
| k s (∀* p)    := ∀* (subst (k+1) s.incr_vdx p)
| k s (∃* p)    := ∃* (subst (k+1) s.incr_vdx p)

end form


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/

import analysis.special_functions.pow
import analysis.special_functions.trigonometric.arctan
import analysis.inner_product_space.basic
import measure_theory.constructions.borel_space

/-!
# Measurability of real and complex functions

We show that most standard real and complex functions are measurable, notably `exp`, `cos`, `sin`,
`cosh`, `sinh`, `log`, `pow`, `arcsin`, `arccos`, `arctan`, and scalar products.
-/

noncomputable theory
open_locale nnreal ennreal

namespace real

@[measurability] lemma measurable_exp : measurable exp := continuous_exp.measurable

@[measurability] lemma measurable_log : measurable log :=
measurable_of_measurable_on_compl_singleton 0 $ continuous.measurable $
  continuous_on_iff_continuous_restrict.1 continuous_on_log

@[measurability] lemma measurable_sin : measurable sin := continuous_sin.measurable

@[measurability] lemma measurable_cos : measurable cos := continuous_cos.measurable

@[measurability] lemma measurable_sinh : measurable sinh := continuous_sinh.measurable

@[measurability] lemma measurable_cosh : measurable cosh := continuous_cosh.measurable

@[measurability] lemma measurable_arcsin : measurable arcsin := continuous_arcsin.measurable

@[measurability] lemma measurable_arccos : measurable arccos := continuous_arccos.measurable

@[measurability] lemma measurable_arctan : measurable arctan := continuous_arctan.measurable

end real

namespace complex

@[measurability] lemma measurable_re : measurable re := continuous_re.measurable

@[measurability] lemma measurable_im : measurable im := continuous_im.measurable

@[measurability] lemma measurable_of_real : measurable (coe : ℝ → ℂ) :=
continuous_of_real.measurable

@[measurability] lemma measurable_exp : measurable exp := continuous_exp.measurable

@[measurability] lemma measurable_sin : measurable sin := continuous_sin.measurable

@[measurability] lemma measurable_cos : measurable cos := continuous_cos.measurable

@[measurability] lemma measurable_sinh : measurable sinh := continuous_sinh.measurable

@[measurability] lemma measurable_cosh : measurable cosh := continuous_cosh.measurable

@[measurability] lemma measurable_arg : measurable arg :=
have A : measurable (λ x : ℂ, real.arcsin (x.im / x.abs)),
  from real.measurable_arcsin.comp (measurable_im.div measurable_norm),
have B : measurable (λ x : ℂ, real.arcsin ((-x).im / x.abs)),
  from real.measurable_arcsin.comp ((measurable_im.comp measurable_neg).div measurable_norm),
measurable.ite (is_closed_le continuous_const continuous_re).measurable_set A $
  measurable.ite (is_closed_le continuous_const continuous_im).measurable_set
    (B.add_const _) (B.sub_const _)

@[measurability] lemma measurable_log : measurable log :=
(measurable_of_real.comp $ real.measurable_log.comp measurable_norm).add $
  (measurable_of_real.comp measurable_arg).mul_const I

end complex

namespace is_R_or_C

variables {𝕜 : Type*} [is_R_or_C 𝕜]

@[measurability] lemma measurable_re : measurable (re : 𝕜 → ℝ) := continuous_re.measurable

@[measurability] lemma measurable_im : measurable (im : 𝕜 → ℝ) := continuous_im.measurable

end is_R_or_C

section real_composition
open real
variables {α : Type*} [measurable_space α] {f : α → ℝ} (hf : measurable f)

@[measurability] lemma measurable.exp : measurable (λ x, real.exp (f x)) :=
real.measurable_exp.comp hf

@[measurability] lemma measurable.log : measurable (λ x, log (f x)) :=
measurable_log.comp hf

@[measurability] lemma measurable.cos : measurable (λ x, real.cos (f x)) :=
real.measurable_cos.comp hf

@[measurability] lemma measurable.sin : measurable (λ x, real.sin (f x)) :=
real.measurable_sin.comp hf

@[measurability] lemma measurable.cosh : measurable (λ x, real.cosh (f x)) :=
real.measurable_cosh.comp hf

@[measurability] lemma measurable.sinh : measurable (λ x, real.sinh (f x)) :=
real.measurable_sinh.comp hf

@[measurability] lemma measurable.arctan : measurable (λ x, arctan (f x)) :=
measurable_arctan.comp hf

@[measurability] lemma measurable.sqrt : measurable (λ x, sqrt (f x)) :=
continuous_sqrt.measurable.comp hf

end real_composition

section complex_composition
open complex
variables {α : Type*} [measurable_space α] {f : α → ℂ} (hf : measurable f)

@[measurability] lemma measurable.cexp : measurable (λ x, complex.exp (f x)) :=
complex.measurable_exp.comp hf

@[measurability] lemma measurable.ccos : measurable (λ x, complex.cos (f x)) :=
complex.measurable_cos.comp hf

@[measurability] lemma measurable.csin : measurable (λ x, complex.sin (f x)) :=
complex.measurable_sin.comp hf

@[measurability] lemma measurable.ccosh : measurable (λ x, complex.cosh (f x)) :=
complex.measurable_cosh.comp hf

@[measurability] lemma measurable.csinh : measurable (λ x, complex.sinh (f x)) :=
complex.measurable_sinh.comp hf

@[measurability] lemma measurable.carg : measurable (λ x, arg (f x)) :=
measurable_arg.comp hf

@[measurability] lemma measurable.clog : measurable (λ x, log (f x)) :=
measurable_log.comp hf

end complex_composition

section is_R_or_C_composition

variables {α 𝕜 : Type*} [is_R_or_C 𝕜] [measurable_space α]
  {f : α → 𝕜} {μ : measure_theory.measure α}

@[measurability] lemma measurable.re (hf : measurable f) : measurable (λ x, is_R_or_C.re (f x)) :=
is_R_or_C.measurable_re.comp hf

@[measurability] lemma ae_measurable.re (hf : ae_measurable f μ) :
  ae_measurable (λ x, is_R_or_C.re (f x)) μ :=
is_R_or_C.measurable_re.comp_ae_measurable hf

@[measurability] lemma measurable.im (hf : measurable f) : measurable (λ x, is_R_or_C.im (f x)) :=
is_R_or_C.measurable_im.comp hf

@[measurability] lemma ae_measurable.im (hf : ae_measurable f μ) :
  ae_measurable (λ x, is_R_or_C.im (f x)) μ :=
is_R_or_C.measurable_im.comp_ae_measurable hf

end is_R_or_C_composition

section

variables {α 𝕜 : Type*} [is_R_or_C 𝕜] [measurable_space α]
  {f : α → 𝕜} {μ : measure_theory.measure α}

@[measurability] lemma is_R_or_C.measurable_of_real : measurable (coe : ℝ → 𝕜) :=
is_R_or_C.continuous_of_real.measurable

lemma measurable_of_re_im
  (hre : measurable (λ x, is_R_or_C.re (f x)))
  (him : measurable (λ x, is_R_or_C.im (f x))) : measurable f :=
begin
  convert (is_R_or_C.measurable_of_real.comp hre).add
    ((is_R_or_C.measurable_of_real.comp him).mul_const is_R_or_C.I),
  { ext1 x,
    exact (is_R_or_C.re_add_im _).symm },
  all_goals { apply_instance },
end

lemma ae_measurable_of_re_im
  (hre : ae_measurable (λ x, is_R_or_C.re (f x)) μ)
  (him : ae_measurable (λ x, is_R_or_C.im (f x)) μ) : ae_measurable f μ :=
begin
  convert (is_R_or_C.measurable_of_real.comp_ae_measurable hre).add
    ((is_R_or_C.measurable_of_real.comp_ae_measurable him).mul_const is_R_or_C.I),
  { ext1 x,
    exact (is_R_or_C.re_add_im _).symm },
  all_goals { apply_instance },
end

end

section pow_instances

instance complex.has_measurable_pow : has_measurable_pow ℂ ℂ :=
⟨measurable.ite (measurable_fst (measurable_set_singleton 0))
  (measurable.ite (measurable_snd (measurable_set_singleton 0)) measurable_one measurable_zero)
  (measurable_fst.clog.mul measurable_snd).cexp⟩

instance real.has_measurable_pow : has_measurable_pow ℝ ℝ :=
⟨complex.measurable_re.comp $ ((complex.measurable_of_real.comp measurable_fst).pow
  (complex.measurable_of_real.comp measurable_snd))⟩

instance nnreal.has_measurable_pow : has_measurable_pow ℝ≥0 ℝ :=
⟨(measurable_fst.coe_nnreal_real.pow measurable_snd).subtype_mk⟩

instance ennreal.has_measurable_pow : has_measurable_pow ℝ≥0∞ ℝ :=
begin
  refine ⟨ennreal.measurable_of_measurable_nnreal_prod _ _⟩,
  { simp_rw ennreal.coe_rpow_def,
    refine measurable.ite _ measurable_const
      (measurable_fst.pow measurable_snd).coe_nnreal_ennreal,
    exact measurable_set.inter (measurable_fst (measurable_set_singleton 0))
      (measurable_snd measurable_set_Iio), },
  { simp_rw ennreal.top_rpow_def,
    refine measurable.ite measurable_set_Ioi measurable_const _,
    exact measurable.ite (measurable_set_singleton 0) measurable_const measurable_const, },
end

end pow_instances

section
variables {α : Type*} {𝕜 : Type*} {E : Type*} [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

@[measurability]
lemma measurable.inner [measurable_space α] [measurable_space E] [opens_measurable_space E]
  [topological_space.second_countable_topology E]
  {f g : α → E} (hf : measurable f) (hg : measurable g) :
  measurable (λ t, ⟪f t, g t⟫) :=
continuous.measurable2 continuous_inner hf hg

@[measurability]
lemma ae_measurable.inner [measurable_space α] [measurable_space E] [opens_measurable_space E]
  [topological_space.second_countable_topology E]
  {μ : measure_theory.measure α} {f g : α → E} (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ x, ⟪f x, g x⟫) μ :=
begin
  refine ⟨λ x, ⟪hf.mk f x, hg.mk g x⟫, hf.measurable_mk.inner hg.measurable_mk, _⟩,
  refine hf.ae_eq_mk.mp (hg.ae_eq_mk.mono (λ x hxg hxf, _)),
  dsimp only,
  congr,
  { exact hxf, },
  { exact hxg, },
end

end


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.equivalence

/-!
# Opposite categories

We provide a category instance on `Cᵒᵖ`.
The morphisms `X ⟶ Y` are defined to be the morphisms `unop Y ⟶ unop X` in `C`.

Here `Cᵒᵖ` is an irreducible typeclass synonym for `C`
(it is the same one used in the algebra library).

We also provide various mechanisms for constructing opposite morphisms, functors,
and natural transformations.

Unfortunately, because we do not have a definitional equality `op (op X) = X`,
there are quite a few variations that are needed in practice.
-/

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

open opposite

variables {C : Type u₁}

section quiver

variables [quiver.{v₁} C]

lemma quiver.hom.op_inj {X Y : C} :
  function.injective (quiver.hom.op : (X ⟶ Y) → (op Y ⟶ op X)) :=
λ _ _ H, congr_arg quiver.hom.unop H

lemma quiver.hom.unop_inj {X Y : Cᵒᵖ} :
  function.injective (quiver.hom.unop : (X ⟶ Y) → (unop Y ⟶ unop X)) :=
λ _ _ H, congr_arg quiver.hom.op H

@[simp] lemma quiver.hom.unop_op {X Y : C} (f : X ⟶ Y) : f.op.unop = f := rfl
@[simp] lemma quiver.hom.op_unop {X Y : Cᵒᵖ} (f : X ⟶ Y) : f.unop.op = f := rfl

end quiver

namespace category_theory

variables [category.{v₁} C]

/--
The opposite category.

See <https://stacks.math.columbia.edu/tag/001M>.
-/
instance category.opposite : category.{v₁} Cᵒᵖ :=
{ comp := λ _ _ _ f g, (g.unop ≫ f.unop).op,
  id   := λ X, (𝟙 (unop X)).op }

@[simp] lemma op_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).op = g.op ≫ f.op := rfl
@[simp] lemma op_id {X : C} : (𝟙 X).op = 𝟙 (op X) := rfl

@[simp] lemma unop_comp {X Y Z : Cᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unop = g.unop ≫ f.unop := rfl
@[simp] lemma unop_id {X : Cᵒᵖ} : (𝟙 X).unop = 𝟙 (unop X) := rfl

@[simp] lemma unop_id_op {X : C} : (𝟙 (op X)).unop = 𝟙 X := rfl
@[simp] lemma op_id_unop {X : Cᵒᵖ} : (𝟙 (unop X)).op = 𝟙 X := rfl

section
variables (C)

/-- The functor from the double-opposite of a category to the underlying category. -/
@[simps]
def op_op : (Cᵒᵖ)ᵒᵖ ⥤ C :=
{ obj := λ X, unop (unop X),
  map := λ X Y f, f.unop.unop }

/-- The functor from a category to its double-opposite.  -/
@[simps]
def unop_unop : C ⥤ Cᵒᵖᵒᵖ :=
{ obj := λ X, op (op X),
  map := λ X Y f, f.op.op }

/-- The double opposite category is equivalent to the original. -/
@[simps]
def op_op_equivalence : Cᵒᵖᵒᵖ ≌ C :=
{ functor := op_op C,
  inverse := unop_unop C,
  unit_iso := iso.refl (𝟭 Cᵒᵖᵒᵖ),
  counit_iso := iso.refl (unop_unop C ⋙ op_op C) }

end

/-- If `f` is an isomorphism, so is `f.op` -/
instance is_iso_op {X Y : C} (f : X ⟶ Y) [is_iso f] : is_iso f.op :=
⟨⟨(inv f).op,
  ⟨quiver.hom.unop_inj (by tidy), quiver.hom.unop_inj (by tidy)⟩⟩⟩

/--
If `f.op` is an isomorphism `f` must be too.
(This cannot be an instance as it would immediately loop!)
-/
lemma is_iso_of_op {X Y : C} (f : X ⟶ Y) [is_iso f.op] : is_iso f :=
⟨⟨(inv (f.op)).unop,
  ⟨quiver.hom.op_inj (by simp), quiver.hom.op_inj (by simp)⟩⟩⟩

lemma is_iso_op_iff {X Y : C} (f : X ⟶ Y) : is_iso f.op ↔ is_iso f :=
⟨λ hf, by exactI is_iso_of_op _, λ hf, by exactI infer_instance⟩

lemma is_iso_unop_iff {X Y : Cᵒᵖ} (f : X ⟶ Y) : is_iso f.unop ↔ is_iso f :=
by rw [← is_iso_op_iff f.unop, quiver.hom.op_unop]

instance is_iso_unop {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso f] : is_iso f.unop :=
(is_iso_unop_iff _).2 infer_instance

@[simp] lemma op_inv {X Y : C} (f : X ⟶ Y) [is_iso f] : (inv f).op = inv f.op :=
by { ext, rw [← op_comp, is_iso.inv_hom_id, op_id] }

@[simp] lemma unop_inv {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso f] : (inv f).unop = inv f.unop :=
by { ext, rw [← unop_comp, is_iso.inv_hom_id, unop_id] }

namespace functor

section

variables {D : Type u₂} [category.{v₂} D]

variables {C D}

/--
The opposite of a functor, i.e. considering a functor `F : C ⥤ D` as a functor `Cᵒᵖ ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made between these.
-/
@[simps]
protected def op (F : C ⥤ D) : Cᵒᵖ ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).op }

/--
Given a functor `F : Cᵒᵖ ⥤ Dᵒᵖ` we can take the "unopposite" functor `F : C ⥤ D`.
In informal mathematics no distinction is made between these.
-/
@[simps]
protected def unop (F : Cᵒᵖ ⥤ Dᵒᵖ) : C ⥤ D :=
{ obj := λ X, unop (F.obj (op X)),
  map := λ X Y f, (F.map f.op).unop }

/-- The isomorphism between `F.op.unop` and `F`. -/
@[simps] def op_unop_iso (F : C ⥤ D) : F.op.unop ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

/-- The isomorphism between `F.unop.op` and `F`. -/
@[simps] def unop_op_iso (F : Cᵒᵖ ⥤ Dᵒᵖ) : F.unop.op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

variables (C D)

/--
Taking the opposite of a functor is functorial.
-/
@[simps]
def op_hom : (C ⥤ D)ᵒᵖ ⥤ (Cᵒᵖ ⥤ Dᵒᵖ) :=
{ obj := λ F, (unop F).op,
  map := λ F G α,
  { app := λ X, (α.unop.app (unop X)).op,
    naturality' := λ X Y f, quiver.hom.unop_inj (α.unop.naturality f.unop).symm } }

/--
Take the "unopposite" of a functor is functorial.
-/
@[simps]
def op_inv : (Cᵒᵖ ⥤ Dᵒᵖ) ⥤ (C ⥤ D)ᵒᵖ :=
{ obj := λ F, op F.unop,
  map := λ F G α, quiver.hom.op
  { app := λ X, (α.app (op X)).unop,
    naturality' := λ X Y f, quiver.hom.op_inj $ (α.naturality f.op).symm } }

variables {C D}

/--
Another variant of the opposite of functor, turning a functor `C ⥤ Dᵒᵖ` into a functor `Cᵒᵖ ⥤ D`.
In informal mathematics no distinction is made.
-/
@[simps]
protected def left_op (F : C ⥤ Dᵒᵖ) : Cᵒᵖ ⥤ D :=
{ obj := λ X, unop (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).unop }

/--
Another variant of the opposite of functor, turning a functor `Cᵒᵖ ⥤ D` into a functor `C ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made.
-/
@[simps]
protected def right_op (F : Cᵒᵖ ⥤ D) : C ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (op X)),
  map := λ X Y f, (F.map f.op).op }

instance {F : C ⥤ D} [full F] : full F.op :=
{ preimage := λ X Y f, (F.preimage f.unop).op }

instance {F : C ⥤ D} [faithful F] : faithful F.op :=
{ map_injective' := λ X Y f g h,
    quiver.hom.unop_inj $ by simpa using map_injective F (quiver.hom.op_inj h) }

/-- If F is faithful then the right_op of F is also faithful. -/
instance right_op_faithful {F : Cᵒᵖ ⥤ D} [faithful F] : faithful F.right_op :=
{ map_injective' := λ X Y f g h, quiver.hom.op_inj (map_injective F (quiver.hom.op_inj h)) }

/-- If F is faithful then the left_op of F is also faithful. -/
instance left_op_faithful {F : C ⥤ Dᵒᵖ} [faithful F] : faithful F.left_op :=
{ map_injective' := λ X Y f g h, quiver.hom.unop_inj (map_injective F (quiver.hom.unop_inj h)) }

/-- The isomorphism between `F.left_op.right_op` and `F`. -/
@[simps]
def left_op_right_op_iso (F : C ⥤ Dᵒᵖ) : F.left_op.right_op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

/-- The isomorphism between `F.right_op.left_op` and `F`. -/
@[simps]
def right_op_left_op_iso (F : Cᵒᵖ ⥤ D) : F.right_op.left_op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

end

end functor

namespace nat_trans

variables {D : Type u₂} [category.{v₂} D]

section
variables {F G : C ⥤ D}

/-- The opposite of a natural transformation. -/
@[simps] protected def op (α : F ⟶ G) : G.op ⟶ F.op :=
{ app         := λ X, (α.app (unop X)).op,
  naturality' := λ X Y f, quiver.hom.unop_inj (by simp) }

@[simp] lemma op_id (F : C ⥤ D) : nat_trans.op (𝟙 F) = 𝟙 (F.op) := rfl

/-- The "unopposite" of a natural transformation. -/
@[simps] protected def unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ⟶ G) : G.unop ⟶ F.unop :=
{ app         := λ X, (α.app (op X)).unop,
  naturality' := λ X Y f, quiver.hom.op_inj (by simp) }

@[simp] lemma unop_id (F : Cᵒᵖ ⥤ Dᵒᵖ) : nat_trans.unop (𝟙 F) = 𝟙 (F.unop) := rfl

/--
Given a natural transformation `α : F.op ⟶ G.op`,
we can take the "unopposite" of each component obtaining a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_op (α : F.op ⟶ G.op) : G ⟶ F :=
{ app         := λ X, (α.app (op X)).unop,
  naturality' := λ X Y f, quiver.hom.op_inj $
    by simpa only [functor.op_map] using (α.naturality f.op).symm }

@[simp] lemma remove_op_id (F : C ⥤ D) : nat_trans.remove_op (𝟙 F.op) = 𝟙 F := rfl

/-- Given a natural transformation `α : F.unop ⟶ G.unop`, we can take the opposite of each
component obtaining a natural transformation `G ⟶ F`. -/
@[simps] protected def remove_unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F.unop ⟶ G.unop) : G ⟶ F :=
{ app := λ X, (α.app (unop X)).op,
  naturality' := λ X Y f, quiver.hom.unop_inj $
    by simpa only [functor.unop_map] using (α.naturality f.unop).symm }

@[simp] lemma remove_unop_id (F : Cᵒᵖ ⥤ Dᵒᵖ) : nat_trans.remove_unop (𝟙 F.unop) = 𝟙 F := rfl

end

section
variables {F G H : C ⥤ Dᵒᵖ}

/--
Given a natural transformation `α : F ⟶ G`, for `F G : C ⥤ Dᵒᵖ`,
taking `unop` of each component gives a natural transformation `G.left_op ⟶ F.left_op`.
-/
@[simps] protected def left_op (α : F ⟶ G) : G.left_op ⟶ F.left_op :=
{ app         := λ X, (α.app (unop X)).unop,
  naturality' := λ X Y f, quiver.hom.op_inj (by simp) }

@[simp] lemma left_op_id : (𝟙 F : F ⟶ F).left_op = 𝟙 F.left_op := rfl

@[simp] lemma left_op_comp (α : F ⟶ G) (β : G ⟶ H) :
  (α ≫ β).left_op = β.left_op ≫ α.left_op := rfl

/--
Given a natural transformation `α : F.left_op ⟶ G.left_op`, for `F G : C ⥤ Dᵒᵖ`,
taking `op` of each component gives a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_left_op (α : F.left_op ⟶ G.left_op) : G ⟶ F :=
{ app         := λ X, (α.app (op X)).op,
  naturality' := λ X Y f, quiver.hom.unop_inj $
    by simpa only [functor.left_op_map] using (α.naturality f.op).symm }

@[simp] lemma remove_left_op_id : nat_trans.remove_left_op (𝟙 F.left_op) = 𝟙 F := rfl

end

section
variables {F G H : Cᵒᵖ ⥤ D}

/--
Given a natural transformation `α : F ⟶ G`, for `F G : Cᵒᵖ ⥤ D`,
taking `op` of each component gives a natural transformation `G.right_op ⟶ F.right_op`.
-/
@[simps] protected def right_op (α : F ⟶ G) : G.right_op ⟶ F.right_op :=
{ app := λ X, (α.app _).op,
  naturality' := λ X Y f, quiver.hom.unop_inj (by simp) }

@[simp] lemma right_op_id : (𝟙 F : F ⟶ F).right_op = 𝟙 F.right_op := rfl

@[simp] lemma right_op_comp (α : F ⟶ G) (β : G ⟶ H) :
  (α ≫ β).right_op = β.right_op ≫ α.right_op := rfl

/--
Given a natural transformation `α : F.right_op ⟶ G.right_op`, for `F G : Cᵒᵖ ⥤ D`,
taking `unop` of each component gives a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_right_op (α : F.right_op ⟶ G.right_op) : G ⟶ F :=
{ app := λ X, (α.app X.unop).unop,
  naturality' := λ X Y f, quiver.hom.op_inj $
    by simpa only [functor.right_op_map] using (α.naturality f.unop).symm }

@[simp] lemma remove_right_op_id : nat_trans.remove_right_op (𝟙 F.right_op) = 𝟙 F := rfl

end
end nat_trans

namespace iso

variables {X Y : C}

/--
The opposite isomorphism.
-/
@[simps]
protected def op (α : X ≅ Y) : op Y ≅ op X :=
{ hom := α.hom.op,
  inv := α.inv.op,
  hom_inv_id' := quiver.hom.unop_inj α.inv_hom_id,
  inv_hom_id' := quiver.hom.unop_inj α.hom_inv_id }

/-- The isomorphism obtained from an isomorphism in the opposite category. -/
@[simps] def unop {X Y : Cᵒᵖ} (f : X ≅ Y) : Y.unop ≅ X.unop :=
{ hom := f.hom.unop,
  inv := f.inv.unop,
  hom_inv_id' := by simp only [← unop_comp, f.inv_hom_id, unop_id],
  inv_hom_id' := by simp only [← unop_comp, f.hom_inv_id, unop_id] }

@[simp] lemma unop_op {X Y : Cᵒᵖ} (f : X ≅ Y) : f.unop.op = f :=
by ext; refl

@[simp] lemma op_unop {X Y : C} (f : X ≅ Y) : f.op.unop = f :=
by ext; refl

end iso

namespace nat_iso

variables {D : Type u₂} [category.{v₂} D]
variables {F G : C ⥤ D}

/-- The natural isomorphism between opposite functors `G.op ≅ F.op` induced by a natural
isomorphism between the original functors `F ≅ G`. -/
@[simps] protected def op (α : F ≅ G) : G.op ≅ F.op :=
{ hom := nat_trans.op α.hom,
  inv := nat_trans.op α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←op_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←op_comp, rw α.hom_inv_id_app, refl, end }

/-- The natural isomorphism between functors `G ≅ F` induced by a natural isomorphism
between the opposite functors `F.op ≅ G.op`. -/
@[simps] protected def remove_op (α : F.op ≅ G.op) : G ≅ F :=
{ hom := nat_trans.remove_op α.hom,
  inv := nat_trans.remove_op α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←unop_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←unop_comp, rw α.hom_inv_id_app, refl, end }

/-- The natural isomorphism between functors `G.unop ≅ F.unop` induced by a natural isomorphism
between the original functors `F ≅ G`. -/
@[simps] protected def unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ≅ G) : G.unop ≅ F.unop :=
{ hom := nat_trans.unop α.hom,
  inv := nat_trans.unop α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←unop_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←unop_comp, rw α.hom_inv_id_app, refl, end }

end nat_iso

namespace equivalence

variables {D : Type u₂} [category.{v₂} D]

/--
An equivalence between categories gives an equivalence between the opposite categories.
-/
@[simps]
def op (e : C ≌ D) : Cᵒᵖ ≌ Dᵒᵖ :=
{ functor := e.functor.op,
  inverse := e.inverse.op,
  unit_iso := (nat_iso.op e.unit_iso).symm,
  counit_iso := (nat_iso.op e.counit_iso).symm,
  functor_unit_iso_comp' := λ X, by { apply quiver.hom.unop_inj, dsimp, simp, }, }

/--
An equivalence between opposite categories gives an equivalence between the original categories.
-/
@[simps]
def unop (e : Cᵒᵖ ≌ Dᵒᵖ) : C ≌ D :=
{ functor := e.functor.unop,
  inverse := e.inverse.unop,
  unit_iso := (nat_iso.unop e.unit_iso).symm,
  counit_iso := (nat_iso.unop e.counit_iso).symm,
  functor_unit_iso_comp' := λ X, by { apply quiver.hom.op_inj, dsimp, simp, }, }

end equivalence

/-- The equivalence between arrows of the form `A ⟶ B` and `B.unop ⟶ A.unop`. Useful for building
adjunctions.
Note that this (definitionally) gives variants
```
def op_equiv' (A : C) (B : Cᵒᵖ) : (opposite.op A ⟶ B) ≃ (B.unop ⟶ A) :=
op_equiv _ _

def op_equiv'' (A : Cᵒᵖ) (B : C) : (A ⟶ opposite.op B) ≃ (B ⟶ A.unop) :=
op_equiv _ _

def op_equiv''' (A B : C) : (opposite.op A ⟶ opposite.op B) ≃ (B ⟶ A) :=
op_equiv _ _
```
-/
@[simps] def op_equiv (A B : Cᵒᵖ) : (A ⟶ B) ≃ (B.unop ⟶ A.unop) :=
{ to_fun := λ f, f.unop,
  inv_fun := λ g, g.op,
  left_inv := λ _, rfl,
  right_inv := λ _, rfl }

instance subsingleton_of_unop (A B : Cᵒᵖ) [subsingleton (unop B ⟶ unop A)] : subsingleton (A ⟶ B) :=
(op_equiv A B).subsingleton

instance decidable_eq_of_unop (A B : Cᵒᵖ) [decidable_eq (unop B ⟶ unop A)] : decidable_eq (A ⟶ B) :=
(op_equiv A B).decidable_eq

/--
The equivalence between isomorphisms of the form `A ≅ B` and `B.unop ≅ A.unop`.

Note this is definitionally the same as the other three variants:
* `(opposite.op A ≅ B) ≃ (B.unop ≅ A)`
* `(A ≅ opposite.op B) ≃ (B ≅ A.unop)`
* `(opposite.op A ≅ opposite.op B) ≃ (B ≅ A)`
-/
@[simps] def iso_op_equiv (A B : Cᵒᵖ) : (A ≅ B) ≃ (B.unop ≅ A.unop) :=
{ to_fun := λ f, f.unop,
  inv_fun := λ g, g.op,
  left_inv := λ _, by { ext, refl, },
  right_inv := λ _, by { ext, refl, } }

namespace functor

variables (C)
variables (D : Type u₂) [category.{v₂} D]

/--
The equivalence of functor categories induced by `op` and `unop`.
-/
@[simps]
def op_unop_equiv : (C ⥤ D)ᵒᵖ ≌ Cᵒᵖ ⥤ Dᵒᵖ :=
{ functor := op_hom _ _,
  inverse := op_inv _ _,
  unit_iso := nat_iso.of_components (λ F, F.unop.op_unop_iso.op) begin
    intros F G f,
    dsimp [op_unop_iso],
    rw [(show f = f.unop.op, by simp), ← op_comp, ← op_comp],
    congr' 1,
    tidy,
  end,
  counit_iso := nat_iso.of_components (λ F, F.unop_op_iso) (by tidy) }.

/--
The equivalence of functor categories induced by `left_op` and `right_op`.
-/
@[simps]
def left_op_right_op_equiv : (Cᵒᵖ ⥤ D)ᵒᵖ ≌ (C ⥤ Dᵒᵖ) :=
{ functor :=
  { obj := λ F, F.unop.right_op,
    map := λ F G η, η.unop.right_op },
  inverse :=
  { obj := λ F, op F.left_op,
    map := λ F G η, η.left_op.op },
  unit_iso := nat_iso.of_components (λ F, F.unop.right_op_left_op_iso.op) begin
    intros F G η,
    dsimp,
    rw [(show η = η.unop.op, by simp), ← op_comp, ← op_comp],
    congr' 1,
    tidy,
  end,
  counit_iso := nat_iso.of_components (λ F, F.left_op_right_op_iso) (by tidy) }

end functor

end category_theory


import Mathlib
import Init.Data.Range

lemma List.get?_succ (n : ℕ) (x : α) (xs : List α) : (x :: xs).get? (n + 1) = xs.get? n := by simp

def upto : ∀ (n : ℕ), List ℕ
  | 0 => []
  | n+1 => n :: upto n

lemma mem_upto : ∀ {n m}, m ∈ upto n ↔ m < n :=
  by
  intros n m
  induction n
  case zero =>
    rw [iff_iff_and_or_not_and_not]
    simp
    apply Or.inr (List.not_mem_nil _)
  case succ n n_ih =>
    apply Iff.intro
    case mp =>
      intro h
      cases h
      case head => apply Nat.lt_succ_self m
      case tail h =>
       apply Nat.lt_trans (_ : m < n) (Nat.lt_succ_self n)
       rw [← n_ih]
       apply h
    case mpr =>
      intro h
      cases h
      simp [upto]
      case step h =>
        simp [upto]
        apply Or.inr (n_ih.mpr h)

section SplitStream

variable (n : ℕ)

def list2 : List (ℕ × ℕ) := (upto (n+1)).map (λ x => (n, x))

lemma list2_contains (m : ℕ) : m ≤ n -> (n, m) ∈ list2 n :=
  by
  intros mh
  apply List.mem_map_of_mem
  apply mem_upto.mpr (Nat.lt_succ_of_le mh)

def split_stream_aux : {l : List (ℕ × ℕ) // l ≠ ∅} where
  val := list2 n ++ (list2 n).map (λ p => (p.2, p.1))
  property :=
    have ⟨x, xs, xh⟩ : ∃ x xs, x :: xs = list2 n := by
      simp [list2]
    by
    rw [← xh]
    simp

lemma split_stream_aux_contains : ∀ p, p ∈ (split_stream_aux (max.uncurry p)).val
  | (x, y) =>
    if h : y < x
      then by
        rw [split_stream_aux]
        apply List.mem_append_left
        simp [max, if_pos h]
        apply list2_contains
        apply le_of_lt h
      else by
        rw [split_stream_aux]
        apply List.mem_append_right; case h =>
        simp [max, if_neg h]
        clear n
        have h := le_of_not_gt h
        cases h
        case refl => apply Or.inl; rfl
        case step m hm =>
          apply Or.inr; case h =>
          rw [List.mem_map]
          exists x
          constructor
          case left =>
            have h' := le_of_not_gt h
            rw [mem_upto]
            apply Nat.lt_succ_of_le hm
          case right =>
            simp

end SplitStream

def Sequence α := ℕ → α

namespace Sequence

def tail : Sequence α → Sequence α :=
  λ s n => s (n + 1)

@[simp]
def tail_def (s : Sequence α) : s.tail n = s (n+1) := rfl

def take : ℕ → (Sequence α) → List α
  | 0 => λ _ => []
  | n + 1 => λ s => s 0 :: s.tail.take n

@[simp]
def take_zero (s : Sequence α) : s.take 0 = [] := rfl

@[simp]
def take_succ (s : Sequence α) : s.take (n + 1) = s 0 :: s.tail.take n := rfl

lemma take_length : ∀ n (s : Sequence α), (s.take n).length = n
  | 0, s => rfl
  | (n+1), s => by
    simp
    apply take_length n

@[simp]
lemma get?_take_aux : ∀ n ix (s : Sequence α), ix < n → List.get? (s.take n) ix = some (s ix)
  | 0, _, s, p => by exfalso; apply Nat.not_lt_zero _ p
  | (Nat.succ n), 0, s, _ => by simp
  | (Nat.succ (Nat.succ n)), (Nat.succ ix), s, p => by
    rw [Sequence.take_succ]
    rw [List.get?_succ]
    rw [get?_take_aux (n+1)]
    simp
    rw [Nat.add_one] at *
    apply Nat.lt_of_succ_lt_succ p

abbrev get?_take (s : Sequence α) : ∀ n ix, ix < n → List.get? (s.take n) ix = some (s ix) :=
  λ n ix => get?_take_aux n ix s

def concat_aux : ℕ → Sequence ({ l : List α // l ≠ []}) → α := by
  intros n
  apply @Nat.strong_rec_on (λ n => Sequence ({ l : List α // l ≠ []}) → α) n
  exact λ n recOn s =>
    if h : n < (s 0).val.length
    then (s 0).val.get ⟨n, h⟩
    else
      have : n - List.length (s 0).val < n := by
        have m_pos : 0 < List.length (s 0).val
        have ⟨s0, s0_prop⟩ := s 0
        simp
        apply List.length_pos_of_ne_nil s0_prop
        apply Nat.sub_lt
        apply Nat.lt_of_lt_of_le m_pos
        apply le_of_not_gt h
        exact m_pos
      recOn (n - (s 0).val.length) this s.tail

def concat : Sequence ({ l : List α // l ≠ []}) → Sequence α
  | s, n => concat_aux n s

lemma concat_mem (a : α) (n m : ℕ) (l : List α) (s : Sequence ({ l : List α // l ≠ []}))
  (a_in_l : l.get? n = some a)
  (l_in_s : (s m).val = l) :
  ∃ k, s.concat k = a := by
  revert s
  induction m
  case zero =>
    intros s l_in_s
    exists n
    simp [concat, concat_aux, Nat.strong_rec_on]
    rw [WellFounded.fix', WellFounded.fix, WellFounded.fixFEq]
    have : n < (s 0).val.length
    cases l_in_s
    exact (List.get?_eq_some.mp a_in_l).1
    rw [dif_pos this]
    rw [← l_in_s] at a_in_l
    rw [List.get?_eq_get] at a_in_l
    simp at a_in_l
    injection a_in_l with h
    rw [← h]
    simp
    exact this
  case succ m m_ih =>
    intros s l_in_s
    have : ∃ k, concat (tail s) k = a
    apply m_ih (tail s)
    rw [tail]
    apply l_in_s
    have ⟨k, kh⟩ := this
    exists (k + (s 0).val.length)
    have : k = k + (s 0).val.length - (s 0).val.length
    rw [Nat.add_sub_cancel]
    rw [this] at kh
    apply Eq.trans _ kh
    simp [concat, concat_aux, Nat.strong_rec_on, WellFounded.fix', WellFounded.fix]
    rw [WellFounded.fixFEq]
    have : ¬ k + (s 0).val.length < (s 0).val.length
    simp
    apply Nat.le_add_left
    rw [dif_neg this]

def split_stream := concat split_stream_aux

instance : Membership α (Sequence α) where
  mem a s := ∃ n, s n = a

lemma split_stream_contains : ∀ p : ℕ × ℕ, p ∈ split_stream :=
  by
  intros p
  have ⟨n, nh⟩ := List.get?_of_mem (split_stream_aux_contains p)
  apply concat_mem
  case l => exact (split_stream_aux $ Function.uncurry max p).val
  case a_in_l => exact nh
  case m => exact (Function.uncurry max p)
  case l_in_s => rfl

end Sequence

namespace List
def cycle : ∀ l : List α, l.length > 0 → Sequence α :=
  λ l p n => l.get ⟨n % l.length, Nat.mod_lt _ p⟩
end List

open Sequence

@[simp]
def Sequence.cycle_def' (l : List α) (p : l.length > 0) :
  l.cycle p n = l.get ⟨n % l.length, Nat.mod_lt _ p⟩ := rfl

@[simp]
def Sequence.cycle_def (l : List α) (p : l.length > 0) :
  l.cycle p = λ n => l.get ⟨n % l.length, Nat.mod_lt _ p⟩ := by
  funext n
  simp

def some_ext (a b : α) : some a = some b → a = b := λ p => by cases p; rfl

lemma List.length_init_aux : ∀ (n : ℕ) (l : List α), l.length = n → l.init.length = l.length - 1
  | 0, [], _ => rfl
  | 1, [x], _ => rfl
  | (n+2), x :: xs :: xss, p => by
    simp at *
    rw [← Nat.add_one, ← Nat.add_one, Nat.add_sub_cancel]
    simp
    rw [length_init_aux (n+1) (xs :: xss)]
    simp [← Nat.add_one, Nat.add_sub_cancel]
    simp
    exact p

lemma List.length_init (l : List α) : l.init.length = l.length - 1 :=
  l.length_init_aux l.length rfl

inductive Down : Type (u + 1) where
  | Zero : Down
  | Limit (elems : ℕ → Down) : Down

namespace Down
open Down

def succ (n : Down) : Down := Limit (λ _ => n)

def ofNat : Nat → Down
  | 0 => Zero
  | (n+1) => succ (ofNat n)

instance : OfNat Down n := ⟨ofNat n⟩

def mem : Down → Down → Prop
  | d, Limit f => ∃ n, d = f n
  | d, Zero => False

lemma mem_Limit : ∀ {d f}, mem d (Limit f) = ∃ n, d = f n := rfl

@[simp]
lemma mem_Zero : ∀ {d}, mem d Zero = False := rfl

def isToFrom x y (l : List α) := l.head? = some y ∧ l.last' = some x

def isChain (l : List Down) :=
    ∀ n x' y', l.get? n = some x' → l.get? (n+1) = some y' -> mem y' x'

@[simp]
lemma isChain_nil : isChain []
  | n, x', y', x'h, y'h => by simp at *

def le (x y : Down) :=
  ∃ l : List Down, isToFrom x y l ∧ isChain l

def lt x y :=
  ∃ l : List Down, isToFrom x y l ∧ isChain l ∧ l.length ≥ 2

lemma List.more_than_two  {z zs : α} {zss : List α} : (z :: zs :: zss).length ≥ 2 := by
  apply Nat.succ_le_succ
  apply Nat.succ_le_succ
  apply Nat.zero_le

def le_aux : List α → List α → List α
  | l, [] => l
  | l, x :: xs => l ++ xs

@[simp]
lemma le_aux_nil (l : List α ) : le_aux l [] = l := rfl

@[simp]
lemma le_aux_cons (x : α ) : le_aux l (x :: xs) = l ++ xs := rfl

@[simp]
lemma head_le_aux (l : List α) : l ≠ [] → (le_aux l l').head? = l.head? := by
  intros h
  cases l'
  cases l
  simp
  rw [le_aux_nil]; simp
  cases l
  exfalso; apply h; apply rfl
  simp

@[simp]
lemma last_cons : ∀ {xs : List α}, xs ≠ [] -> (x :: xs).last' = xs.last'
  | [], h => by exfalso; apply h; apply rfl
  | x :: xs, _ => by
    simp

@[simp]
lemma last_append : ∀ (l l' : List α), l' ≠ [] → (l ++ l').last' = l'.last'
  | l, [], h => (h rfl).elim
  | [], y :: yz, h => by simp
  | x :: xs, y :: ys, h => by
    simp
    apply last_append _ _ h

lemma get?_last_aux : ∀ {n} {l : List α}, n + 1 = l.length → l.get? n = l.last'
  | 0, [x], rfl => rfl
  | (n + 1), x :: xs, p => by
    simp at p
    rw [p]
    simp
    cases xs with
    | nil => rfl
    | cons xs xss =>
      rw [last_cons]
      simp
      have : xss.length = (xs::xss).length - 1 := rfl
      rw [this]
      have p' : n + 1 = (xs :: xss).length := by simp at p; rw [p]; simp
      rw [← get?_last_aux p', ← p', Nat.add_sub_cancel]
      simp

@[simp]
lemma get?_last : ∀ (l : List α), l.get? (l.length - 1) = l.last'
  | [] => rfl
  | x :: xs => by
    apply get?_last_aux
    simp
    apply Nat.add_sub_cancel _ 1

lemma not_mem_Zero : ∀ a, ¬ mem a Zero
  | a, h => by cases h

lemma not_lt_Zero_aux (x : Down) (l : List Down) : ¬ isChain ([Zero, x] ++ l)
  | h => not_mem_Zero _ (h 0 Zero x rfl rfl)

lemma le_refl : ∀ x, le x x
  | x => ⟨[x], by
    intros
    apply And.intro
    apply ⟨rfl, rfl⟩
    intros n x' y' x'h y'h
    exfalso
    simp at *
  ⟩

lemma isChain_down (x : Down) (xs : List Down) : isChain (x :: xs) → isChain xs := by
  intros h n x' y' getn getn_one
  apply h (n+1)
  rw [← getn]
  simp
  rw [← getn_one]
  simp

lemma Zero_Chains : ∀ (l : List Down), l.head? = some Zero → isChain l → l = [Zero]
  | [], l_head, l_isChain => by cases l_head
  | [x], l_head, l_isChain => by simp at *; exact l_head
  | x :: xs :: xss, l_head, l_isChain => by
    simp at *
    cases l_head
    exfalso
    apply not_mem_Zero xs
    apply l_isChain 0 Zero xs rfl rfl

lemma le_Zero : ∀ (a : Down) (h : le a Zero), a = Zero
  | a, ⟨l, ⟨l_head, l_last⟩, l_isChain⟩ =>
    have : l = [Zero] := Zero_Chains l l_head l_isChain
    by
    cases this
    cases l_last
    apply rfl

lemma le_Zero_iff (a : Down) : le a Zero ↔ a = Zero where
  mpr h := by cases h; apply le_refl
  mp h := le_Zero a h

open Sequence

lemma decending_chain_conditon : ∀ (s : Sequence Down), ¬ ∀ n, isChain (s.take n) := by
  intros s
  let h : ∃ a, s 0 = a := ⟨s 0, rfl⟩
  cases h with | intro a ah =>
  clear h
  revert s
  induction a with

  | Zero =>
    intros s ah impossible
    apply not_mem_Zero (s 1)
    have h := impossible 2
    simp at h
    rw [ah] at h
    apply h 0
    simp
    simp

  | Limit elems elems_ih =>
    intros s ah impossible
    have h : mem (s 1) (Limit elems) := by
      apply (impossible 2 0)
      simp
      exact ah
      simp
    rw [mem_Limit] at h
    cases h with | intro ix ix_h =>
    simp
    apply elems_ih ix (s.tail) ix_h
    intros n
    cases n with
    | zero => simp
    | succ n' =>
      apply isChain_down (s 0)
      have : Sequence.take (n'.succ.succ) s = (s 0 :: s.tail.take n'.succ) := rfl
      rw [← this]
      apply impossible

lemma lt_strongly_antisymm'_aux : ∀ n, n ≥ 2 → n - 1 > 0
  | Nat.succ (Nat.succ n), p => by
    rw [← Nat.add_one]
    rw [Nat.add_sub_cancel]
    apply Nat.gt_of_not_le
    apply Nat.not_lt_zero

lemma not_mem_self {a} : ¬ mem a a :=
  by
  induction a with
  | Zero => simp
  | Limit elems elems_ih =>
    intros h
    have h' := h
    rw [mem_Limit] at h
    have ⟨n, h⟩ := h
    apply elems_ih n
    rw [←h]
    apply h'

lemma List.get?_init {α} : ∀ (ix : ℕ) (l : List α) (ix_neq : ix ≠ l.init.length), l.get? ix = l.init.get? ix
  | _, [], _ => rfl
  | (n+1), [x], refl => rfl
  | 0, x::xs::xss, _ => rfl
  | (n+1), x::xs::xss, ix_neq => by
    match lt_trichotomy (n+1) (x::xs::xss).init.length with
    | Or.inr (Or.inl h) => simp; exact (ix_neq h).elim
    | (Or.inl h) => simp at *; apply get?_init; exact ix_neq
    | Or.inr (Or.inr h) => simp at *; apply get?_init; exact ix_neq

lemma List.head_init {α} : ∀ (l : List α), l.length > 1 → l.init.head? = l.head?
  | x :: y :: l, p => by simp
  | [x], p => by simp at p
  | [], p => by simp at p

lemma lt_strongly_antisymm' (a : Down) : ¬ lt a a :=
  λ h =>
    have ⟨l, ⟨l_head, l_last⟩, l_isChain, l_length⟩ := h
    have l_init_length : l.init.length > 1 :=
      match l with
      | [] => by simp at *
      | [x] => by simp at *
      | [x, y] => by
        cases l_head; cases l_last
        exfalso
        apply not_mem_self (l_isChain 0 a a rfl rfl)
      | _::_::_::_ => by
        simp at *
        apply Nat.succ_lt_succ
        rw [Nat.add_one]
        apply Nat.zero_lt_succ
    have l_init_length' : l.init.length > 0 := Nat.lt_trans Nat.zero_lt_one l_init_length
    have ⟨s, sh⟩ : ∃ s : Sequence Down, s = l.init.cycle l_init_length' := ⟨l.init.cycle l_init_length', rfl⟩
    have neq_of_lt : ∀ n m : ℕ, n < m → n ≠ m := by
      clear s sh
      intros n m h
      rw [lt_iff_le_not_le] at h
      intros h'
      cases h'
      apply h.2
      apply Nat.le_refl
    by
      apply decending_chain_conditon s
      rw [sh]
      intros n ix x' y' xh yh
      cases Nat.decLt (ix + 1) n with
      | isFalse h =>
        exfalso
        apply h; clear h
        rw [List.get?_eq_some] at *
        have h' := yh.1
        rw [take_length] at h'
        exact h'

      | isTrue ix_one_lt_n =>
        have ix_lt_n : ix < n := by apply Nat.lt_trans (Nat.lt_succ_self ix) ix_one_lt_n
        rw [get?_take _ _ _ ix_lt_n] at xh
        rw [get?_take _ _ _ ix_one_lt_n] at yh
        have x'h := some_ext _ _ xh
        have y'h := some_ext _ _ yh
        rw [← y'h, ← x'h]
        clear x' y' xh yh x'h y'h
        rw [Sequence.cycle_def' l.init l_init_length', Sequence.cycle_def' l.init l_init_length']

        apply l_isChain (ix % l.init.length)
        case a =>
          rw [← List.get?_eq_get, ← List.get?_init]
          simp
          apply neq_of_lt
          apply Nat.mod_lt
          apply l_init_length'

        rw [← List.get?_eq_get]

        rw [Nat.add_mod]
          have : 1 % l.init.length = 1 := by apply Nat.mod_eq_of_lt l_init_length
          rw [this]; clear this

        have h :
          (ix % l.init.length + 1 < l.init.length) ∨ (ix % l.init.length + 1 = l.init.length) :=
            le_iff_lt_or_eq.mp (Nat.succ_le_of_lt (Nat.mod_lt _ l_init_length'))
        cases h with
        | inl h =>
          rw [← List.get?_init ]
          apply congr_arg
          apply Eq.symm
          apply Nat.mod_eq_of_lt h
          apply neq_of_lt
          apply Nat.mod_lt
          exact l_init_length'
        | inr h =>
          rw [h, List.length_init, get?_last, l_last]
          rw [← List.length_init]
          rw [Nat.mod_self, List.get?_zero, ← l_head]
          apply Eq.symm
          apply List.head_init
          apply l_length

@[simp]
lemma last_le_aux : ∀ (l l' : List α), l'.length > 1 → (le_aux l l').last' = l'.last'
  | l, [], h => by simp at *
  | l, [x], h => by simp at *
  | l, x :: xs :: xss, h => by simp

lemma le_trans_list_length_aux {y : α} {ys yss} : List.length (y :: ys :: yss) > 1 :=
  show 1 < yss.length.succ.succ from
  show 1 < yss.length + 2 by
  apply lt_of_lt_of_le
  show 1 < 2
  simp
  apply Nat.le_add_left

lemma le_trans_isToFrom
  {y ys z zs : Down}
  {yss zss : List Down}
  (last_lxy : List.last' (y :: ys :: yss) = some x)
  (last_lyz : List.last' (z :: zs :: zss) = some y)
  : isToFrom x z (le_aux (z :: zs :: zss) (y :: ys :: yss)) := by
    apply And.intro
    rw [head_le_aux]
    simp
    simp
    rw [last_le_aux, last_cons]
    assumption
    simp
    apply le_trans_list_length_aux

lemma some_ext (x y : α) : some x = some y → x = y
  | rfl => rfl

lemma le_trans_isChain_aux : ∀ (x y : ℕ), Decidable (x ≤ y)
  | 0, y => isTrue (Nat.zero_le y)
  | n+1, 0 => isFalse $ by
    rw [Nat.le_zero_iff]
    intros h; cases h
  | n+1, m+1 =>
    match le_trans_isChain_aux n m with
    | isTrue h => isTrue (Nat.add_le_add_right h 1)
    | isFalse h => isFalse λ h' => h (Nat.le_of_succ_le_succ h')

lemma le_trans_isChain
  (last_lxy : List.last' xy = some y)
  (lxy_isChain : isChain xy)
  (lyz_isChain : isChain (y :: yzs))
  : isChain (le_aux xy (y :: yzs)) := λ n x' y' =>
    match Nat.lt_trichotomy (n+1) (xy.length) with
    | Or.inl h => by
      simp at *
      rw [List.get?_append, List.get?_append]
      intros getn getn_one
      apply lxy_isChain _ _ _ getn getn_one
      exact h
      apply lt_trans (Nat.lt_succ_self _) h
    | Or.inr h => by
      simp at *
      cases h with
      | inr h =>
        rw [List.get?_append_right, List.get?_append_right]
        intros getn getn_one
        cases (le_trans_isChain_aux _ _ : Decidable (List.length yzs ≤ n + 1 - List.length xy)) with
        | isTrue h2 =>
          rw [List.get?_len_le] at getn_one
          cases getn_one
          exact h2
        | isFalse h2 =>
          apply lyz_isChain (n - xy.length + 1)
          simp
          exact getn
          simp
          have : (n + 1 - xy.length) = (n - xy.length) + 1 := by
            rw [← Nat.add_comm 1, Nat.add_sub_assoc, ← Nat.add_comm 1]
            apply Nat.le_of_lt_succ h
          rw [this] at getn_one
          simp at getn_one
          exact getn_one
        simp
        apply le_of_lt h
        apply Nat.le_of_lt_succ h
      | inl h =>
        simp
        intros getn getn_one
        rw [List.get?_append,] at getn
        rw [List.get?_append_right] at getn_one
        apply lyz_isChain
        rw [List.get?_zero]
        simp
        apply some_ext
        intros
        rw [← getn, ← last_lxy]
        rw [← get?_last, ← h]
        apply congr_arg
        apply Eq.symm
        apply Nat.add_sub_cancel n 1

        rw [← getn_one, h]
        simp
        rw [h]
        apply Nat.le_refl
        apply Nat.lt_of_succ_le
        rw [← h]
        apply Nat.le_refl

lemma lt_trans : ∀ {x y z}, lt x y → lt y z → lt x z
  | x, y, z,
    ⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain, lxy_length⟩,
    ⟨lyz, ⟨head_lyz, last_lyz⟩, lyz_isChain, lyz_length⟩ =>
    match lxy, lyz with
    | _::ys::yss, _::zs::zss  => by
      simp at head_lxy head_lyz
      cases head_lxy
      cases head_lyz
      apply Exists.intro (le_aux (z::zs::zss) (y::ys::yss))
      apply And.intro
      apply le_trans_isToFrom last_lxy last_lyz
      apply And.intro
      apply le_trans_isChain last_lyz lyz_isChain lxy_isChain
      rw [le_aux_cons, List.cons_append, List.cons_append]
      apply List.more_than_two

lemma lt_strongly_antisymm : ∀ a b, lt a b → ¬ lt b a
  | a, b, a_lt_b, b_lt_a => lt_strongly_antisymm' a (lt_trans a_lt_b b_lt_a)

lemma le_antisymm  (a b : Down) : le a b → le b a → a = b
  | ⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain⟩, ⟨lyx, ⟨head_lyx, last_lyx⟩, lyx_isChain⟩ =>
    match lxy, lyx with
    | [], _ => by simp at *
    | _, [] => by simp at *
    | [_], _ => by
      simp at *
      apply Eq.trans last_lxy.symm head_lxy
    | _, [_] => by
      simp at *
      apply Eq.trans head_lyx.symm last_lyx
    | _::ys::yss, _::zs::zss  => by
      have head_lxy' : _ = b := by
        simp at head_lxy
        exact head_lxy
      have head_lyx' : _ = a := by
        simp at head_lyx
        exact head_lyx
      cases head_lxy'
      cases head_lyx'
      exfalso
      apply lt_strongly_antisymm a b
      exact ⟨_, ⟨head_lxy, last_lxy⟩, lxy_isChain, List.more_than_two⟩
      exact ⟨_, ⟨head_lyx, last_lyx⟩, lyx_isChain, List.more_than_two⟩

lemma le_trans {x y z} : le x y → le y z → le x z
  | ⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain⟩, ⟨lyz, ⟨head_lyz, last_lyz⟩, lyz_isChain⟩ =>
    match lxy, lyz with
    | [], _ => by simp at *
    | _, [] => by simp at *
    | [x'], lyz =>
      have some_x_eq_some_y : some x = some y := by
        rw [← head_lxy, ← last_lxy]
        simp
      have : x = y := by
        injection some_x_eq_some_y
        assumption
      by
        simp
        rw [this]
        exact ⟨lyz, ⟨head_lyz, last_lyz⟩, lyz_isChain⟩
    | lxy, [y'] =>
      have some_y_eq_some_z : some y = some z := by
        rw [← head_lyz, ← last_lyz]
        simp
      have : y = z := by
        injection some_y_eq_some_z
        assumption
      by
        rw [← this]
        exact ⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain⟩
    | _::ys::yss, _::zs::zss  => by
      simp at head_lxy head_lyz
      cases head_lxy
      cases head_lyz
      apply Exists.intro (le_aux (z::zs::zss) (y::ys::yss))
      apply And.intro
      apply le_trans_isToFrom last_lxy last_lyz
      apply le_trans_isChain last_lyz lyz_isChain lxy_isChain

lemma lt_iff_le_not_le (a b : Down) : lt a b ↔ le a b ∧ ¬ le b a :=
{ mp := λ ⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain, lxy_long⟩ =>
  have le_b_a := ⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain⟩
  ⟨ le_b_a
  , λ h2 =>
    let a_eq_b : a = b := le_antisymm _ _ le_b_a h2
    by
    cases a_eq_b
    apply lt_strongly_antisymm a a _ _
    assumption
    assumption
  ⟩

, mpr := λ ⟨⟨lxy, ⟨head_lxy, last_lxy⟩, lxy_isChain⟩, not_le_b_a⟩ =>
    have a_neq_b : a ≠ b := by
      intros h
      apply not_le_b_a
      rw [h]
      apply Down.le_refl
    match lxy with
    | [] => by
      simp at *
    | [x] => by
      simp at *
      exfalso
      apply a_neq_b
      apply Eq.trans last_lxy.symm head_lxy
    | x::xs::xss =>
      ⟨x::xs::xss, ⟨head_lxy, last_lxy⟩, lxy_isChain, List.more_than_two⟩
}

instance : PartialOrder Down := {
  le := Down.le
  lt := Down.lt
  le_refl := Down.le_refl
  le_trans := λ _ _ _ => Down.le_trans
  le_antisymm := Down.le_antisymm
  lt_iff_le_not_le := Down.lt_iff_le_not_le
}

lemma mem_lt (h : mem a b) : a < b :=
  have ba_isChain : isChain [b, a] := by
    intros n x' y' xh yh
    cases n with
    | succ n => simp at *
    | zero =>
      simp at *
      cases xh
      cases yh
      exact h
  ⟨[b, a], ⟨rfl, rfl⟩, ba_isChain, Nat.le_refl 2⟩

lemma not_lt_zero : ∀ (a : Down), ¬ a < 0
  | Zero, h => by
    rw [_root_.lt_iff_le_not_le] at h
    apply h.2 (le_refl 0)
  | Limit elems, ⟨[], ⟨l_head, l_tail⟩, l_chain, l_length⟩ => by simp at l_length
  | Limit elems, ⟨[x], ⟨l_head, l_tail⟩, l_chain, l_length⟩ => by simp at l_length
  | Limit elems, ⟨_::xs::xss, ⟨l_head, l_tail⟩, l_chain, l_length⟩ => by
    simp at *
    cases l_head
    apply not_mem_Zero xs
    apply l_chain 0 0 xs rfl rfl

lemma zero_le : ∀ a : Down, 0 ≤ a
  | Zero => le_refl 0
  | Limit a => by
    apply _root_.le_trans (zero_le (a 0)) (le_of_lt (mem_lt _))
    exists 0

lemma zero_lt_Limit (f) : 0 < Limit f :=
  by
  have := zero_le (Limit f)
  rw [le_iff_lt_or_eq] at this
  cases this
  case inl h => exact h
  case inr h => cases h

universe u

decidable_

lemma strong_induction_aux
  (P : Down → Type)
  (P_lt : ∀ a, (∀ b, b < a → P b) → P a)
  : ∀ x y, y ≤ x → P y := by

  intros x
  induction x with
  | Zero =>
    intros y yh
    rw [le_iff_lt_or_eq] at yh
    cases yh with
    | inl h => exfalso; apply not_lt_zero _ h
    | inr h =>
      cases h
      apply P_lt
      intros b b_lt_zero
      exfalso
      apply not_lt_zero b b_lt_zero
  | Limit elems elems_ih =>
    intros y yh
    rw [le_iff_lt_or_eq] at yh
    cases yh
    case inr y_eq =>
      cases y_eq
      apply P_lt
      intros b bh
      have ⟨b_list, ⟨b_head, b_tail⟩, b_chain, b_length⟩ := bh
      match b_list with
      | [] => simp at *
      | [_] => simp at *
      | _::bs::bss =>
        simp at *
        cases b_head
        clear b_length; case refl =>
        have ⟨n, nh⟩ : mem bs (Limit elems) := b_chain 0 (Limit elems) bs rfl rfl
        apply elems_ih n b
        exists (bs :: bss)
        constructor
        constructor
        simp; exact nh
        exact b_tail
        apply isChain_down _ _ b_chain
    case inl y_lt =>
      have ⟨y_list, ⟨y_head, y_tail⟩, y_chain, y_length⟩ := y_lt
      match y_list with
      | [] => simp at *
      | [_] => simp at *
      | _::ys::yss =>
        simp at *
        cases y_head; case refl =>
        clear y_length
        have ⟨n, nh⟩ : mem ys (Limit elems) := y_chain 0 (Limit elems) ys rfl rfl
        cases nh; case refl =>
        apply elems_ih n; case a =>
        exists (elems n :: yss)
        repeat constructor
        exact y_tail
        apply isChain_down _ _ y_chain

lemma strong_induction (P : Down → Prop) (P_lt : ∀ a, (∀ b, b < a → P b) → P a) : ∀ x, P x
  | x => strong_induction_aux P P_lt x x (le_refl x)

def add : Down → Down → Down
  | x, Zero => x
  | x, Limit f => Limit (λ n => add x (f n))

@[simp]
lemma add_zero : add x Zero = x := rfl

@[simp]
lemma add_Limit' : add x (Limit f) = Limit (λ n => add x (f n)) := rfl

lemma zero_add : add Zero x = x :=
  by
  induction x
  case Zero => simp [add]
  case Limit f f_ih => simp [add, f_ih]

lemma add_assoc : ∀ a b c, add (add a b) c = add a (add b c)
  | a, b, Zero => rfl
  | a, b, Limit f => by simp; funext x; apply add_assoc

instance : AddMonoid Down where
  add := add
  zero := Zero
  zero_add := λ _ => zero_add
  add_zero := λ _ => rfl
  add_assoc := add_assoc
  nsmul_zero' := λ _ => rfl
  nsmul_succ' := λ _ _ => rfl

lemma add_Limit : x + Limit f = Limit (λ n => x + f n) := rfl

inductive Sub (a b : Down.{u}) : Prop
  | intro
    (map : {x : Down // x < a} → {x : Down // x < b})
    (zero_to_zero : ∀ {x : {x : Down // x < a}}, x.val = Zero -> (map x).val = Zero)
    (monotonic : ∀ {x : {x : Down // x < a}} {y : {y : Down // y < a}}, x.val < y.val → (map x).val < (map y).val)
    (initial : ∀ {x : {x : Down // x < a}} {y : {y : Down // y < a}}, (map x).val < (map y).val → x.val < y.val)
    : Sub a b

instance : Subset Down where
  subset := Down.Sub

def Sub_fromf
  (f : Down → Down)
  (f_zero : f Zero = Zero)
  (f_mono : ∀ {x y : Down}, x < y → f x < f y)
  (f_initial : ∀ {x y : Down}, f x < f y → x < y)
  (f_takes : ∀ {x : Down}, x < a → f x < b) : a ⊆ b :=
  by
  constructor
  case map => exact λ ⟨z, z_lt⟩ => ⟨f z, f_takes z_lt⟩
  case zero_to_zero =>
    intros x; cases x; case mk x x_lt =>
      intros x_eq_Zero; cases x_eq_Zero
      apply f_zero
  case monotonic =>
    simp
    intros x x_lt y y_lt x_lt_y
    apply f_mono x_lt_y
  case initial =>
    simp
    intro x x_lt y y_lt map_x_lt_map_y
    apply f_initial map_x_lt_map_y

variable {a b c : Down}

lemma Sub.refl : a ⊆ a := by
  apply Sub_fromf
  case f => exact id
  case f_zero => exact rfl
  case f_mono => exact id
  case f_takes => exact id
  case f_initial => exact id

lemma Sub.of_le (a_lt_b : a ≤ b) : a ⊆ b := by
  apply Sub_fromf
  case f => exact id
  case f_zero => exact rfl
  case f_mono => exact id
  case f_takes =>
    intros a a_lt_x
    rw [id]
    apply lt_of_lt_of_le a_lt_x a_lt_b
  case f_initial => exact id

lemma Sub.trans (ab : a ⊆ b) (bc : b ⊆ c) : a ⊆ c :=
  have ⟨ab_map, ab_zero_to_zero, ab_monotonic, ab_initial⟩ := ab
  have ⟨bc_map, bc_zero_to_zero, bc_monotonic, bc_initial⟩ := bc
  by
  constructor
  case map => exact bc_map ∘ ab_map
  case zero_to_zero =>
    intros x p
    cases x; case mk x x_lt =>
    cases p; case refl =>
      simp [ab_zero_to_zero, bc_zero_to_zero]
  case monotonic => exact λ a_lt_b => bc_monotonic (ab_monotonic a_lt_b)
  case initial => exact λ map_a_lt_map_b => ab_initial (bc_initial map_a_lt_map_b)

lemma Sub_zero : ∀ {a : Down}, a ⊆ 0 → a = 0
  | Zero, _ => rfl
  | Limit g, ⟨map, zero_to_zero, monotonic, initial⟩ =>
    have g0_lt_g : g 0 < Limit g := mem_lt ⟨0, rfl⟩
    have y := (map ⟨(g 0), g0_lt_g⟩)
    (not_lt_zero y y.property).elim

lemma Sub.to_map : ∀ a b : Down, a ⊆ b → {x // x < a} → {y // y < b}
  | a, Zero, a_sub_b, ⟨_, lt_a⟩ =>

    by
    have : a = 0 := Sub_zero a_sub_b
    rw [this] at lt_a
    exfalso; apply not_lt_zero _ lt_a

  | Zero, Limit b, a_sub_b, ⟨x, lt_a⟩ => ⟨Zero, zero_lt_Limit _⟩
  | Limit a, Limit b, a_sub_b, ⟨x, lt_a⟩ =>

inductive eqv (x y : Down.{u}) : Prop :=
  | mk (xy : x ⊆ y) (yx : y ⊆ x) : eqv x y

instance Setoid : Setoid Down where
  r := eqv
  iseqv := {
    refl := λ x => ⟨Sub.refl, Sub.refl⟩
    symm := λ ⟨xy, yx⟩ => ⟨yx, xy⟩
    trans := λ ⟨xy, yx⟩ ⟨yz, zy⟩ => ⟨Sub.trans xy yz, Sub.trans zy yx⟩
  }

lemma eqv_zero {a : Down} : a ≈ 0 → a = 0
  | ⟨l, r⟩ => Sub_zero l

lemma eqv_limit {f : ℕ → Down} : ∀ {b}, Limit f ≈ b → ∃ g, Limit g = b
  | Zero, ⟨l, r⟩ => by cases (Sub_zero l)
  | (Limit g), _ => ⟨g, rfl⟩

section

def motive y := ∀ {x : Down}, (h : ∀ (f' : { f' // f' < x }), Σ' (g' : {g' // g' < y}) , f'.val ⊆ g'.val) → x ⊆ y

lemma Sub_limit_limit : motive a := by
  apply strong_induction motive; case P_lt =>
  intros a a_ih
  intros c
  have := a_ih c
  intros h
  constructor
  case map =>
    intros x
    have ⟨g, ⟨gmap, g1, g2, g3⟩⟩ := h x

end Down

def Ordinal := Quotient Down.Setoid

namespace Ordinal

def mk : Down → Ordinal := Quotient.mk Down.Setoid

lemma addWellDefined
  (a₁ : Down) (b₁ : Down) (a₂ : Down) (b₂ : Down)
  (a_eqv : a₁ ≈ a₂) (b_eqv : b₁ ≈ b₂) :
    mk (a₁ + b₁) = mk (a₂ + b₂) :=
  by
  apply Quotient.sound
  case a =>
    revert a₁ a₂ b₂
    induction b₁
    case Zero =>
      intros a₁ a₂ b₂ a_eqv b_eqv
      have := Down.eqv_zero (Setoid.symm b_eqv)
      cases this; case refl =>
      have : Down.Zero = 0 := rfl
      simp [this] at *
      exact a_eqv
    case Limit b₁f b₁f_ih =>
      intros a₁ a₂ b₂ a_eqv b_eqv
      have ⟨b₂f, b_eq⟩ := Down.eqv_limit b_eqv
      simp [← b_eq, Down.add_Limit] at *

def add : Ordinal → Ordinal → Ordinal :=

  Quotient.lift₂ (λ a b => mk $ a + b) _


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

lemma equiv_reflects_mono {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : mono (e.functor.map f)) : mono f :=
-- Hint: when `e : C ≌ D`, `e.functor.map_injective` says
--   `∀ f g, e.functor.map f = e.functor.map g → f = g`
-- Hint: use `cancel_mono`.
-- sorry
begin
  tidy,
  apply e.functor.map_injective,
  apply (cancel_mono (e.functor.map f)).1,
  apply e.inverse.map_injective,
  simp,
  assumption
end
-- sorry

lemma equiv_preserves_mono {X Y : C} (f : X ⟶ Y) [mono f] (e : C ≌ D) :
  mono (e.functor.map f) :=
-- Hint: if `w : f = g`, to obtain `F.map f = F.map G`,
--   you can use `have w' := congr_arg (λ k, F.map k) w`.
-- sorry
begin
  tidy,
  replace w := congr_arg (λ k, e.inverse.map k) w,
  simp at w,
  simp only [←category.assoc, cancel_mono] at w,
  simp at w,
  exact w,
end
-- sorry

/-!
There are some further hints in
`hints/category_theory/exercise3/`
-/


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Kexing Ying
-/

import linear_algebra.matrix.basis
import linear_algebra.matrix.nondegenerate
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.matrix.to_linear_equiv
import linear_algebra.bilinear_form
import linear_algebra.matrix.sesquilinear_form

/-!
# Bilinear form

This file defines the conversion between bilinear forms and matrices.

## Main definitions

 * `matrix.to_bilin` given a basis define a bilinear form
 * `matrix.to_bilin'` define the bilinear form on `n → R`
 * `bilin_form.to_matrix`: calculate the matrix coefficients of a bilinear form
 * `bilin_form.to_matrix'`: calculate the matrix coefficients of a bilinear form on `n → R`

## Notations

In this file we use the following type variables:
 - `M`, `M'`, ... are modules over the semiring `R`,
 - `M₁`, `M₁'`, ... are modules over the ring `R₁`,
 - `M₂`, `M₂'`, ... are modules over the commutative semiring `R₂`,
 - `M₃`, `M₃'`, ... are modules over the commutative ring `R₃`,
 - `V`, ... is a vector space over the field `K`.

## Tags

bilinear_form, matrix, basis

-/

variables {R : Type*} {M : Type*} [semiring R] [add_comm_monoid M] [module R M]
variables {R₁ : Type*} {M₁ : Type*} [ring R₁] [add_comm_group M₁] [module R₁ M₁]
variables {R₂ : Type*} {M₂ : Type*} [comm_semiring R₂] [add_comm_monoid M₂] [module R₂ M₂]
variables {R₃ : Type*} {M₃ : Type*} [comm_ring R₃] [add_comm_group M₃] [module R₃ M₃]
variables {V : Type*} {K : Type*} [field K] [add_comm_group V] [module K V]
variables {B : bilin_form R M} {B₁ : bilin_form R₁ M₁} {B₂ : bilin_form R₂ M₂}

section matrix
variables {n o : Type*}

open_locale big_operators
open bilin_form finset linear_map matrix
open_locale matrix

/-- The map from `matrix n n R` to bilinear forms on `n → R`.

This is an auxiliary definition for the equivalence `matrix.to_bilin_form'`. -/
def matrix.to_bilin'_aux [fintype n] (M : matrix n n R₂) : bilin_form R₂ (n → R₂) :=
{ bilin := λ v w, ∑ i j, v i * M i j * w j,
  bilin_add_left := λ x y z, by simp only [pi.add_apply, add_mul, sum_add_distrib],
  bilin_smul_left := λ a x y, by simp only [pi.smul_apply, smul_eq_mul, mul_assoc, mul_sum],
  bilin_add_right := λ x y z, by simp only [pi.add_apply, mul_add, sum_add_distrib],
  bilin_smul_right := λ a x y,
    by simp only [pi.smul_apply, smul_eq_mul, mul_assoc, mul_left_comm, mul_sum] }

lemma matrix.to_bilin'_aux_std_basis [fintype n] [decidable_eq n] (M : matrix n n R₂)
  (i j : n) : M.to_bilin'_aux (std_basis R₂ (λ _, R₂) i 1) (std_basis R₂ (λ _, R₂) j 1) = M i j :=
begin
  rw [matrix.to_bilin'_aux, coe_fn_mk, sum_eq_single i, sum_eq_single j],
  { simp only [std_basis_same, std_basis_same, one_mul, mul_one] },
  { rintros j' - hj',
    apply mul_eq_zero_of_right,
    exact std_basis_ne R₂ (λ _, R₂) _ _ hj' 1 },
  { intros,
    have := finset.mem_univ j,
    contradiction },
  { rintros i' - hi',
    refine finset.sum_eq_zero (λ j _, _),
    apply mul_eq_zero_of_left,
    apply mul_eq_zero_of_left,
    exact std_basis_ne R₂ (λ _, R₂) _ _ hi' 1 },
  { intros,
    have := finset.mem_univ i,
    contradiction }
end

/-- The linear map from bilinear forms to `matrix n n R` given an `n`-indexed basis.

This is an auxiliary definition for the equivalence `matrix.to_bilin_form'`. -/
def bilin_form.to_matrix_aux (b : n → M₂) : bilin_form R₂ M₂ →ₗ[R₂] matrix n n R₂ :=
{ to_fun := λ B, of $ λ i j, B (b i) (b j),
  map_add' := λ f g, rfl,
  map_smul' := λ f g, rfl }

@[simp] lemma bilin_form.to_matrix_aux_apply (B : bilin_form R₂ M₂) (b : n → M₂) (i j : n) :
  bilin_form.to_matrix_aux b B i j = B (b i) (b j) := rfl

variables [fintype n] [fintype o]

lemma to_bilin'_aux_to_matrix_aux [decidable_eq n] (B₂ : bilin_form R₂ (n → R₂)) :
  matrix.to_bilin'_aux (bilin_form.to_matrix_aux (λ j, std_basis R₂ (λ _, R₂) j 1) B₂) = B₂ :=
begin
  refine ext_basis (pi.basis_fun R₂ n) (λ i j, _),
  rw [pi.basis_fun_apply, pi.basis_fun_apply, matrix.to_bilin'_aux_std_basis,
    bilin_form.to_matrix_aux_apply]
end

section to_matrix'

/-! ### `to_matrix'` section

This section deals with the conversion between matrices and bilinear forms on `n → R₂`.
-/

variables [decidable_eq n] [decidable_eq o]

/-- The linear equivalence between bilinear forms on `n → R` and `n × n` matrices -/
def bilin_form.to_matrix' : bilin_form R₂ (n → R₂) ≃ₗ[R₂] matrix n n R₂ :=
{ inv_fun := matrix.to_bilin'_aux,
  left_inv := by convert to_bilin'_aux_to_matrix_aux,
  right_inv := λ M,
    by { ext i j, simp only [to_fun_eq_coe, bilin_form.to_matrix_aux_apply,
      matrix.to_bilin'_aux_std_basis] },
  ..bilin_form.to_matrix_aux (λ j, std_basis R₂ (λ _, R₂) j 1) }

@[simp] lemma bilin_form.to_matrix_aux_std_basis (B : bilin_form R₂ (n → R₂)) :
  bilin_form.to_matrix_aux (λ j, std_basis R₂ (λ _, R₂) j 1) B =
    bilin_form.to_matrix' B :=
rfl

/-- The linear equivalence between `n × n` matrices and bilinear forms on `n → R` -/
def matrix.to_bilin' : matrix n n R₂ ≃ₗ[R₂] bilin_form R₂ (n → R₂) :=
bilin_form.to_matrix'.symm

@[simp] lemma matrix.to_bilin'_aux_eq (M : matrix n n R₂) :
  matrix.to_bilin'_aux M = matrix.to_bilin' M :=
rfl

lemma matrix.to_bilin'_apply (M : matrix n n R₂) (x y : n → R₂) :
  matrix.to_bilin' M x y = ∑ i j, x i * M i j * y j := rfl

lemma matrix.to_bilin'_apply' (M : matrix n n R₂) (v w : n → R₂) :
  matrix.to_bilin' M v w = matrix.dot_product v (M.mul_vec w) :=
begin
  simp_rw [matrix.to_bilin'_apply, matrix.dot_product,
           matrix.mul_vec, matrix.dot_product],
  refine finset.sum_congr rfl (λ _ _, _),
  rw finset.mul_sum,
  refine finset.sum_congr rfl (λ _ _, _),
  rw ← mul_assoc,
end

@[simp] lemma matrix.to_bilin'_std_basis (M : matrix n n R₂) (i j : n) :
  matrix.to_bilin' M (std_basis R₂ (λ _, R₂) i 1) (std_basis R₂ (λ _, R₂) j 1) =
    M i j :=
matrix.to_bilin'_aux_std_basis M i j

@[simp] lemma bilin_form.to_matrix'_symm :
  (bilin_form.to_matrix'.symm : matrix n n R₂ ≃ₗ[R₂] _) = matrix.to_bilin' :=
rfl

@[simp] lemma matrix.to_bilin'_symm :
  (matrix.to_bilin'.symm : _ ≃ₗ[R₂] matrix n n R₂) = bilin_form.to_matrix' :=
bilin_form.to_matrix'.symm_symm

@[simp] lemma matrix.to_bilin'_to_matrix' (B : bilin_form R₂ (n → R₂)) :
  matrix.to_bilin' (bilin_form.to_matrix' B) = B :=
matrix.to_bilin'.apply_symm_apply B

@[simp] lemma bilin_form.to_matrix'_to_bilin' (M : matrix n n R₂) :
  bilin_form.to_matrix' (matrix.to_bilin' M) = M :=
bilin_form.to_matrix'.apply_symm_apply M

@[simp] lemma bilin_form.to_matrix'_apply (B : bilin_form R₂ (n → R₂)) (i j : n) :
  bilin_form.to_matrix' B i j =
    B (std_basis R₂ (λ _, R₂) i 1) (std_basis R₂ (λ _, R₂) j 1) :=
rfl

@[simp] lemma bilin_form.to_matrix'_comp (B : bilin_form R₂ (n → R₂))
  (l r : (o → R₂) →ₗ[R₂] (n → R₂)) :
  (B.comp l r).to_matrix' = l.to_matrix'ᵀ ⬝ B.to_matrix' ⬝ r.to_matrix' :=
begin
  ext i j,
  simp only [bilin_form.to_matrix'_apply, bilin_form.comp_apply, transpose_apply, matrix.mul_apply,
    linear_map.to_matrix', linear_equiv.coe_mk, sum_mul],
  rw sum_comm,
  conv_lhs { rw ← bilin_form.sum_repr_mul_repr_mul (pi.basis_fun R₂ n) (l _) (r _) },
  rw finsupp.sum_fintype,
  { apply sum_congr rfl,
    rintros i' -,
    rw finsupp.sum_fintype,
    { apply sum_congr rfl,
      rintros j' -,
      simp only [smul_eq_mul, pi.basis_fun_repr, mul_assoc, mul_comm, mul_left_comm,
                 pi.basis_fun_apply, of_apply] },
    { intros, simp only [zero_smul, smul_zero] } },
  { intros, simp only [zero_smul, finsupp.sum_zero] }
end

lemma bilin_form.to_matrix'_comp_left (B : bilin_form R₂ (n → R₂))
  (f : (n → R₂) →ₗ[R₂] (n → R₂)) : (B.comp_left f).to_matrix' = f.to_matrix'ᵀ ⬝ B.to_matrix' :=
by simp only [bilin_form.comp_left, bilin_form.to_matrix'_comp, to_matrix'_id, matrix.mul_one]

lemma bilin_form.to_matrix'_comp_right (B : bilin_form R₂ (n → R₂))
  (f : (n → R₂) →ₗ[R₂] (n → R₂)) : (B.comp_right f).to_matrix' = B.to_matrix' ⬝ f.to_matrix' :=
by simp only [bilin_form.comp_right, bilin_form.to_matrix'_comp, to_matrix'_id,
              transpose_one, matrix.one_mul]

lemma bilin_form.mul_to_matrix'_mul (B : bilin_form R₂ (n → R₂))
  (M : matrix o n R₂) (N : matrix n o R₂) :
  M ⬝ B.to_matrix' ⬝ N = (B.comp Mᵀ.to_lin' N.to_lin').to_matrix' :=
by simp only [B.to_matrix'_comp, transpose_transpose, to_matrix'_to_lin']

lemma bilin_form.mul_to_matrix' (B : bilin_form R₂ (n → R₂)) (M : matrix n n R₂) :
  M ⬝ B.to_matrix' = (B.comp_left Mᵀ.to_lin').to_matrix' :=
by simp only [B.to_matrix'_comp_left, transpose_transpose, to_matrix'_to_lin']

lemma bilin_form.to_matrix'_mul (B : bilin_form R₂ (n → R₂)) (M : matrix n n R₂) :
  B.to_matrix' ⬝ M = (B.comp_right M.to_lin').to_matrix' :=
by simp only [B.to_matrix'_comp_right, to_matrix'_to_lin']

lemma matrix.to_bilin'_comp (M : matrix n n R₂) (P Q : matrix n o R₂) :
  M.to_bilin'.comp P.to_lin' Q.to_lin' = (Pᵀ ⬝ M ⬝ Q).to_bilin' :=
bilin_form.to_matrix'.injective
  (by simp only [bilin_form.to_matrix'_comp, bilin_form.to_matrix'_to_bilin', to_matrix'_to_lin'])

end to_matrix'

section to_matrix

/-! ### `to_matrix` section

This section deals with the conversion between matrices and bilinear forms on
a module with a fixed basis.
-/

variables [decidable_eq n] (b : basis n R₂ M₂)

/-- `bilin_form.to_matrix b` is the equivalence between `R`-bilinear forms on `M` and
`n`-by-`n` matrices with entries in `R`, if `b` is an `R`-basis for `M`. -/
noncomputable def bilin_form.to_matrix : bilin_form R₂ M₂ ≃ₗ[R₂] matrix n n R₂ :=
(bilin_form.congr b.equiv_fun).trans bilin_form.to_matrix'

/-- `bilin_form.to_matrix b` is the equivalence between `R`-bilinear forms on `M` and
`n`-by-`n` matrices with entries in `R`, if `b` is an `R`-basis for `M`. -/
noncomputable def matrix.to_bilin : matrix n n R₂ ≃ₗ[R₂] bilin_form R₂ M₂ :=
(bilin_form.to_matrix b).symm

@[simp] lemma bilin_form.to_matrix_apply (B : bilin_form R₂ M₂) (i j : n) :
  bilin_form.to_matrix b B i j = B (b i) (b j) :=
by rw [bilin_form.to_matrix, linear_equiv.trans_apply, bilin_form.to_matrix'_apply, congr_apply,
       b.equiv_fun_symm_std_basis, b.equiv_fun_symm_std_basis]

@[simp] lemma matrix.to_bilin_apply (M : matrix n n R₂) (x y : M₂) :
  matrix.to_bilin b M x y = ∑ i j, b.repr x i * M i j * b.repr y j :=
begin
  rw [matrix.to_bilin, bilin_form.to_matrix, linear_equiv.symm_trans_apply, ← matrix.to_bilin'],
  simp only [congr_symm, congr_apply, linear_equiv.symm_symm, matrix.to_bilin'_apply,
    basis.equiv_fun_apply]
end

-- Not a `simp` lemma since `bilin_form.to_matrix` needs an extra argument
lemma bilinear_form.to_matrix_aux_eq (B : bilin_form R₂ M₂) :
  bilin_form.to_matrix_aux b B = bilin_form.to_matrix b B :=
ext (λ i j, by rw [bilin_form.to_matrix_apply, bilin_form.to_matrix_aux_apply])

@[simp] lemma bilin_form.to_matrix_symm :
  (bilin_form.to_matrix b).symm = matrix.to_bilin b :=
rfl

@[simp] lemma matrix.to_bilin_symm :
  (matrix.to_bilin b).symm = bilin_form.to_matrix b :=
(bilin_form.to_matrix b).symm_symm

lemma matrix.to_bilin_basis_fun :
  matrix.to_bilin (pi.basis_fun R₂ n) = matrix.to_bilin' :=
by { ext M, simp only [matrix.to_bilin_apply, matrix.to_bilin'_apply, pi.basis_fun_repr] }

lemma bilin_form.to_matrix_basis_fun :
  bilin_form.to_matrix (pi.basis_fun R₂ n) = bilin_form.to_matrix' :=
by { ext B, rw [bilin_form.to_matrix_apply, bilin_form.to_matrix'_apply,
                pi.basis_fun_apply, pi.basis_fun_apply] }

@[simp] lemma matrix.to_bilin_to_matrix (B : bilin_form R₂ M₂) :
  matrix.to_bilin b (bilin_form.to_matrix b B) = B :=
(matrix.to_bilin b).apply_symm_apply B

@[simp] lemma bilin_form.to_matrix_to_bilin (M : matrix n n R₂) :
  bilin_form.to_matrix b (matrix.to_bilin b M) = M :=
(bilin_form.to_matrix b).apply_symm_apply M

variables {M₂' : Type*} [add_comm_monoid M₂'] [module R₂ M₂']
variables (c : basis o R₂ M₂')
variables [decidable_eq o]

-- Cannot be a `simp` lemma because `b` must be inferred.
lemma bilin_form.to_matrix_comp
  (B : bilin_form R₂ M₂) (l r : M₂' →ₗ[R₂] M₂) :
  bilin_form.to_matrix c (B.comp l r) =
    (to_matrix c b l)ᵀ ⬝ bilin_form.to_matrix b B ⬝ to_matrix c b r :=
begin
  ext i j,
  simp only [bilin_form.to_matrix_apply, bilin_form.comp_apply, transpose_apply, matrix.mul_apply,
    linear_map.to_matrix', linear_equiv.coe_mk, sum_mul],
  rw sum_comm,
  conv_lhs { rw ← bilin_form.sum_repr_mul_repr_mul b },
  rw finsupp.sum_fintype,
  { apply sum_congr rfl,
    rintros i' -,
    rw finsupp.sum_fintype,
    { apply sum_congr rfl,
      rintros j' -,
      simp only [smul_eq_mul, linear_map.to_matrix_apply,
        basis.equiv_fun_apply, mul_assoc, mul_comm, mul_left_comm] },
    { intros, simp only [zero_smul, smul_zero] } },
  { intros, simp only [zero_smul, finsupp.sum_zero] }
end

lemma bilin_form.to_matrix_comp_left (B : bilin_form R₂ M₂) (f : M₂ →ₗ[R₂] M₂) :
  bilin_form.to_matrix b (B.comp_left f) = (to_matrix b b f)ᵀ ⬝ bilin_form.to_matrix b B :=
by simp only [comp_left, bilin_form.to_matrix_comp b b, to_matrix_id, matrix.mul_one]

lemma bilin_form.to_matrix_comp_right (B : bilin_form R₂ M₂) (f : M₂ →ₗ[R₂] M₂) :
  bilin_form.to_matrix b (B.comp_right f) = bilin_form.to_matrix b B ⬝ (to_matrix b b f) :=
by simp only [bilin_form.comp_right, bilin_form.to_matrix_comp b b, to_matrix_id,
              transpose_one, matrix.one_mul]

@[simp]
lemma bilin_form.to_matrix_mul_basis_to_matrix (c : basis o R₂ M₂) (B : bilin_form R₂ M₂) :
  (b.to_matrix c)ᵀ ⬝ bilin_form.to_matrix b B ⬝ b.to_matrix c = bilin_form.to_matrix c B :=
by rw [← linear_map.to_matrix_id_eq_basis_to_matrix, ← bilin_form.to_matrix_comp,
       bilin_form.comp_id_id]

lemma bilin_form.mul_to_matrix_mul (B : bilin_form R₂ M₂)
  (M : matrix o n R₂) (N : matrix n o R₂) :
  M ⬝ bilin_form.to_matrix b B ⬝ N =
    bilin_form.to_matrix c (B.comp (to_lin c b Mᵀ) (to_lin c b N)) :=
by simp only [B.to_matrix_comp b c, to_matrix_to_lin, transpose_transpose]

lemma bilin_form.mul_to_matrix (B : bilin_form R₂ M₂) (M : matrix n n R₂) :
  M ⬝ bilin_form.to_matrix b B =
    bilin_form.to_matrix b (B.comp_left (to_lin b b Mᵀ)) :=
by rw [B.to_matrix_comp_left b, to_matrix_to_lin, transpose_transpose]

lemma bilin_form.to_matrix_mul (B : bilin_form R₂ M₂) (M : matrix n n R₂) :
  bilin_form.to_matrix b B ⬝ M =
    bilin_form.to_matrix b (B.comp_right (to_lin b b M)) :=
by rw [B.to_matrix_comp_right b, to_matrix_to_lin]

lemma matrix.to_bilin_comp (M : matrix n n R₂) (P Q : matrix n o R₂) :
  (matrix.to_bilin b M).comp (to_lin c b P) (to_lin c b Q) = matrix.to_bilin c (Pᵀ ⬝ M ⬝ Q) :=
(bilin_form.to_matrix c).injective
  (by simp only [bilin_form.to_matrix_comp b c, bilin_form.to_matrix_to_bilin, to_matrix_to_lin])

end to_matrix

end matrix
section matrix_adjoints
open_locale matrix

variables {n : Type*} [fintype n]
variables (b : basis n R₃ M₃)
variables (J J₃ A A' : matrix n n R₃)

@[simp] lemma is_adjoint_pair_to_bilin' [decidable_eq n] :
  bilin_form.is_adjoint_pair (matrix.to_bilin' J) (matrix.to_bilin' J₃)
      (matrix.to_lin' A) (matrix.to_lin' A') ↔
    matrix.is_adjoint_pair J J₃ A A' :=
begin
  rw bilin_form.is_adjoint_pair_iff_comp_left_eq_comp_right,
  have h : ∀ (B B' : bilin_form R₃ (n → R₃)), B = B' ↔
    (bilin_form.to_matrix' B) = (bilin_form.to_matrix' B'),
  { intros B B',
    split; intros h,
    { rw h },
    { exact bilin_form.to_matrix'.injective h } },
  rw [h, bilin_form.to_matrix'_comp_left, bilin_form.to_matrix'_comp_right,
      linear_map.to_matrix'_to_lin', linear_map.to_matrix'_to_lin',
      bilin_form.to_matrix'_to_bilin', bilin_form.to_matrix'_to_bilin'],
  refl,
end

@[simp] lemma is_adjoint_pair_to_bilin [decidable_eq n] :
  bilin_form.is_adjoint_pair (matrix.to_bilin b J) (matrix.to_bilin b J₃)
      (matrix.to_lin b b A) (matrix.to_lin b b A') ↔
    matrix.is_adjoint_pair J J₃ A A' :=
begin
  rw bilin_form.is_adjoint_pair_iff_comp_left_eq_comp_right,
  have h : ∀ (B B' : bilin_form R₃ M₃), B = B' ↔
    (bilin_form.to_matrix b B) = (bilin_form.to_matrix b B'),
  { intros B B',
    split; intros h,
    { rw h },
    { exact (bilin_form.to_matrix b).injective h } },
  rw [h, bilin_form.to_matrix_comp_left, bilin_form.to_matrix_comp_right,
      linear_map.to_matrix_to_lin, linear_map.to_matrix_to_lin,
      bilin_form.to_matrix_to_bilin, bilin_form.to_matrix_to_bilin],
  refl,
end

lemma matrix.is_adjoint_pair_equiv' [decidable_eq n] (P : matrix n n R₃) (h : is_unit P) :
  (Pᵀ ⬝ J ⬝ P).is_adjoint_pair (Pᵀ ⬝ J ⬝ P) A A' ↔
    J.is_adjoint_pair J (P ⬝ A ⬝ P⁻¹) (P ⬝ A' ⬝ P⁻¹) :=
have h' : is_unit P.det := P.is_unit_iff_is_unit_det.mp h,
begin
  let u := P.nonsing_inv_unit h',
  let v := Pᵀ.nonsing_inv_unit (P.is_unit_det_transpose h'),
  let x := Aᵀ * Pᵀ * J,
  let y := J * P * A',
  suffices : x * ↑u = ↑v * y ↔ ↑v⁻¹ * x = y * ↑u⁻¹,
  { dunfold matrix.is_adjoint_pair,
    repeat { rw matrix.transpose_mul, },
    simp only [←matrix.mul_eq_mul, ←mul_assoc, P.transpose_nonsing_inv],
    conv_lhs { to_rhs, rw [mul_assoc, mul_assoc], congr, skip, rw ←mul_assoc, },
    conv_rhs { rw [mul_assoc, mul_assoc], conv { to_lhs, congr, skip, rw ←mul_assoc }, },
    exact this, },
  rw units.eq_mul_inv_iff_mul_eq, conv_rhs { rw mul_assoc, }, rw v.inv_mul_eq_iff_eq_mul,
end

variables [decidable_eq n]

/-- The submodule of pair-self-adjoint matrices with respect to bilinear forms corresponding to
given matrices `J`, `J₂`. -/
def pair_self_adjoint_matrices_submodule' : submodule R₃ (matrix n n R₃) :=
(bilin_form.is_pair_self_adjoint_submodule (matrix.to_bilin' J) (matrix.to_bilin' J₃)).map
  ((linear_map.to_matrix' : ((n → R₃) →ₗ[R₃] (n → R₃)) ≃ₗ[R₃] matrix n n R₃) :
  ((n → R₃) →ₗ[R₃] (n → R₃)) →ₗ[R₃] matrix n n R₃)

lemma mem_pair_self_adjoint_matrices_submodule' :
  A ∈ (pair_self_adjoint_matrices_submodule J J₃) ↔ matrix.is_adjoint_pair J J₃ A A :=
by simp only [mem_pair_self_adjoint_matrices_submodule]

/-- The submodule of self-adjoint matrices with respect to the bilinear form corresponding to
the matrix `J`. -/
def self_adjoint_matrices_submodule' : submodule R₃ (matrix n n R₃) :=
  pair_self_adjoint_matrices_submodule J J

lemma mem_self_adjoint_matrices_submodule' :
  A ∈ self_adjoint_matrices_submodule J ↔ J.is_self_adjoint A :=
by simp only [mem_self_adjoint_matrices_submodule]

/-- The submodule of skew-adjoint matrices with respect to the bilinear form corresponding to
the matrix `J`. -/
def skew_adjoint_matrices_submodule' : submodule R₃ (matrix n n R₃) :=
  pair_self_adjoint_matrices_submodule (-J) J

lemma mem_skew_adjoint_matrices_submodule' :
  A ∈ skew_adjoint_matrices_submodule J ↔ J.is_skew_adjoint A :=
by simp only [mem_skew_adjoint_matrices_submodule]

end matrix_adjoints

namespace bilin_form

section det

open matrix

variables {A : Type*} [comm_ring A] [is_domain A] [module A M₃] (B₃ : bilin_form A M₃)
variables {ι : Type*} [decidable_eq ι] [fintype ι]

lemma _root_.matrix.nondegenerate_to_bilin'_iff_nondegenerate_to_bilin {M : matrix ι ι R₂}
  (b : basis ι R₂ M₂) : M.to_bilin'.nondegenerate ↔ (matrix.to_bilin b M).nondegenerate :=
(nondegenerate_congr_iff b.equiv_fun.symm).symm

-- Lemmas transferring nondegeneracy between a matrix and its associated bilinear form

theorem _root_.matrix.nondegenerate.to_bilin' {M : matrix ι ι R₃} (h : M.nondegenerate) :
  M.to_bilin'.nondegenerate :=
λ x hx, h.eq_zero_of_ortho $ λ y, by simpa only [to_bilin'_apply'] using hx y

@[simp] lemma _root_.matrix.nondegenerate_to_bilin'_iff {M : matrix ι ι R₃} :
  M.to_bilin'.nondegenerate ↔ M.nondegenerate :=
⟨λ h v hv, h v $ λ w, (M.to_bilin'_apply' _ _).trans $ hv w, matrix.nondegenerate.to_bilin'⟩

theorem _root_.matrix.nondegenerate.to_bilin {M : matrix ι ι R₃} (h : M.nondegenerate)
  (b : basis ι R₃ M₃) : (to_bilin b M).nondegenerate :=
(matrix.nondegenerate_to_bilin'_iff_nondegenerate_to_bilin b).mp h.to_bilin'

@[simp] lemma _root_.matrix.nondegenerate_to_bilin_iff {M : matrix ι ι R₃} (b : basis ι R₃ M₃) :
  (to_bilin b M).nondegenerate ↔ M.nondegenerate :=
by rw [←matrix.nondegenerate_to_bilin'_iff_nondegenerate_to_bilin,
       matrix.nondegenerate_to_bilin'_iff]

-- Lemmas transferring nondegeneracy between a bilinear form and its associated matrix

@[simp] theorem nondegenerate_to_matrix'_iff {B : bilin_form R₃ (ι → R₃)} :
  B.to_matrix'.nondegenerate ↔ B.nondegenerate :=
matrix.nondegenerate_to_bilin'_iff.symm.trans $ (matrix.to_bilin'_to_matrix' B).symm ▸ iff.rfl

theorem nondegenerate.to_matrix' {B : bilin_form R₃ (ι → R₃)} (h : B.nondegenerate) :
  B.to_matrix'.nondegenerate :=
nondegenerate_to_matrix'_iff.mpr h

@[simp] theorem nondegenerate_to_matrix_iff {B : bilin_form R₃ M₃} (b : basis ι R₃ M₃) :
  (to_matrix b B).nondegenerate ↔ B.nondegenerate :=
(matrix.nondegenerate_to_bilin_iff b).symm.trans $ (matrix.to_bilin_to_matrix b B).symm ▸ iff.rfl

theorem nondegenerate.to_matrix {B : bilin_form R₃ M₃} (h : B.nondegenerate)
  (b : basis ι R₃ M₃) : (to_matrix b B).nondegenerate :=
(nondegenerate_to_matrix_iff b).mpr h

-- Some shorthands for combining the above with `matrix.nondegenerate_of_det_ne_zero`

lemma nondegenerate_to_bilin'_iff_det_ne_zero {M : matrix ι ι A} :
  M.to_bilin'.nondegenerate ↔ M.det ≠ 0 :=
by rw [matrix.nondegenerate_to_bilin'_iff, matrix.nondegenerate_iff_det_ne_zero]

theorem nondegenerate_to_bilin'_of_det_ne_zero' (M : matrix ι ι A) (h : M.det ≠ 0) :
  M.to_bilin'.nondegenerate :=
nondegenerate_to_bilin'_iff_det_ne_zero.mpr h

lemma nondegenerate_iff_det_ne_zero {B : bilin_form A M₃}
  (b : basis ι A M₃) : B.nondegenerate ↔ (to_matrix b B).det ≠ 0 :=
by rw [←matrix.nondegenerate_iff_det_ne_zero, nondegenerate_to_matrix_iff]

theorem nondegenerate_of_det_ne_zero (b : basis ι A M₃) (h : (to_matrix b B₃).det ≠ 0) :
  B₃.nondegenerate :=
(nondegenerate_iff_det_ne_zero b).mpr h

end det

end bilin_form


import data.rat.basic
import data.real.basic
import algebra.group_with_zero.basic
import algebra.group.hom

import for_mathlib.hom

-- From Alex J. Best (?)
lemma rat_mk_eq_div (x_num : ℤ) (x_denom : ℕ) (x_pos : 0 < x_denom) (x_cop : nat.coprime (int.nat_abs x_num) x_denom)
: ({num := x_num, denom := x_denom, pos := x_pos, cop := x_cop}:ℚ) = (↑ x_num)/(↑ x_denom) := begin
  norm_cast,
  rw rat.mk,
  rw rat.mk_nat,
  rw dif_neg,
  rw rat.mk_pnat,
  {
    simp [x_cop.gcd_eq_one],
  },
  exact ne_of_gt x_pos,
end

-- Integer values of a morphism `φ` and its value on `-1` completely determines `φ`
theorem ext_hom_pnat (φ₁ φ₂: monoid_with_zero_hom ℚ ℝ)
  (same_on_neg_one: φ₁ (-1) = φ₂ (-1)) (same_on_nat: ∀ n: ℕ, φ₁ n = φ₂ n): (φ₁: ℚ → ℝ) = φ₂ :=
begin
  ext,
  suffices : ∀ z : ℤ, φ₁ z = φ₂ z,
  begin
    induction x,
    rw rat_mk_eq_div,
    repeat { rw div_eq_mul_inv, },
    have x_denom_ne_zero: (x_denom: ℚ) ≠ 0,
    {
      symmetry,
      norm_cast,
      exact (ne_of_lt x_pos),
    },
    rw monoid_with_zero_hom.map_mul φ₁,
    rw monoid_with_zero_hom.map_inv φ₁ x_denom x_denom_ne_zero,
    rw monoid_with_zero_hom.map_mul φ₂,
    rw monoid_with_zero_hom.map_inv φ₂ x_denom x_denom_ne_zero,
    rw this x_num,
    have := this (↑ x_denom),
    norm_cast at this,
    rw this,
  end,
  intro x,
  suffices : ∀ z : ℕ, φ₁ z = φ₂ z,
  begin
    induction x,
    simp [this],
    push_cast,
    conv {
      congr,
      rw neg_eq_neg_one_mul,
      skip,
      rw neg_eq_neg_one_mul,
      skip,
    },
    rw monoid_with_zero_hom.map_mul φ₁,
    rw monoid_with_zero_hom.map_mul φ₂,
    rw same_on_neg_one,
    simp,
    norm_cast,
    exact this _,
  end,
  intro x,
  cases x,
  simp,
  have := same_on_nat (nat.succ x_1),
  simp [-add_comm] at this,
  simp [-add_comm],
  rw this,
end