import order.basic
import data.finset.lattice
import data.rat

namespace o_minimal

set_option old_structure_cmd true

/-- A DUNLO is a dense unbounded nonempty linear order.
This is the setting in which we can talk about o-minimal structures.
See [vdD], §1.3, first italicized paragraph.
-/
class DUNLO (R : Type*) extends linear_order R :=
[dense : densely_ordered R]
[unbounded_below : no_bot_order R]
[unbounded_above : no_top_order R]
[nonempty : nonempty R]

-- These classes are all `Prop`s so these instances should be harmless.
attribute [instance] DUNLO.dense DUNLO.unbounded_below DUNLO.unbounded_above DUNLO.nonempty

instance : DUNLO ℚ :=
{ .. show linear_order ℚ, by apply_instance }

-- TODO: for_mathlib
/-- In a DUNLO, a system of constraints Lᵢ < x, x < Uⱼ is solvable
if and only if Lᵢ < Uⱼ for every i and j. Here i and j range over
possibly empty finite sets I and J respectively.
(In fact, this property characterizes DUNLOs.) -/
lemma order_constraints_feasible_iff {R : Type*} [DUNLO R] (lower upper : finset R) :
  (∃ x, (∀ g ∈ lower, g < x) ∧ (∀ h ∈ upper, x < h)) ↔
  ∀ (g ∈ lower) (h ∈ upper), g < h :=
begin
  split,
  { rintro ⟨x, hx₁, hx₂⟩ g Hg h Hh,
    exact lt_trans (hx₁ g Hg) (hx₂ h Hh) },
  { -- TODO: maybe reformulate all this into a useful lemma:
    -- (s : finset R) : s = ∅ ∨ ∃ max ∈ s, ∀ i ∈ s, i ≤ max
    -- Pretty similar to `exists_max_image`.
    cases hlower : lower.max with lmax;
      [{ rw finset.max_eq_none at hlower, subst lower },
       { have le_lmax : ∀ g ∈ lower, g ≤ lmax,
         { intros g H, apply finset.le_max_of_mem H hlower } }],
    all_goals {                 -- TODO: can't we write it using `;`?
    cases hupper : upper.min with umin;
      [{ rw finset.min_eq_none at hupper, subst upper },
       { have umin_le : ∀ h ∈ upper, umin ≤ h,
         { intros h H, apply finset.min_le_of_mem H hupper } }] },
    { simp },
    { suffices : ∃ (x : R), ∀ (h : R), h ∈ upper → x < h, { simpa },
      obtain ⟨x, hx⟩ := no_bot umin,
      exact ⟨x, λ h H, lt_of_lt_of_le hx (umin_le h H)⟩ },
    { suffices : ∃ (x : R), ∀ (g : R), g ∈ lower → g < x, { simpa },
      obtain ⟨x, hx⟩ := no_top lmax,
      exact ⟨x, λ g H, lt_of_le_of_lt (le_lmax g H) hx⟩ },
    { intro Hgh,
      specialize Hgh lmax (finset.mem_of_max hlower) umin (finset.mem_of_min hupper),
      obtain ⟨x, hx₁, hx₂⟩ := exists_between Hgh,
      exact ⟨x,
        λ g H, lt_of_le_of_lt (le_lmax g H) hx₁,
        λ h H, lt_of_lt_of_le hx₂ (umin_le h H)⟩ } }
end

end o_minimal


-- import data.set
import tactic

-- dEAduction imports
import structures2

-- General principles :
-- Type should be defined as parameters, in order to be implicit everywhere
-- other parameters are implicit in definitions, i.e. defined using '{}' (e.g. {A : set X} )
-- but explicit everywhere else, i.e. defined using '()' (e.g. (A : set X) )
-- each definition must be an iff statement (since it will be called with 'rw' or 'symp_rw')

-- no Magic button ("compute")
/- dEAduction
DefaultAvailableProof
    NONE
DefaultAvailableMagic
    Assumption
-/

-- logic names ['and', 'or', 'negate', 'implicate', 'iff', 'forall', 'exists']
-- proofs names ['proof_methods', 'new_object', 'apply']
-- magic names ['compute', 'assumption']

local attribute [instance] classical.prop_decidable
---------------------------------------------
-- global parameters = implicit variables --
---------------------------------------------
section course
variables (P Q R: Prop) -- NOT global
notation [parsing_only] P ` \and ` Q := P ∧ Q
notation [parsing_only]  P ` \or ` Q := P ∨ Q
notation [parsing_only]  ` \not ` P := ¬ P
notation [parsing_only]  P ` \implies ` Q := P → Q
notation [parsing_only]  P ` \iff ` Q := P ↔ Q

------------------
-- COURSE TITLE --
------------------
namespace Logique_propositionnelle

lemma exercise.tautologie :
P → P
:=
/- dEAduction
PrettyName
    La tautologie
Description
    Le bouton "=>" permet de démontrer une implication : pour montrer
    "P => Q", on suppose P, et on montre Q.
AvailableLogic
    implicate
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et :
P ∧ Q → P
:=
/- dEAduction
PrettyName
    P et Q implique P
Description
    Le bouton "ET" permet de découper une hypothèse
AvailableLogic
    and implicate
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et_commutatif_I :
P ∧ Q → Q ∧ P
:=
/- dEAduction
PrettyName
    Le "ET" est commutatif (version faible)
Description
    Le bouton "ET" permet aussi de découper le but en deux buts distincts
AvailableLogic
    and implicate
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et_commutatif_II :
P ∧ Q ↔ Q ∧ P
:=
/- dEAduction
PrettyName
    Le "ET" est commutatif
Description
    Le bouton "↔" permet de découper le but en deux implications.
    On peut alors appliquer le résultat de l'exercice précédent en le
    sélectionnant dans la liste...
AvailableLogic
    and iff implicate
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_commutatif :
P ∨ Q ↔ Q ∨ P
:=
/- dEAduction
PrettyName
    Le "OU" est commutatif
Description
    Pour utiliser l'hypothèse "P OU Q", on sépare les cas :
    dans le premier cas on suppose P, dans le second cas on suppose Q.
    Pour démontrer "Q OU P", on doit démontrer soit P, soit Q.
AvailableLogic
    and or implicate iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.non_non :
¬ ¬ P ↔ P
:=
/- dEAduction
PrettyName
    Double négation
Description
    Le bouton "NON" permet d'utiliser les règles logiques du "NON".
    On peut l'utiliser uniquement sur les propriétés qui sont des négations,
    c'est-à-dire de la forme "NON (...)".
AvailableLogic
    and or negate implicate iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.non_ET :
¬ (P ∧ Q) ↔ (¬ P) ∨ (¬ Q)
:=
/- dEAduction
PrettyName
    Négation d'un "ET"
Description
    En général, le bouton "NON" tente de "pousser" la négation le long de la
    propriété.
AvailableLogic
    and or negate implicate iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.contradiction :
R ∨ ¬ R
:=
/- dEAduction
PrettyName
    Le tiers exclu : l'une des deux propriétés "R" et "NON R" est vraie
Description
    Le mécanisme de preuve inclus le tiers exclu, de façon un peu cachée...
AvailableLogic
    and or negate implicate iff
AvailableProof
    use_proof_methods
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.contraposition :
(P → Q) ↔ (¬ Q → ¬ P)
:=
/- dEAduction
PrettyName
    Contraposition
Description
    Le bouton "=>" permet également d'appliquer une implication "P => Q" à la
    propriété "P" pour obtenir la propriété "Q". Attention, avant de
    l'actionner il faut sélectionner toutes les propriétés requises !
AvailableLogic
    and or negate implicate iff
AvailableProof
    use_proof_methods apply
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_implication_I :
(P → Q) ↔ (¬ P ∨ Q)
:=
/- dEAduction
PrettyName
    Implication sous forme de "OU"
Description
    Cette propriété permet de transformer une implication en une disjonction
AvailableLogic
    and or negate implicate iff
AvailableProof
    use_proof_methods apply
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_implication_II :
(P ∨ Q) ↔ (¬ P → Q)
:=
/- dEAduction
PrettyName
    "OU" sous forme d'implication
Description
    Cette propriété est très proche de la précédente.
    On peut la redémontrer entièrement, mais on peut aussi tenter d'appliquer
    le résultat de l'exercice précédent. Pour cela, il faudra introduire
    un nouvel objet, avant de lui appliquer le résultat précédent...
AvailableLogic
    and or negate implicate iff
AvailableProof
    use_proof_methods new_object apply
AvailableMagic
    assumption
-/
begin
    sorry
end

end Logique_propositionnelle

end course


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module topology.local_at_target
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sets.Opens

/-!
# Properties of maps that are local at the target.

We show that the following properties of continuous maps are local at the target :
- `inducing`
- `embedding`
- `open_embedding`
- `closed_embedding`

-/

open TopologicalSpace Set Filter

open Topology Filter

variable {α β : Type _} [TopologicalSpace α] [TopologicalSpace β] {f : α → β}

variable {s : Set β} {ι : Type _} {U : ι → Opens β} (hU : supᵢ U = ⊤)

theorem Set.restrictPreimage_inducing (s : Set β) (h : Inducing f) :
    Inducing (s.restrictPreimage f) :=
  by
  simp_rw [inducing_coe.inducing_iff, inducing_iff_nhds, restrict_preimage, maps_to.coe_restrict,
    restrict_eq, ← @Filter.comap_comap _ _ _ _ coe f] at h⊢
  intro a
  rw [← h, ← inducing_coe.nhds_eq_comap]
#align set.restrict_preimage_inducing Set.restrictPreimage_inducing

alias Set.restrictPreimage_inducing ← Inducing.restrictPreimage
#align inducing.restrict_preimage Inducing.restrictPreimage

theorem Set.restrictPreimage_embedding (s : Set β) (h : Embedding f) :
    Embedding (s.restrictPreimage f) :=
  ⟨h.1.restrictPreimage s, h.2.restrictPreimage s⟩
#align set.restrict_preimage_embedding Set.restrictPreimage_embedding

alias Set.restrictPreimage_embedding ← Embedding.restrictPreimage
#align embedding.restrict_preimage Embedding.restrictPreimage

theorem Set.restrictPreimage_openEmbedding (s : Set β) (h : OpenEmbedding f) :
    OpenEmbedding (s.restrictPreimage f) :=
  ⟨h.1.restrictPreimage s,
    (s.range_restrictPreimage f).symm ▸ continuous_subtype_val.isOpen_preimage _ h.2⟩
#align set.restrict_preimage_open_embedding Set.restrictPreimage_openEmbedding

alias Set.restrictPreimage_openEmbedding ← OpenEmbedding.restrictPreimage
#align open_embedding.restrict_preimage OpenEmbedding.restrictPreimage

theorem Set.restrictPreimage_closedEmbedding (s : Set β) (h : ClosedEmbedding f) :
    ClosedEmbedding (s.restrictPreimage f) :=
  ⟨h.1.restrictPreimage s,
    (s.range_restrictPreimage f).symm ▸ inducing_subtype_val.isClosed_preimage _ h.2⟩
#align set.restrict_preimage_closed_embedding Set.restrictPreimage_closedEmbedding

alias Set.restrictPreimage_closedEmbedding ← ClosedEmbedding.restrictPreimage
#align closed_embedding.restrict_preimage ClosedEmbedding.restrictPreimage

theorem Set.restrictPreimage_isClosedMap (s : Set β) (H : IsClosedMap f) :
    IsClosedMap (s.restrictPreimage f) :=
  by
  rintro t ⟨u, hu, e⟩
  refine' ⟨⟨_, (H _ (IsOpen.isClosed_compl hu)).1, _⟩⟩
  rw [← (congr_arg HasCompl.compl e).trans (compl_compl t)]
  simp only [Set.preimage_compl, compl_inj_iff]
  ext ⟨x, hx⟩
  suffices (∃ y, y ∉ u ∧ f y = x) ↔ ∃ y, f y ∈ s ∧ y ∉ u ∧ f y = x by
    simpa [Set.restrictPreimage, ← Subtype.coe_inj]
  exact ⟨fun ⟨a, b, c⟩ => ⟨a, c.symm ▸ hx, b, c⟩, fun ⟨a, _, b, c⟩ => ⟨a, b, c⟩⟩
#align set.restrict_preimage_is_closed_map Set.restrictPreimage_isClosedMap

include hU

theorem isOpen_iff_inter_of_supᵢ_eq_top (s : Set β) : IsOpen s ↔ ∀ i, IsOpen (s ∩ U i) :=
  by
  constructor
  · exact fun H i => H.inter (U i).2
  · intro H
    have : (⋃ i, (U i : Set β)) = Set.univ :=
      by
      convert congr_arg coe hU
      simp
    rw [← s.inter_univ, ← this, Set.inter_unionᵢ]
    exact isOpen_unionᵢ H
#align is_open_iff_inter_of_supr_eq_top isOpen_iff_inter_of_supᵢ_eq_top

theorem isOpen_iff_coe_preimage_of_supᵢ_eq_top (s : Set β) :
    IsOpen s ↔ ∀ i, IsOpen (coe ⁻¹' s : Set (U i)) :=
  by
  simp_rw [(U _).2.openEmbedding_subtype_val.open_iff_image_open, Set.image_preimage_eq_inter_range,
    Subtype.range_coe]
  apply isOpen_iff_inter_of_supᵢ_eq_top
  assumption
#align is_open_iff_coe_preimage_of_supr_eq_top isOpen_iff_coe_preimage_of_supᵢ_eq_top

theorem isClosed_iff_coe_preimage_of_supᵢ_eq_top (s : Set β) :
    IsClosed s ↔ ∀ i, IsClosed (coe ⁻¹' s : Set (U i)) := by
  simpa using isOpen_iff_coe_preimage_of_supᵢ_eq_top hU (sᶜ)
#align is_closed_iff_coe_preimage_of_supr_eq_top isClosed_iff_coe_preimage_of_supᵢ_eq_top

theorem isClosedMap_iff_isClosedMap_of_supᵢ_eq_top :
    IsClosedMap f ↔ ∀ i, IsClosedMap ((U i).1.restrictPreimage f) :=
  by
  refine' ⟨fun h i => Set.restrictPreimage_isClosedMap _ h, _⟩
  rintro H s hs
  rw [isClosed_iff_coe_preimage_of_supᵢ_eq_top hU]
  intro i
  convert H i _ ⟨⟨_, hs.1, eq_compl_comm.mpr rfl⟩⟩
  ext ⟨x, hx⟩
  suffices (∃ y, y ∈ s ∧ f y = x) ↔ ∃ y, f y ∈ U i ∧ y ∈ s ∧ f y = x by
    simpa [Set.restrictPreimage, ← Subtype.coe_inj]
  exact ⟨fun ⟨a, b, c⟩ => ⟨a, c.symm ▸ hx, b, c⟩, fun ⟨a, _, b, c⟩ => ⟨a, b, c⟩⟩
#align is_closed_map_iff_is_closed_map_of_supr_eq_top isClosedMap_iff_isClosedMap_of_supᵢ_eq_top

theorem inducing_iff_inducing_of_supᵢ_eq_top (h : Continuous f) :
    Inducing f ↔ ∀ i, Inducing ((U i).1.restrictPreimage f) :=
  by
  simp_rw [inducing_coe.inducing_iff, inducing_iff_nhds, restrict_preimage, maps_to.coe_restrict,
    restrict_eq, ← @Filter.comap_comap _ _ _ _ coe f]
  constructor
  · intro H i x
    rw [← H, ← inducing_coe.nhds_eq_comap]
  · intro H x
    obtain ⟨i, hi⟩ :=
      opens.mem_supr.mp
        (show f x ∈ supᵢ U by
          rw [hU]
          triv)
    erw [← OpenEmbedding.map_nhds_eq (h.1 _ (U i).2).openEmbedding_subtype_val ⟨x, hi⟩]
    rw [(H i) ⟨x, hi⟩, Filter.subtype_coe_map_comap, Function.comp_apply, Subtype.coe_mk,
      inf_eq_left, Filter.le_principal_iff]
    exact Filter.preimage_mem_comap ((U i).2.mem_nhds hi)
#align inducing_iff_inducing_of_supr_eq_top inducing_iff_inducing_of_supᵢ_eq_top

theorem embedding_iff_embedding_of_supᵢ_eq_top (h : Continuous f) :
    Embedding f ↔ ∀ i, Embedding ((U i).1.restrictPreimage f) :=
  by
  simp_rw [embedding_iff]
  rw [forall_and]
  apply and_congr
  · apply inducing_iff_inducing_of_supᵢ_eq_top <;> assumption
  · apply Set.injective_iff_injective_of_unionᵢ_eq_univ
    convert congr_arg coe hU
    simp
#align embedding_iff_embedding_of_supr_eq_top embedding_iff_embedding_of_supᵢ_eq_top

theorem openEmbedding_iff_openEmbedding_of_supᵢ_eq_top (h : Continuous f) :
    OpenEmbedding f ↔ ∀ i, OpenEmbedding ((U i).1.restrictPreimage f) :=
  by
  simp_rw [openEmbedding_iff]
  rw [forall_and]
  apply and_congr
  · apply embedding_iff_embedding_of_supᵢ_eq_top <;> assumption
  · simp_rw [Set.range_restrictPreimage]
    apply isOpen_iff_coe_preimage_of_supᵢ_eq_top hU
#align open_embedding_iff_open_embedding_of_supr_eq_top openEmbedding_iff_openEmbedding_of_supᵢ_eq_top

theorem closedEmbedding_iff_closedEmbedding_of_supᵢ_eq_top (h : Continuous f) :
    ClosedEmbedding f ↔ ∀ i, ClosedEmbedding ((U i).1.restrictPreimage f) :=
  by
  simp_rw [closedEmbedding_iff]
  rw [forall_and]
  apply and_congr
  · apply embedding_iff_embedding_of_supᵢ_eq_top <;> assumption
  · simp_rw [Set.range_restrictPreimage]
    apply isClosed_iff_coe_preimage_of_supᵢ_eq_top hU
#align closed_embedding_iff_closed_embedding_of_supr_eq_top closedEmbedding_iff_closedEmbedding_of_supᵢ_eq_top


import tactic
import combinatorics.simple_graph.connectivity
import graph_theory.basic graph_theory.pushforward
open relation relation.refl_trans_gen

namespace simple_graph

variables {V V' : Type*} {G G₁ G₂ : simple_graph V} {G' : simple_graph V'} {u v x y z : V}
variables {e : G.dart} {p : walk G x y} {p' : walk G y z} {p'' : walk G z u}
variables {h : G.adj y z} {h' : G.adj u x} {h'' : G.adj z v}

namespace walk

infixr ` :: ` := cons
infix  ` ++ ` := append

lemma point_of_size_0 : p.length = 0 → x = y :=
by { intro h, cases p, refl, contradiction }

lemma mem_edges (h : e ∈ darts p) : e.fst ∈ p.support ∧ e.snd ∈ p.support :=
⟨p.dart_fst_mem_support_of_mem_darts h, p.dart_snd_mem_support_of_mem_darts h⟩

lemma mem_of_edges (h : 0 < p.length) : u ∈ p.support ↔ ∃ e ∈ darts p, u ∈ dart.edge e :=
begin
  induction p with u u v w h p ih,
  { simp only [length_nil, nat.not_lt_zero] at h, contradiction },
  { clear h, cases nat.eq_zero_or_pos (length p),
    { cases p,
      simp only [darts, dart.edge, support_cons, support_nil, list.mem_cons_iff,
        list.mem_singleton, sym2.mem_iff, exists_prop, exists_eq_left],
      simp only [length_cons, nat.succ_ne_zero] at h_1, contradiction },
    { specialize ih h_1, clear h_1, simp only [dart.edge, sym2.mem_iff] at ih, split,
      { simp only [darts, dart.edge, support_cons, list.mem_cons_iff, sym2.mem_iff, exists_prop],
        intro h1, cases h1,
        { subst h1, use ⟨(u,v),h⟩, simp only [eq_self_iff_true, and_self, true_or, sym2.mem_iff] },
        { obtain ⟨e,h2,h3⟩ := ih.mp h1, exact ⟨e, or.inr h2, h3⟩ } },
      { simp only [darts, dart.edge, list.mem_cons_iff, sym2.mem_iff, support_cons,
        forall_exists_index, and_imp, forall_eq_or_imp],
        exact ⟨(λ h, or.cases_on h or.inl (λ h, by { subst h, exact or.inr (start_mem_support _) })),
        (λ e he h1, or.inr (ih.mpr ⟨e,he,h1⟩))⟩ } } }
end

lemma nodup_concat : (append p p').support.nodup ↔
  p.support.nodup ∧ p'.support.nodup ∧ (∀ u, u ∈ p.support → u ∈ p'.support → u = y) :=
begin
  induction p with a a b c h q ih,
  { simp },
  { simp only [cons_append, support_cons, list.nodup_cons, mem_support_append_iff,
    list.mem_cons_iff, forall_eq_or_imp],
    push_neg, split,
    { rintros ⟨⟨h1,h2⟩,h3⟩, replace ih := ih.mp h3, refine ⟨⟨h1,ih.1⟩,ih.2.1,_,λ u h4 h5, _⟩,
      intro, contradiction, exact ih.2.2 u h4 h5 },
    { rintros ⟨⟨h1,h2⟩,h3,h4,h5⟩, refine ⟨⟨h1,_⟩,_⟩,
      intro h5, apply h1, rw h4 h5, exact end_mem_support _,
      refine ih.mpr ⟨h2,h3,_⟩, intros u hu h'u, exact h5 u hu h'u } }
end

end walk
end simple_graph


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.single_obj
import category_theory.limits.shapes.products
import category_theory.pi.basic
import category_theory.limits.is_limit

/-!
# Category of groupoids

This file contains the definition of the category `Groupoid` of all groupoids.
In this category objects are groupoids and morphisms are functors
between these groupoids.

We also provide two “forgetting” functors: `objects : Groupoid ⥤ Type`
and `forget_to_Cat : Groupoid ⥤ Cat`.

## Implementation notes

Though `Groupoid` is not a concrete category, we use `bundled` to define
its carrier type.
-/

universes v u

namespace category_theory

/-- Category of groupoids -/
@[nolint check_univs] -- intended to be used with explicit universe parameters
def Groupoid := bundled groupoid.{v u}

namespace Groupoid

instance : inhabited Groupoid := ⟨bundled.of (single_obj punit)⟩

instance str (C : Groupoid.{v u}) : groupoid.{v u} C.α := C.str

instance : has_coe_to_sort Groupoid Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Groupoid` from the underlying type and the typeclass. -/
def of (C : Type u) [groupoid.{v} C] : Groupoid.{v u} := bundled.of C

@[simp] lemma coe_of (C : Type u) [groupoid C] : (of C : Type u) = C := rfl

/-- Category structure on `Groupoid` -/
instance category : large_category.{max v u} Groupoid.{v u} :=
{ hom := λ C D, C ⥤ D,
  id := λ C, 𝟭 C,
  comp := λ C D E F G, F ⋙ G,
  id_comp' := λ C D F, by cases F; refl,
  comp_id' := λ C D F, by cases F; refl,
  assoc' := by intros; refl }

/-- Functor that gets the set of objects of a groupoid. It is not
called `forget`, because it is not a faithful functor. -/
def objects : Groupoid.{v u} ⥤ Type u :=
{ obj := bundled.α,
  map := λ C D F, F.obj }

/-- Forgetting functor to `Cat` -/
def forget_to_Cat : Groupoid.{v u} ⥤ Cat.{v u} :=
{ obj := λ C, Cat.of C,
  map := λ C D, id }

instance forget_to_Cat_full : full forget_to_Cat :=
{ preimage := λ C D, id }

instance forget_to_Cat_faithful : faithful forget_to_Cat := { }

/-- Convert arrows in the category of groupoids to functors,
which sometimes helps in applying simp lemmas -/
lemma hom_to_functor {C D E : Groupoid.{v u}} (f : C ⟶ D) (g : D ⟶ E) : f ≫ g = f ⋙ g := rfl

/-- Converts identity in the category of groupoids to the functor identity -/
lemma id_to_functor {C : Groupoid.{v u}} : 𝟭 C = 𝟙 C := rfl

section products

local attribute [tidy] tactic.discrete_cases

/-- Construct the product over an indexed family of groupoids, as a fan. -/
def pi_limit_fan ⦃J : Type u⦄ (F : J → Groupoid.{u u}) : limits.fan F :=
limits.fan.mk (@of (Π j : J, F j) _) (λ j, category_theory.pi.eval _ j)

/-- The product fan over an indexed family of groupoids, is a limit cone. -/
def pi_limit_fan_is_limit ⦃J : Type u⦄ (F : J → Groupoid.{u u}) :
  limits.is_limit (pi_limit_fan F) :=
limits.mk_fan_limit (pi_limit_fan F)
(λ s, functor.pi' (λ j, s.proj j))
(by { intros, dunfold pi_limit_fan, simp [hom_to_functor], })
begin
  intros s m w,
  apply functor.pi_ext,
  intro j, specialize w j,
  simpa,
end

instance has_pi : limits.has_products Groupoid.{u u} :=
limits.has_products_of_limit_fans pi_limit_fan pi_limit_fan_is_limit

/-- The product of a family of groupoids is isomorphic
to the product object in the category of Groupoids -/
noncomputable def pi_iso_pi (J : Type u) (f : J → Groupoid.{u u}) : @of (Π j, f j) _ ≅ ∏ f :=
limits.is_limit.cone_point_unique_up_to_iso
  (pi_limit_fan_is_limit f)
  (limits.limit.is_limit (discrete.functor f))

@[simp]
lemma pi_iso_pi_hom_π (J : Type u) (f : J → Groupoid.{u u}) (j : J) :
  (pi_iso_pi J f).hom ≫ (limits.pi.π f j) = category_theory.pi.eval _ j :=
by { simp [pi_iso_pi], refl, }

end products

end Groupoid

end category_theory


/-
Author: <Redacted for anonymized submission>
-/
-- import snarks.groth16.declarations
import ...attributes
import ...integral_domain_tactic
import ...general_lemmas.polynomial_degree
import ...general_lemmas.monomial_pow
import data.mv_polynomial.basic
import data.mv_polynomial.funext
import data.polynomial.field_division
import algebra.polynomial.big_operators
-- import ...attributes
import .vars

/-!
# Knowledge Soundness

This file proves the knowledge-soundness property of the Groth16 system for type III pairings, as
presented in "Another Look at Extraction and Randomization of Groth’s zk-SNARK" by
[Baghery et al.](https://eprint.iacr.org/2020/811.pdf).

-/

open_locale big_operators classical

section lipmaa

-- TODO we open mv_polynomial, so we should be able to delete a lot of `mv_polynomial.`
open mv_polynomial

noncomputable theory

universes u

/-- The finite field parameter of our SNARK -/
parameter {F : Type u}
parameter [field F]

/-- The naturals representing:
  n_stmt - the statement size,
  n_wit - the witness size -/
parameters {n_stmt n_wit n_var : ℕ}

/-- u_stmt and u_wit are fin-indexed collections of polynomials from the square span program -/
parameter {u_stmt : fin n_stmt → (polynomial F) }
parameter {u_wit : fin n_wit → (polynomial F) }
parameter {v_stmt : fin n_stmt → (polynomial F) }
parameter {v_wit : fin n_wit → (polynomial F) }
parameter {w_stmt : fin n_stmt → (polynomial F) }
parameter {w_wit : fin n_wit → (polynomial F) }

-- Defined as integers the exponents are:
-- def α := 0
-- def β := 1
-- def γ := −6
-- def δ := 4
-- def η := −1

-- To sidestep the use of Laurent Polynomials, we instead use
def α : ℕ := 6
def β : ℕ := 7
def γ : ℕ := 0
def δ : ℕ := 10
def η : ℕ := 5

/-- The roots of the polynomial t -/
parameter {r : fin n_wit → F}
/-- l is the polynomial divisibility by which is used to verify satisfaction of the QAP -/
def l : polynomial F := ∏ i in (finset.fin_range n_wit), (polynomial.X - polynomial.C (r i))
-- TODO this could potentially be spun off into a mathlib definition

/-- Checks whether a statement witness pair satisfies the QAP -/
def satisfying (a_stmt : fin n_stmt → F ) (a_wit : fin n_wit → F) :=
((∑ i in (finset.fin_range n_stmt), a_stmt i • u_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • u_wit i))
  *
(∑ i in (finset.fin_range n_stmt), a_stmt i • v_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • v_wit i))
  -
(∑ i in (finset.fin_range n_stmt), a_stmt i • w_stmt i
  + (∑ i in (finset.fin_range n_wit), a_wit i • w_wit i)))
   %ₘ l = 0

run_cmd mk_simp_attr `crs
run_cmd tactic.add_doc_string `simp_attr.crs "Attribute for defintions of CRS elements"

/-- The modified CRS elements, see fig 3 of the paper  -/
@[crs]
def crs'_P_all_wit_1 (i : fin n_wit) : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ (β - α + δ) * C (u_wit i)
 + (X vars.y) ^ (β - α + γ) * C (v_wit i)
 + (X vars.y) ^ (2 * β - α) * C (w_wit i)
@[crs]
def crs'_P_α_1 : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ α
@[crs]
def crs'_P_powers_1 (i : fin n_var) : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ β * C (polynomial.X ^ (i : ℕ))
@[crs]
def crs'_P_l_1 (i : fin (n_var - 1)) : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ (2 * β - α) * C l * C (polynomial.X ^ (i : ℕ))
-- @[crs]
-- def crs'_P_γ_1 : mv_polynomial vars (polynomial F) :=
--  (X vars.y) ^ γ
@[crs]
def crs'_P_δ_1 : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ δ
@[crs]
def crs'_P_se_α_z_1 : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ α * (X vars.z) -- Only in S_qap^se
@[crs]
def crs'_P_se_powers_1 (i : fin n_var) : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ β * (X vars.z) * C (polynomial.X ^ (i : ℕ))  -- Only in S_qap^se
-- @[crs]
-- def crs'_P_α_2 : mv_polynomial vars (polynomial F) :=
--  (X vars.y) ^ α
@[crs]
def crs'_P_powers_2 (i : fin n_var) : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ β * C (polynomial.X ^ (i : ℕ)) -- same as crs'_P_powers_1

@[crs]
def crs'_V_all_stmt_1 (i : fin n_stmt) : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ (β - η + δ) * C (u_stmt i)
 + (X vars.y) ^ (β - η + γ) * C (v_stmt i)
 + (X vars.y) ^ (2 * β - η) * C (w_stmt i)
-- @[crs]
-- def crs'_V_γ_1 : mv_polynomial vars (polynomial F) :=
--  (X vars.y) ^ γ -- Same as crs'_P_γ_1
@[crs]
def crs'_V_se_z_1 : mv_polynomial vars (polynomial F) :=
  (X vars.z) -- Only in S_qap^se
-- @[crs]
-- def crs'_V_α_2 : mv_polynomial vars (polynomial F) :=
--  (X vars.y) ^ α
@[crs]
def crs'_V_δ_2 : mv_polynomial vars (polynomial F) :=
  (X vars.y) ^ δ
@[crs]
def crs'_V_η_2 : mv_polynomial vars (polynomial F) :=
  (X vars.y) ^ η
@[crs]
def crs'_V_γ_δ_T : mv_polynomial vars (polynomial F) :=
  (X vars.y) ^ (γ + δ)

-- Elements both prover and verifier use

@[crs]
def crs'_γ_1 : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ γ
@[crs]
def crs'_α_2 : mv_polynomial vars (polynomial F) :=
 (X vars.y) ^ α

parameters {A_comp_crs'_P_all_wit_1 : fin n_wit → F}
parameters {A_comp_crs'_P_α_1 : F}
parameters {A_comp_crs'_P_powers_1 : fin n_var → F}
parameters {A_comp_crs'_P_l_1 : fin (n_var - 1) → F}
parameters {A_comp_crs'_γ_1 : F}
parameters {A_comp_crs'_P_δ_1 : F}
-- parameters {A_comp_crs'_P_se_α_z_1 : F}
-- parameters {A_comp_crs'_P_se_powers_1 : fin n_var → F}
parameters {A_comp_crs'_V_all_stmt_1 : fin n_stmt → F}
-- parameters {A_comp_crs'_V_γ_1 : F} -- Same as previous
-- parameters {A_comp_crs'_V_se_z_1 : F}

/-- Polynomial form of A in the adversary's proof representation -/
def A' : mv_polynomial vars (polynomial F) :=
  ∑ i in (finset.fin_range n_wit), (crs'_P_all_wit_1 i) * C (polynomial.C (A_comp_crs'_P_all_wit_1 i))
  +
  crs'_P_α_1 * C (polynomial.C (A_comp_crs'_P_α_1))
  +
  ∑ i in (finset.fin_range n_var), (crs'_P_powers_1 i) * C (polynomial.C (A_comp_crs'_P_powers_1 i))
  +
  ∑ i in (finset.fin_range (n_var - 1)), (crs'_P_l_1 i) * C (polynomial.C (A_comp_crs'_P_l_1 i))
  +
  crs'_γ_1 * C (polynomial.C (A_comp_crs'_γ_1))
  +
  crs'_P_δ_1 * C (polynomial.C (A_comp_crs'_P_δ_1))
  +
  ∑ i in (finset.fin_range n_stmt), (crs'_V_all_stmt_1 i) * C (polynomial.C (A_comp_crs'_V_all_stmt_1 i))

parameters {B_comp_crs'_α_2 : F}
parameters {B_comp_crs'_P_powers_2 : fin n_var → F}
-- parameters {B_comp_crs'_V_α_2 : F} -- Same as previous
parameters {B_comp_crs'_V_δ_2 : F}
parameters {B_comp_crs'_V_η_2 : F}

/-- Polynomial form of B in the adversary's proof representation -/
def B' : mv_polynomial vars (polynomial F) :=
  crs'_α_2 * C (polynomial.C (B_comp_crs'_α_2))
  +
  ∑ i in (finset.fin_range n_var), (crs'_P_powers_2 i) * C (polynomial.C (B_comp_crs'_P_powers_2 i))
  +
  crs'_V_δ_2 * C (polynomial.C (B_comp_crs'_V_δ_2))
  +
  crs'_V_η_2 * C (polynomial.C (B_comp_crs'_V_η_2))

parameters {C_comp_crs'_P_all_wit_1 : fin n_wit → F}
parameters {C_comp_crs'_P_α_1 : F}
parameters {C_comp_crs'_P_powers_1 : fin n_var → F}
parameters {C_comp_crs'_P_l_1 : fin (n_var - 1) → F}
parameters {C_comp_crs'_P_γ_1 : F}
parameters {C_comp_crs'_P_δ_1 : F}
-- parameters {C_comp_crs'_P_se_α_z_1 : F}
-- parameters {C_comp_crs'_P_se_powers_1 : fin n_var → F}
parameters {C_comp_crs'_V_all_stmt_1 : fin n_stmt → F}
-- parameters {C_comp_crs'_V_γ_1 : F} -- Same as previous
-- parameters {C_comp_crs'_V_se_z_1 : F}

/-- Polynomial form of C in the adversary's proof representation -/
def C' : mv_polynomial vars (polynomial F) :=
  ∑ i in (finset.fin_range n_wit), (crs'_P_all_wit_1 i) * C (polynomial.C (C_comp_crs'_P_all_wit_1 i))
  +
  crs'_P_α_1 * C (polynomial.C (C_comp_crs'_P_α_1))
  +
  ∑ i in (finset.fin_range n_var), (crs'_P_powers_1 i) * C (polynomial.C (C_comp_crs'_P_powers_1 i))
  +
  ∑ i in (finset.fin_range (n_var - 1)), (crs'_P_l_1 i) * C (polynomial.C (C_comp_crs'_P_l_1 i))
  +
  crs'_γ_1 * C (polynomial.C (C_comp_crs'_P_γ_1))
  +
  crs'_P_δ_1 * C (polynomial.C (C_comp_crs'_P_δ_1))
  +
  ∑ i in (finset.fin_range n_stmt), (crs'_V_all_stmt_1 i) * C (polynomial.C (C_comp_crs'_V_all_stmt_1 i))

def verified' (a_stmt : fin n_stmt → F ) : Prop :=
  (∑ i in finset.fin_range n_stmt, C (polynomial.C (a_stmt i)) * crs'_V_all_stmt_1 i ) * crs'_V_η_2
  +
  C' * crs'_α_2
  =
  (A' + crs'_γ_1) * (B' + crs'_V_δ_2) - crs'_V_γ_δ_T

-- A, modified to be more like what we see in Baghery et al. - this includes athe extra y^γ we see
-- that the verifier adds.

def A_mod_comp_crs_P_γ_1 := A_comp_crs'_γ_1 + 1

lemma A_mod_transform :
  A' + crs'_γ_1 =
   ∑ i in (finset.fin_range n_wit), (crs'_P_all_wit_1 i) * C (polynomial.C (A_comp_crs'_P_all_wit_1 i))
  +
  crs'_P_α_1 * C (polynomial.C (A_comp_crs'_P_α_1))
  +
  ∑ i in (finset.fin_range n_var), (crs'_P_powers_1 i) * C (polynomial.C (A_comp_crs'_P_powers_1 i))
  +
  ∑ i in (finset.fin_range (n_var - 1)), (crs'_P_l_1 i) * C (polynomial.C (A_comp_crs'_P_l_1 i))
  +
  crs'_γ_1 * C (polynomial.C (A_mod_comp_crs_P_γ_1))
  +
  crs'_P_δ_1 * C (polynomial.C (A_comp_crs'_P_δ_1))
  +
  ∑ i in (finset.fin_range n_stmt), (crs'_V_all_stmt_1 i) * C (polynomial.C (A_comp_crs'_V_all_stmt_1 i)) :=
begin
  rw [A', A_mod_comp_crs_P_γ_1],
  simp only [mv_polynomial.C_add, ring_hom.map_add, ring_hom.map_one, mv_polynomial.C_1, mul_add, mul_one],
  abel,
end

-- B, modified to be more like what we see in Baghery et al. - this includes athe extra y^γ we see
-- that the verifier adds.

def B_mod_comp_crs_V_δ_2 := B_comp_crs'_V_δ_2 + 1

lemma B_mod_transform :
  B' + crs'_V_δ_2 =
  crs'_α_2 * C (polynomial.C (B_comp_crs'_α_2))
  +
  ∑ i in (finset.fin_range n_var), (crs'_P_powers_2 i) * C (polynomial.C (B_comp_crs'_P_powers_2 i))
  +
  crs'_V_δ_2 * C (polynomial.C (B_mod_comp_crs_V_δ_2))
  +
  crs'_V_η_2 * C (polynomial.C (B_comp_crs'_V_η_2)) :=
begin
  rw [B', B_mod_comp_crs_V_δ_2],
  simp only [mv_polynomial.C_add, ring_hom.map_add, ring_hom.map_one, mv_polynomial.C_1, mul_add, mul_one],
  abel,
end

-- TODO use this for lots of profiling data
-- set_option profiler true

open finsupp

-- TODO Add to Mathlib next to C_eq_zero
@[simp] lemma polynomial.C_eq_one (a : F) : polynomial.C a = 1 ↔ a = 1 :=
calc polynomial.C a = 1 ↔ polynomial.C a = polynomial.C 1 : by rw polynomial.C_1
         ... ↔ a = 1 : polynomial.C_inj

lemma simplifier1 (x : fin n_stmt) (a_stmt : fin n_stmt → F )
  : polynomial.C (a_stmt x) * u_stmt x = u_stmt x * polynomial.C (a_stmt x)
  :=
  by ring

lemma simplifier2 (x : fin n_stmt) (a_stmt : fin n_stmt → F )
  : polynomial.C (a_stmt x) * v_stmt x = v_stmt x * polynomial.C (a_stmt x)
  :=
  by ring

lemma polynomial.mul_mod_by_monic (t p : polynomial F) (mt : t.monic) : (t * p) %ₘ t = 0 :=
begin
  rw polynomial.dvd_iff_mod_by_monic_eq_zero,
  apply dvd_mul_right,
  exact mt,
end

lemma A_mod_comp_crs_P_γ_1_mul (p : polynomial F) : p * polynomial.C A_mod_comp_crs_P_γ_1  = polynomial.C A_mod_comp_crs_P_γ_1 * p := by ring

lemma B_mod_comp_crs_V_δ_2_mul (p : polynomial F) : p * polynomial.C B_mod_comp_crs_V_δ_2  = polynomial.C B_mod_comp_crs_V_δ_2 * p := by ring

/-- The main theorem for the soundness of the Lipmaa SNARK. Due to the error in the number of necessary monomials, the proof doesn't go through. -/
theorem soundness (a_stmt : fin n_stmt → F ) :
  verified' a_stmt
  -> (satisfying a_stmt C_comp_crs'_P_all_wit_1)
:=
begin

  intros eqn',

  rw satisfying,
  simp only [polynomial.smul_eq_C_mul, rearrange_constants_right_hard],
  suffices :
    (∑ (i : fin n_stmt) in finset.fin_range n_stmt, u_stmt i * polynomial.C (a_stmt i) + ∑ (i : fin n_wit) in finset.fin_range n_wit, u_wit i * polynomial.C (C_comp_crs'_P_all_wit_1  i))
    *
    (∑ (i : fin n_stmt) in finset.fin_range n_stmt, v_stmt i * polynomial.C (a_stmt i) + ∑ (i : fin n_wit) in finset.fin_range n_wit, v_wit i * polynomial.C (C_comp_crs'_P_all_wit_1  i))
    =
    (∑ (i : fin n_stmt) in finset.fin_range n_stmt, w_stmt i * polynomial.C (a_stmt i) + ∑ (i : fin n_wit) in finset.fin_range n_wit, w_wit i * polynomial.C (C_comp_crs'_P_all_wit_1  i))
    +
    ∑ (x : fin (n_var - 1)) in finset.fin_range (n_var - 1), l * polynomial.X ^ (x : ℕ) * polynomial.C (C_comp_crs'_P_l_1 x),
  {
    rw <-sub_eq_iff_eq_add' at this,
    have h := congr_arg (%ₘ l) this,
    simp only at h,
    rw h,
    clear this h,
    conv
    begin
      to_lhs,
      congr,
      congr,
      skip,
      funext,
      rw mul_comm,
      rw <-mul_assoc,
      skip,
    end,
    simp_rw mul_comm _ l,
    simp_rw mul_assoc,
    simp_rw mul_comm l _,
    rw <-finset.sum_mul,
    rw mul_comm,
    apply polynomial.mul_mod_by_monic,
    rw l,
    apply monic_of_product_form,
  },

  rw verified' at eqn',
  rw [A_mod_transform, B_mod_transform, C'] at eqn',
  simp only [] with crs at eqn',
  -- simp only [] with polynomial_nf_3 at eqn',
  simp only [α, β, γ, δ, η, algebra.id.smul_eq_mul, nat.succ_sub_succ, nat.sub_zero, nat.zero_mul, nat.mul_zero, nat.zero_add, nat.add_zero, nat.mul_succ, nat.add_succ] at eqn',
  -- done,
  simp only [mv_polynomial.X, C_apply, mv_polynomial.monomial_mul, mv_polynomial.monomial_pow, finsupp.smul_single, one_pow, one_mul, mul_one, add_zero, zero_add, finset.sum_add_distrib, finset.sum_hom, mul_add, add_mul, sum_monomial_hom] at eqn',

  -- have h0 := congr_arg (coeff (single vars.y 0)) eqn',
  -- -- have h1 := congr_arg (coeff (single vars.y 1)) eqn',
  -- -- have h2 := congr_arg (coeff (single vars.y 2)) eqn',
  -- -- have h3 := congr_arg (coeff (single vars.y 3)) eqn',
  -- -- have h4 := congr_arg (coeff (single vars.y 4)) eqn',
  -- have h5 := congr_arg (coeff (single vars.y 5)) eqn',
  -- -- have h6 := congr_arg (coeff (single vars.y 6)) eqn',
  -- have h7 := congr_arg (coeff (single vars.y 7)) eqn',
  -- -- have h8 := congr_arg (coeff (single vars.y 8)) eqn',
  -- -- have h9 := congr_arg (coeff (single vars.y 9)) eqn',
  -- have h10 := congr_arg (coeff (single vars.y 10)) eqn',
  -- -- have h11 := congr_arg (coeff (single vars.y 11)) eqn',
  -- -- have h12 := congr_arg (coeff (single vars.y 12)) eqn',
  -- -- have h13 := congr_arg (coeff (single vars.y 13)) eqn',
  -- have h14 := congr_arg (coeff (single vars.y 14)) eqn',
  -- -- have h15 := congr_arg (coeff (single vars.y 15)) eqn',
  -- -- have h16 := congr_arg (coeff (single vars.y 16)) eqn',
  -- have h17 := congr_arg (coeff (single vars.y 17)) eqn',
  -- have h18 := congr_arg (coeff (single vars.y 18)) eqn',
  -- -- have h19 := congr_arg (coeff (single vars.y 19)) eqn',
  -- have h20 := congr_arg (coeff (single vars.y 20)) eqn',
  -- -- have h21 := congr_arg (coeff (single vars.y 21)) eqn',
  -- -- have h22 := congr_arg (coeff (single vars.y 22)) eqn',
  -- -- have h23 := congr_arg (coeff (single vars.y 23)) eqn',
  -- -- have h24 := congr_arg (coeff (single vars.y 24)) eqn',
  -- -- have h25 := congr_arg (coeff (single vars.y 25)) eqn',
  -- -- have h26 := congr_arg (coeff (single vars.y 26)) eqn',
  -- -- have h27 := congr_arg (coeff (single vars.y 27)) eqn',

-- def α : ℕ := 26
-- def β : ℕ := 27
-- def γ : ℕ := 0
-- def δ : ℕ := 40
-- def η : ℕ := 24

  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 0 - (β-η) * 1 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 0 - (β-η) * 2 - (β-α) * 1
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 0 - (β-η) * 2 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 1 - (β-η) * 1 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 1 - (β-η) * 2 - (β-α) * 1
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 1 - (β-η) * 2 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 2 - (β-η) * 1 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 2 - (β-η) * 2 - (β-α) * 1
  -- #eval 2 * β - (β-γ) * 0 + (δ-β) * 2 - (β-η) * 2 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 1 + (δ-β) * 0 - (β-η) * 2 - (β-α) * 2
  -- -- #eval 2 * β - (β-γ) * 1 + (δ-β) * 0 - (β-η) * 2 - (β-α) * 3
  -- #eval 2 * β - (β-γ) * 1 + (δ-β) * 1 - (β-η) * 1 - (β-α) * 2
  -- #eval 2 * β - (β-γ) * 1 + (δ-β) * 1 - (β-η) * 2 - (β-α) * 1
  -- #eval 2 * β - (β-γ) * 1 + (δ-β) * 1 - (β-η) * 2 - (β-α) * 2,

  have h0012 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 0 + (β-η) * 1 + (β-α) * 0))) eqn',
  have h0021 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 0 + (β-η) * 0 + (β-α) * 1))) eqn',
  have h0022 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 0 + (β-η) * 0 + (β-α) * 0))) eqn',
  -- have h0022 := congr_arg (coeff (single vars.y (46))) eqn',
  have h0112 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 1 + (β-η) * 1 + (β-α) * 0))) eqn',
  have h0121 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 1 + (β-η) * 0 + (β-α) * 1))) eqn',
  have h0122 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 1 + (β-η) * 0 + (β-α) * 0))) eqn',
  have h0212 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 2 + (β-η) * 1 + (β-α) * 0))) eqn',
  have h0221 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 2 + (β-η) * 0 + (β-α) * 1))) eqn',
  have h0222 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 0 + (δ-β) * 2 + (β-η) * 0 + (β-α) * 0))) eqn',
  have h1022 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 1 + (δ-β) * 0 + (β-η) * 0 + (β-α) * 0))) eqn',
  -- have h1023 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 1 + (δ-β) * 0 + (β-η) * 0 - (β-α) * 3))) eqn',
  have h1112 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 1 + (δ-β) * 1 + (β-η) * 1 + (β-α) * 0))) eqn',
  have h1121 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 1 + (δ-β) * 1 + (β-η) * 0 + (β-α) * 1))) eqn',
  have h1122 := congr_arg (coeff (single vars.y (2 * β - (β-γ) * 1 + (δ-β) * 1 + (β-η) * 0 + (β-α) * 0))) eqn',

  simp only [α, β, η, δ, γ, algebra.id.smul_eq_mul, nat.succ_sub_succ, nat.sub_zero, nat.zero_mul, nat.mul_zero, nat.zero_add, nat.add_zero, nat.mul_succ, nat.add_succ] at h0012 h0021 h0022 h0112 h0121 h0122 h0212 h0221 h0222 h1022 h1112 h1121 h1122,

  -- done,

  clear eqn',
  -- clear h0012 h0021 h0112 h0121 h0122 h0212 h0221 h0222 h1022 h1112 h1121 h1122,

  -- done,

  simp only [finsupp_vars_eq_ext, mv_polynomial.coeff_sub] with coeff_simp finsupp_eq at h0012 h0021 h0022 h0112 h0121 h0122 h0212 h0221 h0222 h1022 h1112 h1121 h1122,

  -- simp only [finsupp_vars_eq_ext, mv_polynomial.coeff_sub] with coeff_simp finsupp_eq at h0022,

  -- simp only [algebra.id.smul_eq_mul, nat.succ_sub_succ, nat.sub_zero, nat.zero_mul, nat.mul_zero, nat.mul_succ, nat.add_succ] with finsupp_simp at h0022,
  simp only [algebra.id.smul_eq_mul, nat.succ_sub_succ, sub_zero, nat.zero_mul, nat.mul_zero, nat.mul_succ, nat.add_succ] with finsupp_simp at h0012 h0021 h0022 h0112 h0121 h0122 h0212 h0221 h0222 h1022 h1112 h1121 h1122,

  -- abel at *,
  rw sub_eq_zero at h1122,

  done,

  -- Step 2: Recursively simplify and case-analyze the equations

  trace "Moving Cs right",
  simp only [simplifier1, simplifier2] at *,

  trace "Grouping distributivity",
  simp only [<-mul_add, <-add_mul, <-add_assoc, add_mul_distrib, add_mul_distrib'] at *,

  have h1022' :
    polynomial.C A_mod_comp_crs_P_γ_1 *
      ∑ (x : fin n_var) in finset.fin_range n_var,
        polynomial.X ^ (x : ℕ) * polynomial.C (B_comp_crs'_P_powers_2 x) +
      (∑ (x : fin n_stmt) in finset.fin_range n_stmt, v_stmt x * polynomial.C (A_comp_crs'_V_all_stmt_1 x)) *
        polynomial.C B_comp_crs'_V_η_2 +
    (∑ (x : fin n_wit) in finset.fin_range n_wit, v_wit x * polynomial.C (A_comp_crs'_P_all_wit_1 x)) *
          polynomial.C B_comp_crs'_α_2 =
    ∑ (x : fin n_stmt) in finset.fin_range n_stmt, v_stmt x * polynomial.C (a_stmt x) +
      ∑ (x : fin n_wit) in finset.fin_range n_wit, v_wit x * polynomial.C (C_comp_crs'_P_all_wit_1 x),
  {
    rw h1022,
    ring,
  },

  have h0122' :
    polynomial.C A_comp_crs'_P_δ_1 *
      ∑ (x : fin n_var) in finset.fin_range n_var,
        polynomial.X ^ (x : ℕ) * polynomial.C (B_comp_crs'_P_powers_2 x) +
    (∑ (x : fin n_var) in finset.fin_range n_var,
       polynomial.X ^ (x : ℕ) * polynomial.C (A_comp_crs'_P_powers_1 x)) *
            polynomial.C B_mod_comp_crs_V_δ_2 +
    (∑ (x : fin n_stmt) in finset.fin_range n_stmt, u_stmt x * polynomial.C (A_comp_crs'_V_all_stmt_1 x)) *
        polynomial.C B_comp_crs'_V_η_2 +
    (∑ (x : fin n_wit) in finset.fin_range n_wit, u_wit x * polynomial.C (A_comp_crs'_P_all_wit_1 x)) *
              polynomial.C B_comp_crs'_α_2  =
    ∑ (x : fin n_stmt) in finset.fin_range n_stmt, u_stmt x * polynomial.C (a_stmt x) +
      ∑ (x : fin n_wit) in finset.fin_range n_wit, u_wit x * polynomial.C (C_comp_crs'_P_all_wit_1 x),
  {
    rw h0122,
    ring,
  },

  have h0022' :
    (∑ (x : fin n_var) in finset.fin_range n_var,
      polynomial.X ^ (x : ℕ) * polynomial.C (A_comp_crs'_P_powers_1 x)) *
    ∑ (x : fin n_var) in finset.fin_range n_var,
      polynomial.X ^ (x : ℕ) * polynomial.C (B_comp_crs'_P_powers_2 x) +
    (∑ (x : fin n_stmt) in finset.fin_range n_stmt, w_stmt x * polynomial.C (A_comp_crs'_V_all_stmt_1 x)) *
        polynomial.C B_comp_crs'_V_η_2 +
    polynomial.C B_comp_crs'_α_2  *
      ((∑ (x : fin n_wit) in finset.fin_range n_wit, w_wit x * polynomial.C (A_comp_crs'_P_all_wit_1 x)) +
       (∑ (x : fin (n_var - 1)) in finset.fin_range (n_var - 1),
         l * polynomial.X ^ (x : ℕ) * polynomial.C (A_comp_crs'_P_l_1 x)))
    =
    ∑ (x : fin n_stmt) in finset.fin_range n_stmt, w_stmt x * polynomial.C (a_stmt x) +
        ∑ (x : fin n_wit) in finset.fin_range n_wit, w_wit x * polynomial.C (C_comp_crs'_P_all_wit_1 x) +
      ∑ (x : fin (n_var - 1)) in
        finset.fin_range (n_var - 1),
        l * polynomial.X ^ (x : ℕ) * polynomial.C (C_comp_crs'_P_l_1 x),
  {
    rw h0022,
    ring,
  },

  clear h0122 h1022 h0022,

  -- hack rewrites to get things the same as in the groth16typeIII
  rw eq_comm at h0012 h0021 h0112 h0121 h0212 h0221 h0222 h1112 h1121 h1122 h0122' h1022' h0022',

  rw eq_comm at h0021 h0022' h0121 h0012 h0112 h0122' h1022' h0212 h0221 h0222 h1112 h1121 h1122,

  -- done,

  trace "Main simplification",
  simp only [*] with integral_domain_simp at *,

  -- have hγη : (1 + polynomial.C A_comp_crs'_P_γ_1) * polynomial.C B_comp_crs'_V_η_2 = 0,
  -- { rw add_mul, rw <-h5, ring, },
  -- rw mul_eq_zero at hγη,

  -- have hδδ : polynomial.C A_comp_crs'_P_δ_1 * (1 + polynomial.C B_comp_crs'_V_δ_2) = 0,
  -- { rw mul_add, rw <-h0222, ring, },
  -- rw mul_eq_zero at hδδ,

  -- have hγδ : (1 + polynomial.C A_comp_crs'_P_γ_1) * (1 + polynomial.C B_comp_crs'_V_δ_2) = 1,
  -- { rw <-sub_eq_zero, rw <-h1122, ring, },

  -- have hββ := h14,
  -- have hβγ := h7,
  -- have hβδ := h17,
  -- have hγγ := h0,
  -- have hγδ := h10,

  -- clear h0 h5 h7 h10 h14 h17 h20,

  tactic.integral_domain_tactic_v4,

  -- rw <-hβγ,
  -- rw <-hβδ,
  -- rw <-hββ,

  -- done,

  -- Solve remaining four cases by hand
  { rw [<-h1022', <-h0122', <-h0022'],
    simp only [B_mod_comp_crs_V_δ_2_mul],
    simp only [<-mul_assoc],
    simp only [A_mod_comp_crs_P_γ_1_mul],
    simp only [<-mul_assoc],
    rw h1122,
    ring, },

end

end lipmaa


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

/-!
# Determinant of families of vectors

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

## Main definitions

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

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

## Tags

basis, det, determinant
-/

noncomputable theory

open_locale big_operators
open_locale matrix

open linear_map
open submodule

universes u v w

open linear_map matrix set function

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

section conjugate

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

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

namespace matrix

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

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

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

/-- If `M'` is a two-sided inverse for `M` (indexed differently), `det (M ⬝ N ⬝ M') = det N`. -/
lemma det_conj [is_domain A] [decidable_eq m] [decidable_eq n]
  {M : matrix m n A} {M' : matrix n m A} {N : matrix n n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  det (M ⬝ N ⬝ M') = det N :=
by rw [← det_comm' hM'M hMM', ← matrix.mul_assoc, hM'M, matrix.one_mul]

end matrix

end conjugate

namespace linear_map

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

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

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

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

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

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

/-- Unfold lemma for `det_aux`.

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

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

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

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

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

section
open_locale classical

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

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

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

end

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end linear_map

namespace linear_equiv

variables [is_domain R]

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

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

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

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

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

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

end linear_equiv

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.action
import combinatorics.quiver
import group_theory.is_free_group
/-!
# The Nielsen-Schreier theorem

This file proves that a subgroup of a free group is itself free.

## Main result

- `subgroup_is_free_of_is_free H`: an instance saying that a subgroup of a free group is free.

## Proof overview

The proof is analogous to the proof using covering spaces and fundamental groups of graphs,
but we work directly with groupoids instead of topological spaces. Under this analogy,

- `is_free_groupoid G` corresponds to saying that a space is a graph.
- `End_mul_equiv_subgroup H` plays the role of replacing 'subgroup of fundamental group' with
  'fundamental group of covering space'.
- `action_category_is_free G A` corresponds to the fact that a covering of a (single-vertex)
  graph is a graph.
- `End_is_free_group_of_arborescence` corresponds to the fact that, given a spanning tree of a
  graph, its fundamental group is free (generated by loops from the complement of the tree).

## Implementation notes

Our definition of `is_free_groupoid` is nonstandard. Normally one would require that functors
`G ⥤ X` to any _groupoid_ `X` are given by graph homomorphisms from the generators, but we only
consider _groups_ `X`. This simplifies the argument since functor equality is complicated in
general, but simple for functors to single object categories.

## References

https://ncatlab.org/nlab/show/Nielsen-Schreier+theorem

## Tags

free group, free groupoid, Nielsen-Schreier

-/

noncomputable theory
open_locale classical
universes v u

open category_theory category_theory.action_category category_theory.single_obj quiver
  is_free_group as fgp

/-- `is_free_groupoid.generators G` is a type synonym for `G`. We think of this as
the vertices of the generating quiver of `G` when `G` is free. We can't use `G` directly,
since `G` already has a quiver instance from being a groupoid. -/
@[nolint unused_arguments has_inhabited_instance]
def is_free_groupoid.generators (G) [groupoid G] := G

/-- A groupoid `G` is free when we have the following data:
 - a quiver on `is_free_groupoid.generators G` (a type synonym for `G`)
 - a function `of` taking a generating arrow to a morphism in `G`
 - such that a functor from `G` to any group `X` is uniquely determined
   by assigning labels in `X` to the generating arrows.

   This definition is nonstandard. Normally one would require that functors `G ⥤ X`
   to any _groupoid_ `X` are given by graph homomorphisms from `generators`. -/
class is_free_groupoid (G) [groupoid.{v} G] :=
(quiver_generators : quiver.{v+1} (is_free_groupoid.generators G))
(of : Π {a b : is_free_groupoid.generators G}, (a ⟶ b) → ((show G, from a) ⟶ b))
(unique_lift : ∀ {X : Type v} [group X] (f : labelling (is_free_groupoid.generators G) X),
                ∃! F : G ⥤ single_obj X, ∀ a b (g : a ⟶ b),
                  F.map (of g) = f g)

namespace is_free_groupoid

attribute [instance] quiver_generators

/-- Two functors from a free groupoid to a group are equal when they agree on the generating
quiver. -/
@[ext]
lemma ext_functor {G} [groupoid.{v} G] [is_free_groupoid G] {X : Type v} [group X]
  (f g : G ⥤ single_obj X)
  (h : ∀ a b (e : a ⟶ b), f.map (of e) = g.map (of e)) :
  f = g :=
let ⟨_, _, u⟩ := @unique_lift G _ _ X _ (λ (a b : generators G) (e : a ⟶ b), g.map (of e)) in
trans (u _ h) (u _ (λ _ _ _, rfl)).symm

/-- An action groupoid over a free froup is free. More generally, one could show that the groupoid
of elements over a free groupoid is free, but this version is easier to prove and suffices for our
purposes.

Analogous to the fact that a covering space of a graph is a graph. (A free groupoid is like a graph,
and a groupoid of elements is like a covering space.) -/
instance action_groupoid_is_free {G A : Type u} [group G] [is_free_group G] [mul_action G A] :
  is_free_groupoid (action_category G A) :=
{ quiver_generators := ⟨λ a b, { e : fgp.generators G // fgp.of e • a.back = b.back }⟩,
  of := λ a b e, ⟨fgp.of e, e.property⟩,
  unique_lift := begin
    introsI X _ f,
    let f' : fgp.generators G → (A → X) ⋊[mul_aut_arrow] G :=
      λ e, ⟨λ b, @f ⟨(), _⟩ ⟨(), b⟩ ⟨e, smul_inv_smul _ b⟩, fgp.of e⟩,
    rcases fgp.unique_lift f' with ⟨F', hF', uF'⟩,
    refine ⟨uncurry F' _, _, _⟩,
    { suffices : semidirect_product.right_hom.comp F' = monoid_hom.id _,
      { exact monoid_hom.ext_iff.mp this },
      ext,
      rw [monoid_hom.comp_apply, hF'],
      refl },
    { rintros ⟨⟨⟩, a : A⟩ ⟨⟨⟩, b⟩ ⟨e, h : fgp.of e • a = b⟩,
      change (F' (fgp.of _)).left _ = _,
      rw hF',
      cases (inv_smul_eq_iff.mpr h.symm),
      refl },
    { intros E hE,
      have : curry E = F',
      { apply uF',
        intro e,
        ext,
        { convert hE _ _ _, refl },
        { refl } },
      apply functor.hext,
      { intro, apply unit.ext },
      { refine action_category.cases _, intros,
        simp only [←this, uncurry_map, curry_apply_left, coe_back, hom_of_pair.val] } },
  end }

namespace spanning_tree
/- In this section, we suppose we have a free groupoid with a spanning tree for its generating
quiver. The goal is to prove that the vertex group at the root is free. A picture to have in mind
is that we are 'pulling' the endpoints of all the edges of the quiver along the spanning tree to
the root. -/
variables {G : Type u} [groupoid.{u} G] [is_free_groupoid G]
  (T : wide_subquiver (symmetrify $ generators G)) [arborescence T]

/-- The root of `T`, except its type is `G` instead of the type synonym `T`. -/
private def root' : G := show T, from root T

/-- A path in the tree gives a hom, by composition. -/
-- this has to be marked noncomputable, see issue #451.
-- It might be nicer to define this in terms of `compose_path`
noncomputable def hom_of_path : Π {a : G}, path (root T) a → (root' T ⟶ a)
| _ path.nil := 𝟙 _
| a (path.cons p f) := hom_of_path p ≫ sum.rec_on f.val (λ e, of e) (λ e, inv (of e))

/-- For every vertex `a`, there is a canonical hom from the root, given by the path in the tree. -/
def tree_hom (a : G) : root' T ⟶ a := hom_of_path T (default _)

/-- Any path to `a` gives `tree_hom T a`, since paths in the tree are unique. -/
lemma tree_hom_eq {a : G} (p : path (root T) a) : tree_hom T a = hom_of_path T p :=
by rw [tree_hom, unique.default_eq]

@[simp] lemma tree_hom_root : tree_hom T (root' T) = 𝟙 _ :=
-- this should just be `tree_hom_eq T path.nil`, but Lean treats `hom_of_path` with suspicion.
trans (tree_hom_eq T path.nil) rfl

/-- Any hom in `G` can be made into a loop, by conjugating with `tree_hom`s. -/
def loop_of_hom {a b : G} (p : a ⟶ b) : End (root' T) :=
tree_hom T a ≫ p ≫ inv (tree_hom T b)

/-- Turning an edge in the spanning tree into a loop gives the indentity loop. -/
lemma loop_of_hom_eq_id {a b : generators G} (e ∈ wide_subquiver_symmetrify T a b) :
  loop_of_hom T (of e) = 𝟙 (root' T) :=
begin
  rw [loop_of_hom, ←category.assoc, is_iso.comp_inv_eq, category.id_comp],
  cases H,
  { rw [tree_hom_eq T (path.cons (default _) ⟨sum.inl e, H⟩), hom_of_path], refl },
  { rw [tree_hom_eq T (path.cons (default _) ⟨sum.inr e, H⟩), hom_of_path],
    simp only [is_iso.inv_hom_id, category.comp_id, category.assoc, tree_hom] }
end

/-- Since a hom gives a loop, any homomorphism from the vertex group at the root
    extends to a functor on the whole groupoid. -/
@[simps] def functor_of_monoid_hom {X} [monoid X] (f : End (root' T) →* X) :
  G ⥤ single_obj X :=
{ obj := λ _, (),
  map := λ a b p, f (loop_of_hom T p),
  map_id' := begin
    intro a,
    rw [loop_of_hom, category.id_comp, is_iso.hom_inv_id, ←End.one_def, f.map_one, id_as_one],
 end,
  map_comp' := begin
    intros,
    rw [comp_as_mul, ←f.map_mul],
    simp only [is_iso.inv_hom_id_assoc, loop_of_hom, End.mul_def, category.assoc]
  end }

/-- Given a free groupoid and an arborescence of its generating quiver, the vertex
    group at the root is freely generated by loops coming from generating arrows
    in the complement of the tree. -/
def End_is_free : is_free_group (End (root' T)) :=
{ generators := set.compl (wide_subquiver_equiv_set_total $ wide_subquiver_symmetrify T),
  of := λ e, loop_of_hom T (of e.val.hom),
  unique_lift' := begin
    introsI X _ f,
    let f' : labelling (generators G) X := λ a b e,
      if h : e ∈ wide_subquiver_symmetrify T a b then 1
      else f ⟨⟨a, b, e⟩, h⟩,
    rcases unique_lift f' with ⟨F', hF', uF'⟩,
    refine ⟨F'.map_End _, _, _⟩,
    { suffices : ∀ {x y} (q : x ⟶ y), F'.map (loop_of_hom T q) = (F'.map q : X),
      { rintro ⟨⟨a, b, e⟩, h⟩,
        rw [functor.map_End_apply, this, hF'],
        exact dif_neg h },
      intros,
      suffices : ∀ {a} (p : path (root' T) a), F'.map (hom_of_path T p) = 1,
      { simp only [this, tree_hom, comp_as_mul, inv_as_inv, loop_of_hom,
        one_inv, mul_one, one_mul, functor.map_inv, functor.map_comp] },
      intros a p, induction p with b c p e ih,
      { rw [hom_of_path, F'.map_id, id_as_one] },
      rw [hom_of_path, F'.map_comp, comp_as_mul, ih, mul_one],
      rcases e with ⟨e | e, eT⟩,
      { rw hF', exact dif_pos (or.inl eT) },
      { rw [F'.map_inv, inv_as_inv, inv_eq_one, hF'], exact dif_pos (or.inr eT) } },
    { intros E hE,
      ext,
      suffices : (functor_of_monoid_hom T E).map x = F'.map x,
      { simpa only [loop_of_hom, functor_of_monoid_hom_map, is_iso.inv_id, tree_hom_root,
          category.id_comp, category.comp_id] using this },
      congr,
      apply uF',
      intros a b e,
      change E (loop_of_hom T _) = dite _ _ _,
      split_ifs,
      { rw [loop_of_hom_eq_id T e h, ←End.one_def, E.map_one] },
      { exact hE ⟨⟨a, b, e⟩, h⟩ } }
  end }

end spanning_tree

/-- Another name for the identity function `G → G`, to help type checking. -/
private def symgen {G : Type u} [groupoid.{v} G] [is_free_groupoid G] :
  G → symmetrify (generators G) := id

/-- If there exists a morphism `a → b` in a free groupoid, then there also exists a zigzag
from `a` to `b` in the generating quiver. -/
lemma path_nonempty_of_hom {G} [groupoid.{u u} G] [is_free_groupoid G] {a b : G} :
  nonempty (a ⟶ b) → nonempty (path (symgen a) (symgen b)) :=
begin
  rintro ⟨p⟩,
  rw [←weakly_connected_component.eq, eq_comm, ←free_group.of_injective.eq_iff, ←mul_inv_eq_one],
  let X := free_group (weakly_connected_component $ symmetrify $ generators G),
  let f : G → X := λ g, free_group.of ↑(symgen g),
  let F : G ⥤ single_obj X := single_obj.difference_functor f,
  change F.map p = ((category_theory.functor.const G).obj ()).map p,
  congr, ext,
  rw [functor.const.obj_map, id_as_one, difference_functor_map, mul_inv_eq_one],
  apply congr_arg free_group.of,
  rw weakly_connected_component.eq,
  exact ⟨hom.to_path (sum.inr e)⟩,
end

/-- Given a connected free groupoid, its generating quiver is rooted-connected. -/
instance generators_connected (G) [groupoid.{u u} G] [is_connected G] [is_free_groupoid G]
  (r : G) : rooted_connected (symgen r) :=
⟨λ b, path_nonempty_of_hom (category_theory.nonempty_hom_of_connected_groupoid r b)⟩

/-- A vertex group in a free connected groupoid is free. With some work one could drop the
connectedness assumption, by looking at connected components. -/
instance End_is_free_of_connected_free {G} [groupoid G] [is_connected G] [is_free_groupoid G]
  (r : G) : is_free_group (End r) :=
spanning_tree.End_is_free $ geodesic_subtree (symgen r)

end is_free_groupoid

/-- The Nielsen-Schreier theorem: a subgroup of a free group is free. -/
instance subgroup_is_free_of_is_free {G : Type u} [group G] [is_free_group G]
  (H : subgroup G) : is_free_group H :=
is_free_group.of_mul_equiv (End_mul_equiv_subgroup H)


lemma example3 (a b : mynat) (h : succ a = b) : succ(succ(a)) = succ(b) :=
begin
rw h,
refl,
end


import test.random

import system.random
import test.slim_check.liftable

universes u v

@[reducible]
def gen (α : Type u) := reader_t (ulift ℕ) rand α

-- namespace gen

-- variables {α β γ : Type u}

-- protected def pure (x : α) : gen α :=
-- λ _, pure x

-- protected def bind (x : gen α) (f : α → gen β) : gen β
--  | sz := do
-- i ← x sz,
-- f i sz

-- instance : has_bind gen :=
-- ⟨ @gen.bind ⟩

-- instance : has_pure gen :=
-- ⟨ @gen.pure ⟩

-- lemma bind_assoc (x : gen α) (f : α → gen β) (g : β → gen γ)
-- : x >>= f >>= g = x >>= (λ i, f i >>= g) :=
-- begin
--   funext sz,
--   simp [has_bind.bind],
--   simp [gen.bind,monad.bind_assoc],
-- end

-- lemma pure_bind (x : α) (f : α → gen β)
-- : pure x >>= f = f x :=
-- begin
--   funext i,
--   simp [has_bind.bind],
--   simp [gen.bind,monad.pure_bind],
--   refl
-- end

-- lemma id_map (x : gen α)
-- : x >>= pure ∘ id = x :=
-- begin
--   funext i,
--   simp [has_bind.bind,function.comp,pure,has_pure.pure],
--   simp [gen.bind,gen.pure],
--   rw monad.bind_pure,
--   exact α,
-- end

-- end gen

-- instance : monad gen :=
-- { pure := @gen.pure
-- , bind := @gen.bind
-- , bind_assoc := @gen.bind_assoc
-- , pure_bind  := @gen.pure_bind
-- , id_map := @gen.id_map }

variable (α : Type u)

section random

variable [random α]

def choose_any : gen α :=
⟨ λ _, random.random α _ ⟩

variables {α}

def choose (x y : α) (p : x ≤ y . check_range) : gen (x .. y) :=
⟨ λ _, random.random_r _ x y p ⟩

end random

open nat (hiding choose)

def choose_nat (x y : ℕ) (p : x ≤ y . check_range) : gen (x .. y) := do
⟨z,h⟩ ← @choose (fin $ succ y) _ ⟨x,succ_le_succ p⟩ ⟨y,lt_succ_self _⟩ p,
have h' : x ≤ z.val ∧ z.val ≤ y,
  by { simp [fin.le_def] at h, apply h },
return ⟨z.val,h'⟩

open nat

namespace gen

variable {α}

instance : liftable gen.{u} gen.{v} :=
reader_t.liftable' (equiv.ulift.trans equiv.ulift.symm)
set_option pp.universes true
-- begin
--    reader_t.liftable
-- end

end gen

variable {α}

def sized (cmd : ℕ → gen α) : gen α :=
⟨ λ ⟨sz⟩, (cmd sz).run ⟨sz⟩ ⟩

def vector_of : ∀ (n : ℕ) (cmd : gen α), gen (vector α n)
 | 0 _ := return vector.nil
 | (succ n) cmd := vector.cons <$> cmd <*> vector_of n cmd

def list_of (cmd : gen α) : gen (list α) :=
sized $ λ sz, do
do ⟨ n ⟩ ← liftable.up' $ choose_nat 0 sz,
   v ← vector_of n.val cmd,
   return v.to_list

open ulift

def one_of (xs : list (gen α)) (pos : 0 < xs.length) : gen α :=
have _inst : random _ := random_fin_of_pos _ pos, do
n ← liftable.up' $ @choose_any (fin xs.length) _inst,
list.nth_le xs (down n).val (down n).is_lt


import topology.sheaves.sheaf
import topology.category.Top.opens
import algebra.category.CommRing
import cats

open category_theory Top topological_space opposite

structure PresheafOfModules1 (X : Top) :=
(𝒪 : presheaf CommRing X)
(ℱ : presheaf AddCommGroup X)
[is_module : Π (U : (opens X)ᵒᵖ), module (𝒪.obj U) (ℱ.obj U)]
(res_compatible : Π (U V : (opens X)ᵒᵖ) (h : U ⟶ V) (r : 𝒪.obj U) (a: ℱ.obj U),
  ℱ.map h (r • a) = 𝒪.map h r • ℱ.map h a)

-- Now I believe this is not the correct definition, because for `h : U ⟶ V`, `ℱ.map h` is only an `AddCommGroup`-map not a `Module`-map

open restriction_of_scalar

/--
This is a presheaf of Modules over ℱ ⋙ BundledModule.forget

If `h : U ⊆ V`, then `ℱ.map h` is a pair `⟨res₁, res₂⟩`, and `res₁` is the restriction map of sheaf of ring while `res₂` is the restriction map of sheaf of module.
-/

class PresheafOfModules2 {X : Top} (ℱ : @presheaf BundledModule BundledModule.is_cat X):=
(res_compatible : Π (U V : (opens X)ᵒᵖ) (h : U ⟶ V) (r : (ℱ.obj U).R) (m : (ℱ.obj U).M), (ℱ.map h).2 (r • m) = (r • (ℱ.map h).2 m))

open ulift

@[reducible] instance int_as_cring.has_add : has_add (ulift ℤ) :=
⟨λ x y, up (down x + down y)⟩

@[simp] lemma int_as_cring.add_def (x y : ℤ) : (up x) + (up y) = up (x + y) := rfl

@[reducible] instance int_as_cring.has_neg : has_neg (ulift ℤ) :=
⟨λ x, up (- down x)⟩

@[simp] lemma int_as_cring.neg_def (z : ℤ) : -(up z) = up (- z) := rfl

@[reducible] instance int_as_cring.has_mul : has_mul (ulift ℤ) :=
⟨λ x y, up (down x * down y)⟩

@[simp] lemma int_as_cring.mul_def (x y : ℤ) : up x * up y = up (x * y) := rfl

def int_as_cring : CommRing :=
{ α := ulift ℤ,
  str := { add_assoc := λ a b c, begin
             cases a, cases b, cases c,
             dsimp only, rw add_assoc,
           end,

           zero := up 0,
           add_zero := λ a, begin
             cases a,
             dsimp only, rw add_zero,
           end,
           zero_add := λ a, begin
             cases a, dsimp only, rw zero_add,
           end,

           neg := λ r, up (- down r),
           add_left_neg := λ a,
           begin
             cases a, rw [int_as_cring.neg_def, int_as_cring.add_def, int.add_left_neg],
             refl,
           end,

           add_comm := λ x y, begin
             cases x, cases y,
             rw [int_as_cring.add_def, add_comm, int_as_cring.add_def],
           end,

           mul_assoc := λ x y z, begin
             cases x, cases y, cases z,
             rw [int_as_cring.mul_def, int_as_cring.mul_def, mul_assoc],
           end,
           mul_comm := λ x y, begin
             cases x, cases y,
             rw [int_as_cring.mul_def, mul_comm, int_as_cring.mul_def],
           end,

           one := up 1,
           one_mul := λ a, begin
             cases a, rw [int_as_cring.mul_def, one_mul],
           end,
           mul_one := λ a, begin
             cases a, rw [int_as_cring.mul_def, mul_one],
           end,

           left_distrib := λ a b c, begin
             cases a, cases b, cases c,
             rw [int_as_cring.add_def, int_as_cring.mul_def, mul_add],
           end,
           right_distrib := λ a b c, begin
             cases a, cases b, cases c,
             rw [int_as_cring.add_def, int_as_cring.mul_def, add_mul],
           end,
           ..(int_as_cring.has_add),
           ..(int_as_cring.has_neg),
           ..(int_as_cring.has_mul) } }

@[simp] lemma lift_int.add_down (x y : int_as_cring) : (x + y).down = x.down + y.down := rfl
@[simp] lemma lift_int.zero_down : (0 : int_as_cring).down = 0 := rfl

instance int_as_cring.distrib_mul_action (A : AddCommGroup) : distrib_mul_action (int_as_cring) A :=
{ smul := λ x y, x.1 • y,
  one_smul := λ x, by erw one_zsmul,
  mul_smul := λ x y r, begin
    cases x, cases y,
    rw [int_as_cring.mul_def, mul_zsmul],
  end,
  smul_add := λ r x y, by rw zsmul_add,
  smul_zero := λ r, by rw zsmul_zero }

@[simp] lemma lift_int.zsmul (A : AddCommGroup) (r : int_as_cring) (a : A) : r • a = r.1 • a := rfl

instance is_int_module (A : AddCommGroup) : module int_as_cring A :=
{ add_smul := λ x y r, begin
    cases x, cases y,
    unfold has_scalar.smul,
    simp only [zsmul_eq_smul],
    rw [lift_int.add_down], dsimp only, rw add_smul,
  end,
  zero_smul := λ x, begin
    unfold has_scalar.smul,
    simp only [zsmul_eq_smul],
    rw [lift_int.zero_down, zero_smul],
  end}

def as_int_module (A : AddCommGroup) : module ℤ A := by apply_instance

-- @[reducible] def psh_m {X : Top} (𝒪 : presheaf AddCommGroup X) :
--   @presheaf BundledModule BundledModule.is_cat X :=
-- { obj := λ U, { R := int_as_cring, M := { carrier := 𝒪.obj U, is_module := is_int_module (𝒪.obj U)} },
--   map := λ U V h,
--     ⟨𝟙 _, { to_fun := λ m, 𝒪.map h m,
--             map_add' := λ x y, by rw add_monoid_hom.map_add,
--             map_smul' := λ r m, begin
--             dsimp only at *,
--             rw [ring_hom.id_apply],
--             erw add_monoid_hom.map_zsmul,
--             erw [lift_int.zsmul],
--           end }⟩ }

-- instance {X : Top} (𝒪 : presheaf AddCommGroup X) :
--   (PresheafOfModules2 (psh_m 𝒪)) :=
-- { res_compatible := λ U V h r m, begin
--     dsimp only,
--     erw [smul_def', id_apply, add_monoid_hom.map_zsmul, lift_int.zsmul],
--   end }

example (X : Top) (ℱ : @presheaf BundledModule BundledModule.is_cat X) [PresheafOfModules2 ℱ]: PresheafOfModules1 X :=
{ 𝒪 := { obj := λ U, (ℱ.obj U).R,
         map := λ _ _ h, (ℱ.map h).1 },
  ℱ :=
    { obj := λ U, AddCommGroup.of (ℱ.obj U).M,
      map := λ U V h, @AddCommGroup.of_hom (AddCommGroup.of (ℱ.obj U).M) (AddCommGroup.of (ℱ.obj V).M) _ _
        { to_fun := (ℱ.map h).2,
          map_zero' :=  linear_map.map_zero _,
          map_add' := λ m m', begin
            -- rw linear_map.map_add,
            sorry,
          end, }, },
  is_module := λ U, begin
    dsimp only [AddCommGroup.coe_of], apply_instance,
  end,
  res_compatible := λ U V h r m, begin
    dsimp only [AddCommGroup.coe_of, linear_map.map_zero, functor.map_comp, functor.map_id] at *,
    erw PresheafOfModules2.res_compatible U V h r m,
    erw [smul_def'],
  end}

@[reducible] def convert_to2 (X : Top) (psofm : PresheafOfModules1 X) : @presheaf BundledModule BundledModule.is_cat X :=
{ obj := λ U,{ R := psofm.𝒪.obj U,
               M := { carrier := psofm.ℱ.obj U,
               is_module := psofm.is_module U } },
  map := λ U V h, ⟨psofm.𝒪.map h,
        { to_fun := λ m, psofm.ℱ.map h m,
          map_add' := λ m m', begin
            dsimp only at *,
            simp only [add_monoid_hom.map_add],
          end,
          map_smul' := λ r m, begin
            dsimp only at *,
            rw [ring_hom.id_apply, psofm.res_compatible _ _ h],
            -- erw (smul_def' (psofm.𝒪.map h) r { carrier := psofm.ℱ.obj V,
            --    is_module := psofm.is_module V } (psofm.ℱ.map h m)).symm,

            sorry,
          end}⟩ }

instance (X : Top) (psofm : PresheafOfModules1 X) : PresheafOfModules2 (convert_to2 X psofm) :=
{ res_compatible := λ U V h r m, begin
  dsimp only [convert_to2] at *,
  rw smul_def',
  erw psofm.res_compatible, refl,
end }


import separation.heap.lemmas
import util.meta.tactic

universes u

namespace heap

def heap.le (hp₀ hp₁ : heap) : Prop :=
∃ hp, some hp₁ = part (some hp₀) hp

instance : has_le heap :=
⟨ heap.le ⟩

instance : partial_order heap :=
{ le := heap.le
, le_refl := by { intro x, existsi (some heap.emp), simp, }
, le_trans := by { introv,
                   simp [has_le.le,heap.le],
                   intros hp₀ h₀ hp₁ h₁,
                   -- have : hp₀ ## hp₁, admit,
                   existsi part hp₀ hp₁,
                   simp [h₁,h₀], ac_refl }
, le_antisymm := by { introv,
                      simp [has_le.le,heap.le],
                      intros hp₀ h₀ hp₁ h₁,
                      simp [h₀,part_assoc] at h₁,
                      simp [h₁.left] at h₀,
                      subst b, }
}

lemma part'_delete_maplet (p : pointer) (v : word) (hp : heap)
  (h : heap.delete p 1 hp ## maplet p v)
  (h' : maplet p v ≤ hp)
: part' (heap.delete p 1 hp) (maplet p v) = hp :=
begin
  funext p',
  by_cases h : (p = p'),
  { simp [part', heap.delete, maplet, if_pos, h],
    unfold has_le.le heap.le at h',
    cases h' with hp' h', cases hp' with hp',
    { contradiction },
    have h₂ := eq_part'_of_some_eq_part _ _ _ h',
    rw [h₂,part',maplet,if_pos h],
    simp },
  { simp [part', heap.delete, maplet, if_neg, h] }
end

end heap