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

! This file was ported from Lean 3 source module tactic.ext
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Rcases
import Mathbin.Logic.Function.Basic

universe u₁ u₂

open Interactive Interactive.Types

section Ext

open Lean.Parser Nat Tactic

initialize
  registerTraceClass.1 `ext

/-- `derive_struct_ext_lemma n` generates two extensionality lemmas based on
the equality of all non-propositional projections.

On the following:

```lean
@[ext]
structure foo (α : Type*) :=
(x y : ℕ)
(z : {z // z < x})
(k : α)
(h : x < y)
```

`derive_struct_lemma` generates:

```lean
lemma foo.ext : ∀ {α : Type u_1} (x y : foo α),
  x.x = y.x → x.y = y.y → x.z == y.z → x.k = y.k → x = y
lemma foo.ext_iff : ∀ {α : Type u_1} (x y : foo α),
  x = y ↔ x.x = y.x ∧ x.y = y.y ∧ x.z == y.z ∧ x.k = y.k
```

-/
unsafe def derive_struct_ext_lemma (n : Name) : tactic Name := do
  let e ← get_env
  let fs ← e.structure_fields n
  let d ← get_decl n
  let n ← resolve_constant n
  let r := @expr.const true n <| d.univ_params.map level.param
  let (args, _) ← infer_type r >>= open_pis
  let args := args.map expr.to_implicit_local_const
  let t := r.mk_app args
  let x ← mk_local_def `x t
  let y ← mk_local_def `y t
  let args_x := args ++ [x]
  let args_y := args ++ [y]
  let bs ←
    fs.mapM fun f => do
        let d ← get_decl (n ++ f)
        let a := @expr.const true (n ++ f) <| d.univ_params.map level.param
        let t ← infer_type a
        let s ← infer_type t
        if s ≠ q(Prop) then do
            let x := a args_x
            let y := a args_y
            let t ← infer_type x
            let t' ← infer_type y
            some <$>
                if t = t' then mk_app `eq [x, y] >>= mk_local_def `h
                else mk_mapp `heq [none, x, none, y] >>= mk_local_def `h
          else pure none
  let bs := bs.filterMap id
  let eq_t ← mk_app `eq [x, y]
  let t ← pis (args ++ [x, y] ++ bs) eq_t
  let pr ←
    run_async do
        let (_, pr) ←
          solve_aux t do
              let args ← intron args.length
              let x ← intro1
              let y ← intro1
              cases x
              cases y
              bs fun _ => do
                  let e ← intro1
                  cases e
              reflexivity
        instantiate_mvars pr
  let decl_n := .str n "ext"
  add_decl (declaration.thm decl_n d t pr)
  let bs ← bs.mapM infer_type
  let rhs := expr.mk_and_lst bs
  let iff_t ← mk_app `iff [eq_t, rhs]
  let t ← pis (args ++ [x, y]) iff_t
  let pr ←
    run_async do
        let (_, pr) ←
          solve_aux t do
              let args ← intron args.length
              let x ← intro1
              let y ← intro1
              cases x
              cases y
              split
              solve1 do
                  let h ← intro1
                  let hs ← injection h
                  subst_vars
                  repeat (refine ``(And.intro _ _) >> reflexivity)
                  done <|> reflexivity
              solve1 do
                  repeat do
                      refine ``(and_imp.mpr _)
                      let h ← intro1
                      cases h
                      skip
                  let h ← intro1
                  cases h
                  reflexivity
        instantiate_mvars pr
  add_decl (declaration.thm (.str n "ext_iff") d t pr)
  pure decl_n
#align derive_struct_ext_lemma derive_struct_ext_lemma

unsafe def get_ext_subject : expr → tactic Name
  | expr.pi n bi d b => do
    let v ← mk_local' n bi d
    let b' ← whnf <| b.instantiate_var v
    get_ext_subject b'
  | expr.app _ e => do
    let t ← infer_type e >>= instantiate_mvars >>= head_beta
    if t then pure <| t
      else
        if t then pure <| Name.mk_numeral 0 Name.anonymous
        else
          if t then pure <| Name.mk_numeral 1 Name.anonymous
          else do
            let t ← pp t
            fail f! "only constants and Pi types are supported: {t}"
  | e => fail f! "Only expressions of the form `_ → _ → ... → R ... e are supported: {e}"
#align get_ext_subject get_ext_subject

open Native

unsafe def saturate_fun : Name → tactic expr
  | Name.mk_numeral 0 Name.anonymous => do
    let v₀ ← mk_mvar
    let v₁ ← mk_mvar
    return <| v₀ v₁
  | Name.mk_numeral 1 Name.anonymous => do
    let u ← mk_meta_univ
    pure <| expr.sort u
  | n => do
    let e ← resolve_constant n >>= mk_const
    let a ← get_arity e
    e <$> (List.iota a).mapM fun _ => mk_mvar
#align saturate_fun saturate_fun

unsafe def equiv_type_constr (n n' : Name) : tactic Unit := do
  let e ← saturate_fun n
  let e' ← saturate_fun n'
  unify e e' <|> fail f! "{n } and {n'} are not definitionally equal types"
#align equiv_type_constr equiv_type_constr

section PerformanceHack

library_note "user attribute parameters"/--
For performance reasons, it is inadvisable to use `user_attribute.get_param`.
The parameter is stored as a reflected expression.  When calling `get_param`,
the stored parameter is evaluated using `eval_expr`, which first compiles the
expression into VM bytecode. The unevaluated expression is available using
`user_attribute.get_param_untyped`.

In particular, `user_attribute.get_param` MUST NEVER BE USED in the
implementation of an attribute cache. This is because calling `eval_expr`
disables the attribute cache.

There are several possible workarounds:
 1. Set a different attribute depending on the parameter.
 2. Use your own evaluation function instead of `eval_expr`, such as e.g. `expr.to_nat`.
 3. Write your own `has_reflect Param` instance (using a more efficient serialization format).
   The `user_attribute` code unfortunately checks whether the expression has the correct type,
   but you can use `` `(id %%e : Param) `` to pretend that your expression `e` has type `Param`.
-/

/-!
For performance reasons, the parameters of the `@[ext]` attribute are stored
in two auxiliary attributes:
```lean
attribute [ext thunk] funext

-- is turned into
attribute [_ext_core (@id name @funext)] thunk
attribute [_ext_lemma_core] funext
```

see Note [user attribute parameters]
-/

attribute [local semireducible] reflected

@[local instance]
private unsafe def hacky_name_reflect : has_reflect Name := fun n =>
  q((id $(expr.const n []) : Name))
#align hacky_name_reflect hacky_name_reflect

@[user_attribute]
private unsafe def ext_attr_core : user_attribute (name_map Name) Name
    where
  Name := `_ext_core
  descr := "(internal attribute used by ext)"
  cache_cfg :=
    { dependencies := []
      mk_cache := fun ns =>
        ns.foldlM
          (fun m n => do
            let ext_l ← ext_attr_core.get_param_untyped n
            pure (m n ext_l))
          mk_name_map }
  parser := failure
#align ext_attr_core ext_attr_core

end PerformanceHack

/-- Private attribute used to tag extensionality lemmas. -/
@[user_attribute]
private unsafe def ext_lemma_attr_core : user_attribute
    where
  Name := `_ext_lemma_core
  descr := "(internal attribute used by ext)"
  parser := failure
#align ext_lemma_attr_core ext_lemma_attr_core

/-- Returns the extensionality lemmas in the environment, as a map from structure
name to lemma name.
-/
unsafe def get_ext_lemmas : tactic (name_map Name) :=
  ext_attr_core.get_cache
#align get_ext_lemmas get_ext_lemmas

/-- Returns the extensionality lemmas in the environment, as a list of lemma names.
-/
unsafe def get_ext_lemma_names : tactic (List Name) :=
  attribute.get_instances ext_lemma_attr_core.Name
#align get_ext_lemma_names get_ext_lemma_names

/-- Marks `lem` as an extensionality lemma corresponding to type constructor `constr`;
if `persistent` is true then this is a global attribute, else local. -/
unsafe def add_ext_lemma (constr lem : Name) (persistent : Bool) : tactic Unit :=
  ext_attr_core.Set constr lem persistent >> ext_lemma_attr_core.Set lem () persistent
#align add_ext_lemma add_ext_lemma

/-- Tag lemmas of the form:

```lean
@[ext]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

The attribute indexes extensionality lemma using the type of the
objects (i.e. `my_collection`) which it gets from the statement of
the lemma.  In some cases, the same lemma can be used to state the
extensionality of multiple types that are definitionally equivalent.

```lean
attribute [ext thunk, ext stream] funext
```

Also, the following:

```lean
@[ext]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

is equivalent to

```lean
@[ext my_collection]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

This allows us specify type synonyms along with the type
that is referred to in the lemma statement.

```lean
@[ext, ext my_type_synonym]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

The `ext` attribute can be applied to a structure to generate its extensionality lemmas:

```lean
@[ext]
structure foo (α : Type*) :=
(x y : ℕ)
(z : {z // z < x})
(k : α)
(h : x < y)
```

will generate:

```lean
@[ext] lemma foo.ext : ∀ {α : Type u_1} (x y : foo α),
x.x = y.x → x.y = y.y → x.z == y.z → x.k = y.k → x = y
lemma foo.ext_iff : ∀ {α : Type u_1} (x y : foo α),
x = y ↔ x.x = y.x ∧ x.y = y.y ∧ x.z == y.z ∧ x.k = y.k
```

-/
@[user_attribute]
unsafe def extensional_attribute : user_attribute Unit (Option Name)
    where
  Name := `ext
  descr := "lemmas usable by `ext` tactic"
  parser := optional ident
  after_set :=
    some fun n _ b => do
      let add ← extensional_attribute.get_param n
      let e ← get_env
      let n ← if (e.structure_fields n).isSome then derive_struct_ext_lemma n else pure n
      let s ← mk_const n >>= infer_type >>= get_ext_subject
      match add with
        | none => add_ext_lemma s n b
        | some add => equiv_type_constr s add >> add_ext_lemma add n b
#align extensional_attribute extensional_attribute

add_tactic_doc
  { Name := "ext"
    category := DocCategory.attr
    declNames := [`extensional_attribute]
    tags := ["rewrite", "logic"] }

library_note "partially-applied ext lemmas"/--
When possible, `ext` lemmas are stated without a full set of arguments. As an example, for bundled
homs `f`, `g`, and `of`, `f.comp of = g.comp of → f = g` is a better `ext` lemma than
`(∀ x, f (of x) = g (of x)) → f = g`, as the former allows a second type-specific extensionality
lemmas to be applied to `f.comp of = g.comp of`.
If the domain of `of` is `ℕ` or `ℤ` and `of` is a `ring_hom`, such a lemma could then make the goal
`f (of 1) = g (of 1)`.

For bundled morphisms, there is a `ext` lemma that always applies of the form
`(∀ x, ⇑f x = ⇑g x) → f = g`. When adding type-specific `ext` lemmas like the one above, we want
these to be tried first. This happens automatically since the type-specific lemmas are inevitably
defined later.
-/

-- We mark some existing extensionality lemmas.
attribute [ext] Array'.ext propext Function.hfunext

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Ext.lean:18:19: unsupported: attribute [ext id] -/
attribute [ext] _root_.funext

-- This line is equivalent to:
--   attribute [ext (→)] _root_.funext
-- but (→) is not actually a binary relation with a constant at the head,
-- so we use the special name [anon].0 to represent (→).
run_cmd
  add_ext_lemma (Name.mk_numeral 0 Name.anonymous) `` _root_.funext true

-- We create some extensionality lemmas for existing structures.
attribute [ext] ULift

namespace PLift

-- This is stronger than the one generated automatically.
@[ext]
theorem ext {P : Prop} (a b : PLift P) : a = b := by cases a; cases b; rfl
#align plift.ext PLift.ext

end PLift

-- Conservatively, we'll only add extensionality lemmas for `has_*` structures
-- as they become useful.
attribute [ext] Zero

#print Unit.ext /-
@[ext]
theorem Unit.ext {x y : Unit} : x = y := by
  cases x
  cases y
  rfl
#align unit.ext Unit.ext
-/

#print PUnit.ext /-
@[ext]
theorem PUnit.ext {x y : PUnit} : x = y := by
  cases x
  cases y
  rfl
#align punit.ext PUnit.ext
-/

namespace Tactic

/-- Helper structure for `ext` and `ext1`. `lemmas` keeps track of extensionality lemmas
  applied so far. -/
unsafe structure ext_state : Type where
  patts : List rcases_patt := []
  trace_msg : List String := []
  fuel : Option ℕ := none
#align tactic.ext_state tactic.ext_state

/-- Helper function for `try_intros`. Additionally populates the `trace_msg` field
  of `ext_state`. -/
private unsafe def try_intros_core : StateT ext_state tactic Unit := do
  let ⟨patts, trace_msg, fuel⟩ ← get
  match patts with
    | [] =>
      (do
          let es ← StateT.lift intros
          when (es > 0) do
              let msg := "intros " ++ " ".intercalate (es fun e => e)
              modify fun ⟨patts, trace_msg, fuel⟩ => ⟨patts, trace_msg ++ [msg], fuel⟩) <|>
        pure ()
    | x :: xs => do
      let tgt ← StateT.lift (target >>= whnf)
      when tgt do
          StateT.lift (rintro [x])
          let msg ← StateT.lift ((· ++ ·) "rintro " <$> format.to_string <$> x ff)
          modify fun ⟨_, trace_msg, fuel⟩ => ⟨xs, trace_msg ++ [msg], fuel⟩
          try_intros_core
#align tactic.try_intros_core tactic.try_intros_core

/-- Try to introduce as many arguments as possible, using the given patterns to destruct the
  introduced variables. Returns the unused patterns. -/
unsafe def try_intros (patts : List rcases_patt) : tactic (List rcases_patt) :=
  let σ := ext_state.mk patts [] none
  (ext_state.patts ∘ Prod.snd) <$> StateT.run try_intros_core σ
#align tactic.try_intros tactic.try_intros

/-- Apply one extensionality lemma, and destruct the arguments using the patterns
  in the ext_state. -/
unsafe def ext1_core (cfg : ApplyCfg := { }) : StateT ext_state tactic Unit := do
  let ⟨patts, trace_msg, _⟩ ← get
  let new_msgs ←
    StateT.lift <|
        focus1 do
          let m ← get_ext_lemmas
          let tgt ← target
          when_tracing `ext <|
              ← do
                dbg_trace "[ext] goal: {← tgt}"
          let subject ← get_ext_subject tgt
          let new_trace_msg ←
            (do
                  let rule ← m.find subject
                  if is_trace_enabled_for `ext then
                      (← do
                          dbg_trace "[ext] matched goal to rule: {← rule}") >>
                        timetac "[ext] application attempt time" (applyc rule cfg)
                    else applyc rule cfg
                  pure ["apply " ++ rule]) <|>
                (do
                    let ls ← get_ext_lemma_names
                    let nms := ls.map Name.toString
                    let rule ←
                      ls.any_of fun n =>
                          (if is_trace_enabled_for `ext then
                              (← do
                                  dbg_trace "[ext] trying to apply ext lemma: {← n}") >>
                                timetac "[ext] application attempt time" (applyc n cfg)
                            else applyc n cfg) *>
                            pure n
                    pure ["apply " ++ rule]) <|>
                  fail f! "no applicable extensionality rule found for {subject}"
          pure new_trace_msg
  modify fun ⟨patts, trace_msg, fuel⟩ => ⟨patts, trace_msg ++ new_msgs, fuel⟩
  try_intros_core
#align tactic.ext1_core tactic.ext1_core

/-- Apply multiple extensionality lemmas, destructing the arguments using the given patterns. -/
unsafe def ext_core (cfg : ApplyCfg := { }) : StateT ext_state tactic Unit := do
  let acc@⟨_, _, fuel⟩ ← get
  match fuel with
    | some 0 => pure ()
    | n => do
      ext1_core cfg
      modify fun ⟨patts, lemmas, _⟩ => ⟨patts, lemmas, Nat.pred <$> n⟩
      ext_core <|> pure ()
#align tactic.ext_core tactic.ext_core

/-- Apply one extensionality lemma, and destruct the arguments using the given patterns.
  Returns the unused patterns. -/
unsafe def ext1 (xs : List rcases_patt) (cfg : ApplyCfg := { }) (trace : Bool := false) :
    tactic (List rcases_patt) := do
  let ⟨_, σ⟩ ← StateT.run (ext1_core cfg) { patts := xs }
  when trace <| tactic.trace <| "Try this: " ++ ", ".intercalate σ
  pure σ
#align tactic.ext1 tactic.ext1

/-- Apply multiple extensionality lemmas, destructing the arguments using the given patterns.
  `ext ps (some n)` applies at most `n` extensionality lemmas. Returns the unused patterns. -/
unsafe def ext (xs : List rcases_patt) (fuel : Option ℕ) (cfg : ApplyCfg := { })
    (trace : Bool := false) : tactic (List rcases_patt) := do
  let ⟨_, σ⟩ ←
    StateT.run (ext_core cfg)
        { patts := xs
          fuel }
  when trace <| tactic.trace <| "Try this: " ++ ", ".intercalate σ
  pure σ
#align tactic.ext tactic.ext

-- mathport name: parser.optional
local postfix:1024 "?" => optional

-- mathport name: parser.many
local postfix:1024 "*" => many

/-- `ext1 id` selects and apply one extensionality lemma (with attribute
`ext`), using `id`, if provided, to name a local constant
introduced by the lemma. If `id` is omitted, the local constant is
named automatically, as per `intro`. Placing a `?` after `ext1`
 (e.g. `ext1? i ⟨a,b⟩ : 3`) will display a sequence of tactic
applications that can replace the call to `ext1`.
-/
unsafe def interactive.ext1 (trace : parse (tk "?")?) (xs : parse rcases_patt_parse_hi*) :
    tactic Unit :=
  ext1 xs { } trace.isSome $> ()
#align tactic.interactive.ext1 tactic.interactive.ext1

/-- - `ext` applies as many extensionality lemmas as possible;
- `ext ids`, with `ids` a list of identifiers, finds extentionality and applies them
  until it runs out of identifiers in `ids` to name the local constants.
- `ext` can also be given an `rcases` pattern in place of an identifier.
  This will destruct the introduced local constant.
- Placing a `?` after `ext` (e.g. `ext? i ⟨a,b⟩ : 3`) will display
  a sequence of tactic applications that can replace the call to `ext`.
- `set_option trace.ext true` will trace every attempted lemma application,
  along with the time it takes for the application to succeed or fail.
  This is useful for debugging slow `ext` calls.

When trying to prove:

```lean
α β : Type,
f g : α → set β
⊢ f = g
```

applying `ext x y` yields:

```lean
α β : Type,
f g : α → set β,
x : α,
y : β
⊢ y ∈ f x ↔ y ∈ f x
```

by applying functional extensionality and set extensionality.

When trying to prove:

```lean
α β γ : Type
f g : α × β → γ
⊢ f = g
```

applying `ext ⟨a, b⟩` yields:

```lean
α β γ : Type,
f g : α × β → γ,
a : α,
b : β
⊢ f (a, b) = g (a, b)
```

by applying functional extensionality and destructing the introduced pair.

In the previous example, applying `ext? ⟨a,b⟩` will produce the trace message:

```lean
Try this: apply funext, rintro ⟨a, b⟩
```

A maximum depth can be provided with `ext x y z : 3`.
-/
unsafe def interactive.ext :
    (parse <| (tk "?")?) → parse rintro_patt_parse_hi* → parse (tk ":" *> small_nat)? → tactic Unit
  | trace, [], some n => iterate_range 1 n (ext1 [] { } trace.isSome $> ())
  | trace, [], none => repeat1 (ext1 [] { } trace.isSome $> ())
  | trace, xs, n => ext xs.join n { } trace.isSome $> ()
#align tactic.interactive.ext tactic.interactive.ext

/-- * `ext1 id` selects and apply one extensionality lemma (with
  attribute `ext`), using `id`, if provided, to name a
  local constant introduced by the lemma. If `id` is omitted, the
  local constant is named automatically, as per `intro`.

* `ext` applies as many extensionality lemmas as possible;
* `ext ids`, with `ids` a list of identifiers, finds extensionality lemmas
  and applies them until it runs out of identifiers in `ids` to name
  the local constants.
* `ext` can also be given an `rcases` pattern in place of an identifier.
  This will destruct the introduced local constant.
- Placing a `?` after `ext`/`ext1` (e.g. `ext? i ⟨a,b⟩ : 3`) will display
  a sequence of tactic applications that can replace the call to `ext`/`ext1`.
- `set_option trace.ext true` will trace every attempted lemma application,
  along with the time it takes for the application to succeed or fail.
  This is useful for debugging slow `ext` calls.

When trying to prove:

```lean
α β : Type,
f g : α → set β
⊢ f = g
```

applying `ext x y` yields:

```lean
α β : Type,
f g : α → set β,
x : α,
y : β
⊢ y ∈ f x ↔ y ∈ g x
```
by applying functional extensionality and set extensionality.

When trying to prove:

```lean
α β γ : Type
f g : α × β → γ
⊢ f = g
```

applying `ext ⟨a, b⟩` yields:

```lean
α β γ : Type,
f g : α × β → γ,
a : α,
b : β
⊢ f (a, b) = g (a, b)
```

by applying functional extensionality and destructing the introduced pair.

In the previous example, applying `ext? ⟨a,b⟩` will produce the trace message:

```lean
Try this: apply funext, rintro ⟨a, b⟩
```

A maximum depth can be provided with `ext x y z : 3`.
-/
add_tactic_doc
  { Name := "ext1 / ext"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.ext1, `tactic.interactive.ext]
    tags := ["rewriting", "logic"] }

end Tactic

end Ext


import FOL.deduction FOL.lindenbaum

-- Prenex normal form

universes u v

namespace fol
open_locale logic_symbol

variables (L : language.{u})

structure pnf : Type u :=
(quantifier : list bool)
(form : formula L)
(is_openform : form.is_open)

local notation `𝚷` := bool.tt

local notation `𝚺` := bool.ff

variables {L}

namespace pnf

def fal : pnf L → pnf L
| ⟨Q, p, h⟩ := ⟨𝚷 :: Q, p, h⟩

def ex : pnf L → pnf L
| ⟨Q, p, h⟩ := ⟨𝚺 :: Q, p, h⟩

instance : has_univ_quantifier (pnf L) := ⟨pnf.fal⟩

instance : has_exists_quantifier (pnf L) := ⟨pnf.ex⟩

@[simp] lemma fal_eq (Q : list bool) (p : formula L) (h) : (∀.(⟨Q, p, h⟩ : pnf L) : pnf L) = ⟨𝚷 :: Q, p, h⟩ := rfl

@[simp] lemma ex_eq (Q : list bool) (p : formula L) (h) : (∃.(⟨Q, p, h⟩ : pnf L) : pnf L) = ⟨𝚺 :: Q, p, h⟩ := rfl

@[simp] lemma fal_inj : ∀ (p q : pnf L), (∀.p : pnf L) = ∀.q ↔ p = q
| ⟨Q₁, p₁, h₁⟩ ⟨Q₂, p₂, h₂⟩ := by simp

@[simp] lemma ex_inj : ∀ (p q : pnf L), (∃.p : pnf L) = ∃.q ↔ p = q
| ⟨Q₁, p₁, h₁⟩ ⟨Q₂, p₂, h₂⟩ := by simp

@[simp] def to_openform : pnf L → formula L
| ⟨Q, p, h⟩ := p

@[simp] def to_formula : pnf L → formula L
| ⟨[], p, h⟩     := p
| ⟨𝚷 :: Q, p, h⟩ := ∀.to_formula ⟨Q, p, h⟩
| ⟨𝚺 :: Q, p, h⟩ := ∃.to_formula ⟨Q, p, h⟩

instance : has_coe (pnf L) (formula L) := ⟨to_formula⟩

def to_formula_inj : ∀ {p q : pnf L}, p.to_formula = q.to_formula ↔ p = q
| ⟨[],       p₁, h₁⟩ ⟨[],       p₂, h₂⟩ := by simp
| ⟨[],       p₁, h₁⟩ ⟨q₂ :: Q₂, p₂, h₂⟩ := by { cases q₂; { simp, intros h, simp[h] at h₁, contradiction } }
| ⟨q₁ :: Q₁, p₁, h₁⟩ ⟨[],       p₂, h₂⟩ := by { cases q₁; { simp, intros h, simp[←h] at h₂, contradiction } }
| ⟨q₁ :: Q₁, p₁, h₁⟩ ⟨q₂ :: Q₂, p₂, h₂⟩ := by cases q₁; cases q₂; simp[@to_formula_inj ⟨Q₁, p₁, h₁⟩ ⟨Q₂, p₂, h₂⟩]

@[simp] def fal_to_formula : ∀ p : pnf L, (∀.p : pnf L).to_formula = ∀.p.to_formula
| ⟨Q, p, h⟩     := by simp

@[simp] def ex_to_formula : ∀ p : pnf L, (∃.p : pnf L).to_formula = ∃.p.to_formula
| ⟨Q, p, h⟩     := by simp

@[simp] def rank : pnf L → ℕ := λ p, p.1.length

def rew (s : ℕ → term L) : pnf L → pnf L
| ⟨Q, p, h⟩ := ⟨Q, p.rew (s^Q.length), by simp[h]⟩

instance : has_pow (pnf L) ℕ := ⟨λ p i, p.rew (λ x, #(x + i))⟩

@[simp] lemma rew_to_formula_eq_to_formula_rew : ∀ (p : pnf L) (s : ℕ → term L),
  (p.rew s).to_formula = p.to_formula.rew s
| ⟨[], p, h⟩     s := by simp[rew]
| ⟨𝚷 :: Q, p, h⟩ s := by simp[rew, ←rew_to_formula_eq_to_formula_rew ⟨Q, p, by simp[h]⟩ (s^1),
    rewriting_sf_itr.pow_add, show 1 + Q.length = Q.length + 1, from add_comm _ _]
| ⟨𝚺 :: Q, p, h⟩ s := by simp[rew, ←rew_to_formula_eq_to_formula_rew ⟨Q, p, by simp[h]⟩ (s^1),
    rewriting_sf_itr.pow_add, show 1 + Q.length = Q.length + 1, from add_comm _ _]

@[simp] lemma pow_to_formula_eq_to_formula_pow (p : pnf L) (i : ℕ) : (p^i).to_formula = p.to_formula^i :=
by simp[formula.pow_eq, rew_to_formula_eq_to_formula_rew, has_pow.pow]

lemma rew_fal (Q : list bool) (p : formula L) {h} (s : ℕ → term L) :
  (⟨(𝚷 :: Q), p, h⟩ : pnf L).rew s = ∀.(⟨Q, p, h⟩ : pnf L).rew (s^1) :=
by simp[rew, show Q.length + 1 = 1 + Q.length, from add_comm _ _, rewriting_sf_itr.pow_add]

@[simp] lemma rew_fal' : ∀ (p : pnf L) (s : ℕ → term L),
  (∀.p : pnf L).rew s = ∀.(p.rew (s^1))
| ⟨Q, p, h⟩ s := by simp[rew_fal]

lemma rew_ex (Q : list bool) (p : formula L) {h} (s : ℕ → term L) :
  (⟨(𝚺 :: Q), p, h⟩ : pnf L).rew s = ∃.(⟨Q, p, h⟩ : pnf L).rew (s^1) :=
by simp[rew, show Q.length + 1 = 1 + Q.length, from add_comm _ _, rewriting_sf_itr.pow_add]

@[simp] lemma rew_ex' : ∀ (p : pnf L) (s : ℕ → term L),
  (∃.p : pnf L).rew s = ∃.(p.rew (s^1))
| ⟨Q, p, h⟩ s := by simp[rew_ex]

lemma nested_rew (p : pnf L) (s₀ s₁) :
  (p.rew s₀).rew s₁ = p.rew (λ x, (s₀ x).rew s₁) :=
to_formula_inj.mp (by simp[formula.nested_rew])

@[simp] lemma rew_rank : ∀ (p : pnf L) (s), (p.rew s).rank = p.rank
| ⟨[], p, h⟩     s := by simp[rew]
| ⟨𝚷 :: Q, p, h⟩ s := by simp[rew]
| ⟨𝚺 :: Q, p, h⟩ s := by simp[rew]

@[simp] lemma pow_rank (p : pnf L) (i : ℕ) : (p^i).rank = p.rank :=
by simp[has_pow.pow]

@[simp] def neg : pnf L → pnf L
| ⟨[], p, h⟩ := ⟨[], ∼p, by simp[h]⟩
| ⟨𝚷 :: Q, p, h⟩ := ∃.neg ⟨Q, p, by simp[h]⟩
| ⟨𝚺 :: Q, p, h⟩ := ∀.neg ⟨Q, p, by simp[h]⟩
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf rank⟩]}

instance : has_negation (pnf L) := ⟨neg⟩

@[simp] def imply : pnf L → pnf L → pnf L
| ⟨[], p₁, h₁⟩      ⟨[], p₂, h₂⟩      := ⟨[], p₁ ⟶ p₂, by simp[h₁, h₂]⟩
| ⟨[], p₁, h₁⟩      ⟨𝚷 :: Q₂, p₂, h₂⟩ := ∀.imply (⟨[], p₁^1, by simp[h₁]⟩) ⟨Q₂, p₂, h₂⟩
| ⟨[], p₁, h₁⟩      ⟨𝚺 :: Q₂, p₂, h₂⟩ := ∃.imply ⟨[], p₁^1, by simp[h₁]⟩ ⟨Q₂, p₂, h₂⟩
| ⟨𝚷 :: Q₁, p₁, h₁⟩ ⟨[], p₂, h₂⟩      := ∃.imply ⟨Q₁, p₁, by simp[h₁]⟩ ⟨[], p₂^1, by simp[h₂]⟩
| ⟨𝚷 :: Q₁, p₁, h₁⟩ ⟨𝚷 :: Q₂, p₂, h₂⟩ :=
    ∃.(∀.imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ (by simp[h₂])).rew ı-{1}) : pnf L)
| ⟨𝚷 :: Q₁, p₁, h₁⟩ ⟨𝚺 :: Q₂, p₂, h₂⟩ :=
    ∃.(∃.imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ (by simp[h₂])).rew ı-{1}) : pnf L)
| ⟨𝚺 :: Q₁, p₁, h₁⟩ ⟨[], p₂, h₂⟩      := ∀.imply ⟨Q₁, p₁, by simp[h₁]⟩ ⟨[], p₂^1, by simp[h₂]⟩
| ⟨𝚺 :: Q₁, p₁, h₁⟩ ⟨𝚷 :: Q₂, p₂, h₂⟩ :=
    ∀.(∀.imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ (by simp[h₂])).rew ı-{1}) : pnf L)
| ⟨𝚺 :: Q₁, p₁, h₁⟩ ⟨𝚺 :: Q₂, p₂, h₂⟩ :=
    ∀.(∃.imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ (by simp[h₂])).rew ı-{1}) : pnf L)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ x, x.fst.rank + x.snd.rank)⟩]}

instance : has_arrow (pnf L) := ⟨imply⟩

end pnf

namespace formula

@[simp] def to_pnf : formula L → pnf L
| ⊤         := ⟨[], ⊤, by simp⟩
| (app p v) := ⟨[], app p v, by simp⟩
| ((t : term L) =' u) := ⟨[], (t : term L) =' u, by simp⟩
| (p ⟶ q) := (to_pnf p).imply (to_pnf q)
| (∼p) := (to_pnf p).neg
| (∀.(p : formula L)) := ∀.(to_pnf p)

end formula

lemma equiv_normalize_imply : ∀ (p q : pnf L) (T : Theory L),
  (p.imply q).to_formula  ≈[T] p.to_formula ⟶ q.to_formula
| ⟨[], p₁, h₁⟩      ⟨[], p₂, h₂⟩      T := by simp
| ⟨[], p₁, h₁⟩      ⟨𝚷 :: Q₂, p₂, h₂⟩ T := by { simp, have ih := equiv_normalize_imply ⟨[], p₁^1, by simp[h₁]⟩ ⟨Q₂, p₂, h₂⟩,
    calc     ∀.((pnf.mk ([]) (p₁^1) (by simp[h₁])).imply (pnf.mk Q₂ p₂ h₂)).to_formula
        ≈[(T)] ∀.((pnf.mk ([]) (p₁^1) (by simp[h₁])).to_formula ⟶ (pnf.mk Q₂ p₂ h₂).to_formula)
    : show _ ≈[T] _, from provable.equiv_univ_of_equiv (ih _)
    ... ≈[T] p₁ ⟶ ∀.(pnf.mk Q₂ p₂ h₂).to_formula
    : by { symmetry, refine by simp[classical_logic.equiv] } }
| ⟨[], p₁, h₁⟩      ⟨𝚺 :: Q₂, p₂, h₂⟩ T := by { simp, have ih := equiv_normalize_imply ⟨[], p₁^1, by simp[h₁]⟩ ⟨Q₂, p₂, h₂⟩,
    calc     ∃.((pnf.mk ([]) (p₁^1) (by simp[h₁])).imply (pnf.mk Q₂ p₂ h₂)).to_formula
        ≈[T] ∃.((pnf.mk ([]) (p₁^1) (by simp[h₁])).to_formula ⟶ (pnf.mk Q₂ p₂ h₂).to_formula)
    : show _ ≈[T] _, from provable.equiv_ex_of_equiv (ih _)
    ... ≈[T] p₁ ⟶ ∃.(pnf.mk Q₂ p₂ h₂).to_formula
    : by { symmetry, simp[classical_logic.equiv] } }
| ⟨𝚷 :: Q₁, p₁, h₁⟩ ⟨[], p₂, h₂⟩      T := by { simp, have ih := equiv_normalize_imply ⟨Q₁, p₁, h₁⟩ (pnf.mk ([]) p₂ h₂^1),
    calc     ∃.((pnf.mk Q₁ p₁ h₁).imply (pnf.mk ([]) p₂ h₂^1)).to_formula
        ≈[T] ∃.((pnf.mk Q₁ p₁ h₁).to_formula ⟶ (pnf.mk ([]) p₂ h₂^1).to_formula)
    : show _ ≈[T] _, from provable.equiv_ex_of_equiv (ih _)
    ... ≈[T] ∀.(pnf.mk Q₁ p₁ (by simp[h₁])).to_formula ⟶ p₂
    : by { symmetry, simp[classical_logic.equiv] } }
| ⟨𝚷 :: Q₁, p₁, h₁⟩ ⟨𝚷 :: Q₂, p₂, h₂⟩ T := by { simp,
    have ih := equiv_normalize_imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ h₂).rew ı-{1}),
    calc     ∃.∀.((pnf.mk Q₁ p₁ h₁^1).imply ((pnf.mk Q₂ p₂ h₂).rew ı-{1})).to_formula
        ≈[T] ∃.∀.((pnf.mk Q₁ p₁ h₁^1).to_formula ⟶ ((pnf.mk Q₂ p₂ h₂).rew ı-{1}).to_formula)
    : show _ ≈[T] _, from provable.equiv_ex_of_equiv (provable.equiv_univ_of_equiv (ih _))
    ... ≈[T] ∃.((pnf.mk Q₁ p₁ h₁).to_formula ⟶ (∀.(pnf.mk Q₂ p₂ h₂).to_formula)^1)
    : by { show _ ≈[T] _, symmetry, simp[classical_logic.equiv, formula.fal_pow_discard],
           refine provable.equiv_ex_of_equiv (by simp) }
    ... ≈[T] ∀.(pnf.mk Q₁ p₁ h₁).to_formula ⟶ ∀.(pnf.mk Q₂ p₂ h₂).to_formula
    : by { symmetry, simp [classical_logic.equiv] } }
| ⟨𝚷 :: Q₁, p₁, h₁⟩ ⟨𝚺 :: Q₂, p₂, h₂⟩ T := by { simp,
    have ih := equiv_normalize_imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ h₂).rew ı-{1}),
    calc     ∃.∃.((pnf.mk Q₁ p₁ h₁^1).imply ((pnf.mk Q₂ p₂ h₂).rew ı-{1})).to_formula
        ≈[T] ∃.∃.((pnf.mk Q₁ p₁ h₁^1).to_formula ⟶ ((pnf.mk Q₂ p₂ h₂).rew ı-{1}).to_formula)
    : show _ ≈[T] _, from provable.equiv_ex_of_equiv (provable.equiv_ex_of_equiv (ih _))
    ... ≈[T] ∃.((pnf.mk Q₁ p₁ h₁).to_formula ⟶ (∃.(pnf.mk Q₂ p₂ h₂).to_formula)^1)
    : by { show _ ≈[T] _, symmetry, simp[classical_logic.equiv, formula.ex_pow_discard],
           refine provable.equiv_ex_of_equiv (by simp) }
    ... ≈[T] ∀.(pnf.mk Q₁ p₁ h₁).to_formula ⟶ ∃.(pnf.mk Q₂ p₂ h₂).to_formula
    : by { symmetry, simp [classical_logic.equiv] } }
| ⟨𝚺 :: Q₁, p₁, h₁⟩ ⟨[], p₂, h₂⟩      T := by { simp, have ih := equiv_normalize_imply ⟨Q₁, p₁, h₁⟩ (pnf.mk ([]) p₂ h₂^1),
    calc     ∀.((pnf.mk Q₁ p₁ h₁).imply (pnf.mk ([]) p₂ h₂^1)).to_formula
        ≈[T] ∀.((pnf.mk Q₁ p₁ h₁).to_formula ⟶ (pnf.mk ([]) p₂ h₂^1).to_formula)
    : show _ ≈[T] _, from provable.equiv_univ_of_equiv (ih _)
    ... ≈[T] ∃.(pnf.mk Q₁ p₁ (by simp[h₁])).to_formula ⟶ p₂
    : by { symmetry, simp[classical_logic.equiv] } }
| ⟨𝚺 :: Q₁, p₁, h₁⟩ ⟨𝚷 :: Q₂, p₂, h₂⟩ T := by { simp,
    have ih := equiv_normalize_imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ h₂).rew ı-{1}),
    calc     ∀.∀.((pnf.mk Q₁ p₁ h₁^1).imply ((pnf.mk Q₂ p₂ h₂).rew ı-{1})).to_formula
        ≈[T] ∀.∀.((pnf.mk Q₁ p₁ h₁^1).to_formula ⟶ ((pnf.mk Q₂ p₂ h₂).rew ı-{1}).to_formula)
    : show _ ≈[T] _, from provable.equiv_univ_of_equiv (provable.equiv_univ_of_equiv (ih _))
    ... ≈[T] ∀.((pnf.mk Q₁ p₁ h₁).to_formula ⟶ (∀.(pnf.mk Q₂ p₂ h₂).to_formula)^1)
    : by { show _ ≈[T] _, symmetry, simp[classical_logic.equiv, formula.fal_pow_discard],
           refine provable.equiv_univ_of_equiv (by simp) }
    ... ≈[T] ∃.(pnf.mk Q₁ p₁ h₁).to_formula ⟶ ∀.(pnf.mk Q₂ p₂ h₂).to_formula
    : by { symmetry, simp [classical_logic.equiv] } }
| ⟨𝚺 :: Q₁, p₁, h₁⟩ ⟨𝚺 :: Q₂, p₂, h₂⟩ T := by { simp,
    have ih := equiv_normalize_imply (pnf.mk Q₁ p₁ h₁^1) ((pnf.mk Q₂ p₂ h₂).rew ı-{1}),
    calc     ∀.∃.((pnf.mk Q₁ p₁ h₁^1).imply ((pnf.mk Q₂ p₂ h₂).rew ı-{1})).to_formula
        ≈[T] ∀.∃.((pnf.mk Q₁ p₁ h₁^1).to_formula ⟶ ((pnf.mk Q₂ p₂ h₂).rew ı-{1}).to_formula)
    : show _ ≈[T] _, from provable.equiv_univ_of_equiv (provable.equiv_ex_of_equiv (ih _))
    ... ≈[T] ∀.((pnf.mk Q₁ p₁ h₁).to_formula ⟶ (∃.(pnf.mk Q₂ p₂ h₂).to_formula)^1)
    : by { show _ ≈[T] _, symmetry, simp[classical_logic.equiv, formula.ex_pow_discard],
           refine provable.equiv_univ_of_equiv (by simp) }
    ... ≈[T] ∃.(pnf.mk Q₁ p₁ h₁).to_formula ⟶ ∃.(pnf.mk Q₂ p₂ h₂).to_formula
    : by { symmetry, simp [classical_logic.equiv] } }
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ x, x.1.rank + x.2.1.rank)⟩]}

lemma equiv_normalize_neg : ∀ (p : pnf L) (T : Theory L) , T ⊢ p.neg.to_formula ⟷ ∼p.to_formula
| ⟨[], p, h⟩     T := by simp
| ⟨𝚷 :: Q, p, h⟩ T := by simp;
    calc ∃.(pnf.mk Q p (by simp[h])).neg.to_formula ≈[T] ∃.∼(pnf.mk Q p (by simp[h])).to_formula
    : show _ ≈[T] _, from provable.equiv_ex_of_equiv (equiv_normalize_neg ⟨Q, p, by simp[h]⟩ _)
                                                 ... ≈[T] ∼∀.(pnf.mk Q p (by simp[h])).to_formula
    : classical_logic.equiv_neg_of_equiv (provable.equiv_univ_of_equiv (by simp))
| ⟨𝚺 :: Q, p, h⟩ T := by { simp,
    calc     ∀.(pnf.mk Q p (by simp[h])).neg.to_formula ≈[T] ∀.∼(pnf.mk Q p (by simp[h])).to_formula
    : show _ ≈[T] _, from provable.equiv_univ_of_equiv (equiv_normalize_neg ⟨Q, p, by simp[h]⟩ _)
                                                    ... ≈[T] ∼∃.(pnf.mk Q p (by simp[h])).to_formula
    : by { simp[has_exists_quantifier.ex, formula.ex, classical_logic.equiv] } }

@[reducible] def formula.normalize (p : formula L) : formula L := p.to_pnf.to_formula

@[reducible] def formula.open (p : formula L) : formula L := p.to_pnf.2

@[simp] lemma formula.open_is_open (p : formula L) : p.open.is_open := p.to_pnf.is_openform

open axiomatic_classical_logic'

lemma equiv_normalize : ∀ (p : formula L) {T : Theory L},  T ⊢ p ⟷ p.normalize
| ⊤                 T := by simp[formula.normalize]
| (formula.app p v) T := by simp[formula.normalize]
| (t =' u)          T := by simp[formula.normalize]
| (p ⟶ q)          T :=
    by { simp[formula.normalize],
         have : T ⊢ p ⟶ q ⟷ (p.to_pnf.to_formula ⟶ q.to_pnf.to_formula) :=  (equiv_imply_of_equiv (equiv_normalize p) (equiv_normalize q)),
         refine equiv_trans this (classical_logic.equiv_symm (equiv_normalize_imply p.to_pnf q.to_pnf T)) }
| (∼p)              T := by { simp[formula.normalize],
    have : T ⊢ ∼p ⟷ ∼p.to_pnf.to_formula, from equiv_neg_of_equiv (equiv_normalize p),
    exact equiv_trans this (equiv_symm (equiv_normalize_neg p.to_pnf T)) }
| (∀.p)           T := by { simp[formula.normalize], refine provable.equiv_univ_of_equiv (equiv_normalize p) }

def formula.rank (p : formula L) : ℕ := p.to_pnf.rank

end fol


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

import for_mathlib.algebraic_topology.homotopical_algebra.model_category
import category_theory.abelian.basic
import category_theory.preadditive.projective
import algebra.homology.homological_complex
import algebra.homology.quasi_iso
import for_mathlib.category_theory.limits.kernel_functor
import for_mathlib.algebra.homology.twist_cocycle
import tactic.linarith

noncomputable theory

open category_theory category_theory.limits category_theory.category
open algebraic_topology cochain_complex.hom_complex

open_locale zero_object

variables (C : Type*) [category C] [abelian C]

namespace cochain_complex

@[derive category]
def Cminus := full_subcategory (λ (K : cochain_complex C ℤ), K.is_bounded_above)

namespace Cminus

variable {C}

@[simps]
def mk (K : cochain_complex C ℤ) (hK : K.is_bounded_above) : Cminus C := ⟨K, hK⟩

def homology_functor (i : ℤ) : Cminus C ⥤ C := induced_functor _ ⋙ homology_functor _ _ i

def eval (i : ℤ) : Cminus C ⥤ C := induced_functor _ ⋙ homological_complex.eval _ _ i

namespace projective_structure

variable (C)

def arrow_classes : category_with_fib_cof_weq (Cminus C) :=
{ weq := λ X Y w, quasi_iso w,
  fib := λ X Y w, ∀ n, epi (w.f n),
  cof := λ X Y w, ∀ n, mono (w.f n) ∧ (projective (cokernel (w.f n))), }

variable {C}

def CM2 : (arrow_classes C).CM2 :=
{ of_comp := λ X Y Z f g (hf : quasi_iso f) (hg : quasi_iso g), begin
    haveI := hf,
    haveI := hg,
    exact quasi_iso_comp f g,
  end,
  of_comp_left := λ X Y Z f g (hf : quasi_iso f) (hfg : quasi_iso (f ≫ g)), begin
    haveI := hf,
    haveI := hfg,
    convert quasi_iso_of_comp_left f g,
  end,
  of_comp_right := λ X Y Z f g (hg : quasi_iso g) (hfg : quasi_iso (f ≫ g)), begin
    haveI := hg,
    haveI := hfg,
    convert quasi_iso_of_comp_right f g,
  end, }

def CM3 : (arrow_classes C).CM3 :=
{ weq := λ X₁ X₂ Y₁ Y₂ f g hfg hg, ⟨λ n, begin
    have hfg' := is_retract.imp_of_functor (homology_functor n).map_arrow
      (arrow.mk f) (arrow.mk g) hfg,
    apply morphism_property.is_stable_by_retract.for_isomorphisms _ _ hfg',
    apply hg.1,
  end⟩,
  cof := λ X₁ X₂ Y₁ Y₂ f g hfg hg n, begin
    split,
    { exact morphism_property.is_stable_by_retract.for_monomorphisms _ _
      (is_retract.imp_of_functor (eval n).map_arrow _ _ hfg) (hg n).1, },
    { exact projective.of_retract (is_retract.imp_of_functor
      ((eval n).map_arrow ⋙ limits.cokernel_functor C) _ _ hfg) (hg n).2, },
  end,
  fib := λ X₁ X₂ Y₁ Y₂ f g hfg hg n, morphism_property.is_stable_by_retract.for_epimorphisms _ _
      (is_retract.imp_of_functor (eval n).map_arrow _ _ hfg) (hg n), }

def CM4 : (arrow_classes C).CM4 := sorry

variable [enough_projectives C]

namespace CM5a

def P (L : Cminus C) (q : ℤ) : C :=
begin
  by_cases is_zero (L.1.X q),
  { exact 0, },
  { exact projective.over (L.1.X q), },
end

instance (L : Cminus C) (q : ℤ) : projective (P L q) :=
begin
  dsimp [P],
  split_ifs,
  { apply projective.zero_projective, },
  { apply projective.projective_over, },
end

lemma P_eq (L : Cminus C) (q : ℤ) (hq : ¬(is_zero (L.1.X q))) :
  P L q = projective.over (L.1.X q) :=
begin
  dsimp [P],
  split_ifs,
  { exfalso, exact hq h, },
  { refl, },
end

lemma P_eq_zero (L : Cminus C) (q : ℤ) (hq : is_zero (L.1.X q)) :
  P L q = 0 :=
begin
  dsimp [P],
  split_ifs,
  { refl, },
  { exfalso, exact h hq, },
end

lemma P_is_initial (L : Cminus C) (q : ℤ) (hq : is_zero (L.1.X q)) :
  is_initial (P L q) :=
begin
  rw P_eq_zero L q hq,
  apply is_zero.is_initial,
  apply is_zero_zero,
end

def is_zero.unique_up_to_iso {X Y : C} (hX : is_zero X) (hY : is_zero Y) : X ≅ Y :=
{ hom := 0,
  inv := 0,
  hom_inv_id' := by { rw is_zero.iff_id_eq_zero at hX, rw [hX, comp_zero], },
  inv_hom_id' := by { rw is_zero.iff_id_eq_zero at hY, rw [hY, comp_zero], }, }

def P_π (L : Cminus C) (q : ℤ) : P L q ⟶ L.1.X q :=
begin
  by_cases is_zero (L.1.X q),
  { have e : 0 ≅ L.1.X q := is_zero.unique_up_to_iso
      (is_zero_zero C) h, swap,
    exact eq_to_hom (P_eq_zero L q h) ≫ e.hom, },
  { exact eq_to_hom (P_eq L q h) ≫ projective.π (L.1.X q), },
end

lemma P_π_eq_to_hom (L : Cminus C) (q₁ q₂ : ℤ) (hq : q₁ = q₂) :
  P_π L q₁ = eq_to_hom (by rw hq) ≫ P_π L q₂ ≫ eq_to_hom (by rw hq) :=
by { subst hq, simp only [eq_to_hom_refl, comp_id, id_comp], }

@[simps]
def KP (L : Cminus C) : Cminus C := Cminus.mk
{ X := λ q, P L (q-1),
  d := λ i j, 0,
  shape' := λ i j hij, rfl,
  d_comp_d' := λ i j k hij hjk, comp_zero, }
begin
  cases L.2 with r hr,
  use r+1,
  intros i hi,
  dsimp,
  rw P_eq_zero L,
  { apply is_zero_zero, },
  { apply hr,
    linarith, },
end

instance (L : Cminus C) (q : ℤ) : epi (P_π L q) :=
by { dsimp only [P_π], split_ifs; apply epi_comp, }

def twistP (L : Cminus C) : Cminus C :=
⟨twist (cocycle.of_hom (𝟙 (KP L).1)), twist.is_bounded_above _ (KP L).2 (KP L).2⟩

def π (L : Cminus C) : twistP L ⟶ L :=
begin
  refine twist.desc (cocycle.of_hom (𝟙 (KP L).1)) (cochain.mk _) _ (neg_add_self 1) _ ,
  { exact (λ p q hpq, P_π L _ ≫ eq_to_hom (by {congr' 1, linarith})), },
  { exact
    { f := λ i, P_π L (i-1) ≫ L.1.d (i-1) i,
      comm' := λ i j hij, begin
        change i+1=j at hij,
        dsimp [KP],
        simp only [assoc, homological_complex.d_comp_d, comp_zero, zero_comp],
      end, }, },
  { ext,
    dsimp [KP],
    simp only [δ_v (-1) 0 rfl _ p p (add_zero p).symm (p-1) (p+1) rfl rfl,
      add_zero, zero_comp, cochain.mk_v, eq_to_hom_refl, comp_id,
      smul_zero, cochain.id_comp, cochain.of_hom_v], },
end

example : 2+2=4 := rfl

instance (L : Cminus C) (q : ℤ) : epi ((π L).f q) :=
begin
  haveI : epi (biprod.inl ≫ (π L).f q),
  { have eq : biprod.inl ≫ (π L).f q = eq_to_hom (by { dsimp, congr, linarith }) ≫ P_π L q,
    { dsimp [π, twist.desc_cochain, twist.fst, twist.snd, cochain.mk, cochain.v,
        cochain.of_hom, cochain.of_homs, cochain.comp],
      simp only [id_comp, assoc, add_zero, preadditive.comp_add, biprod.inl_fst_assoc, biprod.inl_snd_assoc, zero_comp,
        P_π_eq_to_hom L (q+(0 - -1)-1) q (by linarith), eq_to_hom_trans, eq_to_hom_refl,
        eq_to_hom_trans_assoc, comp_id], },
    rw eq,
    apply epi_comp, },
  exact epi_of_epi biprod.inl ((π L).f q),
end

instance : preadditive (Cminus C) := sorry
instance : has_binary_biproducts (Cminus C) := sorry

end CM5a

lemma CM5a : (arrow_classes C).CM5a := λ X Z f,
begin
  let Y := CM5a.twistP Z,
  let i : X ⟶ X ⊞ Y := biprod.inl,
  let p : X ⊞ Y ⟶ Z := biprod.desc f (CM5a.π Z),
  let j : Y ⟶ X ⊞ Y := biprod.inr,
  have hip : i ≫ p = f := biprod.inl_desc _ _,
  refine ⟨X ⊞ Y, i, _, p, _, hip⟩,
  { sorry, },
  { intro,
    have hjp : j ≫ p = CM5a.π Z := biprod.inr_desc _ _,
    have hjp' : j.f n ≫ p.f n = (CM5a.π Z).f n,
    { rw [← hjp, ← homological_complex.comp_f],
      refl, },
    haveI : epi (j.f n ≫ p.f n),
    { rw hjp',
      apply_instance, },
    exact epi_of_epi (j.f n) (p.f n), },
end

def CM5 : (arrow_classes C).CM5 := ⟨CM5a, sorry⟩

variable (C)

@[simps]
def projective_structure : model_category (Cminus C) :=
{ to_category_with_fib_cof_weq := arrow_classes C,
  CM1axiom := sorry,
  CM2axiom := CM2,
  CM3axiom := CM3,
  CM4axiom := CM4,
  CM5axiom := CM5, }

instance : model_category (Cminus C) := projective_structure C

end projective_structure

end Cminus

end cochain_complex


def f (n : Nat) := n + 1
example (k : Nat) : let x := 10; f x = k := by
  have : f 10 = 11 := rfl
  intro x
  rw [this]
  trace_state
  revert x
  trace_state
  sorry


import for_mathlib.projective_space.incidence
import for_mathlib.projective_space.affine_embedding

open projectivization

notation `mk₀` x := (mk _ x (by simp))
notation `mk[` F `]` x := (mk F (x : F × F × F) (by simp))

variables {K F : Type*} [field K] [field F]

section configurations

meta def helper₃ := `[
  rw [independent_mk_iff₃, fintype.linear_independent_iff],
  intros g hg,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
    mul_one, mul_zero, matrix.cons_val_succ, fin.succ_zero_eq_one, fintype.univ_of_subsingleton,
    fin.mk_zero, finset.sum_singleton, fin.succ_one_eq_two, prod.mk_add_mk, add_zero,
    zero_add, prod.mk_eq_zero] at hg,
  rcases hg with ⟨h1,h2,h3⟩ ]

meta def helper₂ := `[
  rw [independent_mk_iff₂, fintype.linear_independent_iff],
  intros g hg,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
    mul_one, mul_zero, matrix.cons_val_succ, fin.succ_zero_eq_one, fintype.univ_of_subsingleton,
    fin.mk_zero, finset.sum_singleton, fin.succ_one_eq_two, prod.mk_add_mk, add_zero,
    zero_add, prod.mk_eq_zero] at hg,
  rcases hg with ⟨h1,h2,h3⟩ ]

variables (F K)
def one_add_x_add_y_config : projectivization.configuration F (F × F × F)
  (mk[F] (1,0,0)) -- (φ 1)
  (mk[F] (0,1,0)) -- (φ (1 + x))
  (mk[F] (0,0,1))-- (φ (1 + y))
  (mk[F] (1,1,0)) -- (φ x)
  (mk[F] (1,0,1)) -- (φ y)
  :=
{ Iabc := begin
    helper₃,
    intros i, fin_cases i; assumption
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    refine ⟨![1,1,-1], by simp [fin.sum_univ_succ], 0, by norm_num⟩,
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    refine ⟨![1,1,-1], by simp [fin.sum_univ_succ], 0, by norm_num⟩,
  end,
  Iau := begin
    rw [← ne_iff_independent],
    apply (affine_embedding_injective _ _).ne,
    norm_num,
  end,
  Ibu := begin
    rw [← ne_iff_independent],
    apply ne.symm,
    apply ne_of_leading_one_of_leading_zero,
    norm_num
  end,
  Iav := begin
    rw [← ne_iff_independent],
    apply (affine_embedding_injective _ _).ne,
    norm_num,
  end,
  Icv := begin
    rw [← ne_iff_independent],
    apply ne.symm,
    apply ne_of_leading_one_of_leading_zero,
    norm_num
  end }

def two_add_x_add_y_config : configuration F (F × F × F)
  (mk[F] (1,0,1)) -- (φ y)
  (mk[F] (1,1,1)) -- (φ (1 + x + y))
  (mk[F] (0,0,1)) -- (φ (1 + y))
  (mk[F] (0,1,0)) -- (φ (1 + x))
  (mk[F] (1,0,0)) -- (φ 1)
  :=
{ Iabc := begin
    helper₃,
    intros i, fin_cases i,
    { simpa [h2] using h1 },
    { exact h2 },
    { rw [h2, add_zero] at h1, simpa [h2,h1] using h3 },
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    refine ⟨![1,-1,1], by simp [fin.sum_univ_succ], 0, by norm_num⟩,
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    refine ⟨![-1,1,1], by simp [fin.sum_univ_succ], 0, by norm_num⟩,
  end,
  Iau := begin
    rw [← ne_iff_independent],
    apply ne_of_leading_one_of_leading_zero,
    norm_num
  end,
  Ibu := begin
    rw [← ne_iff_independent],
    apply ne_of_leading_one_of_leading_zero,
    norm_num
  end,
  Iav := begin
    rw [← ne_iff_independent],
    apply (affine_embedding_injective _ _).ne,
    norm_num
  end,
  Icv := begin
    rw [← ne_iff_independent],
    apply ne.symm,
    apply ne_of_leading_one_of_leading_zero,
    norm_num
  end }

def frac_config (n : ℕ) : configuration F (F × F × F)
  (mk[F] (n-1,1,0))
  (mk[F] (1,0,0))
  (mk[F] (1,0,1))
  (mk[F] (n,1,0))
  (mk[F] (n,1,1)) :=
{ Iabc := begin
    helper₃,
    intros i, fin_cases i,
    { exact h2 },
    { simpa [h2,h3] using h1 },
    { exact h3 },
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk,
        algebra.id.smul_eq_mul, one_mul, mul_one, mul_zero,
        matrix.cons_val_succ, fintype.univ_of_subsingleton, fin.mk_zero,
        matrix.cons_val_fin_one, neg_smul, prod.neg_mk, finset.sum_const, finset.card_singleton,
        nsmul_eq_mul, nat.cast_one, prod.mk_add_mk, zero_add, add_zero, add_right_neg,
        prod.mk_eq_zero, eq_self_iff_true, and_true],
      ring },
    use 1, norm_num,
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
        one_mul, mul_one, mul_zero, matrix.cons_val_succ, fintype.univ_of_subsingleton,
        fin.mk_zero, matrix.cons_val_fin_one, neg_smul, prod.neg_mk,
        finset.sum_const, finset.card_singleton, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true],
      ring },
    use 1, norm_num,
  end,
  Iau := begin
    helper₂,
    have : g 0 * ((n : F) - 1) + g 1 * n = n * (g 0 + g 1) - g 0, by ring,
    rw [this,h2, mul_zero, zero_sub, neg_eq_zero] at h1,
    rw [h1, zero_add] at h2,
    intros i, fin_cases i,
    exacts [h1, h2]
  end,
  Ibu := begin
    helper₂,
    intros i, fin_cases i,
    { simpa [h2] using h1 },
    { exact h2 }
  end,
  Iav := begin
    helper₂,
    intros i, fin_cases i,
    { simpa [h3] using h2 },
    { exact h3 }
  end,
  Icv := begin
    helper₂,
    intros i, fin_cases i,
    { simpa [h2] using h3 },
    { exact h2 }
  end }

def frac_config' (n : ℕ) : configuration F (F × F × F)
  (mk[F] (n,1,1))
  (mk[F] (0,0,1))
  (mk[F] (1,0,0))
  (mk[F] (n,1,0))
  (mk[F] (n+1,1,1)) :=
{ Iabc := begin
    helper₃,
    simp only [h2, zero_mul, zero_add] at h1 h3,
    intros i, fin_cases i, assumption',
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num }
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num }
  end,
  Iau := begin
    helper₂,
    simp only [h3, zero_add] at h2,
    intros i, fin_cases i, assumption',
  end,
  Ibu := begin
    helper₂,
    intros i, fin_cases i, assumption',
  end,
  Iav := begin
    helper₂,
    rw (show g 0 * ↑n + g 1 * (↑n + 1) = (g 0 + g 1) * n + g 1, by ring) at h1,
    simp only [h2, zero_mul, zero_add] at h1,
    simp only [h1, add_zero] at h2,
    intros i, fin_cases i, assumption'
  end,
  Icv := begin
    helper₂,
    simp only [h2, zero_mul, add_zero] at h1,
    intro i, fin_cases i, assumption',
  end }

def frac_config_horizontal (n m : ℕ) (hn : (n : F) ≠ 0) : configuration F (F × F × F)
  (mk F (n,m-1,0) (λ c, hn (congr_arg prod.fst c)))
  (mk[F] (0,1,0))
  (mk[F] (0,1,1))
  (mk F (n,m,0) (λ c, hn (congr_arg prod.fst c)))
  (mk F (n,m,1) (λ c, hn (congr_arg prod.fst c))) :=
{ Iabc := begin
    helper₃,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1,h3,zero_mul,zero_add,add_zero] at h2,
    intros i, fin_cases i, assumption'
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
        one_mul, mul_zero, matrix.cons_val_succ, mul_one, fintype.univ_of_subsingleton,
        fin.mk_zero, matrix.cons_val_fin_one, neg_smul, prod.neg_mk,
        finset.sum_const, finset.card_singleton, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_zero, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
      ring },
    use 0, norm_num
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
        one_mul, mul_zero, matrix.cons_val_succ, mul_one, fintype.univ_of_subsingleton,
        fin.mk_zero, matrix.cons_val_fin_one, neg_smul, prod.neg_mk,
        finset.sum_const, finset.card_singleton, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_zero, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
      ring },
    use 1, norm_num,
  end,
  Iau := begin
    helper₂,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [add_mul, mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    have : g 0 * (↑m - 1) + g 1 * ↑m = (g 0 + g 1) * (m : F) - g 0, by ring,
    rw [this, h1, zero_mul, zero_sub, neg_eq_zero] at h2,
    rw [h2, zero_add] at h1,
    intros i, fin_cases i, assumption'
  end,
  Ibu := begin
    helper₂,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1, zero_mul, add_zero] at h2,
    intros i, fin_cases i, assumption'
  end,
  Iav := begin
    helper₂,
    simp only [h3, zero_mul, add_zero] at h1,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [zero_mul, add_zero, mul_assoc, mul_inv_cancel hn, mul_one] at h1,
    intros i, fin_cases i, assumption'
  end,
  Icv := begin
    helper₂,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1, add_zero] at h3,
    intros i, fin_cases i, assumption',
  end }

def frac_config_horizontal' (n m : ℕ) (hn : (n : F) ≠ 0) : configuration F (F × F × F)
  (mk F (n,m,1) (λ c, hn (congr_arg prod.fst c)))
  (mk[F] (0,1,0))
  (mk[F] (0,0,1))
  (mk[F] (n,m+1,1))
  (mk F (n,m,0) (λ c, hn (congr_arg prod.fst c)))
  :=
{ Iabc := begin
    helper₃,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1, zero_add, zero_mul] at h2 h3,
    intros i, fin_cases i, assumption'
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num },
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num },
  end,
  Iau := begin
    rw ← ne_iff_independent,
    apply (affine_embedding_of_nonzero_injective _ _ _ hn).ne,
    norm_num,
  end,
  Ibu := begin
    rw ← ne_iff_independent, apply ne.symm,
    apply ne_of_leading_nonzero_of_leading_zero,
    norm_num, assumption
  end,
  Iav := begin
    rw ← ne_iff_independent, apply ne.symm,
    apply (affine_embedding_of_nonzero_injective _ _ _ hn).ne,
    norm_num,
  end,
  Icv := begin
    rw ← ne_iff_independent, apply ne.symm,
    apply ne_of_leading_nonzero_of_leading_zero,
    norm_num, assumption
  end }

/-
def neg_frac_config (n : ℕ) : configuration F (F × F × F)
  (mk[F] (n-1,-1,0))
  (mk[F] (1,0,0))
  (mk[F] (1,0,1))
  (mk[F] (n,-1,0))
  (mk[F] (n,-1,1)) :=
{ Iabc := begin
    helper₃,
    simp only [mul_neg, mul_one, neg_eq_zero] at h2,
    intros i, fin_cases i,
    { exact h2 },
    { simpa [h2,h3] using h1 },
    { exact h3 },
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk,
        algebra.id.smul_eq_mul, one_mul, mul_one, mul_zero,
        matrix.cons_val_succ, fintype.univ_of_subsingleton, fin.mk_eq_subtype_mk, fin.mk_zero,
        matrix.cons_val_fin_one, neg_smul, prod.neg_mk, finset.sum_const, finset.card_singleton,
        nsmul_eq_mul, nat.cast_one, prod.mk_add_mk, zero_add, add_zero, add_right_neg,
        prod.mk_eq_zero, eq_self_iff_true, and_true],
      ring },
    use 1, norm_num,
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
        one_mul, mul_one, mul_zero, matrix.cons_val_succ, fintype.univ_of_subsingleton,
        fin.mk_eq_subtype_mk, fin.mk_zero, matrix.cons_val_fin_one, neg_smul, prod.neg_mk,
        finset.sum_const, finset.card_singleton, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true],
      ring },
    use 1, norm_num,
  end,
  Iau := begin
    helper₂,
    simp only [mul_neg, mul_one, neg_eq_zero, ← neg_add] at h2,
    have : g 0 * ((n : F) - 1) + g 1 * n = n * (g 0 + g 1) - g 0, by ring,
    rw [this,h2, mul_zero, zero_sub, neg_eq_zero] at h1,
    rw [h1, zero_add] at h2,
    intros i, fin_cases i,
    exacts [h1, h2]
  end,
  Ibu := begin
    helper₂,
    simp only [mul_neg, mul_one, neg_eq_zero] at h2,
    intros i, fin_cases i,
    { simpa [h2] using h1 },
    { exact h2 }
  end,
  Iav := begin
    helper₂,
    intros i, fin_cases i,
    { simpa [h3] using h2 },
    { exact h3 }
  end,
  Icv := begin
    helper₂,
    simp only [mul_neg, mul_one, neg_eq_zero] at h2,
    intros i, fin_cases i,
    { simpa [h2] using h3 },
    { exact h2 }
  end }

def neg_frac_config' (n : ℕ) : configuration F (F × F × F)
  (mk[F] (n,-1,1))
  (mk[F] (0,0,1))
  (mk[F] (1,0,0))
  (mk[F] (n,-1,0))
  (mk[F] (n+1,-1,1)) :=
{ Iabc := begin
    helper₃,
    simp only [mul_neg, mul_one, neg_eq_zero] at h2,
    simp only [h2, zero_mul, zero_add] at h1 h3,
    intros i, fin_cases i, assumption',
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num }
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num }
  end,
  Iau := begin
    helper₂,
    rw [← add_mul, mul_neg, mul_one, neg_eq_zero] at h2,
    simp only [h3, zero_add] at h2,
    intros i, fin_cases i, assumption',
  end,
  Ibu := begin
    helper₂,
    simp only [mul_neg, mul_one, neg_eq_zero] at h2,
    intros i, fin_cases i, assumption',
  end,
  Iav := begin
    helper₂,
    rw [← add_mul, mul_neg, mul_one, neg_eq_zero] at h2,
    rw (show g 0 * ↑n + g 1 * (↑n + 1) = (g 0 + g 1) * n + g 1, by ring) at h1,
    simp only [h2, zero_mul, zero_add] at h1,
    simp only [h1, add_zero] at h2,
    intros i, fin_cases i, assumption'
  end,
  Icv := begin
    helper₂,
    simp only [mul_neg, mul_one, neg_eq_zero] at h2,
    simp only [h2, zero_mul, add_zero] at h1,
    intro i, fin_cases i, assumption',
  end }

def neg_frac_config_horizontal (n m : ℕ) (hn : (n : F) ≠ 0) : configuration F (F × F × F)
  (mk F (n,1-m,0) (λ c, hn (congr_arg prod.fst c)))
  (mk[F] (0,1,0))
  (mk[F] (0,-1,1))
  (mk F (n,-m,0) (λ c, hn (congr_arg prod.fst c)))
  (mk F (n,-m,1) (λ c, hn (congr_arg prod.fst c))) :=
{ Iabc := begin
    helper₃,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1,h3,zero_mul,zero_add,add_zero] at h2,
    intros i, fin_cases i, assumption'
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
        one_mul, mul_zero, matrix.cons_val_succ, mul_one, fintype.univ_of_subsingleton,
        fin.mk_eq_subtype_mk, fin.mk_zero, matrix.cons_val_fin_one, neg_smul, prod.neg_mk,
        finset.sum_const, finset.card_singleton, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_zero, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
      refine ⟨_,_,_⟩; ring },
    use 0, norm_num
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul,
        one_mul, mul_zero, matrix.cons_val_succ, mul_one, fintype.univ_of_subsingleton,
        fin.mk_eq_subtype_mk, fin.mk_zero, matrix.cons_val_fin_one, neg_smul, prod.neg_mk,
        finset.sum_const, finset.card_singleton, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_zero, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
      ring },
    use 1, norm_num,
  end,
  Iau := begin
    helper₂,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [add_mul, mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    have : g 0 * (1 - ↑m) + g 1 * (-↑m) = (g 0 + g 1) * -(m : F) + g 0, by ring,
    rw [this, h1, zero_mul, zero_add] at h2,
    rw [h2, zero_add] at h1,
    intros i, fin_cases i, assumption'
  end,
  Ibu := begin
    helper₂,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1, zero_mul, add_zero] at h2,
    intros i, fin_cases i, assumption'
  end,
  Iav := begin
    helper₂,
    simp only [h3, zero_mul, add_zero] at h1,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [zero_mul, add_zero, mul_assoc, mul_inv_cancel hn, mul_one] at h1,
    intros i, fin_cases i, assumption'
  end,
  Icv := begin
    helper₂,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1, add_zero] at h3,
    intros i, fin_cases i, assumption',
  end }

def neg_frac_config_horizontal' (n m : ℕ) (hn : (n : F) ≠ 0) : configuration F (F × F × F)
  (mk F (n,-m,1) (λ c, hn (congr_arg prod.fst c)))
  (mk[F] (0,1,0))
  (mk[F] (0,0,1))
  (mk[F] (n,-m-1,1))
  (mk F (n,-m,0) (λ c, hn (congr_arg prod.fst c)))
  :=
{ Iabc := begin
    helper₃,
    apply_fun (λ e, e * (n : F)⁻¹) at h1,
    simp only [mul_assoc, mul_inv_cancel hn, mul_one, zero_mul] at h1,
    simp only [h1, zero_add, zero_mul] at h2 h3,
    intros i, fin_cases i, assumption'
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num },
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num },
  end,
  Iau := begin
    rw ← ne_iff_independent,
    apply (affine_embedding_of_nonzero_injective _ _ _ hn).ne,
    simp only [ne.def, prod.mk.inj_iff, eq_self_iff_true, and_true],
    rw (show (-(m : F) - 1) = -(m+1), by ring),
    norm_num,
  end,
  Ibu := begin
    rw ← ne_iff_independent, apply ne.symm,
    apply ne_of_leading_nonzero_of_leading_zero,
    norm_num, assumption
  end,
  Iav := begin
    rw ← ne_iff_independent, apply ne.symm,
    apply (affine_embedding_of_nonzero_injective _ _ _ hn).ne,
    norm_num,
  end,
  Icv := begin
    rw ← ne_iff_independent, apply ne.symm,
    apply ne_of_leading_nonzero_of_leading_zero,
    norm_num, assumption
  end }
-/

def neg_config : configuration F (F × F × F)
  (mk[F] (1,1,1))
  (mk[F] (0,1,0))
  (mk[F] (0,1,1))
  (mk[F] (1,0,1))
  (mk[F] (1,0,0)) :=
{ Iabc := begin
    helper₃,
    simp only [h1, zero_add] at h3,
    simp only [h1, h3, add_zero, zero_add] at h2,
    intros i, fin_cases i, assumption'
  end,
  Dabu := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num }
  end,
  Dacv := begin
    rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num }
  end,
  Iau := begin
    rw ← ne_iff_independent,
    apply (affine_embedding_injective _ _).ne,
    norm_num,
  end,
  Ibu := begin
    rw ← ne_iff_independent,
    apply ne.symm,
    apply ne_of_leading_one_of_leading_zero,
    norm_num,
  end,
  Iav := begin
    rw ← ne_iff_independent,
    apply (affine_embedding_injective _ _).ne,
    norm_num,
  end,
  Icv := begin
    rw ← ne_iff_independent,
    apply ne.symm,
    apply ne_of_leading_one_of_leading_zero,
    norm_num,
  end }

variables {F K}
end configurations

structure setup (φ : K → ℙ F (F × F × F)) (x y : K) :=
(map_zero : φ 0 = mk₀ (1,0,0))
(map_one : φ 1 = mk₀ (1,0,0))
(map_x : φ x = mk₀ (1,1,0))
(map_y : φ y = mk₀ (1,0,1))
(map_one_add_x : φ (1+x) = mk₀ (0,1,0))
(map_one_add_y : φ (1+y) = mk₀ (0,0,1))
(map_neg : ∀ u : K, φ (-u) = φ u)
(dependent_pos : ∀ u v : K, dependent ![φ u, φ v, φ (u + v)])
(dependent_neg : ∀ u v : K, dependent ![φ u, φ v, φ (u - v)]) .

namespace setup

variables {φ : K → ℙ F (F × F × F)} {x y : K} (C : setup φ x y)
include C

lemma map_one_add_x_add_y : φ (1 + x + y) = mk₀ (1,1,1) :=
begin
  apply eq_of_config _ _ _ _ _ _ _ (one_add_x_add_y_config F),
  all_goals { simp only [← C.map_one, ← C.map_x, ← C.map_y, ← C.map_one_add_x, ← C.map_one_add_y] },
  rw (show (1 + x + y) = x + (1 + y), by ring),
  apply C.dependent_pos,
  rw (show (1 + x + y) = y + (1 + x), by ring),
  apply C.dependent_pos,
  { rw [C.map_x, C.map_one_add_y, dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 1, simp } },
  { rw [C.map_y, C.map_one_add_x, dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 1, simp } },
end

lemma map_two_add_x_add_y : φ (2 + x + y) = mk₀ (0,1,1) :=
begin
  apply eq_of_config _ _ _ _ _ _ _ (two_add_x_add_y_config F),
  all_goals
  { simp only [← C.map_y, ← C.map_one_add_x_add_y, ← C.map_one_add_y,
      ← C.map_one_add_x, ← C.map_one] },
  { rw (show (2 + x + y) = (1 + x) + (1 + y), by ring),
    apply C.dependent_pos },
  { rw (show (2 + x + y) = 1 + (1 + x + y), by ring),
    apply C.dependent_pos },
  { rw [C.map_one_add_x, C.map_one_add_y, dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, simp } },
  { rw [C.map_one, C.map_one_add_x_add_y, dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, simp } },
end

lemma map_two_add_x : φ (2 + x) = mk[F] (1,-1,0) :=
begin
  apply eq_of_config _ _ _ _ _ _ _ (neg_config F),
  all_goals { simp only [← C.map_two_add_x_add_y, ← C.map_y,
    ← C.map_one, ← C.map_one_add_x] },
  { nth_rewrite 1 (show (2 + x) = (-y) + (2 + x + y), by ring),
    rw ← C.map_neg y,
    apply C.dependent_pos },
  { rw (show (2 + x) = 1 + (1 + x), by ring),
    apply C.dependent_pos },
  { simp only [C.map_y, C.map_two_add_x_add_y, dependent_mk_iff₃,
      fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num } },
  { simp only [C.map_one, C.map_one_add_x, dependent_mk_iff₃,
      fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num } },
end

lemma map_to_frac (n : ℕ) :
  (φ ((2 - n) + x + y) = mk[F] (n,1,1)) ∧
  (φ ((1 - n) + x) = mk[F] (n,1,0)) :=
begin
  induction n with n hn,
  { simp only [nat.cast_zero, sub_zero],
    refine ⟨C.map_two_add_x_add_y, C.map_one_add_x⟩ },
  cases hn with h1 h2,
  have key : φ ((2 - (↑n+1)) + x + y) = mk[F] (↑n+1,1,1),
  { apply eq_of_config _ _ _ _ _ _ _ (frac_config F n),
    { rw [← h2, ← C.map_y],
      rw (show 2 - (↑n + 1) + x + y = (1 - ↑n + x) + y, by ring),
      apply C.dependent_pos },
    { rw [← h1, ← C.map_one],
      convert C.dependent_neg _ _, ring },
    { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
      use ![1,1,-1], split,
      { simp [fin.sum_univ_succ] },
      { use 0, norm_num } },
    { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
      use ![1,1,-1], split,
      { simp [fin.sum_univ_succ] },
      { use 0, norm_num } } },
  refine ⟨_, _⟩,
  { exact_mod_cast key },
  apply eq_of_config _ _ _ _ _ _ _ (frac_config' F n),
  { rw [← h2, ← C.map_one],
    convert C.dependent_neg _ _,
    push_cast, ring },
  { rw [← key, ← C.map_one_add_y],
    convert C.dependent_neg _ _,
    push_cast, ring },
  { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num } },
  { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp only [fin.sum_univ_succ, nat.cast_succ, matrix.cons_val_zero, prod.smul_mk,
        algebra.id.smul_eq_mul, one_mul, mul_one, matrix.cons_val_succ, neg_smul,
        mul_zero, prod.neg_mk, neg_zero, fintype.univ_of_subsingleton,
        fin.mk_zero, matrix.cons_val_fin_one, neg_add_rev, finset.sum_const,
        finset.card_singleton, smul_add, nsmul_eq_mul, nat.cast_one, prod.mk_add_mk,
        zero_add, add_zero, add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true],
      ring },
    { use 0, norm_num } },
end

lemma map_to_frac_horizontal (n m : ℕ) (hn : (n : F) ≠ 0) (hm : m ≠ 0) :
  (φ ((1 + m - n) + m * x + y) = mk[F] (n,m,1)) ∧
  (φ ((m-n) + m * x) = projectivization.mk F (n,m,0) (λ c, hn (congr_arg prod.fst c))) :=
begin
  cases m, { exfalso, exact hm rfl },
  induction m with m H,
  { convert (C.map_to_frac n) using 3,
    { push_cast, ring },
    { exact_mod_cast rfl },
    { push_cast, ring },
    { exact_mod_cast rfl } },
  specialize H (m.succ_ne_zero),
  have key :
    φ (1 + m + 2 - n + (m + 2) * x + y) =
    projectivization.mk F (n, m + 1 + 1, 1) (λ c, hn (congr_arg prod.fst c)),
  { apply eq_of_config _ _ _ _ _ _ _ (frac_config_horizontal F n (m + 1) hn),
    { rw [← H.2, ← C.map_two_add_x_add_y],
      convert C.dependent_pos _ _ using 5,
      push_cast, ring },
    { erw [← H.1, ← C.map_one_add_x],
      convert C.dependent_pos _ _ using 5,
      push_cast, ring },
    { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
      use ![1,1,-1], split,
      { simp only [fin.sum_univ_succ, nat.cast_add, nat.cast_one, matrix.cons_val_zero,
          prod.smul_mk, algebra.id.smul_eq_mul, one_mul, mul_zero, matrix.cons_val_succ,
          mul_one, fintype.univ_of_subsingleton, fin.mk_zero,
          matrix.cons_val_fin_one, neg_smul, prod.neg_mk, neg_add_rev, finset.sum_const,
          finset.card_singleton, nsmul_eq_mul, prod.mk_add_mk, zero_add, add_right_neg,
          prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
        ring },
      { use 0, norm_num } },
    { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
      use ![1,1,-1], split,
      { simp only [fin.sum_univ_succ, nat.cast_add, nat.cast_one, matrix.cons_val_zero,
          prod.smul_mk, algebra.id.smul_eq_mul, one_mul, mul_zero, matrix.cons_val_succ,
          mul_one, fintype.univ_of_subsingleton, fin.mk_zero,
          matrix.cons_val_fin_one, neg_smul, prod.neg_mk, neg_add_rev, finset.sum_const,
          finset.card_singleton, nsmul_eq_mul, prod.mk_add_mk, zero_add, add_right_neg,
          prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
        ring },
      { use 0, norm_num } } },
  split, { exact_mod_cast key },
  push_cast at H,
  apply eq_of_config _ _ _ _ _ _ _ (frac_config_horizontal' F n (m + 1) hn),
  { push_cast, rw [← key, ← C.map_one_add_y],
    convert C.dependent_neg _ _ using 5, ring },
  { push_cast, rw [← H.2, ← C.map_one_add_x],
    convert C.dependent_pos _ _ using 5, ring },
  { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,-1,-1], split,
    { simp only [fin.sum_univ_succ, nat.cast_add, nat.cast_one, nat.cast_succ,
        matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul, one_mul,
        mul_one, matrix.cons_val_succ, neg_smul, mul_zero, prod.neg_mk, neg_zero,
        fintype.univ_of_subsingleton, fin.mk_zero,
        matrix.cons_val_fin_one, neg_add_rev, finset.sum_const, finset.card_singleton,
        nsmul_eq_mul, mul_neg, smul_add, smul_zero, prod.mk_add_mk, zero_add, add_zero,
        add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
      simp only [nat.cast_zero, zero_add, one_mul, prod.mk_add_mk, add_zero,
        add_right_neg, prod.mk_eq_zero, eq_self_iff_true,
        and_true, true_and],
      ring },
    { use 0, norm_num } },
  { rw [dependent_mk_iff₃, fintype.not_linear_independent_iff],
    use ![1,1,-1], split,
    { simp only [fin.sum_univ_succ, nat.cast_add, nat.cast_one, nat.cast_succ,
        matrix.cons_val_zero, prod.smul_mk, algebra.id.smul_eq_mul, one_mul,
        mul_zero, matrix.cons_val_succ, mul_one, fintype.univ_of_subsingleton,
        fin.mk_zero, matrix.cons_val_fin_one, neg_smul,
        prod.neg_mk, neg_add_rev, neg_zero, finset.sum_const, finset.card_singleton,
        nsmul_eq_mul, mul_neg, smul_add, smul_zero, prod.mk_add_mk, zero_add,
        add_neg_cancel_left, add_zero, add_right_neg, prod.mk_eq_zero, eq_self_iff_true,
        and_true, true_and, ne.def],
      simp only [nat.cast_zero, zero_add, one_mul, prod.mk_add_mk, add_neg_cancel_left,
        add_right_neg, prod.mk_eq_zero, eq_self_iff_true, and_true, true_and],
      ring },
    { use 0, norm_num } },
end

/-!

Now we use the symmetry of the situation.

-/

omit C

variable (F)

@[simps]
def negate_snd_equiv : (F × F × F) ≃ₗ[F] (F × F × F) :=
{ to_fun := λ a, ⟨a.1, -a.2.1, a.2.2⟩,
  map_add' := by { intros x y, ext; simp; ring },
  map_smul' := by { intros r x, ext; dsimp; simp; ring },
  inv_fun := λ a, ⟨a.1, -a.2.1, a.2.2⟩,
  left_inv := by { intros x, ext; simp },
  right_inv := by { intros x, ext; simp } }

@[simp]
lemma negate_snd_equiv_negate_snd_equiv_apply (x : F × F × F) :
  negate_snd_equiv F (negate_snd_equiv F x) = x :=
begin
  cases x, dsimp, simp,
end

@[simp]
lemma negate_snd_equiv_comp_negate_snd_equiv :
  (negate_snd_equiv F).to_linear_map.comp (negate_snd_equiv F).to_linear_map = linear_map.id :=
by { apply fun_like.ext, dsimp, simp }

variable {F}
include C

def negate_snd : setup (map (negate_snd_equiv F).to_linear_map (negate_snd_equiv F).injective ∘ φ)
  (-2 - x) y :=
{ map_zero := begin
    dsimp,
    rw [C.map_zero, map_mk_eq_mk],
    dsimp, simp only [neg_zero],
  end,
  map_one := begin
    dsimp,
    rw [C.map_one, map_mk_eq_mk],
    dsimp, simp only [neg_zero],
  end,
  map_x := begin
    dsimp,
    rw [(show -2 - x = -(2+x), by ring), C.map_neg, C.map_two_add_x, map_mk_eq_mk],
    dsimp, simp only [neg_neg],
  end,
  map_y := begin
    dsimp,
    rw [C.map_y, map_mk_eq_mk],
    dsimp, simp only [neg_zero],
  end,
  map_one_add_x := begin
    dsimp,
    rw [(show 1 + (-2 - x) = -(1 + x), by ring), C.map_neg, C.map_one_add_x, map_mk_eq_mk],
    dsimp, rw mk_eq_mk_iff, use (-1), norm_num,
  end,
  map_one_add_y := begin
    dsimp, rw [C.map_one_add_y, map_mk_eq_mk],
    dsimp, simp only [neg_zero],
  end,
  map_neg := begin
    intros u, dsimp, rw [C.map_neg],
  end,
  dependent_pos := begin
    intros u v,
    rw ← dependent_iff_dependent₃, apply C.dependent_pos,
  end,
  dependent_neg := begin
    intros u v,
    rw ← dependent_iff_dependent₃, apply C.dependent_neg,
  end }

theorem main_theorem (m : ℤ) (n : ℕ) (h : ((n : F), (m : F), (0 : F)) ≠ 0) :
  ∃ (t : K), φ t = projectivization.mk F ((n : F), (m : F), 0) h :=
begin
  induction m,
  { cases m,
    { have H : ((n : F), (0 : F), (0 : F)) ≠ 0, by simpa using h,
      simp only [nat.nat_zero_eq_zero, int.of_nat_eq_coe, int.coe_nat_zero, int.cast_zero],
      use 1, symmetry, rw [C.map_one, mk_eq_mk_iff],
      simp only [ne.def, prod.mk_eq_zero, eq_self_iff_true, and_true] at H,
      use (is_unit.mk0 _ H).unit, simp [units.smul_def] },
    simp only [int.of_nat_eq_coe, int.coe_nat_succ, int.cast_add, int.cast_coe_nat, int.cast_one],
    by_cases hn : (n : F) = 0,
    { use 1 + x,
      have H : (m : F) + 1 ≠ 0, by simpa [hn] using h,
      simp only [hn], rw C.map_one_add_x, symmetry, rw mk_eq_mk_iff,
      use (is_unit.mk0 ((m : F) + 1) H).unit, simp [units.smul_def] },
    { have := (C.map_to_frac_horizontal n (m + 1) hn (by norm_num)).2,
      push_cast at this,
      refine ⟨_, this⟩ } },
  { let H := h, --push_cast at H,
    by_cases hn : (n : F) = 0,
    { simp only [hn, int.cast_neg_succ_of_nat, neg_add_rev, ne.def, prod.mk_eq_zero,
        eq_self_iff_true, and_true, true_and] at H ⊢,
      use 1 + x,
      symmetry, rw [C.map_one_add_x, mk_eq_mk_iff],
      use (is_unit.mk0 _ H).unit, simp [units.smul_def] },
    { have := (C.negate_snd.map_to_frac_horizontal n (m + 1) hn (by norm_num)).2,
      push_cast at this ⊢,
      let E := negate_snd_equiv F,
      apply_fun (map E.to_linear_map E.injective) at this,
      dsimp [map_mk_eq_mk] at this,
      change ((map E.to_linear_map E.injective) ∘ (map E.to_linear_map E.injective)) _ = _ at this,
      rw ← map_comp at this,
      conv_lhs at this
      { congr, erw negate_snd_equiv_comp_negate_snd_equiv },
      erw map_id at this, dsimp [id] at this,
      refine ⟨_, by exact_mod_cast this⟩, } }
end

--lemma map_to_frac_horizontal (n m : ℕ) (hn : (n : F) ≠ 0) (hm : m ≠ 0) :
--  (φ ((1 + m - n) + m * x + y) = mk[F] (n,m,1)) ∧
theorem main_theorem_char (m : ℕ) (hm : m ≠ 0) :
  (φ ((m-1) + m * x) = mk[F] (1,m,0)) :=
by convert (map_to_frac_horizontal C 1 m _ hm).2; norm_num

end setup


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
namespace Std
universe u v w w'

namespace PersistentHashMap

inductive Entry (α : Type u) (β : Type v) (σ : Type w) where
  | entry (key : α) (val : β) : Entry α β σ
  | ref   (node : σ) : Entry α β σ
  | null  : Entry α β σ

instance {α β σ} : Inhabited (Entry α β σ) := ⟨Entry.null⟩

inductive Node (α : Type u) (β : Type v) : Type (max u v) where
  | entries   (es : Array (Entry α β (Node α β))) : Node α β
  | collision (ks : Array α) (vs : Array β) (h : ks.size = vs.size) : Node α β

instance {α β} : Inhabited (Node α β) := ⟨Node.entries #[]⟩

abbrev shift         : USize  := 5
abbrev branching     : USize  := USize.ofNat (2 ^ shift.toNat)
abbrev maxDepth      : USize  := 7
abbrev maxCollisions : Nat    := 4

def mkEmptyEntriesArray {α β} : Array (Entry α β (Node α β)) :=
  (Array.mkArray PersistentHashMap.branching.toNat PersistentHashMap.Entry.null)

end PersistentHashMap

structure PersistentHashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] where
  root    : PersistentHashMap.Node α β := PersistentHashMap.Node.entries PersistentHashMap.mkEmptyEntriesArray
  size    : Nat                        := 0

abbrev PHashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] := PersistentHashMap α β

namespace PersistentHashMap
variable {α : Type u} {β : Type v}

def empty [BEq α] [Hashable α] : PersistentHashMap α β := {}

def isEmpty [BEq α] [Hashable α] (m : PersistentHashMap α β) : Bool :=
  m.size == 0

instance [BEq α] [Hashable α] : Inhabited (PersistentHashMap α β) := ⟨{}⟩

def mkEmptyEntries {α β} : Node α β :=
  Node.entries mkEmptyEntriesArray

abbrev mul2Shift (i : USize) (shift : USize) : USize := i.shiftLeft shift
abbrev div2Shift (i : USize) (shift : USize) : USize := i.shiftRight shift
abbrev mod2Shift (i : USize) (shift : USize) : USize := USize.land i ((USize.shiftLeft 1 shift) - 1)

inductive IsCollisionNode : Node α β → Prop where
  | mk (keys : Array α) (vals : Array β) (h : keys.size = vals.size) : IsCollisionNode (Node.collision keys vals h)

abbrev CollisionNode (α β) := { n : Node α β // IsCollisionNode n }

inductive IsEntriesNode : Node α β → Prop where
  | mk (entries : Array (Entry α β (Node α β))) : IsEntriesNode (Node.entries entries)

abbrev EntriesNode (α β) := { n : Node α β // IsEntriesNode n }

private theorem size_set {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (i : Fin ks.size) (j : Fin vs.size) (k : α) (v : β)
                           : (ks.set i k).size = (vs.set j v).size := by
  simp [h]

private theorem size_push {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (k : α) (v : β) : (ks.push k).size = (vs.push v).size := by
  simp [h]

partial def insertAtCollisionNodeAux [BEq α] : CollisionNode α β → Nat → α → β → CollisionNode α β
  | n@⟨Node.collision keys vals heq, _⟩, i, k, v =>
    if h : i < keys.size then
      let idx : Fin keys.size := ⟨i, h⟩;
      let k' := keys.get idx;
      if k == k' then
         let j : Fin vals.size := ⟨i, by rw [←heq]; assumption⟩
         ⟨Node.collision (keys.set idx k) (vals.set j v) (size_set heq idx j k v), IsCollisionNode.mk _ _ _⟩
      else insertAtCollisionNodeAux n (i+1) k v
    else
      ⟨Node.collision (keys.push k) (vals.push v) (size_push heq k v), IsCollisionNode.mk _ _ _⟩
  | ⟨Node.entries _, h⟩, _, _, _ => False.elim (nomatch h)

def insertAtCollisionNode [BEq α] : CollisionNode α β → α → β → CollisionNode α β :=
  fun n k v => insertAtCollisionNodeAux n 0 k v

def getCollisionNodeSize : CollisionNode α β → Nat
  | ⟨Node.collision keys _ _, _⟩ => keys.size
  | ⟨Node.entries _, h⟩          => False.elim (nomatch h)

def mkCollisionNode (k₁ : α) (v₁ : β) (k₂ : α) (v₂ : β) : Node α β :=
  let ks : Array α := Array.mkEmpty maxCollisions
  let ks := (ks.push k₁).push k₂
  let vs : Array β := Array.mkEmpty maxCollisions
  let vs := (vs.push v₁).push v₂
  Node.collision ks vs rfl

partial def insertAux [BEq α] [Hashable α] : Node α β → USize → USize → α → β → Node α β
  | Node.collision keys vals heq, _, depth, k, v =>
    let newNode := insertAtCollisionNode ⟨Node.collision keys vals heq, IsCollisionNode.mk _ _ _⟩ k v
    if depth >= maxDepth || getCollisionNodeSize newNode < maxCollisions then newNode.val
    else match newNode with
      | ⟨Node.entries _, h⟩ => False.elim (nomatch h)
      | ⟨Node.collision keys vals heq, _⟩ =>
        let rec traverse (i : Nat) (entries : Node α β) : Node α β :=
          if h : i < keys.size then
            let k := keys.get ⟨i, h⟩
            let v := vals.get ⟨i, heq ▸ h⟩
            let h := hash k |>.toUSize
            let h := div2Shift h (shift * (depth - 1))
            traverse (i+1) (insertAux entries h depth k v)
          else
            entries
        traverse 0 mkEmptyEntries
  | Node.entries entries, h, depth, k, v =>
    let j     := (mod2Shift h shift).toNat
    Node.entries $ entries.modify j fun entry =>
      match entry with
      | Entry.null        => Entry.entry k v
      | Entry.ref node    => Entry.ref $ insertAux node (div2Shift h shift) (depth+1) k v
      | Entry.entry k' v' =>
        if k == k' then Entry.entry k v
        else Entry.ref $ mkCollisionNode k' v' k v

def insert [BEq α] [Hashable α] : PersistentHashMap α β → α → β → PersistentHashMap α β
  | { root := n, size := sz }, k, v => { root := insertAux n (hash k |>.toUSize) 1 k v, size := sz + 1 }

partial def findAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) : Option β :=
  if h : i < keys.size then
    let k' := keys.get ⟨i, h⟩
    if k == k' then some (vals.get ⟨i, by rw [←heq]; assumption⟩)
    else findAtAux keys vals heq (i+1) k
  else none

partial def findAux [BEq α] : Node α β → USize → α → Option β
  | Node.entries entries, h, k =>
    let j     := (mod2Shift h shift).toNat
    match entries.get! j with
    | Entry.null       => none
    | Entry.ref node   => findAux node (div2Shift h shift) k
    | Entry.entry k' v => if k == k' then some v else none
  | Node.collision keys vals heq, _, k => findAtAux keys vals heq 0 k

def find? [BEq α] [Hashable α] : PersistentHashMap α β → α → Option β
  | { root := n, .. }, k => findAux n (hash k |>.toUSize) k

@[inline] def getOp [BEq α] [Hashable α] (self : PersistentHashMap α β) (idx : α) : Option β :=
  self.find? idx

@[inline] def findD [BEq α] [Hashable α] (m : PersistentHashMap α β) (a : α) (b₀ : β) : β :=
  (m.find? a).getD b₀

@[inline] def find! [BEq α] [Hashable α] [Inhabited β] (m : PersistentHashMap α β) (a : α) : β :=
  match m.find? a with
  | some b => b
  | none   => panic! "key is not in the map"

partial def findEntryAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) : Option (α × β) :=
  if h : i < keys.size then
    let k' := keys.get ⟨i, h⟩
    if k == k' then some (k', vals.get ⟨i, by rw [←heq]; assumption⟩)
    else findEntryAtAux keys vals heq (i+1) k
  else none

partial def findEntryAux [BEq α] : Node α β → USize → α → Option (α × β)
  | Node.entries entries, h, k =>
    let j     := (mod2Shift h shift).toNat
    match entries.get! j with
    | Entry.null       => none
    | Entry.ref node   => findEntryAux node (div2Shift h shift) k
    | Entry.entry k' v => if k == k' then some (k', v) else none
  | Node.collision keys vals heq, _, k => findEntryAtAux keys vals heq 0 k

def findEntry? [BEq α] [Hashable α] : PersistentHashMap α β → α → Option (α × β)
  | { root := n, .. }, k => findEntryAux n (hash k |>.toUSize) k

partial def containsAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) : Bool :=
  if h : i < keys.size then
    let k' := keys.get ⟨i, h⟩
    if k == k' then true
    else containsAtAux keys vals heq (i+1) k
  else false

partial def containsAux [BEq α] : Node α β → USize → α → Bool
  | Node.entries entries, h, k =>
    let j     := (mod2Shift h shift).toNat
    match entries.get! j with
    | Entry.null       => false
    | Entry.ref node   => containsAux node (div2Shift h shift) k
    | Entry.entry k' v => k == k'
  | Node.collision keys vals heq, _, k => containsAtAux keys vals heq 0 k

def contains [BEq α] [Hashable α] : PersistentHashMap α β → α → Bool
  | { root := n, .. }, k => containsAux n (hash k |>.toUSize) k

partial def isUnaryEntries (a : Array (Entry α β (Node α β))) (i : Nat) (acc : Option (α × β)) : Option (α × β) :=
  if h : i < a.size then
    match a.get ⟨i, h⟩ with
    | Entry.null      => isUnaryEntries a (i+1) acc
    | Entry.ref _     => none
    | Entry.entry k v =>
      match acc with
      | none   => isUnaryEntries a (i+1) (some (k, v))
      | some _ => none
  else acc

def isUnaryNode : Node α β → Option (α × β)
  | Node.entries entries         => isUnaryEntries entries 0 none
  | Node.collision keys vals heq =>
    if h : 1 = keys.size then
      have : 0 < keys.size := by rw [←h]; decide
      some (keys.get ⟨0, this⟩, vals.get ⟨0, by rw [←heq]; assumption⟩)
    else
      none

partial def eraseAux [BEq α] : Node α β → USize → α → Node α β × Bool
  | n@(Node.collision keys vals heq), _, k =>
    match keys.indexOf? k with
    | some idx =>
      let ⟨keys', keq⟩ := keys.eraseIdx' idx
      let ⟨vals', veq⟩ := vals.eraseIdx' (Eq.ndrec idx heq)
      have : keys.size - 1 = vals.size - 1 := by rw [heq]
      (Node.collision keys' vals' (keq.trans (this.trans veq.symm)), true)
    | none     => (n, false)
  | n@(Node.entries entries), h, k =>
    let j       := (mod2Shift h shift).toNat
    let entry   := entries.get! j
    match entry with
    | Entry.null       => (n, false)
    | Entry.entry k' v =>
      if k == k' then (Node.entries (entries.set! j Entry.null), true) else (n, false)
    | Entry.ref node   =>
      let entries := entries.set! j Entry.null
      let (newNode, deleted) := eraseAux node (div2Shift h shift) k
      if !deleted then (n, false)
      else match isUnaryNode newNode with
        | none        => (Node.entries (entries.set! j (Entry.ref newNode)), true)
        | some (k, v) => (Node.entries (entries.set! j (Entry.entry k v)), true)

def erase [BEq α] [Hashable α] : PersistentHashMap α β → α → PersistentHashMap α β
  | { root := n, size := sz }, k =>
    let h := hash k |>.toUSize
    let (n, del) := eraseAux n h k
    { root := n, size := if del then sz - 1 else sz }

section
variable {m : Type w → Type w'} [Monad m]
variable {σ : Type w}

@[specialize] partial def foldlMAux (f : σ → α → β → m σ) : Node α β → σ → m σ
  | Node.collision keys vals heq, acc =>
    let rec traverse (i : Nat) (acc : σ) : m σ := do
      if h : i < keys.size then
        let k := keys.get ⟨i, h⟩
        let v := vals.get ⟨i, heq ▸ h⟩
        traverse (i+1) (← f acc k v)
      else
        pure acc
    traverse 0 acc
  | Node.entries entries, acc => entries.foldlM (fun acc entry =>
    match entry with
    | Entry.null      => pure acc
    | Entry.entry k v => f acc k v
    | Entry.ref node  => foldlMAux f node acc)
    acc

@[specialize] def foldlM [BEq α] [Hashable α] (map : PersistentHashMap α β) (f : σ → α → β → m σ) (init : σ) : m σ :=
  foldlMAux f map.root init

@[specialize] def forM [BEq α] [Hashable α] (map : PersistentHashMap α β) (f : α → β → m PUnit) : m PUnit :=
  map.foldlM (fun _ => f) ⟨⟩

@[specialize] def foldl [BEq α] [Hashable α] (map : PersistentHashMap α β) (f : σ → α → β → σ) (init : σ) : σ :=
  Id.run $ map.foldlM f init
end

def toList [BEq α] [Hashable α] (m : PersistentHashMap α β) : List (α × β) :=
  m.foldl (init := []) fun ps k v => (k, v) :: ps

structure Stats where
  numNodes      : Nat := 0
  numNull       : Nat := 0
  numCollisions : Nat := 0
  maxDepth      : Nat := 0

partial def collectStats : Node α β → Stats → Nat → Stats
  | Node.collision keys _ _, stats, depth =>
    { stats with
      numNodes      := stats.numNodes + 1,
      numCollisions := stats.numCollisions + keys.size - 1,
      maxDepth      := Nat.max stats.maxDepth depth }
  | Node.entries entries, stats, depth =>
    let stats :=
      { stats with
        numNodes      := stats.numNodes + 1,
        maxDepth      := Nat.max stats.maxDepth depth }
    entries.foldl (fun stats entry =>
      match entry with
      | Entry.null      => { stats with numNull := stats.numNull + 1 }
      | Entry.ref node  => collectStats node stats (depth + 1)
      | Entry.entry _ _ => stats)
      stats

def stats [BEq α] [Hashable α] (m : PersistentHashMap α β) : Stats :=
  collectStats m.root {} 1

def Stats.toString (s : Stats) : String :=
  s!"\{ nodes := {s.numNodes}, null := {s.numNull}, collisions := {s.numCollisions}, depth := {s.maxDepth}}"

instance : ToString Stats := ⟨Stats.toString⟩

end PersistentHashMap
end Std


import logic.funrel
import logic.finite
import logic.idecidable
import .basic .bool .decfree

namespace binary_module

local attribute [instance] binary_abelian

--- Type for matrices whose entries are indexed in subtypes of `finord`. This is defined so that `matrix p q` is isomorphic to the type of homomorphisms from the free `binary_module` generated by `subtype q` to that by `subtype p`.
definition submatrix {m n : ℕ} (p : finord m → Prop) (q : finord n → Prop) : Type _ :=
  {a : finord m → subtype q → bool // ∀ i y, a i y ≠ 0 → p i}

namespace submatrix

variables {m n : ℕ} {p : finord m → Prop} {q : finord n → Prop}

--- In each column, 'non-zero' is a decidable condition.
instance col_decidable_neq_zero (a : submatrix p q) (y : subtype q) : decidable_pred (λ i, p i ∧ a.val i y ≠ 0) :=
  begin
    intros i; dsimp *,
    cases bool.decidable_eq (a.val i y) 0 with haiy haiy,
    case is_false {
      exact is_true ⟨a.property _ _ haiy, haiy⟩,
    },
    case is_true {
      apply is_false,
      intros h,
      exact h.right haiy
    }
  end

--- The 'support' of each column; i.e. the `exhaustive_list` of non-zero entries.
definition col_support (a : submatrix p q) (y : subtype q) : exhaustive_list {x : subtype p // a.val x.val y ≠ 0} :=
  exhaustive_list.translate
    (@bijection.subtype_uncurry _ p (λ i, a.val i y ≠ 0)).inv_is_bijective
    ((finord.exhaustive_list m).restrict (λ i, p i ∧ a.val i y ≠ 0))

--- In each column of `submatrix`, only finitely many entries are non-zero.
lemma col_finite (a : submatrix p q) (y : subtype q) : is_finite {x : subtype p // a.val x.val y ≠ 0} :=
  is_finite.of_exhaustive_list (a.col_support y)

--- Realize matrices as maps into free modules generated by the row indices (aka. Kleisli arrows).
definition to_fun (a : submatrix p q) : subtype q → finsupp_bits (subtype p) :=
  λ y, subtype.mk (λ (x : subtype p), a.val x.val y) $ a.col_finite y

--- For every term `finsupp_bits (subtype p)`, its support is internally-decidable in the super type.
lemma support_idec {α : Type _} (f : α → finsupp_bits (subtype p)) (a : α): ∀ (i : finord m), idecidable (∃ (h : p i), (f a).val ⟨i,h⟩ ≠ 0) :=
  λ i, @is_finite.idec_in_super _ _ p (λ x, (f a).val x ≠ 0) (f a).property i

namespace unsafe

--- Representation matrix
noncomputable definition mk_mat (f : subtype q → finsupp_bits (subtype p)) : submatrix p q :=
{
  val := λ i y,
    decidable.cases_on
      (@unsafe.decidable_of_idecidable _ (support_idec f y i))
      (λ _, ff) (λ _, tt),
  property :=
    begin
      intros i y h,
      cases @whether _ (support_idec f y i) with hpi hnpi,
      case or.inl { cases hpi with hpi _, exact hpi },
      case or.inr {
        rw [@unsafe.dec_of_idec_neg _ (support_idec f y i) hnpi] at h,
        dsimp * at h,
        exfalso; exact h rfl
      }
    end
}

--- The representation matrix of a function defined from a matrix is exactly the original one.
lemma mat_of_to_fun (a : submatrix p q) : mk_mat a.to_fun = a :=
  begin
    apply subtype.eq,
    dsimp [mk_mat],
    funext,
    cases @whether _ (support_idec a.to_fun y i) with hpi hnpi,
    case or.inl {
      rw [@unsafe.dec_of_idec_pos _ (support_idec _ _ _) hpi],
      dsimp *,
      symmetry,
      cases hpi with hpi hai,
      dsimp [to_fun] at hai,
      exact (neq_ff_iff _).mp hai,
    },
    case or.inr {
      rw [@unsafe.dec_of_idec_neg _ (support_idec _ _ _) hnpi],
      dsimp *,
      symmetry,
      dsimp [to_fun] at hnpi,
      cases haiy: a.val i y,
      case ff { refl },
      case tt {
        exfalso; apply hnpi; clear hnpi,
        existsi a.property i y ((neq_ff_iff _).mpr haiy),
        rw [haiy],
        intro h; injection h,
      }
    }
  end

--- The function defined from a representation matrix is exactly the original one.
lemma to_fun_of_mat (f : subtype q → finsupp_bits (subtype p)) : (mk_mat f).to_fun = f :=
  begin
    funext y,
    apply subtype.eq,
    funext x,
    dsimp [mk_mat, to_fun],
    cases @whether _ (support_idec f y x.val) with hp hnp,
    case or.inl {
      rw [@unsafe.dec_of_idec_pos _ (support_idec _ _ _) hp],
      dsimp *,
      symmetry,
      cases hp with hpx hfy,
      rw [subtype.eta x hpx] at hfy,
      exact (neq_ff_iff _).mp hfy
    },
    case or.inr {
      rw [@unsafe.dec_of_idec_neg _ (support_idec _ _ _) hnp],
      dsimp *,
      symmetry,
      cases hfy: (f y).val x,
      case ff { refl },
      case tt {
        exfalso; apply hnp; clear hnp,
        existsi x.property,
        rw [subtype.eta x x.property],
        exact (neq_ff_iff _).mpr hfy,
      }
    }
  end

end unsafe

end submatrix

end binary_module