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

! This file was ported from Lean 3 source module tactic.slim_check
! leanprover-community/mathlib commit c0a51cf2de54089d69301befc4c73bbc2f5c7342
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Testing.SlimCheck.Testable
import Mathbin.Data.List.Sort

/-!
## Finding counterexamples automatically using `slim_check`

A proposition can be tested by writing it out as:

```lean
example (xs : list ℕ) (w : ∃ x ∈ xs, x < 3) : ∀ y ∈ xs, y < 5 := by slim_check
-- ===================
-- Found problems!

-- xs := [0, 5]
-- x := 0
-- y := 5
-- -------------------

example (x : ℕ) (h : 2 ∣ x) : x < 100 := by slim_check
-- ===================
-- Found problems!

-- x := 258
-- -------------------

example (α : Type) (xs ys : list α) : xs ++ ys = ys ++ xs := by slim_check
-- ===================
-- Found problems!

-- α := ℤ
-- xs := [-4]
-- ys := [1]
-- -------------------

example : ∀ x ∈ [1,2,3], x < 4 := by slim_check
-- Success
```

In the first example, `slim_check` is called on the following goal:

```lean
xs : list ℕ,
h : ∃ (x : ℕ) (H : x ∈ xs), x < 3
⊢ ∀ (y : ℕ), y ∈ xs → y < 5
```

The local constants are reverted and an instance is found for
`testable (∀ (xs : list ℕ), (∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))`.
The `testable` instance is supported by instances of `sampleable (list ℕ)`,
`decidable (x < 3)` and `decidable (y < 5)`. `slim_check` builds a
`testable` instance step by step with:

```
- testable (∀ (xs : list ℕ), (∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))
                                     -: sampleable (list xs)
- testable ((∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))
- testable (∀ x ∈ xs, x < 3 → (∀ y ∈ xs, y < 5))
- testable (x < 3 → (∀ y ∈ xs, y < 5))
                                     -: decidable (x < 3)
- testable (∀ y ∈ xs, y < 5)
                                     -: decidable (y < 5)
```

`sampleable (list ℕ)` lets us create random data of type `list ℕ` in a way that
helps find small counter-examples.  Next, the test of the proposition
hinges on `x < 3` and `y < 5` to both be decidable. The
implication between the two could be tested as a whole but it would be
less informative. Indeed, if we generate lists that only contain numbers
greater than `3`, the implication will always trivially hold but we should
conclude that we haven't found meaningful examples. Instead, when `x < 3`
does not hold, we reject the example (i.e.  we do not count it toward
the 100 required positive examples) and we start over. Therefore, when
`slim_check` prints `Success`, it means that a hundred suitable lists
were found and successfully tested.

If no counter-examples are found, `slim_check` behaves like `admit`.

`slim_check` can also be invoked using `#eval`:

```lean
#eval slim_check.testable.check (∀ (α : Type) (xs ys : list α), xs ++ ys = ys ++ xs)
-- ===================
-- Found problems!

-- α := ℤ
-- xs := [-4]
-- ys := [1]
-- -------------------
```

For more information on writing your own `sampleable` and `testable`
instances, see `testing.slim_check.testable`.
-/

namespace Tactic.Interactive

open Tactic SlimCheck

initialize
  registerTraceClass.1 `slim_check.instance

initialize
  registerTraceClass.1 `slim_check.decoration

initialize
  registerTraceClass.1 `slim_check.discarded

initialize
  registerTraceClass.1 `slim_check.success

initialize
  registerTraceClass.1 `slim_check.shrink.steps

initialize
  registerTraceClass.1 `slim_check.shrink.candidates

open Expr

/-- Tree structure representing a `testable` instance. -/
unsafe inductive instance_tree
  | node : Name → expr → List instance_tree → instance_tree
#align tactic.interactive.instance_tree tactic.interactive.instance_tree

/-- Gather information about a `testable` instance. Given
an expression of type `testable ?p`, gather the
name of the `testable` instances that it is built from
and the proposition that they test. -/
unsafe def summarize_instance : expr → tactic instance_tree
  | lam n bi d b => do
    let v ← mk_local' n bi d
    summarize_instance <| b v
  | e@(app f x) => do
    let q(Testable $(p)) ← infer_type e
    let xs ← e.get_app_args.filterMapM (try_core ∘ summarize_instance)
    pure <| instance_tree.node e p xs
  | e => do
    failed
#align tactic.interactive.summarize_instance tactic.interactive.summarize_instance

/-- format a `instance_tree` -/
unsafe def instance_tree.to_format : instance_tree → tactic format
  | instance_tree.node n p xs => do
    let xs ← format.join <$> xs.mapM fun t => flip format.indent 2 <$> instance_tree.to_format t
    let ys ← f!"testable ({← p})"
    f!"+ {(← n)} :{(← format.indent ys 2)}
        {← xs}"
#align tactic.interactive.instance_tree.to_format tactic.interactive.instance_tree.to_format

unsafe instance instance_tree.has_to_tactic_format : has_to_tactic_format instance_tree :=
  ⟨instance_tree.to_format⟩
#align tactic.interactive.instance_tree.has_to_tactic_format tactic.interactive.instance_tree.has_to_tactic_format

/-- `slim_check` considers a proof goal and tries to generate examples
that would contradict the statement.

Let's consider the following proof goal.

```lean
xs : list ℕ,
h : ∃ (x : ℕ) (H : x ∈ xs), x < 3
⊢ ∀ (y : ℕ), y ∈ xs → y < 5
```

The local constants will be reverted and an instance will be found for
`testable (∀ (xs : list ℕ), (∃ x ∈ xs, x < 3) → (∀ y ∈ xs, y < 5))`.
The `testable` instance is supported by an instance of `sampleable (list ℕ)`,
`decidable (x < 3)` and `decidable (y < 5)`.

Examples will be created in ascending order of size (more or less)

The first counter-examples found will be printed and will result in an error:

```
===================
Found problems!

xs := [1, 28]
x := 1
y := 28
-------------------
```

If `slim_check` successfully tests 100 examples, it acts like
admit. If it gives up or finds a counter-example, it reports an error.

For more information on writing your own `sampleable` and `testable`
instances, see `testing.slim_check.testable`.

Optional arguments given with `slim_check_cfg`
* `num_inst` (default 100): number of examples to test properties with
* `max_size` (default 100): final size argument
* `enable_tracing` (default `ff`): enable the printing of discarded samples

Options:
* `set_option trace.slim_check.decoration true`: print the proposition with quantifier annotations
* `set_option trace.slim_check.discarded true`: print the examples discarded because they do not
  satisfy assumptions
* `set_option trace.slim_check.shrink.steps true`: trace the shrinking of counter-example
* `set_option trace.slim_check.shrink.candidates true`: print the lists of candidates considered
  when shrinking each variable
* `set_option trace.slim_check.instance true`: print the instances of `testable` being used to test
  the proposition
* `set_option trace.slim_check.success true`: print the tested samples that satisfy a property
-/
unsafe def slim_check (cfg : SlimCheckCfg := { }) : tactic Unit := do
  let tgt ← retrieve <| tactic.revert_all >> target
  let tgt' := tactic.add_decorations tgt
  let cfg :=
    {
      cfg with
      traceDiscarded := cfg.traceDiscarded || is_trace_enabled_for `slim_check.discarded
      traceShrink := cfg.traceShrink || is_trace_enabled_for `slim_check.shrink.steps
      traceShrinkCandidates :=
        cfg.traceShrinkCandidates || is_trace_enabled_for `slim_check.shrink.candidates
      traceSuccess := cfg.traceSuccess || is_trace_enabled_for `slim_check.success }
  let inst ←
    mk_app `` testable [tgt'] >>= mk_instance <|>
        throwError "Failed to create a `testable` instance for `{(← tgt)}`.
          What to do:
          1. make sure that the types you are using have `slim_check.sampleable` instances
             (you can use `#sample my_type` if you are unsure);
          2. make sure that the relations and predicates that your proposition use are decidable;
          3. make sure that instances of `slim_check.testable` exist that, when combined,
             apply to your decorated proposition:
          ```
          {(← tgt')}
          ```

          Use `set_option trace.class_instances true` to understand what instances are missing.

          Try this:
          set_option trace.class_instances true
          #check (by apply_instance : slim_check.testable ({← tgt'}))"
  let e ← mk_mapp `` testable.check [tgt, q(cfg), tgt', inst]
  when_tracing `slim_check.decoration
      (← do
        dbg_trace "[testable decoration]
            {← tgt'}")
  when_tracing `slim_check.instance do
      let inst ← summarize_instance inst >>= pp
      ← do
          dbg_trace "
            [testable instance]{← format.indent inst 2}"
  let code ← eval_expr (Io PUnit) e
  unsafe_run_io code
  tactic.admit
#align tactic.interactive.slim_check tactic.interactive.slim_check

end Tactic.Interactive


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Proof of the end-to-end correctness theorem for the variational autoencoder: that
backpropagation on AEVB samples correct gradients for the naive variational autoencoder
we started with.
-/
import .util .graph .prog .grads_correct .transformations ..prove_model_ok ..backprop_correct

set_option profiler true

namespace certigrad
namespace aevb

open graph list tactic certigrad.tactic

#print "proving aevb_backprop_correct_for_naive_aevb..."

theorem aevb_backprop_correct_for_naive_aevb (a : arch) (ws : weights a) (x_data : T [a^.n_in, a^.n_x]) :

let g₀ : graph := naive_aevb a x_data,
    g_aevb : graph := reparam (integrate_kl g₀),
    fdict : env := mk_input_dict ws x_data g₀ in

∀ (tgt : reference) (idx : ℕ) (H_at_idx : at_idx g₀^.targets idx tgt),
∇ (λ θ₀, E (graph.to_dist (λ m, ⟦sum_costs m g₀^.costs⟧) (env.insert tgt θ₀ fdict) g₀^.nodes) dvec.head) (env.get tgt fdict)
=
E (graph.to_dist (λ m, backprop g_aevb^.costs g_aevb^.nodes m g_aevb^.targets) fdict g_aevb^.nodes)
  (λ dict, dvec.get tgt.2 dict idx) :=

begin
whnf_target, intros tgt idx H_at_idx,
simp only [@aevb_transformations_sound a ws x_data tgt idx H_at_idx],
apply backprop_correct_on_aevb,
rw [naive_aevb_as_graph] at H_at_idx, rw [naive_aevb_as_graph],
exact H_at_idx
end

end aevb
end certigrad


import data.list.chain data.int.basic tactic

variables {α : Type*}

open list

def reduced (l : list (α × ℤ)) : Prop :=
l.chain' (λ a b, a.1 ≠ b.1) ∧ ∀ a : α × ℤ, a ∈ l → a.2 ≠ 0

@[simp] lemma reduced_nil : reduced ([] : list (α × ℤ)) :=
⟨list.chain'_nil, λ _, false.elim⟩

lemma reduced_of_reduced_cons {a : α × ℤ} {l : list (α × ℤ)}
  (h : reduced (a :: l)) : reduced l :=
⟨(list.chain'_cons'.1 h.1).2, λ b hb, h.2 _ (mem_cons_of_mem _ hb)⟩

lemma reduced_cons_of_reduced_cons {a : α} {i j : ℤ} {l : list (α × ℤ)}
  (h : reduced ((a, i) :: l)) (hj : j ≠ 0) : reduced ((a, j) :: l) :=
⟨chain'_cons'.2 (chain'_cons'.1 h.1),
  begin
    rintros ⟨b, k⟩ hb,
    cases (mem_cons_iff _ _ _).1 hb with hb hb,
    { cc },
    { exact h.2 _ (mem_cons_of_mem _ hb) }
  end⟩

lemma reduced_cons_cons {a b : α} {i j : ℤ} {l : list (α × ℤ)} (hab : a ≠ b) (hi : i ≠ 0)
  (hbl : reduced ((b, j) :: l)) : reduced ((a, i) :: (b, j) :: l) :=
⟨chain'_cons.2 ⟨hab, hbl.1⟩,
  begin
    rintros ⟨c, k⟩ hc,
    cases (mem_cons_iff _ _ _).1 hc with hc hc,
    { cc },
    { exact hbl.2 _ hc }
  end⟩

lemma reduced_reverse {l : list (α × ℤ)} (h : reduced l) : reduced l.reverse :=
⟨chain'_reverse.2 $ by {convert h.1, simp [function.funext_iff, eq_comm] },
  by simpa using h.2⟩

@[simp] lemma reduced_reverse_iff {l : list (α × ℤ)} : reduced l.reverse ↔ reduced l :=
⟨λ h, by convert reduced_reverse h; simp, reduced_reverse⟩

variable (α)
def free_group : Type* := {l : list (α × ℤ) // reduced l}

namespace free_group

instance : has_one (free_group α) := ⟨⟨[], trivial, by simp⟩⟩

variables {α} [decidable_eq α]

def rcons : α × ℤ → list (α × ℤ) → list (α × ℤ)
| a []     := [a]
| a (b::l) :=
  if a.1 = b.1
    then let k := a.2 + b.2 in
      if k = 0
        then l
        else (a.1, k) :: l
    else a :: b :: l

def rconcat (a : α × ℤ) (l : list (α × ℤ)) : list (α × ℤ) :=
(rcons a l.reverse).reverse

lemma reduced_rcons : ∀ {a : α × ℤ} {l : list (α × ℤ)},
  a.2 ≠ 0 → reduced l → reduced (rcons a l)
| (a, i) []            ha h := ⟨list.chain'_singleton _, by simp [rcons]; cc⟩
| (a, i) ((b, j) :: l) ha h := begin
  simp [rcons],
  split_ifs,
  { exact reduced_of_reduced_cons h },
  { subst h_1,
    exact reduced_cons_of_reduced_cons h h_2 },
  { exact reduced_cons_cons h_1 ha h }
end

lemma reduced_rconcat  {a : α × ℤ} {l : list (α × ℤ)}
  (ha : a.2 ≠ 0) (hl : reduced l) : reduced (rconcat a l) :=
begin
  rw [rconcat, reduced_reverse_iff],
  exact reduced_rcons ha (reduced_reverse hl)
end

lemma reduced_reduce : ∀ l : list (α × ℤ), reduced (reduce l)
| []     := reduced_nil
| [a]    := begin simp [reduced, reduce], end
| (a::l) := begin
  rw reduce,
  split_ifs,
  { exact reduced_reduce l },
  { exact reduced_rcons h (reduced_reduce l) }
end

lemma rcons_eq_cons : ∀ {a : α × ℤ} {l : list (α × ℤ)},
  reduced (a :: l) → rcons a l = a :: l
| a []     h := rfl
| a (b::l) h := if_neg (chain'_cons.1 h.1).1

lemma rconcat_eq_concat  {a : α × ℤ} {l : list (α × ℤ)}
  (h : reduced (l ++ [a])) : rconcat a l = l ++ [a] :=
begin
  rw [rconcat, rcons_eq_cons], simp,
  convert reduced_reverse h, simp,
end

lemma rcons_reduce_eq_reduce_cons : ∀ {a : α × ℤ} {l : list (α × ℤ)},
  a.2 ≠ 0 → rcons a (reduce l) = reduce (a :: l)
| a []     ha := by simp [rcons, reduce, ha]
| a (b::l) ha := begin
  rw [reduce],
  split_ifs,
  { rw [reduce, if_neg ha, reduce, if_pos h] },
  { rw [reduce, if_neg ha, reduce, if_neg h] }
end

inductive rel : list (α × ℤ) → list (α × ℤ) → Prop
| refl : ∀ l, rel l l
| zero : ∀ {a : α}, rel [(a, 0)] []
| add : ∀ {a i j}, rel [(a, i), (a, j)] [(a, i + j)]
| append : ∀ {l₁ l₂ l₃ l₄}, rel l₁ l₂ → rel l₃ l₄ → rel (l₁ ++ l₃) (l₂ ++ l₄)
| symm : ∀ {l₁ l₂}, rel l₁ l₂ → rel l₂ l₁
| trans : ∀ {l₁ l₂ l₃}, rel l₁ l₂ → rel l₂ l₃ → rel l₁ l₃

attribute [refl] rel.refl
attribute [symm] rel.symm
attribute [trans] rel.trans

-- @[refl] lemma rel.refl : ∀ l : list (α × ℤ), rel l l := sorry

lemma rel_rcons_cons : ∀ (a : α × ℤ) (l : list (α × ℤ)),
  rel (rcons a l) (a::l)
| a [] := rel.refl _
| (a, i) ((b,j)::l) := begin
  rw rcons,
  split_ifs,
  { replace h : a = b := h, subst h,
    show rel ([] ++ l) ([(a,i), (a, j)]  ++ l),
    refine rel.append _ (rel.refl _),
    symmetry,
    exact rel.add.trans (h_1.symm ▸ rel.zero) },
  { replace h : a = b := h, subst h,
    show rel ([(a, i + j)] ++ l) ([(a, i), (a, j)] ++ l),
    exact rel.append rel.add.symm (rel.refl _) },
  { refl },
end

lemma rel_cons_of_rel {l₁ l₂ : list (α × ℤ)} (h : rel l₁ l₂) (a : α × ℤ) :
  rel (a :: l₁) (a :: l₂) :=
show rel ([a] ++ l₁) ([a] ++ l₂), from rel.append (rel.refl _) h

lemma rel_rcons_cons_of_rel {a : α × ℤ} {l₁ l₂ : list (α × ℤ)} (h : rel l₁ l₂) :
  rel (rcons a l₁) (a ::l₂) :=
(rel_rcons_cons a l₁).trans (rel_cons_of_rel h _)

lemma rel_reduce : ∀ l : list (α × ℤ), rel l (reduce l)
| [] := rel.refl _
| ((a, i)::l) := begin
  rw reduce,
  split_ifs,
  { replace h : i = 0 := h, subst h,
    show rel ([(a, 0)] ++ l) ([] ++ reduce l),
    exact rel.append rel.zero (rel_reduce _) },
  { exact (rel_rcons_cons_of_rel (rel_reduce _).symm).symm }
end

lemma reduce_eq_reduce_of_rel {l₁ l₂ : list (α × ℤ)} (h : rel l₁ l₂) : reduce l₁ = reduce l₂ :=
begin
  induction h,
  { refl },
  { simp [reduce] },
  { simp only [reduce],
    split_ifs,
    { refl },
    { simp * at * },
    { exfalso, omega },
    { simp [rcons, *] },
    { exfalso, omega },
    { simp [rcons, *] },
    { simp [rcons, *] },
    { simp [rcons, *] } },
  {  }

end

lemma reduce_eq_self_of_reduced : ∀ {l : list (α × ℤ)}, reduced l → reduce l = l
| []     h := rfl
| (a::l) h := by rw [← rcons_reduce_eq_reduce_cons (h.2 a (mem_cons_self _ _)),
    reduce_eq_self_of_reduced (reduced_of_reduced_cons h), rcons_eq_cons h]

lemma rcons_eq_reduce_cons {a : α × ℤ} {l : list (α × ℤ)}
  (ha : a.2 ≠ 0) (hl : reduced l) : rcons a l = reduce (a :: l) :=
by rw [← rcons_reduce_eq_reduce_cons ha, reduce_eq_self_of_reduced hl]

@[simp] lemma reduce_reduce (l : list (α × ℤ)) : reduce (reduce l) = reduce l :=
reduce_eq_self_of_reduced (reduced_reduce l)

lemma reduce_cons_reduce_eq_reduce_cons (a : α × ℤ) (l : list (α × ℤ)) :
  reduce (a :: reduce l) = reduce (a :: l)  :=
if ha : a.2 = 0 then by rw [reduce, if_pos ha, reduce, if_pos ha, reduce_reduce]
else by rw [← rcons_reduce_eq_reduce_cons ha, ← rcons_reduce_eq_reduce_cons ha,
    reduce_reduce]

lemma reduce_reduce_concat_eq_reduce_concat  : ∀ (l : list (α × ℤ)), ∀ (a : α × ℤ),
  reduce (reduce l ++ [a]) = reduce (l ++ [a])
| [] a := rfl
| [a] b := begin simp [reduce], split_ifs; simp [reduce, *, rcons] end
| (a::b::l) c := begin
  simp only [reduce, cons_append],
  split_ifs,
  { exact reduce_reduce_concat_eq_reduce_concat _ _ },
  { rw [rcons_eq_reduce_cons h_1 (reduced_reduce _),
      reduce_reduce_concat_eq_reduce_concat,
      rcons_eq_reduce_cons h_1 (reduced_reduce _),
      cons_append, ← reduce_cons_reduce_eq_reduce_cons,
      reduce_reduce_concat_eq_reduce_concat] },
  { rw [rcons_eq_reduce_cons h (reduced_reduce _),
      reduce_reduce_concat_eq_reduce_concat,
      rcons_eq_reduce_cons h (reduced_reduce _),
      cons_append, ← reduce_cons_reduce_eq_reduce_cons,
      reduce_reduce_concat_eq_reduce_concat] },
  { rw [rcons_eq_reduce_cons h (reduced_rcons h_1 (reduced_reduce _)),
      rcons_eq_reduce_cons h_1 (reduced_reduce _),
      rcons_eq_reduce_cons h (reduced_rcons h_1 (reduced_reduce _)),
      rcons_eq_reduce_cons h_1 (reduced_reduce _),
      reduce_cons_reduce_eq_reduce_cons,
      reduce_cons_reduce_eq_reduce_cons,
      ← reduce_reduce_concat_eq_reduce_concat l c,
      ← reduce_cons_reduce_eq_reduce_cons], }

end
-- list.reverse_rec_on l (by simp [reduce])
-- begin
--   assume l b ih a,

-- end
-- begin
--   intro a,
--   induction l with b l ih generalizing a,
--   { simp [reduce] },
--   { simp [reduce],
--     split_ifs,
--     { exact ih a },
--     {  } }

-- end

lemma reduce_reduce_append_eq_reduce_append : ∀ {l₁ l₂ : list (α × ℤ)},
  reduce (l₁ ++ reduce l₂) = reduce (l₁ ++ l₂)
| []      l₂ := by simp
| (a::l₁) l₂ := by rw [cons_append, ← reduce_cons_reduce_eq_reduce_cons,
    reduce_reduce_append_eq_reduce_append,
    reduce_cons_reduce_eq_reduce_cons, cons_append]

lemma reduce_reduce_append_eq_reduce_append' : ∀ (l₁ l₂ : list (α × ℤ)),
  reduce (reduce l₁ ++ l₂) = reduce (l₁ ++ l₂)
| l₁ []         := by simp
| l₁ [a]        := begin  end
| l₁ (a::b::l₂) := show reduce (reduce l₁ ++ ([a] ++ (b::l₂))) = reduce (l₁ ++ a :: b::l₂),
begin
  rw [← append_assoc, ← reduce_reduce_append_eq_reduce_append' _ (b :: l₂),
    reduce_reduce_append_eq_reduce_append' l₁ [a],
    reduce_reduce_append_eq_reduce_append'],
  simp
end
using_well_founded { rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ x, list.length x.2)⟩] }

lemma reduce_reverse : ∀ {l : list (α × ℤ)}, reduce (reverse l) = reverse (reduce l)
| [] := rfl
| [a] := begin
  simp [reduce],
  split_ifs; simp [reduce_cons],
end
| (a::b::l) := begin
  rw [reduce],
  split_ifs,

end

lemma reduce_reduce_cons : ∀ (a : α × ℤ) (l : list (α × ℤ)),
  reduce (reduce_cons a l) = reduce (a :: l)
| a [] := rfl
| a (b::l) := begin
  simp [reduce, reduce_cons],
  split_ifs,
  { refl },
  { exfalso, omega },
  { exfalso, omega },
  { rw [reduce_cons_reduce_eq_reduce_cons h_3,
      reduce_cons_reduce_eq_reduce_cons h_2],
       }

end

def mul_aux : list (α × ℤ) → list (α × ℤ) → list (α × ℤ)
| []        l₂ := l₂
| (a :: l₁) l₂ := reduce_cons a (mul_aux l₁ l₂)

lemma mul_aux_reduced : ∀ {l₁ l₂ : list (α × ℤ)}, reduced l₁ →
  reduced l₂ → reduced (mul_aux l₁ l₂)
| []      l₂ _  h  := h
| (a::l₁) l₂ h₁ h₂ := reduced_reduce_cons
  (h₁.2 _ (mem_cons_self _ _))
  (mul_aux_reduced (reduced_of_reduced_cons h₁) h₂)

lemma mul_aux_eq_reduce_append : ∀ {l₁ l₂ : list (α × ℤ)}, reduced l₁ →
  reduced l₂ → mul_aux l₁ l₂ = reduce (l₁ ++ l₂)
| []      l₂ _  h  := by simp [reduce, mul_aux, reduce_eq_self_of_reduced h]
| (a::l₁) l₂ h₁ h₂ :=
  by rw [mul_aux, mul_aux_eq_reduce_append (reduced_of_reduced_cons h₁) h₂,
    reduce_cons_reduce_eq_reduce_cons (h₁.2 a (mem_cons_self _ _)), cons_append]

lemma reduce_cons_append : ∀ {a b : α × ℤ} {l₁ l₂ : list (α × ℤ)},
  reduce_cons a ((b::l₁) ++ l₂) = reduce_cons a (b::l₁) ++ l₂
| a b [] l₂ := begin
  simp [reduce_cons], split_ifs; simp
end
| a b (c::l₁) l₂ := begin
  rw [cons_append, reduce_cons],
  dsimp,
  split_ifs,
  { simp [reduce_cons, *] },
  { simp [reduce_cons, *] },
  { simp [reduce_cons, *] }
end

lemma mul_aux_reduce_cons : ∀ (a : α) (i : ℤ) (hi : i ≠ 0), ∀ l₁ l₂ : list (α × ℤ),
  reduced l₁ → reduced l₂ → mul_aux (reduce_cons (a, i) l₁) l₂ =
  reduce_cons (a, i) (mul_aux l₁ l₂)
| a i hi []      l₂ h₁ h₂ := rfl
| a i hi ((b, j)::l₁) l₂ h₁ h₂ := begin
  conv_rhs {  },
  rw [mul_aux, reduce_cons_eq_reduce_cons (show (a, i).snd ≠ 0, from hi) h₁,
    reduce_cons_eq_reduce_cons, ← mul_aux_reduce_cons],

end

-- lemma mul_aux_assoc {l₁ l₂ l₃ : list (α × ℤ)} (h₁ : reduced l₁) (h₂ : reduced l₂) (h₃ : reduced l₃) :
--   mul_aux (mul_aux l₁ l₂) l₃ = mul_aux l₁ (mul_aux l₂ l₃) :=
-- begin
--   rw [mul_aux_eq_reduce_append (mul_aux_reduced h₁ h₂) h₃,
--     mul_aux_eq_reduce_append h₁ h₂],

-- end

instance : has_mul (free_group α) :=
⟨λ a b : free_group α, ⟨mul_aux a.1 b.1, mul_aux_reduced a.2 b.2⟩⟩

lemma reduce_cons_reduce_cons {a : α} {i j : ℤ} : ∀ {l : list (α × ℤ)},
  i + j = 0 → reduce_cons (a, i) (reduce_cons (a, j) l) = l
| []            hij := by simp [reduce_cons, hij]
| [(c, k)] hij := begin  simp [reduce_cons], split_ifs;
  simp [reduce_cons, add_comm j, add_eq_zero_iff_eq_neg, *] at *,
 end

lemma reduce_cons_reduce_cons {a b : α} {i j : ℤ} : ∀ {l : list (α × ℤ)},
  reduced l → i ≠ 0 → j ≠ 0 → reduce_cons (a, i) (reduce_cons (b, j) l) =
  if a = b
    then if i + j = 0
      then l
      else reduce_cons (a, i + j) l
    else (a, i) :: reduce_cons (b, j)
| []       hl hi hj := begin
  split_ifs,
  simp [reduce_cons, *],
  simp,
end

lemma mul_aux_reduce_cons (a : α) (i : ℤ) : ∀ l₁ l₂ : list (α × ℤ),
  reduced l₁ → reduced l₂ → mul_aux (reduce_cons (a, i) l₁) l₂ =
  reduce_cons (a, i) (mul_aux l₁ l₂)
| []        l₂ h₁ h₂:= rfl
| ((b, j) :: l₁) l₂ h₁ h₂ :=
  begin
    rw [mul_aux, reduce_cons],
    dsimp only,
    split_ifs,
    sorry,

  end
| [(b, j)]       [] h₁ h₂ := begin
    simp [mul_aux, reduce_cons],
    split_ifs,
    { refl },
    { refl },
    { simp [mul_aux, reduce_cons, h] }
  end
|
| [(b, j)] [(c, k)] ⟨h₁c, h₁0⟩ ⟨h₂c, h₂0⟩ := begin
    simp [mul_aux, reduce_cons],
    split_ifs,
    { simp [mul_aux, reduce_cons, *], omega },
    { simp [mul_aux, reduce_cons, h],
      split_ifs,
      { have := h₂0 (c, k) (mem_singleton_self _),
        omega },
      {  } }

  end

lemma mul_aux_assoc (l₁ l₂ l₃ : list (α × ℤ)) (h₁ : reduced l₁) (h₂ : reduced l₂) (h₃ : reduced l₃) :
  mul_aux (mul_aux l₁ l₂) l₃ = mul_aux l₁ (mul_aux l₂ l₃) :=
begin
  repeat { rw mul_aux_eq_reduce_append },
  rw [reduce_reduce_append_eq_reduce_append]
,
end

lemma mul_aux_assoc : ∀ (l₁ l₂ l₃ : list (α × ℤ)),
  mul_aux (mul_aux l₁ l₂) l₃ = mul_aux l₁ (mul_aux l₂ l₃)
| []      l₂ l₃ := rfl
| (a::l₁) l₂ l₃ := begin
  simp [mul_aux],

end

def inv_aux (l : list (α × ℤ)) : list (α × ℤ) :=
l.reverse.map (λ a, (a.1, -a.2))

lemma reduced_inv_aux {l : list (α × ℤ)} (ha : reduced l) : reduced (inv_aux l) :=
⟨(list.chain'_map _).2 (list.chain'_reverse.2 begin
  convert ha, simp [function.funext_iff, eq_comm]
end), begin simp [inv_aux, eq_comm] , end⟩

-- instance : has_inv (free_group α) :=
-- ⟨λ a, ⟨inv_aux a.1, reduced_inv_aux a.2⟩⟩

-- lemma mul_aux_assoc : ∀ l₁ l₂ l₃ : list (α × ℤ),
--   mul_aux (mul_aux l₁ l₂) l₃ = mul_aux l₁ (mul_aux l₂ l₃)
-- | [] l₂ l₃ := by simp
-- | l₁ [] l₃ := by simp
-- | l₁ l₂ [] := by simp
-- | [(a, i)] [(b, j)] ((c, k) :: l₃) := begin
--   simp with mul_aux,
--   split_ifs; simp [*, add_assoc] with mul_aux at *,
-- end
-- | [(a, i)] ((b, j) :: (c, k) :: l₂) l₃ :=
-- begin
--   simp with mul_aux,
--   split_ifs; simp * with mul_aux
-- end
-- | [(a, i), (b, j)] ((c, k) :: l₂) ((d, l) :: l₃) :=
-- begin
--   simp with mul_aux,
--   split_ifs; simp [*, add_assoc, ← mul_aux_assoc] with mul_aux at *
-- end
-- | ((a, i) :: (b, j) :: (c, k) :: l₁) l₂ l₃ :=
-- begin
--   simp only with mul_aux,
--   rw [← mul_aux_cons_cons, mul_aux_assoc],
--   simp with mul_aux
-- end

-- lemma mul_aux_inv_aux_cancel : ∀ l₁ : list (α × ℤ),
--   mul_aux l₁ (inv_aux l₁) = []
-- | []       := rfl
-- | [(a, i)] := by simp [inv_aux] with mul_aux
-- | ((a, i) :: (b, j) :: l) := begin
--   rw [inv_aux, list.reverse_cons, list.reverse_cons, list.map_append,
--     list.map_append, list.map_singleton, list.map_singleton,
--     mul_aux_cons_cons],

-- end

end free_group


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.homology.exact
import category_theory.types
import category_theory.limits.shapes.biproducts

/-!
# Projective objects and categories with enough projectives

An object `P` is called projective if every morphism out of `P` factors through every epimorphism.

A category `C` has enough projectives if every object admits an epimorphism from some
projective object.

`projective.over X` picks an arbitrary such projective object,
and `projective.π X : projective.over X ⟶ X` is the corresponding epimorphism.

Given a morphism `f : X ⟶ Y`, `projective.left f` is a projective object over `kernel f`,
and `projective.d f : projective.left f ⟶ X` is the morphism `π (kernel f) ≫ kernel.ι f`.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v u

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

/--
An object `P` is called projective if every morphism out of `P` factors through every epimorphism.
-/
class projective (P : C) : Prop :=
(factors : ∀ {E X : C} (f : P ⟶ X) (e : E ⟶ X) [epi e], ∃ f', f' ≫ e = f)

section

/--
A projective presentation of an object `X` consists of an epimorphism `f : P ⟶ X`
from some projective object `P`.
-/
@[nolint has_inhabited_instance]
structure projective_presentation (X : C) :=
(P : C)
(projective : projective P . tactic.apply_instance)
(f : P ⟶ X)
(epi : epi f . tactic.apply_instance)

variables (C)

/-- A category "has enough projectives" if for every object `X` there is a projective object `P` and
    an epimorphism `P ↠ X`. -/
class enough_projectives : Prop :=
(presentation : ∀ (X : C), nonempty (projective_presentation X))

end

namespace projective

/--
An arbitrarily chosen factorisation of a morphism out of a projective object through an epimorphism.
-/
def factor_thru {P X E : C} [projective P] (f : P ⟶ X) (e : E ⟶ X) [epi e] : P ⟶ E :=
(projective.factors f e).some

@[simp] lemma factor_thru_comp {P X E : C} [projective P] (f : P ⟶ X) (e : E ⟶ X) [epi e] :
  factor_thru f e ≫ e = f :=
(projective.factors f e).some_spec

section
open_locale zero_object

instance zero_projective [has_zero_object C] [has_zero_morphisms C] : projective (0 : C) :=
{ factors := λ E X f e epi, by { use 0, ext, }}

end

lemma of_iso {P Q : C} (i : P ≅ Q) (hP : projective P) : projective Q :=
begin
  fsplit,
  introsI E X f e e_epi,
  obtain ⟨f', hf'⟩ := projective.factors (i.hom ≫ f) e,
  exact ⟨i.inv ≫ f', by simp [hf']⟩
end

lemma iso_iff {P Q : C} (i : P ≅ Q) : projective P ↔ projective Q :=
⟨of_iso i, of_iso i.symm⟩

/-- The axiom of choice says that every type is a projective object in `Type`. -/
instance (X : Type u) : projective X :=
{ factors := λ E X' f e epi,
  ⟨λ x, ((epi_iff_surjective _).mp epi (f x)).some,
  by { ext x, exact ((epi_iff_surjective _).mp epi (f x)).some_spec, }⟩ }

instance Type.enough_projectives : enough_projectives (Type u) :=
{ presentation := λ X, ⟨{ P := X, f := 𝟙 X, }⟩, }

instance {P Q : C} [has_binary_coproduct P Q] [projective P] [projective Q] :
  projective (P ⨿ Q) :=
{ factors := λ E X' f e epi, by exactI
  ⟨coprod.desc (factor_thru (coprod.inl ≫ f) e) (factor_thru (coprod.inr ≫ f) e), by tidy⟩, }

instance {β : Type v} (g : β → C) [has_coproduct g] [∀ b, projective (g b)] :
  projective (∐ g) :=
{ factors := λ E X' f e epi, by exactI
  ⟨sigma.desc (λ b, factor_thru (sigma.ι g b ≫ f) e), by tidy⟩, }

instance {P Q : C} [has_zero_morphisms C] [has_binary_biproduct P Q]
  [projective P] [projective Q] :
  projective (P ⊞ Q) :=
{ factors := λ E X' f e epi, by exactI
  ⟨biprod.desc (factor_thru (biprod.inl ≫ f) e) (factor_thru (biprod.inr ≫ f) e), by tidy⟩, }

instance {β : Type v} [decidable_eq β] (g : β → C) [has_zero_morphisms C] [has_biproduct g]
  [∀ b, projective (g b)] : projective (⨁ g) :=
{ factors := λ E X' f e epi, by exactI
  ⟨biproduct.desc (λ b, factor_thru (biproduct.ι g b ≫ f) e), by tidy⟩, }

section enough_projectives
variables [enough_projectives C]

/--
`projective.over X` provides an arbitrarily chosen projective object equipped with
an epimorphism `projective.π : projective.over X ⟶ X`.
-/
def over (X : C) : C :=
(enough_projectives.presentation X).some.P

instance projective_over (X : C) : projective (over X) :=
(enough_projectives.presentation X).some.projective

/--
The epimorphism `projective.π : projective.over X ⟶ X`
from the arbitrarily chosen projective object over `X`.
-/
def π (X : C) : over X ⟶ X :=
(enough_projectives.presentation X).some.f

instance π_epi (X : C) : epi (π X) :=
(enough_projectives.presentation X).some.epi

section
variables [has_zero_morphisms C] {X Y : C} (f : X ⟶ Y) [has_kernel f]

/--
When `C` has enough projectives, the object `projective.syzygies f` is
an arbitrarily chosen projective object over `kernel f`.
-/
@[derive projective]
def syzygies : C := over (kernel f)

/--
When `C` has enough projectives,
`projective.d f : projective.syzygies f ⟶ X` is the composition
`π (kernel f) ≫ kernel.ι f`.

(When `C` is abelian, we have `exact (projective.d f) f`.)
-/
abbreviation d : syzygies f ⟶ X :=
π (kernel f) ≫ kernel.ι f

end

end enough_projectives

end projective

open projective

section
variables [has_zero_morphisms C] [has_equalizers C] [has_images C]

/--
Given a projective object `P` mapping via `h` into
the middle object `R` of a pair of exact morphisms `f : Q ⟶ R` and `g : R ⟶ S`,
such that `h ≫ g = 0`, there is a lift of `h` to `Q`.
-/
def exact.lift {P Q R S : C} [projective P] (h : P ⟶ R) (f : Q ⟶ R) (g : R ⟶ S)
  [exact f g] (w : h ≫ g = 0) : P ⟶ Q :=
factor_thru
  (factor_thru
    (factor_thru_kernel_subobject g h w)
    (image_to_kernel f g (by simp)))
  (factor_thru_image_subobject f)

@[simp] lemma exact.lift_comp {P Q R S : C} [projective P] (h : P ⟶ R) (f : Q ⟶ R) (g : R ⟶ S)
  [exact f g] (w : h ≫ g = 0) : exact.lift h f g w ≫ f = h :=
begin
  simp [exact.lift],
  conv_lhs { congr, skip, rw ← image_subobject_arrow_comp f, },
  rw [←category.assoc, factor_thru_comp, ←image_to_kernel_arrow,
    ←category.assoc, category_theory.projective.factor_thru_comp,
    factor_thru_kernel_subobject_comp_arrow],
end

end

end category_theory


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.finite_limits
import category_theory.limits.shapes.products
import category_theory.limits.shapes.terminal

/-!
# Categories with finite (co)products

Typeclasses representing categories with (co)products over finite indexing types.
-/

universes w v u

open category_theory
open_locale classical

namespace category_theory.limits

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

/--
A category has finite products if there is a chosen limit for every diagram
with shape `discrete J`, where we have `[fintype J]`.
-/
-- We can't simply make this an abbreviation, as we do with other `has_Xs` limits typeclasses,
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_products : Prop :=
(out (J : Type v) [fintype J] : has_limits_of_shape (discrete J) C)

instance has_limits_of_shape_discrete
  (J : Type v) [fintype J] [has_finite_products C] :
  has_limits_of_shape (discrete J) C :=
by { haveI := @has_finite_products.out C _ _ J, apply_instance }

/-- If `C` has finite limits then it has finite products. -/
@[priority 10]
instance has_finite_products_of_has_finite_limits [has_finite_limits C] : has_finite_products C :=
⟨λ J 𝒥, by { resetI, apply_instance }⟩

instance has_fintype_products [has_finite_products C] (ι : Type w) [fintype ι] :
  has_limits_of_shape (discrete ι) C :=
has_limits_of_shape_of_equivalence
  (discrete.equivalence
    ((show ulift.{v} (fin (fintype.card ι)) ≃ fin (fintype.card ι), by tidy).trans
      (fintype.equiv_fin ι).symm))

/-- We can now write this for powers. -/
noncomputable example [has_finite_products C] (X : C) : C := ∏ (λ (i : fin 5), X)

/--
If a category has all products then in particular it has finite products.
-/
lemma has_finite_products_of_has_products [has_products C] : has_finite_products C :=
⟨by apply_instance⟩

/--
A category has finite coproducts if there is a chosen colimit for every diagram
with shape `discrete J`, where we have `[fintype J]`.
-/
class has_finite_coproducts : Prop :=
(out (J : Type v) [fintype J] : has_colimits_of_shape (discrete J) C)

attribute [class] has_finite_coproducts

instance has_colimits_of_shape_discrete
  (J : Type v) [fintype J] [has_finite_coproducts C] :
  has_colimits_of_shape (discrete J) C :=
by { haveI := @has_finite_coproducts.out C _ _ J, apply_instance }

/-- If `C` has finite colimits then it has finite coproducts. -/
@[priority 10]
instance has_finite_coproducts_of_has_finite_colimits [has_finite_colimits C] :
  has_finite_coproducts C :=
⟨λ J 𝒥, by { resetI, apply_instance }⟩

instance has_fintype_coproducts [has_finite_coproducts C] (ι : Type w) [fintype ι] :
  has_colimits_of_shape (discrete ι) C :=
has_colimits_of_shape_of_equivalence
  (discrete.equivalence
    ((show ulift.{v} (fin (fintype.card ι)) ≃ fin (fintype.card ι), by tidy).trans
      (fintype.equiv_fin ι).symm))

/--
If a category has all coproducts then in particular it has finite coproducts.
-/
lemma has_finite_coproducts_of_has_coproducts [has_coproducts C] : has_finite_coproducts C :=
⟨by apply_instance⟩

end category_theory.limits


import Mathlib.Tactic.Ring
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Nat.Parity
import Mathlib.Algebra.Ring.Basic
import Mathlib.Algebra.Free

lemma l1 (x : Nat) : Xor' (Even x) (Odd x) := by simp

lemma l5 (q : Nat) : (Odd (q * q)) -> (Odd q) := by
  rw [← not_imp_not]
  simp
  intro hnp
  match (l1 (q * q)) with
  | Or.inl xi =>
    rw [Nat.even_iff_not_odd]
    apply And.right xi
  | Or.inr h1 =>
    rw [Nat.even_mul]
    tauto

theorem q3 (n : Nat) : (∃ q: Nat, q * q = 2 * n + 1) -> (∃ y: Nat, n + 1 = y * y + (y + 1) * (y + 1)) := by
  intro hq
  match hq with
  | ⟨q, y⟩ =>
    match (l5 q (Exists.intro n y)) with
    | ⟨r, hr⟩ =>
      conv at y =>
        simp
        rw [hr, right_distrib, one_mul, ← add_assoc,
            add_right_cancel_iff, mul_assoc, ← left_distrib]
        simp
      apply Exists.intro r
      rw [← y]
      ring

variable {α : Type u}
theorem a4 : (∀ x y : FreeMagma α, (x * (x * y) = y) ∧ ((y * x) * x = y)) -> (∀ x y : FreeMagma α, x * y = y * x) := by
  intro h1 x y
  rw [← (And.left (h1 y (x * y)))]
  conv in (y * (x * y)) =>
    arg 1
    rw [← And.left (h1 x y)]
  rw [And.right (h1 (x * y) x)]

def F (m n : Nat) : Nat :=
  match m, n with
    | 0, n => n + 1
    | m + 1, 0 => F m 1
    | m + 1, n + 1 => F m (F (m + 1) n)
  termination_by F m n => (m, n)

theorem q5 (m n: ℕ) : (F m n > n) := by
  revert n
  induction m with
  | zero =>
    intro n
    rw [F]
    simp
  | succ m ha =>
    intro n
    induction n with
    | zero =>
      have hb := ha 1
      apply Nat.lt_trans Nat.zero_lt_one hb
    | succ n hb =>
      have hc := ha (F (m + 1) n)
      have hd := Nat.succ_le_of_lt hb
      apply Nat.lt_of_le_of_lt hd hc

def main : IO Unit :=
  IO.println s!"Hello, world!"


import data.set.basic

open set

def equivalence_class {X : Type} (R : X → X → Prop) (x : X) := {y : X | R x y}

example (X : Type) (R : X → X → Prop) (hR : equivalence R) (x : X) : equivalence_class R x ≠ ∅ :=
begin
  sorry
end


/-
Copyright (c) 2021 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.monoidal.free.basic
import category_theory.discrete_category

/-!
# The monoidal coherence theorem

In this file, we prove the monoidal coherence theorem, stated in the following form: the free
monoidal category over any type `C` is thin.

We follow a proof described by Ilya Beylin and Peter Dybjer, which has been previously formalized
in the proof assistant ALF. The idea is to declare a normal form (with regard to association and
adding units) on objects of the free monoidal category and consider the discrete subcategory of
objects that are in normal form. A normalization procedure is then just a functor
`full_normalize : free_monoidal_category C ⥤ discrete (normal_monoidal_object C)`, where
functoriality says that two objects which are related by associators and unitors have the
same normal form. Another desirable property of a normalization procedure is that an object is
isomorphic (i.e., related via associators and unitors) to its normal form. In the case of the
specific normalization procedure we use we not only get these isomorphismns, but also that they
assemble into a natural isomorphism `𝟭 (free_monoidal_category C) ≅ full_normalize ⋙ inclusion`.
But this means that any two parallel morphisms in the free monoidal category factor through a
discrete category in the same way, so they must be equal, and hence the free monoidal category
is thin.

## References

* [Ilya Beylin and Peter Dybjer, Extracting a proof of coherence for monoidal categories from a
   proof of normalization for monoids][beylin1996]

-/

universe u

namespace category_theory
open monoidal_category

namespace free_monoidal_category

variables {C : Type u}

section
variables (C)

/-- We say an object in the free monoidal category is in normal form if it is of the form
    `(((𝟙_ C) ⊗ X₁) ⊗ X₂) ⊗ ⋯`. -/
@[nolint has_inhabited_instance]
inductive normal_monoidal_object : Type u
| unit : normal_monoidal_object
| tensor : normal_monoidal_object → C → normal_monoidal_object

end

local notation `F` := free_monoidal_category
local notation `N` := discrete ∘ normal_monoidal_object
local infixr ` ⟶ᵐ `:10 := hom

/-- Auxiliary definition for `inclusion`. -/
@[simp] def inclusion_obj : normal_monoidal_object C → F C
| normal_monoidal_object.unit := unit
| (normal_monoidal_object.tensor n a) := tensor (inclusion_obj n) (of a)

/-- The discrete subcategory of objects in normal form includes into the free monoidal category. -/
@[simp] def inclusion : N C ⥤ F C :=
discrete.functor inclusion_obj

/-- Auxiliary definition for `normalize`. -/
@[simp] def normalize_obj : F C → normal_monoidal_object C → normal_monoidal_object C
| unit n := n
| (of X) n := normal_monoidal_object.tensor n X
| (tensor X Y) n := normalize_obj Y (normalize_obj X n)

@[simp] lemma normalize_obj_unitor (n : N C) : normalize_obj (𝟙_ (F C)) n = n :=
rfl

@[simp] lemma normalize_obj_tensor (X Y : F C) (n : N C) :
  normalize_obj (X ⊗ Y) n = normalize_obj Y (normalize_obj X n) :=
rfl

section
open hom

/-- Auxiliary definition for `normalize`. Here we prove that objects that are related by
    associators and unitors map to the same normal form. -/
@[simp] def normalize_map_aux : Π {X Y : F C},
  (X ⟶ᵐ Y) →
    ((discrete.functor (normalize_obj X) : _ ⥤ N C) ⟶ discrete.functor (normalize_obj Y))
| _ _ (id _) := 𝟙 _
| _ _ (α_hom _ _ _) := ⟨λ X, 𝟙 _⟩
| _ _ (α_inv _ _ _) := ⟨λ X, 𝟙 _⟩
| _ _ (l_hom _) := ⟨λ X, 𝟙 _⟩
| _ _ (l_inv _) := ⟨λ X, 𝟙 _⟩
| _ _ (ρ_hom _) := ⟨λ X, 𝟙 _⟩
| _ _ (ρ_inv _) := ⟨λ X, 𝟙 _⟩
| X Y (@comp _ U V W f g) := normalize_map_aux f ≫ normalize_map_aux g
| X Y (@hom.tensor _ T U V W f g) :=
    ⟨λ X, (normalize_map_aux g).app (normalize_obj T X) ≫
      (discrete.functor (normalize_obj W) : _ ⥤ N C).map ((normalize_map_aux f).app X), by tidy⟩

end

section
variables (C)

/-- Our normalization procedure works by first defining a functor `F C ⥤ (N C ⥤ N C)` (which turns
    out to be very easy), and then obtain a functor `F C ⥤ N C` by plugging in the normal object
    `𝟙_ C`. -/
@[simp] def normalize : F C ⥤ N C ⥤ N C :=
{ obj := λ X, discrete.functor (normalize_obj X),
  map := λ X Y, quotient.lift normalize_map_aux (by tidy) }

/-- A variant of the normalization functor where we consider the result as an object in the free
    monoidal category (rather than an object of the discrete subcategory of objects in normal
    form). -/
@[simp] def normalize' : F C ⥤ N C ⥤ F C :=
normalize C ⋙ (whiskering_right _ _ _).obj inclusion

/-- The normalization functor for the free monoidal category over `C`. -/
def full_normalize : F C ⥤ N C :=
{ obj := λ X, ((normalize C).obj X).obj normal_monoidal_object.unit,
  map := λ X Y f, ((normalize C).map f).app normal_monoidal_object.unit }

/-- Given an object `X` of the free monoidal category and an object `n` in normal form, taking
    the tensor product `n ⊗ X` in the free monoidal category is functorial in both `X` and `n`. -/
@[simp] def tensor_func : F C ⥤ N C ⥤ F C :=
{ obj := λ X, discrete.functor (λ n, (inclusion.obj n) ⊗ X),
  map := λ X Y f, ⟨λ n, 𝟙 _ ⊗ f, by tidy⟩ }

lemma tensor_func_map_app {X Y : F C} (f : X ⟶ Y) (n) : ((tensor_func C).map f).app n =
  𝟙 _ ⊗ f :=
rfl

lemma tensor_func_obj_map (Z : F C) {n n' : N C} (f : n ⟶ n') :
  ((tensor_func C).obj Z).map f = inclusion.map f ⊗ 𝟙 Z :=
by tidy

/-- Auxiliary definition for `normalize_iso`. Here we construct the isomorphism between
    `n ⊗ X` and `normalize X n`. -/
@[simp] def normalize_iso_app :
  Π (X : F C) (n : N C), ((tensor_func C).obj X).obj n ≅ ((normalize' C).obj X).obj n
| (of X) n := iso.refl _
| unit n := ρ_ _
| (tensor X Y) n :=
    (α_ _ _ _).symm ≪≫ tensor_iso (normalize_iso_app X n) (iso.refl _) ≪≫ normalize_iso_app _ _

@[simp] lemma normalize_iso_app_tensor (X Y : F C) (n : N C) :
  normalize_iso_app C (X ⊗ Y) n =
  (α_ _ _ _).symm ≪≫ tensor_iso (normalize_iso_app C X n) (iso.refl _) ≪≫
    normalize_iso_app _ _ _ :=
rfl

@[simp] lemma normalize_iso_app_unitor (n : N C) : normalize_iso_app C (𝟙_ (F C)) n = ρ_ _ :=
rfl

/-- Auxiliary definition for `normalize_iso`. -/
@[simp] def normalize_iso_aux (X : F C) : (tensor_func C).obj X ≅ (normalize' C).obj X :=
nat_iso.of_components (normalize_iso_app C X) (by tidy)

/-- The isomorphism between `n ⊗ X` and `normalize X n` is natural (in both `X` and `n`, but
    naturality in `n` is trivial and was "proved" in `normalize_iso_aux`). This is the real heart
    of our proof of the coherence theorem. -/
def normalize_iso : tensor_func C ≅ normalize' C :=
nat_iso.of_components (normalize_iso_aux C)
begin
  rintros X Y f,
  apply quotient.induction_on f,
  intro f,
  ext n,
  induction f generalizing n,
  { simp only [mk_id, functor.map_id, category.id_comp, category.comp_id] },
  { dsimp,
    simp only [id_tensor_associator_inv_naturality_assoc, ←pentagon_inv_assoc,
      tensor_hom_inv_id_assoc, tensor_id, category.id_comp, discrete.functor_map_id, comp_tensor_id,
      iso.cancel_iso_inv_left, category.assoc],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    simp only [discrete.functor_map_id, comp_tensor_id, category.assoc, pentagon_inv_assoc,
      ←associator_inv_naturality_assoc, tensor_id, iso.cancel_iso_inv_left],
    dsimp, simp only [category.comp_id],},
  { dsimp,
    rw triangle_assoc_comp_right_assoc,
    simp only [discrete.functor_map_id, category.assoc],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    simp only [triangle_assoc_comp_left_inv_assoc, inv_hom_id_tensor_assoc, tensor_id,
      category.id_comp, discrete.functor_map_id],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    rw [←(iso.inv_comp_eq _).2 (right_unitor_tensor _ _), category.assoc, ←right_unitor_naturality],
    simp only [discrete.functor_map_id, iso.cancel_iso_inv_left, category.assoc],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    simp only [←(iso.eq_comp_inv _).1 (right_unitor_tensor_inv _ _), iso.hom_inv_id_assoc,
      right_unitor_conjugation, discrete.functor_map_id, category.assoc],
    dsimp, simp only [category.comp_id], },
  { dsimp at *,
    rw [id_tensor_comp, category.assoc, f_ih_g ⟦f_g⟧, ←category.assoc, f_ih_f ⟦f_f⟧, category.assoc,
      ←functor.map_comp],
    congr' 2 },
  { dsimp at *,
    rw associator_inv_naturality_assoc,
    slice_lhs 2 3 { rw [←tensor_comp, f_ih_f ⟦f_f⟧] },
    conv_lhs { rw [←@category.id_comp (F C) _ _ _ ⟦f_g⟧] },
    simp only [category.comp_id, tensor_comp, category.assoc],
    congr' 2,
    rw [←mk_tensor, quotient.lift_mk],
    dsimp,
    rw [functor.map_comp, ←category.assoc, ←f_ih_g ⟦f_g⟧, ←@category.comp_id (F C) _ _ _ ⟦f_g⟧,
      ←category.id_comp ((discrete.functor inclusion_obj).map _), tensor_comp],
    dsimp,
    simp only [category.assoc, category.comp_id],
    congr' 1,
    convert (normalize_iso_aux C f_Z).hom.naturality ((normalize_map_aux f_f).app n),
    exact (tensor_func_obj_map _ _ _).symm }
end

/-- The isomorphism between an object and its normal form is natural. -/
def full_normalize_iso : 𝟭 (F C) ≅ full_normalize C ⋙ inclusion :=
nat_iso.of_components
  (λ X, (λ_ X).symm ≪≫ ((normalize_iso C).app X).app normal_monoidal_object.unit)
  begin
    intros X Y f,
    dsimp,
    rw [left_unitor_inv_naturality_assoc, category.assoc, iso.cancel_iso_inv_left],
    exact congr_arg (λ f, nat_trans.app f normal_monoidal_object.unit)
      ((normalize_iso.{u} C).hom.naturality f),
  end

end

/-- The monoidal coherence theorem. -/
instance subsingleton_hom {X Y : F C} : subsingleton (X ⟶ Y) :=
⟨λ f g, have (full_normalize C).map f = (full_normalize C).map g, from subsingleton.elim _ _,
 begin
  rw [←functor.id_map f, ←functor.id_map g],
  simp [←nat_iso.naturality_2 (full_normalize_iso.{u} C), this]
 end⟩

section groupoid

section
open hom

/-- Auxiliary construction for showing that the free monoidal category is a groupoid. Do not use
    this, use `is_iso.inv` instead. -/
def inverse_aux : Π {X Y : F C}, (X ⟶ᵐ Y) → (Y ⟶ᵐ X)
| _ _ (id X) := id X
| _ _ (α_hom _ _ _) := α_inv _ _ _
| _ _ (α_inv _ _ _) := α_hom _ _ _
| _ _ (ρ_hom _) := ρ_inv _
| _ _ (ρ_inv _) := ρ_hom _
| _ _ (l_hom _) := l_inv _
| _ _ (l_inv _) := l_hom _
| _ _ (comp f g) := (inverse_aux g).comp (inverse_aux f)
| _ _ (hom.tensor f g) := (inverse_aux f).tensor (inverse_aux g)

end

instance : groupoid.{u} (F C) :=
{ inv := λ X Y, quotient.lift (λ f, ⟦inverse_aux f⟧) (by tidy),
  ..(infer_instance : category (F C)) }

end groupoid

end free_monoidal_category

end category_theory


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Scott Morrison
-/
import category_theory.preadditive
import category_theory.limits.shapes.biproducts

/-!
# Additive Functors

A functor between two preadditive categories is called *additive*
provided that the induced map on hom types is a morphism of abelian
groups.

An additive functor between preadditive categories creates and preserves biproducts.

# Implementation details

`functor.additive` is a `Prop`-valued class, defined by saying that
for every two objects `X` and `Y`, the map
`F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of abelian
groups.

# Project:

- Prove that a functor is additive if it preserves finite biproducts
  (See https://stacks.math.columbia.edu/tag/010M.)
-/

namespace category_theory

/-- A functor `F` is additive provided `F.map` is an additive homomorphism. -/
class functor.additive {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] (F : C ⥤ D) : Prop :=
(map_add' : Π {X Y : C} {f g : X ⟶ Y}, F.map (f + g) = F.map f + F.map g . obviously)

section preadditive

namespace functor

section
variables {C D : Type*} [category C] [category D] [preadditive C]
  [preadditive D] (F : C ⥤ D) [functor.additive F]

@[simp]

/-- `F.map_add_hom` is an additive homomorphism whose underlying function is `F.map`. -/
@[simps {fully_applied := ff}]
def map_add_hom {X Y : C} : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y) :=
add_monoid_hom.mk' (λ f, F.map f) (λ f g, F.map_add)

lemma coe_map_add_hom {X Y : C} : ⇑(F.map_add_hom : (X ⟶ Y) →+ _) = @map C _ D _ F X Y := rfl

@[simp]
lemma map_zero {X Y : C} : F.map (0 : X ⟶ Y) = 0 :=
F.map_add_hom.map_zero

instance : additive (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] (G : D ⥤ E) [functor.additive G] :
  additive (F ⋙ G) :=
{}

@[simp]
lemma map_neg {X Y : C} {f : X ⟶ Y} : F.map (-f) = - F.map f :=
F.map_add_hom.map_neg _

@[simp]
lemma map_sub {X Y : C} {f g : X ⟶ Y} : F.map (f - g) = F.map f - F.map g :=
F.map_add_hom.map_sub _ _

-- You can alternatively just use `functor.map_smul` here, with an explicit `(r : ℤ)` argument.
lemma map_zsmul {X Y : C} {f : X ⟶ Y} {r : ℤ} : F.map (r • f) = r • F.map f :=
F.map_add_hom.map_zsmul _ _

open_locale big_operators

@[simp]
lemma map_sum {X Y : C} {α : Type*} (f : α → (X ⟶ Y)) (s : finset α) :
  F.map (∑ a in s, f a) = ∑ a in s, F.map (f a) :=
(F.map_add_hom : (X ⟶ Y) →+ _).map_sum f s

open category_theory.limits
open_locale zero_object

/-- An additive functor takes the zero object to the zero object (up to isomorphism). -/
@[simps]
def map_zero_object [has_zero_object C] [has_zero_object D] : F.obj 0 ≅ 0 :=
{ hom := 0,
  inv := 0,
  hom_inv_id' := by { rw ←F.map_id, simp, } }

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] (F : C → D)

instance induced_functor_additive : functor.additive (induced_functor F) := {}

end induced_category

section
-- To talk about preservation of biproducts we need to specify universes explicitly.

noncomputable theory
universes v u₁ u₂

variables {C : Type u₁} {D : Type u₂} [category.{v} C] [category.{v} D]
  [preadditive C] [preadditive D] (F : C ⥤ D) [functor.additive F]

open category_theory.limits

/--
An additive functor between preadditive categories creates finite biproducts.
-/
instance map_has_biproduct {J : Type v} [fintype J] [decidable_eq J] (f : J → C) [has_biproduct f] :
  has_biproduct (λ j, F.obj (f j)) :=
has_biproduct_of_total
{ X := F.obj (⨁ f),
  π := λ j, F.map (biproduct.π f j),
  ι := λ j, F.map (biproduct.ι f j),
  ι_π := λ j j', by { simp only [←F.map_comp], split_ifs, { subst h, simp, }, { simp [h], }, }, }
(by simp_rw [←F.map_comp, ←F.map_sum, biproduct.total, functor.map_id])

/--
An additive functor between preadditive categories preserves finite biproducts.
-/
-- This essentially repeats the work of the previous instance,
-- but gives good definitional reduction to `biproduct.lift` and `biproduct.desc`.
@[simps]
def map_biproduct {J : Type v} [fintype J] [decidable_eq J] (f : J → C) [has_biproduct f] :
  F.obj (⨁ f) ≅ ⨁ (λ j, F.obj (f j)) :=
{ hom := biproduct.lift (λ j, F.map (biproduct.π f j)),
  inv := biproduct.desc (λ j, F.map (biproduct.ι f j)),
  hom_inv_id' :=
  by simp only [biproduct.lift_desc, ←F.map_comp, ←F.map_sum, biproduct.total, F.map_id],
  inv_hom_id' :=
  begin
    ext j j',
    simp only [category.comp_id,  category.assoc, biproduct.lift_π, biproduct.ι_desc_assoc,
      ←F.map_comp, biproduct.ι_π, F.map_dite, dif_ctx_congr, eq_to_hom_map, F.map_zero],
  end }

end

end functor

namespace equivalence

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

instance inverse_additive (e : C ≌ D) [e.functor.additive] : e.inverse.additive :=
{ map_add' := λ X Y f g, by { apply e.functor.map_injective, simp, }, }

end equivalence

end preadditive

end category_theory


/-
Copyright (c) 2021 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import linear_algebra.ray
import linear_algebra.determinant

/-!
# Orientations of modules

This file defines orientations of modules.

## Main definitions

* `orientation` is a type synonym for `module.ray` for the case where the module is that of
alternating maps from a module to its underlying ring.  An orientation may be associated with an
alternating map or with a basis.

* `module.oriented` is a type class for a choice of orientation of a module that is considered
the positive orientation.

## Implementation notes

`orientation` is defined for an arbitrary index type, but the main intended use case is when
that index type is a `fintype` and there exists a basis of the same cardinality.

## References

* https://en.wikipedia.org/wiki/Orientation_(vector_space)

-/

noncomputable theory

open_locale big_operators

section ordered_comm_semiring

variables (R : Type*) [ordered_comm_semiring R]
variables (M : Type*) [add_comm_monoid M] [module R M]
variables {N : Type*} [add_comm_monoid N] [module R N]
variables (ι : Type*) [decidable_eq ι]

/-- An orientation of a module, intended to be used when `ι` is a `fintype` with the same
cardinality as a basis. -/
abbreviation orientation := module.ray R (alternating_map R M R ι)

/-- A type class fixing an orientation of a module. -/
class module.oriented :=
(positive_orientation : orientation R M ι)

variables {R M}

/-- An equivalence between modules implies an equivalence between orientations. -/
def orientation.map (e : M ≃ₗ[R] N) : orientation R M ι ≃ orientation R N ι :=
module.ray.map $ alternating_map.dom_lcongr R R ι R e

@[simp] lemma orientation.map_apply (e : M ≃ₗ[R] N) (v : alternating_map R M R ι)
  (hv : v ≠ 0) :
  orientation.map ι e (ray_of_ne_zero _ v hv) = ray_of_ne_zero _ (v.comp_linear_map e.symm)
      (mt (v.comp_linear_equiv_eq_zero_iff e.symm).mp hv) := rfl

@[simp] lemma orientation.map_refl :
  (orientation.map ι $ linear_equiv.refl R M) = equiv.refl _ :=
by rw [orientation.map, alternating_map.dom_lcongr_refl, module.ray.map_refl]

@[simp] lemma orientation.map_symm (e : M ≃ₗ[R] N) :
  (orientation.map ι e).symm = orientation.map ι e.symm := rfl

end ordered_comm_semiring

section ordered_comm_ring

variables {R : Type*} [ordered_comm_ring R]
variables {M N : Type*} [add_comm_group M] [add_comm_group N] [module R M] [module R N]

namespace basis

variables {ι : Type*} [fintype ι] [decidable_eq ι]

/-- The orientation given by a basis. -/
protected def orientation [nontrivial R] (e : basis ι R M) : orientation R M ι :=
ray_of_ne_zero R _ e.det_ne_zero

lemma orientation_map [nontrivial R] (e : basis ι R M)
  (f : M ≃ₗ[R] N) : (e.map f).orientation = orientation.map ι f e.orientation :=
by simp_rw [basis.orientation, orientation.map_apply, basis.det_map']

/-- The value of `orientation.map` when the index type has the cardinality of a basis, in terms
of `f.det`. -/
lemma map_orientation_eq_det_inv_smul (e : basis ι R M)
  (x : orientation R M ι) (f : M ≃ₗ[R] M) : orientation.map ι f x = (f.det)⁻¹ • x :=
begin
  induction x using module.ray.ind with g hg,
  rw [orientation.map_apply, smul_ray_of_ne_zero, ray_eq_iff, units.smul_def,
      (g.comp_linear_map ↑f.symm).eq_smul_basis_det e, g.eq_smul_basis_det e,
      alternating_map.comp_linear_map_apply, alternating_map.smul_apply, basis.det_comp,
      basis.det_self, mul_one, smul_eq_mul, mul_comm, mul_smul, linear_equiv.coe_inv_det],
end

/-- The orientation given by a basis derived using `units_smul`, in terms of the product of those
units. -/
lemma orientation_units_smul [nontrivial R] (e : basis ι R M) (w : ι → units R) :
  (e.units_smul w).orientation = (∏ i, w i)⁻¹ • e.orientation :=
begin
  rw [basis.orientation, basis.orientation, smul_ray_of_ne_zero, ray_eq_iff,
      e.det.eq_smul_basis_det (e.units_smul w), det_units_smul, units.smul_def, smul_smul],
  norm_cast,
  simp
end

end basis

end ordered_comm_ring

section linear_ordered_comm_ring

variables {R : Type*} [linear_ordered_comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]
variables {ι : Type*} [decidable_eq ι]

namespace basis

variables [fintype ι]

/-- The orientations given by two bases are equal if and only if the determinant of one basis
with respect to the other is positive. -/
lemma orientation_eq_iff_det_pos (e₁ e₂ : basis ι R M) :
  e₁.orientation = e₂.orientation ↔ 0 < e₁.det e₂ :=
calc e₁.orientation = e₂.orientation ↔ same_ray R e₁.det e₂.det : ray_eq_iff _ _
... ↔ same_ray R (e₁.det e₂ • e₂.det) e₂.det : by rw [← e₁.det.eq_smul_basis_det e₂]
... ↔ 0 < e₁.det e₂ : same_ray_smul_left_iff_of_ne e₂.det_ne_zero (e₁.is_unit_det e₂).ne_zero

/-- Given a basis, any orientation equals the orientation given by that basis or its negation. -/
lemma orientation_eq_or_eq_neg (e : basis ι R M) (x : orientation R M ι) :
  x = e.orientation ∨ x = -e.orientation :=
begin
  induction x using module.ray.ind with x hx,
  rw ← x.map_basis_ne_zero_iff e at hx,
  rwa [basis.orientation, ray_eq_iff, neg_ray_of_ne_zero, ray_eq_iff, x.eq_smul_basis_det e,
    same_ray_neg_smul_left_iff_of_ne e.det_ne_zero hx,
    same_ray_smul_left_iff_of_ne e.det_ne_zero hx, lt_or_lt_iff_ne, ne_comm]
end

/-- Given a basis, an orientation equals the negation of that given by that basis if and only
if it does not equal that given by that basis. -/
lemma orientation_ne_iff_eq_neg (e : basis ι R M) (x : orientation R M ι) :
  x ≠ e.orientation ↔ x = -e.orientation :=
⟨λ h, (e.orientation_eq_or_eq_neg x).resolve_left h,
 λ h, h.symm ▸ (module.ray.ne_neg_self e.orientation).symm⟩

/-- Composing a basis with a linear equiv gives the same orientation if and only if the
determinant is positive. -/
lemma orientation_comp_linear_equiv_eq_iff_det_pos (e : basis ι R M) (f : M ≃ₗ[R] M) :
  (e.map f).orientation = e.orientation ↔ 0 < (f : M →ₗ[R] M).det :=
by rw [orientation_map, e.map_orientation_eq_det_inv_smul, units_inv_smul, units_smul_eq_self_iff,
  linear_equiv.coe_det]

/-- Composing a basis with a linear equiv gives the negation of that orientation if and only if
the determinant is negative. -/
lemma orientation_comp_linear_equiv_eq_neg_iff_det_neg (e : basis ι R M) (f : M ≃ₗ[R] M) :
  (e.map f).orientation = -e.orientation ↔ (f : M →ₗ[R] M).det < 0 :=
by rw [orientation_map, e.map_orientation_eq_det_inv_smul, units_inv_smul, units_smul_eq_neg_iff,
  linear_equiv.coe_det]

/-- Negating a single basis vector (represented using `units_smul`) negates the corresponding
orientation. -/
@[simp] lemma orientation_neg_single [nontrivial R] (e : basis ι R M) (i : ι) :
  (e.units_smul (function.update 1 i (-1))).orientation = -e.orientation :=
begin
  rw [orientation_units_smul, finset.prod_update_of_mem (finset.mem_univ _)],
  simp
end

/-- Given a basis and an orientation, return a basis giving that orientation: either the original
basis, or one constructed by negating a single (arbitrary) basis vector. -/
def adjust_to_orientation [nontrivial R] [nonempty ι] (e : basis ι R M) (x : orientation R M ι) :
  basis ι R M :=
by haveI := classical.dec_eq (orientation R M ι); exact if e.orientation = x then e else
  (e.units_smul (function.update 1 (classical.arbitrary ι) (-1)))

/-- `adjust_to_orientation` gives a basis with the required orientation. -/
@[simp] lemma orientation_adjust_to_orientation [nontrivial R] [nonempty ι] (e : basis ι R M)
  (x : orientation R M ι) : (e.adjust_to_orientation x).orientation = x :=
begin
  rw adjust_to_orientation,
  split_ifs with h,
  { exact h },
  { rw [orientation_neg_single, eq_comm, ←orientation_ne_iff_eq_neg, ne_comm],
    exact h }
end

/-- Every basis vector from `adjust_to_orientation` is either that from the original basis or its
negation. -/
lemma adjust_to_orientation_apply_eq_or_eq_neg [nontrivial R] [nonempty ι] (e : basis ι R M)
  (x : orientation R M ι) (i : ι) :
  e.adjust_to_orientation x i = e i ∨ e.adjust_to_orientation x i = -(e i) :=
begin
  rw adjust_to_orientation,
  split_ifs with h,
  { simp },
  { by_cases hi : i = classical.arbitrary ι;
      simp [units_smul_apply, hi] }
end

end basis

end linear_ordered_comm_ring

section linear_ordered_field

variables {R : Type*} [linear_ordered_field R]
variables {M : Type*} [add_comm_group M] [module R M]
variables {ι : Type*} [decidable_eq ι]

namespace orientation

variables [fintype ι] [finite_dimensional R M]

open finite_dimensional

/-- If the index type has cardinality equal to the finite dimension, any two orientations are
equal or negations. -/
lemma eq_or_eq_neg (x₁ x₂ : orientation R M ι) (h : fintype.card ι = finrank R M) :
  x₁ = x₂ ∨ x₁ = -x₂ :=
begin
  have e := (fin_basis R M).reindex (fintype.equiv_fin_of_card_eq h).symm,
  rcases e.orientation_eq_or_eq_neg x₁ with h₁|h₁;
    rcases e.orientation_eq_or_eq_neg x₂ with h₂|h₂;
    simp [h₁, h₂]
end

/-- If the index type has cardinality equal to the finite dimension, an orientation equals the
negation of another orientation if and only if they are not equal. -/
lemma ne_iff_eq_neg (x₁ x₂ : orientation R M ι) (h : fintype.card ι = finrank R M) :
  x₁ ≠ x₂ ↔ x₁ = -x₂ :=
⟨λ hn, (eq_or_eq_neg x₁ x₂ h).resolve_left hn, λ he, he.symm ▸ (module.ray.ne_neg_self x₂).symm⟩

/-- The value of `orientation.map` when the index type has cardinality equal to the finite
dimension, in terms of `f.det`. -/
lemma map_eq_det_inv_smul (x : orientation R M ι) (f : M ≃ₗ[R] M)
  (h : fintype.card ι = finrank R M) :
  orientation.map ι f x = (f.det)⁻¹ • x :=
begin
  have e := (fin_basis R M).reindex (fintype.equiv_fin_of_card_eq h).symm,
  exact e.map_orientation_eq_det_inv_smul x f
end

/-- If the index type has cardinality equal to the finite dimension, composing an alternating
map with the same linear equiv on each argument gives the same orientation if and only if the
determinant is positive. -/
lemma map_eq_iff_det_pos (x : orientation R M ι) (f : M ≃ₗ[R] M)
  (h : fintype.card ι = finrank R M) :
  orientation.map ι f x = x ↔  0 < (f : M →ₗ[R] M).det :=
by rw [map_eq_det_inv_smul _ _ h, units_inv_smul, units_smul_eq_self_iff, linear_equiv.coe_det]

/-- If the index type has cardinality equal to the finite dimension, composing an alternating
map with the same linear equiv on each argument gives the negation of that orientation if and
only if the determinant is negative. -/
lemma map_eq_neg_iff_det_neg (x : orientation R M ι) (f : M ≃ₗ[R] M)
  (h : fintype.card ι = finrank R M) :
  orientation.map ι f x = -x ↔ (f : M →ₗ[R] M).det < 0 :=
by rw [map_eq_det_inv_smul _ _ h, units_inv_smul, units_smul_eq_neg_iff, linear_equiv.coe_det]

/-- If the index type has cardinality equal to the finite dimension, a basis with the given
orientation. -/
def some_basis [nonempty ι] (x : orientation R M ι) (h : fintype.card ι = finrank R M) :
  basis ι R M :=
((fin_basis R M).reindex (fintype.equiv_fin_of_card_eq h).symm).adjust_to_orientation x

/-- `some_basis` gives a basis with the required orientation. -/
@[simp] lemma some_basis_orientation [nonempty ι] (x : orientation R M ι)
  (h : fintype.card ι = finrank R M) : (x.some_basis h).orientation = x :=
basis.orientation_adjust_to_orientation _ _

end orientation

end linear_ordered_field